libguile/srcprop.c

   1 /*      Copyright (C) 1995,1996, 1997 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 "alist.h"
  50 #include "debug.h"
  51 #include "hashtab.h"
  52 #include "hash.h"
  53 #include "weaks.h"
  54
  55 #include "srcprop.h"
  56 \f
  57 /* {Source Properties}
  58  *
  59  * Properties of source list expressions.
  60  * Five of these have special meaning and optimized storage:
  61  *
  62  * filename    string   The name of the source file.
  63  * copy        list     A copy of the list expression.
  64  * line        integer  The source code line number.
  65  * column      integer  The source code column number.
  66  * breakpoint  boolean  Sets a breakpoint on this form.
  67  *
  68  * Most properties above can be set by the reader.
  69  *
  70  */
  71
  72 SCM scm_i_filename;
  73 SCM scm_i_copy;
  74 SCM scm_i_line;
  75 SCM scm_i_column;
  76 SCM scm_i_breakpoint;
  77
  78 long scm_tc16_srcprops;
  79 static scm_srcprops_chunk *srcprops_chunklist = 0;
  80 static scm_srcprops *srcprops_freelist = 0;
  81
  82
  83 static SCM marksrcprops SCM_P ((SCM obj));
  84
  85 static SCM
  86 marksrcprops (obj)
  87      SCM obj;
  88 {
  89   scm_gc_mark (SRCPROPFNAME (obj));
  90   scm_gc_mark (SRCPROPCOPY (obj));
  91   return SRCPROPPLIST (obj);
  92 }
  93
  94
  95 static scm_sizet freesrcprops SCM_P ((SCM obj));
  96
  97 static scm_sizet
  98 freesrcprops (obj)
  99      SCM obj;
 100 {
 101   *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist;
 102   srcprops_freelist = (scm_srcprops *) SCM_CDR (obj);
 103   return 0; /* srcprops_chunks are not freed until leaving guile */
 104 }
 105
 106
 107 static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
 108
 109 static int
 110 prinsrcprops (obj, port, pstate)
 111      SCM obj;
 112      SCM port;
 113      scm_print_state *pstate;
 114 {
 115   int writingp = SCM_WRITINGP (pstate);
 116   scm_puts ("#<srcprops ", port);
 117   SCM_SET_WRITINGP (pstate, 1);
 118   scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
 119   SCM_SET_WRITINGP (pstate, writingp);
 120   scm_putc ('>', port);
 121   return 1;
 122 }
 123
 124 static scm_smobfuns srcpropssmob =
 125 {marksrcprops, freesrcprops, prinsrcprops, 0};
 126
 127
 128 SCM
 129 scm_make_srcprops (line, col, filename, copy, plist)
 130      int line;
 131      int col;
 132      SCM filename;
 133      SCM copy;
 134      SCM plist;
 135 {
 136   register SCM ans;
 137   register scm_srcprops *ptr;
 138   SCM_DEFER_INTS;
 139   if ((ptr = srcprops_freelist) != NULL)
 140     srcprops_freelist = *(scm_srcprops **)ptr;
 141   else
 142     {
 143       int i;
 144       scm_srcprops_chunk *mem;
 145       scm_sizet n = sizeof (scm_srcprops_chunk)
 146                     + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
 147       SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n));
 148       SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops");
 149       scm_mallocated += n;
 150       mem->next = srcprops_chunklist;
 151       srcprops_chunklist = mem;
 152       ptr = &mem->srcprops[0];
 153       for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
 154         *(scm_srcprops **)&ptr[i] = &ptr[i + 1];
 155       *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
 156       srcprops_freelist = (scm_srcprops *) &ptr[1];
 157     }
 158   SCM_NEWCELL (ans);
 159   SCM_SETCAR (ans, scm_tc16_srcprops);
 160   ptr->pos = SRCPROPMAKPOS (line, col);
 161   ptr->fname = filename;
 162   ptr->copy = copy;
 163   ptr->plist = plist;
 164   SCM_SETCDR (ans, (SCM) ptr);
 165   SCM_ALLOW_INTS;
 166   return ans;
 167 }
 168
 169
 170 SCM
 171 scm_srcprops_to_plist (obj)
 172      SCM obj;
 173 {
 174   SCM plist = SRCPROPPLIST (obj);
 175   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
 176     plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist);
 177   if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
 178     plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist);
 179   plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist);
 180   plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist);
 181   plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist);
 182   return plist;
 183 }
 184
 185 SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties);
 186
 187 SCM
 188 scm_source_properties (obj)
 189      SCM obj;
 190 {
 191   SCM p;
 192   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties);
 193   if (SCM_MEMOIZEDP (obj))
 194     obj = SCM_MEMOIZED_EXP (obj);
 195 #ifndef SCM_RECKLESS
 196   else if (SCM_NCONSP (obj))
 197     scm_wrong_type_arg (s_source_properties, 1, obj);
 198 #endif
 199   p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL);
 200   if (p != (SCM) NULL && SRCPROPSP (p))
 201     return scm_srcprops_to_plist (p);
 202   return SCM_EOL;
 203 }
 204
 205 /* Perhaps this procedure should look through an alist
 206    and try to make a srcprops-object...? */
 207 SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x);
 208
 209 SCM
 210 scm_set_source_properties_x (obj, plist)
 211      SCM obj;
 212      SCM plist;
 213 {
 214   SCM handle;
 215   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x);
 216   if (SCM_MEMOIZEDP (obj))
 217     obj = SCM_MEMOIZED_EXP (obj);
 218 #ifndef SCM_RECKLESS
 219   else if (SCM_NCONSP (obj))
 220     scm_wrong_type_arg (s_set_source_properties_x, 1, obj);
 221 #endif
 222   handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
 223   SCM_SETCDR (handle, plist);
 224   return plist;
 225 }
 226
 227 SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property);
 228
 229 SCM
 230 scm_source_property (obj, key)
 231      SCM obj;
 232      SCM key;
 233 {
 234   SCM p;
 235   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property);
 236   if (SCM_MEMOIZEDP (obj))
 237     obj = SCM_MEMOIZED_EXP (obj);
 238 #ifndef SCM_RECKLESS
 239   else if (SCM_NCONSP (obj))
 240     scm_wrong_type_arg (s_source_property, 1, obj);
 241 #endif
 242   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 243   if (SCM_IMP (p) || !SRCPROPSP (p))
 244     goto plist;
 245   if      (scm_i_breakpoint == key) p = SRCPROPBRK (p);
 246   else if (scm_i_line       == key) p = SCM_MAKINUM (SRCPROPLINE (p));
 247   else if (scm_i_column     == key) p = SCM_MAKINUM (SRCPROPCOL (p));
 248   else if (scm_i_filename   == key) p = SRCPROPFNAME (p);
 249   else if (scm_i_copy       == key) p = SRCPROPCOPY (p);
 250   else
 251     {
 252       p = SRCPROPPLIST (p);
 253     plist:
 254       p = scm_assoc (key, p);
 255       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
 256     }
 257   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 258 }
 259
 260 SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x);
 261
 262 SCM
 263 scm_set_source_property_x (obj, key, datum)
 264      SCM obj;
 265      SCM key;
 266      SCM datum;
 267 {
 268   scm_whash_handle h;
 269   SCM p;
 270   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x);
 271   if (SCM_MEMOIZEDP (obj))
 272     obj = SCM_MEMOIZED_EXP (obj);
 273 #ifndef SCM_RECKLESS
 274   else if (SCM_NCONSP (obj))
 275     scm_wrong_type_arg (s_set_source_property_x, 1, obj);
 276 #endif
 277   h = scm_whash_get_handle (scm_source_whash, obj);
 278   if (SCM_WHASHFOUNDP (h))
 279     p = SCM_WHASHREF (scm_source_whash, h);
 280   else
 281     {
 282       h = scm_whash_create_handle (scm_source_whash, obj);
 283       p = SCM_EOL;
 284     }
 285   if (scm_i_breakpoint == key)
 286     {
 287       if (SCM_FALSEP (datum))
 288         CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
 289                          ? p
 290                          : SCM_WHASHSET (scm_source_whash, h,
 291                                          scm_make_srcprops (0,
 292                                                             0,
 293                                                             SCM_UNDEFINED,
 294                                                             SCM_UNDEFINED,
 295                                                             p)));
 296       else
 297         SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
 298                        ? p
 299                        : SCM_WHASHSET (scm_source_whash, h,
 300                                        scm_make_srcprops (0,
 301                                                           0,
 302                                                           SCM_UNDEFINED,
 303                                                           SCM_UNDEFINED,
 304                                                           p)));
 305     }
 306   else if (scm_i_line == key)
 307     {
 308       if (SCM_NIMP (p) && SRCPROPSP (p))
 309         SETSRCPROPLINE (p, datum);
 310       else
 311         SCM_WHASHSET (scm_source_whash, h,
 312                   scm_make_srcprops (datum, 0, SCM_UNDEFINED, SCM_UNDEFINED, p));
 313     }
 314   else if (scm_i_column == key)
 315     {
 316       if (SCM_NIMP (p) && SRCPROPSP (p))
 317         SETSRCPROPCOL (p, datum);
 318       else
 319         SCM_WHASHSET (scm_source_whash, h,
 320                   scm_make_srcprops (0, datum, SCM_UNDEFINED, SCM_UNDEFINED, p));
 321     }
 322   else if (scm_i_filename == key)
 323     {
 324       if (SCM_NIMP (p) && SRCPROPSP (p))
 325         SRCPROPFNAME (p) = datum;
 326       else
 327         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
 328     }
 329   else if (scm_i_filename == key)
 330     {
 331       if (SCM_NIMP (p) && SRCPROPSP (p))
 332         SRCPROPCOPY (p) = datum;
 333       else
 334         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
 335     }
 336   else
 337     SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
 338   return SCM_UNSPECIFIED;
 339 }
 340
 341
 342 void
 343 scm_init_srcprop ()
 344 {
 345   scm_tc16_srcprops = scm_newsmob (&srcpropssmob);
 346   scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047));
 347
 348   scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED));
 349   scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED));
 350   scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED));
 351   scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED));
 352   scm_i_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 }