libguile/srcprop.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 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 "libguile/_scm.h"
  52 #include "libguile/smob.h"
  53 #include "libguile/alist.h"
  54 #include "libguile/debug.h"
  55 #include "libguile/hashtab.h"
  56 #include "libguile/hash.h"
  57 #include "libguile/ports.h"
  58 #include "libguile/root.h"
  59 #include "libguile/weaks.h"
  60
  61 #include "libguile/validate.h"
  62 #include "libguile/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_CELL_WORD_1 (obj)) = srcprops_freelist;
 103   srcprops_freelist = (scm_srcprops *) SCM_CELL_WORD_1 (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       if (mem == NULL)
 136         scm_memory_error ("srcprops");
 137       scm_mallocated += n;
 138       mem->next = srcprops_chunklist;
 139       srcprops_chunklist = mem;
 140       ptr = &mem->srcprops[0];
 141       for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
 142         *(scm_srcprops **)&ptr[i] = &ptr[i + 1];
 143       *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
 144       srcprops_freelist = (scm_srcprops *) &ptr[1];
 145     }
 146   ptr->pos = SRCPROPMAKPOS (line, col);
 147   ptr->fname = filename;
 148   ptr->copy = copy;
 149   ptr->plist = plist;
 150   SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
 151 }
 152
 153
 154 SCM
 155 scm_srcprops_to_plist (SCM obj)
 156 {
 157   SCM plist = SRCPROPPLIST (obj);
 158   if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
 159     plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
 160   if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
 161     plist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), plist);
 162   plist = scm_acons (scm_sym_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist);
 163   plist = scm_acons (scm_sym_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist);
 164   plist = scm_acons (scm_sym_breakpoint, SRCPROPBRK (obj), plist);
 165   return plist;
 166 }
 167
 168 SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
 169             (SCM obj),
 170 "")
 171 #define FUNC_NAME s_scm_source_properties
 172 {
 173   SCM p;
 174   SCM_VALIDATE_NIM (1,obj);
 175   if (SCM_MEMOIZEDP (obj))
 176     obj = SCM_MEMOIZED_EXP (obj);
 177 #ifndef SCM_RECKLESS
 178   else if (SCM_NCONSP (obj))
 179     SCM_WRONG_TYPE_ARG (1, obj);
 180 #endif
 181   p = scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F);
 182   if (SRCPROPSP (p))
 183     return scm_srcprops_to_plist (p);
 184   return SCM_EOL;
 185 }
 186 #undef FUNC_NAME
 187
 188 /* Perhaps this procedure should look through an alist
 189    and try to make a srcprops-object...? */
 190 SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
 191             (SCM obj, SCM plist),
 192 "")
 193 #define FUNC_NAME s_scm_set_source_properties_x
 194 {
 195   SCM handle;
 196   SCM_VALIDATE_NIM (1,obj);
 197   if (SCM_MEMOIZEDP (obj))
 198     obj = SCM_MEMOIZED_EXP (obj);
 199 #ifndef SCM_RECKLESS
 200   else if (SCM_NCONSP (obj))
 201     SCM_WRONG_TYPE_ARG(1, obj);
 202 #endif
 203   handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
 204   SCM_SETCDR (handle, plist);
 205   return plist;
 206 }
 207 #undef FUNC_NAME
 208
 209 SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
 210             (SCM obj, SCM key),
 211 "")
 212 #define FUNC_NAME s_scm_source_property
 213 {
 214   SCM p;
 215   SCM_VALIDATE_NIM (1,obj);
 216   if (SCM_MEMOIZEDP (obj))
 217     obj = SCM_MEMOIZED_EXP (obj);
 218 #ifndef SCM_RECKLESS
 219   else if (SCM_NECONSP (obj))
 220     SCM_WRONG_TYPE_ARG (1, obj);
 221 #endif
 222   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
 223   if (SCM_IMP (p) || !SRCPROPSP (p))
 224     goto plist;
 225   if      (SCM_EQ_P (scm_sym_breakpoint, key)) p = SRCPROPBRK (p);
 226   else if (SCM_EQ_P (scm_sym_line,       key)) p = SCM_MAKINUM (SRCPROPLINE (p));
 227   else if (SCM_EQ_P (scm_sym_column,     key)) p = SCM_MAKINUM (SRCPROPCOL (p));
 228   else if (SCM_EQ_P (scm_sym_filename,   key)) p = SRCPROPFNAME (p);
 229   else if (SCM_EQ_P (scm_sym_copy,       key)) p = SRCPROPCOPY (p);
 230   else
 231     {
 232       p = SRCPROPPLIST (p);
 233     plist:
 234       p = scm_assoc (key, p);
 235       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
 236     }
 237   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 238 }
 239 #undef FUNC_NAME
 240
 241 SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
 242             (SCM obj, SCM key, SCM datum),
 243 "")
 244 #define FUNC_NAME s_scm_set_source_property_x
 245 {
 246   scm_whash_handle h;
 247   SCM p;
 248   SCM_VALIDATE_NIM (1,obj);
 249   if (SCM_MEMOIZEDP (obj))
 250     obj = SCM_MEMOIZED_EXP (obj);
 251 #ifndef SCM_RECKLESS
 252   else if (SCM_NCONSP (obj))
 253     SCM_WRONG_TYPE_ARG (1, obj);
 254 #endif
 255   h = scm_whash_get_handle (scm_source_whash, obj);
 256   if (SCM_WHASHFOUNDP (h))
 257     p = SCM_WHASHREF (scm_source_whash, h);
 258   else
 259     {
 260       h = scm_whash_create_handle (scm_source_whash, obj);
 261       p = SCM_EOL;
 262     }
 263   if (SCM_EQ_P (scm_sym_breakpoint, key))
 264     {
 265       if (SRCPROPSP (p))
 266         {
 267           if (SCM_FALSEP (datum))
 268             CLEARSRCPROPBRK (p);
 269           else
 270             SETSRCPROPBRK (p);
 271         }
 272       else
 273         {
 274           SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p);
 275           SCM_WHASHSET (scm_source_whash, h, sp);
 276           if (SCM_FALSEP (datum))
 277             CLEARSRCPROPBRK (sp);
 278           else
 279             SETSRCPROPBRK (sp);
 280         }
 281     }
 282   else if (SCM_EQ_P (scm_sym_line, key))
 283     {
 284       SCM_VALIDATE_INUM (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_EQ_P (scm_sym_column, key))
 293     {
 294       SCM_VALIDATE_INUM (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_EQ_P (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_EQ_P (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 "libguile/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 }
 353
 354 /*
 355   Local Variables:
 356   c-file-style: "gnu"
 357   End:
 358 */