libguile/variable.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 2000 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, 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 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "libguile/_scm.h"
  49 #include "libguile/eq.h"
  50 #include "libguile/ports.h"
  51 #include "libguile/root.h"
  52 #include "libguile/smob.h"
  53
  54 #include "libguile/validate.h"
  55 #include "libguile/variable.h"
  56 \f
  57 scm_bits_t scm_tc16_variable;
  58
  59 static int
  60 variable_print (SCM exp, SCM port, scm_print_state *pstate)
  61 {
  62   scm_puts ("#<variable ", port);
  63   scm_intprint(SCM_UNPACK (exp), 16, port);
  64   {
  65     SCM val_cell;
  66     val_cell = SCM_CDR(exp);
  67     if (!SCM_UNBNDP (SCM_CAR (val_cell)))
  68       {
  69         scm_puts (" name: ", port);
  70         scm_iprin1 (SCM_CAR (val_cell), port, pstate);
  71       }
  72     scm_puts (" binding: ", port);
  73     scm_iprin1 (SCM_CDR (val_cell), port, pstate);
  74   }
  75   scm_putc('>', port);
  76   return 1;
  77 }
  78
  79 static SCM
  80 variable_equalp (SCM var1, SCM var2)
  81 {
  82   return scm_equal_p (SCM_CDR (var1), SCM_CDR (var2));
  83 }
  84 \f
  85
  86 static SCM anonymous_variable_sym;
  87
  88
  89 static SCM
  90 make_vcell_variable (SCM vcell)
  91 {
  92   SCM_RETURN_NEWSMOB (scm_tc16_variable, SCM_UNPACK (vcell));
  93 }
  94
  95 SCM_DEFINE (scm_make_variable, "make-variable", 1, 1, 0,
  96             (SCM init, SCM name_hint),
  97             "Return a variable object initialized to value INIT.\n"
  98             "If given, uses NAME-HINT as its internal (debugging)\n"
  99             "name, otherwise just treat it as an anonymous variable.\n"
 100             "Remember, of course, that multiple bindings to the same\n"
 101             "variable may exist, so NAME-HINT is just that---a hint.\n")
 102 #define FUNC_NAME s_scm_make_variable
 103 {
 104   SCM val_cell;
 105
 106   if (SCM_UNBNDP (name_hint))
 107     name_hint = anonymous_variable_sym;
 108
 109   SCM_NEWCELL(val_cell);
 110   SCM_DEFER_INTS;
 111   SCM_SETCAR (val_cell, name_hint);
 112   SCM_SETCDR (val_cell, init);
 113   SCM_ALLOW_INTS;
 114   return make_vcell_variable (val_cell);
 115 }
 116 #undef FUNC_NAME
 117
 118
 119 SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0,
 120             (SCM name_hint),
 121             "Return a variable object initialized to an undefined value.\n"
 122             "If given, uses NAME-HINT as its internal (debugging)\n"
 123             "name, otherwise just treat it as an anonymous variable.\n"
 124             "Remember, of course, that multiple bindings to the same\n"
 125             "variable may exist, so NAME-HINT is just that---a hint.\n")
 126 #define FUNC_NAME s_scm_make_undefined_variable
 127 {
 128   SCM vcell;
 129
 130   if (SCM_UNBNDP (name_hint))
 131     name_hint = anonymous_variable_sym;
 132
 133   SCM_NEWCELL (vcell);
 134   SCM_DEFER_INTS;
 135   SCM_SETCAR (vcell, name_hint);
 136   SCM_SETCDR (vcell, SCM_UNDEFINED);
 137   SCM_ALLOW_INTS;
 138   return make_vcell_variable (vcell);
 139 }
 140 #undef FUNC_NAME
 141
 142
 143 SCM_DEFINE (scm_variable_p, "variable?", 1, 0, 0,
 144             (SCM obj),
 145             "Return #t iff OBJ is a variable object, else return #f\n")
 146 #define FUNC_NAME s_scm_variable_p
 147 {
 148   return SCM_BOOL (SCM_VARIABLEP (obj));
 149 }
 150 #undef FUNC_NAME
 151
 152
 153 SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0,
 154             (SCM var),
 155             "Dereference VAR and return its value.\n"
 156             "VAR must be a variable object;  see `make-variable' and\n"
 157             "`make-undefined-variable'")
 158 #define FUNC_NAME s_scm_variable_ref
 159 {
 160   SCM_VALIDATE_VARIABLE (1, var);
 161   return SCM_CDR (SCM_CDR (var));
 162 }
 163 #undef FUNC_NAME
 164
 165
 166
 167 SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0,
 168             (SCM var, SCM val),
 169             "Set the value of the variable VAR to VAL.\n"
 170             "VAR must be a variable object, VAL can be any value.\n"
 171             "Returns an unspecified value.\n")
 172 #define FUNC_NAME s_scm_variable_set_x
 173 {
 174   SCM_VALIDATE_VARIABLE (1,var);
 175   SCM_SETCDR (SCM_CDR (var), val);
 176   return SCM_UNSPECIFIED;
 177 }
 178 #undef FUNC_NAME
 179
 180
 181 SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0,
 182             (SCM name),
 183             "Return the built-in variable with the name NAME.\n"
 184             "NAME must be a symbol (not a string).\n"
 185             "Then use `variable-ref' to access its value.\n")
 186 #define FUNC_NAME s_scm_builtin_variable
 187 {
 188   SCM vcell;
 189   SCM var_slot;
 190
 191   SCM_VALIDATE_SYMBOL (1,name);
 192   vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T);
 193   if (SCM_FALSEP (vcell))
 194     return SCM_BOOL_F;
 195
 196   scm_intern_symbol (scm_symhash_vars, name);
 197   var_slot = scm_sym2ovcell (name, scm_symhash_vars);
 198
 199   SCM_DEFER_INTS;
 200   if (SCM_IMP (SCM_CDR (var_slot))
 201       || !SCM_EQ_P (SCM_VARVCELL (var_slot), vcell))
 202     SCM_SETCDR (var_slot, make_vcell_variable (vcell));
 203   SCM_ALLOW_INTS;
 204
 205   return SCM_CDR (var_slot);
 206 }
 207 #undef FUNC_NAME
 208
 209
 210 SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0,
 211             (SCM var),
 212             "Return #t iff VAR is bound to a value.\n"
 213             "Throws an error if VAR is not a variable object.\n")
 214 #define FUNC_NAME s_scm_variable_bound_p
 215 {
 216   SCM_VALIDATE_VARIABLE (1,var);
 217   return SCM_NEGATE_BOOL(SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var))));
 218 }
 219 #undef FUNC_NAME
 220
 221
 222
 223
 224 void
 225 scm_init_variable ()
 226 {
 227   scm_tc16_variable = scm_make_smob_type ("variable", 0);
 228   scm_set_smob_mark (scm_tc16_variable, scm_markcdr);
 229   scm_set_smob_print (scm_tc16_variable, variable_print);
 230   scm_set_smob_equalp (scm_tc16_variable, variable_equalp);
 231
 232   anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
 233 #ifndef SCM_MAGIC_SNARFER
 234 #include "libguile/variable.x"
 235 #endif
 236 }
 237
 238
 239 /*
 240   Local Variables:
 241   c-file-style: "gnu"
 242   End:
 243 */