libguile/srcprop.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009, 2010, 2011 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 #include "libguile/private-options.h"
  42
  43 \f
  44 /* {Source Properties}
  45  *
  46  * Properties of source list expressions.
  47  * Four of these have special meaning:
  48  *
  49  * filename    string   The name of the source file.
  50  * copy        list     A copy of the list expression.
  51  * line        integer  The source code line number.
  52  * column      integer  The source code column number.
  53  *
  54  * Most properties above can be set by the reader.
  55  *
  56  */
  57
  58 SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename");
  59 SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
  60 SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
  61 SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
  62
  63 static SCM scm_source_whash;
  64 static scm_i_pthread_mutex_t source_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  65
  66
  67 /*
  68  *  Source properties are stored as double cells with the
  69  *  following layout:
  70
  71  * car = tag
  72  * cbr = pos
  73  * ccr = copy
  74  * cdr = alist
  75  */
  76
  77 #define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
  78 #define SRCPROPPOS(p) (SCM_SMOB_DATA(p))
  79 #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
  80 #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
  81 #define SRCPROPCOPY(p) (SCM_SMOB_OBJECT_2(p))
  82 #define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3(p))
  83 #define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
  84 #define SETSRCPROPPOS(p, l, c) (SCM_SET_SMOB_DATA_1 (p, SRCPROPMAKPOS (l, c)))
  85 #define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
  86 #define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
  87 #define SETSRCPROPCOPY(p, c) (SCM_SET_SMOB_OBJECT_2 (p, c))
  88 #define SETSRCPROPALIST(p, l) (SCM_SET_SMOB_OBJECT_3 (p, l))
  89
  90
  91 static SCM scm_srcprops_to_alist (SCM obj);
  92
  93
  94 scm_t_bits scm_tc16_srcprops;
  95
  96 static int
  97 srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
  98 {
  99   int writingp = SCM_WRITINGP (pstate);
 100   scm_puts ("#<srcprops ", port);
 101   SCM_SET_WRITINGP (pstate, 1);
 102   scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate);
 103   SCM_SET_WRITINGP (pstate, writingp);
 104   scm_putc ('>', port);
 105   return 1;
 106 }
 107
 108
 109 /*
 110  * We remember the last file name settings, so we can share that alist
 111  * entry.  This works because scm_set_source_property_x does not use
 112  * assoc-set! for modifying the alist.
 113  *
 114  * This variable contains a protected cons, whose cdr is the cached
 115  * alist
 116  */
 117 static SCM scm_last_alist_filename;
 118
 119 SCM
 120 scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
 121 {
 122   if (!SCM_UNBNDP (filename))
 123     {
 124       SCM old_alist = alist;
 125
 126       /*
 127         have to extract the acons, and operate on that, for
 128         thread safety.
 129        */
 130       SCM last_acons = SCM_CDR (scm_last_alist_filename);
 131       if (scm_is_null (old_alist)
 132           && scm_is_eq (SCM_CDAR (last_acons), filename))
 133         {
 134           alist = last_acons;
 135         }
 136       else
 137         {
 138           alist = scm_acons (scm_sym_filename, filename, alist);
 139           if (scm_is_null (old_alist))
 140             SCM_SETCDR (scm_last_alist_filename, alist);
 141         }
 142     }
 143
 144   SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
 145                        SRCPROPMAKPOS (line, col),
 146                        SCM_UNPACK (copy),
 147                        SCM_UNPACK (alist));
 148 }
 149
 150
 151 static SCM
 152 scm_srcprops_to_alist (SCM obj)
 153 {
 154   SCM alist = SRCPROPALIST (obj);
 155   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
 156     alist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), alist);
 157   alist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), alist);
 158   alist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), alist);
 159   return alist;
 160 }
 161
 162 SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
 163             (SCM obj),
 164             "Return the source property association list of @var{obj}.")
 165 #define FUNC_NAME s_scm_source_properties
 166 {
 167   SCM p;
 168   SCM_VALIDATE_NIM (1, obj);
 169
 170   scm_i_pthread_mutex_lock (&source_lock);
 171   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 172   scm_i_pthread_mutex_unlock (&source_lock);
 173
 174   if (SRCPROPSP (p))
 175     return scm_srcprops_to_alist (p);
 176   else
 177     /* list from set-source-properties!, or SCM_EOL for not found */
 178     return p;
 179 }
 180 #undef FUNC_NAME
 181
 182 /* Perhaps this procedure should look through an alist
 183    and try to make a srcprops-object...? */
 184 SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
 185             (SCM obj, SCM alist),
 186             "Install the association list @var{alist} as the source property\n"
 187             "list for @var{obj}.")
 188 #define FUNC_NAME s_scm_set_source_properties_x
 189 {
 190   SCM_VALIDATE_NIM (1, obj);
 191
 192   scm_i_pthread_mutex_lock (&source_lock);
 193   scm_hashq_set_x (scm_source_whash, obj, alist);
 194   scm_i_pthread_mutex_unlock (&source_lock);
 195
 196   return alist;
 197 }
 198 #undef FUNC_NAME
 199
 200 int
 201 scm_i_has_source_properties (SCM obj)
 202 #define FUNC_NAME "%set-source-properties"
 203 {
 204   int ret;
 205
 206   SCM_VALIDATE_NIM (1, obj);
 207
 208   scm_i_pthread_mutex_lock (&source_lock);
 209   ret = scm_is_true (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F));
 210   scm_i_pthread_mutex_unlock (&source_lock);
 211
 212   return ret;
 213 }
 214 #undef FUNC_NAME
 215
 216
 217 void
 218 scm_i_set_source_properties_x (SCM obj, long line, int col, SCM fname)
 219 #define FUNC_NAME "%set-source-properties"
 220 {
 221   SCM_VALIDATE_NIM (1, obj);
 222
 223   scm_i_pthread_mutex_lock (&source_lock);
 224   scm_hashq_set_x (scm_source_whash, obj,
 225                    scm_make_srcprops (line, col, fname,
 226                                       SCM_COPY_SOURCE_P
 227                                       ? scm_copy_tree (obj)
 228                                       : SCM_UNDEFINED,
 229                                       SCM_EOL));
 230   scm_i_pthread_mutex_unlock (&source_lock);
 231 }
 232 #undef FUNC_NAME
 233
 234 SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
 235             (SCM obj, SCM key),
 236             "Return the source property specified by @var{key} from\n"
 237             "@var{obj}'s source property list.")
 238 #define FUNC_NAME s_scm_source_property
 239 {
 240   SCM p;
 241   SCM_VALIDATE_NIM (1, obj);
 242
 243   scm_i_pthread_mutex_lock (&source_lock);
 244   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 245   scm_i_pthread_mutex_unlock (&source_lock);
 246
 247   if (!SRCPROPSP (p))
 248     goto alist;
 249   if (scm_is_eq (scm_sym_line, key))
 250     p = scm_from_int (SRCPROPLINE (p));
 251   else if (scm_is_eq (scm_sym_column, key))
 252     p = scm_from_int (SRCPROPCOL (p));
 253   else if (scm_is_eq (scm_sym_copy, key))
 254     p = SRCPROPCOPY (p);
 255   else
 256     {
 257       p = SRCPROPALIST (p);
 258     alist:
 259       p = scm_assoc (key, p);
 260       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
 261     }
 262   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 263 }
 264 #undef FUNC_NAME
 265
 266 SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
 267             (SCM obj, SCM key, SCM datum),
 268             "Set the source property of object @var{obj}, which is specified by\n"
 269             "@var{key} to @var{datum}.  Normally, the key will be a symbol.")
 270 #define FUNC_NAME s_scm_set_source_property_x
 271 {
 272   SCM p;
 273   SCM_VALIDATE_NIM (1, obj);
 274
 275   scm_i_pthread_mutex_lock (&source_lock);
 276   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 277
 278   if (scm_is_eq (scm_sym_line, key))
 279     {
 280       if (SRCPROPSP (p))
 281         SETSRCPROPLINE (p, scm_to_int (datum));
 282       else
 283         scm_hashq_set_x (scm_source_whash, obj,
 284                          scm_make_srcprops (scm_to_int (datum), 0,
 285                                             SCM_UNDEFINED, SCM_UNDEFINED, p));
 286     }
 287   else if (scm_is_eq (scm_sym_column, key))
 288     {
 289       if (SRCPROPSP (p))
 290         SETSRCPROPCOL (p, scm_to_int (datum));
 291       else
 292         scm_hashq_set_x (scm_source_whash, obj,
 293                          scm_make_srcprops (0, scm_to_int (datum),
 294                                             SCM_UNDEFINED, SCM_UNDEFINED, p));
 295     }
 296   else if (scm_is_eq (scm_sym_copy, key))
 297     {
 298       if (SRCPROPSP (p))
 299         SETSRCPROPCOPY (p, datum);
 300       else
 301         scm_hashq_set_x (scm_source_whash, obj,
 302                          scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
 303     }
 304   else
 305     {
 306       if (SRCPROPSP (p))
 307         SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
 308       else
 309         scm_hashq_set_x (scm_source_whash, obj,
 310                          scm_acons (key, datum, p));
 311     }
 312   scm_i_pthread_mutex_unlock (&source_lock);
 313
 314   return SCM_UNSPECIFIED;
 315 }
 316 #undef FUNC_NAME
 317
 318
 319 SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
 320             (SCM xorig, SCM x, SCM y),
 321             "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
 322             "Any source properties associated with @var{xorig} are also associated\n"
 323             "with the new pair.")
 324 #define FUNC_NAME s_scm_cons_source
 325 {
 326   SCM p, z;
 327   z = scm_cons (x, y);
 328   scm_i_pthread_mutex_lock (&source_lock);
 329   /* Copy source properties possibly associated with xorig. */
 330   p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
 331   if (scm_is_true (p))
 332     scm_hashq_set_x (scm_source_whash, z, p);
 333   scm_i_pthread_mutex_unlock (&source_lock);
 334   return z;
 335 }
 336 #undef FUNC_NAME
 337
 338
 339 void
 340 scm_init_srcprop ()
 341 {
 342   scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
 343   scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
 344
 345   scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
 346   scm_c_define ("source-whash", scm_source_whash);
 347
 348   scm_last_alist_filename = scm_cons (SCM_EOL,
 349                                       scm_acons (SCM_EOL, SCM_EOL, SCM_EOL));
 350
 351 #include "libguile/srcprop.x"
 352 }
 353
 354
 355 /*
 356   Local Variables:
 357   c-file-style: "gnu"
 358   End:
 359 */