1 /*@z09.c:Closure Expansion:SearchEnv()@***************************************/
2 /* */
3 /* THE LOUT DOCUMENT FORMATTING SYSTEM (VERSION 3.39) */
4 /* COPYRIGHT (C) 1991, 2008 Jeffrey H. Kingston */
5 /* */
6 /* Jeffrey H. Kingston (jeff@it.usyd.edu.au) */
7 /* School of Information Technologies */
8 /* The University of Sydney 2006 */
9 /* AUSTRALIA */
10 /* */
11 /* This program is free software; you can redistribute it and/or modify */
12 /* it under the terms of the GNU General Public License as published by */
13 /* the Free Software Foundation; either Version 3, or (at your option) */
14 /* any later version. */
15 /* */
16 /* This program is distributed in the hope that it will be useful, */
17 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
18 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
19 /* GNU General Public License for more details. */
20 /* */
21 /* You should have received a copy of the GNU General Public License */
22 /* along with this program; if not, write to the Free Software */
23 /* Foundation, Inc., 59 Temple Place, Suite 330, Boston MA 02111-1307 USA */
24 /* */
25 /* FILE: z09.c */
26 /* MODULE: Closure Expansion */
27 /* EXTERNS: SearchEnv(), SetEnv(), AttachEnv(), GetEnv(), */
28 /* DetachEnv(), ClosureExpand() */
29 /* */
30 /*****************************************************************************/
31 #include "externs.h"
32
33
34 /*****************************************************************************/
35 /* */
36 /* OBJECT SearchEnv(env, sym) */
37 /* */
38 /* Search environment env for a symbol such that actual() == sym. */
39 /* */
40 /*****************************************************************************/
41
SearchEnv(OBJECT env,OBJECT sym)42 OBJECT SearchEnv(OBJECT env, OBJECT sym)
43 { OBJECT link, y;
44 debug2(DCE, DD, "[ SearchEnv(%s, %s)", EchoObject(env), SymName(sym));
45 for(;;)
46 {
47 debug1(DCE, DDD, " searching env %s", EchoObject(env));
48 assert( env != nilobj && type(env) == ENV, "SearchEnv: env!" );
49 if( Down(env) == env )
50 { debug0(DCE, DD, "] SearchEnv returning <nilobj>");
51 return nilobj;
52 }
53 Child(y, Down(env));
54 assert( type(y) == CLOSURE, "SearchEnv: type(y) != CLOSURE!" );
55 if( actual(y) == sym )
56 { debug1(DCE, DD, "] SearchEnv returning %s", EchoObject(y));
57 return y;
58 }
59 assert( LastDown(y) != y, "SearchEnv: LastDown(y) == y!" );
60 link = LastDown(env) != Down(env) ? LastDown(env) : LastDown(y);
61 Child(env, link);
62 }
63 } /* end SearchEnv */
64
65
66 /*@::SetEnv(), AttachEnv(), GetEnv(), DetachEnv()@****************************/
67 /* */
68 /* OBJECT SetEnv(x, y) */
69 /* */
70 /* Create a new environment containing x and possibly y. */
71 /* */
72 /*****************************************************************************/
73
SetEnv(OBJECT x,OBJECT y)74 OBJECT SetEnv(OBJECT x, OBJECT y)
75 { OBJECT res;
76 debug1(DCE, DD, "SetEnv( x, %s ), x =", EchoObject(y));
77 ifdebug(DCE, DD, DebugObject(x));
78 assert( x!=nilobj && type(x)==CLOSURE, "SetEnv: x==nilobj or not CLOSURE!" );
79 assert( y==nilobj || type(y)==ENV, "SetEnv: y!=nilobj && type(y) != ENV!" );
80 New(res, ENV); Link(res, x);
81 if( y != nilobj ) Link(res, y);
82 debug1(DCE, DD, "SetEnv returning %s", EchoObject(res));
83 return res;
84 } /* end SetEnv */
85
86
87 /*****************************************************************************/
88 /* */
89 /* AttachEnv(env, x) */
90 /* */
91 /* Attach environment env to CLOSURE x. */
92 /* */
93 /*****************************************************************************/
94
AttachEnv(OBJECT env,OBJECT x)95 void AttachEnv(OBJECT env, OBJECT x)
96 { debug2(DCE, DD, "AttachEnv( %s, %s )", EchoObject(env), EchoObject(x));
97 assert( env != nilobj && type(env) == ENV, "AttachEnv: type(env) != ENV!" );
98 assert( type(x) == CLOSURE || type(x) == ENV_OBJ, "AttachEnv: type(x)!" );
99 Link(x, env);
100 debug0(DCE, DD, "AttachEnv returning.");
101 } /* end AttachEnv */
102
103
104 /*****************************************************************************/
105 /* */
106 /* OBJECT GetEnv(x) */
107 /* */
108 /* Get from CLOSURE x the environment previously attached. */
109 /* */
110 /*****************************************************************************/
111
GetEnv(OBJECT x)112 OBJECT GetEnv(OBJECT x)
113 { OBJECT env;
114 assert( type(x) == CLOSURE, "GetEnv: type(x) != CLOSURE!" );
115 assert( LastDown(x) != x, "GetEnv: LastDown(x) == x!" );
116 Child(env, LastDown(x));
117 assert( type(env) == ENV, "GetEnv: type(env) != ENV!" );
118 return env;
119 } /* end GetEnv */
120
121
122 /*****************************************************************************/
123 /* */
124 /* OBJECT DetachEnv(x) */
125 /* */
126 /* Detach from CLOSURE x the environment previously attached. */
127 /* */
128 /*****************************************************************************/
129
DetachEnv(OBJECT x)130 OBJECT DetachEnv(OBJECT x)
131 { OBJECT env;
132 debug1(DCE, DD, "DetachEnv( %s )", EchoObject(x));
133 assert( type(x) == CLOSURE, "DetachEnv: type(x) != CLOSURE!" );
134 assert( LastDown(x) != x, "DetachEnv: LastDown(x) == x!" );
135 Child(env, LastDown(x));
136 DeleteLink(LastDown(x));
137 assert( type(env) == ENV, "DetachEnv: type(env) != ENV!" );
138 debug1(DCE, DD, "DetachEnv resturning %s", EchoObject(env));
139 return env;
140 } /* end DetachEnv */
141
142
143 /*@::ClosureExpand()@*********************************************************/
144 /* */
145 /* OBJECT ClosureExpand(x, env, crs_wanted, crs, res_env) */
146 /* */
147 /* Return expansion of closure x in environment env. */
148 /* The body comes from the environment of x if x is a parameter, else from */
149 /* the symbol table. The original x is pushed into the environments. */
150 /* If crs_wanted and x has a tag, a cross-reference is added to crs. */
151 /* */
152 /*****************************************************************************/
153
ClosureExpand(OBJECT x,OBJECT env,BOOLEAN crs_wanted,OBJECT * crs,OBJECT * res_env)154 OBJECT ClosureExpand(OBJECT x, OBJECT env, BOOLEAN crs_wanted,
155 OBJECT *crs, OBJECT *res_env)
156 { OBJECT link, y, res, prnt_env, par, prnt;
157 debug3(DCE, D, "[ ClosureExpand( %s, %s, %s, crs, res_env )",
158 EchoObject(x), EchoObject(env), bool(crs_wanted));
159 assert( type(x) == CLOSURE, "ClosureExpand given non-CLOSURE!");
160 assert( predefined(actual(x)) == FALSE, "ClosureExpand given predefined!" );
161
162 /* add tag to x if needed but not provided; add cross-reference to crs */
163 if( has_tag(actual(x)) ) CrossAddTag(x);
164 if( crs_wanted && has_tag(actual(x)) )
165 { OBJECT tmp = CopyObject(x, no_fpos); AttachEnv(env, tmp);
166 y = CrossMake(actual(x), tmp, CROSS_TARG);
167 New(tmp, CROSS_TARG); actual(tmp) = y; Link(tmp, y);
168 if( *crs == nilobj ) New(*crs, CR_LIST); Link(*crs, tmp);
169 }
170
171 /* case x is a parameter */
172 res = *res_env = nilobj;
173 if( is_par(type(actual(x))) )
174 { prnt = SearchEnv(env, enclosing(actual(x)));
175 if( prnt != nilobj )
176 {
177 prnt_env = GetEnv(prnt);
178 for( link = Down(prnt); link != prnt; link = NextDown(link) )
179 { Child(par, link);
180 if( type(par) == PAR && actual(par) == actual(x) )
181 { assert( Down(par) != par, "ExpandCLosure: Down(par)!");
182 Child(res, Down(par));
183 if( dirty(enclosing(actual(par))) || is_enclose(actual(par)) )
184 { debug2(DCE, DD, "copy %s %s", SymName(actual(par)), EchoObject(res));
185 res = CopyObject(res, no_fpos);
186 }
187 else
188 {
189 debug2(DCE, DD, "link %s %s",
190 FullSymName(actual(par), AsciiToFull(".")), EchoObject(res));
191 DeleteLink(Down(par));
192 y = MakeWord(WORD, STR_NOCROSS, &fpos(res));
193 Link(par, y);
194 }
195 ReplaceNode(res, x);
196 if( type(actual(x)) == RPAR && has_body(enclosing(actual(x))) )
197 { debug0(DCR, DDD, " calling SetEnv from ClosureExpand (a)");
198 *res_env = SetEnv(prnt, nilobj); DisposeObject(x);
199 }
200 else if( type(actual(x)) == NPAR && imports_encl(actual(x)) )
201 { debug0(DCR, DDD, " calling SetEnv from ClosureExpand (x)");
202 AttachEnv(env, x);
203 *res_env = SetEnv(x, nilobj);
204 }
205 else
206 { AttachEnv(env, x);
207 debug0(DCR, DDD, " calling SetEnv from ClosureExpand (b)");
208 *res_env = SetEnv(x, prnt_env);
209 }
210 break;
211 }
212 }
213 }
214 else
215 {
216 /* fail only if there is no default value available */
217 if( sym_body(actual(x)) == nilobj )
218 {
219 debug3(DCE, D, "failing ClosureExpand( %s, crs, %s, %s, res_env )",
220 EchoObject(x), bool(crs_wanted), EchoObject(env));
221 Error(9, 2, "no value for parameter %s of symbol %s:", WARN, &fpos(x),
222 SymName(actual(x)), SymName(enclosing(actual(x))));
223 Error(9, 1, "symbol with import list misused", FATAL, &fpos(x));
224 }
225 }
226 }
227
228 /* case x is a user-defined symbol or default parameter */
229 if( res == nilobj )
230 { if( sym_body(actual(x)) == nilobj )
231 res = MakeWord(WORD, STR_NOCROSS, &fpos(x));
232 else
233 res = CopyObject(sym_body(actual(x)), &fpos(x));
234 ReplaceNode(res, x); AttachEnv(env, x);
235 debug0(DCR, DDD, " calling SetEnv from ClosureExpand (c)");
236 *res_env = SetEnv(x, nilobj);
237 }
238
239 assert( *res_env!=nilobj && type(*res_env)==ENV, "ClosureExpand: *res_env!");
240 debug0(DCE, D, "] ClosureExpand returning, res =");
241 ifdebug(DCE, D, DebugObject(res));
242 debug1(DCE, D, " environment = %s", EchoObject(*res_env));
243 return res;
244 } /* end ClosureExpand */
245
246
247 /*@::ParameterCheck()@********************************************************/
248 /* */
249 /* OBJECT ParameterCheck(x, env) */
250 /* */
251 /* Check whether object x (which is an actual parameter that happens to be */
252 /* a CLOSURE) has a value which is a simple word, and if so return a copy */
253 /* of that word, else nilobj. */
254 /* */
255 /*****************************************************************************/
256
ParameterCheck(OBJECT x,OBJECT env)257 OBJECT ParameterCheck(OBJECT x, OBJECT env)
258 { OBJECT link, y, res, prnt_env, par, prnt;
259 debug2(DCE, DD, "ParameterCheck(%s, %s)", EchoObject(x), EchoObject(env));
260 assert( type(x) == CLOSURE, "ParameterCheck given non-CLOSURE!");
261
262 /* case x is a parameter */
263 prnt = SearchEnv(env, enclosing(actual(x)));
264 if( prnt == nilobj )
265 { debug0(DCE, DD, "ParameterCheck returning nilobj (prnt fail)");
266 return nilobj;
267 }
268 prnt_env = GetEnv(prnt);
269 for( link = Down(prnt); link != prnt; link = NextDown(link) )
270 { Child(par, link);
271 if( type(par) == PAR && actual(par) == actual(x) )
272 { assert( Down(par) != par, "ParameterCheck: Down(par)!");
273 Child(y, Down(par));
274 res = is_word(type(y)) ? CopyObject(y, no_fpos) : nilobj;
275 debug1(DCE, DD, " ParameterCheck returning %s", EchoObject(res));
276 return res;
277 }
278 }
279
280 /* case x is a default parameter */
281 y = sym_body(actual(x));
282 if( y == nilobj )
283 { res = nilobj;
284 }
285 else if( is_word(type(y)) )
286 { res = CopyObject(y, &fpos(y));
287 }
288 else if( type(y) == CLOSURE && is_par(type(actual(y))) )
289 { res = ParameterCheck(y, prnt_env);
290 }
291 else
292 { res = nilobj;
293 }
294 debug1(DCE, DD, "ParameterCheck returning %s", EchoObject(res));
295 return res;
296 } /* end ParameterCheck */
297