1 /* env.c: Environments, define, set!, etc.
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include "kernel.h"
34
35 void Set_Name (Object, Object);
36 void Memoize_Frame (Object);
37 void Memoize_Frames (Object, Object);
38 void Forget_Frame (Object);
39
40 #define Env_To_List(env, list) SET((list), T_Pair, (intptr_t)POINTER(env))
41 #define List_To_Env(list, env) SET((env), T_Environment, (intptr_t)POINTER(list))
42
43 Object The_Environment, Global_Environment;
44
45 Object General_Define();
46
Init_Env()47 void Init_Env () {
48 List_To_Env (Cons (Null, Null), Global_Environment);
49 The_Environment = Global_Environment;
50 Global_GC_Link (Global_Environment);
51 Global_GC_Link (The_Environment);
52 }
53
P_Environment_To_List(Object env)54 Object P_Environment_To_List (Object env) {
55 Object e;
56
57 Check_Type (env, T_Environment);
58 Env_To_List (env, e);
59 return Copy_List (e);
60 }
61
P_Environmentp(Object x)62 Object P_Environmentp (Object x) {
63 return TYPE(x) == T_Environment ? True : False;
64 }
65
Push_Frame(Object frame)66 void Push_Frame (Object frame) {
67 Object e;
68
69 Memoize_Frame (frame);
70 Env_To_List (The_Environment, e);
71 List_To_Env (Cons (frame, e), The_Environment);
72 }
73
Pop_Frame()74 void Pop_Frame () {
75 Object e;
76
77 Env_To_List (The_Environment, e);
78 List_To_Env (Cdr (e), The_Environment);
79 Forget_Frame (Car (e));
80 }
81
Switch_Environment(Object to)82 void Switch_Environment (Object to) {
83 Object old, new, n;
84
85 if (EQ(The_Environment,to))
86 return;
87 Env_To_List (The_Environment, old);
88 Env_To_List (to, new);
89 for ( ; !Nullp (old); old = Cdr (old)) {
90 for (n = new; !Nullp (n) && !EQ(n,old);
91 n = Cdr (n))
92 ;
93 if (EQ(n,old))
94 break;
95 Forget_Frame (Car (old));
96 }
97 Memoize_Frames (new, n);
98 The_Environment = to;
99 }
100
Memoize_Frames(Object this,Object last)101 void Memoize_Frames (Object this, Object last) {
102 if (Nullp (this) || EQ(this,last))
103 return;
104 Memoize_Frames (Cdr (this), last);
105 Memoize_Frame (Car (this));
106 }
107
Memoize_Frame(Object frame)108 void Memoize_Frame (Object frame) {
109 Object binding;
110
111 for (; !Nullp (frame); frame = Cdr (frame)) {
112 binding = Car (frame);
113 SYMBOL(Car (binding))->value = Cdr (binding);
114 }
115 }
116
Forget_Frame(Object frame)117 void Forget_Frame (Object frame) {
118 for (; !Nullp (frame); frame = Cdr (frame))
119 SYMBOL(Car (Car (frame)))->value = Unbound;
120 }
121
Add_Binding(Object frame,Object sym,Object val)122 Object Add_Binding (Object frame, Object sym, Object val) {
123 Object b;
124 GC_Node;
125
126 GC_Link (frame);
127 b = Cons (sym, val);
128 GC_Unlink;
129 return Cons (b, frame);
130 }
131
Lookup_Symbol(Object sym,int err)132 Object Lookup_Symbol (Object sym, int err) {
133 Object p, f, b;
134
135 Env_To_List (The_Environment, p);
136 for (; !Nullp (p); p = Cdr (p)) {
137 for (f = Car (p); !Nullp (f); f = Cdr (f)) { /* Inlined Assq() */
138 b = Car (f);
139 if (EQ(Car (b), sym))
140 return b;
141 }
142 }
143 if (err)
144 Primitive_Error ("unbound variable: ~s", sym);
145 return Null;
146 }
147
P_The_Environment()148 Object P_The_Environment () { return The_Environment; }
149
P_Global_Environment()150 Object P_Global_Environment () { return Global_Environment; }
151
Define_Procedure(Object form,Object body,Object sym)152 Object Define_Procedure (Object form, Object body, Object sym) {
153 Object ret;
154 GC_Node3;
155
156 GC_Link3 (form, body, sym);
157 body = Cons (Cdr (form), body);
158 body = Cons (sym, body);
159 body = Cons (body, Null);
160 body = Cons (Car (form), body);
161 ret = General_Define (body, sym);
162 GC_Unlink;
163 return ret;
164 }
165
General_Define(Object argl,Object sym)166 Object General_Define (Object argl, Object sym) {
167 Object val, var, frame, binding;
168 GC_Node3;
169 TC_Prolog;
170
171 var = Car (argl);
172 val = Cdr (argl);
173 if (TYPE(var) == T_Symbol) {
174 frame = Null;
175 GC_Link3 (var, val, frame);
176 if (Nullp (val)) {
177 val = Void;
178 } else {
179 TC_Disable;
180 val = Eval (Car (val));
181 TC_Enable;
182 }
183 Set_Name (var, val);
184 frame = Car (The_Environment);
185 binding = Assq (var, frame);
186 if (EQ(binding, False)) {
187 frame = Add_Binding (frame, var, val);
188 Car (The_Environment) = frame;
189 } else
190 Cdr (binding) = val;
191 SYMBOL(var)->value = val;
192 GC_Unlink;
193 return var;
194 } else if (TYPE(var) == T_Pair) {
195 if (Nullp (val))
196 Primitive_Error ("no sub-forms in compound: ~s", var);
197 return Define_Procedure (var, val, sym);
198 } else Wrong_Type_Combination (var, "symbol or pair");
199 /*NOTREACHED*/
200 }
201
P_Define(Object argl)202 Object P_Define (Object argl) {
203 return General_Define (argl, Sym_Lambda);
204 }
205
P_Define_Macro(Object argl)206 Object P_Define_Macro (Object argl) {
207 return General_Define (argl, Sym_Macro);
208 }
209
P_Set(Object argl)210 Object P_Set (Object argl) {
211 Object val, var, binding, old;
212 GC_Node3;
213 TC_Prolog;
214
215 var = Car (argl);
216 val = Car (Cdr (argl));
217 Check_Type (var, T_Symbol);
218 binding = Lookup_Symbol (var, 1);
219 old = Cdr (binding);
220 GC_Link3 (var, binding, old);
221 TC_Disable;
222 val = Eval (val);
223 TC_Enable;
224 Set_Name (var, val);
225 Cdr (binding) = val;
226 SYMBOL(var)->value = val;
227 GC_Unlink;
228 return old;
229 }
230
Set_Name(Object var,Object val)231 void Set_Name (Object var, Object val) {
232 register int t;
233
234 t = TYPE(val);
235 if (t == T_Compound) {
236 if (Nullp (COMPOUND(val)->name))
237 COMPOUND(val)->name = var;
238 } else if (t == T_Macro) {
239 if (Nullp (MACRO(val)->name))
240 MACRO(val)->name = var;
241 }
242 }
243
P_Boundp(Object x)244 Object P_Boundp (Object x) {
245 Check_Type (x, T_Symbol);
246 return Nullp (Lookup_Symbol (x, 0)) ? False : True;
247 }
248