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