Babylon/mud
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
master
mud/fluffos-2.23-ds03/grammar.y.pre
Babylon 433e764989 first commit
2020-09-06 05:43:07 -07:00

3794 lines
92 KiB
C
Raw Permalink Blame History

/* This is to make emacs edit this in C mode: -*-C-*- */
%{
extern char *outp;
#include "std.h"
#include "compiler.h"
#include "lex.h"
#include "scratchpad.h"
#include "lpc_incl.h"
#include "simul_efun.h"
#include "generate.h"
#include "master.h"
/* gross. Necessary? - Beek */
#ifdef WIN32
#define MSDOS
#endif
#define YYSTACK_USE_ALLOCA 0
%line
/*
* This is the grammar definition of LPC, and its parse tree generator.
*/
/* down to one global :)
bits:
SWITCH_CONTEXT - we're inside a switch
LOOP_CONTEXT - we're inside a loop
SWITCH_STRINGS - a string case has been found
SWITCH_NUMBERS - a non-zero numeric case has been found
SWITCH_RANGES - a range has been found
SWITCH_DEFAULT - a default has been found
*/
int context;
int num_refs;
int func_present;
/*
* bison & yacc don't prototype this in y.tab.h
*/
int yyparse (void);
%}
/*
* Token definitions.
*
* Appearing in the precedence declarations are:
* '+' '-' '/' '*' '%'
* '&' '|' '<' '>' '^'
* '~' '?'
*
* Other single character tokens recognized in this grammar:
* '{' '}' ',' ';' ':'
* '(' ')' '[' ']' '$'
*/
%token L_STRING L_NUMBER L_REAL
%token L_BASIC_TYPE L_TYPE_MODIFIER
%token L_DEFINED_NAME L_IDENTIFIER
%token L_EFUN
%token L_INC L_DEC
%token L_ASSIGN
%token L_LAND L_LOR
%token L_LSH L_RSH
%token L_ORDER
%token L_NOT
%token L_IF L_ELSE
%token L_SWITCH L_CASE L_DEFAULT L_RANGE L_DOT_DOT_DOT
%token L_WHILE L_DO L_FOR L_FOREACH L_IN
%token L_BREAK L_CONTINUE
%token L_RETURN
%token L_ARROW L_INHERIT L_COLON_COLON
%token L_ARRAY_OPEN L_MAPPING_OPEN L_FUNCTION_OPEN L_NEW_FUNCTION_OPEN
%token L_SSCANF L_CATCH
%ifdef DEBUG
%token L_TREE
%endif
%ifdef ARRAY_RESERVED_WORD
%token L_ARRAY
%endif
%ifdef REF_RESERVED_WORD
%token L_REF
%endif
%token L_PARSE_COMMAND L_TIME_EXPRESSION
%token L_CLASS L_NEW
%token L_PARAMETER
%ifdef COMPAT_32
%token L_LAMBDA
%endif
/*
* 'Dangling else' shift/reduce conflict is well known...
* define these precedences to shut yacc up.
*/
%nonassoc LOWER_THAN_ELSE
%nonassoc L_ELSE
/*
* Operator precedence and associativity...
* greatly simplify the grammar.
*/
%right L_ASSIGN
%right '?'
%left L_LOR
%left L_LAND
%left '|'
%left '^'
%left '&'
%left L_EQ L_NE
%left L_ORDER '<'
%left L_LSH L_RSH
%left '+' '-'
%left '*' '%' '/'
%right L_NOT '~'
%nonassoc L_INC L_DEC
/*
* YYTYPE
*
* Anything with size > 4 is commented. Sizes assume typical 32 bit
* architecture. This size of the largest element of this union should
* be kept as small as possible to optimize copying of compiler stack
* elements.
*/
%union
{
POINTER_INT pointer_int;
long number;
float real;
char *string;
struct { short num_arg; char flags; } argument;
ident_hash_elem_t *ihe;
parse_node_t *node;
function_context_t *contextp;
struct {
parse_node_t *node;
char num;
} decl; /* 5 */
struct {
char num_local;
char max_num_locals;
short context;
short save_current_type;
short save_exact_types;
} func_block; /* 8 */
}
/*
* Type declarations.
*/
/* These hold opcodes */
%type <number> efun_override L_ASSIGN L_ORDER
/* Holds a variable index */
%type <number> L_PARAMETER single_new_local_def
/* These hold arbitrary numbers */
%type <number> L_NUMBER
/* These hold numbers that are going to be stuffed into pointers :)
* Don't ask :)
*/
%type <pointer_int> constant
/* These hold a real number */
%type <real> L_REAL
/* holds a string constant */
%type <string> L_STRING string_con1 string_con2
/* Holds the number of elements in a list and whether it must be a prototype */
%type <argument> argument_list argument
/* These hold a list of possible interpretations of an identifier */
%type <ihe> L_DEFINED_NAME
/* These hold a type */
%type <number> type optional_star type_modifier_list
%type <number> opt_basic_type L_TYPE_MODIFIER L_BASIC_TYPE basic_type atomic_type
%type <number> cast arg_type
%ifdef ARRAY_RESERVED_WORD
%type <number> opt_atomic_type
%endif
/* This holds compressed and less flexible def_name information */
%type <number> L_NEW_FUNCTION_OPEN l_new_function_open
%ifdef COMPAT_32
%type <number> simple_function_pointer
%endif
/* holds an identifier or some sort */
%type <string> L_IDENTIFIER L_EFUN function_name identifier
%type <string> new_local_name
/* The following return a parse node */
%type <node> number real string expr0 comma_expr for_expr sscanf catch
%type <node> parse_command time_expression expr_list expr_list2 expr_list3
%type <node> expr_list4 assoc_pair expr4 lvalue function_call lvalue_list
%type <node> new_local_def statement while cond do switch case
%type <node> return optional_else_part block_or_semi
%type <node> case_label statements switch_block
%type <node> expr_list_node expr_or_block
%type <node> single_new_local_def_with_init
%type <node> class_init opt_class_init all def
%type <node> program modifier_change inheritance type_decl
%ifdef DEBUG
%type <node> tree
%endif
/* The following hold information about blocks and local vars */
%type <decl> local_declarations local_name_list block decl_block
%type <decl> foreach_var foreach_vars first_for_expr foreach for
/* This holds a flag */
%type <number> new_arg
%%
%pragma auto_note_compiler_case_start
all:
program
{
comp_trees[TREE_MAIN] = $$;
}
;
program:
program def possible_semi_colon
{
CREATE_TWO_VALUES($$, 0, $1, $2);
}
| /* empty */
{
$$ = 0;
}
;
possible_semi_colon:
/* empty */
| ';'
{
yywarn("Extra ';'. Ignored.");
}
;
inheritance:
type_modifier_list L_INHERIT string_con1 ';'
{
object_t *ob;
inherit_t inherit;
int initializer;
%ifdef SENSIBLE_MODIFIERS
int acc_mod;
%endif
$1 |= global_modifiers;
%ifdef SENSIBLE_MODIFIERS
acc_mod = ($1 & DECL_ACCESS) & ~global_modifiers;
if (acc_mod & (acc_mod - 1)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Multiple access modifiers (");
p = get_type_modifiers(p, end, $1);
p = strput(p, end, ") for inheritance");
yyerror(buf);
}
%endif
if (!($1 & DECL_ACCESS)) $1 |= DECL_PUBLIC;
#ifndef ALLOW_INHERIT_AFTER_FUNCTION
if (func_present)
yyerror("Illegal to inherit after defining functions.");
#endif
if (var_defined)
yyerror("Illegal to inherit after defining global variables.");
#ifndef ALLOW_INHERIT_AFTER_FUNCTION
if (func_present || var_defined){
#else
if (var_defined){
#endif
inherit_file = 0;
YYACCEPT;
}
#ifdef NEVER
} //stupid bison
#endif
ob = find_object2($3);
if (ob == 0) {
inherit_file = alloc_cstring($3, "inherit");
/* Return back to load_object() */
YYACCEPT;
}
scratch_free($3);
inherit.prog = ob->prog;
if (mem_block[A_INHERITS].current_size){
inherit_t *prev_inherit = INHERIT(NUM_INHERITS - 1);
inherit.function_index_offset
= prev_inherit->function_index_offset
+ prev_inherit->prog->num_functions_defined
+ prev_inherit->prog->last_inherited;
if (prev_inherit->prog->num_functions_defined &&
prev_inherit->prog->function_table[prev_inherit->prog->num_functions_defined - 1].funcname[0] == APPLY___INIT_SPECIAL_CHAR)
inherit.function_index_offset--;
} else inherit.function_index_offset = 0;
inherit.variable_index_offset =
mem_block[A_VAR_TEMP].current_size /
sizeof (variable_t);
inherit.type_mod = $1;
add_to_mem_block(A_INHERITS, (char *)&inherit, sizeof inherit);
/* The following has to come before copy_vars - Sym */
copy_structures(ob->prog);
copy_variables(ob->prog, $1);
initializer = copy_functions(ob->prog, $1);
if (initializer >= 0) {
parse_node_t *node, *newnode;
/* initializer is an index into the object we're
inheriting's function table; this finds the
appropriate entry in our table and generates
a call to it */
node = new_node_no_line();
node->kind = NODE_CALL_2;
node->r.expr = 0;
node->v.number = F_CALL_INHERITED;
node->l.number = initializer | ((NUM_INHERITS - 1) << 16);
node->type = TYPE_ANY;
/* The following illustrates a distinction between */
/* macros and funcs...newnode is needed here - Sym */
newnode = comp_trees[TREE_INIT];
CREATE_TWO_VALUES(comp_trees[TREE_INIT],0, newnode, node);
comp_trees[TREE_INIT] = pop_value(comp_trees[TREE_INIT]);
}
$$ = 0;
}
;
real:
L_REAL
{
CREATE_REAL($$, $1);
}
;
number:
L_NUMBER
{
CREATE_NUMBER($$, $1);
}
;
optional_star:
/* empty */
{
$$ = 0;
}
| '*'
{
$$ = TYPE_MOD_ARRAY;
}
;
block_or_semi:
block
{
$$ = $1.node;
if (!$$) {
CREATE_RETURN($$, 0);
}
}
| ';'
{
$$ = 0;
}
| error
{
$$ = 0;
}
;
identifier:
L_DEFINED_NAME
{
$$ = scratch_copy($1->name);
}
| L_IDENTIFIER
;
def:
type optional_star identifier
{
int flags;
%ifdef SENSIBLE_MODIFIERS
int acc_mod;
%endif
func_present = 1;
flags = ($1 >> 16);
flags |= global_modifiers;
%ifdef SENSIBLE_MODIFIERS
acc_mod = (flags & DECL_ACCESS) & ~global_modifiers;
if (acc_mod & (acc_mod - 1)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Multiple access modifiers (");
p = get_type_modifiers(p, end, flags);
p = strput(p, end, ") for function");
yyerror(buf);
}
%endif
if (!(flags & DECL_ACCESS)) flags |= DECL_PUBLIC;
%ifdef SENSIBLE_MODIFIERS
if (flags & DECL_NOSAVE) {
yywarn("Illegal to declare nosave function.");
flags &= ~DECL_NOSAVE;
}
%endif
$1 = (flags << 16) | ($1 & 0xffff);
/* Handle type checking here so we know whether to typecheck
'argument' */
if ($1 & 0xffff) {
%ifdef OLD_TYPE_BEHAVIOR
exact_types = 0;
%else
exact_types = ($1& 0xffff) | $2;
%endif
} else {
if (pragmas & PRAGMA_STRICT_TYPES) {
if (strcmp($3, "create") != 0)
yyerror("\"#pragma strict_types\" requires type of function");
else
exact_types = TYPE_VOID; /* default for create() */
} else
exact_types = 0;
}
}
'(' argument ')'
{
char *p = $3;
$3 = make_shared_string($3);
scratch_free(p);
/* If we had nested functions, we would need to check */
/* here if we have enough space for locals */
/*
* Define a prototype. If it is a real function, then the
* prototype will be replaced below.
*/
$<number>$ = FUNC_PROTOTYPE;
if ($6.flags & ARG_IS_VARARGS) {
$<number>$ |= (FUNC_TRUE_VARARGS | FUNC_VARARGS);
}
$<number>$ |= ($1 >> 16);
define_new_function($3, $6.num_arg, 0, $<number>$, ($1 & 0xffff)| $2);
/* This is safe since it is guaranteed to be in the
function table, so it can't be dangling */
free_string($3);
context = 0;
}
block_or_semi
{
/* Either a prototype or a block */
if ($9) {
int fun;
$<number>8 &= ~FUNC_PROTOTYPE;
if ($9->kind != NODE_RETURN &&
($9->kind != NODE_TWO_VALUES
|| $9->r.expr->kind != NODE_RETURN)) {
parse_node_t *replacement;
CREATE_STATEMENTS(replacement, $9, 0);
CREATE_RETURN(replacement->r.expr, 0);
$9 = replacement;
}
fun = define_new_function($3, $6.num_arg,
max_num_locals - $6.num_arg,
$<number>8, ($1 & 0xffff) | $2);
if (fun != -1) {
$$ = new_node_no_line();
$$->kind = NODE_FUNCTION;
$$->v.number = fun;
$$->l.number = max_num_locals;
$$->r.expr = $9;
} else
$$ = 0;
} else
$$ = 0;
free_all_local_names(!!$9);
}
| type name_list ';'
{
if (!($1 & ~(DECL_MODS)) && (pragmas & PRAGMA_STRICT_TYPES))
yyerror("Missing type for global variable declaration");
$$ = 0;
}
| inheritance
| type_decl
| modifier_change
;
modifier_change: type_modifier_list ':'
{
if (!$1)
yyerror("modifier list may not be empty.");
if ($1 & FUNC_VARARGS) {
yyerror("Illegal modifier 'varargs' in global modifier list.");
$1 &= ~FUNC_VARARGS;
}
if (!($1 & DECL_ACCESS)) $1 |= DECL_PUBLIC;
global_modifiers = $1;
$$ = 0;
}
;
member_name:
optional_star identifier
{
/* At this point, the current_type here is only a basic_type */
/* and cannot be unused yet - Sym */
if (current_type == TYPE_VOID)
yyerror("Illegal to declare class member of type void.");
add_local_name($2, current_type | $1);
scratch_free($2);
}
;
member_name_list:
member_name
| member_name ',' member_name_list
;
member_list:
/* empty */
| member_list basic_type
{
current_type = $2;
}
member_name_list ';'
;
type_decl:
type_modifier_list L_CLASS identifier '{'
{
ident_hash_elem_t *ihe;
ihe = find_or_add_ident(
PROG_STRING($<number>$ = store_prog_string($3)),
FOA_GLOBAL_SCOPE);
if (ihe->dn.class_num == -1) {
ihe->sem_value++;
ihe->dn.class_num = mem_block[A_CLASS_DEF].current_size / sizeof(class_def_t);
if (ihe->dn.class_num > CLASS_NUM_MASK){
char buf[256];
char *p;
p = buf;
sprintf(p, "Too many classes, max is %d.\n", CLASS_NUM_MASK + 1);
yyerror(buf);
}
scratch_free($3);
$<ihe>2 = 0;
}
else {
$<ihe>2 = ihe;
}
}
member_list '}'
{
class_def_t *sd;
class_member_entry_t *sme;
int i, raise_error = 0;
/* check for a redefinition */
if ($<ihe>2 != 0) {
sd = CLASS($<ihe>2->dn.class_num);
if (sd->size != current_number_of_locals)
raise_error = 1;
else {
i = sd->size;
sme = (class_member_entry_t *)mem_block[A_CLASS_MEMBER].block + sd->index;
while (i--) {
/* check for matching names and types */
if (strcmp(PROG_STRING(sme[i].membername), locals_ptr[i].ihe->name) != 0 ||
sme[i].type != (type_of_locals_ptr[i] & ~LOCAL_MODS)) {
raise_error = 1;
break;
}
}
}
}
if (raise_error) {
char buf[512];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Illegal to redefine class ");
p = strput(p, end, PROG_STRING($<number>$));
yyerror(buf);
} else {
sd = (class_def_t *)allocate_in_mem_block(A_CLASS_DEF, sizeof(class_def_t));
i = sd->size = current_number_of_locals;
sd->index = mem_block[A_CLASS_MEMBER].current_size / sizeof(class_member_entry_t);
sd->classname = $<number>5;
sme = (class_member_entry_t *)allocate_in_mem_block(A_CLASS_MEMBER, sizeof(class_member_entry_t) * current_number_of_locals);
while (i--) {
sme[i].membername = store_prog_string(locals_ptr[i].ihe->name);
sme[i].type = type_of_locals_ptr[i] & ~LOCAL_MODS;
}
}
free_all_local_names(0);
$$ = 0;
}
;
new_local_name:
L_IDENTIFIER
| L_DEFINED_NAME
{
if ($1->dn.local_num != -1) {
char buff[256];
char *end = EndOf(buff);
char *p;
p = strput(buff, end, "Illegal to redeclare local name '");
p = strput(p, end, $1->name);
p = strput(p, end, "'");
yyerror(buff);
}
$$ = scratch_copy($1->name);
}
;
atomic_type:
L_BASIC_TYPE
| L_CLASS L_DEFINED_NAME
{
if ($2->dn.class_num == -1) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Undefined class '");
p = strput(p, end, $2->name);
p = strput(p, end, "'");
yyerror(buf);
$$ = TYPE_ANY;
} else {
$$ = $2->dn.class_num | TYPE_MOD_CLASS;
}
}
| L_CLASS L_IDENTIFIER
{
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Undefined class '");
p = strput(p, end, $2);
p = strput(p, end, "'");
yyerror(buf);
$$ = TYPE_ANY;
}
;
%ifdef ARRAY_RESERVED_WORD
opt_atomic_type:
atomic_type
| /* empty */
{
$$ = TYPE_ANY;
}
;
%endif
basic_type:
atomic_type
%ifdef ARRAY_RESERVED_WORD
| opt_atomic_type L_ARRAY
{
$$ = $1 | TYPE_MOD_ARRAY;
}
%endif
;
arg_type:
basic_type
%ifdef REF_RESERVED_WORD
| basic_type ref
{
$$ = $1 | LOCAL_MOD_REF;
}
%endif
;
new_arg:
arg_type optional_star
{
$$ = $1 | $2;
if ($1 != TYPE_VOID)
add_local_name("", $1 | $2);
}
| arg_type optional_star new_local_name
{
if ($1 == TYPE_VOID)
yyerror("Illegal to declare argument of type void.");
add_local_name($3, $1 | $2);
scratch_free($3);
$$ = $1 | $2;
}
| new_local_name
{
if (exact_types) {
yyerror("Missing type for argument");
}
add_local_name($1, TYPE_ANY);
scratch_free($1);
$$ = TYPE_ANY;
}
;
argument:
/* empty */
{
$$.num_arg = 0;
$$.flags = 0;
}
| argument_list
| argument_list L_DOT_DOT_DOT
{
int x = type_of_locals_ptr[max_num_locals-1];
int lt = x & ~LOCAL_MODS;
$$ = $1;
$$.flags |= ARG_IS_VARARGS;
if (x & LOCAL_MOD_REF) {
yyerror("Variable to hold remainder of args may not be a reference");
x &= ~LOCAL_MOD_REF;
}
if (lt != TYPE_ANY && !(lt & TYPE_MOD_ARRAY))
yywarn("Variable to hold remainder of arguments should be an array.");
}
;
argument_list:
new_arg
{
if (($1 & TYPE_MASK) == TYPE_VOID && !($1 & TYPE_MOD_CLASS)) {
if ($1 & ~TYPE_MASK)
yyerror("Illegal to declare argument of type void.");
$$.num_arg = 0;
} else {
$$.num_arg = 1;
}
$$.flags = 0;
}
| argument_list ',' new_arg
{
if (!$$.num_arg) /* first arg was void w/no name */
yyerror("argument of type void must be the only argument.");
if (($3 & TYPE_MASK) == TYPE_VOID && !($3 & TYPE_MOD_CLASS))
yyerror("Illegal to declare argument of type void.");
$$ = $1;
$$.num_arg++;
}
;
type_modifier_list:
/* empty */
{
$$ = 0;
}
| L_TYPE_MODIFIER type_modifier_list
{
%ifdef SENSIBLE_MODIFIERS
int acc_mod;
%endif
$$ = $1 | $2;
%ifdef SENSIBLE_MODIFIERS
acc_mod = ($$ & DECL_ACCESS) & ~global_modifiers;
if (acc_mod & (acc_mod - 1)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Multiple access modifiers (");
p = get_type_modifiers(p, end, $$);
p = strput(p, end, ") ");
yyerror(buf);
$$ = DECL_PUBLIC;
}
%endif
}
;
type:
type_modifier_list opt_basic_type
{
$$ = ($1 << 16) | $2;
current_type = $$;
}
;
cast:
'(' basic_type optional_star ')'
{
$$ = $2 | $3;
}
;
opt_basic_type:
basic_type
| /* empty */
{
$$ = TYPE_UNKNOWN;
}
;
name_list:
new_name
| new_name ',' name_list
;
new_name:
optional_star identifier
{
if (current_type & (FUNC_VARARGS << 16)){
yyerror("Illegal to declare varargs variable.");
current_type &= ~(FUNC_VARARGS << 16);
}
/* Now it is ok to merge the two
* remember that class_num and varargs was the reason for above
* Do the merging once only per row of decls
*/
if (current_type & 0xffff0000){
current_type = (current_type >> 16) | (current_type & 0xffff);
}
current_type |= global_modifiers;
if (!(current_type & DECL_ACCESS)) current_type |= DECL_PUBLIC;
if ((current_type & ~DECL_MODS) == TYPE_VOID)
yyerror("Illegal to declare global variable of type void.");
define_new_variable($2, current_type | $1);
scratch_free($2);
}
| optional_star identifier L_ASSIGN expr0
{
parse_node_t *expr, *newnode;
int type;
if (current_type & (FUNC_VARARGS << 16)){
yyerror("Illegal to declare varargs variable.");
current_type &= ~(FUNC_VARARGS << 16);
}
if (current_type & 0xffff0000){
current_type = (current_type >> 16) | (current_type & 0xffff);
}
current_type |= global_modifiers;
if (!(current_type & DECL_ACCESS)) current_type |= DECL_PUBLIC;
if ((current_type & ~DECL_MODS) == TYPE_VOID)
yyerror("Illegal to declare global variable of type void.");
if ($3 != F_ASSIGN)
yyerror("Only '=' is legal in initializers.");
/* ignore current_type == 0, which gets a missing type error
later anyway */
if (current_type) {
type = (current_type | $1) & ~DECL_MODS;
if ((current_type & ~DECL_MODS) == TYPE_VOID)
yyerror("Illegal to declare global variable of type void.");
if (!compatible_types(type, $4->type)) {
char buff[256];
char *end = EndOf(buff);
char *p;
p = strput(buff, end, "Type mismatch ");
p = get_two_types(p, end, type, $4->type);
p = strput(p, end, " when initializing ");
p = strput(p, end, $2);
yyerror(buff);
}
} else type = 0;
$4 = do_promotions($4, type);
CREATE_BINARY_OP(expr, F_VOID_ASSIGN, 0, $4, 0);
CREATE_OPCODE_1(expr->r.expr, F_GLOBAL_LVALUE, 0,
define_new_variable($2, current_type | $1));
newnode = comp_trees[TREE_INIT];
CREATE_TWO_VALUES(comp_trees[TREE_INIT], 0,
newnode, expr);
scratch_free($2);
}
;
block:
'{' local_declarations statements '}'
{
if ($2.node && $3) {
CREATE_STATEMENTS($$.node, $2.node, $3);
} else $$.node = ($2.node ? $2.node : $3);
$$.num = $2.num;
}
;
decl_block: block | for | foreach ;
local_declarations:
/* empty */
{
$$.node = 0;
$$.num = 0;
}
| local_declarations basic_type
{
if ($2 == TYPE_VOID)
yyerror("Illegal to declare local variable of type void.");
/* can't do this in basic_type b/c local_name_list contains
* expr0 which contains cast which contains basic_type
*/
current_type = $2;
}
local_name_list ';'
{
if ($1.node && $4.node) {
CREATE_STATEMENTS($$.node, $1.node, $4.node);
} else $$.node = ($1.node ? $1.node : $4.node);
$$.num = $1.num + $4.num;
}
;
new_local_def:
optional_star new_local_name
{
if (current_type & LOCAL_MOD_REF) {
yyerror("Illegal to declare local variable as reference");
current_type &= ~LOCAL_MOD_REF;
}
add_local_name($2, current_type | $1 | LOCAL_MOD_UNUSED);
scratch_free($2);
$$ = 0;
}
| optional_star new_local_name L_ASSIGN expr0
{
int type = (current_type | $1) & ~DECL_MODS;
if (current_type & LOCAL_MOD_REF) {
yyerror("Illegal to declare local variable as reference");
current_type &= ~LOCAL_MOD_REF;
type &= ~LOCAL_MOD_REF;
}
if ($3 != F_ASSIGN)
yyerror("Only '=' is allowed in initializers.");
if (!compatible_types($4->type, type)) {
char buff[256];
char *end = EndOf(buff);
char *p;
p = strput(buff, end, "Type mismatch ");
p = get_two_types(p, end, type, $4->type);
p = strput(p, end, " when initializing ");
p = strput(p, end, $2);
yyerror(buff);
}
$4 = do_promotions($4, type);
CREATE_UNARY_OP_1($$, F_VOID_ASSIGN_LOCAL, 0, $4,
add_local_name($2, current_type | $1 | LOCAL_MOD_UNUSED));
scratch_free($2);
}
;
single_new_local_def:
arg_type optional_star new_local_name
{
if ($1 == TYPE_VOID)
yyerror("Illegal to declare local variable of type void.");
$$ = add_local_name($3, $1 | $2);
scratch_free($3);
}
;
single_new_local_def_with_init:
single_new_local_def L_ASSIGN expr0
{
int type = type_of_locals_ptr[$1];
if (type & LOCAL_MOD_REF) {
yyerror("Illegal to declare local variable as reference");
type_of_locals_ptr[$1] &= ~LOCAL_MOD_REF;
}
type &= ~LOCAL_MODS;
if ($2 != F_ASSIGN)
yyerror("Only '=' is allowed in initializers.");
if (!compatible_types($3->type, type)) {
char buff[256];
char *end = EndOf(buff);
char *p;
p = strput(buff, end, "Type mismatch ");
p = get_two_types(p, end, type, $3->type);
p = strput(p, end, " when initializing.");
yyerror(buff);
}
$3 = do_promotions($3, type);
/* this is an expression */
CREATE_BINARY_OP($$, F_ASSIGN, 0, $3, 0);
CREATE_OPCODE_1($$->r.expr, F_LOCAL_LVALUE, 0, $1);
}
;
local_name_list:
new_local_def
{
$$.node = $1;
$$.num = 1;
}
| new_local_def ',' local_name_list
{
if ($1 && $3.node) {
CREATE_STATEMENTS($$.node, $1, $3.node);
} else $$.node = ($1 ? $1 : $3.node);
$$.num = 1 + $3.num;
}
;
statements:
/* empty */
{
$$ = 0;
}
| statement statements
{
if ($1 && $2) {
CREATE_STATEMENTS($$, $1, $2);
} else $$ = ($1 ? $1 : $2);
}
| error ';'
{
$$ = 0;
}
;
statement:
comma_expr ';'
{
$$ = pop_value($1);
#ifdef DEBUG
{
parse_node_t *replacement;
CREATE_STATEMENTS(replacement, $$, 0);
CREATE_OPCODE(replacement->r.expr, F_BREAK_POINT, 0);
$$ = replacement;
}
#endif
}
| cond
| while
| do
| switch
| return
| decl_block
{
$$ = $1.node;
pop_n_locals($1.num);
}
| /* empty */ ';'
{
$$ = 0;
}
| L_BREAK ';'
{
if (context & SPECIAL_CONTEXT) {
yyerror("Cannot break out of catch { } or time_expression { }");
$$ = 0;
} else
if (context & SWITCH_CONTEXT) {
CREATE_CONTROL_JUMP($$, CJ_BREAK_SWITCH);
} else
if (context & LOOP_CONTEXT) {
CREATE_CONTROL_JUMP($$, CJ_BREAK);
if (context & LOOP_FOREACH) {
parse_node_t *replace;
CREATE_STATEMENTS(replace, 0, $$);
CREATE_OPCODE(replace->l.expr, F_EXIT_FOREACH, 0);
$$ = replace;
}
} else {
yyerror("break statement outside loop");
$$ = 0;
}
}
| L_CONTINUE ';'
{
if (context & SPECIAL_CONTEXT)
yyerror("Cannot continue out of catch { } or time_expression { }");
else
if (!(context & LOOP_CONTEXT))
yyerror("continue statement outside loop");
CREATE_CONTROL_JUMP($$, CJ_CONTINUE);
}
;
while:
L_WHILE '(' comma_expr ')'
{
$<number>1 = context;
context = LOOP_CONTEXT;
}
statement
{
CREATE_LOOP($$, 1, $6, 0, optimize_loop_test($3));
context = $<number>1;
}
;
do:
L_DO
{
$<number>1 = context;
context = LOOP_CONTEXT;
}
statement L_WHILE '(' comma_expr ')' ';'
{
CREATE_LOOP($$, 0, $3, 0, optimize_loop_test($6));
context = $<number>1;
}
;
for:
L_FOR '(' first_for_expr ';' for_expr ';' for_expr ')'
{
$3.node = pop_value($3.node);
$<number>1 = context;
context = LOOP_CONTEXT;
}
statement
{
$$.num = $3.num; /* number of declarations (0/1) */
$7 = pop_value($7);
if ($7 && IS_NODE($7, NODE_UNARY_OP, F_INC)
&& IS_NODE($7->r.expr, NODE_OPCODE_1, F_LOCAL_LVALUE)) {
long lvar = $7->r.expr->l.number;
CREATE_OPCODE_1($7, F_LOOP_INCR, 0, lvar);
}
CREATE_STATEMENTS($$.node, $3.node, 0);
CREATE_LOOP($$.node->r.expr, 1, $10, $7, optimize_loop_test($5));
context = $<number>1;
}
;
foreach_var: L_DEFINED_NAME
{
if ($1->dn.local_num != -1) {
CREATE_OPCODE_1($$.node, F_LOCAL_LVALUE, 0, $1->dn.local_num);
type_of_locals_ptr[$1->dn.local_num] &= ~LOCAL_MOD_UNUSED;
} else
if ($1->dn.global_num != -1) {
CREATE_OPCODE_1($$.node, F_GLOBAL_LVALUE, 0, $1->dn.global_num);
} else {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "'");
p = strput(p, end, $1->name);
p = strput(p, end, "' is not a local or a global variable.");
yyerror(buf);
CREATE_OPCODE_1($$.node, F_GLOBAL_LVALUE, 0, 0);
}
$$.num = 0;
}
| single_new_local_def
{
if (type_of_locals_ptr[$1] & LOCAL_MOD_REF) {
CREATE_OPCODE_1($$.node, F_REF_LVALUE, 0, $1);
} else {
CREATE_OPCODE_1($$.node, F_LOCAL_LVALUE, 0, $1);
type_of_locals_ptr[$1] &= ~LOCAL_MOD_UNUSED;
}
$$.num = 1;
}
| L_IDENTIFIER
{
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "'");
p = strput(p, end, $1);
p = strput(p, end, "' is not a local or a global variable.");
yyerror(buf);
CREATE_OPCODE_1($$.node, F_GLOBAL_LVALUE, 0, 0);
scratch_free($1);
$$.num = 0;
}
;
foreach_vars:
foreach_var
{
CREATE_FOREACH($$.node, $1.node, 0);
$$.num = $1.num;
}
| foreach_var ',' foreach_var
{
CREATE_FOREACH($$.node, $1.node, $3.node);
$$.num = $1.num + $3.num;
if ($1.node->v.number == F_REF_LVALUE)
yyerror("Mapping key may not be a reference in foreach()");
}
;
foreach:
L_FOREACH '(' foreach_vars L_IN expr0 ')'
{
$3.node->v.expr = $5;
$<number>1 = context;
context = LOOP_CONTEXT | LOOP_FOREACH;
}
statement
{
$$.num = $3.num;
CREATE_STATEMENTS($$.node, $3.node, 0);
CREATE_LOOP($$.node->r.expr, 2, $8, 0, 0);
CREATE_OPCODE($$.node->r.expr->r.expr, F_NEXT_FOREACH, 0);
context = $<number>1;
}
;
for_expr:
/* EMPTY */
{
$$ = 0;
}
| comma_expr
;
first_for_expr:
for_expr
{
$$.node = $1;
$$.num = 0;
}
| single_new_local_def_with_init
{
$$.node = $1;
$$.num = 1;
}
;
switch:
L_SWITCH '(' comma_expr ')'
{
$<number>1 = context;
context &= LOOP_CONTEXT;
context |= SWITCH_CONTEXT;
$<number>2 = mem_block[A_CASES].current_size;
}
'{' local_declarations case switch_block '}'
{
parse_node_t *node1, *node2;
if ($9) {
CREATE_STATEMENTS(node1, $8, $9);
} else node1 = $8;
if (context & SWITCH_STRINGS) {
NODE_NO_LINE(node2, NODE_SWITCH_STRINGS);
} else if (context & SWITCH_RANGES) {
NODE_NO_LINE(node2, NODE_SWITCH_RANGES);
} else if ((context & SWITCH_NUMBERS) ||
(context & SWITCH_NOT_EMPTY)) {
NODE_NO_LINE(node2, NODE_SWITCH_NUMBERS);
} else {
// to prevent crashing during the remaining parsing bits
NODE_NO_LINE(node2, NODE_SWITCH_NUMBERS);
yyerror("need case statements in switch/case, not just default:"); //just a default case present
}
node2->l.expr = $3;
node2->r.expr = node1;
prepare_cases(node2, $<number>2);
context = $<number>1;
$$ = node2;
pop_n_locals($7.num);
}
;
switch_block:
case switch_block
{
if ($2){
CREATE_STATEMENTS($$, $1, $2);
} else $$ = $1;
}
| statement switch_block
{
if ($2){
CREATE_STATEMENTS($$, $1, $2);
} else $$ = $1;
}
| /* empty */
{
$$ = 0;
}
;
case:
L_CASE case_label ':'
{
$$ = $2;
$$->v.expr = 0;
add_to_mem_block(A_CASES, (char *)&($2), sizeof($2));
}
| L_CASE case_label L_RANGE case_label ':'
{
if ( $2->kind != NODE_CASE_NUMBER
|| $4->kind != NODE_CASE_NUMBER )
yyerror("String case labels not allowed as range bounds");
if ($2->r.number > $4->r.number) break;
context |= SWITCH_RANGES;
$$ = $2;
$$->v.expr = $4;
add_to_mem_block(A_CASES, (char *)&($2), sizeof($2));
}
| L_CASE case_label L_RANGE ':'
{
if ( $2->kind != NODE_CASE_NUMBER )
yyerror("String case labels not allowed as range bounds");
context |= SWITCH_RANGES;
$$ = $2;
$$->v.expr = new_node();
$$->v.expr->kind = NODE_CASE_NUMBER;
$$->v.expr->r.number = ((unsigned long)-1)/2; //maxint
add_to_mem_block(A_CASES, (char *)&($2), sizeof($2));
}
| L_CASE L_RANGE case_label ':'
{
if ( $3->kind != NODE_CASE_NUMBER )
yyerror("String case labels not allowed as range bounds");
context |= SWITCH_RANGES;
$$ = new_node();
$$->kind = NODE_CASE_NUMBER;
$$->r.number = (long) 1+ ((unsigned long)-1)/2; //maxint +1 wraps to min_int, on all computers i know, just not in the C standard iirc
$$->v.expr = $3;
add_to_mem_block(A_CASES, (char *)&($$), sizeof($$));
}
| L_DEFAULT ':'
{
if (context & SWITCH_DEFAULT) {
yyerror("Duplicate default");
$$ = 0;
break;
}
$$ = new_node();
$$->kind = NODE_DEFAULT;
$$->v.expr = 0;
add_to_mem_block(A_CASES, (char *)&($$), sizeof($$));
context |= SWITCH_DEFAULT;
}
;
case_label:
constant
{
if ((context & SWITCH_STRINGS) && $1)
yyerror("Mixed case label list not allowed");
if ($1)
context |= SWITCH_NUMBERS;
else
context |= SWITCH_NOT_EMPTY;
$$ = new_node();
$$->kind = NODE_CASE_NUMBER;
$$->r.expr = (parse_node_t *)$1;
}
| string_con1
{
int str;
str = store_prog_string($1);
scratch_free($1);
if (context & SWITCH_NUMBERS)
yyerror("Mixed case label list not allowed");
context |= SWITCH_STRINGS;
$$ = new_node();
$$->kind = NODE_CASE_STRING;
$$->r.number = str;
}
;
constant:
constant '|' constant
{
$$ = $1 | $3;
}
| constant '^' constant
{
$$ = $1 ^ $3;
}
| constant '&' constant
{
$$ = $1 & $3;
}
| constant L_EQ constant
{
$$ = $1 == $3;
}
| constant L_NE constant
{
$$ = $1 != $3;
}
| constant L_ORDER constant
{
switch($2){
case F_GE: $$ = $1 >= $3; break;
case F_LE: $$ = $1 <= $3; break;
case F_GT: $$ = $1 > $3; break;
}
}
| constant '<' constant
{
$$ = $1 < $3;
}
| constant L_LSH constant
{
$$ = $1 << $3;
}
| constant L_RSH constant
{
$$ = $1 >> $3;
}
| constant '+' constant
{
$$ = $1 + $3;
}
| constant '-' constant
{
$$ = $1 - $3;
}
| constant '*' constant
{
$$ = $1 * $3;
}
| constant '%' constant
{
if ($3) $$ = $1 % $3; else yyerror("Modulo by zero");
}
| constant '/' constant
{
if ($3) $$ = $1 / $3; else yyerror("Division by zero");
}
| '(' constant ')'
{
$$ = $2;
}
| L_NUMBER
{
$$ = $1;
}
| '-' L_NUMBER
{
$$ = -$2;
}
| L_NOT L_NUMBER
{
$$ = !$2;
}
| '~' L_NUMBER
{
$$ = ~$2;
}
;
comma_expr:
expr0
{
$$ = $1;
}
| comma_expr ',' expr0
{
CREATE_TWO_VALUES($$, $3->type, pop_value($1), $3);
}
;
%ifdef REF_RESERVED_WORD
ref:
L_REF
%ifdef COMPAT_32
| '&'
%endif
;
%endif
expr0:
%ifdef REF_RESERVED_WORD
ref lvalue
{
int op;
if (!(context & ARG_LIST))
yyerror("ref illegal outside function argument list");
else
num_refs++;
switch ($2->kind) {
case NODE_PARAMETER_LVALUE:
op = F_LOCAL_LVALUE;
break;
case NODE_TERNARY_OP:
case NODE_OPCODE_1:
case NODE_UNARY_OP_1:
case NODE_BINARY_OP:
op = $2->v.number;
if (op > F_RINDEX_LVALUE)
yyerror("Illegal to make reference to range");
break;
default:
op=0; //0 is harmless, i hope
yyerror("unknown lvalue kind");
}
CREATE_UNARY_OP_1($$, F_MAKE_REF, TYPE_ANY, $2, op);
}
|
%endif
lvalue L_ASSIGN expr0
{
parse_node_t *l = $1, *r = $3;
/* set this up here so we can change it below */
/* assignments are backwards; rhs is evaluated before
lhs, so put the RIGHT hand side on the LEFT hand
side of the tree node. */
CREATE_BINARY_OP($$, $2, r->type, r, l);
if (exact_types && !compatible_types(r->type, l->type) &&
!($2 == F_ADD_EQ
&& l->type == TYPE_STRING &&
(COMP_TYPE(r->type, TYPE_NUMBER))||r->type == TYPE_OBJECT)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Bad assignment ");
p = get_two_types(p, end, l->type, r->type);
p = strput(p, end, ".");
yyerror(buf);
}
if ($2 == F_ASSIGN)
$$->l.expr = do_promotions(r, l->type);
}
| error L_ASSIGN expr0
{
yyerror("Illegal LHS");
CREATE_ERROR($$);
}
| expr0 '?' expr0 ':' expr0 %prec '?'
{
parse_node_t *p1 = $3, *p2 = $5;
if (exact_types && !compatible_types2(p1->type, p2->type)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Types in ?: do not match ");
p = get_two_types(p, end, p1->type, p2->type);
p = strput(p, end, ".");
yywarn(buf);
}
/* optimize if last expression did F_NOT */
if (IS_NODE($1, NODE_UNARY_OP, F_NOT)) {
/* !a ? b : c --> a ? c : b */
CREATE_IF($$, $1->r.expr, p2, p1);
} else {
CREATE_IF($$, $1, p1, p2);
}
$$->type = ((p1->type == p2->type) ? p1->type : TYPE_ANY);
}
| expr0 L_LOR expr0
{
CREATE_LAND_LOR($$, F_LOR, $1, $3);
if (IS_NODE($1, NODE_LAND_LOR, F_LOR))
$1->kind = NODE_BRANCH_LINK;
}
| expr0 L_LAND expr0
{
CREATE_LAND_LOR($$, F_LAND, $1, $3);
if (IS_NODE($1, NODE_LAND_LOR, F_LAND))
$1->kind = NODE_BRANCH_LINK;
}
| expr0 '|' expr0
{
int t1 = $1->type, t3 = $3->type;
if (is_boolean($1) && is_boolean($3))
yywarn("bitwise operation on boolean values.");
if ((t1 & TYPE_MOD_ARRAY) || (t3 & TYPE_MOD_ARRAY)) {
if (t1 != t3) {
if ((t1 != TYPE_ANY) && (t3 != TYPE_ANY) &&
!(t1 & t3 & TYPE_MOD_ARRAY)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Incompatible types for | ");
p = get_two_types(p, end, t1, t3);
p = strput(p, end, ".");
yyerror(buf);
}
t1 = TYPE_ANY | TYPE_MOD_ARRAY;
}
CREATE_BINARY_OP($$, F_OR, t1, $1, $3);
}
else $$ = binary_int_op($1, $3, F_OR, "|");
}
| expr0 '^' expr0
{
$$ = binary_int_op($1, $3, F_XOR, "^");
}
| expr0 '&' expr0
{
int t1 = $1->type, t3 = $3->type;
if (is_boolean($1) && is_boolean($3))
yywarn("bitwise operation on boolean values.");
if ((t1 & TYPE_MOD_ARRAY) || (t3 & TYPE_MOD_ARRAY)) {
if (t1 != t3) {
if ((t1 != TYPE_ANY) && (t3 != TYPE_ANY) &&
!(t1 & t3 & TYPE_MOD_ARRAY)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Incompatible types for & ");
p = get_two_types(p, end, t1, t3);
p = strput(p, end, ".");
yyerror(buf);
}
t1 = TYPE_ANY | TYPE_MOD_ARRAY;
}
CREATE_BINARY_OP($$, F_AND, t1, $1, $3);
} else $$ = binary_int_op($1, $3, F_AND, "&");
}
| expr0 L_EQ expr0
{
if (exact_types && !compatible_types2($1->type, $3->type)){
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "== always false because of incompatible types ");
p = get_two_types(p, end, $1->type, $3->type);
p = strput(p, end, ".");
yyerror(buf);
}
/* x == 0 -> !x */
if (IS_NODE($1, NODE_NUMBER, 0)) {
CREATE_UNARY_OP($$, F_NOT, TYPE_NUMBER, $3);
} else
if (IS_NODE($3, NODE_NUMBER, 0)) {
CREATE_UNARY_OP($$, F_NOT, TYPE_NUMBER, $1);
} else {
CREATE_BINARY_OP($$, F_EQ, TYPE_NUMBER, $1, $3);
}
}
| expr0 L_NE expr0
{
if (exact_types && !compatible_types2($1->type, $3->type)){
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "!= always true because of incompatible types ");
p = get_two_types(p, end, $1->type, $3->type);
p = strput(p, end, ".");
yyerror(buf);
}
CREATE_BINARY_OP($$, F_NE, TYPE_NUMBER, $1, $3);
}
| expr0 L_ORDER expr0
{
if (exact_types) {
int t1 = $1->type;
int t3 = $3->type;
if (!COMP_TYPE(t1, TYPE_NUMBER)
&& !COMP_TYPE(t1, TYPE_STRING)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Bad left argument to '");
p = strput(p, end, query_instr_name($2));
p = strput(p, end, "' : \"");
p = get_type_name(p, end, t1);
p = strput(p, end, "\"");
yyerror(buf);
} else if (!COMP_TYPE(t3, TYPE_NUMBER)
&& !COMP_TYPE(t3, TYPE_STRING)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Bad right argument to '");
p = strput(p, end, query_instr_name($2));
p = strput(p, end, "' : \"");
p = get_type_name(p, end, t3);
p = strput(p, end, "\"");
yyerror(buf);
} else if (!compatible_types2(t1,t3)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Arguments to ");
p = strput(p, end, query_instr_name($2));
p = strput(p, end, " do not have compatible types : ");
p = get_two_types(p, end, t1, t3);
yyerror(buf);
}
}
CREATE_BINARY_OP($$, $2, TYPE_NUMBER, $1, $3);
}
| expr0 '<' expr0
{
if (exact_types) {
int t1 = $1->type, t3 = $3->type;
if (!COMP_TYPE(t1, TYPE_NUMBER)
&& !COMP_TYPE(t1, TYPE_STRING)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Bad left argument to '<' : \"");
p = get_type_name(p, end, t1);
p = strput(p, end, "\"");
yyerror(buf);
} else if (!COMP_TYPE(t3, TYPE_NUMBER)
&& !COMP_TYPE(t3, TYPE_STRING)) {
char buf[200];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Bad right argument to '<' : \"");
p = get_type_name(p, end, t3);
p = strput(p, end, "\"");
yyerror(buf);
} else if (!compatible_types2(t1,t3)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Arguments to < do not have compatible types : ");
p = get_two_types(p, end, t1, t3);
yyerror(buf);
}
}
CREATE_BINARY_OP($$, F_LT, TYPE_NUMBER, $1, $3);
}
| expr0 L_LSH expr0
{
$$ = binary_int_op($1, $3, F_LSH, "<<");
}
| expr0 L_RSH expr0
{
$$ = binary_int_op($1, $3, F_RSH, ">>");
}
| expr0 '+' expr0
{
int result_type;
if (exact_types) {
int t1 = $1->type, t3 = $3->type;
if (t1 == t3){
#ifdef CAST_CALL_OTHERS
if (t1 == TYPE_UNKNOWN){
yyerror("Bad arguments to '+' (unknown vs unknown)");
result_type = TYPE_ANY;
} else
#endif
result_type = t1;
}
else if (t1 == TYPE_ANY) {
if (t3 == TYPE_FUNCTION) {
yyerror("Bad right argument to '+' (function)");
result_type = TYPE_ANY;
} else result_type = t3;
} else if (t3 == TYPE_ANY) {
if (t1 == TYPE_FUNCTION) {
yyerror("Bad left argument to '+' (function)");
result_type = TYPE_ANY;
} else result_type = t1;
} else {
switch(t1) {
case TYPE_OBJECT:
if(t3 == TYPE_STRING){
result_type = TYPE_STRING;
} else goto add_error;
break;
case TYPE_STRING:
{
if (t3 == TYPE_REAL || t3 == TYPE_NUMBER || t3 == TYPE_OBJECT){
result_type = TYPE_STRING;
} else goto add_error;
break;
}
case TYPE_NUMBER:
{
if (t3 == TYPE_REAL || t3 == TYPE_STRING)
result_type = t3;
else goto add_error;
break;
}
case TYPE_REAL:
{
if (t3 == TYPE_NUMBER) result_type = TYPE_REAL;
else if (t3 == TYPE_STRING) result_type = TYPE_STRING;
else goto add_error;
break;
}
default:
{
if (t1 & t3 & TYPE_MOD_ARRAY) {
result_type = TYPE_ANY|TYPE_MOD_ARRAY;
break;
}
add_error:
{
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Invalid argument types to '+' ");
p = get_two_types(p, end, t1, t3);
yyerror(buf);
result_type = TYPE_ANY;
}
}
}
}
} else
result_type = TYPE_ANY;
/* TODO: perhaps we should do (string)+(number) and
* (number)+(string) constant folding as well.
*
* codefor string x = "foo" + 1;
*
* 0000: push string 13, number 1
* 0004: +
* 0005: (void)assign_local LV0
*/
switch ($1->kind) {
case NODE_NUMBER:
/* 0 + X */
if ($1->v.number == 0 &&
($3->type == TYPE_NUMBER || $3->type == TYPE_REAL)) {
$$ = $3;
break;
}
if ($3->kind == NODE_NUMBER) {
$$ = $1;
$1->v.number += $3->v.number;
break;
}
if ($3->kind == NODE_REAL) {
$$ = $3;
$3->v.real += $1->v.number;
break;
}
/* swapping the nodes may help later constant folding */
if ($3->type != TYPE_STRING && $3->type != TYPE_ANY)
CREATE_BINARY_OP($$, F_ADD, result_type, $3, $1);
else
CREATE_BINARY_OP($$, F_ADD, result_type, $1, $3);
break;
case NODE_REAL:
if ($3->kind == NODE_NUMBER) {
$$ = $1;
$1->v.real += $3->v.number;
break;
}
if ($3->kind == NODE_REAL) {
$$ = $1;
$1->v.real += $3->v.real;
break;
}
/* swapping the nodes may help later constant folding */
if ($3->type != TYPE_STRING && $3->type != TYPE_ANY)
CREATE_BINARY_OP($$, F_ADD, result_type, $3, $1);
else
CREATE_BINARY_OP($$, F_ADD, result_type, $1, $3);
break;
case NODE_STRING:
if ($3->kind == NODE_STRING) {
/* Combine strings */
long n1, n2;
const char *s1, *s2;
char *news;
int l;
n1 = $1->v.number;
n2 = $3->v.number;
s1 = PROG_STRING(n1);
s2 = PROG_STRING(n2);
news = (char *)DXALLOC( (l = strlen(s1))+strlen(s2)+1, TAG_COMPILER, "combine string" );
strcpy(news, s1);
strcat(news + l, s2);
/* free old strings (ordering may help shrink table) */
if (n1 > n2) {
free_prog_string(n1); free_prog_string(n2);
} else {
free_prog_string(n2); free_prog_string(n1);
}
$$ = $1;
$$->v.number = store_prog_string(news);
FREE(news);
break;
}
/* Yes, this can actually happen for absurd code like:
* (int)"foo" + 0
* for which I guess we ought to generate (int)"foo"
* in order to be consistent. Then shoot the coder.
*/
/* FALLTHROUGH */
default:
/* X + 0 */
if (IS_NODE($3, NODE_NUMBER, 0) &&
($1->type == TYPE_NUMBER || $1->type == TYPE_REAL)) {
$$ = $1;
break;
}
CREATE_BINARY_OP($$, F_ADD, result_type, $1, $3);
break;
}
}
| expr0 '-' expr0
{
int result_type;
if (exact_types) {
int t1 = $1->type, t3 = $3->type;
if (t1 == t3){
switch(t1){
case TYPE_ANY:
case TYPE_NUMBER:
case TYPE_REAL:
result_type = t1;
break;
default:
if (!(t1 & TYPE_MOD_ARRAY)){
type_error("Bad argument number 1 to '-'", t1);
result_type = TYPE_ANY;
} else result_type = t1;
}
} else if (t1 == TYPE_ANY){
switch(t3){
case TYPE_REAL:
case TYPE_NUMBER:
result_type = t3;
break;
default:
if (!(t3 & TYPE_MOD_ARRAY)){
type_error("Bad argument number 2 to '-'", t3);
result_type = TYPE_ANY;
} else result_type = t3;
}
} else if (t3 == TYPE_ANY){
switch(t1){
case TYPE_REAL:
case TYPE_NUMBER:
result_type = t1;
break;
default:
if (!(t1 & TYPE_MOD_ARRAY)){
type_error("Bad argument number 1 to '-'", t1);
result_type = TYPE_ANY;
} else result_type = t1;
}
} else if ((t1 == TYPE_REAL && t3 == TYPE_NUMBER) ||
(t3 == TYPE_REAL && t1 == TYPE_NUMBER)){
result_type = TYPE_REAL;
} else if (t1 & t3 & TYPE_MOD_ARRAY){
result_type = TYPE_MOD_ARRAY|TYPE_ANY;
} else {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Invalid types to '-' ");
p = get_two_types(p, end, t1, t3);
yyerror(buf);
result_type = TYPE_ANY;
}
} else result_type = TYPE_ANY;
switch ($1->kind) {
case NODE_NUMBER:
if ($1->v.number == 0) {
CREATE_UNARY_OP($$, F_NEGATE, $3->type, $3);
} else if ($3->kind == NODE_NUMBER) {
$$ = $1;
$1->v.number -= $3->v.number;
} else if ($3->kind == NODE_REAL) {
$$ = $3;
$3->v.real = $1->v.number - $3->v.real;
} else {
CREATE_BINARY_OP($$, F_SUBTRACT, result_type, $1, $3);
}
break;
case NODE_REAL:
if ($3->kind == NODE_NUMBER) {
$$ = $1;
$1->v.real -= $3->v.number;
} else if ($3->kind == NODE_REAL) {
$$ = $1;
$1->v.real -= $3->v.real;
} else {
CREATE_BINARY_OP($$, F_SUBTRACT, result_type, $1, $3);
}
break;
default:
/* optimize X-0 */
if (IS_NODE($3, NODE_NUMBER, 0)) {
$$ = $1;
}
CREATE_BINARY_OP($$, F_SUBTRACT, result_type, $1, $3);
}
}
| expr0 '*' expr0
{
int result_type;
if (exact_types){
int t1 = $1->type, t3 = $3->type;
if (t1 == t3){
switch(t1){
case TYPE_MAPPING:
case TYPE_ANY:
case TYPE_NUMBER:
case TYPE_REAL:
result_type = t1;
break;
default:
type_error("Bad argument number 1 to '*'", t1);
result_type = TYPE_ANY;
}
} else if (t1 == TYPE_ANY || t3 == TYPE_ANY){
int t = (t1 == TYPE_ANY) ? t3 : t1;
switch(t){
case TYPE_NUMBER:
case TYPE_REAL:
case TYPE_MAPPING:
result_type = t;
break;
default:
type_error((t1 == TYPE_ANY) ?
"Bad argument number 2 to '*'" :
"Bad argument number 1 to '*'",
t);
result_type = TYPE_ANY;
}
} else if ((t1 == TYPE_NUMBER && t3 == TYPE_REAL) ||
(t1 == TYPE_REAL && t3 == TYPE_NUMBER)){
result_type = TYPE_REAL;
} else {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Invalid types to '*' ");
p = get_two_types(p, end, t1, t3);
yyerror(buf);
result_type = TYPE_ANY;
}
} else result_type = TYPE_ANY;
switch ($1->kind) {
case NODE_NUMBER:
if ($3->kind == NODE_NUMBER) {
$$ = $1;
$$->v.number *= $3->v.number;
break;
}
if ($3->kind == NODE_REAL) {
$$ = $3;
$3->v.real *= $1->v.number;
break;
}
CREATE_BINARY_OP($$, F_MULTIPLY, result_type, $3, $1);
break;
case NODE_REAL:
if ($3->kind == NODE_NUMBER) {
$$ = $1;
$1->v.real *= $3->v.number;
break;
}
if ($3->kind == NODE_REAL) {
$$ = $1;
$1->v.real *= $3->v.real;
break;
}
CREATE_BINARY_OP($$, F_MULTIPLY, result_type, $3, $1);
break;
default:
CREATE_BINARY_OP($$, F_MULTIPLY, result_type, $1, $3);
}
}
| expr0 '%' expr0
{
$$ = binary_int_op($1, $3, F_MOD, "%");
}
| expr0 '/' expr0
{
int result_type;
if (exact_types){
int t1 = $1->type, t3 = $3->type;
if (t1 == t3){
switch(t1){
case TYPE_NUMBER:
case TYPE_REAL:
case TYPE_ANY:
result_type = t1;
break;
default:
type_error("Bad argument 1 to '/'", t1);
result_type = TYPE_ANY;
}
} else if (t1 == TYPE_ANY || t3 == TYPE_ANY){
int t = (t1 == TYPE_ANY) ? t3 : t1;
if (t == TYPE_REAL || t == TYPE_NUMBER)
result_type = t;
else {
type_error(t1 == TYPE_ANY ?
"Bad argument 2 to '/'" :
"Bad argument 1 to '/'", t);
result_type = TYPE_ANY;
}
} else if ((t1 == TYPE_NUMBER && t3 == TYPE_REAL) ||
(t1 == TYPE_REAL && t3 == TYPE_NUMBER)) {
result_type = TYPE_REAL;
} else {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Invalid types to '/' ");
p = get_two_types(p, end, t1, t3);
yyerror(buf);
result_type = TYPE_ANY;
}
} else result_type = TYPE_ANY;
/* constant expressions */
switch ($1->kind) {
case NODE_NUMBER:
if ($3->kind == NODE_NUMBER) {
if ($3->v.number == 0) {
yyerror("Divide by zero in constant");
$$ = $1;
break;
}
$$ = $1;
$1->v.number /= $3->v.number;
break;
}
if ($3->kind == NODE_REAL) {
if ($3->v.real == 0.0) {
yyerror("Divide by zero in constant");
$$ = $1;
break;
}
$$ = $3;
$3->v.real = ($1->v.number / $3->v.real);
break;
}
CREATE_BINARY_OP($$, F_DIVIDE, result_type, $1, $3);
break;
case NODE_REAL:
if ($3->kind == NODE_NUMBER) {
if ($3->v.number == 0) {
yyerror("Divide by zero in constant");
$$ = $1;
break;
}
$$ = $1;
$1->v.real /= $3->v.number;
break;
}
if ($3->kind == NODE_REAL) {
if ($3->v.real == 0.0) {
yyerror("Divide by zero in constant");
$$ = $1;
break;
}
$$ = $1;
$1->v.real /= $3->v.real;
break;
}
CREATE_BINARY_OP($$, F_DIVIDE, result_type, $1, $3);
break;
default:
CREATE_BINARY_OP($$, F_DIVIDE, result_type, $1, $3);
}
}
| cast expr0 %prec L_NOT
{
$$ = $2;
$$->type = $1;
if (exact_types &&
$2->type != $1 &&
$2->type != TYPE_ANY &&
$2->type != TYPE_UNKNOWN &&
$1 != TYPE_VOID) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Cannot cast ");
p = get_type_name(p, end, $2->type);
p = strput(p, end, "to ");
p = get_type_name(p, end, $1);
yyerror(buf);
}
}
| L_INC lvalue %prec L_NOT /* note lower precedence here */
{
CREATE_UNARY_OP($$, F_PRE_INC, 0, $2);
if (exact_types){
switch($2->type){
case TYPE_NUMBER:
case TYPE_ANY:
case TYPE_REAL:
{
$$->type = $2->type;
break;
}
default:
{
$$->type = TYPE_ANY;
type_error("Bad argument 1 to ++x", $2->type);
}
}
} else $$->type = TYPE_ANY;
}
| L_DEC lvalue %prec L_NOT /* note lower precedence here */
{
CREATE_UNARY_OP($$, F_PRE_DEC, 0, $2);
if (exact_types){
switch($2->type){
case TYPE_NUMBER:
case TYPE_ANY:
case TYPE_REAL:
{
$$->type = $2->type;
break;
}
default:
{
$$->type = TYPE_ANY;
type_error("Bad argument 1 to --x", $2->type);
}
}
} else $$->type = TYPE_ANY;
}
| L_NOT expr0
{
if ($2->kind == NODE_NUMBER) {
$$ = $2;
$$->v.number = !($$->v.number);
} else {
CREATE_UNARY_OP($$, F_NOT, TYPE_NUMBER, $2);
}
}
| '~' expr0
{
if (exact_types && !IS_TYPE($2->type, TYPE_NUMBER))
type_error("Bad argument to ~", $2->type);
if ($2->kind == NODE_NUMBER) {
$$ = $2;
$$->v.number = ~$$->v.number;
} else {
CREATE_UNARY_OP($$, F_COMPL, TYPE_NUMBER, $2);
}
}
| '-' expr0 %prec L_NOT
{
int result_type;
if (exact_types){
int t = $2->type;
if (!COMP_TYPE(t, TYPE_NUMBER)){
type_error("Bad argument to unary '-'", t);
result_type = TYPE_ANY;
} else result_type = t;
} else result_type = TYPE_ANY;
switch ($2->kind) {
case NODE_NUMBER:
$$ = $2;
$$->v.number = -$$->v.number;
break;
case NODE_REAL:
$$ = $2;
$$->v.real = -$$->v.real;
break;
default:
CREATE_UNARY_OP($$, F_NEGATE, result_type, $2);
}
}
| lvalue L_INC /* normal precedence here */
{
CREATE_UNARY_OP($$, F_POST_INC, 0, $1);
$$->v.number = F_POST_INC;
if (exact_types){
switch($1->type){
case TYPE_NUMBER:
case TYPE_ANY:
case TYPE_REAL:
{
$$->type = $1->type;
break;
}
default:
{
$$->type = TYPE_ANY;
type_error("Bad argument 1 to x++", $1->type);
}
}
} else $$->type = TYPE_ANY;
}
| lvalue L_DEC
{
CREATE_UNARY_OP($$, F_POST_DEC, 0, $1);
if (exact_types){
switch($1->type){
case TYPE_NUMBER:
case TYPE_ANY:
case TYPE_REAL:
{
$$->type = $1->type;
break;
}
default:
{
$$->type = TYPE_ANY;
type_error("Bad argument 1 to x--", $1->type);
}
}
} else $$->type = TYPE_ANY;
}
| expr4
| sscanf
| parse_command
| time_expression
| number
| real
;
return:
L_RETURN ';'
{
if (exact_types && !IS_TYPE(exact_types, TYPE_VOID))
yywarn("Non-void functions must return a value.");
CREATE_RETURN($$, 0);
}
| L_RETURN comma_expr ';'
{
if (exact_types && !compatible_types($2->type, exact_types)) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Type of returned value doesn't match function return type ");
p = get_two_types(p, end, $2->type, exact_types);
yyerror(buf);
}
if (IS_NODE($2, NODE_NUMBER, 0)) {
CREATE_RETURN($$, 0);
} else {
CREATE_RETURN($$, $2);
}
}
;
expr_list:
/* empty */
{
CREATE_EXPR_LIST($$, 0);
}
| expr_list2
{
CREATE_EXPR_LIST($$, $1);
}
| expr_list2 ','
{
CREATE_EXPR_LIST($$, $1);
}
;
expr_list_node:
expr0
{
CREATE_EXPR_NODE($$, $1, 0);
}
| expr0 L_DOT_DOT_DOT
{
CREATE_EXPR_NODE($$, $1, 1);
}
;
expr_list2:
expr_list_node
{
$1->kind = 1;
$$ = $1;
}
| expr_list2 ',' expr_list_node
{
$3->kind = 0;
$$ = $1;
$$->kind++;
$$->l.expr->r.expr = $3;
$$->l.expr = $3;
}
;
expr_list3:
/* empty */
{
/* this is a dummy node */
CREATE_EXPR_LIST($$, 0);
}
| expr_list4
{
CREATE_EXPR_LIST($$, $1);
}
| expr_list4 ','
{
CREATE_EXPR_LIST($$, $1);
}
;
expr_list4:
assoc_pair
{
$$ = new_node_no_line();
$$->kind = 2;
$$->v.expr = $1;
$$->r.expr = 0;
$$->type = 0;
/* we keep track of the end of the chain in the left nodes */
$$->l.expr = $$;
}
| expr_list4 ',' assoc_pair
{
parse_node_t *expr;
expr = new_node_no_line();
expr->kind = 0;
expr->v.expr = $3;
expr->r.expr = 0;
expr->type = 0;
$1->l.expr->r.expr = expr;
$1->l.expr = expr;
$1->kind += 2;
$$ = $1;
}
;
assoc_pair:
expr0 ':' expr0
{
CREATE_TWO_VALUES($$, 0, $1, $3);
}
;
lvalue:
expr4
{
#define LV_ILLEGAL 1
#define LV_RANGE 2
#define LV_INDEX 4
/* Restrictive lvalues, but I think they make more sense :) */
$$ = $1;
if($$->kind == NODE_BINARY_OP && $$->v.number == F_TYPE_CHECK)
$$ = $$->l.expr;
switch($$->kind) {
default:
yyerror("Illegal lvalue");
break;
case NODE_PARAMETER:
$$->kind = NODE_PARAMETER_LVALUE;
break;
case NODE_TERNARY_OP:
$$->v.number = $$->r.expr->v.number;
case NODE_OPCODE_1:
case NODE_UNARY_OP_1:
case NODE_BINARY_OP:
if ($$->v.number >= F_LOCAL && $$->v.number <= F_MEMBER)
$$->v.number++; /* make it an lvalue */
else if ($$->v.number >= F_INDEX
&& $$->v.number <= F_RE_RANGE) {
parse_node_t *node = $$;
int flag = 0;
do {
switch(node->kind) {
case NODE_PARAMETER:
node->kind = NODE_PARAMETER_LVALUE;
flag |= LV_ILLEGAL;
break;
case NODE_TERNARY_OP:
node->v.number = node->r.expr->v.number;
case NODE_OPCODE_1:
case NODE_UNARY_OP_1:
case NODE_BINARY_OP:
if(node->kind == NODE_BINARY_OP &&
node->v.number == F_TYPE_CHECK) {
node = node->l.expr;
continue;
}
if (node->v.number >= F_LOCAL
&& node->v.number <= F_MEMBER) {
node->v.number++;
flag |= LV_ILLEGAL;
break;
} else if (node->v.number == F_INDEX ||
node->v.number == F_RINDEX) {
node->v.number++;
flag |= LV_INDEX;
break;
} else if (node->v.number >= F_ADD_EQ
&& node->v.number <= F_ASSIGN) {
if (!(flag & LV_INDEX)) {
yyerror("Illegal lvalue, a possible lvalue is (x <assign> y)[a]");
}
if (node->r.expr->kind == NODE_BINARY_OP||
node->r.expr->kind == NODE_TERNARY_OP){
if (node->r.expr->v.number >= F_NN_RANGE_LVALUE && node->r.expr->v.number <= F_NR_RANGE_LVALUE)
yyerror("Illegal to have (x[a..b] <assign> y) to be the beginning of an lvalue");
}
flag = LV_ILLEGAL;
break;
} else if (node->v.number >= F_NN_RANGE
&& node->v.number <= F_RE_RANGE) {
if (flag & LV_RANGE) {
yyerror("Can't do range lvalue of range lvalue.");
flag |= LV_ILLEGAL;
break;
}
if (flag & LV_INDEX){
yyerror("Can't do indexed lvalue of range lvalue.");
flag |= LV_ILLEGAL;
break;
}
if (node->v.number == F_NE_RANGE) {
/* x[foo..] -> x[foo..<1] */
parse_node_t *rchild = node->r.expr;
node->kind = NODE_TERNARY_OP;
CREATE_BINARY_OP(node->r.expr,
F_NR_RANGE_LVALUE,
0, 0, rchild);
CREATE_NUMBER(node->r.expr->l.expr, 1);
} else if (node->v.number == F_RE_RANGE) {
/* x[<foo..] -> x[<foo..<1] */
parse_node_t *rchild = node->r.expr;
node->kind = NODE_TERNARY_OP;
CREATE_BINARY_OP(node->r.expr,
F_RR_RANGE_LVALUE,
0, 0, rchild);
CREATE_NUMBER(node->r.expr->l.expr, 1);
} else
node->r.expr->v.number++;
flag |= LV_RANGE;
node = node->r.expr->r.expr;
continue;
}
default:
yyerror("Illegal lvalue");
flag = LV_ILLEGAL;
break;
}
if ((flag & LV_ILLEGAL) || !(node = node->r.expr)) break;
} while (1);
break;
} else
yyerror("Illegal lvalue");
break;
}
}
;
l_new_function_open: L_NEW_FUNCTION_OPEN
| L_FUNCTION_OPEN efun_override
{
$$ = ($2 << 8) | FP_EFUN;
}
;
%ifdef COMPAT_32
simple_function_pointer: l_new_function_open ':' ')'
{
$$ = $1;
}
| L_LAMBDA L_DEFINED_NAME
{
int val;
if ((val=$2->dn.local_num) >= 0){
$$ = (val << 8) | FP_L_VAR;
} else if ((val=$2->dn.global_num) >= 0) {
$$ = (val << 8) | FP_G_VAR;
} else if ((val=$2->dn.function_num) >=0) {
$$ = (val << 8)|FP_LOCAL;
} else if ((val=$2->dn.simul_num) >=0) {
$$ = (val << 8)|FP_SIMUL;
} else if ((val=$2->dn.efun_num) >=0) {
$$ = (val << 8)|FP_EFUN;
}
}
;
%endif
expr4:
function_call
| L_DEFINED_NAME
{
int i;
if ((i = $1->dn.local_num) != -1) {
type_of_locals_ptr[i] &= ~LOCAL_MOD_UNUSED;
if (type_of_locals_ptr[i] & LOCAL_MOD_REF)
CREATE_OPCODE_1($$, F_REF, type_of_locals_ptr[i] & ~LOCAL_MOD_REF,i & 0xff);
else
CREATE_OPCODE_1($$, F_LOCAL, type_of_locals_ptr[i], i & 0xff);
if (current_function_context)
current_function_context->num_locals++;
} else
if ((i = $1->dn.global_num) != -1) {
if (current_function_context)
current_function_context->bindable = FP_NOT_BINDABLE;
CREATE_OPCODE_1($$, F_GLOBAL,
VAR_TEMP(i)->type & ~DECL_MODS, i);
if (VAR_TEMP(i)->type & DECL_HIDDEN) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Illegal to use private variable '");
p = strput(p, end, $1->name);
p = strput(p, end, "'");
yyerror(buf);
}
} else {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Undefined variable '");
p = strput(p, end, $1->name);
p = strput(p, end, "'");
if (current_number_of_locals < CFG_MAX_LOCAL_VARIABLES) {
add_local_name($1->name, TYPE_ANY);
}
CREATE_ERROR($$);
yyerror(buf);
}
}
| L_IDENTIFIER
{
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Undefined variable '");
p = strput(p, end, $1);
p = strput(p, end, "'");
if (current_number_of_locals < CFG_MAX_LOCAL_VARIABLES) {
add_local_name($1, TYPE_ANY);
}
CREATE_ERROR($$);
yyerror(buf);
scratch_free($1);
}
| L_PARAMETER
{
CREATE_PARAMETER($$, TYPE_ANY, $1);
}
| '$' '('
{
$<contextp>$ = current_function_context;
/* already flagged as an error */
if (current_function_context)
current_function_context = current_function_context->parent;
}
comma_expr ')'
{
parse_node_t *node;
current_function_context = $<contextp>3;
if (!current_function_context || current_function_context->num_parameters == -2) {
/* This was illegal, and error'ed when the '$' token
* was returned.
*/
CREATE_ERROR($$);
} else {
CREATE_OPCODE_1($$, F_LOCAL, $4->type,
current_function_context->values_list->kind++);
node = new_node_no_line();
node->type = 0;
current_function_context->values_list->l.expr->r.expr = node;
current_function_context->values_list->l.expr = node;
node->r.expr = 0;
node->v.expr = $4;
}
}
| expr4 L_ARROW identifier
{
if ($1->type == TYPE_ANY) {
int cmi;
unsigned char tp;
if ((cmi = lookup_any_class_member($3, &tp)) != -1) {
CREATE_UNARY_OP_1($$, F_MEMBER, tp, $1, 0);
$$->l.number = cmi;
} else {
CREATE_ERROR($$);
}
} else if (!IS_CLASS($1->type)) {
yyerror("Left argument of -> is not a class");
CREATE_ERROR($$);
} else {
CREATE_UNARY_OP_1($$, F_MEMBER, 0, $1, 0);
$$->l.number = lookup_class_member(CLASS_IDX($1->type),
$3,
&($$->type));
}
scratch_free($3);
}
| expr4 '[' comma_expr L_RANGE comma_expr ']'
{
%ifndef OLD_RANGE_BEHAVIOR
%ifdef WARN_OLD_RANGE_BEHAVIOR
if ($1->type != TYPE_MAPPING &&
$5->kind == NODE_NUMBER && $5->v.number < 0)
yywarn("A negative constant as the second element of arr[x..y] no longer means indexing from the end. Use arr[x..<y]");
%endif
%endif
$$ = make_range_node(F_NN_RANGE, $1, $3, $5);
}
| expr4 '[' '<' comma_expr L_RANGE comma_expr ']'
{
$$ = make_range_node(F_RN_RANGE, $1, $4, $6);
}
| expr4 '[' '<' comma_expr L_RANGE '<' comma_expr ']'
{
if ($7->kind == NODE_NUMBER && $7->v.number <= 1)
$$ = make_range_node(F_RE_RANGE, $1, $4, 0);
else
$$ = make_range_node(F_RR_RANGE, $1, $4, $7);
}
| expr4 '[' comma_expr L_RANGE '<' comma_expr ']'
{
if ($6->kind == NODE_NUMBER && $6->v.number <= 1)
$$ = make_range_node(F_NE_RANGE, $1, $3, 0);
else
$$ = make_range_node(F_NR_RANGE, $1, $3, $6);
}
| expr4 '[' comma_expr L_RANGE ']'
{
$$ = make_range_node(F_NE_RANGE, $1, $3, 0);
}
| expr4 '[' '<' comma_expr L_RANGE ']'
{
$$ = make_range_node(F_RE_RANGE, $1, $4, 0);
}
| expr4 '[' '<' comma_expr ']'
{
if (IS_NODE($1, NODE_CALL, F_AGGREGATE)
&& $4->kind == NODE_NUMBER) {
int i = $4->v.number;
if (i < 1 || i > $1->l.number)
yyerror("Illegal index to array constant.");
else {
parse_node_t *node = $1->r.expr;
i = $1->l.number - i;
while (i--)
node = node->r.expr;
$$ = node->v.expr;
break;
}
}
CREATE_BINARY_OP($$, F_RINDEX, 0, $4, $1);
if (exact_types) {
switch($1->type) {
case TYPE_MAPPING:
yyerror("Illegal index for mapping.");
case TYPE_ANY:
$$->type = TYPE_ANY;
break;
case TYPE_STRING:
case TYPE_BUFFER:
$$->type = TYPE_NUMBER;
if (!IS_TYPE($4->type,TYPE_NUMBER))
type_error("Bad type of index", $4->type);
break;
default:
if ($1->type & TYPE_MOD_ARRAY) {
$$->type = $1->type & ~TYPE_MOD_ARRAY;
if ($$->type != TYPE_ANY)
$$ = add_type_check($$, $$->type);
if (!IS_TYPE($4->type,TYPE_NUMBER))
type_error("Bad type of index", $4->type);
} else {
type_error("Value indexed has a bad type ", $1->type);
$$->type = TYPE_ANY;
}
}
} else $$->type = TYPE_ANY;
}
| expr4 '[' comma_expr ']'
{
/* Something stupid like ({ 1, 2, 3 })[1]; we take the
* time to optimize this because people who don't understand
* the preprocessor often write things like:
*
* #define MY_ARRAY ({ "foo", "bar", "bazz" })
* ...
* ... MY_ARRAY[1] ...
*
* which of course expands to the above.
*/
if (IS_NODE($1, NODE_CALL, F_AGGREGATE) && $3->kind == NODE_NUMBER) {
int i = $3->v.number;
if (i < 0 || i >= $1->l.number)
yyerror("Illegal index to array constant.");
else {
parse_node_t *node = $1->r.expr;
while (i--)
node = node->r.expr;
$$ = node->v.expr;
break;
}
}
%ifndef OLD_RANGE_BEHAVIOR
if ($3->kind == NODE_NUMBER && $3->v.number < 0)
yywarn("A negative constant in arr[x] no longer means indexing from the end. Use arr[<x]");
%endif
CREATE_BINARY_OP($$, F_INDEX, 0, $3, $1);
if (exact_types) {
switch($1->type) {
case TYPE_MAPPING:
case TYPE_ANY:
$$->type = TYPE_ANY;
break;
case TYPE_STRING:
case TYPE_BUFFER:
$$->type = TYPE_NUMBER;
if (!IS_TYPE($3->type,TYPE_NUMBER))
type_error("Bad type of index", $3->type);
break;
default:
if ($1->type & TYPE_MOD_ARRAY) {
$$->type = $1->type & ~TYPE_MOD_ARRAY;
if($$->type != TYPE_ANY)
$$ = add_type_check($$, $$->type);
if (!IS_TYPE($3->type,TYPE_NUMBER))
type_error("Bad type of index", $3->type);
} else {
type_error("Value indexed has a bad type ", $1->type);
$$->type = TYPE_ANY;
}
}
} else $$->type = TYPE_ANY;
}
| string
| '(' comma_expr ')'
{
$$ = $2;
}
| catch
%ifdef DEBUG
| tree
%endif
| L_BASIC_TYPE
{
if ($1 != TYPE_FUNCTION) yyerror("Reserved type name unexpected.");
$<func_block>$.num_local = current_number_of_locals;
$<func_block>$.max_num_locals = max_num_locals;
$<func_block>$.context = context;
$<func_block>$.save_current_type = current_type;
$<func_block>$.save_exact_types = exact_types;
if (type_of_locals_ptr + max_num_locals + CFG_MAX_LOCAL_VARIABLES >= &type_of_locals[type_of_locals_size])
reallocate_locals();
deactivate_current_locals();
locals_ptr += current_number_of_locals;
type_of_locals_ptr += max_num_locals;
max_num_locals = current_number_of_locals = 0;
push_function_context();
current_function_context->num_parameters = -1;
exact_types = TYPE_ANY;
context = 0;
}
'(' argument ')' block
{
if ($4.flags & ARG_IS_VARARGS) {
yyerror("Anonymous varargs functions aren't implemented");
}
if (!$6.node) {
CREATE_RETURN($6.node, 0);
} else if ($6.node->kind != NODE_RETURN &&
($6.node->kind != NODE_TWO_VALUES || $6.node->r.expr->kind != NODE_RETURN)) {
parse_node_t *replacement;
CREATE_STATEMENTS(replacement, $6.node, 0);
CREATE_RETURN(replacement->r.expr, 0);
$6.node = replacement;
}
$$ = new_node();
$$->kind = NODE_ANON_FUNC;
$$->type = TYPE_FUNCTION;
$$->l.number = (max_num_locals - $4.num_arg);
$$->r.expr = $6.node;
$$->v.number = $4.num_arg;
if (current_function_context->bindable)
$$->v.number |= 0x10000;
free_all_local_names(1);
current_number_of_locals = $<func_block>2.num_local;
max_num_locals = $<func_block>2.max_num_locals;
context = $<func_block>2.context;
current_type = $<func_block>2.save_current_type;
exact_types = $<func_block>2.save_exact_types;
pop_function_context();
locals_ptr -= current_number_of_locals;
type_of_locals_ptr -= max_num_locals;
reactivate_current_locals();
}
%ifdef COMPAT_32
| simple_function_pointer
%else
| l_new_function_open ':' ')'
%endif
{
#ifdef WOMBLES
if(*(outp-2) != ':')
yyerror("End of functional not found");
#endif
$$ = new_node();
$$->kind = NODE_FUNCTION_CONSTRUCTOR;
$$->type = TYPE_FUNCTION;
$$->r.expr = 0;
switch ($1 & 0xff) {
case FP_L_VAR:
yyerror("Illegal to use local variable in a functional.");
CREATE_NUMBER($$->l.expr, 0);
$$->l.expr->r.expr = 0;
$$->l.expr->l.expr = 0;
$$->v.number = FP_FUNCTIONAL;
break;
case FP_G_VAR:
CREATE_OPCODE_1($$->l.expr, F_GLOBAL, 0, $1 >> 8);
$$->v.number = FP_FUNCTIONAL | FP_NOT_BINDABLE;
if (VAR_TEMP($$->l.expr->l.number)->type & DECL_HIDDEN) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Illegal to use private variable '");
p = strput(p, end, VAR_TEMP($$->l.expr->l.number)->name);
p = strput(p, end, "'");
yyerror(buf);
}
break;
default:
$$->v.number = $1;
break;
}
}
| l_new_function_open ',' expr_list2 ':' ')'
{
#ifdef WOMBLES
if(*(outp-2) != ':')
yyerror("End of functional not found");
#endif
$$ = new_node();
$$->kind = NODE_FUNCTION_CONSTRUCTOR;
$$->type = TYPE_FUNCTION;
$$->v.number = $1;
$$->r.expr = $3;
switch ($1 & 0xff) {
case FP_EFUN: {
int *argp;
int f = $1 >>8;
int num = $3->kind;
int max_arg = predefs[f].max_args;
if(f!=-1){
if (num > max_arg && max_arg != -1) {
parse_node_t *pn = $3;
while (pn) {
if (pn->type & 1) break;
pn = pn->r.expr;
}
if (!pn) {
char bff[256];
char *end = EndOf(bff);
char *p;
p = strput(bff, end, "Too many arguments to ");
p = strput(p, end, predefs[f].word);
yyerror(bff);
}
} else if (max_arg != -1 && exact_types) {
/*
* Now check all types of arguments to efuns.
*/
int i, argn, tmp;
parse_node_t *enode = $3;
argp = &efun_arg_types[predefs[f].arg_index];
for (argn = 0; argn < num; argn++) {
if (enode->type & 1) break;
tmp = enode->v.expr->type;
for (i=0; !compatible_types(tmp, argp[i])
&& argp[i] != 0; i++)
;
if (argp[i] == 0) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Bad argument ");
p = strput_int(p, end, argn+1);
p = strput(p, end, " to efun ");
p = strput(p, end, predefs[f].word);
p = strput(p, end, "()");
yyerror(buf);
} else {
/* this little section necessary b/c in the
case float | int we dont want to do
promoting. */
if (tmp == TYPE_NUMBER && argp[i] == TYPE_REAL) {
for (i++; argp[i] && argp[i] != TYPE_NUMBER; i++)
;
if (!argp[i])
enode->v.expr = promote_to_float(enode->v.expr);
}
if (tmp == TYPE_REAL && argp[i] == TYPE_NUMBER) {
for (i++; argp[i] && argp[i] != TYPE_REAL; i++)
;
if (!argp[i])
enode->v.expr = promote_to_int(enode->v.expr);
}
}
while (argp[i] != 0)
i++;
argp += i + 1;
enode = enode->r.expr;
}
}
}
break;
}
case FP_L_VAR:
case FP_G_VAR:
yyerror("Can't give parameters to functional.");
break;
}
}
| L_FUNCTION_OPEN comma_expr ':' ')'
{
#ifdef WOMBLES
if(*(outp-2) != ':')
yyerror("End of functional not found");
#endif
if (current_function_context->num_locals)
yyerror("Illegal to use local variable in functional.");
if (current_function_context->values_list->r.expr)
current_function_context->values_list->r.expr->kind = current_function_context->values_list->kind;
$$ = new_node();
$$->kind = NODE_FUNCTION_CONSTRUCTOR;
$$->type = TYPE_FUNCTION;
$$->l.expr = $2;
if ($2->kind == NODE_STRING)
yywarn("Function pointer returning string constant is NOT a function call");
$$->r.expr = current_function_context->values_list->r.expr;
$$->v.number = FP_FUNCTIONAL + current_function_context->bindable
+ (current_function_context->num_parameters << 8);
pop_function_context();
}
| L_MAPPING_OPEN expr_list3 ']' ')'
{
#ifdef WOMBLES
if(*(outp-2) != ']')
yyerror("End of mapping not found");
#endif
CREATE_CALL($$, F_AGGREGATE_ASSOC, TYPE_MAPPING, $2);
}
| L_ARRAY_OPEN expr_list '}' ')'
{
#ifdef WOMBLES
if(*(outp-2) != '}')
yyerror("End of array not found");
#endif
CREATE_CALL($$, F_AGGREGATE, TYPE_ANY | TYPE_MOD_ARRAY, $2);
}
;
expr_or_block:
block
{
$$ = $1.node;
}
| '(' comma_expr ')'
{
$$ = insert_pop_value($2);
}
;
catch:
L_CATCH
{
$<number>$ = context;
context = SPECIAL_CONTEXT;
}
expr_or_block
{
CREATE_CATCH($$, $3);
context = $<number>2;
}
;
%ifdef DEBUG
tree:
L_TREE block
{
$$ = new_node_no_line();
lpc_tree_form($2.node, $$);
}
|
L_TREE '(' comma_expr ')'
{
$$ = new_node_no_line();
lpc_tree_form($3, $$);
}
;
%endif
sscanf:
L_SSCANF '(' expr0 ',' expr0 lvalue_list ')'
{
int p = $6->v.number;
CREATE_LVALUE_EFUN($$, TYPE_NUMBER, $6);
CREATE_BINARY_OP_1($$->l.expr, F_SSCANF, 0, $3, $5, p);
}
;
parse_command:
L_PARSE_COMMAND '(' expr0 ',' expr0 ',' expr0 lvalue_list ')'
{
int p = $8->v.number;
CREATE_LVALUE_EFUN($$, TYPE_NUMBER, $8);
CREATE_TERNARY_OP_1($$->l.expr, F_PARSE_COMMAND, 0,
$3, $5, $7, p);
}
;
time_expression:
L_TIME_EXPRESSION
{
$<number>$ = context;
context = SPECIAL_CONTEXT;
}
expr_or_block
{
CREATE_TIME_EXPRESSION($$, $3);
context = $<number>2;
}
;
lvalue_list:
/* empty */
{
$$ = new_node_no_line();
$$->r.expr = 0;
$$->v.number = 0;
}
| ',' lvalue lvalue_list
{
parse_node_t *insert;
$$ = $3;
insert = new_node_no_line();
insert->r.expr = $3->r.expr;
insert->l.expr = $2;
$3->r.expr = insert;
$$->v.number++;
}
;
string:
string_con2
{
CREATE_STRING($$, $1);
scratch_free($1);
}
;
string_con1:
string_con2
| '(' string_con1 ')'
{
$$ = $2;
}
| string_con1 '+' string_con1
{
$$ = scratch_join($1, $3);
}
;
string_con2:
L_STRING
| string_con2 L_STRING
{
$$ = scratch_join($1, $2);
}
;
class_init: identifier ':' expr0
{
$$ = new_node();
$$->l.expr = (parse_node_t *)$1;
$$->v.expr = $3;
$$->r.expr = 0;
}
;
opt_class_init:
/* empty */
{
$$ = 0;
}
| opt_class_init ',' class_init
{
$$ = $3;
$$->r.expr = $1;
}
;
function_call:
efun_override '('
{
$<number>$ = context;
$<number>2 = num_refs;
context |= ARG_LIST;
}
expr_list ')'
{
context = $<number>3;
$$ = validate_efun_call($1,$4);
$$ = check_refs(num_refs - $<number>2, $4, $$);
num_refs = $<number>2;
}
| L_NEW '('
{
$<number>$ = context;
$<number>2 = num_refs;
context |= ARG_LIST;
}
expr_list ')'
{
ident_hash_elem_t *ihe;
int f;
context = $<number>3;
ihe = lookup_ident("clone_object");
if ((f = ihe->dn.simul_num) != -1) {
$$ = $4;
$$->kind = NODE_CALL_1;
$$->v.number = F_SIMUL_EFUN;
$$->l.number = f;
$$->type = (SIMUL(f)->type) & ~DECL_MODS;
} else {
$$ = validate_efun_call(lookup_predef("clone_object"), $4);
#ifdef CAST_CALL_OTHERS
$$->type = TYPE_UNKNOWN;
#else
$$->type = TYPE_ANY;
#endif
}
$$ = check_refs(num_refs - $<number>2, $4, $$);
num_refs = $<number>2;
}
| L_NEW '(' L_CLASS L_DEFINED_NAME opt_class_init ')'
{
parse_node_t *node;
if ($4->dn.class_num == -1) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Undefined class '");
p = strput(p, end, $4->name);
p = strput(p, end, "'");
yyerror(buf);
CREATE_ERROR($$);
node = $5;
while (node) {
scratch_free((char *)node->l.expr);
node = node->r.expr;
}
} else {
int type = $4->dn.class_num | TYPE_MOD_CLASS;
if ((node = $5)) {
CREATE_TWO_VALUES($$, type, 0, 0);
$$->l.expr = reorder_class_values($4->dn.class_num,
node);
CREATE_OPCODE_1($$->r.expr, F_NEW_CLASS,
type, $4->dn.class_num);
} else {
CREATE_OPCODE_1($$, F_NEW_EMPTY_CLASS,
type, $4->dn.class_num);
}
}
}
| L_NEW '(' L_CLASS L_IDENTIFIER opt_class_init ')'
{
parse_node_t *node;
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Undefined class '");
p = strput(p, end, $4);
p = strput(p, end, "'");
yyerror(buf);
CREATE_ERROR($$);
node = $5;
while (node) {
scratch_free((char *)node->l.expr);
node = node->r.expr;
}
}
| L_DEFINED_NAME '('
{
$<number>$ = context;
$<number>2 = num_refs;
context |= ARG_LIST;
}
expr_list ')'
{
int f;
context = $<number>3;
$$ = $4;
if ((f = $1->dn.function_num) != -1) {
if (current_function_context)
current_function_context->bindable = FP_NOT_BINDABLE;
$$->kind = NODE_CALL_1;
$$->v.number = F_CALL_FUNCTION_BY_ADDRESS;
$$->l.number = f;
$$->type = validate_function_call(f, $4->r.expr);
} else if ((f=$1->dn.simul_num) != -1) {
$$->kind = NODE_CALL_1;
$$->v.number = F_SIMUL_EFUN;
$$->l.number = f;
$$->type = (SIMUL(f)->type) & ~DECL_MODS;
} else if ((f=$1->dn.efun_num) != -1) {
$$ = validate_efun_call(f, $4);
} else {
/* This here is a really nasty case that only occurs with
* exact_types off. The user has done something gross like:
*
* func() { int f; f(); } // if f was prototyped we wouldn't
* f() { } // need this case
*
* Don't complain, just grok it.
*/
if (current_function_context)
current_function_context->bindable = FP_NOT_BINDABLE;
f = define_new_function($1->name, 0, 0,
DECL_PUBLIC|FUNC_UNDEFINED, TYPE_ANY);
$$->kind = NODE_CALL_1;
$$->v.number = F_CALL_FUNCTION_BY_ADDRESS;
$$->l.number = f;
$$->type = TYPE_ANY; /* just a guess */
if (exact_types) {
char buf[256];
char *end = EndOf(buf);
char *p;
const char *n = $1->name;
if (*n == ':') n++;
/* prevent some errors; by making it look like an
* inherited function we prevent redeclaration errors
* if it shows up later
*/
FUNCTION_FLAGS(f) &= ~FUNC_UNDEFINED;
FUNCTION_FLAGS(f) |= (FUNC_INHERITED | FUNC_VARARGS);
p = strput(buf, end, "Undefined function ");
p = strput(p, end, n);
yyerror(buf);
}
}
$$ = check_refs(num_refs - $<number>2, $4, $$);
num_refs = $<number>2;
}
| function_name '('
{
$<number>$ = context;
$<number>2 = num_refs;
context |= ARG_LIST;
}
expr_list ')'
{
char *name = $1;
context = $<number>3;
$$ = $4;
if (current_function_context)
current_function_context->bindable = FP_NOT_BINDABLE;
if (*name == ':') {
int f;
if ((f = arrange_call_inherited(name + 1, $$)) != -1)
/* Can't do this; f may not be the correct function
entry. It might be overloaded.
validate_function_call(f, $$->r.expr)
*/
;
} else {
int f;
ident_hash_elem_t *ihe;
f = (ihe = lookup_ident(name)) ? ihe->dn.function_num : -1;
$$->kind = NODE_CALL_1;
$$->v.number = F_CALL_FUNCTION_BY_ADDRESS;
if (f!=-1) {
/* The only way this can happen is if function_name
* below made the function name. The lexer would
* return L_DEFINED_NAME instead.
*/
$$->type = validate_function_call(f, $4->r.expr);
} else {
f = define_new_function(name, 0, 0,
DECL_PUBLIC|FUNC_UNDEFINED, TYPE_ANY);
}
$$->l.number = f;
/*
* Check if this function has been defined.
* But, don't complain yet about functions defined
* by inheritance.
*/
if (exact_types && (FUNCTION_FLAGS(f) & FUNC_UNDEFINED)) {
char buf[256];
char *end = EndOf(buf);
char *p;
char *n = $1;
if (*n == ':') n++;
/* prevent some errors */
FUNCTION_FLAGS(f) &= ~FUNC_UNDEFINED;
FUNCTION_FLAGS(f) |= (FUNC_INHERITED | FUNC_VARARGS);
p = strput(buf, end, "Undefined function ");
p = strput(p, end, n);
yyerror(buf);
}
if (!(FUNCTION_FLAGS(f) & FUNC_UNDEFINED))
$$->type = FUNCTION_DEF(f)->type;
else
$$->type = TYPE_ANY; /* Just a guess */
}
$$ = check_refs(num_refs - $<number>2, $4, $$);
num_refs = $<number>2;
scratch_free(name);
}
| expr4 L_ARROW identifier '('
{
$<number>$ = context;
$<number>4 = num_refs;
context |= ARG_LIST;
}
expr_list ')'
{
ident_hash_elem_t *ihe;
int f;
parse_node_t *pn1, *pn2;
$6->v.number += 2;
pn1 = new_node_no_line();
pn1->type = 0;
pn1->v.expr = $1;
pn1->kind = $6->v.number;
pn2 = new_node_no_line();
pn2->type = 0;
CREATE_STRING(pn2->v.expr, $3);
scratch_free($3);
/* insert the two nodes */
pn2->r.expr = $6->r.expr;
pn1->r.expr = pn2;
$6->r.expr = pn1;
if (!$6->l.expr) $6->l.expr = pn2;
context = $<number>5;
ihe = lookup_ident("call_other");
if ((f = ihe->dn.simul_num) != -1) {
$$ = $6;
$$->kind = NODE_CALL_1;
$$->v.number = F_SIMUL_EFUN;
$$->l.number = f;
$$->type = (SIMUL(f)->type) & ~DECL_MODS;
} else {
$$ = validate_efun_call(arrow_efun, $6);
#ifdef CAST_CALL_OTHERS
$$->type = TYPE_UNKNOWN;
#else
$$->type = TYPE_ANY;
#endif
}
$$ = check_refs(num_refs - $<number>4, $6, $$);
num_refs = $<number>4;
}
| '(' '*' comma_expr ')' '('
{
$<number>$ = context;
$<number>5 = num_refs;
context |= ARG_LIST;
}
expr_list ')'
{
parse_node_t *expr;
context = $<number>6;
$$ = $7;
$$->kind = NODE_EFUN;
$$->l.number = $$->v.number + 1;
$$->v.number = predefs[evaluate_efun].token;
#ifdef CAST_CALL_OTHERS
$$->type = TYPE_UNKNOWN;
#else
$$->type = TYPE_ANY;
#endif
expr = new_node_no_line();
expr->type = 0;
expr->v.expr = $3;
expr->r.expr = $$->r.expr;
$$->r.expr = expr;
$$ = check_refs(num_refs - $<number>5, $7, $$);
num_refs = $<number>5;
}
;
efun_override: L_EFUN L_COLON_COLON identifier {
svalue_t *res;
ident_hash_elem_t *ihe;
$$ = (ihe = lookup_ident($3)) ? ihe->dn.efun_num : -1;
if ($$ == -1) {
char buf[256];
char *end = EndOf(buf);
char *p;
p = strput(buf, end, "Unknown efun: ");
p = strput(p, end, $3);
yyerror(buf);
} else {
push_malloced_string(the_file_name(current_file));
share_and_push_string($3);
push_malloced_string(add_slash(main_file_name()));
res = safe_apply_master_ob(APPLY_VALID_OVERRIDE, 3);
if (!MASTER_APPROVED(res)) {
yyerror("Invalid simulated efunction override");
$$ = -1;
}
}
scratch_free($3);
}
| L_EFUN L_COLON_COLON L_NEW {
svalue_t *res;
push_malloced_string(the_file_name(current_file));
push_constant_string("new");
push_malloced_string(add_slash(main_file_name()));
res = safe_apply_master_ob(APPLY_VALID_OVERRIDE, 3);
if (!MASTER_APPROVED(res)) {
yyerror("Invalid simulated efunction override");
$$ = -1;
} else $$ = new_efun;
}
;
function_name:
L_IDENTIFIER
| L_COLON_COLON identifier
{
int l = strlen($2) + 1;
char *p;
/* here we be a bit cute. we put a : on the front so we
* don't have to strchr for it. Here we do:
* "name" -> ":::name"
*/
$$ = scratch_realloc($2, l + 3);
p = $$ + l;
while (p--,l--)
*(p+3) = *p;
strncpy($$, ":::", 3);
}
| L_BASIC_TYPE L_COLON_COLON identifier
{
int z, l = strlen($3) + 1;
char *p;
/* <type> and "name" -> ":type::name" */
z = strlen(compiler_type_names[$1]) + 3; /* length of :type:: */
$$ = scratch_realloc($3, l + z);
p = $$ + l;
while (p--,l--)
*(p+z) = *p;
$$[0] = ':';
strncpy($$ + 1, compiler_type_names[$1], z - 3);
$$[z-2] = ':';
$$[z-1] = ':';
}
| identifier L_COLON_COLON identifier
{
int l = strlen($1);
/* "ob" and "name" -> ":ob::name" */
$$ = scratch_alloc(l + strlen($3) + 4);
*($$) = ':';
strcpy($$ + 1, $1);
strcpy($$ + l + 1, "::");
strcpy($$ + l + 3, $3);
scratch_free($1);
scratch_free($3);
}
;
cond:
L_IF '(' comma_expr ')' statement optional_else_part
{
/* x != 0 -> x */
if (IS_NODE($3, NODE_BINARY_OP, F_NE)) {
if (IS_NODE($3->r.expr, NODE_NUMBER, 0))
$3 = $3->l.expr;
else if (IS_NODE($3->l.expr, NODE_NUMBER, 0))
$3 = $3->r.expr;
}
/* TODO: should optimize if (0), if (1) here.
* Also generalize this.
*/
if ($5 == 0) {
if ($6 == 0) {
/* if (x) ; -> x; */
$$ = pop_value($3);
break;
} else {
/* if (x) {} else y; -> if (!x) y; */
parse_node_t *repl;
CREATE_UNARY_OP(repl, F_NOT, TYPE_NUMBER, $3);
$3 = repl;
$5 = $6;
$6 = 0;
}
}
CREATE_IF($$, $3, $5, $6);
}
;
optional_else_part:
/* empty */ %prec LOWER_THAN_ELSE
{
$$ = 0;
}
| L_ELSE statement
{
$$ = $2;
}
;
%%
%line
Reference in New Issue View Git Blame Copy Permalink