libguile/srcprop.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but 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 02110-1301 USA
  16  */
  17
  18
  19 \f
  20
  21 #include <errno.h>
  22
  23 #include "libguile/_scm.h"
  24 #include "libguile/async.h"
  25 #include "libguile/smob.h"
  26 #include "libguile/alist.h"
  27 #include "libguile/debug.h"
  28 #include "libguile/hashtab.h"
  29 #include "libguile/hash.h"
  30 #include "libguile/ports.h"
  31 #include "libguile/root.h"
  32 #include "libguile/weaks.h"
  33
  34 #include "libguile/validate.h"
  35 #include "libguile/srcprop.h"
  36 \f
  37 /* {Source Properties}
  38  *
  39  * Properties of source list expressions.
  40  * Five of these have special meaning and optimized storage:
  41  *
  42  * filename    string   The name of the source file.
  43  * copy        list     A copy of the list expression.
  44  * line        integer  The source code line number.
  45  * column      integer  The source code column number.
  46  * breakpoint  boolean  Sets a breakpoint on this form.
  47  *
  48  * Most properties above can be set by the reader.
  49  *
  50  */
  51
  52 SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename");
  53 SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
  54 SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
  55 SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
  56 SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
  57
  58 scm_t_bits scm_tc16_srcprops;
  59 static scm_t_srcprops_chunk *srcprops_chunklist = 0;
  60 static scm_t_srcprops *srcprops_freelist = 0;
  61
  62
  63 static SCM
  64 srcprops_mark (SCM obj)
  65 {
  66   scm_gc_mark (SRCPROPFNAME (obj));
  67   scm_gc_mark (SRCPROPCOPY (obj));
  68   return SRCPROPPLIST (obj);
  69 }
  70
  71
  72 static size_t
  73 srcprops_free (SCM obj)
  74 {
  75   *((scm_t_srcprops **) SCM_SMOB_DATA (obj)) = srcprops_freelist;
  76   srcprops_freelist = (scm_t_srcprops *) SCM_SMOB_DATA (obj);
  77   return 0; /* srcprops_chunks are not freed until leaving guile */
  78 }
  79
  80
  81 static int
  82 srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
  83 {
  84   int writingp = SCM_WRITINGP (pstate);
  85   scm_puts ("#<srcprops ", port);
  86   SCM_SET_WRITINGP (pstate, 1);
  87   scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
  88   SCM_SET_WRITINGP (pstate, writingp);
  89   scm_putc ('>', port);
  90   return 1;
  91 }
  92
  93
  94 int
  95 scm_c_source_property_breakpoint_p (SCM form)
  96 {
  97   SCM obj = scm_whash_lookup (scm_source_whash, form);
  98   return SRCPROPSP (obj) && SRCPROPBRK (obj);
  99 }
 100
 101
 102 SCM
 103 scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
 104 {
 105   register scm_t_srcprops *ptr;
 106   SCM_CRITICAL_SECTION_START;
 107   if ((ptr = srcprops_freelist) != NULL)
 108     srcprops_freelist = *(scm_t_srcprops **)ptr;
 109   else
 110     {
 111       size_t i;
 112       scm_t_srcprops_chunk *mem;
 113       size_t n = sizeof (scm_t_srcprops_chunk)
 114                     + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
 115       SCM_SYSCALL (mem = (scm_t_srcprops_chunk *) scm_malloc (n));
 116       if (mem == NULL)
 117         scm_memory_error ("srcprops");
 118       scm_gc_register_collectable_memory (mem, n, "srcprops");
 119
 120       mem->next = srcprops_chunklist;
 121       srcprops_chunklist = mem;
 122       ptr = &mem->srcprops[0];
 123       for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
 124         *(scm_t_srcprops **)&ptr[i] = &ptr[i + 1];
 125       *(scm_t_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
 126       srcprops_freelist = (scm_t_srcprops *) &ptr[1];
 127     }
 128   ptr->pos = SRCPROPMAKPOS (line, col);
 129   ptr->fname = filename;
 130   ptr->copy = copy;
 131   ptr->plist = plist;
 132   SCM_CRITICAL_SECTION_END;
 133   SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
 134 }
 135
 136
 137 SCM
 138 scm_srcprops_to_plist (SCM obj)
 139 {
 140   SCM plist = SRCPROPPLIST (obj);
 141   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
 142     plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
 143   if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
 144     plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist);
 145   plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist);
 146   plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist);
 147   plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist);
 148   return plist;
 149 }
 150
 151 SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
 152             (SCM obj),
 153             "Return the source property association list of @var{obj}.")
 154 #define FUNC_NAME s_scm_source_properties
 155 {
 156   SCM p;
 157   SCM_VALIDATE_NIM (1, obj);
 158   if (SCM_MEMOIZEDP (obj))
 159     obj = SCM_MEMOIZED_EXP (obj);
 160   else if (!scm_is_pair (obj))
 161     SCM_WRONG_TYPE_ARG (1, obj);
 162   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 163   if (SRCPROPSP (p))
 164     return scm_srcprops_to_plist (p);
 165   else
 166     /* list from set-source-properties!, or SCM_EOL for not found */
 167     return p;
 168 }
 169 #undef FUNC_NAME
 170
 171 /* Perhaps this procedure should look through an alist
 172    and try to make a srcprops-object...? */
 173 SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
 174             (SCM obj, SCM plist),
 175             "Install the association list @var{plist} as the source property\n"
 176             "list for @var{obj}.")
 177 #define FUNC_NAME s_scm_set_source_properties_x
 178 {
 179   SCM handle;
 180   SCM_VALIDATE_NIM (1, obj);
 181   if (SCM_MEMOIZEDP (obj))
 182     obj = SCM_MEMOIZED_EXP (obj);
 183   else if (!scm_is_pair (obj))
 184     SCM_WRONG_TYPE_ARG(1, obj);
 185   handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
 186   SCM_SETCDR (handle, plist);
 187   return plist;
 188 }
 189 #undef FUNC_NAME
 190
 191 SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
 192             (SCM obj, SCM key),
 193             "Return the source property specified by @var{key} from\n"
 194             "@var{obj}'s source property list.")
 195 #define FUNC_NAME s_scm_source_property
 196 {
 197   SCM p;
 198   SCM_VALIDATE_NIM (1, obj);
 199   if (SCM_MEMOIZEDP (obj))
 200     obj = SCM_MEMOIZED_EXP (obj);
 201   else if (!scm_is_pair (obj))
 202     SCM_WRONG_TYPE_ARG (1, obj);
 203   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 204   if (!SRCPROPSP (p))
 205     goto plist;
 206   if      (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p));
 207   else if (scm_is_eq (scm_sym_line,       key)) p = scm_from_int (SRCPROPLINE (p));
 208   else if (scm_is_eq (scm_sym_column,     key)) p = scm_from_int (SRCPROPCOL (p));
 209   else if (scm_is_eq (scm_sym_filename,   key)) p = SRCPROPFNAME (p);
 210   else if (scm_is_eq (scm_sym_copy,       key)) p = SRCPROPCOPY (p);
 211   else
 212     {
 213       p = SRCPROPPLIST (p);
 214     plist:
 215       p = scm_assoc (key, p);
 216       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
 217     }
 218   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 219 }
 220 #undef FUNC_NAME
 221
 222 SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
 223             (SCM obj, SCM key, SCM datum),
 224             "Set the source property of object @var{obj}, which is specified by\n"
 225             "@var{key} to @var{datum}.  Normally, the key will be a symbol.")
 226 #define FUNC_NAME s_scm_set_source_property_x
 227 {
 228   scm_whash_handle h;
 229   SCM p;
 230   SCM_VALIDATE_NIM (1, obj);
 231   if (SCM_MEMOIZEDP (obj))
 232     obj = SCM_MEMOIZED_EXP (obj);
 233   else if (!scm_is_pair (obj))
 234     SCM_WRONG_TYPE_ARG (1, obj);
 235   h = scm_whash_get_handle (scm_source_whash, obj);
 236   if (SCM_WHASHFOUNDP (h))
 237     p = SCM_WHASHREF (scm_source_whash, h);
 238   else
 239     {
 240       h = scm_whash_create_handle (scm_source_whash, obj);
 241       p = SCM_EOL;
 242     }
 243   if (scm_is_eq (scm_sym_breakpoint, key))
 244     {
 245       if (SRCPROPSP (p))
 246         {
 247           if (scm_is_false (datum))
 248             CLEARSRCPROPBRK (p);
 249           else
 250             SETSRCPROPBRK (p);
 251         }
 252       else
 253         {
 254           SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p);
 255           SCM_WHASHSET (scm_source_whash, h, sp);
 256           if (scm_is_false (datum))
 257             CLEARSRCPROPBRK (sp);
 258           else
 259             SETSRCPROPBRK (sp);
 260         }
 261     }
 262   else if (scm_is_eq (scm_sym_line, key))
 263     {
 264       if (SRCPROPSP (p))
 265         SETSRCPROPLINE (p, scm_to_int (datum));
 266       else
 267         SCM_WHASHSET (scm_source_whash, h,
 268                       scm_make_srcprops (scm_to_int (datum), 0,
 269                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 270     }
 271   else if (scm_is_eq (scm_sym_column, key))
 272     {
 273       if (SRCPROPSP (p))
 274         SETSRCPROPCOL (p, scm_to_int (datum));
 275       else
 276         SCM_WHASHSET (scm_source_whash, h,
 277                       scm_make_srcprops (0, scm_to_int (datum),
 278                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 279     }
 280   else if (scm_is_eq (scm_sym_filename, key))
 281     {
 282       if (SRCPROPSP (p))
 283         SRCPROPFNAME (p) = datum;
 284       else
 285         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
 286     }
 287   else if (scm_is_eq (scm_sym_copy, key))
 288     {
 289       if (SRCPROPSP (p))
 290         SRCPROPCOPY (p) = datum;
 291       else
 292         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
 293     }
 294   else
 295     {
 296       if (SRCPROPSP (p))
 297         SRCPROPPLIST (p) = scm_acons (key, datum, SRCPROPPLIST (p));
 298       else
 299         SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
 300     }
 301   return SCM_UNSPECIFIED;
 302 }
 303 #undef FUNC_NAME
 304
 305
 306 void
 307 scm_init_srcprop ()
 308 {
 309   scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
 310   scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark);
 311   scm_set_smob_free (scm_tc16_srcprops, srcprops_free);
 312   scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
 313
 314   scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
 315   scm_c_define ("source-whash", scm_source_whash);
 316
 317 #include "libguile/srcprop.x"
 318 }
 319
 320 void
 321 scm_finish_srcprop ()
 322 {
 323   register scm_t_srcprops_chunk *ptr = srcprops_chunklist, *next;
 324   size_t n= sizeof (scm_t_srcprops_chunk)
 325     + sizeof (scm_t_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
 326   while (ptr)
 327     {
 328       next = ptr->next;
 329       scm_gc_unregister_collectable_memory (ptr, n, "srcprops");
 330       free ((char *) ptr);
 331       ptr = next;
 332     }
 333 }
 334
 335 /*
 336   Local Variables:
 337   c-file-style: "gnu"
 338   End:
 339 */