libguile/srcprop.c

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