libguile/srcprop.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008 Free Software Foundation
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include <errno.h>
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/async.h"
  29 #include "libguile/smob.h"
  30 #include "libguile/alist.h"
  31 #include "libguile/debug.h"
  32 #include "libguile/hashtab.h"
  33 #include "libguile/hash.h"
  34 #include "libguile/ports.h"
  35 #include "libguile/root.h"
  36 #include "libguile/weaks.h"
  37
  38 #include "libguile/validate.h"
  39 #include "libguile/srcprop.h"
  40 \f
  41 /* {Source Properties}
  42  *
  43  * Properties of source list expressions.
  44  * Five of these have special meaning:
  45  *
  46  * filename    string   The name of the source file.
  47  * copy        list     A copy of the list expression.
  48  * line        integer  The source code line number.
  49  * column      integer  The source code column number.
  50  * breakpoint  boolean  Sets a breakpoint on this form.
  51  *
  52  * Most properties above can be set by the reader.
  53  *
  54  */
  55
  56 SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename");
  57 SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
  58 SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
  59 SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
  60 SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
  61
  62
  63
  64 /*
  65  *  Source properties are stored as double cells with the
  66  *  following layout:
  67
  68  * car = tag
  69  * cbr = pos
  70  * ccr = copy
  71  * cdr = alist
  72  */
  73
  74 #define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
  75 #define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
  76 #define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
  77 #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
  78 #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
  79 #define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
  80 #define SRCPROPALIST(p) (SCM_CELL_OBJECT_3(p))
  81 #define SETSRCPROPBRK(p) \
  82  (SCM_SET_SMOB_FLAGS ((p), \
  83                       SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
  84 #define CLEARSRCPROPBRK(p)  \
  85  (SCM_SET_SMOB_FLAGS ((p), \
  86                       SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
  87 #define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
  88 #define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
  89 #define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
  90 #define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
  91 #define SETSRCPROPCOPY(p, c) (SCM_SET_CELL_WORD(p, 2, c))
  92 #define SETSRCPROPALIST(p, l) (SCM_SET_CELL_WORD(p, 3, l))
  93
  94
  95 static SCM scm_srcprops_to_alist (SCM obj);
  96
  97
  98 scm_t_bits scm_tc16_srcprops;
  99
 100 static SCM
 101 srcprops_mark (SCM obj)
 102 {
 103   scm_gc_mark (SRCPROPCOPY (obj));
 104   return SRCPROPALIST (obj);
 105 }
 106
 107 static int
 108 srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
 109 {
 110   int writingp = SCM_WRITINGP (pstate);
 111   scm_puts ("#<srcprops ", port);
 112   SCM_SET_WRITINGP (pstate, 1);
 113   scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate);
 114   SCM_SET_WRITINGP (pstate, writingp);
 115   scm_putc ('>', port);
 116   return 1;
 117 }
 118
 119
 120 int
 121 scm_c_source_property_breakpoint_p (SCM form)
 122 {
 123   SCM obj = scm_whash_lookup (scm_source_whash, form);
 124   return SRCPROPSP (obj) && SRCPROPBRK (obj);
 125 }
 126
 127
 128 /*
 129  * We remember the last file name settings, so we can share that alist
 130  * entry.  This works because scm_set_source_property_x does not use
 131  * assoc-set! for modifying the alist.
 132  *
 133  * This variable contains a protected cons, whose cdr is the cached
 134  * alist
 135  */
 136 static SCM scm_last_alist_filename;
 137
 138 SCM
 139 scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
 140 {
 141   if (!SCM_UNBNDP (filename))
 142     {
 143       SCM old_alist = alist;
 144
 145       /*
 146         have to extract the acons, and operate on that, for
 147         thread safety.
 148        */
 149       SCM last_acons = SCM_CDR (scm_last_alist_filename);
 150       if (old_alist == SCM_EOL
 151           && SCM_CDAR (last_acons) == filename)
 152         {
 153           alist = last_acons;
 154         }
 155       else
 156         {
 157           alist = scm_acons (scm_sym_filename, filename, alist);
 158           if (old_alist == SCM_EOL)
 159             SCM_SETCDR (scm_last_alist_filename, alist);
 160         }
 161     }
 162
 163   SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
 164                        SRCPROPMAKPOS (line, col),
 165                        copy,
 166                        alist);
 167 }
 168
 169
 170 static SCM
 171 scm_srcprops_to_alist (SCM obj)
 172 {
 173   SCM alist = SRCPROPALIST (obj);
 174   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
 175     alist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), alist);
 176   alist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), alist);
 177   alist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), alist);
 178   alist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), alist);
 179   return alist;
 180 }
 181
 182 SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
 183             (SCM obj),
 184             "Return the source property association list of @var{obj}.")
 185 #define FUNC_NAME s_scm_source_properties
 186 {
 187   SCM p;
 188   SCM_VALIDATE_NIM (1, obj);
 189   if (SCM_MEMOIZEDP (obj))
 190     obj = SCM_MEMOIZED_EXP (obj);
 191   else if (!scm_is_pair (obj))
 192     SCM_WRONG_TYPE_ARG (1, obj);
 193   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 194   if (SRCPROPSP (p))
 195     return scm_srcprops_to_alist (p);
 196   else
 197     /* list from set-source-properties!, or SCM_EOL for not found */
 198     return p;
 199 }
 200 #undef FUNC_NAME
 201
 202 /* Perhaps this procedure should look through an alist
 203    and try to make a srcprops-object...? */
 204 SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
 205             (SCM obj, SCM alist),
 206             "Install the association list @var{alist} as the source property\n"
 207             "list for @var{obj}.")
 208 #define FUNC_NAME s_scm_set_source_properties_x
 209 {
 210   SCM handle;
 211   long line = 0, col = 0;
 212   SCM fname = SCM_UNDEFINED, copy = SCM_UNDEFINED, breakpoint = SCM_BOOL_F;
 213   SCM others = SCM_EOL;
 214   SCM *others_cdrloc = &others;
 215   int need_srcprops = 0;
 216   SCM tail, key;
 217
 218   SCM_VALIDATE_NIM (1, obj);
 219   if (SCM_MEMOIZEDP (obj))
 220     obj = SCM_MEMOIZED_EXP (obj);
 221   else if (!scm_is_pair (obj))
 222     SCM_WRONG_TYPE_ARG(1, obj);
 223
 224   tail = alist;
 225   while (!scm_is_null (tail))
 226     {
 227       key = SCM_CAAR (tail);
 228       if (scm_is_eq (key, scm_sym_line))
 229         {
 230           line = scm_to_long (SCM_CDAR (tail));
 231           need_srcprops = 1;
 232         }
 233       else if (scm_is_eq (key, scm_sym_column))
 234         {
 235           col = scm_to_long (SCM_CDAR (tail));
 236           need_srcprops = 1;
 237         }
 238       else if (scm_is_eq (key, scm_sym_filename))
 239         {
 240           fname = SCM_CDAR (tail);
 241           need_srcprops = 1;
 242         }
 243       else if (scm_is_eq (key, scm_sym_copy))
 244         {
 245           copy = SCM_CDAR (tail);
 246           need_srcprops = 1;
 247         }
 248       else if (scm_is_eq (key, scm_sym_breakpoint))
 249         {
 250           breakpoint = SCM_CDAR (tail);
 251           need_srcprops = 1;
 252         }
 253       else
 254         {
 255           /* Do we allocate here, or clobber the caller's alist?
 256
 257              Source properties aren't supposed to be used for anything
 258              except the special properties above, so the mainline case
 259              is that we never execute this else branch, and hence it
 260              doesn't matter much.
 261
 262              We choose allocation here, as that seems safer.
 263           */
 264           *others_cdrloc = scm_cons (scm_cons (key, SCM_CDAR (tail)),
 265                                      SCM_EOL);
 266           others_cdrloc = SCM_CDRLOC (*others_cdrloc);
 267         }
 268       tail = SCM_CDR (tail);
 269     }
 270   if (need_srcprops)
 271     {
 272       alist = scm_make_srcprops (line, col, fname, copy, others);
 273       if (scm_is_true (breakpoint))
 274         SETSRCPROPBRK (alist);
 275     }
 276   else
 277     alist = others;
 278
 279   handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist);
 280   SCM_SETCDR (handle, alist);
 281   return alist;
 282 }
 283 #undef FUNC_NAME
 284
 285 SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
 286             (SCM obj, SCM key),
 287             "Return the source property specified by @var{key} from\n"
 288             "@var{obj}'s source property list.")
 289 #define FUNC_NAME s_scm_source_property
 290 {
 291   SCM p;
 292   SCM_VALIDATE_NIM (1, obj);
 293   if (SCM_MEMOIZEDP (obj))
 294     obj = SCM_MEMOIZED_EXP (obj);
 295   else if (!scm_is_pair (obj))
 296     SCM_WRONG_TYPE_ARG (1, obj);
 297   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 298   if (!SRCPROPSP (p))
 299     goto alist;
 300   if      (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p));
 301   else if (scm_is_eq (scm_sym_line,       key)) p = scm_from_int (SRCPROPLINE (p));
 302   else if (scm_is_eq (scm_sym_column,     key)) p = scm_from_int (SRCPROPCOL (p));
 303   else if (scm_is_eq (scm_sym_copy,       key)) p = SRCPROPCOPY (p);
 304   else
 305     {
 306       p = SRCPROPALIST (p);
 307     alist:
 308       p = scm_assoc (key, p);
 309       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
 310     }
 311   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 312 }
 313 #undef FUNC_NAME
 314
 315 SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
 316             (SCM obj, SCM key, SCM datum),
 317             "Set the source property of object @var{obj}, which is specified by\n"
 318             "@var{key} to @var{datum}.  Normally, the key will be a symbol.")
 319 #define FUNC_NAME s_scm_set_source_property_x
 320 {
 321   scm_whash_handle h;
 322   SCM p;
 323   SCM_VALIDATE_NIM (1, obj);
 324   if (SCM_MEMOIZEDP (obj))
 325     obj = SCM_MEMOIZED_EXP (obj);
 326   else if (!scm_is_pair (obj))
 327     SCM_WRONG_TYPE_ARG (1, obj);
 328   h = scm_whash_get_handle (scm_source_whash, obj);
 329   if (SCM_WHASHFOUNDP (h))
 330     p = SCM_WHASHREF (scm_source_whash, h);
 331   else
 332     {
 333       h = scm_whash_create_handle (scm_source_whash, obj);
 334       p = SCM_EOL;
 335     }
 336   if (scm_is_eq (scm_sym_breakpoint, key))
 337     {
 338       if (SRCPROPSP (p))
 339         {
 340           if (scm_is_false (datum))
 341             CLEARSRCPROPBRK (p);
 342           else
 343             SETSRCPROPBRK (p);
 344         }
 345       else
 346         {
 347           SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p);
 348           SCM_WHASHSET (scm_source_whash, h, sp);
 349           if (scm_is_false (datum))
 350             CLEARSRCPROPBRK (sp);
 351           else
 352             SETSRCPROPBRK (sp);
 353         }
 354     }
 355   else if (scm_is_eq (scm_sym_line, key))
 356     {
 357       if (SRCPROPSP (p))
 358         SETSRCPROPLINE (p, scm_to_int (datum));
 359       else
 360         SCM_WHASHSET (scm_source_whash, h,
 361                       scm_make_srcprops (scm_to_int (datum), 0,
 362                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 363     }
 364   else if (scm_is_eq (scm_sym_column, key))
 365     {
 366       if (SRCPROPSP (p))
 367         SETSRCPROPCOL (p, scm_to_int (datum));
 368       else
 369         SCM_WHASHSET (scm_source_whash, h,
 370                       scm_make_srcprops (0, scm_to_int (datum),
 371                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 372     }
 373   else if (scm_is_eq (scm_sym_copy, key))
 374     {
 375       if (SRCPROPSP (p))
 376         SETSRCPROPCOPY (p, datum);
 377       else
 378         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
 379     }
 380   else
 381     {
 382       if (SRCPROPSP (p))
 383         SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
 384       else
 385         SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
 386     }
 387   return SCM_UNSPECIFIED;
 388 }
 389 #undef FUNC_NAME
 390
 391
 392 void
 393 scm_init_srcprop ()
 394 {
 395   scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
 396   scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark);
 397   scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
 398
 399   scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
 400   scm_c_define ("source-whash", scm_source_whash);
 401
 402   scm_last_alist_filename
 403     = scm_permanent_object (scm_cons (SCM_EOL,
 404                                       scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
 405
 406 #include "libguile/srcprop.x"
 407 }
 408
 409
 410 /*
 411   Local Variables:
 412   c-file-style: "gnu"
 413   End:
 414 */