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