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
  51 static scm_sizet free_var SCM_P ((SCM obj));
  52
  53 static scm_sizet
  54 free_var (obj)
  55      SCM obj;
  56 {
  57   return 0;
  58 }
  59
  60
  61
  62 static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
  63
  64 static int
  65 prin_var (exp, port, pstate)
  66      SCM exp;
  67      SCM port;
  68      scm_print_state *pstate;
  69 {
  70   scm_gen_puts (scm_regular_string, "#<variable ", port);
  71   scm_intprint(exp, 16, port);
  72   {
  73     SCM val_cell;
  74     val_cell = SCM_CDR(exp);
  75     if (SCM_CAR (val_cell) != SCM_UNDEFINED)
  76       {
  77         scm_gen_puts (scm_regular_string, " name: ", port);
  78         scm_iprin1 (SCM_CAR (val_cell), port, pstate);
  79       }
  80     scm_gen_puts (scm_regular_string, " binding: ", port);
  81     scm_iprin1 (SCM_CDR (val_cell), port, pstate);
  82   }
  83   scm_gen_putc('>', port);
  84   return 1;
  85 }
  86
  87
  88 static SCM scm_markvar SCM_P ((SCM ptr));
  89
  90 static SCM
  91 scm_markvar (ptr)
  92      SCM ptr;
  93 {
  94   if (SCM_GC8MARKP (ptr))
  95     return SCM_BOOL_F;
  96   SCM_SETGC8MARK (ptr);
  97   return SCM_CDR (ptr);
  98 }
  99
 100 int scm_tc16_variable;
 101 static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, 0};
 102 \f
 103
 104 static SCM anonymous_variable_sym;
 105
 106
 107 static SCM make_vcell_variable SCM_P ((SCM vcell));
 108
 109 static SCM
 110 make_vcell_variable (vcell)
 111      SCM vcell;
 112 {
 113   SCM answer;
 114   SCM_NEWCELL(answer);
 115   SCM_REDEFER_INTS;
 116   SCM_CAR(answer) = scm_tc16_variable;
 117   SCM_CDR(answer) = vcell;
 118   SCM_REALLOW_INTS;
 119   return answer;
 120 }
 121
 122 SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable);
 123
 124 SCM
 125 scm_make_variable (init, name_hint)
 126      SCM init;
 127      SCM name_hint;
 128 {
 129   SCM val_cell;
 130
 131   if (name_hint == SCM_UNDEFINED)
 132     name_hint = anonymous_variable_sym;
 133
 134   SCM_NEWCELL(val_cell);
 135   SCM_DEFER_INTS;
 136   SCM_CAR(val_cell) = name_hint;
 137   SCM_CDR(val_cell) = init;
 138   SCM_ALLOW_INTS;
 139   return make_vcell_variable (val_cell);
 140 }
 141
 142
 143 SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable);
 144
 145 SCM
 146 scm_make_undefined_variable (name_hint)
 147      SCM name_hint;
 148 {
 149   SCM vcell;
 150
 151   if (name_hint == SCM_UNDEFINED)
 152     name_hint = anonymous_variable_sym;
 153
 154   SCM_NEWCELL (vcell);
 155   SCM_DEFER_INTS;
 156   SCM_CAR (vcell) = name_hint;
 157   SCM_CDR (vcell) = SCM_UNDEFINED;
 158   SCM_ALLOW_INTS;
 159   return make_vcell_variable (vcell);
 160 }
 161
 162
 163 SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p);
 164
 165 SCM
 166 scm_variable_p (obj)
 167      SCM obj;
 168 {
 169   return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj))
 170           ? SCM_BOOL_T
 171           : SCM_BOOL_F);
 172 }
 173
 174
 175 SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref);
 176
 177 SCM
 178 scm_variable_ref (var)
 179      SCM var;
 180 {
 181   SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref);
 182   return SCM_CDR (SCM_CDR (var));
 183 }
 184
 185
 186
 187 SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x);
 188
 189 SCM
 190 scm_variable_set_x (var, val)
 191      SCM var;
 192      SCM val;
 193 {
 194   SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x);
 195   SCM_CDR (SCM_CDR (var)) = val;
 196   return SCM_UNSPECIFIED;
 197 }
 198
 199
 200 SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable);
 201
 202 SCM
 203 scm_builtin_variable (name)
 204      SCM name;
 205 {
 206   SCM vcell;
 207   SCM var_slot;
 208
 209   SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_builtin_variable);
 210   vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T);
 211   if (vcell == SCM_BOOL_F)
 212     return SCM_BOOL_F;
 213
 214   scm_intern_symbol (scm_symhash_vars, name);
 215   var_slot = scm_sym2ovcell (name, scm_symhash_vars);
 216
 217   SCM_DEFER_INTS;
 218   if (   SCM_IMP (SCM_CDR (var_slot))
 219       || (SCM_VARVCELL (var_slot) != vcell))
 220     SCM_CDR (var_slot) = make_vcell_variable (vcell);
 221   SCM_ALLOW_INTS;
 222
 223   return SCM_CDR (var_slot);
 224 }
 225
 226
 227 SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p);
 228
 229 SCM
 230 scm_variable_bound_p (var)
 231      SCM var;
 232 {
 233   SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p);
 234   return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))
 235           ? SCM_BOOL_F
 236           : SCM_BOOL_T);
 237 }
 238
 239
 240
 241
 242 void
 243 scm_init_variable ()
 244 {
 245   scm_tc16_variable = scm_newsmob (&variable_smob);
 246   anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
 247 #include "variable.x"
 248 }
 249