1 /* Part of XPCE --- The SWI-Prolog GUI toolkit
2
3 Author: Jan Wielemaker and Anjo Anjewierden
4 E-mail: jan@swi.psy.uva.nl
5 WWW: http://www.swi.psy.uva.nl/projects/xpce/
6 Copyright (c) 1985-2002, University of Amsterdam
7 All rights reserved.
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions
11 are met:
12
13 1. Redistributions of source code must retain the above copyright
14 notice, this list of conditions and the following disclaimer.
15
16 2. Redistributions in binary form must reproduce the above copyright
17 notice, this list of conditions and the following disclaimer in
18 the documentation and/or other materials provided with the
19 distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32 POSSIBILITY OF SUCH DAMAGE.
33 */
34
35 #include <h/kernel.h>
36
37 forwards void initVars(void);
38 forwards VarBinding findVarEnvironment(VarEnvironment ev, Var v);
39
40 static HashTable VarTable;
41
42 static status
initialiseVar(Var v,Type type,Name name,Any value)43 initialiseVar(Var v, Type type, Name name, Any value)
44 { if ( isDefault(type) )
45 type = TypeUnchecked;
46 if ( isDefault(name) ) /* local var */
47 name = NIL;
48
49 assign(v, name, name);
50 assign(v, type, type);
51 assign(v, global_value, value);
52
53 v->value = value;
54 if ( isObject(value) )
55 addCodeReference(value);
56
57 if ( notNil(name) )
58 { if ( getMemberHashTable(VarTable, name) )
59 errorPce(v, NAME_redeclaredVar);
60 appendHashTable(VarTable, name, v);
61 protectObject(v);
62 }
63
64 return initialiseFunction((Function) v);
65 }
66
67
68 static status
unlinkVar(Var v)69 unlinkVar(Var v)
70 { VarEnvironment ev = varEnvironment;
71
72 for(; ev; ev = ev->parent)
73 { VarBinding b;
74
75 if ( (b = findVarEnvironment(ev, v)) )
76 b->variable = NULL;
77 }
78
79 if ( isObject(v->value) )
80 delCodeReference(v->value);
81
82
83 succeed;
84 }
85
86
87 static Var
getConvertVar(Class class,Any name)88 getConvertVar(Class class, Any name)
89 { answer(getMemberHashTable(VarTable, name));
90 }
91
92
93 /* see assignVar()
94 static status
95 valueVar(Var v, Any value)
96 { if ( v->value != value )
97 { if ( isObject(v->value) )
98 delCodeReference(v->value);
99 v->value = value;
100 if ( isObject(value) )
101 addCodeReference(value);
102 }
103
104 succeed;
105 }
106 */
107
108 static Any
getValueVar(Var v)109 getValueVar(Var v)
110 { answer(v->value);
111 }
112
113
114 /*******************************
115 * CLASS DECLARATION *
116 *******************************/
117
118 /* Type declarations */
119
120 static char *T_initialise[] =
121 { "type=[type]", "name=[name]", "value=[any]" };
122 static char *T_assign[] =
123 { "value=any", "scope=[{local,outer,global}]" };
124
125 /* Instance Variables */
126
127 static vardecl var_var[] =
128 { IV(NAME_Name, "name*", IV_GET,
129 NAME_name, "Name of the var"),
130 IV(NAME_Type, "type", IV_BOTH,
131 NAME_type, "Type of the <-_value"),
132 IV(NAME_Value, "alien:Any", IV_NONE,
133 NAME_value, "Value of the var"),
134 IV(NAME_GlobalValue, "any", IV_GET,
135 NAME_abort, "Global value of the var")
136 };
137
138 /* Send Methods */
139
140 static senddecl send_var[] =
141 { SM(NAME_initialise, 3, T_initialise, initialiseVar,
142 DEFAULT, "Create var from name and value"),
143 SM(NAME_unlink, 0, NULL, unlinkVar,
144 DEFAULT, "Release code reference of value"),
145 SM(NAME_assign, 2, T_assign, assignVar,
146 NAME_value, "Assign value to variable (with scope)")
147 };
148
149 /* Get Methods */
150
151 static getdecl get_var[] =
152 { GM(NAME_convert, 1, "var", "name", getConvertVar,
153 NAME_conversion, "Converts name to var from @variables"),
154 GM(NAME_Execute, 0, "unchecked", NULL, getValueVar,
155 NAME_execute, "Current value of the variable"),
156 GM(NAME_Value, 0, "unchecked", NULL, getValueVar,
157 NAME_value, "Current value of the variable")
158 };
159
160 /* Resources */
161
162 #define rc_var NULL
163 /*
164 static classvardecl rc_var[] =
165 {
166 };
167 */
168
169 /* Class Declaration */
170
171 static Name var_termnames[] = { NAME_Value };
172
173 ClassDecl(var_decls,
174 var_var, send_var, get_var, rc_var,
175 1, var_termnames,
176 "$Rev$");
177
178 status
makeClassVar(Class class)179 makeClassVar(Class class)
180 { declareClass(class, &var_decls);
181 saveStyleClass(class, NAME_external);
182
183 VarTable = globalObject(NAME_variables, ClassHashTable, EAV);
184 initVars();
185
186 succeed;
187 }
188
189
190 static Var
initVar(Name name,char * type,Any value)191 initVar(Name name, char *type, Any value)
192 { return globalObject(name, ClassVar, CtoType(type), name, value, EAV);
193 }
194
195
196 static Var
initGrVar(Name ref,Name name)197 initGrVar(Name ref, Name name)
198 { return globalObject(ref, ClassVar, TypeInt, name, ZERO, EAV);
199 }
200
201
202 static void
initVars(void)203 initVars(void)
204 { int n;
205
206 RECEIVER = initVar(NAME_receiver, "object*", NIL);
207 RECEIVER_CLASS = initVar(NAME_receiverClass, "class*", NIL);
208 EVENT = initVar(NAME_event, "event*", NIL);
209 SELECTOR = initVar(NAME_selector, "name*", NIL);
210 REPORTEE = initVar(NAME_reportee, "chain*", NIL);
211
212 VarX = initGrVar(NAME_xVar, NAME_x);
213 VarY = initGrVar(NAME_yVar, NAME_y);
214 VarW = initGrVar(NAME_wVar, NAME_w);
215 VarH = initGrVar(NAME_hVar, NAME_h);
216 VarW2 = initGrVar(NAME_w2Var, NAME_w2);
217 VarH2 = initGrVar(NAME_h2Var, NAME_h2);
218 VarXref = initGrVar(NAME_xrefVar, NAME_xref);
219 VarYref = initGrVar(NAME_yrefVar, NAME_yref);
220
221 for(n = 1; n <= FWD_PCE_MAX_ARGS; n++)
222 { char varname[100];
223
224 sprintf(varname, "arg%d", n);
225 Arg(n) = initVar(CtoName(varname), "unchecked", DEFAULT);
226 }
227 }
228
229
230 void
resetVars(void)231 resetVars(void)
232 { varEnvironment = NULL;
233
234 if ( VarTable )
235 for_hash_table(VarTable, s,
236 { Var v = s->value;
237
238 v->value = v->global_value;
239 });
240 }
241
242
243 /********************************
244 * ENVIRONMENTS *
245 ********************************/
246
247 #define sizeofVarExtension(n) ((int)(intptr_t)(&((VarExtension)NULL)->bindings[n]))
248
249 #define EXTBLOCKSIZE 8
250
251 static VarBinding
findVarEnvironment(VarEnvironment ev,Var v)252 findVarEnvironment(VarEnvironment ev, Var v)
253 { int i;
254 VarBinding b;
255
256 b = ev->bindings; i = 0;
257 while( i < ev->size )
258 { if ( b->variable == v )
259 return b;
260
261 if ( ++i == BINDINGBLOCKSIZE && ev->extension )
262 b = ev->extension->bindings;
263 else
264 b++;
265 }
266
267 return NULL;
268 }
269
270
271 static VarExtension
expandVarExtension(VarExtension ext,int size)272 expandVarExtension(VarExtension ext, int size)
273 { if ( ext == NULL )
274 { ext = alloc(sizeofVarExtension(EXTBLOCKSIZE));
275 ext->allocated = EXTBLOCKSIZE;
276 return ext;
277 } else if ( size > ext->allocated )
278 { int a = ((size + EXTBLOCKSIZE - 1) / EXTBLOCKSIZE) * EXTBLOCKSIZE;
279 int i;
280
281 VarExtension new = alloc(sizeofVarExtension(a));
282 new->allocated = a;
283 for(i=0; i<ext->allocated; i++)
284 new->bindings[i] = ext->bindings[i];
285 unalloc(sizeofVarExtension(ext->allocated), ext);
286
287 return new;
288 } else
289
290 return ext;
291 }
292
293
294 static VarBinding
appendVarEnvironment(VarEnvironment ev,Var v)295 appendVarEnvironment(VarEnvironment ev, Var v)
296 { VarBinding b;
297
298 DEBUG(NAME_var, Cprintf("Appending %s to env %p\n", pp(v), ev));
299
300 if ( ev->size < BINDINGBLOCKSIZE )
301 b = &ev->bindings[ev->size++];
302 else
303 { int ext = ev->size - BINDINGBLOCKSIZE;
304
305 ev->extension = expandVarExtension(ev->extension, ext+1);
306 b = &ev->extension->bindings[ext];
307 }
308
309 b->variable = v;
310 b->value = v->value;
311
312 return b;
313 }
314
315
316 void
popVarEnvironment(void)317 popVarEnvironment(void)
318 { int i;
319 VarBinding b;
320 VarEnvironment ev = varEnvironment;
321
322 b = ev->bindings; i = 0;
323 while( i < ev->size )
324 { if ( b->variable ) /* may be ->unlink'ed! */
325 { if ( isObject(b->variable->value) )
326 delCodeReference(b->variable->value);
327 b->variable->value = b->value;
328 }
329
330 DEBUG(NAME_var, Cprintf("Restoring %s to %s\n",
331 pp(b->variable), pp(b->value)));
332
333 if ( ++i == BINDINGBLOCKSIZE && ev->extension )
334 b = ev->extension->bindings;
335 else
336 b++;
337 }
338
339 if ( ev->extension )
340 unalloc(sizeofVarExtension(ev->extension->allocated), ev->extension);
341
342 varEnvironment = ev->parent;
343 }
344
345
346 static void
valueVarBinding(VarBinding b,Any value)347 valueVarBinding(VarBinding b, Any value)
348 { if ( isObject(b->variable->value) )
349 delCodeReference(b->variable->value);
350 b->value = value;
351 }
352
353
354 status
assignVar(Var v,Any value,Name scope)355 assignVar(Var v, Any value, Name scope)
356 { if ( isDefault(scope) || scope == NAME_local )
357 { if ( varEnvironment && !findVarEnvironment(varEnvironment, v) )
358 appendVarEnvironment(varEnvironment, v);
359 } else if ( scope == NAME_outer )
360 { VarBinding b;
361
362 if ( varEnvironment )
363 { if ( !(b = findVarEnvironment(varEnvironment, v)) )
364 b = appendVarEnvironment(varEnvironment, v);
365
366 valueVarBinding(b, value);
367 }
368 } else /* if ( scope == NAME_global ) */
369 { VarEnvironment ev = varEnvironment;
370
371 for(; ev; ev = ev->parent)
372 { VarBinding b;
373
374 if ( (b = findVarEnvironment(ev, v)) )
375 valueVarBinding(b, value);
376 }
377 assign(v, global_value, value);
378 }
379
380 DEBUG(NAME_var, Cprintf("assignVar(%s) %s --> %s\n",
381 pp(v), pp(v->value), pp(value)));
382 v->value = value;
383 if ( isObject(value) )
384 addCodeReference(value);
385
386 succeed;
387 }
388