libguile/variable.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "genio.h"
  46 #include "smob.h"
  47
  48 #include "variable.h"
  49 \f
  50 #ifdef __STDC__
  51 static scm_sizet
  52 free_var (SCM obj)
  53 #else
  54 static scm_sizet
  55 free_var (obj)
  56      SCM obj;
  57 #endif
  58 {
  59   return 0;
  60 }
  61
  62
  63 #ifdef __STDC__
  64 static int
  65 prin_var (SCM exp, SCM port, int writing)
  66 #else
  67 static int
  68 prin_var (exp, port, writing)
  69      SCM exp;
  70      SCM port;
  71      int writing;
  72 #endif
  73 {
  74   scm_gen_puts (scm_regular_string, "#<variable ", port);
  75   scm_intprint(exp, 16, port);
  76   {
  77     SCM val_cell;
  78     val_cell = SCM_CDR(exp);
  79     if (SCM_CAR (val_cell) != SCM_UNDEFINED)
  80       {
  81         scm_gen_puts (scm_regular_string, " name: ", port);
  82         scm_iprin1 (SCM_CAR (val_cell), port, writing);
  83       }
  84     scm_gen_puts (scm_regular_string, " binding: ", port);
  85     scm_iprin1 (SCM_CDR (val_cell), port, writing);
  86   }
  87   scm_gen_putc('>', port);
  88   return 1;
  89 }
  90
  91 #ifdef __STDC__
  92 static SCM
  93 scm_markvar (SCM ptr)
  94 #else
  95 static SCM
  96 scm_markvar (ptr)
  97      SCM ptr;
  98 #endif
  99 {
 100   if (SCM_GC8MARKP (ptr))
 101     return SCM_BOOL_F;
 102   SCM_SETGC8MARK (ptr);
 103   return SCM_CDR (ptr);
 104 }
 105
 106 int scm_tc16_variable;
 107 static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, 0};
 108 \f
 109
 110 static SCM variable_sym;
 111
 112 #ifdef __STDC__
 113 static SCM
 114 make_vcell_variable (SCM vcell)
 115 #else
 116 static SCM
 117 make_vcell_variable (vcell)
 118      SCM vcell;
 119 #endif
 120 {
 121   SCM answer;
 122   SCM_NEWCELL(answer);
 123   SCM_REDEFER_INTS;
 124   SCM_CAR(answer) = scm_tc16_variable;
 125   SCM_CDR(answer) = vcell;
 126   SCM_REALLOW_INTS;
 127   return answer;
 128 }
 129
 130 SCM_PROC(s_make_variable, "make-variable", 2, 0, 0, scm_make_variable);
 131 #ifdef __STDC__
 132 SCM
 133 scm_make_variable (SCM init, SCM name_hint)
 134 #else
 135 SCM
 136 scm_make_variable (init, name_hint)
 137      SCM init;
 138      SCM name_hint;
 139 #endif
 140 {
 141   SCM val_cell;
 142   SCM_NEWCELL(val_cell);
 143   SCM_DEFER_INTS;
 144   SCM_CAR(val_cell) = name_hint;
 145   SCM_CDR(val_cell) = init;
 146   SCM_ALLOW_INTS;
 147   return make_vcell_variable (val_cell);
 148 }
 149
 150
 151 SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable);
 152 #ifdef __STDC__
 153 SCM
 154 scm_make_undefined_variable (SCM name_hint)
 155 #else
 156 SCM
 157 scm_make_undefined_variable (name_hint)
 158      SCM name_hint;
 159 #endif
 160 {
 161   SCM vcell;
 162
 163   if (name_hint == SCM_UNDEFINED)
 164     name_hint = variable_sym;
 165
 166   SCM_NEWCELL (vcell);
 167   SCM_DEFER_INTS;
 168   SCM_CAR (vcell) = name_hint;
 169   SCM_CDR (vcell) = SCM_UNDEFINED;
 170   SCM_ALLOW_INTS;
 171   return make_vcell_variable (vcell);
 172 }
 173
 174
 175 SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p);
 176 #ifdef __STDC__
 177 SCM
 178 scm_variable_p (SCM obj)
 179 #else
 180 SCM
 181 scm_variable_p (obj)
 182      SCM obj;
 183 #endif
 184 {
 185   return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj))
 186           ? SCM_BOOL_T
 187           : SCM_BOOL_F);
 188 }
 189
 190
 191 SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref);
 192 #ifdef __STDC__
 193 SCM
 194 scm_variable_ref (SCM var)
 195 #else
 196 SCM
 197 scm_variable_ref (var)
 198      SCM var;
 199 #endif
 200 {
 201   SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref);
 202   return SCM_CDR (SCM_CDR (var));
 203 }
 204
 205
 206
 207 SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x);
 208 #ifdef __STDC__
 209 SCM
 210 scm_variable_set_x (SCM var, SCM val)
 211 #else
 212 SCM
 213 scm_variable_set_x (var, val)
 214      SCM var;
 215      SCM val;
 216 #endif
 217 {
 218   SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x);
 219   SCM_CDR (SCM_CDR (var)) = val;
 220   return SCM_UNSPECIFIED;
 221 }
 222
 223
 224 SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable);
 225 #ifdef __STDC__
 226 SCM
 227 scm_builtin_variable (SCM name)
 228 #else
 229 SCM
 230 scm_builtin_variable (name)
 231      SCM name;
 232 #endif
 233 {
 234   SCM vcell;
 235   SCM var_slot;
 236
 237   SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_builtin_variable);
 238   vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T);
 239   if (vcell == SCM_BOOL_F)
 240     return SCM_BOOL_F;
 241
 242   scm_intern_symbol (scm_symhash_vars, name);
 243   var_slot = scm_sym2ovcell (name, scm_symhash_vars);
 244
 245   SCM_DEFER_INTS;
 246   if (   SCM_IMP (SCM_CDR (var_slot))
 247       || (SCM_VARVCELL (var_slot) != vcell))
 248     SCM_CDR (var_slot) = make_vcell_variable (vcell);
 249   SCM_ALLOW_INTS;
 250
 251   return SCM_CDR (var_slot);
 252 }
 253
 254
 255 SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p);
 256 #ifdef __STDC__
 257 SCM
 258 scm_variable_bound_p (SCM var)
 259 #else
 260 SCM
 261 scm_variable_bound_p (var)
 262      SCM var;
 263 #endif
 264 {
 265   SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p);
 266   return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))
 267           ? SCM_BOOL_F
 268           : SCM_BOOL_T);
 269 }
 270
 271
 272
 273 #ifdef __STDC__
 274 void
 275 scm_init_variable (void)
 276 #else
 277 void
 278 scm_init_variable ()
 279 #endif
 280 {
 281   scm_tc16_variable = scm_newsmob (&variable_smob);
 282   variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
 283 #include "variable.x"
 284 }
 285