libguile/srcprop.c

   1 /*      Copyright (C) 1995,1996,1997,1998 Free Software Foundation
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.
  41  *
  42  * The author can be reached at djurfeldt@nada.kth.se
  43  * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
  44 \f
  45
  46 #include <stdio.h>
  47 #include "_scm.h"
  48 #include "smob.h"
  49 #include "genio.h"
  50 #include "alist.h"
  51 #include "debug.h"
  52 #include "hashtab.h"
  53 #include "hash.h"
  54 #include "weaks.h"
  55
  56 #include "srcprop.h"
  57 \f
  58 /* {Source Properties}
  59  *
  60  * Properties of source list expressions.
  61  * Five of these have special meaning and optimized storage:
  62  *
  63  * filename    string   The name of the source file.
  64  * copy        list     A copy of the list expression.
  65  * line        integer  The source code line number.
  66  * column      integer  The source code column number.
  67  * breakpoint  boolean  Sets a breakpoint on this form.
  68  *
  69  * Most properties above can be set by the reader.
  70  *
  71  */
  72
  73 SCM scm_sym_filename;
  74 SCM scm_sym_copy;
  75 SCM scm_sym_line;
  76 SCM scm_sym_column;
  77 SCM scm_sym_breakpoint;
  78
  79 long scm_tc16_srcprops;
  80 static scm_srcprops_chunk *srcprops_chunklist = 0;
  81 static scm_srcprops *srcprops_freelist = 0;
  82
  83
  84 static SCM marksrcprops SCM_P ((SCM obj));
  85
  86 static SCM
  87 marksrcprops (obj)
  88      SCM obj;
  89 {
  90   scm_gc_mark (SRCPROPFNAME (obj));
  91   scm_gc_mark (SRCPROPCOPY (obj));
  92   return SRCPROPPLIST (obj);
  93 }
  94
  95
  96 static scm_sizet freesrcprops SCM_P ((SCM obj));
  97
  98 static scm_sizet
  99 freesrcprops (obj)
 100      SCM obj;
 101 {
 102   *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist;
 103   srcprops_freelist = (scm_srcprops *) SCM_CDR (obj);
 104   return 0; /* srcprops_chunks are not freed until leaving guile */
 105 }
 106
 107
 108 static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
 109
 110 static int
 111 prinsrcprops (obj, port, pstate)
 112      SCM obj;
 113      SCM port;
 114      scm_print_state *pstate;
 115 {
 116   int writingp = SCM_WRITINGP (pstate);
 117   scm_puts ("#<srcprops ", port);
 118   SCM_SET_WRITINGP (pstate, 1);
 119   scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
 120   SCM_SET_WRITINGP (pstate, writingp);
 121   scm_putc ('>', port);
 122   return 1;
 123 }
 124
 125
 126 SCM
 127 scm_make_srcprops (line, col, filename, copy, plist)
 128      int line;
 129      int col;
 130      SCM filename;
 131      SCM copy;
 132      SCM plist;
 133 {
 134   register scm_srcprops *ptr;
 135   SCM_DEFER_INTS;
 136   if ((ptr = srcprops_freelist) != NULL)
 137     srcprops_freelist = *(scm_srcprops **)ptr;
 138   else
 139     {
 140       int i;
 141       scm_srcprops_chunk *mem;
 142       scm_sizet n = sizeof (scm_srcprops_chunk)
 143                     + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
 144       SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n));
 145       SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops");
 146       scm_mallocated += n;
 147       mem->next = srcprops_chunklist;
 148       srcprops_chunklist = mem;
 149       ptr = &mem->srcprops[0];
 150       for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
 151         *(scm_srcprops **)&ptr[i] = &ptr[i + 1];
 152       *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
 153       srcprops_freelist = (scm_srcprops *) &ptr[1];
 154     }
 155   ptr->pos = SRCPROPMAKPOS (line, col);
 156   ptr->fname = filename;
 157   ptr->copy = copy;
 158   ptr->plist = plist;
 159   SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
 160 }
 161
 162
 163 SCM
 164 scm_srcprops_to_plist (obj)
 165      SCM obj;
 166 {
 167   SCM plist = SRCPROPPLIST (obj);
 168   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
 169     plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
 170   if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
 171     plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist);
 172   plist = scm_acons (scm_sym_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist);
 173   plist = scm_acons (scm_sym_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist);
 174   plist = scm_acons (scm_sym_breakpoint, SRCPROPBRK (obj), plist);
 175   return plist;
 176 }
 177
 178 SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties);
 179
 180 SCM
 181 scm_source_properties (obj)
 182      SCM obj;
 183 {
 184   SCM p;
 185   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties);
 186   if (SCM_MEMOIZEDP (obj))
 187     obj = SCM_MEMOIZED_EXP (obj);
 188 #ifndef SCM_RECKLESS
 189   else if (SCM_NCONSP (obj))
 190     scm_wrong_type_arg (s_source_properties, 1, obj);
 191 #endif
 192   p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL);
 193   if (p != (SCM) NULL && SRCPROPSP (p))
 194     return scm_srcprops_to_plist (p);
 195   return SCM_EOL;
 196 }
 197
 198 /* Perhaps this procedure should look through an alist
 199    and try to make a srcprops-object...? */
 200 SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x);
 201
 202 SCM
 203 scm_set_source_properties_x (obj, plist)
 204      SCM obj;
 205      SCM plist;
 206 {
 207   SCM handle;
 208   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x);
 209   if (SCM_MEMOIZEDP (obj))
 210     obj = SCM_MEMOIZED_EXP (obj);
 211 #ifndef SCM_RECKLESS
 212   else if (SCM_NCONSP (obj))
 213     scm_wrong_type_arg (s_set_source_properties_x, 1, obj);
 214 #endif
 215   handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
 216   SCM_SETCDR (handle, plist);
 217   return plist;
 218 }
 219
 220 SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property);
 221
 222 SCM
 223 scm_source_property (obj, key)
 224      SCM obj;
 225      SCM key;
 226 {
 227   SCM p;
 228   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property);
 229   if (SCM_MEMOIZEDP (obj))
 230     obj = SCM_MEMOIZED_EXP (obj);
 231 #ifndef SCM_RECKLESS
 232   else if (SCM_NECONSP (obj))
 233     scm_wrong_type_arg (s_source_property, 1, obj);
 234 #endif
 235   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 236   if (SCM_IMP (p) || !SRCPROPSP (p))
 237     goto plist;
 238   if      (scm_sym_breakpoint == key) p = SRCPROPBRK (p);
 239   else if (scm_sym_line       == key) p = SCM_MAKINUM (SRCPROPLINE (p));
 240   else if (scm_sym_column     == key) p = SCM_MAKINUM (SRCPROPCOL (p));
 241   else if (scm_sym_filename   == key) p = SRCPROPFNAME (p);
 242   else if (scm_sym_copy       == key) p = SRCPROPCOPY (p);
 243   else
 244     {
 245       p = SRCPROPPLIST (p);
 246     plist:
 247       p = scm_assoc (key, p);
 248       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
 249     }
 250   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 251 }
 252
 253 SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x);
 254
 255 SCM
 256 scm_set_source_property_x (obj, key, datum)
 257      SCM obj;
 258      SCM key;
 259      SCM datum;
 260 {
 261   scm_whash_handle h;
 262   SCM p;
 263   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x);
 264   if (SCM_MEMOIZEDP (obj))
 265     obj = SCM_MEMOIZED_EXP (obj);
 266 #ifndef SCM_RECKLESS
 267   else if (SCM_NCONSP (obj))
 268     scm_wrong_type_arg (s_set_source_property_x, 1, obj);
 269 #endif
 270   h = scm_whash_get_handle (scm_source_whash, obj);
 271   if (SCM_WHASHFOUNDP (h))
 272     p = SCM_WHASHREF (scm_source_whash, h);
 273   else
 274     {
 275       h = scm_whash_create_handle (scm_source_whash, obj);
 276       p = SCM_EOL;
 277     }
 278   if (scm_sym_breakpoint == key)
 279     {
 280       if (SCM_FALSEP (datum))
 281         CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
 282                          ? p
 283                          : SCM_WHASHSET (scm_source_whash, h,
 284                                          scm_make_srcprops (0,
 285                                                             0,
 286                                                             SCM_UNDEFINED,
 287                                                             SCM_UNDEFINED,
 288                                                             p)));
 289       else
 290         SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
 291                        ? p
 292                        : SCM_WHASHSET (scm_source_whash, h,
 293                                        scm_make_srcprops (0,
 294                                                           0,
 295                                                           SCM_UNDEFINED,
 296                                                           SCM_UNDEFINED,
 297                                                           p)));
 298     }
 299   else if (scm_sym_line == key)
 300     {
 301       SCM_ASSERT (SCM_INUMP (datum),
 302                   datum, SCM_ARG3, s_set_source_property_x);
 303       if (SCM_NIMP (p) && SRCPROPSP (p))
 304         SETSRCPROPLINE (p, SCM_INUM (datum));
 305       else
 306         SCM_WHASHSET (scm_source_whash, h,
 307                       scm_make_srcprops (SCM_INUM (datum), 0,
 308                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 309     }
 310   else if (scm_sym_column == key)
 311     {
 312       SCM_ASSERT (SCM_INUMP (datum),
 313                   datum, SCM_ARG3, s_set_source_property_x);
 314       if (SCM_NIMP (p) && SRCPROPSP (p))
 315         SETSRCPROPCOL (p, SCM_INUM (datum));
 316       else
 317         SCM_WHASHSET (scm_source_whash, h,
 318                       scm_make_srcprops (0, SCM_INUM (datum),
 319                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 320     }
 321   else if (scm_sym_filename == key)
 322     {
 323       if (SCM_NIMP (p) && SRCPROPSP (p))
 324         SRCPROPFNAME (p) = datum;
 325       else
 326         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
 327     }
 328   else if (scm_sym_filename == key)
 329     {
 330       if (SCM_NIMP (p) && SRCPROPSP (p))
 331         SRCPROPCOPY (p) = datum;
 332       else
 333         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
 334     }
 335   else
 336     SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
 337   return SCM_UNSPECIFIED;
 338 }
 339
 340
 341 void
 342 scm_init_srcprop ()
 343 {
 344   scm_tc16_srcprops = scm_make_smob_type_mfpe ("srcprops", 0,
 345                                          marksrcprops, freesrcprops, prinsrcprops, NULL);
 346   scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047));
 347
 348   scm_sym_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED));
 349   scm_sym_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED));
 350   scm_sym_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED));
 351   scm_sym_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED));
 352   scm_sym_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED));
 353
 354   scm_sysintern ("source-whash", scm_source_whash);
 355 #include "srcprop.x"
 356 }
 357
 358 void
 359 scm_finish_srcprop ()
 360 {
 361   register scm_srcprops_chunk *ptr = srcprops_chunklist, *next;
 362   while (ptr)
 363     {
 364       next = ptr->next;
 365       free ((char *) ptr);
 366       scm_mallocated -= sizeof (scm_srcprops_chunk)
 367                         + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
 368       ptr = next;
 369     }
 370 }