Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | /* Copyright (C) 2001 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 | #include <string.h> | |
43 | #include "envs.h" | |
44 | ||
45 | #define ENV_OBARRAY_SIZE 31 | |
46 | ||
47 | \f | |
48 | scm_bits_t scm_tc16_env; | |
49 | ||
50 | SCM | |
51 | scm_c_make_env (void) | |
52 | { | |
53 | struct scm_env *p = scm_must_malloc (sizeof (struct scm_env), | |
54 | "scm_c_make_env"); | |
55 | p->identifier = SCM_BOOL_F; | |
56 | p->obarray = scm_c_make_hash_table (ENV_OBARRAY_SIZE); | |
57 | SCM_RETURN_NEWSMOB (scm_tc16_env, p); | |
58 | } | |
59 | ||
60 | static SCM | |
61 | env_mark (SCM obj) | |
62 | { | |
63 | struct scm_env *p = SCM_ENV_DATA (obj); | |
64 | scm_gc_mark (p->identifier); | |
65 | return p->obarray; | |
66 | } | |
67 | ||
68 | static scm_sizet | |
69 | env_free (SCM obj) | |
70 | { | |
71 | scm_must_free (SCM_ENV_DATA (obj)); | |
72 | return sizeof (struct scm_env); | |
73 | } | |
74 | ||
75 | \f | |
76 | /* | |
77 | * C interface | |
78 | */ | |
79 | ||
80 | static SCM env_table; | |
81 | static SCM load_env; | |
82 | ||
83 | SCM | |
84 | scm_c_lookup_env (SCM identifier) | |
85 | { | |
86 | /* Check if the env is already loaded */ | |
87 | SCM vcell = scm_sym2ovcell_soft (identifier, env_table); | |
88 | ||
89 | /* If not, load the env */ | |
90 | if (SCM_FALSEP (vcell)) | |
91 | { | |
92 | SCM env = scm_apply (SCM_CDR (load_env), | |
93 | SCM_LIST1 (identifier), SCM_EOL); | |
94 | if (!SCM_ENV_P (env)) | |
95 | scm_misc_error ("scm_c_lookup_env", | |
96 | "Invalid env: ~S", SCM_LIST1 (env)); | |
97 | scm_intern_symbol (env_table, identifier); | |
98 | vcell = scm_sym2ovcell_soft (identifier, env_table); | |
99 | SCM_SETCDR (vcell, env); | |
100 | } | |
101 | ||
102 | return SCM_CDR (vcell); | |
103 | } | |
104 | ||
105 | SCM | |
106 | scm_c_env_vcell (SCM env, SCM name, int intern) | |
107 | { | |
108 | SCM ob = SCM_ENV_OBARRAY (env); | |
109 | if (intern) | |
110 | scm_intern_symbol (ob, name); | |
111 | return scm_sym2ovcell_soft (name, ob); | |
112 | } | |
113 | ||
114 | \f | |
115 | /* | |
116 | * Scheme interface | |
117 | */ | |
118 | ||
119 | SCM_DEFINE (scm_make_env, "make-env", 0, 0, 0, | |
120 | (), | |
121 | "") | |
122 | #define FUNC_NAME s_scm_make_env | |
123 | { | |
124 | return scm_c_make_env (); | |
125 | } | |
126 | #undef FUNC_NAME | |
127 | ||
128 | SCM_DEFINE (scm_env_p, "env?", 1, 0, 0, | |
129 | (SCM x), | |
130 | "") | |
131 | #define FUNC_NAME s_scm_env_p | |
132 | { | |
133 | return SCM_BOOL (SCM_ENV_P (x)); | |
134 | } | |
135 | #undef FUNC_NAME | |
136 | ||
137 | SCM_DEFINE (scm_env_identifier, "env-identifier", 1, 0, 0, | |
138 | (SCM env), | |
139 | "") | |
140 | #define FUNC_NAME s_scm_env_identifier | |
141 | { | |
142 | SCM_VALIDATE_ENV (1, env); | |
143 | return SCM_ENV_IDENTIFIER (env); | |
144 | } | |
145 | #undef FUNC_NAME | |
146 | ||
147 | SCM_DEFINE (scm_set_env_identifier_x, "set-env-identifier!", 2, 0, 0, | |
148 | (SCM env, SCM identifier), | |
149 | "") | |
150 | #define FUNC_NAME s_scm_set_env_identifier_x | |
151 | { | |
152 | SCM_VALIDATE_ENV (1, env); | |
153 | SCM_VALIDATE_SYMBOL (2, identifier); | |
154 | SCM_ENV_IDENTIFIER (env) = identifier; | |
155 | return SCM_UNSPECIFIED; | |
156 | } | |
157 | #undef FUNC_NAME | |
158 | ||
159 | SCM_DEFINE (scm_env_bound_p, "env-bound?", 2, 0, 0, | |
160 | (SCM env, SCM name), | |
161 | "") | |
162 | #define FUNC_NAME s_scm_env_bound_p | |
163 | { | |
164 | SCM vcell; | |
165 | SCM_VALIDATE_ENV (1, env); | |
166 | SCM_VALIDATE_SYMBOL (2, name); | |
167 | vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env)); | |
168 | return SCM_BOOL (!SCM_FALSEP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell))); | |
169 | } | |
170 | #undef FUNC_NAME | |
171 | ||
172 | SCM_DEFINE (scm_env_ref, "env-ref", 2, 0, 0, | |
173 | (SCM env, SCM name), | |
174 | "") | |
175 | #define FUNC_NAME s_scm_env_ref | |
176 | { | |
177 | SCM vcell; | |
178 | SCM_VALIDATE_ENV (1, env); | |
179 | SCM_VALIDATE_SYMBOL (2, name); | |
180 | vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env)); | |
181 | if (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell))) | |
182 | SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A", | |
183 | SCM_LIST2 (env, name)); | |
184 | return SCM_CDR (vcell); | |
185 | } | |
186 | #undef FUNC_NAME | |
187 | ||
188 | SCM_DEFINE (scm_env_set_x, "env-set!", 3, 0, 0, | |
189 | (SCM env, SCM name, SCM val), | |
190 | "") | |
191 | #define FUNC_NAME s_scm_env_set_x | |
192 | { | |
193 | SCM vcell; | |
194 | SCM_VALIDATE_ENV (1, env); | |
195 | SCM_VALIDATE_SYMBOL (2, name); | |
196 | vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env)); | |
197 | if (SCM_FALSEP (vcell)) | |
198 | SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A", | |
199 | SCM_LIST2 (env, name)); | |
200 | SCM_SETCDR (vcell, val); | |
201 | return SCM_UNSPECIFIED; | |
202 | } | |
203 | #undef FUNC_NAME | |
204 | ||
205 | SCM_DEFINE (scm_env_define, "env-define", 3, 0, 0, | |
206 | (SCM env, SCM name, SCM val), | |
207 | "") | |
208 | #define FUNC_NAME s_scm_env_define | |
209 | { | |
210 | SCM vcell; | |
211 | SCM_VALIDATE_ENV (1, env); | |
212 | SCM_VALIDATE_SYMBOL (2, name); | |
213 | vcell = scm_c_env_vcell (env, name, 1); | |
214 | SCM_SETCDR (vcell, val); | |
215 | return SCM_UNSPECIFIED; | |
216 | } | |
217 | #undef FUNC_NAME | |
218 | ||
219 | \f | |
220 | void | |
221 | scm_init_envs (void) | |
222 | { | |
b4ea62ef | 223 | SCM mod; |
17e90c5e KN |
224 | |
225 | scm_tc16_env = scm_make_smob_type ("env", 0); | |
226 | scm_set_smob_mark (scm_tc16_env, env_mark); | |
227 | scm_set_smob_free (scm_tc16_env, env_free); | |
228 | ||
229 | env_table = scm_permanent_object (scm_c_make_hash_table (51)); | |
230 | ||
17e90c5e KN |
231 | #ifndef SCM_MAGIC_SNARFER |
232 | #include "envs.x" | |
233 | #endif | |
234 | ||
b4ea62ef | 235 | mod = scm_current_module (); |
17e90c5e KN |
236 | load_env = scm_eval_closure_lookup (scm_standard_eval_closure (mod), |
237 | scm_str2symbol ("load-env"), | |
238 | SCM_BOOL_T); | |
239 | load_env = SCM_VARVCELL (load_env); | |
17e90c5e KN |
240 | } |
241 | ||
242 | /* | |
243 | Local Variables: | |
244 | c-file-style: "gnu" | |
245 | End: | |
246 | */ |