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_i_filename;
  74 SCM scm_i_copy;
  75 SCM scm_i_line;
  76 SCM scm_i_column;
  77 SCM scm_i_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 static scm_smobfuns srcpropssmob =
 126 {marksrcprops, freesrcprops, prinsrcprops, 0};
 127
 128
 129 SCM
 130 scm_make_srcprops (line, col, filename, copy, plist)
 131      int line;
 132      int col;
 133      SCM filename;
 134      SCM copy;
 135      SCM plist;
 136 {
 137   register SCM ans;
 138   register scm_srcprops *ptr;
 139   SCM_DEFER_INTS;
 140   if ((ptr = srcprops_freelist) != NULL)
 141     srcprops_freelist = *(scm_srcprops **)ptr;
 142   else
 143     {
 144       int i;
 145       scm_srcprops_chunk *mem;
 146       scm_sizet n = sizeof (scm_srcprops_chunk)
 147                     + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
 148       SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n));
 149       SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops");
 150       scm_mallocated += n;
 151       mem->next = srcprops_chunklist;
 152       srcprops_chunklist = mem;
 153       ptr = &mem->srcprops[0];
 154       for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
 155         *(scm_srcprops **)&ptr[i] = &ptr[i + 1];
 156       *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
 157       srcprops_freelist = (scm_srcprops *) &ptr[1];
 158     }
 159   SCM_NEWCELL (ans);
 160   SCM_SETCAR (ans, scm_tc16_srcprops);
 161   ptr->pos = SRCPROPMAKPOS (line, col);
 162   ptr->fname = filename;
 163   ptr->copy = copy;
 164   ptr->plist = plist;
 165   SCM_SETCDR (ans, (SCM) ptr);
 166   SCM_ALLOW_INTS;
 167   return ans;
 168 }
 169
 170
 171 SCM
 172 scm_srcprops_to_plist (obj)
 173      SCM obj;
 174 {
 175   SCM plist = SRCPROPPLIST (obj);
 176   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
 177     plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist);
 178   if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
 179     plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist);
 180   plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist);
 181   plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist);
 182   plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist);
 183   return plist;
 184 }
 185
 186 SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties);
 187
 188 SCM
 189 scm_source_properties (obj)
 190      SCM obj;
 191 {
 192   SCM p;
 193   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties);
 194   if (SCM_MEMOIZEDP (obj))
 195     obj = SCM_MEMOIZED_EXP (obj);
 196 #ifndef SCM_RECKLESS
 197   else if (SCM_NCONSP (obj))
 198     scm_wrong_type_arg (s_source_properties, 1, obj);
 199 #endif
 200   p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL);
 201   if (p != (SCM) NULL && SRCPROPSP (p))
 202     return scm_srcprops_to_plist (p);
 203   return SCM_EOL;
 204 }
 205
 206 /* Perhaps this procedure should look through an alist
 207    and try to make a srcprops-object...? */
 208 SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x);
 209
 210 SCM
 211 scm_set_source_properties_x (obj, plist)
 212      SCM obj;
 213      SCM plist;
 214 {
 215   SCM handle;
 216   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x);
 217   if (SCM_MEMOIZEDP (obj))
 218     obj = SCM_MEMOIZED_EXP (obj);
 219 #ifndef SCM_RECKLESS
 220   else if (SCM_NCONSP (obj))
 221     scm_wrong_type_arg (s_set_source_properties_x, 1, obj);
 222 #endif
 223   handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
 224   SCM_SETCDR (handle, plist);
 225   return plist;
 226 }
 227
 228 SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property);
 229
 230 SCM
 231 scm_source_property (obj, key)
 232      SCM obj;
 233      SCM key;
 234 {
 235   SCM p;
 236   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property);
 237   if (SCM_MEMOIZEDP (obj))
 238     obj = SCM_MEMOIZED_EXP (obj);
 239 #ifndef SCM_RECKLESS
 240   else if (SCM_NCONSP (obj))
 241     scm_wrong_type_arg (s_source_property, 1, obj);
 242 #endif
 243   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 244   if (SCM_IMP (p) || !SRCPROPSP (p))
 245     goto plist;
 246   if      (scm_i_breakpoint == key) p = SRCPROPBRK (p);
 247   else if (scm_i_line       == key) p = SCM_MAKINUM (SRCPROPLINE (p));
 248   else if (scm_i_column     == key) p = SCM_MAKINUM (SRCPROPCOL (p));
 249   else if (scm_i_filename   == key) p = SRCPROPFNAME (p);
 250   else if (scm_i_copy       == key) p = SRCPROPCOPY (p);
 251   else
 252     {
 253       p = SRCPROPPLIST (p);
 254     plist:
 255       p = scm_assoc (key, p);
 256       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
 257     }
 258   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 259 }
 260
 261 SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x);
 262
 263 SCM
 264 scm_set_source_property_x (obj, key, datum)
 265      SCM obj;
 266      SCM key;
 267      SCM datum;
 268 {
 269   scm_whash_handle h;
 270   SCM p;
 271   SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x);
 272   if (SCM_MEMOIZEDP (obj))
 273     obj = SCM_MEMOIZED_EXP (obj);
 274 #ifndef SCM_RECKLESS
 275   else if (SCM_NCONSP (obj))
 276     scm_wrong_type_arg (s_set_source_property_x, 1, obj);
 277 #endif
 278   h = scm_whash_get_handle (scm_source_whash, obj);
 279   if (SCM_WHASHFOUNDP (h))
 280     p = SCM_WHASHREF (scm_source_whash, h);
 281   else
 282     {
 283       h = scm_whash_create_handle (scm_source_whash, obj);
 284       p = SCM_EOL;
 285     }
 286   if (scm_i_breakpoint == key)
 287     {
 288       if (SCM_FALSEP (datum))
 289         CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
 290                          ? p
 291                          : SCM_WHASHSET (scm_source_whash, h,
 292                                          scm_make_srcprops (0,
 293                                                             0,
 294                                                             SCM_UNDEFINED,
 295                                                             SCM_UNDEFINED,
 296                                                             p)));
 297       else
 298         SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
 299                        ? p
 300                        : SCM_WHASHSET (scm_source_whash, h,
 301                                        scm_make_srcprops (0,
 302                                                           0,
 303                                                           SCM_UNDEFINED,
 304                                                           SCM_UNDEFINED,
 305                                                           p)));
 306     }
 307   else if (scm_i_line == key)
 308     {
 309       SCM_ASSERT (SCM_INUMP (datum),
 310                   datum, SCM_ARG3, s_set_source_property_x);
 311       if (SCM_NIMP (p) && SRCPROPSP (p))
 312         SETSRCPROPLINE (p, SCM_INUM (datum));
 313       else
 314         SCM_WHASHSET (scm_source_whash, h,
 315                       scm_make_srcprops (SCM_INUM (datum), 0,
 316                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 317     }
 318   else if (scm_i_column == key)
 319     {
 320       SCM_ASSERT (SCM_INUMP (datum),
 321                   datum, SCM_ARG3, s_set_source_property_x);
 322       if (SCM_NIMP (p) && SRCPROPSP (p))
 323         SETSRCPROPCOL (p, SCM_INUM (datum));
 324       else
 325         SCM_WHASHSET (scm_source_whash, h,
 326                       scm_make_srcprops (0, SCM_INUM (datum),
 327                                          SCM_UNDEFINED, SCM_UNDEFINED, p));
 328     }
 329   else if (scm_i_filename == key)
 330     {
 331       if (SCM_NIMP (p) && SRCPROPSP (p))
 332         SRCPROPFNAME (p) = datum;
 333       else
 334         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
 335     }
 336   else if (scm_i_filename == key)
 337     {
 338       if (SCM_NIMP (p) && SRCPROPSP (p))
 339         SRCPROPCOPY (p) = datum;
 340       else
 341         SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
 342     }
 343   else
 344     SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
 345   return SCM_UNSPECIFIED;
 346 }
 347
 348
 349 void
 350 scm_init_srcprop ()
 351 {
 352   scm_tc16_srcprops = scm_newsmob (&srcpropssmob);
 353   scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047));
 354
 355   scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED));
 356   scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED));
 357   scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED));
 358   scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED));
 359   scm_i_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED));
 360
 361   scm_sysintern ("source-whash", scm_source_whash);
 362 #include "srcprop.x"
 363 }
 364
 365 void
 366 scm_finish_srcprop ()
 367 {
 368   register scm_srcprops_chunk *ptr = srcprops_chunklist, *next;
 369   while (ptr)
 370     {
 371       next = ptr->next;
 372       free ((char *) ptr);
 373       scm_mallocated -= sizeof (scm_srcprops_chunk)
 374                         + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
 375       ptr = next;
 376     }
 377 }