1 /******************************** -*- C -*- ****************************
2 *
3 * GNU Smalltalk language grammar definition
4 *
5 ***********************************************************************/
6
7 /***********************************************************************
8 *
9 * Copyright 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
10 * Written by Paolo Bonzini.
11 *
12 * This file is part of GNU Smalltalk.
13 *
14 * GNU Smalltalk is free software; you can redistribute it and/or modify it
15 * under the terms of the GNU General Public License as published by the Free
16 * Software Foundation; either version 2, or (at your option) any later
17 * version.
18 *
19 * Linking GNU Smalltalk statically or dynamically with other modules is
20 * making a combined work based on GNU Smalltalk. Thus, the terms and
21 * conditions of the GNU General Public License cover the whole
22 * combination.
23 *
24 * In addition, as a special exception, the Free Software Foundation
25 * give you permission to combine GNU Smalltalk with free software
26 * programs or libraries that are released under the GNU LGPL and with
27 * independent programs running under the GNU Smalltalk virtual machine.
28 *
29 * You may copy and distribute such a system following the terms of the
30 * GNU GPL for GNU Smalltalk and the licenses of the other code
31 * concerned, provided that you include the source code of that other
32 * code when and as the GNU GPL requires distribution of source code.
33 *
34 * Note that people who make modified versions of GNU Smalltalk are not
35 * obligated to grant this special exception for their modified
36 * versions; it is their choice whether to do so. The GNU General
37 * Public License gives permission to release a modified version without
38 * this exception; this exception also makes it possible to release a
39 * modified version which carries forward this exception.
40 *
41 * GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
42 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
43 * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
44 * more details.
45 *
46 * You should have received a copy of the GNU General Public License along with
47 * GNU Smalltalk; see the file COPYING. If not, write to the Free Software
48 * Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
49 *
50 ***********************************************************************/
51
52 #include "gst.h"
53 #include "gstpriv.h"
54 #include "gst-parse.h"
55 #include <stdio.h>
56 #include <string.h>
57
58 typedef enum expr_kinds {
59 EXPR_ASSIGNMENT = 1,
60 EXPR_GREATER = 2,
61 EXPR_BINOP = 4,
62 EXPR_KEYWORD = 8,
63 EXPR_CASCADE = 16,
64 EXPR_CASCADED = EXPR_GREATER | EXPR_BINOP | EXPR_KEYWORD,
65 EXPR_ANY = 31
66 } expr_kinds;
67
68
69 /* Used to communicate with the #methodsFor: primitive. */
70 gst_parser *_gst_current_parser;
71
72 static inline mst_Boolean is_unlikely_selector (const char *);
73
74 /* Lexer interface. */
75
76 static inline void lex_init (gst_parser *p);
77 static inline void lex_lookahead (gst_parser *p, int n);
78 static inline void lex_consume (gst_parser *p, int n);
79 static inline void lex (gst_parser *p);
80 static inline int token (gst_parser *p, int n);
81 static inline YYSTYPE *val (gst_parser *p, int n);
82 static inline YYLTYPE *loc (gst_parser *p, int n);
83 static inline void lex_must_be (gst_parser *p, int req_token);
84 static inline void lex_skip_mandatory (gst_parser *p, int req_token);
85 static inline mst_Boolean lex_skip_if (gst_parser *p, int req_token, mst_Boolean fail_at_eof);
86
87 /* Error recovery. */
88
89 static void expected (gst_parser *p,
90 int token, ...)
91 ATTRIBUTE_NORETURN;
92 static void recover_error (gst_parser *p)
93 ATTRIBUTE_NORETURN;
94 static int filprintf (Filament *fil,
95 const char *format, ...);
96
97 /* Grammar productions. */
98
99 static void parse_chunks (gst_parser *p);
100 static void parse_doit (gst_parser *p,
101 mst_Boolean fail_at_eof);
102 static mst_Boolean parse_scoped_definition (gst_parser *p,
103 tree_node first_stmt);
104
105
106 static void parse_eval_definition (gst_parser *p);
107
108 static mst_Boolean parse_and_send_attribute (gst_parser *p,
109 OOP receiverOOP);
110 static mst_Boolean parse_namespace_definition (gst_parser *p,
111 tree_node first_stmt);
112 static mst_Boolean parse_class_definition (gst_parser *p,
113 OOP classOOP,
114 mst_Boolean extend);
115 static OOP parse_namespace (tree_node name);
116 static OOP parse_class (tree_node list);
117 static void parse_scoped_method (gst_parser *p,
118 OOP classOOP);
119 static void parse_instance_variables (gst_parser *p,
120 OOP classOOP,
121 mst_Boolean extend);
122
123 static void parse_method_list (gst_parser *p);
124 static void parse_method (gst_parser *p,
125 int at_end);
126 static tree_node parse_message_pattern (gst_parser *p);
127 static tree_node parse_keyword_variable_list (gst_parser *p);
128 static tree_node parse_variable (gst_parser *p);
129 static tree_node parse_attributes (gst_parser *p,
130 tree_node prev_attrs);
131 static tree_node parse_attribute (gst_parser *p);
132 static tree_node parse_temporaries (gst_parser *p,
133 mst_Boolean implied_pipe);
134 static tree_node parse_statements (gst_parser *p,
135 tree_node first_stmt,
136 mst_Boolean accept_caret);
137 static tree_node parse_required_expression (gst_parser *p);
138 static tree_node parse_expression (gst_parser *p,
139 enum expr_kinds kind);
140 static tree_node parse_primary (gst_parser *p);
141 static tree_node parse_variable_primary (gst_parser *p);
142 static tree_node parse_literal (gst_parser *p,
143 mst_Boolean array);
144 static tree_node parse_array_literal (gst_parser *p);
145 static tree_node parse_builtin_identifier (gst_parser *p);
146 static tree_node parse_byte_array_literal (gst_parser *p);
147 static tree_node parse_binding_constant (gst_parser *p);
148 static tree_node parse_compile_time_constant (gst_parser *p);
149 static tree_node parse_array_constructor (gst_parser *p);
150 static tree_node parse_block (gst_parser *p);
151 static tree_node parse_block_variables (gst_parser *p);
152 static tree_node parse_message_expression (gst_parser *p,
153 tree_node receiver,
154 enum expr_kinds kind);
155 static tree_node parse_cascaded_messages (gst_parser *p);
156 static tree_node parse_unary_expression (gst_parser *p,
157 tree_node receiver,
158 enum expr_kinds kind);
159 static tree_node parse_binary_expression (gst_parser *p,
160 tree_node receiver,
161 enum expr_kinds kind);
162 static tree_node parse_keyword_expression (gst_parser *p,
163 tree_node receiver,
164 enum expr_kinds kind);
165 static tree_node parse_keyword_list (gst_parser *p,
166 enum expr_kinds kind);
167
168
169
170 static int
filprintf(Filament * fil,const char * format,...)171 filprintf (Filament *fil, const char *format, ...)
172 {
173 va_list ap;
174 STREAM *out = stream_new (fil, SNV_UNLIMITED, NULL, snv_filputc);
175 int result;
176 va_start (ap, format);
177 result = stream_vprintf (out, format, ap);
178 va_end (ap);
179 stream_delete (out);
180 return result;
181 }
182
183 /* Lexer interface. Intialize the parser before using it. */
184
185 static inline void
lex_init(gst_parser * p)186 lex_init (gst_parser *p)
187 {
188 p->la_first = 0;
189 p->la_size = 0;
190 lex_lookahead (p, 1);
191 }
192
193 /* Lexer interface. Get N tokens out of the stream. */
194
195 static inline void
lex_lookahead(gst_parser * p,int n)196 lex_lookahead (gst_parser *p, int n)
197 {
198 while (p->la_size < n)
199 {
200 int i = (p->la_first + p->la_size) % 4;
201 p->la[i].token = _gst_yylex (&p->la[i].val, &p->la[i].loc);
202 p->la_size++;
203 }
204 }
205
206 /* Lexer interface. Eat the first N lookahead tokens. */
207
208 static inline void
lex_consume(gst_parser * p,int n)209 lex_consume (gst_parser *p, int n)
210 {
211 p->la_first = (p->la_first + n) % 4;
212 p->la_size -= n;
213 }
214
215 /* Lexer interface. Eat the last lookahead token and lex the next one */
216
217 static inline void
lex(gst_parser * p)218 lex (gst_parser *p)
219 {
220 lex_consume (p, 1);
221 lex_lookahead (p, 1);
222 }
223
224 /* Lexer interface. Return the N-th lookahead token. */
225
226 static inline int
token(gst_parser * p,int n)227 token (gst_parser *p, int n)
228 {
229 int i = (p->la_first + n) % 4;
230 return p->la[i].token;
231 }
232
233 /* Lexer interface. Return the value of the N-th lookahead token. */
234
235 static inline YYSTYPE*
val(gst_parser * p,int n)236 val (gst_parser *p, int n)
237 {
238 int i = (p->la_first + n) % 4;
239 return &p->la[i].val;
240 }
241
242
243 /* Lexer interface. Return the location of the N-th lookahead token. */
244
245 static inline YYLTYPE*
loc(gst_parser * p,int n)246 loc (gst_parser *p, int n)
247 {
248 int i = (p->la_first + n) % 4;
249 return &p->la[i].loc;
250 }
251
252 /* Lexer interface. Check that the next token is REQ_TOKEN and fail if
253 it is not. */
254
255 static inline void
lex_must_be(gst_parser * p,int req_token)256 lex_must_be (gst_parser *p, int req_token)
257 {
258 if (token (p, 0) != req_token)
259 expected (p, req_token, -1);
260 }
261
262 /* Lexer interface. Check that the next token is REQ_TOKEN and eat it;
263 fail if it does not match. */
264
265 static inline void
lex_skip_mandatory(gst_parser * p,int req_token)266 lex_skip_mandatory (gst_parser *p, int req_token)
267 {
268 if (token (p, 0) != req_token)
269 expected (p, req_token, -1);
270 else
271 lex (p);
272 }
273
274 /* Lexer interface. If the next token is REQ_TOKEN, eat it and return true;
275 otherwise return false. */
276
277 static inline mst_Boolean
lex_skip_if(gst_parser * p,int req_token,mst_Boolean fail_at_eof)278 lex_skip_if (gst_parser *p, int req_token, mst_Boolean fail_at_eof)
279 {
280 if (token (p, 0) != req_token)
281 {
282 if (token (p, 0) == EOF && fail_at_eof)
283 expected (p, req_token, -1);
284 return false;
285 }
286 else
287 {
288 lex (p);
289 return true;
290 }
291 }
292
293
294 void
_gst_print_tokens(gst_parser * p)295 _gst_print_tokens (gst_parser *p)
296 {
297 int i;
298 printf ("size: %i\n", p->la_size);
299 for (i = 0; i < p->la_size; i++) {
300 if (token (p, i) == 264)
301 printf ("%i - %i - %s\n", i, token (p, i), val (p, i)->sval);
302 else
303 printf ("%i - %i\n", i, token (p, i));
304 }
305 printf ("\n");
306 }
307
308 /* Top of the descent. */
309
310 void
_gst_parse_method()311 _gst_parse_method ()
312 {
313 gst_parser p, *prev_parser = _gst_current_parser;
314 _gst_current_parser = &p;
315 p.state = PARSE_METHOD;
316 lex_init (&p);
317 if (setjmp (p.recover) == 0)
318 parse_method (&p, ']');
319 else
320 _gst_had_error = false;
321
322 _gst_current_parser = prev_parser;
323 }
324
325 void
_gst_parse_chunks()326 _gst_parse_chunks ()
327 {
328 gst_parser p, *prev_parser = _gst_current_parser;
329
330 _gst_current_parser = &p;
331
332 lex_init (&p);
333 if (token (&p, 0) == SHEBANG)
334 lex (&p);
335
336 p.state = PARSE_DOIT;
337 setjmp (p.recover);
338 _gst_had_error = false;
339 while (token (&p, 0) != EOF)
340 parse_chunks (&p);
341
342 _gst_current_parser = prev_parser;
343 }
344
345 static void
parse_chunks(gst_parser * p)346 parse_chunks (gst_parser *p)
347 {
348 if (lex_skip_if (p, '!', false))
349 p->state = PARSE_DOIT;
350 else
351 {
352 OOP oldTemporaries = _gst_push_temporaries_dictionary ();
353 jmp_buf old_recover;
354 memcpy (old_recover, p->recover, sizeof (p->recover));
355 setjmp (p->recover);
356 while (token (p, 0) != EOF && token (p, 0) != '!')
357 {
358 /* Pick the production here, so that subsequent
359 methods are compiled when we come back from an error above. */
360 if (p->state == PARSE_METHOD_LIST)
361 parse_method_list (p);
362 else
363 parse_doit (p, false);
364 }
365
366 lex_skip_if (p, '!', false);
367 _gst_pop_temporaries_dictionary (oldTemporaries);
368 memcpy (p->recover, old_recover, sizeof (p->recover));
369 }
370 }
371
372
373 /* Print an error message and attempt error recovery. All the parameters
374 after P (terminated by -1) are tokens that were expected (possibly a
375 subset to make the error message shorter). */
376
377 static void
expected(gst_parser * p,int token,...)378 expected (gst_parser *p, int token, ...)
379 {
380 int named_tokens = 0;
381 va_list ap;
382 const char *sep = ", expected";
383 char *msg;
384
385 Filament *out_fil = filnew (NULL, 0);
386 filprintf (out_fil, "parse error");
387
388 va_start (ap, token);
389 while (token != -1)
390 {
391 if (token < 256)
392 {
393 filprintf (out_fil, "%s '%c'", sep, token);
394 sep = " or";
395 }
396 else
397 named_tokens |= 1 << (token - FIRST_TOKEN);
398 token = va_arg (ap, int);
399 }
400
401 #define TOKEN_DEF(name, val, str, subsume) \
402 if ((named_tokens & (1 << (val - FIRST_TOKEN))) != 0 \
403 && (subsume == -1 \
404 || (named_tokens & (1 << (subsume - FIRST_TOKEN))) == 0)) \
405 { \
406 filprintf (out_fil, "%s %s", sep, str); \
407 sep = " or"; \
408 }
409
410 TOKEN_DEFS
411 #undef TOKEN_DEF
412
413 msg = fildelete (out_fil);
414 _gst_errorf ("%s", msg);
415 free (msg);
416 recover_error (p);
417 }
418
419
420 /* Perform error recovery and longjmp out of the parser. */
421
422 static void
recover_error(gst_parser * p)423 recover_error (gst_parser *p)
424 {
425 if (p->state != PARSE_METHOD)
426 {
427 _gst_error_recovery = true;
428
429 /* Find the final bang or, if in the REPL, a newline. */
430 while (token (p, 0) != EOF
431 && token (p, 0) != '!'
432 && token (p, 0) != ERROR_RECOVERY)
433 lex (p);
434
435 _gst_error_recovery = false;
436 lex_skip_if (p, ERROR_RECOVERY, false);
437 }
438
439 longjmp (p->recover, 1);
440 }
441
442 /* doit: temporaries statements '!' [ method_list '!' ]
443 | empty */
444
445 static void
parse_doit(gst_parser * p,mst_Boolean fail_at_eof)446 parse_doit (gst_parser *p, mst_Boolean fail_at_eof)
447 {
448 tree_node statement = NULL;
449 mst_Boolean caret;
450
451 if (token (p, 0) == '|')
452 parse_temporaries (p, false);
453
454 if (token (p, 0) == EOF && !fail_at_eof)
455 return;
456
457 caret = lex_skip_if (p, '^', false);
458 statement = parse_required_expression (p);
459 if (!caret && lex_skip_if (p, '[', false))
460 {
461 if (parse_scoped_definition (p, statement))
462 lex_skip_mandatory (p, ']');
463 else
464 {
465 while (!lex_skip_if (p, ']', true))
466 lex (p);
467 }
468 }
469 else if (statement)
470 {
471 _gst_execute_statements (NULL, statement, UNDECLARED_TEMPORARIES, false);
472
473 /* Because a '.' could be inserted automagically, the next token
474 value might be already on the obstack. Do not free in that
475 case! */
476 if (p->la_size == 0)
477 _gst_free_tree ();
478 }
479
480 _gst_had_error = false;
481
482 /* Do not lex until after _gst_free_tree, or we lose a token! */
483 lex_skip_if (p, '.', false);
484 }
485
486
487 /* scoped_definition: eval_definition
488 | class_definition
489 | namespace_definition */
490
491 static mst_Boolean
parse_scoped_definition(gst_parser * p,tree_node first_stmt)492 parse_scoped_definition (gst_parser *p, tree_node first_stmt)
493 {
494 OOP classOOP = NULL;
495 tree_node receiver = first_stmt->v_expr.receiver;
496 tree_node expression = first_stmt->v_expr.expression;
497
498 #if 0
499 _gst_print_tree (first_stmt, 0);
500 #endif
501
502 if (first_stmt->nodeType == TREE_VARIABLE_NODE
503 && strcmp (first_stmt->v_list.name, "Eval") == 0)
504 {
505 parse_eval_definition (p);
506 return true;
507 }
508
509 if (first_stmt->nodeType == TREE_KEYWORD_EXPR
510 && receiver->nodeType == TREE_VARIABLE_NODE
511 && expression->v_list.value->nodeType == TREE_VARIABLE_NODE
512 && expression->v_list.next == NULL)
513 {
514 if (strcmp (receiver->v_list.name, "Namespace") == 0
515 && strcmp (expression->v_list.name, "current:") == 0)
516 return parse_namespace_definition (p, first_stmt);
517
518 if (strcmp (expression->v_list.name, "subclass:") == 0
519 && (classOOP = parse_class (receiver)) != NULL)
520 {
521 const char * name = expression->v_list.value->v_list.name;
522 _gst_msg_sendf (&classOOP, "%o %o subclass: %S", classOOP, name);
523
524 if (IS_NIL (classOOP))
525 _gst_had_error = true;
526 else
527 return parse_class_definition (p, classOOP, false);
528 }
529 }
530
531 else if (first_stmt->nodeType == TREE_UNARY_EXPR
532 && first_stmt->v_expr.selector == _gst_intern_string ("extend"))
533 {
534 OOP namespace_old = _gst_current_namespace;
535 OOP classOrMetaclassOOP = NULL;
536 mst_Boolean ret_value;
537
538 _gst_register_oop (namespace_old);
539 if (receiver->nodeType == TREE_VARIABLE_NODE)
540 {
541 classOOP = parse_class (receiver);
542 classOrMetaclassOOP = classOOP;
543 }
544 else if (receiver->nodeType == TREE_UNARY_EXPR
545 && receiver->v_expr.selector == _gst_intern_string ("class"))
546 {
547 classOOP = parse_class (receiver->v_expr.receiver);
548 classOrMetaclassOOP = classOOP ? OOP_CLASS (classOOP) : NULL;
549 }
550 if (classOrMetaclassOOP != NULL)
551 {
552 OOP namespace_new = ((gst_class) OOP_TO_OBJ (classOOP))->environment;
553
554 /* When creating the image, current namespace is not available. */
555 if (namespace_new != namespace_old)
556 _gst_msg_sendf (NULL, "%v %o current: %o",
557 _gst_namespace_class, namespace_new);
558
559 ret_value = parse_class_definition (p, classOrMetaclassOOP, true);
560
561 if (namespace_new != namespace_old)
562 _gst_msg_sendf (NULL, "%v %o current: %o",
563 _gst_namespace_class, namespace_old);
564
565 _gst_unregister_oop (namespace_old);
566 return ret_value;
567 }
568 }
569
570 _gst_errorf_at (first_stmt->location.first_line,
571 "expected Eval, Namespace or class definition");
572 return false;
573 }
574
575 static void
parse_eval_definition(gst_parser * p)576 parse_eval_definition (gst_parser *p)
577 {
578 tree_node tmps = NULL, stmts = NULL;
579 OOP oldDictionary = _gst_push_temporaries_dictionary ();
580 jmp_buf old_recover;
581
582 memcpy (old_recover, p->recover, sizeof (p->recover));
583 if (setjmp (p->recover) == 0)
584 {
585 tmps = parse_temporaries (p, false);
586 stmts = parse_statements (p, NULL, true);
587 lex_must_be (p, ']');
588 }
589
590 if (stmts && !_gst_had_error)
591 {
592 if (_gst_regression_testing)
593 {
594 printf ("\nExecution begins...\n");
595 fflush (stdout);
596 fflush (stderr);
597 }
598
599 _gst_execute_statements (tmps, stmts, UNDECLARED_TEMPORARIES,
600 _gst_regression_testing);
601
602 if (_gst_regression_testing)
603 {
604 if (!_gst_had_error)
605 printf ("returned value is %O\n", _gst_last_returned_value);
606 fflush (stdout);
607 fflush (stderr);
608 }
609
610 _gst_had_error = false;
611 }
612
613 assert (p->la_size <= 1);
614 _gst_free_tree ();
615 _gst_pop_temporaries_dictionary (oldDictionary);
616 memcpy (p->recover, old_recover, sizeof (p->recover));
617 if (_gst_had_error)
618 longjmp (p->recover, 1);
619 }
620
621 static mst_Boolean
parse_and_send_attribute(gst_parser * p,OOP receiverOOP)622 parse_and_send_attribute (gst_parser *p, OOP receiverOOP)
623 {
624 OOP selectorOOP, *args;
625 tree_node keyword, value, stmt;
626 int i, nb = 0;
627
628 #if 0
629 printf ("parse attribute\n");
630 #endif
631 lex_skip_mandatory (p, '<');
632 keyword = parse_keyword_expression (p, NULL, EXPR_KEYWORD);
633
634 selectorOOP = _gst_compute_keyword_selector (keyword->v_expr.expression);
635 nb = _gst_selector_num_args (selectorOOP);
636 args = alloca (sizeof (*args) * nb);
637 i = 0;
638 for (stmt = keyword->v_expr.expression; stmt; stmt = stmt->v_list.next)
639 {
640 value = stmt->v_list.value;
641 value = _gst_make_statement_list (&value->location, value);
642 args[i] = _gst_execute_statements (NULL, value, UNDECLARED_NONE, true);
643 if (!args[i])
644 {
645 _gst_had_error = true;
646 break;
647 }
648 i = i + 1;
649 }
650
651 if (!_gst_had_error)
652 _gst_nvmsg_send (receiverOOP, selectorOOP, args, i);
653
654 lex_skip_mandatory (p, '>');
655 return !_gst_had_error;
656 }
657
658
659 static mst_Boolean
parse_namespace_definition(gst_parser * p,tree_node first_stmt)660 parse_namespace_definition (gst_parser *p, tree_node first_stmt)
661 {
662 tree_node expr = first_stmt->v_expr.expression;
663 OOP new_namespace = parse_namespace (expr->v_list.value);
664
665 if (new_namespace)
666 {
667 OOP old_namespace = _gst_current_namespace;
668 _gst_register_oop (old_namespace);
669
670 _gst_msg_sendf (NULL, "%v %o current: %o",
671 _gst_namespace_class, new_namespace);
672
673 while (token (p, 0) != ']' && token (p, 0) != EOF && token (p, 0) != '!')
674 {
675 if (token (p, 0) == '<')
676 parse_and_send_attribute (p, new_namespace);
677 else
678 parse_doit (p, true);
679 }
680
681 _gst_msg_sendf (NULL, "%v %o current: %o",
682 _gst_namespace_class, old_namespace);
683
684 _gst_unregister_oop (old_namespace);
685 return true;
686 }
687
688 return false;
689 }
690
691 static mst_Boolean
parse_class_definition(gst_parser * p,OOP classOOP,mst_Boolean extend)692 parse_class_definition (gst_parser *p, OOP classOOP, mst_Boolean extend)
693 {
694 mst_Boolean add_inst_vars = extend;
695
696 for (;;)
697 {
698 int t1, t2, t3;
699 if (_gst_had_error)
700 break;
701
702 lex_lookahead (p, 1);
703 if (token (p, 0) == ']' || token (p, 0) == EOF)
704 break;
705
706 #if 0
707 print_tokens (p);
708 #endif
709
710 t1 = token (p, 0);
711
712 switch (t1)
713 {
714 case '>':
715 case '-':
716 case BINOP:
717 case KEYWORD:
718 #if 0
719 printf ("parse method\n");
720 #endif
721
722 _gst_set_compilation_class (classOOP);
723 parse_method (p, ']');
724 _gst_reset_compilation_category ();
725 continue;
726
727 case '<':
728 lex_lookahead (p, 2);
729 t2 = token (p, 1);
730 if (t2 == IDENTIFIER)
731 {
732 #if 0
733 printf ("parse method\n");
734 #endif
735
736 _gst_set_compilation_class (classOOP);
737 parse_method (p, ']');
738 _gst_reset_compilation_category ();
739 continue;
740 }
741 else if (t2 == KEYWORD)
742 {
743 parse_and_send_attribute (p, classOOP);
744 continue;
745 }
746 break;
747
748 case IDENTIFIER:
749 lex_lookahead (p, 2);
750 t2 = token (p, 1);
751 if (t2 == ASSIGNMENT)
752 {
753 #if 0
754 printf ("parse class variable\n");
755 #endif
756
757 OOP name, class_var_dict, result;
758 tree_node stmt;
759 OOP the_class = classOOP;
760 if (IS_A_METACLASS (classOOP))
761 the_class = METACLASS_INSTANCE (classOOP);
762
763 name = _gst_intern_string (val (p, 0)->sval);
764
765 lex_skip_mandatory (p, IDENTIFIER);
766 lex_skip_mandatory (p, ASSIGNMENT);
767
768 class_var_dict = _gst_class_variable_dictionary (the_class);
769 if (IS_NIL (class_var_dict))
770 {
771 gst_class class;
772 class_var_dict = _gst_binding_dictionary_new (8, the_class);
773 class = (gst_class) OOP_TO_OBJ (the_class);
774 class->classVariables = class_var_dict;
775 }
776
777 stmt = parse_required_expression (p);
778 if (!_gst_had_error)
779 {
780 stmt = _gst_make_statement_list (&stmt->location, stmt);
781 result = _gst_execute_statements (NULL, stmt, UNDECLARED_NONE,
782 true);
783
784 if (result)
785 DICTIONARY_AT_PUT (class_var_dict, name, result);
786 else
787 _gst_had_error = true;
788 }
789
790 if (token (p, 0) != ']')
791 lex_skip_mandatory(p, '.');
792 continue;
793 }
794 else if (t2 == BINOP)
795 {
796 #if 0
797 printf ("parse method\n");
798 #endif
799 parse_scoped_method (p, classOOP);
800 continue;
801 }
802 else if (t2 == '[')
803 {
804 #if 0
805 printf ("parse method\n");
806 #endif
807
808 _gst_set_compilation_class (classOOP);
809 parse_method (p, ']');
810 _gst_reset_compilation_category ();
811 continue;
812 }
813 else if (t2 == SCOPE_SEPARATOR)
814 {
815 #if 0
816 printf ("parse method qualified name\n");
817 #endif
818
819 parse_scoped_method (p, classOOP);
820 continue;
821 }
822 else if (t2 == IDENTIFIER)
823 {
824 lex_lookahead (p, 3);
825 t3 = token (p, 2);
826 if (t3 == BINOP)
827 {
828 #if 0
829 printf ("parse class method\n");
830 #endif
831 parse_scoped_method (p, classOOP);
832 continue;
833 }
834 else if (t3 == '[' && strcmp (val (p, 1)->sval, "class") == 0)
835 {
836 #if 0
837 printf ("parse class protocol\n");
838 #endif
839 if (_gst_object_is_kind_of (classOOP, _gst_metaclass_class))
840 {
841 _gst_errorf ("already on class side");
842 _gst_had_error = true;
843 continue;
844 }
845 else if (((gst_class) OOP_TO_OBJ (classOOP))->name
846 != _gst_intern_string (val (p, 0)->sval))
847 {
848 _gst_errorf ("`%s class' invalid within %O",
849 val (p, 0)->sval, classOOP);
850 _gst_had_error = true;
851 continue;
852 }
853 else
854 {
855 lex_consume (p, 3);
856 parse_class_definition (p, OOP_CLASS (classOOP), extend);
857 lex_skip_mandatory (p, ']');
858 }
859 continue;
860 }
861 }
862 break;
863
864 case '|':
865 lex_lookahead (p, 2);
866 t2 = token (p, 1);
867 if (t2 == '|')
868 {
869 #if 0
870 printf ("parse instance variables - ignore\n");
871 #endif
872 lex_consume (p, 2);
873 continue;
874 }
875 else if (t2 == IDENTIFIER)
876 {
877 lex_lookahead (p, 3);
878 t3 = token (p, 2);
879 if (t3 == IDENTIFIER || t3 == '|')
880 {
881 #if 0
882 printf ("parse instance variables\n");
883 #endif
884 parse_instance_variables (p, classOOP, add_inst_vars);
885 add_inst_vars = true;
886 continue;
887 }
888 else if (t3 == '[')
889 {
890 #if 0
891 printf ("parse method\n");
892 #endif
893 _gst_set_compilation_class (classOOP);
894 parse_method (p, ']');
895 _gst_reset_compilation_category ();
896 continue;
897 }
898 }
899 break;
900
901 default:
902 break;
903 }
904
905 _gst_errorf ("invalid class body element");
906 _gst_had_error = true;
907 }
908
909 return !_gst_had_error;
910 }
911
912 static void
parse_scoped_method(gst_parser * p,OOP classOOP)913 parse_scoped_method (gst_parser *p, OOP classOOP)
914 {
915 OOP class, classInstanceOOP;
916 tree_node class_node;
917 mst_Boolean class_method = false;
918
919 class_node = parse_variable_primary (p);
920 class = parse_class (class_node);
921
922 if (OOP_CLASS (classOOP) == _gst_metaclass_class)
923 classInstanceOOP = METACLASS_INSTANCE (classOOP);
924 else
925 classInstanceOOP = classOOP;
926
927 if (token (p, 0) == IDENTIFIER)
928 {
929 if ((strcmp (val (p, 0)->sval, "class") == 0))
930 {
931 class_method = true;
932 lex_skip_mandatory (p, IDENTIFIER);
933 }
934 else
935 _gst_errorf("expected `class' or `>>'");
936 }
937
938 lex_must_be (p, BINOP);
939 if (strcmp (val (p, 0)->sval, ">>") == 0)
940 lex_skip_mandatory (p, BINOP);
941 else
942 _gst_errorf ("expected `>>'");
943
944 if (!class_method && OOP_CLASS (classOOP) == _gst_metaclass_class)
945 {
946 _gst_skip_compilation = true;
947 _gst_errorf ("class method expected inside class block");
948 }
949
950 else if (!class)
951 {
952 _gst_skip_compilation = true;
953 class = classOOP;
954 }
955
956 else if (!_gst_class_is_kind_of (classInstanceOOP, class))
957 {
958 _gst_skip_compilation = true;
959 _gst_errorf ("%#O is not %#O or one of its superclasses",
960 ((gst_class) OOP_TO_OBJ (class))->name,
961 ((gst_class) OOP_TO_OBJ (classOOP))->name);
962 }
963
964 else
965 {
966 if (class_method)
967 class = OOP_CLASS (class);
968 }
969
970 _gst_set_compilation_class (class);
971 parse_method (p, ']');
972 _gst_reset_compilation_category ();
973 _gst_skip_compilation = false;
974 }
975
976 static OOP
parse_class(tree_node list)977 parse_class (tree_node list)
978 {
979 const char* name;
980 OOP currentOOP = _gst_current_namespace;
981 tree_node next;
982
983 if (strcmp (list->v_list.name, "nil") == 0)
984 return _gst_nil_oop;
985
986 do
987 {
988 name = list->v_list.name;
989 currentOOP = _gst_namespace_at (currentOOP, _gst_intern_string (name));
990
991 if (currentOOP == _gst_nil_oop)
992 {
993 _gst_errorf_at (list->location.first_line, "key %s not found", name);
994 return NULL;
995 }
996
997 next = list->v_list.next;
998 if (next == NULL)
999 {
1000 if (!_gst_object_is_kind_of (currentOOP, _gst_class_class))
1001 {
1002 _gst_errorf_at (list->location.first_line,
1003 "expected class named %s, found %O",
1004 name, OOP_INT_CLASS (currentOOP));
1005 return NULL;
1006 }
1007 }
1008 else
1009 {
1010 if (!_gst_object_is_kind_of (currentOOP, _gst_dictionary_class))
1011 {
1012 _gst_errorf_at (list->location.first_line,
1013 "expected namespace named %s, found %O",
1014 name, OOP_INT_CLASS (currentOOP));
1015 return NULL;
1016 }
1017 }
1018 list = next;
1019 }
1020 while (list != NULL);
1021
1022 return currentOOP;
1023 }
1024
1025 static OOP
parse_namespace(tree_node list)1026 parse_namespace (tree_node list)
1027 {
1028 OOP name, new_namespace, current_namespace;
1029 const char *namespc;
1030
1031 current_namespace = _gst_current_namespace;
1032 while (list->v_list.next != NULL)
1033 {
1034 name = _gst_intern_string (list->v_list.name);
1035 current_namespace = _gst_namespace_at (current_namespace, name);
1036
1037 if (current_namespace == _gst_nil_oop)
1038 {
1039 _gst_errorf_at (list->location.first_line,
1040 "key %s not found", list->v_list.name);
1041 return NULL;
1042 }
1043
1044 if (!_gst_object_is_kind_of (current_namespace, _gst_dictionary_class))
1045 {
1046 _gst_errorf_at (list->location.first_line,
1047 "expected namespace named %s, found %O",
1048 list->v_list.name, OOP_INT_CLASS (current_namespace));
1049 return NULL;
1050 }
1051
1052 list = list->v_list.next;
1053 }
1054
1055 namespc = list->v_list.name;
1056 name = _gst_intern_string (namespc);
1057 new_namespace = dictionary_at (current_namespace, name);
1058
1059 if (new_namespace == _gst_nil_oop)
1060 _gst_msg_sendf (¤t_namespace, "%o %o addSubspace: %o",
1061 current_namespace, name);
1062
1063 else if (_gst_object_is_kind_of (new_namespace, _gst_dictionary_class))
1064 current_namespace = new_namespace;
1065
1066 else
1067 _gst_errorf_at (list->location.first_line,
1068 "expected namespace named %s, found %O", namespc,
1069 OOP_INT_CLASS (new_namespace));
1070
1071 return current_namespace;
1072 }
1073
1074 /* method_list: method_list method '!'
1075 | empty */
1076
1077 static void
parse_instance_variables(gst_parser * p,OOP classOOP,mst_Boolean extend)1078 parse_instance_variables (gst_parser *p, OOP classOOP, mst_Boolean extend)
1079 {
1080 char *vars;
1081 Filament *fil = filnew (NULL, 0);
1082
1083 if (extend)
1084 {
1085 gst_behavior class = (gst_behavior) OOP_TO_OBJ (classOOP);
1086 OOP *instVars = OOP_TO_OBJ (class->instanceVariables)->data;
1087 int n = CLASS_FIXED_FIELDS (classOOP);
1088 OOP superclassOOP = SUPERCLASS (classOOP);
1089 if (!IS_NIL (superclassOOP))
1090 {
1091 int superclassVars = CLASS_FIXED_FIELDS (superclassOOP);
1092 instVars += superclassVars;
1093 n -= superclassVars;
1094 }
1095 for (; n--; instVars++)
1096 {
1097 char *s = _gst_to_cstring (*instVars);
1098 filprintf (fil, "%s ", s);
1099 xfree (s);
1100 }
1101 }
1102
1103 lex_skip_mandatory (p, '|');
1104 while (!lex_skip_if (p, '|', true))
1105 {
1106 lex_must_be (p, IDENTIFIER);
1107 filprintf (fil, "%s ", val (p, 0)->sval);
1108 lex (p);
1109 }
1110
1111 vars = fildelete (fil);
1112 _gst_msg_sendf (NULL, "%v %o instanceVariableNames: %S", classOOP, vars);
1113 free (vars);
1114 }
1115
1116 static void
parse_method_list(gst_parser * p)1117 parse_method_list (gst_parser *p)
1118 {
1119 while (token (p, 0) != '!')
1120 parse_method (p, '!');
1121
1122 _gst_skip_compilation = false;
1123 _gst_reset_compilation_category ();
1124 p->state = PARSE_DOIT;
1125 }
1126
1127
1128 /* method: message_pattern temporaries attributes statements */
1129
1130 static void
parse_method(gst_parser * p,int at_end)1131 parse_method (gst_parser *p, int at_end)
1132 {
1133 tree_node pat, temps, stmts, attrs = NULL;
1134 YYLTYPE current_pos;
1135 tree_node method;
1136
1137 pat = parse_message_pattern (p);
1138
1139 if (at_end == ']')
1140 lex_skip_mandatory (p, '[');
1141
1142 if (token (p, 0) == '<')
1143 attrs = parse_attributes (p, NULL);
1144
1145 temps = parse_temporaries (p, false);
1146
1147 if (token (p, 0) == '<')
1148 attrs = parse_attributes (p, attrs);
1149
1150 stmts = parse_statements (p, NULL, true);
1151
1152 /* Don't lex until _gst_free_tree, or we lose a token. */
1153 lex_must_be (p, at_end);
1154
1155 /* Still, include the ']' in the method source code. */
1156 current_pos = _gst_get_location ();
1157 if (at_end == ']')
1158 current_pos.file_offset++;
1159
1160 method = _gst_make_method (&pat->location, ¤t_pos,
1161 pat, temps, attrs, stmts,
1162 at_end != ']');
1163
1164 if (!_gst_had_error && !_gst_skip_compilation)
1165 {
1166 enum undeclared_strategy oldUndeclared;
1167 oldUndeclared = _gst_set_undeclared (UNDECLARED_GLOBALS);
1168 _gst_compile_method (method, false, true);
1169 _gst_set_undeclared (oldUndeclared);
1170 }
1171
1172 assert (p->la_size <= 1);
1173 _gst_free_tree ();
1174 _gst_had_error = false;
1175 if (at_end != EOF)
1176 lex (p);
1177 }
1178
1179
1180 /* message_pattern: unary_pattern
1181 | binary_pattern
1182 | keyword_pattern
1183
1184 unary_pattern: IDENTIFIER
1185 binary_pattern: binop IDENTIFIER
1186 keyword_pattern: keyword_pattern KEYWORD IDENTIFIER
1187 | KEYWORD IDENTIFIER
1188 binop : BINOP | '<' | '>' | '-' | '|' */
1189
1190 static tree_node
parse_message_pattern(gst_parser * p)1191 parse_message_pattern (gst_parser *p)
1192 {
1193 YYLTYPE location = *loc (p, 0);
1194 tree_node pat, arg;
1195 char *sval = val(p, 0)->sval;
1196
1197 switch (token (p, 0))
1198 {
1199 case IDENTIFIER:
1200 lex (p);
1201 pat = _gst_make_unary_expr (&location, NULL, sval);
1202 break;
1203
1204 case BINOP:
1205 case '<':
1206 case '>':
1207 case '-':
1208 case '|':
1209 lex (p);
1210 arg = parse_variable (p);
1211 pat = _gst_make_binary_expr (&location, NULL, sval, arg);
1212 break;
1213
1214 case KEYWORD:
1215 pat = parse_keyword_variable_list (p);
1216 pat = _gst_make_keyword_expr (&location, NULL, pat);
1217 break;
1218
1219 default:
1220 expected (p, IDENTIFIER, BINOP, KEYWORD, -1);
1221 }
1222
1223 return pat;
1224 }
1225
1226 static tree_node
parse_keyword_variable_list(gst_parser * p)1227 parse_keyword_variable_list (gst_parser *p)
1228 {
1229 YYLTYPE location = *loc (p, 0);
1230 tree_node pat = NULL, arg;
1231
1232 do
1233 {
1234 char *sval = val(p, 0)->sval;
1235 lex (p);
1236 arg = parse_variable (p);
1237 pat = _gst_add_node (pat, _gst_make_keyword_list (&location, sval, arg));
1238 }
1239 while (token (p, 0) == KEYWORD);
1240
1241 return pat;
1242 }
1243
1244
1245 /* variable: IDENTIFIER */
1246
1247 static tree_node
parse_variable(gst_parser * p)1248 parse_variable (gst_parser *p)
1249 {
1250 tree_node var;
1251
1252 lex_must_be (p, IDENTIFIER);
1253 var = _gst_make_variable (loc (p, 0), val(p, 0)->sval);
1254 lex (p);
1255 return var;
1256 }
1257
1258
1259 /* attributes: attributes '<' attribute_keywords '>'
1260 | empty
1261
1262 attribute_keywords: attribute KEYWORD binary_expr
1263 | KEYWORD binary_expr */
1264
1265 static tree_node
parse_attributes(gst_parser * p,tree_node prev_attrs)1266 parse_attributes (gst_parser *p, tree_node prev_attrs)
1267 {
1268 while (token (p, 0) == '<')
1269 {
1270 tree_node attr = parse_attribute (p);
1271 if (attr)
1272 prev_attrs = _gst_add_node (prev_attrs, attr);
1273 }
1274
1275 return prev_attrs;
1276 }
1277
1278 static tree_node
parse_attribute(gst_parser * p)1279 parse_attribute (gst_parser *p)
1280 {
1281 tree_node message, attr, constant;
1282 OOP attributeOOP, selectorOOP, argsOOP;
1283 char *sel;
1284 YYLTYPE location = *loc (p, 0);
1285
1286 lex_skip_mandatory (p, '<');
1287 if (token (p, 0) == IDENTIFIER)
1288 {
1289 sel = val(p, 0)->sval;
1290 lex (p);
1291 selectorOOP = _gst_intern_string (sel);
1292 new_instance_with (_gst_array_class, 0, &argsOOP);
1293 MAKE_OOP_READONLY (selectorOOP, true);
1294 MAKE_OOP_READONLY (argsOOP, true);
1295 message = _gst_make_unary_expr (&location, NULL, sel);
1296 attributeOOP = _gst_message_new_args (selectorOOP, argsOOP);
1297 }
1298 else
1299 {
1300 lex_must_be (p, KEYWORD);
1301 message = parse_keyword_list (p, EXPR_BINOP);
1302
1303 /* First convert the TREE_KEYWORD_EXPR into a Message object, then
1304 into a TREE_CONST_EXPR, and finally embed this one into a
1305 TREE_ATTRIBUTE_LIST. */
1306 attributeOOP = _gst_make_attribute (message);
1307 }
1308 constant = _gst_make_oop_constant (&message->location, attributeOOP);
1309 attr = _gst_make_attribute_list (&constant->location, constant);
1310 lex_skip_mandatory (p, '>');
1311 return attr;
1312 }
1313
1314
1315 /* temporaries: '|' variables '|'
1316 | empty
1317 temp_no_pipe: variables '|'
1318 variables: variables variable
1319 | empty */
1320
1321 static tree_node
parse_temporaries(gst_parser * p,mst_Boolean implied_pipe)1322 parse_temporaries (gst_parser *p, mst_Boolean implied_pipe)
1323 {
1324 tree_node temps = NULL;
1325 if (!implied_pipe && !lex_skip_if (p, '|', false))
1326 return NULL;
1327
1328 while (!lex_skip_if (p, '|', true))
1329 {
1330 tree_node temp;
1331 if (token (p, 0) != IDENTIFIER)
1332 expected (p, '|', IDENTIFIER, -1);
1333 temp = parse_variable (p);
1334 temp = _gst_make_variable_list (&temp->location, temp);
1335 temps = _gst_add_node (temps, temp);
1336 }
1337
1338 return temps;
1339 }
1340
1341
1342 /* statements: statements_no_ret return_statement opt_dot
1343 | statements_no_ret opt_dot
1344 statements_no_ret: statements_no_ret '.' statement
1345 | empty
1346 opt_dot: '.'
1347 | empty */
1348
1349 static tree_node
parse_statements(gst_parser * p,tree_node first_stmt,mst_Boolean accept_caret)1350 parse_statements (gst_parser *p, tree_node first_stmt, mst_Boolean accept_caret)
1351 {
1352 tree_node stmts, stmt;
1353 mst_Boolean caret;
1354
1355 if (first_stmt)
1356 {
1357 stmts = _gst_make_statement_list (&first_stmt->location, first_stmt);
1358 if (!lex_skip_if (p, '.', false))
1359 return stmts;
1360 }
1361 else
1362 stmts = NULL;
1363
1364 do
1365 {
1366 caret = accept_caret && lex_skip_if (p, '^', false);
1367 if (caret)
1368 {
1369 stmt = parse_required_expression (p);
1370 stmt = _gst_make_return (&stmt->location, stmt);
1371 }
1372 else
1373 {
1374 stmt = parse_expression (p, EXPR_ANY);
1375 if (stmt == NULL)
1376 break;
1377 }
1378
1379 stmt = _gst_make_statement_list (&stmt->location, stmt);
1380 stmts = _gst_add_node (stmts, stmt);
1381 }
1382 while (lex_skip_if (p, '.', false) && !caret);
1383 return stmts;
1384 }
1385
1386
1387
1388 /* expression: primary
1389 | variable ':=' expression
1390 | message_expression cascaded_messages */
1391
1392 static tree_node
parse_expression(gst_parser * p,enum expr_kinds kind)1393 parse_expression (gst_parser *p, enum expr_kinds kind)
1394 {
1395 tree_node node, assigns = NULL;
1396 for (;;)
1397 {
1398 if (token (p, 0) != IDENTIFIER)
1399 {
1400 node = parse_primary (p);
1401 break;
1402 }
1403 else
1404 {
1405 node = parse_variable_primary (p);
1406 if (!node
1407 || (kind & EXPR_ASSIGNMENT) == 0
1408 || !lex_skip_if (p, ASSIGNMENT, false))
1409 break;
1410 }
1411
1412 assigns = _gst_add_node (assigns,
1413 _gst_make_assignment_list (&node->location,
1414 node));
1415 }
1416
1417 if (!node && assigns)
1418 {
1419 _gst_errorf ("expected expression");
1420 recover_error (p);
1421 }
1422
1423 if (node)
1424 {
1425 node = parse_message_expression (p, node, kind & ~EXPR_ASSIGNMENT);
1426 assert (node);
1427 }
1428
1429 if (assigns)
1430 node = _gst_make_assign (&assigns->location, assigns, node);
1431
1432 return node;
1433 }
1434
1435 static tree_node
parse_required_expression(gst_parser * p)1436 parse_required_expression (gst_parser *p)
1437 {
1438 tree_node stmt = parse_expression (p, EXPR_ANY);
1439 if (!stmt)
1440 {
1441 _gst_errorf ("expected expression");
1442 recover_error (p);
1443 }
1444 return stmt;
1445 }
1446
1447 /* primary: variable_primary
1448 | '(' expression ')'
1449 | literal
1450 | block
1451 | array_constructor */
1452
1453 static tree_node
parse_primary(gst_parser * p)1454 parse_primary (gst_parser *p)
1455 {
1456 tree_node node;
1457
1458 switch (token (p, 0))
1459 {
1460 case IDENTIFIER:
1461 node = parse_variable_primary (p);
1462 break;
1463
1464 case STRING_LITERAL:
1465 case SYMBOL_LITERAL:
1466 case INTEGER_LITERAL:
1467 case LARGE_INTEGER_LITERAL:
1468 case FLOATD_LITERAL:
1469 case FLOATE_LITERAL:
1470 case FLOATQ_LITERAL:
1471 case SCALED_DECIMAL_LITERAL:
1472 case CHAR_LITERAL:
1473 case '#':
1474 case '-':
1475 node = parse_literal (p, false);
1476 break;
1477
1478 case '[':
1479 node = parse_block (p);
1480 break;
1481
1482 case '{':
1483 node = parse_array_constructor (p);
1484 break;
1485
1486 case '(':
1487 lex (p);
1488 node = parse_required_expression (p);
1489 lex_skip_mandatory (p, ')');
1490 break;
1491
1492 default:
1493 return NULL;
1494 }
1495
1496 return node;
1497 }
1498
1499
1500 /* variable_primary: variable_primary SCOPE_SEPARATOR IDENTIFIER
1501 | IDENTIFIER */
1502
1503 static tree_node
parse_variable_primary_1(gst_parser * p,YYLTYPE * first_loc,const char * first_val)1504 parse_variable_primary_1 (gst_parser *p, YYLTYPE *first_loc,
1505 const char *first_val)
1506 {
1507 tree_node node;
1508 assert (token (p, 0) == IDENTIFIER);
1509 node = _gst_make_variable (first_loc, first_val);
1510 for (;;)
1511 {
1512 lex (p);
1513 if (!lex_skip_if (p, SCOPE_SEPARATOR, false))
1514 break;
1515
1516 lex_must_be (p, IDENTIFIER);
1517 node = _gst_add_node (node, _gst_make_variable (loc (p, 0), val(p, 0)->sval));
1518 }
1519
1520 return node;
1521 }
1522
1523 static tree_node
parse_variable_primary(gst_parser * p)1524 parse_variable_primary (gst_parser *p)
1525 {
1526 return parse_variable_primary_1 (p, loc (p, 0), val(p, 0)->sval);
1527 }
1528
1529
1530 /* array_literal_elt: array_literal
1531 | byte_array_literal
1532 | literal
1533 | builtin_identifier
1534
1535 literal: <any literal token>
1536 | '#' array_literal
1537 | '#' byte_array_literal
1538 | '#' binding_constant
1539 | '#' '#' compile_time_constant */
1540
1541 static tree_node
parse_literal(gst_parser * p,mst_Boolean array)1542 parse_literal (gst_parser *p, mst_Boolean array)
1543 {
1544 tree_node node;
1545 int ival;
1546 int tok = token (p, 0);
1547
1548 switch (tok)
1549 {
1550 case '-':
1551 lex (p);
1552 tok = token (p, 0);
1553 switch (tok)
1554 {
1555 case INTEGER_LITERAL:
1556 case LARGE_INTEGER_LITERAL:
1557 case FLOATD_LITERAL:
1558 case FLOATE_LITERAL:
1559 case FLOATQ_LITERAL:
1560 case SCALED_DECIMAL_LITERAL:
1561 if (_gst_negate_yylval (tok, val (p, 0)))
1562 return parse_literal (p, array);
1563 else
1564 {
1565 _gst_errorf ("parse error, expected positive numeric literal");
1566 recover_error (p);
1567 }
1568
1569 default:
1570 expected (p, INTEGER_LITERAL, FLOATD_LITERAL, SCALED_DECIMAL_LITERAL,
1571 -1);
1572 }
1573 break;
1574
1575 case '(':
1576 assert (array);
1577 node = parse_array_literal (p);
1578 return node;
1579
1580 case '[':
1581 assert (array);
1582 node = parse_byte_array_literal (p);
1583 return node;
1584
1585 case IDENTIFIER:
1586 node = parse_builtin_identifier (p);
1587 return node;
1588
1589 case STRING_LITERAL:
1590 node = _gst_make_string_constant (loc (p, 0), val(p, 0)->sval);
1591 break;
1592
1593 case SYMBOL_LITERAL:
1594 node = _gst_intern_ident (loc (p, 0), val(p, 0)->sval);
1595 node = _gst_make_symbol_constant (loc (p, 0), node);
1596 break;
1597
1598 case INTEGER_LITERAL:
1599 node = _gst_make_int_constant (loc (p, 0), val(p, 0)->ival);
1600 break;
1601
1602 case LARGE_INTEGER_LITERAL:
1603 node = _gst_make_byte_object_constant (loc (p, 0), val(p, 0)->boval);
1604 break;
1605
1606 case FLOATD_LITERAL:
1607 node = _gst_make_float_constant (loc (p, 0), val(p, 0)->fval, CONST_FLOATD);
1608 break;
1609
1610 case FLOATE_LITERAL:
1611 node = _gst_make_float_constant (loc (p, 0), val(p, 0)->fval, CONST_FLOATE);
1612 break;
1613
1614 case FLOATQ_LITERAL:
1615 node = _gst_make_float_constant (loc (p, 0), val(p, 0)->fval, CONST_FLOATQ);
1616 break;
1617
1618 case SCALED_DECIMAL_LITERAL:
1619 node = _gst_make_oop_constant (loc (p, 0), val(p, 0)->oval);
1620 break;
1621
1622 case CHAR_LITERAL:
1623 ival = val(p, 0)->ival;
1624 lex (p);
1625
1626 /* Special case $< INTEGER_LITERAL > where the integer literal
1627 is positive. */
1628 if (ival == '<' && token (p, 0) == INTEGER_LITERAL && val(p, 0)->ival >= 0)
1629 {
1630 ival = val(p, 0)->ival;
1631 lex (p);
1632 lex_skip_mandatory (p, '>');
1633
1634 if (ival > 0x10FFFF)
1635 {
1636 _gst_errorf ("character code point out of range");
1637 recover_error (p);
1638 }
1639 }
1640
1641 return _gst_make_char_constant (loc (p, 0), ival);
1642
1643 case '#':
1644 lex (p);
1645 switch (token (p, 0))
1646 {
1647 case '(':
1648 case '[':
1649 return parse_literal (p, true);
1650
1651 case '#':
1652 return parse_compile_time_constant (p);
1653
1654 case '{':
1655 return parse_binding_constant (p);
1656
1657 default:
1658 expected (p, '(', '[', '#', '{', -1);
1659 }
1660 break;
1661
1662 default:
1663 return NULL;
1664 }
1665
1666 lex (p);
1667 return node;
1668 }
1669
1670
1671 /* array_literal: '(' array_literal_elts ')'
1672 array_literal_elts: array_literal_elts array_literal_elt
1673 | empty */
1674
1675 static tree_node
parse_array_literal(gst_parser * p)1676 parse_array_literal (gst_parser *p)
1677 {
1678 tree_node elts = NULL;
1679 assert (token (p, 0) == '(');
1680 lex (p);
1681
1682 while (!lex_skip_if (p, ')', true))
1683 {
1684 tree_node lit = parse_literal (p, true);
1685 if (lit == NULL)
1686 return NULL;
1687 elts = _gst_add_node (elts, _gst_make_array_elt (&lit->location, lit));
1688 }
1689
1690 return _gst_make_array_constant (elts ? &elts->location : loc (p, 0), elts);
1691 }
1692
1693
1694 /* builtin_identifier: "true" | "false" | "nil" */
1695
1696 static tree_node
parse_builtin_identifier(gst_parser * p)1697 parse_builtin_identifier (gst_parser *p)
1698 {
1699 OOP symbolOOP;
1700 tree_node node;
1701 YYLTYPE location = *loc(p,0);
1702
1703 assert (token (p, 0) == IDENTIFIER);
1704 symbolOOP = _gst_intern_string (val(p, 0)->sval);
1705 if (symbolOOP == _gst_true_symbol)
1706 node = _gst_make_oop_constant (&location, _gst_true_oop);
1707
1708 else if (symbolOOP == _gst_false_symbol)
1709 node = _gst_make_oop_constant (&location, _gst_false_oop);
1710
1711 else if (symbolOOP == _gst_nil_symbol)
1712 node = _gst_make_oop_constant (&location, _gst_nil_oop);
1713
1714 else
1715 {
1716 _gst_errorf ("expected true, false or nil");
1717 recover_error (p);
1718 }
1719
1720 lex (p);
1721 return node;
1722 }
1723
1724
1725 /* byte_array_literal: '[' byte_array_literal_elts ']'
1726 byte_array_literal_elts: byte_array_literal_elts INTEGER_LITERAL
1727 | empty */
1728
1729 static tree_node
parse_byte_array_literal(gst_parser * p)1730 parse_byte_array_literal (gst_parser *p)
1731 {
1732 tree_node elts = NULL;
1733 assert (token (p, 0) == '[');
1734 lex (p);
1735
1736 while (!lex_skip_if (p, ']', true))
1737 {
1738 tree_node lit;
1739 lex_must_be (p, INTEGER_LITERAL);
1740 if (val(p, 0)->ival < 0 || val(p, 0)->ival > 255)
1741 {
1742 _gst_errorf ("byte constant out of range");
1743 recover_error (p);
1744 }
1745 lit = _gst_make_int_constant (loc (p, 0), val(p, 0)->ival);
1746 lex (p);
1747 elts = _gst_add_node (elts, _gst_make_array_elt (&lit->location, lit));
1748 }
1749
1750 return _gst_make_byte_array_constant (elts ? &elts->location : loc (p, 0), elts);
1751 }
1752
1753
1754 /* compile_time_constant: '(' temporaries statements ')' */
1755
1756 static tree_node
parse_compile_time_constant(gst_parser * p)1757 parse_compile_time_constant (gst_parser *p)
1758 {
1759 tree_node temps, statements;
1760 YYLTYPE location = *loc(p,0);
1761 OOP result = NULL;
1762
1763 assert (token (p, 0) == '#');
1764 lex (p);
1765 lex_skip_mandatory (p, '(');
1766 temps = parse_temporaries (p, false);
1767 statements = parse_statements (p, NULL, true);
1768 lex_skip_mandatory (p, ')');
1769
1770 if (statements && !_gst_had_error)
1771 result = _gst_execute_statements (temps, statements, UNDECLARED_NONE, true);
1772
1773 return _gst_make_oop_constant (&location, result ? result : _gst_nil_oop);
1774 }
1775
1776
1777 /* binding_constant: '{' variable_primary '}' */
1778
1779 static tree_node
parse_binding_constant(gst_parser * p)1780 parse_binding_constant (gst_parser *p)
1781 {
1782 tree_node node;
1783
1784 assert (token (p, 0) == '{');
1785 lex (p);
1786 lex_must_be (p, IDENTIFIER);
1787 node = parse_variable_primary (p);
1788 lex_skip_mandatory (p, '}');
1789
1790 return _gst_make_binding_constant (&node->location, node);
1791 }
1792
1793
1794 /* array_constructor: '{' statements_no_ret '}' */
1795
1796 static tree_node
parse_array_constructor(gst_parser * p)1797 parse_array_constructor (gst_parser *p)
1798 {
1799 tree_node stmts;
1800 YYLTYPE location = *loc(p,0);
1801
1802 assert (token (p, 0) == '{');
1803 lex (p);
1804
1805 stmts = parse_statements (p, NULL, false);
1806 lex_skip_mandatory (p, '}');
1807 return _gst_make_array_constructor (&location, stmts);
1808 }
1809
1810
1811 /* block: '[' block_vars '||' temps_no_pipe statements ']'
1812 | '[' block_vars '|' temporaries statements ']'
1813 | '[' block_vars ']'
1814 | '[' temporaries statements ']' */
1815
1816 static tree_node
parse_block(gst_parser * p)1817 parse_block (gst_parser *p)
1818 {
1819 YYLTYPE location = *loc(p,0);
1820 tree_node vars, temps, stmts;
1821 mst_Boolean implied_pipe;
1822
1823 assert (token (p, 0) == '[');
1824 lex (p);
1825
1826 if (token (p, 0) == ':')
1827 {
1828 vars = parse_block_variables (p);
1829 if (token (p, 0) == ']')
1830 implied_pipe = false;
1831 else if (lex_skip_if (p, '|', true))
1832 implied_pipe = false;
1833 else if (token (p, 0) == BINOP
1834 && val(p, 0)->sval[0] == '|' && val(p, 0)->sval[1] == '|')
1835 {
1836 implied_pipe = true;
1837 lex (p);
1838 }
1839 else
1840 expected (p, ':', '|', ']', -1);
1841 }
1842 else
1843 {
1844 vars = NULL;
1845 implied_pipe = false;
1846 }
1847
1848 temps = parse_temporaries (p, implied_pipe);
1849 stmts = parse_statements (p, NULL, true);
1850
1851 lex_skip_mandatory (p, ']');
1852 return _gst_make_block (&location, vars, temps, stmts);
1853 }
1854
1855
1856 /* block_vars: ':' IDENTIFIER
1857 | block_vars ':' IDENTIFIER */
1858
1859 static tree_node
parse_block_variables(gst_parser * p)1860 parse_block_variables (gst_parser *p)
1861 {
1862 tree_node vars = NULL;
1863 assert (token (p, 0) == ':');
1864
1865 while (lex_skip_if (p, ':', false))
1866 vars = _gst_add_node (vars, parse_variable (p));
1867
1868 return vars;
1869 }
1870
1871
1872 /* message_expression: unary_expression
1873 | binary_expression
1874 | keyword_expression
1875
1876 unary_expression: primary unary_message
1877 | unary_expression unary_message
1878 unary_message: IDENTIFIER
1879
1880 binary_expression: unary_expression binop unary_expression
1881 | binary_expression binop unary_expression
1882
1883 keyword_expression: binary_expression KEYWORD binary_expression
1884 | keyword_expression KEYWORD binary_expression */
1885
1886 static tree_node
parse_message_expression(gst_parser * p,tree_node receiver,enum expr_kinds kind)1887 parse_message_expression (gst_parser *p, tree_node receiver, enum expr_kinds kind)
1888 {
1889 tree_node node = receiver;
1890 int n;
1891 for (n = 0; ; n++)
1892 {
1893 switch (token (p, 0))
1894 {
1895 case IDENTIFIER:
1896 node = parse_unary_expression (p, node, kind & ~EXPR_CASCADE);
1897 break;
1898
1899 case '>':
1900 if ((kind & EXPR_GREATER) == 0)
1901 return node;
1902
1903 case BINOP:
1904 case '<':
1905 case '-':
1906 case '|':
1907 if ((kind & EXPR_BINOP) == 0)
1908 return node;
1909 node = parse_binary_expression (p, node, kind & ~EXPR_CASCADE);
1910 break;
1911
1912 case KEYWORD:
1913 if ((kind & EXPR_KEYWORD) == 0)
1914 return node;
1915 node = parse_keyword_expression (p, node, kind & ~EXPR_CASCADE);
1916 break;
1917
1918 case ';':
1919 if (n == 0 || (kind & EXPR_CASCADE) == 0)
1920 return node;
1921 return _gst_make_cascaded_message (&node->location, node,
1922 parse_cascaded_messages (p));
1923
1924 default:
1925 return node;
1926 }
1927 }
1928
1929 abort ();
1930 }
1931
1932
1933 /* cascaded_messages: cascaded_messages ';' message_expression
1934 | empty */
1935
1936 static tree_node
parse_cascaded_messages(gst_parser * p)1937 parse_cascaded_messages (gst_parser *p)
1938 {
1939 tree_node cascade = NULL;
1940 while (lex_skip_if (p, ';', false))
1941 {
1942 tree_node node;
1943 switch (token (p, 0))
1944 {
1945 case IDENTIFIER:
1946 node = parse_unary_expression (p, NULL, EXPR_CASCADED);
1947 break;
1948
1949 case '>':
1950 case BINOP:
1951 case '<':
1952 case '-':
1953 case '|':
1954 node = parse_binary_expression (p, NULL, EXPR_CASCADED);
1955 break;
1956
1957 case KEYWORD:
1958 node = parse_keyword_expression (p, NULL, EXPR_CASCADED);
1959 break;
1960
1961 default:
1962 /* After a semicolon, we can expect a message send. */
1963 expected (p, IDENTIFIER, BINOP, KEYWORD, -1);
1964 }
1965
1966 node = _gst_make_message_list (&node->location, node);
1967 cascade = _gst_add_node (cascade, node);
1968 }
1969
1970 return cascade;
1971 }
1972
1973
1974 /* See above. This function only parses one unary expression. */
1975
1976 static tree_node
parse_unary_expression(gst_parser * p,tree_node receiver,enum expr_kinds kind)1977 parse_unary_expression (gst_parser *p, tree_node receiver, enum expr_kinds kind)
1978 {
1979 YYLTYPE location = receiver ? receiver->location : *loc(p,0);
1980 char *sel;
1981 assert (token (p, 0) == IDENTIFIER);
1982 sel = val(p, 0)->sval;
1983 if (is_unlikely_selector (sel))
1984 _gst_warningf ("sending `%s', most likely you forgot a period", sel);
1985
1986 lex (p);
1987 return _gst_make_unary_expr (&location, receiver, sel);
1988 }
1989
1990
1991 /* See above. This function only parses one binary expression. */
1992
1993 static tree_node
parse_binary_expression(gst_parser * p,tree_node receiver,enum expr_kinds kind)1994 parse_binary_expression (gst_parser *p, tree_node receiver, enum expr_kinds kind)
1995 {
1996 YYLTYPE location = receiver ? receiver->location : *loc(p,0);
1997 char *sel;
1998 tree_node arg;
1999 assert (token (p, 0) == BINOP || token (p, 0) == '|' || token (p, 0) == '<'
2000 || token (p, 0) == '-' || token (p, 0) == '>');
2001 sel = val(p, 0)->sval;
2002 lex (p);
2003 arg = parse_expression (p, kind & ~EXPR_KEYWORD & ~EXPR_BINOP);
2004 if (!arg)
2005 {
2006 _gst_errorf ("expected object");
2007 recover_error (p);
2008 }
2009
2010 return _gst_make_binary_expr (&location, receiver, sel, arg);
2011 }
2012
2013 /* See above. This function parses a keyword expression with all its
2014 arguments. */
2015
2016 static tree_node
parse_keyword_expression(gst_parser * p,tree_node receiver,enum expr_kinds kind)2017 parse_keyword_expression (gst_parser *p, tree_node receiver, enum expr_kinds kind)
2018 {
2019 YYLTYPE location = receiver ? receiver->location : *loc(p,0);
2020 tree_node list = parse_keyword_list (p, kind);
2021 return list ? _gst_make_keyword_expr (&location, receiver, list) : NULL;
2022 }
2023
2024 static tree_node
parse_keyword_list(gst_parser * p,enum expr_kinds kind)2025 parse_keyword_list (gst_parser *p, enum expr_kinds kind)
2026 {
2027 tree_node expr = NULL;
2028 assert (token (p, 0) == KEYWORD);
2029
2030 do
2031 {
2032 YYLTYPE location = *loc(p,0);
2033 char *sval = val(p, 0)->sval;
2034 tree_node arg;
2035 lex (p);
2036 arg = parse_expression (p, kind & ~EXPR_KEYWORD);
2037 if (!arg)
2038 {
2039 _gst_errorf ("expected object");
2040 recover_error (p);
2041 }
2042
2043 expr = _gst_add_node (expr, _gst_make_keyword_list (&location, sval, arg));
2044 }
2045 while (token (p, 0) == KEYWORD);
2046
2047 return expr;
2048 }
2049
2050
2051 /* Based on a hash table produced by gperf version 2.7.2
2052 Command-line: gperf -tn -F ', false' -j1 -k1,2
2053 with the following input:
2054
2055 false
2056 nil
2057 self
2058 super
2059 thisContext
2060 true
2061 fe
2062 ne
2063 nh
2064 sr
2065
2066 A few negatives have been included in the input to avoid that
2067 messages like #new or #size require a strcmp (their hash value is
2068 in range if only the six keywords are included), and the length
2069 has not been included to make the result depend on selectors
2070 *starting* with two given letters. With this hash table and this
2071 implementation, only selectors starting with "fa", "ni", "se",
2072 "su", "th", "tr" (which are unavoidable) require a strcmp, which is
2073 a good compromise. All the others require three array lookups
2074 (two for the hash function, one to check for the first character)
2075
2076 An alternative could have been simple trie-like
2077 code like this:
2078
2079 return ((*$1 == 's' &&
2080 (strcmp ($1+1, "elf") == 0 ||
2081 strcmp ($1+1, "uper") == 0)) ||
2082
2083 (*$1 == 't' &&
2084 (strcmp ($1+1, "rue") == 0 ||
2085 strcmp ($1+1, "hisContext") == 0)) ||
2086
2087 (*$1 == 'f' && strcmp ($1+1, "alse") == 0) ||
2088 (*$1 == 'n' && strcmp ($1+1, "il") == 0))
2089
2090 ... but using gperf is more cool :-) */
2091
2092 mst_Boolean
is_unlikely_selector(register const char * str)2093 is_unlikely_selector (register const char *str)
2094 {
2095 /* The first-character table is big enough that
2096 we skip the range check on the hash value */
2097
2098 static const char first[31] =
2099 "s s f n tt ";
2100
2101 static const char *rest[] =
2102 {
2103 "elf",
2104 NULL,
2105 NULL,
2106 "uper",
2107 NULL,
2108 NULL,
2109 NULL,
2110 "alse",
2111 NULL,
2112 NULL,
2113 "il",
2114 NULL,
2115 NULL,
2116 "hisContext",
2117 "rue"
2118 };
2119
2120 static unsigned char asso_values[] =
2121 {
2122 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2123 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2124 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2125 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2126 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2127 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2128 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2129 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2130 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2131 15, 15, 15, 15, 15, 15, 15, 1, 15, 15,
2132 15, 0, 6, 15, 4, 2, 15, 15, 15, 15,
2133 8, 15, 15, 15, 5, 0, 9, 3, 15, 15,
2134 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2135 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2136 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2137 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2138 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2139 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2140 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2141 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2142 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2143 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2144 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2145 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2146 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
2147 15, 15, 15, 15, 15, 15
2148 };
2149
2150 register int key = asso_values[(unsigned char)str[1]] +
2151 asso_values[(unsigned char)str[0]];
2152
2153 return
2154 first[key] == *str &&
2155 !strcmp (str + 1, rest[key]);
2156 }
2157