1 /******************************** -*- C -*- ****************************
2 *
3  *	Symbol Table module.
4  *
5  *
6  ***********************************************************************/
7 
8 /***********************************************************************
9  *
10  * Copyright 1988,89,90,91,92,94,95,99,2000,2001,2002,2003,
11  * 2005,2006,2007,2008,2009 Free Software Foundation, Inc.
12  * Written by Steve Byrne.
13  *
14  * This file is part of GNU Smalltalk.
15  *
16  * GNU Smalltalk is free software; you can redistribute it and/or modify it
17  * under the terms of the GNU General Public License as published by the Free
18  * Software Foundation; either version 2, or (at your option) any later
19  * version.
20  *
21  * Linking GNU Smalltalk statically or dynamically with other modules is
22  * making a combined work based on GNU Smalltalk.  Thus, the terms and
23  * conditions of the GNU General Public License cover the whole
24  * combination.
25  *
26  * In addition, as a special exception, the Free Software Foundation
27  * give you permission to combine GNU Smalltalk with free software
28  * programs or libraries that are released under the GNU LGPL and with
29  * independent programs running under the GNU Smalltalk virtual machine.
30  *
31  * You may copy and distribute such a system following the terms of the
32  * GNU GPL for GNU Smalltalk and the licenses of the other code
33  * concerned, provided that you include the source code of that other
34  * code when and as the GNU GPL requires distribution of source code.
35  *
36  * Note that people who make modified versions of GNU Smalltalk are not
37  * obligated to grant this special exception for their modified
38  * versions; it is their choice whether to do so.  The GNU General
39  * Public License gives permission to release a modified version without
40  * this exception; this exception also makes it possible to release a
41  * modified version which carries forward this exception.
42  *
43  * GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
44  * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
45  * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
46  * more details.
47  *
48  * You should have received a copy of the GNU General Public License along with
49  * GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
50  * Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
51  *
52  ***********************************************************************/
53 
54 
55 #include "gstpriv.h"
56 #include "pointer-set.h"
57 
58 typedef struct
59 {
60   OBJ_HEADER;
61   OOP nextLink;
62   OOP symbol;
63 }
64  *sym_link;
65 
66 typedef struct symbol_list *symbol_list;
67 
68 struct symbol_list
69 {
70   OOP symbol;
71   mst_Boolean readOnly;
72   int index;
73   symbol_list prevSymbol;
74 };
75 
76 /* Represents all the identifiers, both arguments and temporaries,
77    which are declared in a given scope.  Nested scopes result in
78    nested instances of the scope struct, with the current scope always
79    being the innermost at any point during the compilation.  */
80 typedef struct scope *scope;
81 struct scope
82 {
83   scope prevScope;
84   unsigned int numArguments;
85   unsigned int numTemporaries;
86   symbol_list symbols;
87 };
88 
89 /* Represents all the pools (namespaces) which are declared in the
90    current scope.  This information is relatively complex to compute,
91    so it's kept cached.  */
92 typedef struct pool_list *pool_list;
93 struct pool_list
94 {
95   OOP poolOOP;
96   pool_list next;
97 };
98 
99 
100 typedef struct symbol_info
101 {
102   OOP *symbolVar;
103   const char *value;
104 }
105 symbol_info;
106 
107 
108 /* These variables hold various symbols needed mostly by the compiler
109    and the C interface.  It is important that these symbols are *not*
110    included in the builtin selectors list (builtins.gperf) because
111    of the way we create symbols in _gst_init_symbols_pass1.  */
112 
113 OOP _gst_and_symbol = NULL;
114 OOP _gst_as_scaled_decimal_radix_scale_symbol = NULL;
115 OOP _gst_bad_return_error_symbol = NULL;
116 OOP _gst_boolean_symbol = NULL;
117 OOP _gst_byte_array_out_symbol = NULL;
118 OOP _gst_byte_array_symbol = NULL;
119 OOP _gst_c_object_ptr_symbol = NULL;
120 OOP _gst_c_object_symbol = NULL;
121 OOP _gst_category_symbol = NULL;
122 OOP _gst_char_symbol = NULL;
123 OOP _gst_does_not_understand_symbol = NULL;
124 OOP _gst_double_symbol = NULL;
125 OOP _gst_false_symbol = NULL;
126 OOP _gst_float_symbol = NULL;
127 OOP _gst_if_false_if_true_symbol = NULL;
128 OOP _gst_if_false_symbol = NULL;
129 OOP _gst_if_true_if_false_symbol = NULL;
130 OOP _gst_if_true_symbol = NULL;
131 OOP _gst_int_symbol = NULL;
132 OOP _gst_long_double_symbol = NULL;
133 OOP _gst_long_symbol = NULL;
134 OOP _gst_must_be_boolean_symbol = NULL;
135 OOP _gst_nil_symbol = NULL;
136 OOP _gst_or_symbol = NULL;
137 OOP _gst_permission_symbol = NULL;
138 OOP _gst_primitive_symbol = NULL;
139 OOP _gst_repeat_symbol = NULL;
140 OOP _gst_self_smalltalk_symbol = NULL;
141 OOP _gst_self_symbol = NULL;
142 OOP _gst_short_symbol = NULL;
143 OOP _gst_smalltalk_symbol = NULL;
144 OOP _gst_smalltalk_namespace_symbol = NULL;
145 OOP _gst_start_execution_symbol = NULL;
146 OOP _gst_string_out_symbol = NULL;
147 OOP _gst_string_symbol = NULL;
148 OOP _gst_super_symbol = NULL;
149 OOP _gst_symbol_symbol = NULL;
150 OOP _gst_symbol_out_symbol = NULL;
151 OOP _gst_symbol_table = NULL;
152 OOP _gst_terminate_symbol = NULL;
153 OOP _gst_times_repeat_symbol = NULL;
154 OOP _gst_to_by_do_symbol = NULL;
155 OOP _gst_to_do_symbol = NULL;
156 OOP _gst_true_symbol = NULL;
157 OOP _gst_uchar_symbol = NULL;
158 OOP _gst_uint_symbol = NULL;
159 OOP _gst_ulong_symbol = NULL;
160 OOP _gst_ushort_symbol = NULL;
161 OOP _gst_undeclared_symbol = NULL;
162 OOP _gst_unknown_symbol = NULL;
163 OOP _gst_value_with_rec_with_args_symbol = NULL;
164 OOP _gst_variadic_smalltalk_symbol = NULL;
165 OOP _gst_variadic_symbol = NULL;
166 OOP _gst_vm_primitives_symbol = NULL;
167 OOP _gst_void_symbol = NULL;
168 OOP _gst_wchar_symbol = NULL;
169 OOP _gst_wstring_symbol = NULL;
170 OOP _gst_wstring_out_symbol = NULL;
171 OOP _gst_while_false_colon_symbol = NULL;
172 OOP _gst_while_false_symbol = NULL;
173 OOP _gst_while_true_colon_symbol = NULL;
174 OOP _gst_while_true_symbol = NULL;
175 OOP _gst_current_namespace = NULL;
176 
177 OOP temporaries_dictionary = NULL;
178 
179 /* The list of selectors for the send immediate bytecode.  */
180 struct builtin_selector _gst_builtin_selectors[256] = {};
181 
182 /* True if undeclared globals can be considered forward references.  */
183 enum undeclared_strategy _gst_use_undeclared = UNDECLARED_TEMPORARIES;
184 
185 /* Answer whether OOP is a Smalltalk String LEN characters long and
186    these characters match the first LEN characters of STR (which must
187    not have embedded NULs).  */
188 static mst_Boolean is_same_string (const char *str,
189 				   OOP oop,
190 				   int len);
191 
192 /* Allocate memory for a symbol of length LEN and whose contents are STR.
193    This function does not fill in the object's class because it is called
194    upon image loading, when the classes have not been initialized yet.  */
195 static OOP alloc_symbol_oop (const char *str, int len);
196 
197 /* Link SYMBOLOOP into the symbol table (using the given hash table index),
198    and fill the class slot of the symbol.  */
199 static OOP alloc_symlink (OOP symbolOOP, uintptr_t index);
200 
201 /* Answer whether C is considered a white space character in Smalltalk
202    programs.  */
203 static mst_Boolean is_white_space (char c);
204 
205 /* Free the list of symbols declared in the given SCOPE.  */
206 static void free_scope_symbols (scope scope);
207 
208 /* Scans a variable name (letters and digits, initial letter), and
209    return a symbol for it. PP is a pointer to a pointer to the start
210    of the string to be scanned, which may be pointing at either
211    whitespace or start of variable.  At end, it points to the first
212    character after the initial whitespace, if any.  ENDP instead is
213    initialized by the function to point to first character after the
214    parsed variable name, which may be NUL.  */
215 static void parse_variable_name (const char ** pp,
216 				 const char ** endp);
217 
218 /* This fills ENT's fields with the contents of its parameters.  */
219 static void fill_symbol_entry (symbol_entry * ent,
220 			       scope_type scope,
221 			       mst_Boolean readOnly,
222 			       OOP symbol,
223 			       int index,
224 			       unsigned int scopeDistance);
225 
226 /* Scans a variable name (letters and digits, initial letter), and
227    return a symbol for it. PP is a pointer to a pointer to the start
228    of the string to be scanned.  May be pointing at either whitespace
229    or start of variable.  At end, points to first character after the
230    parsed variable name, which may be NUL.  The output is a Smalltalk
231    Symbol, _gst_nil_oop if no variable name is found.  */
232 static OOP scan_name (const char ** pp);
233 
234 /* This creates a Symbol containing LEN bytes starting at STR and puts
235    it in the symbol list, or returns an existing one if it is
236    found.  */
237 static OOP intern_counted_string (const char *str,
238 				  int len);
239 
240 /* This is a hack.  It is the same as _gst_intern_string except that,
241    if the given symbol is pointed to by PTESTOOP, we increment
242    PTESTOOP and return the old value.  This works and speeds up image
243    loading, because we are careful to create the same symbols in
244    _gst_init_symbols_passN and _gst_restore_symbols.  */
245 static inline OOP
246 intern_string_fast (const char *str, OOP *pTestOOP);
247 
248 /* This looks for SYMBOL among the instance variables that the current
249    class declares, and returns the index of the variable if one is
250    found.  */
251 static int instance_variable_index (OOP symbol);
252 
253 /* This checks if the INDEX-th instance variable among those that the
254    current class declares is read-only.  Read-only index variables are
255    those that are declared by a trusted super-class of an untrusted
256    subclass.  */
257 static mst_Boolean is_instance_variable_read_only (int index);
258 
259 /* This looks for SYMBOL among the arguments and temporary variables
260    that the current scope sees, and returns the entry in the symbol
261    list for the variable if it is found.  */
262 static symbol_list find_local_var (scope scope,
263 				   OOP symbol);
264 
265 /* This looks for SYMBOL among the global variables that the current
266    scope sees, including superspaces if any, and returns the entry in
267    the symbol list for the variable if it is found.  */
268 static OOP find_class_variable (OOP varName);
269 
270 static scope cur_scope = NULL;
271 static pool_list linearized_pools = NULL;
272 
273 /* This is an array of symbols which the virtual machine knows about,
274    and is used to restore the global variables upon image load.  */
275 static const symbol_info sym_info[] = {
276   {&_gst_and_symbol, "and:"},
277   {&_gst_as_scaled_decimal_radix_scale_symbol, "asScaledDecimal:radix:scale:"},
278   {&_gst_bad_return_error_symbol, "badReturnError"},
279   {&_gst_byte_array_symbol, "byteArray"},
280   {&_gst_byte_array_out_symbol, "byteArrayOut"},
281   {&_gst_boolean_symbol, "boolean"},
282   {&_gst_c_object_symbol, "cObject"},
283   {&_gst_c_object_ptr_symbol, "cObjectPtr"},
284   {&_gst_category_symbol, "category:"},
285   {&_gst_char_symbol, "char"},
286   {&_gst_uchar_symbol, "uChar"},
287   {&_gst_does_not_understand_symbol, "doesNotUnderstand:"},
288   {&_gst_float_symbol, "float"},
289   {&_gst_double_symbol, "double"},
290   {&_gst_false_symbol, "false"},
291   {&_gst_if_false_if_true_symbol, "ifFalse:ifTrue:"},
292   {&_gst_if_false_symbol, "ifFalse:"},
293   {&_gst_if_true_if_false_symbol, "ifTrue:ifFalse:"},
294   {&_gst_if_true_symbol, "ifTrue:"},
295   {&_gst_int_symbol, "int"},
296   {&_gst_uint_symbol, "uInt"},
297   {&_gst_long_double_symbol, "longDouble"},
298   {&_gst_long_symbol, "long"},
299   {&_gst_ulong_symbol, "uLong"},
300   {&_gst_must_be_boolean_symbol, "mustBeBoolean"},
301   {&_gst_nil_symbol, "nil"},
302   {&_gst_or_symbol, "or:"},
303   {&_gst_primitive_symbol, "primitive:"},
304   {&_gst_repeat_symbol, "repeat"},
305   {&_gst_self_symbol, "self"},
306   {&_gst_self_smalltalk_symbol, "selfSmalltalk"},
307   {&_gst_short_symbol, "short"},
308   {&_gst_ushort_symbol, "uShort"},
309   {&_gst_smalltalk_symbol, "smalltalk"},
310   {&_gst_smalltalk_namespace_symbol, "Smalltalk"},
311   {&_gst_start_execution_symbol, "startExecution:"},
312   {&_gst_string_out_symbol, "stringOut"},
313   {&_gst_string_symbol, "string"},
314   {&_gst_super_symbol, "super"},
315   {&_gst_symbol_symbol, "symbol"},
316   {&_gst_symbol_out_symbol, "symbolOut"},
317   {&_gst_terminate_symbol, "__terminate"},
318   {&_gst_times_repeat_symbol, "timesRepeat:"},
319   {&_gst_to_by_do_symbol, "to:by:do:"},
320   {&_gst_to_do_symbol, "to:do:"},
321   {&_gst_true_symbol, "true"},
322   {&_gst_undeclared_symbol, "Undeclared"},
323   {&_gst_unknown_symbol, "unknown"},
324   {&_gst_value_with_rec_with_args_symbol, "valueWithReceiver:withArguments:"},
325   {&_gst_variadic_symbol, "variadic"},
326   {&_gst_variadic_smalltalk_symbol, "variadicSmalltalk"},
327   {&_gst_vm_primitives_symbol, "VMPrimitives"},
328   {&_gst_void_symbol, "void"},
329   {&_gst_wchar_symbol, "wchar"},
330   {&_gst_wstring_symbol, "wstring"},
331   {&_gst_wstring_out_symbol, "wstringOut"},
332   {&_gst_while_false_colon_symbol, "whileFalse:"},
333   {&_gst_while_false_symbol, "whileFalse"},
334   {&_gst_while_true_colon_symbol, "whileTrue:"},
335   {&_gst_while_true_symbol, "whileTrue"},
336   {NULL, NULL},
337 };
338 
339 
340 const char *
_gst_get_scope_kind(scope_type scope)341 _gst_get_scope_kind (scope_type scope)
342 {
343   switch (scope)
344     {
345     case SCOPE_TEMPORARY: return "argument";
346     case SCOPE_RECEIVER: return "instance variable";
347     case SCOPE_GLOBAL: return "global variable";
348     case SCOPE_SPECIAL: return "special variable";
349     default: abort ();
350     }
351 }
352 
353 int
_gst_get_arg_count(void)354 _gst_get_arg_count (void)
355 {
356   return (cur_scope->numArguments);
357 }
358 
359 int
_gst_get_temp_count(void)360 _gst_get_temp_count (void)
361 {
362   return (cur_scope->numTemporaries);
363 }
364 
365 void
_gst_push_new_scope(void)366 _gst_push_new_scope (void)
367 {
368   scope newScope;
369   newScope = (scope) xmalloc (sizeof (*newScope));
370   newScope->prevScope = cur_scope;
371   newScope->symbols = NULL;
372   newScope->numArguments = 0;
373   newScope->numTemporaries = 0;
374   cur_scope = newScope;
375 }
376 
377 void
_gst_pop_old_scope(void)378 _gst_pop_old_scope (void)
379 {
380   scope oldScope;
381 
382   oldScope = cur_scope;
383   cur_scope = cur_scope->prevScope;
384 
385   free_scope_symbols (oldScope);
386   xfree (oldScope);
387 }
388 
389 void
_gst_pop_all_scopes(void)390 _gst_pop_all_scopes (void)
391 {
392   pool_list next;
393 
394   while (cur_scope)
395     _gst_pop_old_scope ();
396 
397   while (linearized_pools)
398     {
399       next = linearized_pools->next;
400       xfree (linearized_pools);
401       linearized_pools = next;
402     }
403 }
404 
405 
406 int
_gst_declare_arguments(tree_node args)407 _gst_declare_arguments (tree_node args)
408 {
409   if (args->nodeType == TREE_UNARY_EXPR)
410     return (0);
411 
412   else if (args->nodeType == TREE_BINARY_EXPR)
413     _gst_declare_name (args->v_expr.expression->v_list.name, false, false);
414 
415   else
416     {
417       for (args = args->v_expr.expression; args != NULL;
418 	   args = args->v_list.next)
419 	if (_gst_declare_name (args->v_list.value->v_list.name, false, false) == -1)
420 	  return -1;
421     }
422 
423   /* Arguments are always declared first! */
424   cur_scope->numArguments = cur_scope->numTemporaries;
425   cur_scope->numTemporaries = 0;
426   return (cur_scope->numArguments);
427 }
428 
429 int
_gst_declare_temporaries(tree_node temps)430 _gst_declare_temporaries (tree_node temps)
431 {
432   int n;
433   for (n = 0; temps != NULL; n++, temps = temps->v_list.next)
434     if (_gst_declare_name (temps->v_list.name, true, false) == -1)
435       return -1;
436 
437   return (n);
438 }
439 
440 int
_gst_declare_block_arguments(tree_node args)441 _gst_declare_block_arguments (tree_node args)
442 {
443   for (; args != NULL; args = args->v_list.next)
444     if (_gst_declare_name (args->v_list.name, false, false) == -1)
445       return -1;
446 
447   /* Arguments are always declared first! */
448   cur_scope->numArguments = cur_scope->numTemporaries;
449   cur_scope->numTemporaries = 0;
450   return (cur_scope->numArguments);
451 }
452 
453 void
_gst_undeclare_name(void)454 _gst_undeclare_name (void)
455 {
456   symbol_list oldList;
457 
458   oldList = cur_scope->symbols;
459   cur_scope->symbols = cur_scope->symbols->prevSymbol;
460   xfree (oldList);
461 }
462 
463 
464 int
_gst_declare_name(const char * name,mst_Boolean writeable,mst_Boolean allowDup)465 _gst_declare_name (const char *name,
466 		   mst_Boolean writeable,
467 		   mst_Boolean allowDup)
468 {
469   symbol_list newList;
470   OOP symbol = _gst_intern_string (name);
471 
472   if (!allowDup && find_local_var (cur_scope, symbol) != NULL)
473     return -1;
474 
475   newList = (symbol_list) xmalloc (sizeof (struct symbol_list));
476   newList->symbol = symbol;
477   newList->index = cur_scope->numArguments + cur_scope->numTemporaries;
478   newList->readOnly = !writeable;
479   newList->prevSymbol = cur_scope->symbols;
480 
481   /* Arguments are always declared first, so we can assume it is a
482      temporary -- if it is not, _gst_declare_arguments and
483      _gst_declare_block_arguments will fix it.  */
484   cur_scope->numTemporaries++;
485   cur_scope->symbols = newList;
486   return (newList->index);
487 }
488 
489 
490 static void
free_scope_symbols(scope scope)491 free_scope_symbols (scope scope)
492 {
493   symbol_list oldList;
494 
495   for (oldList = scope->symbols; oldList != NULL;
496        oldList = scope->symbols)
497     {
498       scope->symbols = oldList->prevSymbol;
499       xfree (oldList);
500     }
501 }
502 
503 /* Here are some notes on the design of the shared pool resolution order,
504    codenamed "TwistedPools".
505 
506    The design should maintain a sense of containment within namespaces,
507    while still allowing reference to all inherited environments, as is
508    traditionally expected.
509 
510    The fundamental problem is that when a subclass is not in the same
511    namespace as the superclass, we want to give a higher priority to
512    the symbols in the namespaces imported by the subclass, than to the
513    symbols in the superclass namespaces.  As such, no simple series of
514    walks up the inheritance tree paired with pool-adds will give us a
515    good search order.  Instead, we build a complete linearization of
516    the namespaces (including the superspaces) and look up a symbol in
517    each namespace locally, without looking at the superspaces.
518 
519    This is the essential variable search algorithm for TwistedPools.
520 
521    1. Given a class, starting with the method-owning class:
522 
523       a. Search the class pool.
524 
525       b. Search this class's shared pools in topological order,
526          left-to-right, skipping any pools that are any of
527          this class's namespace or superspaces.
528 
529       c. Search this class's namespace and each superspace in turn
530          before first encounter of a namespace that contains, directly or
531          indirectly, the superclass. This means that if the superclass is
532          in the same namespace or a subspace, no namespaces are searched.
533 
534    2. Move to the superclass, and repeat from #1.
535 
536    Combination details
537    ===================
538 
539    While the add-namespaces step above could be less eager to add namespaces,
540    by allowing any superclass to stop the namespace crawl, rather than
541    just the direct superclasses, it is already less eager than the shared
542    pool manager. The topological sort is an obviously good choice, but
543    why not allow superclasses' namespaces to provide deletions as well
544    as the pool-containing class? While both alternatives have benefits,
545    an eager import of all superspaces, besides those that already contain
546    the pool-containing class, would most closely match what's expected.
547 
548    An argument could also be made that by adding a namespace to shared pools,
549    you expect all superspaces to be included. However, consider the usual
550    case of namespaces in shared pools: imports. While you would want it to
551    completely load an alternate namespace hierarchy, I think you would not
552    want it to inject Smalltalk early into the variable search. Consider
553    this diagram:
554 
555                Smalltalk
556                    |
557                MyCompany
558                /      \
559               /        \
560          MyProject     MyLibrary
561             /            /    \
562            /           ModA   ModB
563      MyLibModule
564 
565     If you were to use ModB as a pool in a class in MyLibModule, I think
566     it is most reasonable that ModB and MyLibrary be immediately imported,
567     but MyCompany and Smalltalk wait until you reach that point in the
568     namespace walk.  In other words, pools only add that part of themselves,
569     which would not be otherwise reachable via the class environment.
570 
571     (Note that, as a side effect, adding MyCompany as a pool will have
572     no effect).
573 
574     Another argument could be made to delay further the namespace walk,
575     waiting to resolve until no superclass is contained in a given namespace,
576     based on the idea of exiting a namespace hierarchy while walking
577     superclasses, then reentering it. Disregarding the unlikelihood of such
578     an organization, it probably would be less confusing to resolve the
579     hierarchy being left first, in case the interloping hierarchy introduces
580     conflicting symbols of its own.
581 
582     There is no objective argument regarding the above points of
583     contention, and no formal proofs, because convenient global name
584     resolution is entirely a matter of feeling, because a formal
585     programmer could always explicitly spell out the path to every
586     variable.
587 
588     Namespaces also have imports (shared pools) of their own, thereby
589     allowing users to import external namespaces for every class in a
590     namespace, rather than each class.  These shared pools should also
591     twist nicely.
592 
593     Here is how I think it would best work: after searching any
594     namespace, combine its shared pools as classes' shared pools are
595     combined, removing all elements that are any of this namespace or
596     its superspaces, and search the combination from left to right.
597 
598     There is one important difference between namespace-sharedpools
599     and class-sharedpools: while class sharedpools export their
600     imports to subclasses, namespaces should not reexport bindings
601     made available by way of shared pools.  As such, the bindings
602     provided by a namespace are only available when compiling methods
603     that actually exist in that namespace (including its subspaces).  */
604 
605 
606 OOP
_gst_get_class_object(OOP classOOP)607 _gst_get_class_object (OOP classOOP)
608 {
609   if (OOP_CLASS (classOOP) == _gst_metaclass_class)
610     classOOP = METACLASS_INSTANCE (classOOP);
611 
612   while (OOP_CLASS (classOOP) == _gst_behavior_class
613 	 || OOP_CLASS (classOOP) == _gst_class_description_class)
614     classOOP = SUPERCLASS (classOOP);
615 
616   return classOOP;
617 }
618 
619 
620 /* Add poolOOP after the node whose next pointer is in P_END.  Return
621    the new next node (actually its next pointer).  */
622 
623 static pool_list *
add_pool(OOP poolOOP,pool_list * p_end)624 add_pool (OOP poolOOP, pool_list *p_end)
625 {
626   pool_list entry;
627   if (IS_NIL (poolOOP))
628     return p_end;
629 
630   entry = xmalloc (sizeof (struct pool_list));
631   entry->poolOOP = poolOOP;
632   entry->next = NULL;
633 
634   *p_end = entry;
635   return &entry->next;
636 }
637 
638 
639 /* Make a pointer set with POOLOOP and all of its superspaces.  */
640 
641 static struct pointer_set_t *
make_with_all_superspaces_set(OOP poolOOP)642 make_with_all_superspaces_set (OOP poolOOP)
643 {
644   struct pointer_set_t *pset = pointer_set_create ();
645   if (is_a_kind_of (OOP_CLASS (poolOOP), _gst_class_class))
646     poolOOP = _gst_class_variable_dictionary (poolOOP);
647 
648   while (is_a_kind_of (OOP_CLASS (poolOOP), _gst_abstract_namespace_class))
649     {
650       gst_namespace pool;
651       pointer_set_insert (pset, poolOOP);
652       pool = (gst_namespace) OOP_TO_OBJ (poolOOP);
653       poolOOP = pool->superspace;
654     }
655 
656   /* Add the last if not nil.  */
657   if (is_a_kind_of (OOP_CLASS (poolOOP), _gst_dictionary_class))
658     pointer_set_insert (pset, poolOOP);
659   return pset;
660 }
661 
662 /* predeclared for add_namespace */
663 static pool_list *combine_local_pools
664   (OOP sharedPoolsOOP, struct pointer_set_t *white, pool_list *p_end);
665 
666 /* Add, after the node whose next pointer is in P_END, the namespace
667    POOLOOP and all of its superspaces except those in EXCEPT.
668    The new last node is returned (actually its next pointer).  */
669 
670 static pool_list *
add_namespace(OOP poolOOP,struct pointer_set_t * except,pool_list * p_end)671 add_namespace (OOP poolOOP, struct pointer_set_t *except, pool_list *p_end)
672 {
673   if (is_a_kind_of (OOP_CLASS (poolOOP), _gst_class_class))
674     poolOOP = _gst_class_variable_dictionary (poolOOP);
675 
676   for (;;)
677     {
678       gst_namespace pool;
679       OOP importsOOP;
680       if (!is_a_kind_of (OOP_CLASS (poolOOP), _gst_dictionary_class))
681         return p_end;
682 
683       if (!except || !pointer_set_contains (except, poolOOP))
684         p_end = add_pool (poolOOP, p_end);
685 
686       /* Add imports and try to find a super-namespace */
687       if (!is_a_kind_of (OOP_CLASS (poolOOP), _gst_abstract_namespace_class))
688         return p_end;
689 
690       pool = (gst_namespace) OOP_TO_OBJ (poolOOP);
691       importsOOP = pool->sharedPools;
692       if (NUM_OOPS (OOP_TO_OBJ (importsOOP)))
693 	{
694 	  struct pointer_set_t *pset;
695 	  pset = make_with_all_superspaces_set (poolOOP);
696 	  p_end = combine_local_pools (importsOOP, pset, p_end);
697 	  pointer_set_destroy (pset);
698 	}
699 
700       poolOOP = pool->superspace;
701     }
702 }
703 
704 
705 /* Add POOLOOP and all of its superspaces to the list in the right order:
706 
707    1. Start a new list.
708 
709    2. From right to left, descend into each given pool not visited.
710 
711    3. Recursively visit the superspace, then...
712 
713    4. Mark this pool as visited, and add to the beginning of #1's list.
714 
715    5. After all recursions exit, the list is appended at the end of the
716       linearized list of pools.
717 
718    This function takes care of 3-4.  These two steps implement
719    a topological sort on the reverse of the namespace tree; it is
720    explicitly modeled after CLOS class precedence.  */
721 
722 static void
visit_pool(OOP poolOOP,struct pointer_set_t * grey,struct pointer_set_t * white,pool_list * p_head,pool_list * p_tail)723 visit_pool (OOP poolOOP, struct pointer_set_t *grey,
724 	    struct pointer_set_t *white,
725 	    pool_list *p_head, pool_list *p_tail)
726 {
727   pool_list entry;
728 
729   if (is_a_kind_of (OOP_CLASS (poolOOP), _gst_class_class))
730     poolOOP = _gst_class_variable_dictionary (poolOOP);
731   if (!is_a_kind_of (OOP_CLASS (poolOOP), _gst_dictionary_class))
732     return;
733 
734   if (pointer_set_contains (white, poolOOP))
735     return;
736 
737   if (pointer_set_contains (grey, poolOOP))
738     {
739       _gst_errorf ("circular dependency in pool dictionaries");
740       return;
741     }
742 
743   /* Visit the super-namespace first, this amounts to processing the
744      hierarchy in reverse order (see Class>>#allSharedPoolDictionariesDo:). */
745   pointer_set_insert (grey, poolOOP);
746   if (is_a_kind_of (OOP_CLASS (poolOOP), _gst_abstract_namespace_class))
747     {
748       gst_namespace pool = (gst_namespace) OOP_TO_OBJ (poolOOP);
749       if (!IS_NIL (pool->superspace))
750 	visit_pool (pool->superspace, grey, white, p_head, p_tail);
751     }
752   pointer_set_insert (white, poolOOP);
753 
754   /* Add an entry for this one at the beginning of the list.  We need
755      to maintain the tail too, because combine_local_pools must return
756      it.  */
757   entry = xmalloc (sizeof (struct pool_list));
758   entry->poolOOP = poolOOP;
759   entry->next = *p_head;
760   *p_head = entry;
761   if (!*p_tail)
762     *p_tail = entry;
763 }
764 
765 /* Run visit_pool on all the shared pools, starting with WHITE as
766    the visited set so that those are not added.  The resulting
767    list is built separately, and at the end all of the namespaces
768    in the list are tacked after the node whose next pointer is
769    in P_END.  The new last node is returned (actually its next pointer).  */
770 
771 static pool_list *
combine_local_pools(OOP sharedPoolsOOP,struct pointer_set_t * white,pool_list * p_end)772 combine_local_pools (OOP sharedPoolsOOP, struct pointer_set_t *white, pool_list *p_end)
773 {
774   struct pointer_set_t *grey = pointer_set_create ();
775   pool_list head = NULL;
776   pool_list tail = NULL;
777   int numPools, i;
778 
779   /* Visit right-to-left because visit_pool adds to the beginning.  */
780   numPools = NUM_OOPS (OOP_TO_OBJ (sharedPoolsOOP));
781   for (i = numPools; --i >= 0; )
782     {
783       OOP poolDictionaryOOP = ARRAY_AT (sharedPoolsOOP, i + 1);
784       visit_pool (poolDictionaryOOP, grey, white, &head, &tail);
785     }
786 
787   pointer_set_destroy (grey);
788   if (head)
789     {
790       /* If anything was found, tack the list after P_END and return
791 	 the new tail.  */
792       *p_end = head;
793       return &tail->next;
794     }
795   else
796     return p_end;
797 }
798 
799 
800 /* Add the list of resolved pools for CLASS_OOP.  This includes:
801    1) its class pool; 2) its shared pools as added by
802    combine_local_pools, and excluding those found from the
803    environment; 3) the environment and its superspaces,
804    excluding those reachable also from the environment of
805    the superclass.  */
806 
807 static pool_list *
add_local_pool_resolution(OOP class_oop,pool_list * p_end)808 add_local_pool_resolution (OOP class_oop, pool_list *p_end)
809 {
810   OOP environmentOOP;
811   gst_class class;
812   struct pointer_set_t *pset;
813 
814   /* First search in the class pool.  */
815   p_end = add_pool (_gst_class_variable_dictionary (class_oop), p_end);
816 
817   /* Then in all the imports not reachable from the environment.  */
818   class = (gst_class) OOP_TO_OBJ (class_oop);
819   environmentOOP = class->environment;
820   pset = make_with_all_superspaces_set (environmentOOP);
821   p_end = combine_local_pools (class->sharedPools, pset, p_end);
822   pointer_set_destroy (pset);
823 
824   /* Then search in the `environments', except those that are already
825      reachable from the superclass. */
826   class_oop = SUPERCLASS (class_oop);
827   class = (gst_class) OOP_TO_OBJ (class_oop);
828   if (!IS_NIL (class_oop))
829     pset = make_with_all_superspaces_set (class->environment);
830   else
831     pset = NULL;
832 
833   p_end = add_namespace (environmentOOP, pset, p_end);
834   if (pset)
835     pointer_set_destroy (pset);
836   return p_end;
837 }
838 
839 OOP
find_class_variable(OOP varName)840 find_class_variable (OOP varName)
841 {
842   pool_list pool;
843   OOP assocOOP;
844 
845   if (!linearized_pools)
846     {
847       pool_list *p_end = &linearized_pools;
848       OOP myClass;
849 
850       /* Add pools separately for each class.  */
851       for (myClass = _gst_get_class_object (_gst_this_class); !IS_NIL (myClass);
852            myClass = SUPERCLASS (myClass))
853         p_end = add_local_pool_resolution (myClass, p_end);
854     }
855 
856   for (pool = linearized_pools; pool; pool = pool->next)
857     {
858       assocOOP =
859 	dictionary_association_at (pool->poolOOP, varName);
860 
861       if (!IS_NIL (assocOOP))
862 	return (assocOOP);
863     }
864 
865   return (_gst_nil_oop);
866 }
867 
868 
869 int
_gst_set_undeclared(enum undeclared_strategy new)870 _gst_set_undeclared (enum undeclared_strategy new)
871 {
872   enum undeclared_strategy old = _gst_use_undeclared;
873   if (new != UNDECLARED_CURRENT)
874     _gst_use_undeclared = new;
875   return old;
876 }
877 
878 OOP
_gst_push_temporaries_dictionary(void)879 _gst_push_temporaries_dictionary (void)
880 {
881   OOP old = temporaries_dictionary;
882   temporaries_dictionary = _gst_dictionary_new (8);
883   _gst_register_oop (temporaries_dictionary);
884   return old;
885 }
886 
887 void
_gst_pop_temporaries_dictionary(OOP dictionaryOOP)888 _gst_pop_temporaries_dictionary (OOP dictionaryOOP)
889 {
890   _gst_unregister_oop (temporaries_dictionary);
891   temporaries_dictionary = dictionaryOOP;
892 }
893 
894 
895 tree_node
_gst_find_variable_binding(tree_node list)896 _gst_find_variable_binding (tree_node list)
897 {
898   OOP symbol, root, assocOOP;
899   tree_node elt;
900 
901   symbol = _gst_intern_string (list->v_list.name);
902   assocOOP = find_class_variable (symbol);
903 
904   for (elt = list; assocOOP != _gst_nil_oop && (elt = elt->v_list.next); )
905     {
906       root = ASSOCIATION_VALUE (assocOOP);
907       symbol = _gst_intern_string (elt->v_list.name);
908       assocOOP = _gst_namespace_association_at (root, symbol);
909     }
910 
911   if (!IS_NIL (assocOOP))
912     return _gst_make_oop_constant (&list->location, assocOOP);
913 
914   else if (_gst_use_undeclared == UNDECLARED_GLOBALS
915 	   && !elt->v_list.next
916 	   && isupper (*STRING_OOP_CHARS (symbol)))
917     {
918       OOP dictOOP = dictionary_at (_gst_smalltalk_dictionary,
919 				   _gst_undeclared_symbol);
920       assocOOP = _gst_namespace_association_at (dictOOP, symbol);
921       if (IS_NIL (assocOOP))
922         assocOOP = NAMESPACE_AT_PUT (dictOOP, symbol, _gst_nil_oop);
923       return _gst_make_oop_constant (&list->location, assocOOP);
924     }
925 
926   /* For temporaries, make a deferred binding so that we can try using
927      a global variable.  Unlike namespaces, the temporaries dictionary
928      does not know anything about Undeclared.  */
929   else if (_gst_use_undeclared == UNDECLARED_TEMPORARIES)
930     return _gst_make_deferred_binding_constant (&list->location, list);
931 
932   else
933     return NULL;
934 }
935 
936 OOP
_gst_get_undeclared_dictionary()937 _gst_get_undeclared_dictionary ()
938 {
939   assert (_gst_use_undeclared == UNDECLARED_TEMPORARIES);
940   return temporaries_dictionary;
941 }
942 
943 mst_Boolean
_gst_find_variable(symbol_entry * se,tree_node list)944 _gst_find_variable (symbol_entry * se,
945 		    tree_node list)
946 {
947   tree_node resolved;
948   int index;
949   unsigned int scopeDistance;
950   scope scope;
951   symbol_list s;
952   OOP varAssoc;
953   OOP symbol;
954 
955   symbol = _gst_intern_string (list->v_list.name);
956   if (symbol == _gst_self_symbol || symbol == _gst_super_symbol)
957     {
958       fill_symbol_entry (se, SCOPE_SPECIAL, true, symbol, RECEIVER_INDEX,
959 			 0);
960       return (true);
961     }
962   else if (symbol == _gst_true_symbol)
963     {
964       fill_symbol_entry (se, SCOPE_SPECIAL, true, symbol, TRUE_INDEX, 0);
965       return (true);
966     }
967   else if (symbol == _gst_false_symbol)
968     {
969       fill_symbol_entry (se, SCOPE_SPECIAL, true, symbol, FALSE_INDEX,
970 			 0);
971       return (true);
972     }
973   else if (symbol == _gst_nil_symbol)
974     {
975       fill_symbol_entry (se, SCOPE_SPECIAL, true, symbol, NIL_INDEX, 0);
976       return (true);
977     }
978   else if (symbol == _gst_builtin_selectors[THIS_CONTEXT_SPECIAL].symbol)
979     {
980       fill_symbol_entry (se, SCOPE_SPECIAL, true, symbol,
981 			 THIS_CONTEXT_INDEX, 0);
982       return (true);
983     }
984 
985   for (scope = cur_scope, scopeDistance = 0; scope != NULL;
986        scope = scope->prevScope, scopeDistance++)
987     {
988       s = find_local_var (scope, symbol);
989       if (s)
990 	{
991 	  fill_symbol_entry (se, SCOPE_TEMPORARY,
992 			     s->readOnly, symbol, s->index,
993 			     scopeDistance);
994 	  return (true);
995 	}
996     }
997 
998   index = instance_variable_index (symbol);
999   if (index >= 0)
1000     {
1001       fill_symbol_entry (se, SCOPE_RECEIVER,
1002 			 is_instance_variable_read_only (index),
1003 			 symbol, index, 0);
1004       return (true);
1005     }
1006 
1007   resolved = _gst_find_variable_binding (list);
1008   if (!resolved)
1009     return (false);
1010 
1011   varAssoc = _gst_make_constant_oop (resolved);
1012   index = _gst_add_forced_object (varAssoc);
1013 
1014   fill_symbol_entry (se, SCOPE_GLOBAL,
1015 		     _gst_untrusted_methods && !IS_OOP_UNTRUSTED (varAssoc),
1016 		     varAssoc, index, 0);
1017   return (true);
1018 }
1019 
1020 static mst_Boolean
is_instance_variable_read_only(int index)1021 is_instance_variable_read_only (int index)
1022 {
1023   int numVars;
1024   OOP class_oop;
1025 
1026   if (!_gst_untrusted_methods)
1027     return (false);
1028 
1029   for (class_oop = _gst_this_class; IS_OOP_UNTRUSTED (class_oop);
1030        class_oop = SUPERCLASS (class_oop))
1031     ;
1032 
1033   numVars = CLASS_FIXED_FIELDS (class_oop);
1034   return index + 1 <= numVars;
1035 }
1036 
1037 static int
instance_variable_index(OOP symbol)1038 instance_variable_index (OOP symbol)
1039 {
1040   OOP arrayOOP;
1041   int index, numVars;
1042 
1043   arrayOOP = _gst_instance_variable_array (_gst_this_class);
1044   numVars = NUM_OOPS (OOP_TO_OBJ (arrayOOP));
1045 
1046   for (index = numVars; index >= 1; index--)
1047     if (ARRAY_AT (arrayOOP, index) == symbol)
1048       return (index - 1);
1049 
1050   return (-1);
1051 }
1052 
1053 
1054 static symbol_list
find_local_var(scope scope,OOP symbol)1055 find_local_var (scope scope,
1056 		OOP symbol)
1057 {
1058   symbol_list s;
1059 
1060   for (s = scope->symbols; s != NULL && symbol != s->symbol;
1061        s = s->prevSymbol);
1062 
1063   return (s);
1064 }
1065 
1066 static void
fill_symbol_entry(symbol_entry * ent,scope_type scope,mst_Boolean readOnly,OOP symbol,int index,unsigned int scopeDistance)1067 fill_symbol_entry (symbol_entry * ent,
1068 		   scope_type scope,
1069 		   mst_Boolean readOnly,
1070 		   OOP symbol,
1071 		   int index,
1072 		   unsigned int scopeDistance)
1073 {
1074   ent->scope = scope;
1075   ent->readOnly = readOnly;
1076   ent->symbol = symbol;
1077   ent->varIndex = index;
1078   ent->scopeDistance = scopeDistance;
1079 }
1080 
1081 void
_gst_print_symbol_entry(symbol_entry * ent)1082 _gst_print_symbol_entry (symbol_entry * ent)
1083 {
1084   printf ("%#O", ent->symbol);
1085   switch (ent->scope)
1086     {
1087     case SCOPE_RECEIVER:
1088       printf (" (inst.var. #%d)", ent->varIndex);
1089       break;
1090 
1091     case SCOPE_GLOBAL:
1092       printf (" (global)");
1093       break;
1094 
1095     case SCOPE_TEMPORARY:
1096       printf (" (temp.var. #");
1097       if (ent->scopeDistance)
1098 	printf ("%d.", ent->scopeDistance);
1099 
1100       printf ("%d)", ent->varIndex);
1101       break;
1102 
1103     case SCOPE_SPECIAL:
1104       printf (" (special)");
1105       break;
1106     }
1107 }
1108 
1109 
1110 
1111 OOP
_gst_find_pragma_handler(OOP classOOP,OOP symbolOOP)1112 _gst_find_pragma_handler (OOP classOOP,
1113 			  OOP symbolOOP)
1114 {
1115   OOP class_oop, myClass;
1116 
1117   myClass = _gst_get_class_object (_gst_this_class);
1118 
1119   /* Now search in the class pools */
1120   for (class_oop = myClass; !IS_NIL (class_oop);
1121        class_oop = SUPERCLASS (class_oop))
1122     {
1123       gst_class class = (gst_class) OOP_TO_OBJ (class_oop);
1124       OOP handlerOOP;
1125 
1126       if (IS_NIL (class->pragmaHandlers))
1127 	continue;
1128 
1129       handlerOOP = _gst_identity_dictionary_at (class->pragmaHandlers,
1130                                                 symbolOOP);
1131       if (!IS_NIL (handlerOOP))
1132 	return handlerOOP;
1133     }
1134 
1135   return (_gst_nil_oop);
1136 }
1137 
1138 OOP
_gst_make_instance_variable_array(OOP superclassOOP,const char * variableString)1139 _gst_make_instance_variable_array (OOP superclassOOP,
1140 				   const char * variableString)
1141 {
1142   OOP arrayOOP, superArrayOOP, name;
1143   int index, numInstanceVars, superInstanceVars;
1144   const char *p;
1145   inc_ptr incPtr;
1146   gst_object array;
1147 
1148   if (variableString == NULL)
1149     variableString = "";
1150 
1151   if (IS_NIL (superclassOOP))
1152     {
1153       superArrayOOP = _gst_nil_oop;
1154       superInstanceVars = numInstanceVars = 0;
1155     }
1156   else
1157     {
1158       superArrayOOP = _gst_instance_variable_array (superclassOOP);
1159       superInstanceVars = numInstanceVars =
1160 	NUM_OOPS (OOP_TO_OBJ (superArrayOOP));
1161     }
1162 
1163   for (p = variableString; *p;)
1164     {
1165       /* skip intervening whitespace */
1166       name = scan_name (&p);
1167       if (!IS_NIL (name))
1168 	numInstanceVars++;
1169     }
1170 
1171   if (numInstanceVars == 0)
1172     return (_gst_nil_oop);	/* no instances here */
1173 
1174   incPtr = INC_SAVE_POINTER ();
1175 
1176   array = instantiate_with (_gst_array_class, numInstanceVars, &arrayOOP);
1177   INC_ADD_OOP (arrayOOP);
1178 
1179   /* inherit variables from parent */
1180   for (index = 1; index <= superInstanceVars; index++)
1181     array->data[index - 1] = ARRAY_AT (superArrayOOP, index);
1182 
1183   /* now add our own variables */
1184   for (p = variableString; *p; index++)
1185     {
1186       /* skip intervening whitespace */
1187       name = scan_name (&p);
1188       /* don't need to add name to incubator -- it's a symbol so it's
1189          already held onto */
1190 
1191       array = OOP_TO_OBJ (arrayOOP);
1192       if (!IS_NIL (name))
1193 	array->data[index - 1] = name;
1194     }
1195 
1196   INC_RESTORE_POINTER (incPtr);
1197   return (arrayOOP);
1198 }
1199 
1200 OOP
_gst_make_class_variable_dictionary(const char * variableNames,OOP classOOP)1201 _gst_make_class_variable_dictionary (const char *variableNames,
1202 				     OOP classOOP)
1203 {
1204   OOP dictionaryOOP, name;
1205   const char *p;
1206   inc_ptr incPtr;
1207 
1208   if (variableNames == NULL)
1209     variableNames = "";
1210 
1211   incPtr = INC_SAVE_POINTER ();
1212 
1213   dictionaryOOP = _gst_nil_oop;
1214   for (p = variableNames; *p;)
1215     {
1216       name = scan_name (&p);
1217       if (!IS_NIL (name))
1218 	{
1219 	  if (IS_NIL (dictionaryOOP))
1220 	    {
1221 	      dictionaryOOP = _gst_binding_dictionary_new (8, classOOP);
1222 	      INC_ADD_OOP (dictionaryOOP);
1223 	    }
1224 
1225 	  /* ### error if already exists */
1226 	  /* don't need to add name to incubator -- it's a symbol so
1227 	     it's already held onto */
1228 	  NAMESPACE_AT_PUT (dictionaryOOP, name, _gst_nil_oop);
1229 	}
1230     }
1231 
1232   INC_RESTORE_POINTER (incPtr);
1233   return (dictionaryOOP);
1234 }
1235 
1236 OOP
_gst_make_pool_array(const char * poolNames)1237 _gst_make_pool_array (const char * poolNames)
1238 {
1239   OOP poolsOOP, name;
1240   gst_object pools;
1241   int numPools, i;
1242   const char *p, *e;
1243   inc_ptr incPtr;
1244 
1245   if (poolNames == NULL)
1246     poolNames = (char *) "";
1247 
1248   /* count the number of new pool names */
1249   for (p = poolNames, numPools = 0; *p;)
1250     {
1251       parse_variable_name (&p, &e);
1252       if (p != e)
1253 	{
1254 	  numPools++;
1255 	  p = e;
1256 	}
1257     }
1258 
1259   incPtr = INC_SAVE_POINTER ();
1260 
1261   poolsOOP = _gst_nil_oop;	/* ### maybe change this to leave empty
1262 				   array */
1263 
1264   for (p = poolNames, i = 0; *p; i++)
1265     {
1266       name = scan_name (&p);
1267       if (!IS_NIL (name))
1268 	{
1269 	  /* don't need to add name to incubator -- it's a symbol so
1270 	     it's already held onto.  */
1271 
1272 	  /* ### error if already exists in parent?, or if value isn't
1273 	     a dictionary */
1274 	  /* ### should I keep these as names? or associations? Should
1275 	     I look up the names somewhere other than in the smalltalk
1276 	     dictionary? Need to check for undefineds? */
1277 	  if (poolsOOP == _gst_nil_oop)
1278 	    {
1279 	      instantiate_with (_gst_array_class, numPools, &poolsOOP);
1280 	      INC_ADD_OOP (poolsOOP);
1281 	    }
1282 
1283 	  pools = OOP_TO_OBJ (poolsOOP);
1284 	  pools->data[i] = dictionary_at (_gst_smalltalk_dictionary,
1285 					  name);
1286 	}
1287     }
1288 
1289 
1290   INC_RESTORE_POINTER (incPtr);
1291   return (poolsOOP);
1292 }
1293 
1294 
1295 
1296 static OOP
scan_name(const char ** pp)1297 scan_name (const char ** pp)
1298 {
1299   const char *end;
1300   char *str;
1301   size_t len;
1302 
1303   parse_variable_name (pp, &end);
1304   len = end - *pp;
1305   if (len == 0)
1306     return (_gst_nil_oop);
1307 
1308   str = (char *) alloca (len + 1);
1309   strncpy (str, *pp, len);
1310   str[len] = '\0';
1311 
1312   *pp = end;
1313 
1314   return (_gst_intern_string (str));
1315 }
1316 
1317 static void
parse_variable_name(const char ** pp,const char ** endp)1318 parse_variable_name (const char ** pp,
1319 		     const char ** endp)
1320 {
1321   const char *p, *e;
1322 
1323   p = *pp;
1324   while (is_white_space (*p))
1325     p++;
1326   *pp = p;
1327 
1328   /* check for non-null here and not alnum; we've jammed on a bogus
1329      char and it's an error */
1330 
1331   if (isalpha (*p)) {
1332     /* variable name extends from p to e-1 */
1333     for (e = p; *e; e++)
1334       if (!isalnum (*e) && *e != '_')
1335 	break;
1336 
1337     *endp = e;
1338   } else
1339     *endp = p;
1340 }
1341 
1342 static mst_Boolean
is_white_space(char c)1343 is_white_space (char c)
1344 {
1345   return (c == ' ' || c == '\r' || c == '\t' || c == '\n' || c == '\f');
1346 }
1347 
1348 
1349 
1350 OOP
_gst_intern_string_oop(OOP stringOOP)1351 _gst_intern_string_oop (OOP stringOOP)
1352 {
1353   unsigned int len;
1354   char copyBuf[100], *copyPtr;
1355   OOP symbolOOP;
1356 
1357   len = _gst_string_oop_len (stringOOP);
1358 
1359   /* do this slightly more complicated bit of code because: 1) we don't
1360      want to call malloc/free if we can help it 2) if we just used
1361      STRING_OOP_CHARS (as we used to), we pass the *dereferenced* value
1362      of the stringOOP.  intern_counted_string can do allocations.  If
1363      it allocates, and the gc runs, stringOOP can move, meaning the
1364      dereferenced set of chars becomes invalid.  So instead we make a
1365      non-moving copy and use that.  */
1366   if (len < sizeof (copyBuf))
1367     copyPtr = copyBuf;
1368   else
1369     copyPtr = (char *) xmalloc (len);
1370 
1371   memcpy (copyPtr, STRING_OOP_CHARS (stringOOP), len);
1372 
1373   symbolOOP = intern_counted_string (copyPtr, len);
1374 
1375   if (len >= sizeof (copyBuf))
1376     xfree (copyPtr);
1377 
1378   return symbolOOP;
1379 }
1380 
1381 OOP
_gst_intern_string(const char * str)1382 _gst_intern_string (const char *str)
1383 {
1384   int len;
1385 
1386   len = strlen (str);
1387   return (intern_counted_string (str, len));
1388 }
1389 
1390 static uintptr_t
hash_symbol(const char * str,int len)1391 hash_symbol (const char *str, int len)
1392 {
1393   uintptr_t index = scramble (_gst_hash_string (str, len));
1394   return (index & (SYMBOL_TABLE_SIZE - 1)) + 1;
1395 }
1396 
1397 static OOP
alloc_symlink(OOP symbolOOP,uintptr_t index)1398 alloc_symlink (OOP symbolOOP, uintptr_t index)
1399 {
1400   gst_symbol symbol;
1401   sym_link link;
1402   OOP linkOOP;
1403 
1404   symbol = (gst_symbol) OOP_TO_OBJ (symbolOOP);
1405   symbol->objClass = _gst_symbol_class;
1406 
1407   link = (sym_link) new_instance (_gst_sym_link_class, &linkOOP);
1408   link->nextLink = ARRAY_AT (_gst_symbol_table, index);
1409   link->symbol = symbolOOP;
1410   ARRAY_AT_PUT (_gst_symbol_table, index, linkOOP);
1411 
1412   return (symbolOOP);
1413 }
1414 
1415 static OOP
intern_counted_string(const char * str,int len)1416 intern_counted_string (const char *str,
1417 		       int len)
1418 {
1419   uintptr_t index;
1420   OOP symbolOOP, linkOOP;
1421   sym_link link;
1422   inc_ptr incPtr;
1423 
1424   index = hash_symbol (str, len);
1425   for (linkOOP = ARRAY_AT (_gst_symbol_table, index); !IS_NIL (linkOOP);
1426        linkOOP = link->nextLink)
1427     {
1428       link = (sym_link) OOP_TO_OBJ (linkOOP);
1429       if (is_same_string (str, link->symbol, len))
1430 	return (link->symbol);
1431     }
1432 
1433   /* no match, have to add it to head of list */
1434 #ifdef HAVE_READLINE
1435   _gst_add_symbol_completion (str, len);
1436 #endif
1437 
1438   incPtr = INC_SAVE_POINTER ();
1439   symbolOOP = alloc_symbol_oop (str, len);
1440   INC_ADD_OOP (symbolOOP);
1441 
1442   alloc_symlink (symbolOOP, index);
1443   INC_RESTORE_POINTER (incPtr);
1444 
1445   return (symbolOOP);
1446 }
1447 
1448 static OOP
alloc_symbol_oop(const char * str,int len)1449 alloc_symbol_oop (const char *str, int len)
1450 {
1451   int numBytes, alignedBytes;
1452   gst_symbol symbol;
1453   OOP symbolOOP;
1454 
1455   numBytes = sizeof(gst_object_header) + len;
1456   alignedBytes = ROUNDED_BYTES (numBytes);
1457   symbol = (gst_symbol) _gst_alloc_obj (alignedBytes, &symbolOOP);
1458   INIT_UNALIGNED_OBJECT (symbolOOP, alignedBytes - numBytes);
1459 
1460   memcpy (symbol->symString, str, len);
1461   symbolOOP->flags |= F_READONLY;
1462   return symbolOOP;
1463 }
1464 
1465 static mst_Boolean
is_same_string(const char * str,OOP oop,int len)1466 is_same_string (const char *str,
1467 		OOP oop,
1468 		int len)
1469 {
1470   if (_gst_string_oop_len (oop) == len)
1471     return (strncmp
1472 	    (str, ((gst_symbol) OOP_TO_OBJ (oop))->symString,
1473 	     len) == 0);
1474 
1475   return (false);
1476 }
1477 
1478 int
_gst_string_oop_len(OOP oop)1479 _gst_string_oop_len (OOP oop)
1480 {
1481   return (OOP_SIZE_BYTES (oop) - (oop->flags & EMPTY_BYTES));
1482 }
1483 
1484 uintptr_t
_gst_hash_string(const char * str,int len)1485 _gst_hash_string (const char *str,
1486 		  int len)
1487 {
1488   uintptr_t hashVal = 1497032417;    /* arbitrary value */
1489 
1490   while (len--)
1491     {
1492       hashVal += *str++;
1493       hashVal += (hashVal << 10);
1494       hashVal ^= (hashVal >> 6);
1495     }
1496 
1497   return hashVal & MAX_ST_INT;
1498 }
1499 
1500 
1501 void
_gst_check_symbol_chain(void)1502 _gst_check_symbol_chain (void)
1503 {
1504   int i;
1505 
1506   for (i = 1; i <= SYMBOL_TABLE_SIZE; i++)
1507     {
1508       sym_link link;
1509       OOP linkOOP;
1510       for (linkOOP = ARRAY_AT (_gst_symbol_table, i); !IS_NIL (linkOOP);
1511 	   linkOOP = link->nextLink)
1512 	{
1513 	  link = (sym_link) OOP_TO_OBJ (linkOOP);
1514 	  if (OOP_CLASS (linkOOP) != _gst_sym_link_class ||
1515 	      OOP_CLASS (link->symbol) != _gst_symbol_class)
1516 	    {
1517 	      printf ("Bad symbol %p\n", linkOOP);
1518 	      abort ();
1519 	    }
1520 	}
1521     }
1522 }
1523 
1524 #ifdef HAVE_READLINE
1525 void
_gst_add_all_symbol_completions(void)1526 _gst_add_all_symbol_completions (void)
1527 {
1528   int i;
1529 
1530   for (i = 1; i <= SYMBOL_TABLE_SIZE; i++)
1531     {
1532       sym_link link;
1533       OOP linkOOP;
1534       char *string;
1535       int len;
1536       for (linkOOP = ARRAY_AT (_gst_symbol_table, i); !IS_NIL (linkOOP);
1537 	   linkOOP = link->nextLink)
1538 	{
1539 	  link = (sym_link) OOP_TO_OBJ (linkOOP);
1540 	  string = _gst_to_cstring (link->symbol);
1541 	  len = _gst_string_oop_len (link->symbol);
1542 	  _gst_add_symbol_completion (string, len);
1543 	  xfree (string);
1544 	}
1545     }
1546 }
1547 #endif
1548 
1549 
1550 
1551 int
_gst_selector_num_args(OOP symbolOOP)1552 _gst_selector_num_args (OOP symbolOOP)
1553 {
1554   char *bytes;
1555   int numArgs, len;
1556 
1557   len = _gst_string_oop_len (symbolOOP);
1558   bytes = (char *) (OOP_TO_OBJ (symbolOOP)->data);
1559   if ((bytes[0] >= 'A' && bytes[0] <= 'Z')
1560       || (bytes[0] >= 'a' && bytes[0] <= 'z')
1561       || bytes[0] == '_')
1562     {
1563       for (numArgs = 0; len;)
1564         if (bytes[--len] == ':')
1565           numArgs++;
1566     }
1567   else
1568     numArgs = 1;
1569 
1570   return (numArgs);
1571 }
1572 
1573 #include "builtins.inl"
1574 
1575 void
_gst_init_symbols_pass1(void)1576 _gst_init_symbols_pass1 (void)
1577 {
1578   const symbol_info *si;
1579   struct builtin_selector *bs;
1580 
1581   for (si = sym_info; si->symbolVar; si++)
1582     *si->symbolVar = alloc_symbol_oop (si->value, strlen (si->value));
1583 
1584   /* Complete gperf's generated table with each symbol's OOP,
1585      and prepare a kind of reverse mapping from the 256 bytecodes
1586      to the hash table entries.  */
1587   for (bs = _gst_builtin_selectors_hash;
1588        bs - _gst_builtin_selectors_hash <
1589 	 sizeof (_gst_builtin_selectors_hash) / sizeof (_gst_builtin_selectors_hash[0]);
1590        bs++)
1591     if (bs->offset != -1)
1592       {
1593 	const char *name = bs->offset + _gst_builtin_selectors_names;
1594 	bs->symbol = alloc_symbol_oop (name, strlen (name));
1595         _gst_builtin_selectors[bs->bytecode] = *bs;
1596       }
1597 }
1598 
1599 void
_gst_init_symbols_pass2(void)1600 _gst_init_symbols_pass2 (void)
1601 {
1602   const symbol_info *si;
1603   struct builtin_selector *bs;
1604 
1605   for (si = sym_info; si->symbolVar; si++)
1606     alloc_symlink (*si->symbolVar, hash_symbol (si->value, strlen (si->value)));
1607 
1608   /* Complete gperf's generated table with each symbol's OOP,
1609      and prepare a kind of reverse mapping from the 256 bytecodes
1610      to the hash table entries.  */
1611   for (bs = _gst_builtin_selectors_hash;
1612        bs - _gst_builtin_selectors_hash <
1613 	 sizeof (_gst_builtin_selectors_hash) / sizeof (_gst_builtin_selectors_hash[0]);
1614        bs++)
1615     if (bs->offset != -1)
1616       {
1617 	const char *name = bs->offset + _gst_builtin_selectors_names;
1618 	alloc_symlink (bs->symbol, hash_symbol (name, strlen (name)));
1619       }
1620 }
1621 
1622 static inline OOP
intern_string_fast(const char * str,OOP * pTestOOP)1623 intern_string_fast (const char *str, OOP *pTestOOP)
1624 {
1625   int len = strlen (str);
1626   OOP testOOP = *pTestOOP;
1627 
1628   if (is_same_string (str, testOOP, len))
1629     {
1630       (*pTestOOP)++;
1631       return testOOP;
1632     }
1633   else
1634     return intern_counted_string (str, len);
1635 }
1636 
1637 void
_gst_restore_symbols(void)1638 _gst_restore_symbols (void)
1639 {
1640   const symbol_info *si;
1641   struct builtin_selector *bs;
1642   OOP currentOOP = _gst_symbol_table + 1;
1643 
1644   for (si = sym_info; si->symbolVar; si++)
1645     *si->symbolVar = intern_string_fast (si->value, &currentOOP);
1646 
1647   /* Complete gperf's generated table with each symbol's OOP,
1648      and prepare a kind of reverse mapping from the 256 bytecodes
1649      to the hash table entries.  */
1650   for (bs = _gst_builtin_selectors_hash;
1651        bs - _gst_builtin_selectors_hash <
1652 	 sizeof (_gst_builtin_selectors_hash) / sizeof (_gst_builtin_selectors_hash[0]);
1653        bs++)
1654     if (bs->offset != -1)
1655       {
1656 	const char *name = bs->offset + _gst_builtin_selectors_names;
1657 	bs->symbol = intern_string_fast (name, &currentOOP);
1658         _gst_builtin_selectors[bs->bytecode] = *bs;
1659       }
1660 }
1661