/*
* This is a Yacc-style attribute grammar for type checking and interpretation
* of a simple imperative language (SIL). SIL has the same basic semantics as
* Lisp with setq. The differences between SIL and imperative Lisp are: (1)
* SIL has more Pascal-like syntax; (2) SIL has explicit type declarations for
* variables and function parameters; (3) SIL distinguishes between statements
* and expressions, where statements are executed solely for there effect on
* the store, and do not return a value.
*
* The following semantic attributes are used in the SIL definition. The meta
* notation for semantic data definitions and auxiliary functions is standard
* ML, except for the "one of" notation, which is a simplified form of the ML
* union-defining datatype construct.
*
* NAME DESCRIPTION
* ===================================================================
*
* state A tuple of the form (env, store).
*
* env A list of the form [ env_binding ...]. Note that env is
* actually two separate attributes, denoted env and env`. Env is
* an inherited attribute representing the incoming environment;
* env` is a synthesized attribute representing the outgoing
* environment.
*
* store A list of the form [ act_rec ... ]. As with env, store is
* actually two attributes: an inherited store and a synthesized
* store`. Note the store is managed in a LIFO discipline, with
* the bottomost (earliest added) act_rec representing the global
* store, and the topmost (most recently added) act_rec
* representing the current function activation record.
*
* env_binding
* A tuple of the form (name, def).
*
* def One of var_def or fun_def.
*
* var_def
* A type.
*
* fun_def
* A triple form (type, formals, body).
*
* formals
* A list of the form [ var_binding ... ] used in a function def.
*
* var_binding
* A tuple of the form (name, var_def).
*
* type One of "integer", "real", "string", "boolean", or "OK".
*
* body A function (env*store)->store`.
*
* act_rec
* A list of the form [ value_binding, ... ]
*
* value_binding
* A tuple of the form (name, value).
*
* value One of integer or real or string or boolean, where these are
* considered primitive value types of the meta-language.
*
* op_fun A function (value*value)->value representing the built-in
* binary operators of the language.
*
* op_fun_1 A function value->value representing the built-in unary
* operators of the language.
*
* name A string.
*
* nil_X, error_X
* Attribute values built-in to the metalanguage for each
* attribute type X. nil_X is the nil or empty value for
* attributes of type X; error_X is the error value for attributes
* of type X.
*
* The following auxiliary functions are used in the definition:
*
* fun assoc(name, alist) =
* if null(alist) then nil_binding
* else if name = #1(hd(alist)) then hd(alist)
* else assoc(name, tl(alist))
*
* fun last(l) = hd(nthtail(l, length(l)-1))
*
* fun butlast(l) =
* if (null(l) orelse null(tl(l))) then nil
* else hd(l) :: butlast(tl(l))
*
* fun reassign(name, value, alist) =
* if name = #1(hd(alist)) then (name, value) :: tl(alist)
* else hd(alist) :: reassign(name, value, tl(alist)
*
* fun assign(name, value, alist) = (name, value) :: alist
*
* fun chk_apply(fun_name, actual_types, env)
* let
* val fun_binding = assoc(fun_name, env)
* val formals = make_type_list(#2(fun_binding))
* val fun-type = #1(fun_binding)
* in
* if chk_bindings(formals, actuals) then
* if fun_type = nil_type then
* "OK"
* else
* fun_type
* else
* error_type
* end
*
* fun make_type_list(formals) =
* if formals = nil then nil
* else #2(hd(formals)) :: make_type_list(tl(formals))
*
* fun chk_bindings(formals, actuals) =
* if formals = nil then true
* else (hd(formals) = hd(actuals)) and
* chk_bindings(tl(formals), tl(actuals))
*
* fun apply(fun_name, actuals, env, store) =
* let
* val fun_binding = assoc(fun_name, env)
* val fun_body = #3(fun_binding)
* val formals = make_name_list(#2(fun_binding))
* val bindings = bind(formals, actuals)
* in
* fun_body(env, bindings @ store)
* end
*
* fun make_name_list(formals) =
* if formals = nil then nil
* else #1(hd(formals)) :: make_name_list(tl(formals))
*
* fun bind(formals, actuals) =
* if formals = nil then nil
* else (hd(formals), hd(actuals)) :: bind(tl(formals), tl(actuals))
*
* fun functionize(tree,ins,outs) = a meta-function that transforms an
* attributed parse tree denoted by T into a function
* fT(ia<1>*...*ia<m>)->(sa<1>*...*sa<n>)
* where ia<i> are some or all of the inherited attributes of T and
* sa<j> are some or all of the synthesized attributes of T, as
* specified by ins and outs, resp. In practice within this
* definition, functionize is used to transform the parse tree of a
* function body into a function fn:(env*store)->store`.
*
* fun init_env() = []
*/
%token PROGRAM
%token END
%token VAR
%token INTEGER
%token REAL
%token CHAR
%token BOOLEAN
%token IDENTIFIER
%token PROCEDURE
%token BEGIN
%token IF
%token THEN
%token ENDIF
%token ELSE
%token OR
%token AND
%token LEQ
%token GEG
%token NEW
%token REALVAL
%token INTEGERVAL
%token CHARVAL
%token BOOLVAL
%left '=' '<' '>' LEQ GEQ NEQ
%left '+' '-' OR
%left '*' '/' AND
%%
program : PROGRAM decls stmts END
{$2.env = init_env()
$3.env = $2.env`
$3.store = []
$$.state = if ($2.type != error_type) and
($3.type != error_type) then
($2.env`, $3.store`)
else
error_state}
;
decls : /* empty */
{$$.env` = []
$$.type = "OK"}
| decl ';' decls
{$1.env = $$.env
$3.env = $1.env`
$$.env` = $1.env` @ $3.env`
$$.type = if ($1.type != error_type) and
($3.type != error_type) then
"OK"
else
error_type}
;
decl : vardecl
{$$.env` = $1.env`
$$.type = $1.type}
| procdecl
{$1.env = $$.env
$$.env` = $1.env`
$$.type = $1.type}
;
vardecl : VAR vars ':' type
{$2.type = $4.type
$$.env` = $2.env`
$$.type = $4.type}
;
type : INTEGER
{$$.type = "integer"}
| REAL
{$$.type = "real"}
| CHAR
{$$.type = "char"}
| BOOLEAN
{$$.type = "boolean"}
;
vars : var
{$$.env` = [($1.name, $$.type)]}
| var ',' vars
{$3.type = $$.type
$$.env` = [($1.name, $$.type)] @ $3.env`}
;
var : IDENTIFIER
{$$.name = $1.name}
/* NOTE: The lexer provides ident string names. */
;
procdecl : PROCEDURE prochdr procbody
{$3.env = $2.formals @ $$.env
$$.env` =
[($2.name, nil_type, $2.formals, $3.fun_body)]
$$.type = $3.type}
| PROCEDURE prochdr ':' type procbody
{$5.env = $2.formals @ [($2.name, $4.type)] @ $$.env
$$.env` =
[($2.name, $4.type,
$2.formals @ [($2.name, $4.type)],
/* ^^^^^^^^^^^^^^^^^^ return val */
$5.fun_body)]
$$.type = $5.type}
;
prochdr : IDENTIFIER '(' formals ')'
{$$.name = $1.name
$$.formals = $3.formals}
;
formals : /* empty */
{$$.formals = []}
| formal
{$$.formals = [$1.env_binding]}
| formal ',' formals
{$$.formals = $1.env_binding @ $3.formals}
;
formal : var ':' type
{$$.env_binding = ($1.name, $3.type)}
;
procbody : BEGIN stmts END
{$$.type = $2.type
$$.fun_body = functionize($2,(env*store),store`)}
;
stmts : stmt ';'
{$1.env = $$.env
$1.store = $$.store
$$.type = $1.type
$$.store` = $1.store`}
| stmt ';' stmts
{$1.env = $3.env = $$.env
$$.type = if $1.(type = "OK") and ($3.type = "OK")
then "OK" else error_type
$1.store = $$.store
$3.store = $1.store`
$$.store` = $3.store`}
;
stmt : /* empty */
| var ':=' expr
{$3.env = $$.env
$$.type = if #2(assoc($1.name, $$.env)) = $3.type
then "OK" else error_type
$3.store = $$.store
$$.store` =
if (length($3.store`) > 1) andalso
assoc($1.name, hd($3.store`)) then
reassign($1,name, $3.value, hd($3.store`)) @
tl($3.store`)
else if assoc($1.name, last($3.store`)) then
butlast($3.store`) @
reassign($1.name, $3.value, last($3.store`))
else
butlast($3.store`) @
assign($1.name, $3.value, last($3.store`))}
| IDENTIFIER '(' actuals ')'
{$$.type = if chk_apply($1,name, $3.types, $$.env)
$$.store` = tl(apply(
$1.name, $3.values, $$.env, $$.store))}
| IF expr THEN stmts ENDIF
{$2.env = $4.env = $$.env
$$.type =
if $2.type = "boolean"
then $4.type else error_type
(* NOTE WEAKNESS HERE *)
$4.store = $2.store`
$$.store` = if $2.value then $4.store` else $2.store`}
| IF expr THEN stmts ELSE stmts ENDIF
{$2.env = $4.env = $6.env = $$.env
$$.type =
if $2.type = "boolean"
then if $4.type = "OK" and $6.type = "OK"
then "OK"
else error_type (* NOTE WEAKNESS HERE *)
$4.store = $6.store = $2.store`
$$.store` = if $2.value then $4.store` else $6.store`}
;
expr : number
{$$.type = $1.type
$$.store` = $$.store
$$.value = $1.value}
| char
{$$.type = $1.type
$$.store` = $$.store
$$.value = $1.value}
| bool
{$$.type = $1.type
$$.store` = $$.store
$$.value = $1.value}
| var
{$$.type =
if assoc($1.name, $$.env) then
#2(assoc($1.name, $$.env))
else
error_type
$$.store` = $$.store
$$.value =
if (length($$.store) > 1) and also
assoc($1.name, hd($$.store)) then
#2(assoc($1.name, hd($$.store)))
else if assoc($1.name, last($$.store)) then
#2(assoc($1.name, last($$.store)))
else
error_value}
| IDENTIFIER '(' actuals ')'
{$3.env = $$.env
$3.store = $$.store
$$.type = chk_apply($1,name, $3.types, $$.env)
$$.store` = tl(apply(
$1.name, $3.values, $$.env, $$.store))
$$.value = last(hd(apply(
$1.name, $3.values, $$.env, $$.store)))}
| expr rel_op expr %prec '<'
{$1.env = $3.env = $$.env
$$.type =
if ($1.type = $2.type)
then $1.type
else error_type
$1.store = $$.store
$3.store = $1.store` (* NOTE *)
$$.store` = $3.store `
$$.value = $2.op_fun($1.value, $3.value)}
| expr add_op expr %prec '+'
{$1.env = $3.env = $$.env
$$.type =
if ($1.type = $2.type) and
(($1.type = "real") or ($1.type = "integer"))
then $1.type
else error_type
$1.store = $$.store
$3.store = $1.store`
$$.store` = $3.store `
$$.value = $2.op_fun($1.value, $3.value)}
| expr mult_op expr %prec '*'
{$1.env = $3.env = $$.env
$$.type =
if ($1.type = $2.type) and
(($1.type = "real") or ($1.type = "integer"))
then $1.type
else error_type
$1.store = $$.store
$3.store = $1.store`
$$.store` = $3.store `
$$.value = $2.op_fun($1.value, $3.value)}
| '(' expr ')'
{$2.env = $$.env
$$.type = $2.type
$2.store = $$.store
$$.store` = $2.store`
$$.value = $2.value}
;
add_op : '+' {$$.op_fun = $1.op_fun}
| '-' {$$.op_fun = $1.op_fun}
| OR {$$.op_fun = $1.op_fun}
/* NOTE: The lexer provides function literals. */
;
mult_op : '*' {$$.op_fun = $1.op_fun}
| '/' {$$.op_fun = $1.op_fun}
| AND {$$.op_fun = $1.op_fun}
;
rel_op : '<' {$$.op_fun = $1.op_fun}
| '>' {$$.op_fun = $1.op_fun}
| '=' {$$.op_fun = $1.op_fun}
| LEQ {$$.op_fun = $1.op_fun}
| GEQ {$$.op_fun = $1.op_fun}
| NEQ {$$.op_fun = $1.op_fun}
;
actuals : /* empty */
{$$.types = []
$$.store` = $$.store
$$.values = []}
| actual
{$1.env = $$.env
$1.store = $$.store
$$.types = [$1.type]
$$.store` = $1.store`
$$.values = [$1.value]}
| actual ',' actuals
{$1.env = $3.env = $$.env
$1.store = $$.store
$3.store = $1.store` /* NOTE sequential eval */
$$.store` = $3.store`
$$.values = $1.value @ $3.values}
;
actual : expr
{$$.type = $1.type
$$.store` = $1.store`
$$.value = $1.value}
;
number : real
{$$.type = $1.type
$$.value = $1.value}
| integer
{$$.type = $1.type
$$.value = $1.value}
;
real : REALVAL
{$$.type = "real"
$$.value = $1.value}
/* The lexer provides real literals. */
;
integer : INTEGERVAL
{$$.type = "integer"
$$.value = $1.value}
/* The lexer provides integer literals. */
;
char : CHARVAL
{$$.type = "char"
$$.value = $1.value}
/* The lexer provides char literals. */
;
bool : BOOLVAL
{$$.type = "boolean"
$$.value = $1.value}
/* The lexer provides boolean literals. */
;