BEGIN

#MODULE 'a-lex' is the lexical analyzer

#include "AtoC.h"


INT tk_COLON = ABS ':';
INT tk_LESS = ABS '<';
INT tk_GREATER = ABS '>';
INT tk_DIV = ABS '/';
INT tk_EQUAL = ABS '=';
INT tk_MULT = ABS '*';
INT tk_PLUS = ABS '+';
INT tk_MINUS = ABS '-';
INT tk_PIPE = ABS '|';
INT tk_LBRACKET = ABS '[';
INT tk_RBRACKET = ABS ']';
INT tk_LPARENTH = ABS '(';
INT tk_RPARENTH = ABS ')';
INT tk_SEMICOLON = ABS ';';
INT tk_COMMA = ABS ',';

INT tk_REF = 257;
INT tk_LOC = 258;
INT tk_STRUCT = 259;
INT tk_UNION = 260;
INT tk_TRUE = 261;
INT tk_FALSE = 262;
INT tk_NIL = 263;
INT tk_CHARCONST = 264;
INT tk_POWER = 265;
INT tk_UPB = 266;
INT tk_LWB = 267;
INT tk_BEGIN = 268;
INT tk_END = 269;
INT tk_IF = 270;
INT tk_THEN = 271;
INT tk_ELSE = 272;
INT tk_ELIF = 273;
INT tk_FI = 274;
INT tk_FOR = 275;
INT tk_FROM = 276;
INT tk_BY = 277;
INT tk_TO = 278;
INT tk_WHILE = 279;
INT tk_DO = 280;
INT tk_OD = 281;
INT tk_REPR = 282;
INT tk_FORWARD = 283;
INT tk_MOD  = 284;
INT tk_ESAC = 285;
INT tk_PROC = 286;
INT tk_ID = 287;
INT tk_INTCONST = 288;
INT tk_STRCONST = 289;
INT tk_COMMENT = 290;
INT tk_MODE = 291;
INT tk_AMODE = 292;

INT tk_ASSIGN = 293;
INT tk_OR = 294;
INT tk_OR = 295;
INT tk_AND = 296;
INT tk_AND = 297;
INT tk_NOT = 298;
INT tk_ABS = 299;
INT tk_NEQ = 300;
INT tk_GEQ = 301;
INT tk_LEQ = 302;
INT tk_IS = 303;
INT tk_ISNT = 304;
INT tk_OF = 305;

#INLINE /*
INT tk_EOF = 0;
#INLINE */

INT tk_ERROR = 1001;


# Forward declarations-macros

FORWARD PROC debugger = VOID;

# General constants

INT string_size = 256;
# (upper bound - 4, size in octets - 4)
INT array_header_size = 8;
INT struc_header_size = 0;


# New modes & structures

#INLINE typedef CHAR STRING[string_size];
MODE TOKEN = STRUCT(INT id, STRING str, STRING descr, INT line, BOOL used); 


# Variables

TOKEN token;
CHAR nextChar := REPR 0;
INT line := 1;
BOOL debug_echo := FALSE;
BOOL debug_stop := FALSE;
BOOL debug_stepwise := FALSE;
BOOL debug_expr := FALSE;
BOOL code_refs := FALSE;
BOOL code_comments := FALSE;


# Error: on error display message and terminate!

PROC error = (STRING msg) VOID:
BEGIN
  printf("ERROR: at token '%s', %s(%i): %s\n", str OF token, descr OF token, id OF token, msg);
  close(1);
  close(5);
  exit;
END;


PROC read = CHAR:
BEGIN
  CHAR ch := readc(1);
#  IF (ch = 10) THEN line := line + 1 FI;
  ch
END;


PROC itos = (INT value, REF STRING s) VOID:
BEGIN
  INT val := value;
  INT d, i;
  INT base;
  BOOL started := FALSE;

  base := 1000000;
  IF val < 0 THEN s[0] := '-'; val := -val; i := 1; ELSE i := 0; FI;
  WHILE base > 1 
  DO
    d := ABS '0';
    WHILE val >= base DO d := d + 1; val := val - base; OD;
    IF started OR d > ABS '0' THEN
      s[i] := REPR d;
      started := TRUE;
      i := i + 1;
    FI;
    base := base / 10; 
  OD;
  s[i] := REPR (val + ABS '0');
  s[i+1] := REPR 0;
END;


PROC IsDigit = (STRING s) BOOL:
BEGIN
  s[0] = '-' OR (s[0] >= '0' AND s[0] <= '9')
END;

PROC StrEqual = (STRING s1, STRING s2) BOOL:
BEGIN
  INT i := 0;
  WHILE i < string_size AND s1[i] /= REPR 0 AND s2[i] /= REPR 0 AND s1[i] = s2[i]
  DO 
    i := i + 1
  OD;
  s1[i] = s2[i]
END;


PROC StrLen = (STRING s) INT:
BEGIN
  INT i := 0;
  WHILE (s[i] /= REPR 0) DO i := i + 1 OD;
  i
END;


PROC StrUCase = (STRING s) BOOL:
BEGIN
  INT i := 0;
  WHILE i < string_size AND s[i] /= REPR 0 AND s[i] >= 'A' AND s[i] <= 'Z'
  DO 
    i := i + 1
  OD;
  s[i] = REPR 0
END;


PROC StrFind = (STRING s, CHAR ch, INT start) INT:
BEGIN
  INT i := start;
  WHILE i < string_size AND s[i] /= REPR 0 AND s[i] /= ch DO i := i + 1; OD;
  i
END;


PROC StrBelongs = (STRING s, CHAR ch) BOOL:
BEGIN
  INT i := 0;
  WHILE i < string_size AND s[i] /= REPR 0 AND s[i] /= ch DO i := i + 1; OD;
  s[i] /= REPR 0
END;


PROC StrAssign = (REF STRING s1, STRING s2) VOID:
BEGIN
  INT i := 0;
  WHILE i < string_size AND s2[i] /= REPR 0
  DO
    s1[i] := s2[i]; 
    i := i + 1
  OD;
  s1[i] := s2[i];
END;


PROC StrTail = (REF STRING s1, STRING s2, INT pos) VOID:
BEGIN
  INT i := 0;
  WHILE i+pos < string_size AND s2[i+pos] /= REPR 0 DO
    s1[i] := s2[i+pos]; 
    i := i + 1
  OD;
  s1[i] := s2[i+pos];
END;


PROC StrSlice = (REF STRING t, STRING s, INT start, INT end) VOID:
BEGIN
  INT k := start;
  WHILE k < string_size AND k <= end
  DO
    t[k-start] := s[k]; 
    k := k + 1
  OD;
  t[k-start] := REPR 0; 
END;


PROC StrAppend = (REF STRING s, STRING s1, STRING s2) VOID:
BEGIN
  STRING t;
  INT i := 0, j := 0;
  WHILE i < string_size AND s1[i] /= REPR 0 DO t[j] := s1[i]; i := i + 1; j := j + 1 OD;
  i := 0;
  WHILE i < string_size AND s2[i] /= REPR 0 DO t[j] := s2[i]; i := i + 1; j := j + 1 OD;
  t[j] := REPR 0;
  StrAssign(s, t);
END;


PROC store_token = (INT id, STRING descr) VOID:
BEGIN
  id OF token := id;
  StrAssign(descr OF token, descr);
  line OF token := line;
END;


PROC GetTokenId = VOID:
BEGIN
  StrAssign(descr OF token, "RESERVED");
  IF StrEqual(str OF token, "REF") THEN id OF token := tk_REF;
  ELIF StrEqual(str OF token, "LOC") THEN id OF token := tk_LOC;
  ELIF StrEqual(str OF token, "STRUCT") THEN id OF token := tk_STRUCT;
  ELIF StrEqual(str OF token, "TRUE") THEN id OF token := tk_TRUE;
  ELIF StrEqual(str OF token, "FALSE") THEN id OF token := tk_FALSE;
  ELIF StrEqual(str OF token, "NIL") THEN id OF token := tk_NIL;
  ELIF StrEqual(str OF token, "ABS") THEN id OF token := tk_ABS;
  ELIF StrEqual(str OF token, "NOT") THEN id OF token := tk_NOT;
  ELIF StrEqual(str OF token, "AND") THEN id OF token := tk_AND;
  ELIF StrEqual(str OF token, "OR") THEN id OF token := tk_OR;
  ELIF StrEqual(str OF token, "AND") THEN id OF token := tk_AND;
  ELIF StrEqual(str OF token, "OR") THEN id OF token := tk_OR;
  ELIF StrEqual(str OF token, "IS") THEN id OF token := tk_IS;
  ELIF StrEqual(str OF token, "ISNT") THEN id OF token := tk_ISNT;
  ELIF StrEqual(str OF token, "OF") THEN id OF token := tk_OF;
  ELIF StrEqual(str OF token, "BEGIN") THEN id OF token := tk_BEGIN;
  ELIF StrEqual(str OF token, "END") THEN id OF token := tk_END;
  ELIF StrEqual(str OF token, "IF") THEN id OF token := tk_IF;
  ELIF StrEqual(str OF token, "THEN") THEN id OF token := tk_THEN;
  ELIF StrEqual(str OF token, "ELSE") THEN id OF token := tk_ELSE;
  ELIF StrEqual(str OF token, "ELIF") THEN id OF token := tk_ELIF;
  ELIF StrEqual(str OF token, "FI") THEN id OF token := tk_FI;
  ELIF StrEqual(str OF token, "FOR") THEN id OF token := tk_FOR;
  ELIF StrEqual(str OF token, "FROM") THEN id OF token := tk_FROM;
  ELIF StrEqual(str OF token, "BY") THEN id OF token := tk_BY;
  ELIF StrEqual(str OF token, "TO") THEN id OF token := tk_TO;
  ELIF StrEqual(str OF token, "WHILE") THEN id OF token := tk_WHILE;
  ELIF StrEqual(str OF token, "DO") THEN id OF token := tk_DO;
  ELIF StrEqual(str OF token, "OD") THEN id OF token := tk_OD;
  ELIF StrEqual(str OF token, "PROC") THEN id OF token := tk_PROC;
  ELIF StrEqual(str OF token, "MODE") THEN id OF token := tk_MODE;
  ELIF StrEqual(str OF token, "LWB") THEN id OF token := tk_LWB;
  ELIF StrEqual(str OF token, "UPB") THEN id OF token := tk_UPB;
  ELIF StrEqual(str OF token, "REPR") THEN id OF token := tk_REPR;
  ELIF StrEqual(str OF token, "FORWARD") THEN id OF token := tk_FORWARD;
  ELIF StrEqual(str OF token, "MOD") THEN id OF token := tk_MOD;
  ELIF StrUCase(str OF token) THEN 
    store_token(tk_AMODE, "AMODE");
  ELSE 
    store_token(tk_ID, "IDENTIFIER");
  FI;
END;


PROC IsSeparator = (CHAR ch) BOOL:
BEGIN
  BOOL result;
  IF (ch = '(') 
     OR (ch = ')') 
     OR (ch = '[') 
     OR (ch = ']') 
     OR (ch = ':') 
     OR (ch = ';') 
     OR (ch = ',') 
     OR (ch = '*') 
     OR (ch = '+') 
     OR (ch = '-') 
     OR (ch = '=') 
     OR (ch = '/') 
     OR (ch = '>') 
     OR (ch = '<') 
     OR (ch = '|') 
  THEN
    result := TRUE
  ELSE
    result := FALSE
  FI;
  result
END;


PROC IsBlank = (CHAR ch) BOOL:
BEGIN
  BOOL result;
  IF ch <= ' ' AND ch /= REPR tk_EOF THEN
    result := TRUE
  ELSE
    result := FALSE
  FI;
  result
END;


PROC IsNumber = (CHAR ch) BOOL:
BEGIN
  BOOL result;
  IF (ch >= '0') AND (ch <= '9') THEN
    result := TRUE
  ELSE
    result := FALSE
  FI;
  result
END;


PROC IsIdChar = (CHAR ch) BOOL:
BEGIN
  BOOL result;
  IF ((ch >= 'A') AND (ch <= 'Z'))
     OR ((ch >= 'a') AND (ch <= 'z'))
     OR IsNumber(ch)
     OR (ch = '_')
  THEN
    result := TRUE
  ELSE
    result := FALSE
  FI;
  result
END;


PROC GetSeparator = VOID:
BEGIN
  IF nextChar = ':' THEN
    nextChar := read;
    IF nextChar = '=' THEN 
      store_token(tk_ASSIGN, "ASSIGN");				# ASSIGN 
      StrAssign(str OF token, ":=");
      nextChar := read;
    ELSE
      store_token(tk_COLON, "COLON");				# COLON 
      StrAssign(str OF token, ":");
    FI;
  ELIF nextChar = '<' THEN
    nextChar := read;
    IF nextChar = '=' THEN 
      store_token(tk_LEQ, "LEQ");					# LESSEQUAL 
      StrAssign(str OF token, "<=");
      nextChar := read;
    ELSE
      store_token(tk_LESS, "LESS");
      StrAssign(str OF token, "<")	;				# LESS 
    FI;
  ELIF nextChar = '>' THEN
    nextChar := read;
    IF nextChar = '=' THEN 
      store_token(tk_GEQ, "GEQ");					# GREATEREQUAL 
      StrAssign(str OF token, ">=");
      nextChar := read;
    ELSE
      store_token(tk_GREATER, "GREATER");				# GREATER 
      StrAssign(str OF token, ">");
    FI;
  ELIF nextChar = '/' THEN
    nextChar := read;
    IF nextChar = '=' THEN 
      store_token(tk_NEQ, "NEQ");					# NOTEQUAL 
      StrAssign(str OF token, "/=");
      nextChar := read;
    ELSE
      store_token(tk_DIV, "DIV");					# DIV 
      StrAssign(str OF token, "/");
    FI;
  ELIF nextChar = '=' THEN
    nextChar := read;
    store_token(tk_EQUAL, "EQUAL");					# EQUAL 
    StrAssign(str OF token, "=");
  ELIF nextChar = '*' THEN
    nextChar := read;
    IF nextChar = '*' THEN 
      store_token(tk_POWER, "POWER");				# POWER
      StrAssign(str OF token, "**");
      nextChar := read;
    ELSE
      store_token(tk_MULT, "MULT");					# MULT 
      StrAssign(str OF token, "*");
    FI;
  ELIF nextChar = '+' THEN
    nextChar := read;
    store_token(tk_PLUS, "PLUS");					# PLUS 
    StrAssign(str OF token, "+");
  ELIF nextChar = '-' THEN
    nextChar := read;
    store_token(tk_MINUS, "MINUS");					# MINUS 
    StrAssign(str OF token, "-");
  ELIF nextChar = '|' THEN
    nextChar := read;
    store_token(tk_PIPE, "PIPE");					# PIPE 
    StrAssign(str OF token, "|");
  ELIF nextChar = '[' THEN
    nextChar := read;
    store_token(tk_LBRACKET, "LBRACKET");				# LEFT BRACKET 
    StrAssign(str OF token, "[");
  ELIF nextChar = ']' THEN
    nextChar := read;
    store_token(tk_RBRACKET, "RBRACKET");				# RIGHT BRACKET 
    StrAssign(str OF token, "]");
  ELIF nextChar = '(' THEN
    nextChar := read;
    store_token(tk_LPARENTH, "LPARENTH");				# LEFT PARENTHESIS 
    StrAssign(str OF token, "(");
  ELIF nextChar = ')' THEN
    nextChar := read;
    store_token(tk_RPARENTH, "RPARENTH");				# RIGHT PARENTHESIS 
    StrAssign(str OF token, ")");
  ELIF nextChar = ';' THEN
    nextChar := read;
    store_token(tk_SEMICOLON, "SEMICOLON");			# SEMI-COLON 
    StrAssign(str OF token, ";");
  ELIF nextChar = ',' THEN
    nextChar := read;
    store_token(tk_COMMA, "COMMA");					# COMMA 
    StrAssign(str OF token, ",");
  ELSE
    printf("UNEXPECTED ERROR!\n");
  FI;
END;


PROC GetNextToken = VOID:
BEGIN
  INT i := 0;

  IF debug_stepwise THEN debugger; FI;

  WHILE IsBlank(nextChar) OR nextChar = '#'
  DO
    WHILE IsBlank(nextChar) DO				# Handle WHITE SPACE
      nextChar := read;
    OD;
    IF nextChar = '#' THEN					# Handle COMMENTS
      nextChar := read;
      WHILE nextChar /= '\n' DO nextChar := read OD;
      nextChar := read;
    ELIF nextChar = '@' THEN
      nextChar := read;
      IF nextChar = '+' THEN debug_echo := TRUE; nextChar := read;
      ELIF nextChar = '-' THEN debug_echo := FALSE; nextChar := read;
      ELSE debugger;
      FI;
    FI;
  OD;

  IF nextChar = REPR tk_EOF THEN
    store_token(tk_EOF, "EOF");
# ---------------------------------------------------------------------------------	#
# 						SEPARATORS 							#
# ---------------------------------------------------------------------------------	#
  ELIF IsSeparator(nextChar) THEN
    GetSeparator;
# ---------------------------------------------------------------------------------	#
# 						 STRINGS 							#
# ---------------------------------------------------------------------------------	#
  ELIF nextChar = '\"' THEN 
    store_token(tk_STRCONST, "STRCONST");
    (str OF token)[i] := nextChar;
    i := i + 1;
    nextChar := read;
    WHILE nextChar /= '\"' DO
      (str OF token)[i] := nextChar;
      i := i + 1;
      IF nextChar = '\\' THEN (str OF token)[i] := read; i := i + 1; FI;
      nextChar := read;
    OD;
    (str OF token)[i] := nextChar;
    (str OF token)[i+1] := REPR 0;
    nextChar := read;
# ---------------------------------------------------------------------------------	#
# 						CHARACTERS 							#
# ---------------------------------------------------------------------------------	#
  ELIF nextChar = '\'' THEN
    nextChar := read;
    IF nextChar = '\\' THEN					  # handle special characters
      nextChar := read;
      IF nextChar = '\'' OR nextChar = '\"' OR nextChar = '\\' THEN (str OF token)[0] := nextChar;
      ELIF nextChar = 't' THEN (str OF token)[0] := REPR 9;
      ELIF nextChar = 'n' THEN (str OF token)[0] := REPR 10;
      ELSE error("Invalid char constant!");
      FI;
    ELSE
      (str OF token)[0] := nextChar;			  # store char
    FI;
    nextChar := read;
    IF nextChar /= '\'' THEN					  # end of char
      error("Invalid char constant!");
    ELSE
      (str OF token)[1] := REPR 0;
      store_token(tk_CHARCONST, "CHARCONST");
    FI;
    nextChar := read;
# ---------------------------------------------------------------------------------	#
# 						INTEGERS 							#
# ---------------------------------------------------------------------------------	#
  ELIF IsNumber(nextChar) THEN 
    store_token(tk_INTCONST, "INTCONST");
    WHILE IsNumber(nextChar) 
    DO
      (str OF token)[i] := nextChar;
      i := i + 1;
      nextChar := read;
    OD;
    (str OF token)[i] := REPR 0;
# ---------------------------------------------------------------------------------	#
# 					     IDENTIFIERS 							#
# ---------------------------------------------------------------------------------	#
  ELIF IsIdChar(nextChar) THEN 
    WHILE IsIdChar(nextChar) 
    DO
      (str OF token)[i] := nextChar;
      i := i + 1;
      nextChar := read;
    OD;
    (str OF token)[i] := REPR 0;
    GetTokenId;
# ---------------------------------------------------------------------------------	#
# 						  ERROR 							#
# ---------------------------------------------------------------------------------	#
  ELSE 
    store_token(tk_ERROR, "ERROR");
    (str OF token)[0] := nextChar;
    (str OF token)[1] := REPR 0;
    nextChar := read;
  FI;
  used OF token := FALSE;
END;




#MODULE 'a-symbol' set of data structures & functions to manipulate the symbol table


FORWARD PROC generate_code = VOID;
FORWARD PROC process_frame = VOID;
FORWARD PROC lookup = (STRING name) INT;


INT stack_bound = 3000;
INT proc_info_bound = 1000;
INT temps_bound = 1000;

INT rule_assign = 1;
INT rule_identity = 2;
INT rule_itemize = 3;


INT context_firm = 1;
INT context_strong = 2;
INT context_meek = 3;
INT context_week = 4;
INT context_soft = 5;


INT entity_empty = 0;
INT entity_frame = 1;
INT entity_var = 2;
INT entity_tempvar = 3;
INT entity_ptrvar = 4;
INT entity_argvar = 5;
INT entity_param = 6;
INT entity_constant = 7;
INT entity_proc = 8;
INT entity_mode = 9;
INT entity_label = 10;
INT entity_startscope = 11;
INT entity_endscope = 12;


INT max_nesting = 10;
INT max_gtemps = 10;
INT max_files = 5;
INT max_params = 10;


STRING dummy;


# ################################################################################################### #
# TABLE table_strings: all constant strings are stored here!							#
# ################################################################################################### #
# <table_strings_bound>	- maximum table size 										#
# <table_strings>		- where strings are stored during compile time						#
# current_strindex	- next char to be used for storing strings into the table				#
# current_stroffset	- next run-time offset with respect to global register <strp>			#
# ################################################################################################### #
INT table_strings_bound = 20000;
[table_strings_bound]CHAR table_strings;
INT current_stroffset := 0;
INT current_strindex := 0;



# ################################################################################################### #
# Structure PROCINFO: information about procedures									#
# ################################################################################################### #
# <label>		- procedure label in the assembly code								#
# <quadptr>		- pointer to the quad of table <quads> where the procedure starts				#
# <temps_used>	- array where the used temporaries are kept							#
# <max_temp>	- the highest rank of used temporary within the procedure					#
# <done>		- mark TRUE if code was generated for this procedure						#
# ################################################################################################### #
MODE PROCINFO = STRUCT(STRING label, INT quadptr, [temps_bound]BOOL temps_used, INT max_temp, BOOL done);

[proc_info_bound]PROCINFO table_proc_info;
INT proc_info_index := 0;
INT current_proc := 0;
INT current_nesting := 0;


# ################################################################################################### #
# Structure ENTITY: information about symbol table entries								#
# ################################################################################################### #
# <type>		- type of entry												#
# <name>		- symbol name (variable, constant, procedure name, etc.)					#
# <value>		- constant value (if applicable)									#
# <nesting>		- nesting level												#
# <id>		- symbol id number for temporaries and labels							#
# <mode>		- symbol mode name											#
# <mode_size>	- the required size in bytes							 			#
# <storage_type>	- where the symbol is stored (<register>, <constant>, or <memory>)			#
# <addr_offset>	- variable's offset, if stored in memory								#
# <reg>		- variable's register, if in register								#
# <proc_info>	- pointer to procedure information table <table_proc_info>					#
# <scopeptr>	- pointer to start of previous scope in table <stack>						#
# ################################################################################################### #
MODE ENTITY = STRUCT(INT type, STRING name, STRING value, INT nesting, INT id, INT proc_info, INT scopeptr, 			   STRING mode, INT mode_size, INT storage_type, INT addr_offset, INT reg);


[stack_bound]ENTITY stack;
INT stack_index := 1;
INT current_scope_start := 1;


INT arg_count := 0;

INT label_count := 0;
INT quad_index := 0;


PROC align = (INT n) INT:
BEGIN
  INT i; 
  IF n MOD 8 = 0 THEN i := n ELSE i := 8*(n/8+1) FI;
  i
END;


PROC set_next_proc = VOID:
BEGIN
  current_proc := proc_info_index;
  WHILE current_proc > 0 AND done OF table_proc_info[current_proc]
  DO
    current_proc := current_proc - 1;
  OD;
END;


PROC reset_temps = VOID:
BEGIN
  INT i := 0;
  max_temp OF table_proc_info[proc_info_index] := 0;			# CAUTION: is proc_info_index right?
  WHILE i < temps_bound 
  DO 
    (temps_used OF table_proc_info[proc_info_index])[i] := FALSE;
    i := i + 1;
  OD;
END;


PROC get_next_temp = INT:
BEGIN
  INT i := 0;
  WHILE i < temps_bound AND (temps_used OF table_proc_info[current_proc])[i] DO i := i + 1; OD;
  IF i = temps_bound THEN error("Temporary variables exhausted!"); FI;
  IF i > max_temp OF table_proc_info[current_proc] THEN 
    max_temp OF table_proc_info[current_proc] := max_temp OF table_proc_info[current_proc] + 1; 
  FI;
  (temps_used OF table_proc_info[current_proc])[i] := TRUE;
  i
END;


PROC reset_args = VOID:
BEGIN
  arg_count := 0; 
END;


PROC get_arg_temp = INT:
BEGIN
  INT i := arg_count;
  arg_count := arg_count + 1;
  i
END;


PROC free_temp = (INT ptr) VOID:
BEGIN
  INT n;
  IF type OF stack[ptr] = entity_tempvar OR type OF stack[ptr] = entity_ptrvar THEN
    n := id OF stack[ptr];
    (temps_used OF table_proc_info[current_proc])[n] := FALSE;
    IF debug_echo THEN printf("\nTemp %i freed\n", n); FI;
  ELSE
    IF debug_echo THEN printf("\nFailed to free temp!\n"); FI;
  FI;
END;


PROC reset_labels = VOID:
BEGIN
  label_count := 0;
END;


PROC get_next_label = INT:
BEGIN
  label_count := label_count + 1;
  label_count
END;


PROC inc_stack_index = VOID:
BEGIN
  stack_index := stack_index + 1;
  IF stack_index >= stack_bound THEN printf("Panic: Max stack limit exceeded!\n"); exit; FI;
END;


# ################################################################################################### #
# MODE MANIPULATION FUNCTIONS													#
# ################################################################################################### #


PROC IsPrefix = (STRING s, STRING p) BOOL:
BEGIN
  INT i := 0;
  WHILE p[i] /= REPR 0 AND s[i] = p[i] DO i := i + 1 OD;
  p[i] = REPR 0
END;


PROC is_mode_void = (INT ptr) BOOL:
BEGIN
  StrEqual(mode OF stack[ptr], "VOID")
END;


PROC is_mode_array = (INT ptr) BOOL:
BEGIN
  IsPrefix(mode OF stack[ptr], "[") OR IsPrefix(mode OF stack[ptr], "REF [")
END;


PROC is_mode_struc = (INT ptr) BOOL:
BEGIN
  IsPrefix(mode OF stack[ptr], "(") OR IsPrefix(mode OF stack[ptr], "REF (")
END;


PROC is_mode_ptr = (INT ptr) BOOL:
BEGIN
  IsPrefix(mode OF stack[ptr], "REF REF")
END;


PROC get_storage_size = (STRING m, BOOL array) INT:
BEGIN
  INT ptr, size;
  STRING mode;

  IF IsPrefix(mode, "REF") THEN StrTail(mode, m, 4); ELSE StrAssign(mode, m); FI;
  
  IF array THEN
    IF StrEqual(mode, "REF") THEN size := 8;
    ELIF StrEqual(mode, "FILE") THEN size := 4;
    ELIF StrEqual(mode, "INT") THEN size := 4;
    ELIF StrEqual(mode, "CHAR") THEN size := 1;
    ELIF StrEqual(mode, "BOOL") THEN size := 1;
    ELIF StrEqual(mode, "STRING") THEN size := string_size;
    ELIF StrEqual(mode, "VOID") THEN size := 0;
    ELSE ptr := lookup(mode); size := mode_size OF stack[ptr];
    FI;
  ELSE
    IF StrEqual(mode, "REF") THEN size := 8;
    ELIF StrEqual(mode, "FILE") THEN size := 8;
    ELIF StrEqual(mode, "INT") THEN size := 8;
    ELIF StrEqual(mode, "CHAR") THEN size := 8;
    ELIF StrEqual(mode, "BOOL") THEN size := 8;
    ELIF StrEqual(mode, "STRING") THEN size := string_size;
    ELIF StrEqual(mode, "VOID") THEN size := 0;
    ELSE ptr := lookup(mode); size := mode_size OF stack[ptr]; 
    FI;
  FI;
  size
END;


PROC get_element_size = (INT ptr) INT:
BEGIN
  STRING mode;
  INT size;

  IF is_mode_array(ptr) THEN StrTail(mode, mode OF stack[ptr], 3) 
  ELSE StrAssign(mode, mode OF stack[ptr]) FI; 

  IF IsPrefix(mode, "REF") THEN size := 8;
  ELIF StrEqual(mode, "FILE") THEN size := 4;
  ELIF StrEqual(mode, "INT") THEN size := 4;
  ELIF StrEqual(mode, "CHAR") THEN size := 1;
  ELIF StrEqual(mode, "BOOL") THEN size := 1;
  ELIF StrEqual(mode, "STRING") THEN size := string_size;
  ELSE
    printf("get_element_size: mode %s not implemented!\n", mode);
    error("");
  FI;
  size
END;


PROC get_storage_code = (INT ptr) CHAR:
BEGIN
  STRING mode;
  CHAR code;

  IF IsPrefix(mode OF stack[ptr], "REF") THEN StrTail(mode, mode OF stack[ptr], 4); 
  ELSE StrAssign(mode, mode OF stack[ptr]); FI; 

  IF is_mode_array(ptr) THEN StrTail(mode, mode, StrFind(mode, ']', 0) + 2); FI; 

  IF IsPrefix(mode, "REF") THEN code := 'O';
  ELIF StrEqual(mode, "INT") THEN code := 'T';
  ELIF StrEqual(mode, "CHAR") THEN code := 'B';
  ELIF StrEqual(mode, "BOOL") THEN code := 'B';
  ELIF StrEqual(mode, "STRING") THEN code := 'B';
  ELSE
    printf("get_storage_code: non-primitive mode _%s_\n", mode);
    error("");
  FI;
  code 
END;


PROC deref_mode = (STRING source_mode, STRING target_mode) INT:
BEGIN
  STRING mode;
  INT count := 0;
  StrAssign(mode, source_mode);
  WHILE NOT StrEqual(mode, target_mode) AND IsPrefix(mode, "REF")
  DO 
    count := count + 1;
    StrTail(mode, mode, 4);
  OD;
  IF NOT StrEqual(mode, target_mode) THEN count := -1; FI;
  count
END;


PROC check_mode = (INT ptr, STRING mode) BOOL:
BEGIN
  deref_mode(mode OF stack[ptr], mode) >= 0
END;


PROC accept_mode = (INT ptr, STRING mode) VOID:
BEGIN
  IF NOT check_mode(ptr, mode) THEN
    printf("Expected mode %s and found %s! ", mode, mode OF stack[ptr]);
    error("Incompatible modes!")
  FI;
END;


PROC is_mode_composite = (INT ptr) BOOL:
BEGIN
  check_mode(ptr, "STRING") OR is_mode_array(ptr) OR is_mode_struc(ptr)
END;


PROC is_mode_ref = (INT ptr) BOOL:
BEGIN
  IsPrefix(mode OF stack[ptr], "REF")
END;


PROC StrMatchPrefix = (REF STRING str, STRING prefix) INT:
BEGIN
  STRING tmp;
  INT j := 0;
  WHILE prefix[j] /= REPR 0 AND prefix[j] = str[j]
  DO 
    IF str[j] = '[' THEN 
      StrSlice(tmp, str, 0, j);
      StrTail(str, str, StrFind(str, ']', j));
      StrAppend(str, tmp, str);
    FI;
    j := j + 1; 
  OD;
  j
END;


PROC unify = (REF STRING lmode, REF STRING rmode, REF STRING mode) VOID:
BEGIN
  STRING prefix;
  INT i, j, n;
  BOOL found;

  IF IsPrefix(mode, "{}") AND 
     NOT IsPrefix(rmode, "REF") AND NOT IsPrefix(rmode, "(") AND NOT IsPrefix(rmode, "[")
  THEN
    StrAppend(lmode, lmode, rmode);
    StrAssign(mode, "");
  ELIF IsPrefix(mode, "{") THEN
    i := 1;
    n := StrLen(mode);
    found := FALSE;
    WHILE i < n AND NOT found
    DO
      j := StrFind(mode, ',', i);
      IF j = n THEN StrSlice(prefix, mode, i, j - 2); ELSE StrSlice(prefix, mode, i, j - 1); FI;
      IF StrEqual(rmode, prefix) THEN 
        StrAppend(lmode, lmode, prefix);
        StrAssign(mode, "");
        found := TRUE;
      FI;
      i := j + 1;
    OD;
  ELSE
    i := StrMatchPrefix(rmode, mode);
# printf("StrMatchPrefix(%s,%s) = %i\n", rmode, mode, i);
    StrSlice(prefix, rmode, 0, i - 1);
    StrAppend(lmode, lmode, prefix);
    StrTail(rmode, rmode, i);
    StrTail(mode, mode, i);
# printf("unify: (prefix,lmode,rmode,mode) = (%s,%s,%s,%s)\n", prefix, lmode, rmode, mode);
  FI;
END;


PROC unify_labels = (INT target, INT source) VOID:
BEGIN
  id OF stack[target] := id OF stack[source];
  StrAssign(name OF stack[target], name OF stack[source]);
END;



# ################################################################################################### #
# EXTRACT SEMANTIC INFO FOR PROCEDURES											#
# --------------------------------------------------------------------------------------------------- #
# get_proc_mode: returns the mode of a procedure									#
# get_param_mode: returns the mode of a procedure's parameter							#
# ################################################################################################### #

PROC get_proc_mode = (INT proc, REF STRING mode) VOID:
BEGIN
  StrTail(mode, mode OF stack[proc], StrFind(mode OF stack[proc], ':', 0) + 1);
END;


PROC get_param_mode = (INT proc, INT rank, REF STRING mode) VOID:
BEGIN
  STRING pmode;
  INT pos, k, count := rank - 1;
  StrAssign(pmode, mode OF stack[proc]);
  pos := StrFind(pmode, '(', 0) + 1;
  k := pos;
  WHILE count > 0 
  DO
    IF pmode[pos] = '|' THEN count := count - 1; pos := pos + 1; k := pos; FI;
    pos := pos + 1;
  OD;
  StrSlice(mode, pmode, k, StrFind(pmode, '|', k) - 1);
END;



# ################################################################################################### #
# calc_mode_size - compute the size of a mode (ignore initial REF?)						#
# ################################################################################################### #

PROC get_next_field = (REF STRING fieldmode, REF STRING fieldname, STRING mode, INT pos) INT:
BEGIN
  INT paren;
  INT i := pos;
  INT j;

  IF mode[i] = '(' THEN
    paren := 1;
    i := i + 1;
    WHILE paren > 0
    DO
      IF mode[i] = '(' THEN paren := paren + 1; ELIF mode[i] = ')' THEN paren := paren - 1; FI;
      i := i + 1;
    OD;
  ELSE
    WHILE mode[i] < 'a' OR mode[i] > 'z' DO i := i + 1; OD;
  FI;
  StrSlice(fieldmode, mode, pos, i - 2);

  WHILE mode[i] = ' ' DO i := i + 1; OD;
  j := i;
  WHILE mode[i] /= ')' AND mode[i] /= ',' DO i := i + 1; OD;
  StrSlice(fieldname, mode, j, i - 1);

  IF mode[i] = ')' THEN i := -1; ELSE i := i + 1; FI;

  i
END;


PROC calc_mode_size = (STRING source_mode, BOOL array) INT:
BEGIN
  INT size, k, pos;
  STRING next_mode, mode, field, items;
  INT ptr;

  IF IsPrefix(source_mode, "REF") THEN StrTail(mode, source_mode, 4); 
  ELSE StrAssign(mode, source_mode); 
  FI;

# CAUTION: STRUCT recursiveness does NOT work!

  IF IsPrefix(mode, "[") THEN 
    k := StrFind(mode, '[', 0);
    pos := StrFind(mode, ']', 0);
    StrSlice(items, mode, k + 1, pos - 1);
    StrTail(next_mode, mode, pos + 2);
    size := align(array_header_size + str2int(items) * calc_mode_size(next_mode, TRUE));      
  ELIF IsPrefix(mode, "(") THEN
    pos := StrFind(mode, '(', 0) + 1;
    size := struc_header_size;
    WHILE pos > 0 
    DO
      pos := get_next_field(next_mode, field, mode, pos);
      size := size + calc_mode_size(next_mode, FALSE);
    OD;
  ELSE
    IF array THEN
      IF IsPrefix(mode, "REF") THEN size := 8;
      ELIF StrEqual(mode, "FILE") THEN size := 4;
      ELIF StrEqual(mode, "INT") THEN size := 4;
      ELIF StrEqual(mode, "CHAR") THEN size := 1;
      ELIF StrEqual(mode, "BOOL") THEN size := 1;
      ELIF StrEqual(mode, "STRING") THEN size := string_size;
      ELIF StrEqual(mode, "VOID") OR StrEqual(mode, "?") THEN size := 0;
      ELSE 
        ptr := lookup(mode);
        size := calc_mode_size(mode OF stack[ptr], FALSE);
      FI;
    ELSE
      IF IsPrefix(mode, "REF") THEN size := 8;
      ELIF StrEqual(mode, "FILE") THEN size := 8;
      ELIF StrEqual(mode, "INT") THEN size := 8;
      ELIF StrEqual(mode, "CHAR") THEN size := 8;
      ELIF StrEqual(mode, "BOOL") THEN size := 8;
      ELIF StrEqual(mode, "STRING") THEN size := string_size;
      ELIF StrEqual(mode, "VOID") OR StrEqual(mode, "?") THEN size := 0;
      ELSE 
        ptr := lookup(mode);
        size := calc_mode_size(mode OF stack[ptr], FALSE);
      FI;
    FI;
  FI;
  size
END;


PROC calc_mode_items = (STRING mode) INT:
BEGIN
  INT i, j;
  STRING items;
  IF IsPrefix(mode, "[") OR IsPrefix(mode, "REF [") THEN 
    i := StrFind(mode, '[', 0);
    j := StrFind(mode, ']', i);
    StrSlice(items, mode, i + 1, j - 1);
  ELSE
    printf("calc_mode_items: %s not an array!", mode);
    error("");
  FI;
  str2int(items)
END;






# ################################################################################################### #
# FUNCTIONS	FOR STRUCTURES													#
# ################################################################################################### #


PROC match = (STRING strucmode, STRING fieldname, INT start) INT:
BEGIN
  INT i := start;
  INT j := 0;

  WHILE fieldname[j] /= REPR 0 AND fieldname[j] = strucmode[i] 
  DO
    j := j + 1;
    i := i + 1;
  OD;
  IF NOT (fieldname[j] = REPR 0 AND 
    (strucmode[i] = REPR 0 OR strucmode[i] = ',' OR strucmode[i] = ')'))
  THEN
    i := -1;
  FI;
  i
END;


PROC calc_field_offset = (STRING mode, STRING name) INT:
BEGIN
  STRING fieldmode, field;
  INT pos := StrFind(mode, '(', 0) + 1;
  INT offset := struc_header_size;
  WHILE pos > 0 
  DO
    pos := get_next_field(fieldmode, field, mode, pos);
    IF StrEqual(field, name) THEN pos := 0;
    ELSE offset := offset + calc_mode_size(fieldmode, FALSE); FI;
  OD;
  offset
END;


PROC find_field = (REF STRING strucmode, STRING fieldname, REF STRING fieldmode) BOOL:
BEGIN
  STRING alias, mode, field;
  BOOL found := FALSE;
  INT paren, pos, k;
  INT i;
  INT ptr;

#  printf("STRUCMODE = %s\n", strucmode);

# get rid of leading REF
  IF IsPrefix(strucmode, "REF") THEN 
    i := 4;
    StrSlice(fieldmode, strucmode, 0, i - 1); 
  ELSE 
    i := 0;
  FI;

# CAUTION: this should be a WHILE loop
  IF strucmode[i] /= '(' THEN
    StrTail(alias, strucmode, i);
    strucmode[i] := REPR 0;
    ptr := lookup(alias);
    StrAppend(strucmode, strucmode, mode OF stack[ptr]);
  FI;

  i := i + 1;
  k := i;

  WHILE strucmode[i] /= REPR 0 AND NOT found
  DO 

    IF strucmode[i] = '(' THEN
      paren := 1;
      i := i + 1;
      WHILE paren > 0
      DO
        IF strucmode[i] = '(' THEN paren := paren + 1; ELIF strucmode[i] = ')' THEN paren := paren - 1; FI;
        i := i + 1;
      OD;
    FI;

    IF strucmode[i] >= 'a' AND strucmode[i] <= 'z' THEN
      pos := match(strucmode, fieldname, i);
# printf("MATCHING '%s' in '%s' => %i\n", fieldname, strucmode + i, pos);
      IF pos = -1 THEN
        WHILE NOT (strucmode[i] = ',' OR strucmode[i] = ')') DO i := i + 1; OD;
        IF strucmode[i] = ',' THEN i := i + 1; k := i; FI;
      ELSE
        StrSlice(mode, strucmode, k, i - 2);
        StrAppend(fieldmode, fieldmode, mode);
        found := TRUE;
      FI;

    ELSE
      i := i + 1;
    FI;
  OD;
  found
END;


PROC set_fieldvar = (INT struc, INT field) VOID:
BEGIN
  STRING fieldmode;
  STRING tmp;

  IF NOT find_field(mode OF stack[struc], name OF stack[field], fieldmode) THEN
    printf("Field %s not found in structure %s!", name OF stack[field], mode OF stack[struc]);
    error("")
  FI;
#  printf("Final mode is _%s_\n", fieldmode);

  type OF stack[field] := entity_ptrvar;
  StrAssign(mode OF stack[field], fieldmode);
  mode_size OF stack[field] := calc_mode_size(fieldmode, FALSE);
  addr_offset OF stack[field] := calc_field_offset(mode OF stack[struc], name OF stack[field]);

  id OF stack[field] := get_next_temp;
  int2str(id OF stack[field], tmp);
  StrAppend(name OF stack[field], "%", tmp);
END;




# ################################################################################################### #
# SYMBOL TABLE ENTRY FUNCTIONS												#
# ################################################################################################### #


PROC record_string = (STRING name) INT:
BEGIN
  INT offset := current_stroffset;
  INT i;
  IF StrLen(name) > 2 THEN
    table_strings[current_strindex] := name[0];
    current_strindex := current_strindex + 1;
    current_stroffset := current_stroffset + 1;
    i := 1;
    WHILE name[i+1] /= REPR 0 
    DO
      IF name[i] = '\"' THEN								# MMIX wants quotes out of string
        table_strings[current_strindex] := '\"';
        table_strings[current_strindex+1] := ',';
        table_strings[current_strindex+2] := '\'';
        table_strings[current_strindex+3] := '\"';
        table_strings[current_strindex+4] := '\'';
        table_strings[current_strindex+5] := ',';
        table_strings[current_strindex+6] := '\"';
        current_strindex := current_strindex + 7;
        current_stroffset := current_stroffset + 1;
        i := i + 1;
      ELSE
        table_strings[current_strindex] := name[i];
        current_strindex := current_strindex + 1;
        current_stroffset := current_stroffset + 1;
        i := i + 1;
      FI;
    OD;
    table_strings[current_strindex] := name[i];
    table_strings[current_strindex+1] := name[i+1];
    current_strindex := current_strindex + 2;
    current_stroffset := align(current_stroffset + 8);			# trailing zero + zero octabyte!
  ELSE
    offset := current_stroffset - 8;						# use previous!
  FI;
  offset
END;


PROC new_mode = (STRING name, STRING mode) INT:
BEGIN
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_mode;
  StrAssign(name OF stack[stack_index], name);
  nesting OF stack[stack_index] := current_nesting;
  StrAssign(mode OF stack[stack_index], mode);
  mode_size OF stack[stack_index] := calc_mode_size(mode, FALSE); 
  addr_offset OF stack[stack_index] := 0;
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr
END;


PROC new_var = (STRING name, STRING mode) INT:
BEGIN
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_var;
  StrAssign(name OF stack[stack_index], name);
  nesting OF stack[stack_index] := current_nesting;
  StrAssign(mode OF stack[stack_index], mode);
  mode_size OF stack[stack_index] := calc_mode_size(mode, FALSE); 
  addr_offset OF stack[stack_index] := 0;
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr
END;


PROC new_tempvar = (STRING mode) INT:
BEGIN
  STRING tmp;
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_tempvar;
  id OF stack[stack_index] := get_next_temp;
  int2str(id OF stack[stack_index], tmp);
  StrAppend(name OF stack[stack_index], "%", tmp);
  nesting OF stack[stack_index] := current_nesting;
  StrAssign(mode OF stack[stack_index], mode);
  mode_size OF stack[stack_index] := calc_mode_size(mode, FALSE);
  addr_offset OF stack[stack_index] := 0;
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr
END;


PROC new_argvar = (STRING mode) INT:
BEGIN
  STRING tmp;
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_argvar;
  id OF stack[stack_index] := get_arg_temp;
  int2str(id OF stack[stack_index], tmp);
  StrAppend(name OF stack[stack_index], "&", tmp);
  nesting OF stack[stack_index] := current_nesting;
  StrAssign(mode OF stack[stack_index], mode);
  mode_size OF stack[stack_index] := calc_mode_size(mode, FALSE);
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr
END;


PROC new_param = (STRING name, STRING mode) INT:
BEGIN
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_param;
  StrAssign(name OF stack[stack_index], name);
  nesting OF stack[stack_index] := current_nesting;
  StrAssign(mode OF stack[stack_index], mode);
  mode_size OF stack[stack_index] := calc_mode_size(mode, FALSE);
  addr_offset OF stack[stack_index] := 0;
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr 
END;


PROC new_const = (STRING name, STRING mode) INT:
BEGIN
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_constant;
  StrAssign(name OF stack[stack_index], name);
  StrAssign(value OF stack[stack_index], name);
  nesting OF stack[stack_index] := current_nesting;
  StrAssign(mode OF stack[stack_index], mode);
  mode_size OF stack[stack_index] := calc_mode_size(mode, FALSE);
  addr_offset OF stack[stack_index] := 0;
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr
END;


PROC new_charconst = (STRING name) INT:
BEGIN
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_constant;
  (name OF stack[stack_index])[0] := '\'';
  (name OF stack[stack_index])[1] := name[0];
  (name OF stack[stack_index])[2] := '\'';
  StrAssign(value OF stack[stack_index], name);
  nesting OF stack[stack_index] := -1;
  StrAssign(mode OF stack[stack_index], "CHAR");
  mode_size OF stack[stack_index] := 0;
  addr_offset OF stack[stack_index] := 0;
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr
END;


PROC new_strconst = (STRING name) INT:
BEGIN
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_constant;
  StrAssign(name OF stack[stack_index], name);
  StrAssign(value OF stack[stack_index], name);
  nesting OF stack[stack_index] := -1;
  StrAssign(mode OF stack[stack_index], "STRING");
  mode_size OF stack[stack_index] := string_size;
  addr_offset OF stack[stack_index] := record_string(name);
  reg OF stack[stack_index] := -1;
  inc_stack_index;
  ptr
END;


PROC new_label = INT:
BEGIN
  STRING lbl;
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_label;
  id OF stack[stack_index] := get_next_label;				# CAUTION: Do we need this?
  int2str(id OF stack[stack_index], lbl);
  StrAppend(name OF stack[stack_index], "L", lbl);
  nesting OF stack[stack_index] := current_nesting;
  inc_stack_index;
  ptr
END;


PROC new_fixedlabel = (STRING label) INT:
BEGIN
  STRING lbl;
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_label;
  StrAssign(name OF stack[stack_index], label);
  nesting OF stack[stack_index] := current_nesting;
  inc_stack_index;
  ptr
END;


PROC new_proc = (STRING name) INT:
BEGIN
  INT ptr := stack_index;
  type OF stack[stack_index] := entity_proc;
  StrAssign(name OF stack[stack_index], name);
  StrAssign(mode OF stack[stack_index], "");
  nesting OF stack[stack_index] := current_nesting + 1;
  proc_info_index := proc_info_index + 1;
  IF proc_info_index >= proc_info_bound THEN error("Procedure entries maximum exceeded!"); FI;
  current_proc := proc_info_index;
  proc_info OF stack[stack_index] := proc_info_index;
  quadptr OF table_proc_info[proc_info_index] := quad_index;
  done OF table_proc_info[proc_info_index] := FALSE;
  reset_temps;
  inc_stack_index;
  ptr
END;


PROC set_proc_properties = (INT ptr, INT label, STRING mode, INT mode_size) VOID:
BEGIN
  INT proc_info := proc_info OF stack[ptr];
  current_proc := proc_info;
  StrAssign(label OF table_proc_info[proc_info], name OF stack[label]);
  StrAssign(mode OF stack[ptr], mode);
  mode_size OF stack[ptr] := mode_size;
END;


PROC runtime_proc = (STRING name, STRING label, STRING mode, INT mode_size) VOID:
BEGIN
  type OF stack[stack_index] := entity_proc;
  StrAssign(name OF stack[stack_index], name);
  nesting OF stack[stack_index] := current_nesting + 1;
  proc_info_index := proc_info_index + 1;
  IF proc_info_index >= proc_info_bound THEN error("Procedure entries maximum exceeded!"); FI;
  current_proc := proc_info_index;
  proc_info OF stack[stack_index] := proc_info_index;
  quadptr OF table_proc_info[proc_info_index] := 0;
  done OF table_proc_info[proc_info_index] := TRUE;
  reset_temps;
  StrAssign(label OF table_proc_info[proc_info_index], label);
  StrAssign(mode OF stack[stack_index], mode);
  mode_size OF stack[stack_index] := mode_size;
  inc_stack_index;
END;


PROC open_scope = VOID:
BEGIN
  type OF stack[stack_index] := entity_startscope;
  StrAssign(name OF stack[stack_index], "");
  inc_stack_index;
END;


PROC close_scope = VOID:
BEGIN
  type OF stack[stack_index] := entity_endscope;
  StrAssign(name OF stack[stack_index], "");
  inc_stack_index;
END;


PROC open_frame = VOID:
BEGIN
  IF current_nesting > 0 THEN process_frame; FI;
  type OF stack[stack_index] := entity_frame;
  StrAssign(name OF stack[stack_index], "");
  current_nesting := current_nesting + 1;
  IF current_nesting > max_nesting THEN error("Maximum procedure nesting level exceeded!") FI;
  nesting OF stack[stack_index] := current_nesting;
  scopeptr OF stack[stack_index] := current_scope_start;
  current_scope_start := stack_index;
  inc_stack_index;
END;


PROC close_frame = VOID:
BEGIN
  printf("Generating code...\n");
  generate_code;
  stack_index := current_scope_start;
  current_scope_start := scopeptr OF stack[stack_index];
  done OF table_proc_info[current_proc] := TRUE;
  current_nesting := current_nesting - 1;
  set_next_proc;
END;


PROC init_stack = VOID:
BEGIN
  type OF stack[0] := entity_empty;
  StrAssign(name OF stack[0], "EMPTY");
  id OF stack[0] := -1;
  proc_info OF stack[0] := -1;
  scopeptr OF stack[0] := -1;
  StrAssign(mode OF stack[0], "EMPTY");
  storage_type OF stack[0] := -1;
  addr_offset OF stack[0] := -1;
  reg OF stack[0] := -1;
END;


PROC lookup = (STRING name) INT:
BEGIN
  INT enclosed;
  INT index := stack_index - 1;
  WHILE index >= 1 AND NOT StrEqual(name OF stack[index], name)
  DO
    IF type OF stack[index] = entity_endscope THEN
      enclosed := 1;
      WHILE enclosed > 0 
      DO
        index := index - 1;
        IF type OF stack[index] = entity_endscope THEN enclosed := enclosed + 1;
        ELIF type OF stack[index] = entity_startscope THEN enclosed := enclosed - 1;
        FI;
      OD;
    FI;
    index := index - 1;
  OD;
  index
END;


PROC flookup = (STRING name) INT:
BEGIN
  INT index := lookup(name);
  IF index = 0 THEN printf("Symbol %s undeclared!\n", name); error(""); FI;
  index
END;


#MODULE 'a-code' generate intermediate and final mmix assembly code


MODE QUAD = STRUCT(INT type, INT result, INT left, INT right);

INT max_tetra = 65535;
INT max_byte = 255;

INT quad_bound = 10000;
INT register_bound = 200;

# INT quad_nop = 0;

INT quad_jump = 1;
INT quad_test = 2;
INT quad_label = 3;
INT quad_deref = 4;
INT quad_ret = 5;
INT quad_call = 6;
INT quad_arg = 7;
INT quad_proc = 8;
INT quad_endproc = 9;
INT quad_printn = 10;
INT quad_printc = 11;
INT quad_prints = 12;
INT quad_printi = 13;
INT quad_subscript = 14;
INT quad_of = 15;
INT quad_main = 16;
INT quad_alloc = 17;
INT quad_halt = 18;
INT quad_upb = 19;
INT quad_dump = 20;
INT quad_close = 21;
INT quad_open = 22;
INT quad_readc = 23;
INT quad_establish = 24;
INT quad_argref = 25;
INT quad_argsize = 26;
INT quad_addstr = 27;
INT quad_neg = 28;
INT quad_readchar = 29;
INT quad_alias = 30;


INT storage_constant = 0;
INT storage_regvalue = 1;
INT storage_regaddr = 2;
INT storage_memvalue = 3;
INT storage_memaddr = 4;


INT approx_code_lines := 0;


# ################################################################################################### #
# Structure STACKFRAME: information on the current stack frame							#
# ################################################################################################### #
# <param_size>	- parameter fixed frame size in bytes								#
# <localvar_size>	- local variable fixed frame size in bytes							#
# <retaddr_reg>	- register holding the return address								#
# <display_reg>	- register holding the appropriate global display address					#
# <frameptr_reg>	- register holding the old frame pointer								#
# ################################################################################################### #
MODE STACKFRAME = STRUCT(INT param_size, INT localvar_size, INT retaddr_reg, INT display_reg, INT frameptr_reg);


[quad_bound]QUAD quads;
STACKFRAME stack_frame;


INT temp_regs, param_regs, var_regs, ret_regs;

PROC init_regs = VOID:
BEGIN
  temp_regs := max_temp OF table_proc_info[current_proc] + 1;
  param_regs := 0;
  var_regs := 0;
  ret_regs := 0;
END;

PROC get_param_reg = INT:
BEGIN
  param_regs := param_regs + 1;
  param_regs - 1
END;

PROC get_var_reg = INT:
BEGIN
  var_regs := var_regs + 1;
  param_regs + temp_regs + var_regs - 1
END;

PROC get_temp_reg = (INT offset) INT:
BEGIN
  param_regs + offset
END;

PROC get_last_reg = INT:
BEGIN
  param_regs + temp_regs + var_regs + ret_regs
END;

PROC get_arg_reg = INT:
BEGIN
  arg_count := arg_count + 1;
  get_last_reg + arg_count
END;




# ################################################################################################### #
# HANDLE QUADRUPLES														#
# ################################################################################################### #

PROC generate_quad = (INT type, INT result, INT left, INT right) VOID:
BEGIN
  IF quad_index > 0 AND type OF quads[quad_index-1] = quad_label AND type = quad_label THEN
    unify_labels(result, result OF quads[quad_index-1]);
  ELSE
    type OF quads[quad_index] := type; 
    result OF quads[quad_index] := result;
    left OF quads[quad_index] := left;
    right OF quads[quad_index] := right;
    quad_index := quad_index + 1;
    IF quad_index >= quad_bound THEN printf("Panic: Max quad array limit exceeded!\n"); exit; FI;
  FI;
END;


PROC print_quad = (INT index) VOID:
BEGIN
  INT resptr, lptr, rptr;
  INT proc_info;
  STRING tmp;

  resptr := result OF quads[index];
  lptr := left OF quads[index];
  rptr := right OF quads[index];
  IF type OF quads[index] = tk_ASSIGN THEN 
    fprintf("ASSIGN %s := %s\n", name OF stack[resptr], name OF stack[rptr]);
  ELIF type OF quads[index] = quad_deref THEN 
    fprintf("DEREF %s -> %s\n", name OF stack[lptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_alias THEN 
    fprintf("ALIAS %s -> %s\n", name OF stack[lptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_main THEN 
    fprintf("MAIN\n");
  ELIF type OF quads[index] = quad_halt THEN 
    fprintf("HALT\n");
  ELIF type OF quads[index] = quad_dump THEN 
    fprintf("DUMPFRAME\n");
  ELIF type OF quads[index] = ABS '=' THEN 
    fprintf("EQUAL %s = %s -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = ABS '>' THEN 
    fprintf("GREATER %s > %s -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = ABS '<' THEN 
    fprintf("LESS %s < %s -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = tk_GEQ THEN 
    fprintf("GEQ %s >= %s -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = tk_LEQ THEN 
    fprintf("LEQ %s <= %s -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = tk_NEQ THEN 
    fprintf("NEQ %s /= %s -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = tk_NOT THEN 
    fprintf("NOT %s -> %s\n", name OF stack[lptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_neg THEN 
    fprintf("NEG -%s -> %s\n", name OF stack[lptr], name OF stack[resptr]);
  ELIF type OF quads[index] = ABS '+' THEN 
    fprintf("PLUS %s := %s + %s\n", name OF stack[resptr], name OF stack[lptr], name OF stack[rptr]);
  ELIF type OF quads[index] = ABS '-' THEN 
    fprintf("MINUS %s := %s - %s\n", name OF stack[resptr], name OF stack[lptr], name OF stack[rptr]);
  ELIF type OF quads[index] = ABS '*' THEN 
    fprintf("MULT %s := %s * %s\n", name OF stack[resptr], name OF stack[lptr], name OF stack[rptr]);
  ELIF type OF quads[index] = ABS '/' THEN 
    fprintf("DIV %s := %s / %s\n", name OF stack[resptr], name OF stack[lptr], name OF stack[rptr]);
  ELIF type OF quads[index] = tk_MOD THEN 
    fprintf("MOD %s := %s MOD %s\n", name OF stack[resptr], name OF stack[lptr], name OF stack[rptr]);
  ELIF type OF quads[index] = tk_OR THEN 
    fprintf("OR %s := %s || %s\n", name OF stack[resptr], name OF stack[lptr], name OF stack[rptr]);
  ELIF type OF quads[index] = tk_AND THEN 
    fprintf("AND %s := %s && %s\n", name OF stack[resptr], name OF stack[lptr], name OF stack[rptr]);
  ELIF type OF quads[index] = quad_subscript THEN 
    fprintf("SUBSCRIPT %s[%s] -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_of THEN 
    fprintf("OF %s OF %s -> %s\n", name OF stack[resptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_upb THEN 
    fprintf("UPB %s -> %s\n", name OF stack[lptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_jump THEN 
    fprintf("JUMP %s\n", name OF stack[resptr]);
  ELIF type OF quads[index] = quad_test THEN 
    fprintf("TEST %s -> %s\n", name OF stack[lptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_label THEN 
    fprintf("%s: ", name OF stack[resptr]); print_quad(index + 1);
  ELIF type OF quads[index] = quad_printn THEN 
    fprintf("PRINTn\n");
  ELIF type OF quads[index] = quad_printc THEN 
    fprintf("PRINTc %s\n", name OF stack[resptr]);
  ELIF type OF quads[index] = quad_prints THEN 
    fprintf("PRINTs %s\n", name OF stack[resptr]);
  ELIF type OF quads[index] = quad_printi THEN 
    fprintf("PRINTi %s\n", name OF stack[resptr]);
  ELIF type OF quads[index] = quad_open THEN 
    fprintf("OPEN %s, %s -> %s\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_close THEN 
    fprintf("CLOSE %s\n", name OF stack[lptr]);
  ELIF type OF quads[index] = quad_readc THEN 
    fprintf("READC %s -> %s\n", name OF stack[lptr], name OF stack[resptr]);
  ELIF type OF quads[index] = quad_readchar THEN 
    fprintf("READCHAR -> %s\n", name OF stack[resptr]);
  ELIF type OF quads[index] = quad_alloc THEN 
    fprintf("ALLOC %s of mode %s, %i items\n", name OF stack[resptr], mode OF stack[resptr], mode_size OF stack[resptr]);
  ELIF type OF quads[index] = quad_ret THEN 
    fprintf("RET value %s\n", name OF stack[resptr]);
  ELIF type OF quads[index] = quad_arg THEN 
    fprintf("ARG %s of mode %s -> %s\n", name OF stack[lptr], mode OF stack[lptr], mode OF stack[resptr]);
  ELIF type OF quads[index] = quad_argref THEN 
    fprintf("ARGREF %s of mode %s and offset %i\n", name OF stack[lptr], mode OF stack[lptr], resptr - 8);
  ELIF type OF quads[index] = quad_argsize THEN 
    fprintf("ARGSIZE size is %i\n", resptr + 8);
  ELIF type OF quads[index] = quad_call THEN 
    get_proc_mode(lptr, tmp);
    fprintf("CALL procedure %s of mode %s -> %s\n", name OF stack[lptr], tmp, name OF stack[resptr]);
  ELIF type OF quads[index] = quad_proc THEN 
    proc_info := proc_info OF stack[resptr];
    get_proc_mode(resptr, tmp);
    fprintf("PROC %s of mode %s with label %s\n", name OF stack[resptr], tmp, label OF table_proc_info[proc_info]);
  ELIF type OF quads[index] = quad_endproc THEN 
    fprintf("ENDPROC %s\n", name OF stack[resptr]);
  ELSE
    fprintf("UNKNOWN\n", index);
  FI;
END;


PROC process_frame = VOID:
BEGIN
  INT reg;
  INT index;
  INT param_offset := 0, localvar_offset := 0;

  init_regs;

  index := stack_index - 1;
  WHILE type OF stack[index] /= entity_frame DO index := index - 1; OD;

# reserve three registers to hold return address, old frame pointer and global display
  IF index > 1 THEN ret_regs := 3; FI; 

  WHILE index < stack_index 
  DO
# ---------------------------------------------------------------------------------------------	#
# 							CONSTANTS								#
# ---------------------------------------------------------------------------------------------	#
    IF type OF stack[index] = entity_constant THEN 
      storage_type OF stack[index] := storage_constant;
      reg OF stack[index] := -1;					# do not remove this!

# ---------------------------------------------------------------------------------------------	#
# 							PARAMETERS								#
# ---------------------------------------------------------------------------------------------	#
    ELIF type OF stack[index] = entity_param AND NOT is_mode_void(index) THEN
# CAUTION: move everything to stack!
      IF is_mode_ref(index) THEN 								# ALL REFs are handled here!
        storage_type OF stack[index] := storage_regaddr;
        reg OF stack[index] := get_param_reg;
      ELIF is_mode_composite(index) THEN 							# composite non-REFs 
        storage_type OF stack[index] := storage_regaddr;
        reg OF stack[index] := get_param_reg;
      ELSE												# primitive non-REFs 
        storage_type OF stack[index] := storage_regvalue;
        reg OF stack[index] := get_param_reg;
      FI;

# ---------------------------------------------------------------------------------------------	#
# 							VARIABLES								#
# ---------------------------------------------------------------------------------------------	#
    ELIF type OF stack[index] = entity_var AND NOT is_mode_void(index) THEN 
      storage_type OF stack[index] := storage_memvalue;
      addr_offset OF stack[index] := localvar_offset;
# TRICK: for arrays, the first 8 bytes belong to the header, so make offset point to data!
      IF is_mode_array(index) THEN 
        addr_offset OF stack[index] := addr_offset OF stack[index] + 8;
      FI;
      localvar_offset := localvar_offset + mode_size OF stack[index];

#      ELSE
#        storage_type OF stack[index] := storage_regvalue;
#        reg OF stack[index] := get_var_reg;
#      FI;

# ---------------------------------------------------------------------------------------------	#
# 							ARGUMENTS								#
# ---------------------------------------------------------------------------------------------	#
    ELIF type OF stack[index] = entity_argvar AND NOT is_mode_void(index) THEN 
      IF is_mode_composite(index) AND NOT is_mode_ref(index) THEN 
        IF is_mode_array(index) THEN						# variable size non-REF composites
          storage_type OF stack[index] := storage_regaddr;
          reg OF stack[index] := -1;
        ELSE										# fixed size non-REF composites
          storage_type OF stack[index] := storage_memvalue;
          addr_offset OF stack[index] := localvar_offset;
          # TRICK: for arrays, the first 8 bytes belong to the header, so make offset point to data!
          IF is_mode_array(index) THEN 
            addr_offset OF stack[index] := addr_offset OF stack[index] + 8;
          FI;
          localvar_offset := localvar_offset + mode_size OF stack[index];
        FI;
      ELSE
        storage_type OF stack[index] := storage_regvalue;
        reg OF stack[index] := -1;
      FI;

# ---------------------------------------------------------------------------------------------	#
# 							TEMPORARIES								#
# ---------------------------------------------------------------------------------------------	#
    ELIF type OF stack[index] = entity_tempvar AND NOT is_mode_void(index) THEN 
      IF is_mode_composite(index) THEN 
        reg OF stack[index] := get_temp_reg(id OF stack[index]);			# CAUTION: not always needed!
        storage_type OF stack[index] := storage_memvalue;
        addr_offset OF stack[index] := localvar_offset;
# TRICK: for arrays, the first 8 bytes belong to the header, so make offset point to data!
        IF is_mode_array(index) THEN 
          addr_offset OF stack[index] := addr_offset OF stack[index] + 8;
        FI;
        localvar_offset := localvar_offset + mode_size OF stack[index];
      ELSE
        storage_type OF stack[index] := storage_regvalue;
        reg OF stack[index] := get_temp_reg(id OF stack[index]);
      FI;

# ---------------------------------------------------------------------------------------------	#
# 							POINTERS?								#
# ---------------------------------------------------------------------------------------------	#
    ELIF type OF stack[index] = entity_ptrvar AND NOT is_mode_void(index) THEN 
      storage_type OF stack[index] := storage_regaddr;
#      addr_offset OF stack[index] := addr_offset OF stack[index];
# TRICK: for arrays, the first 8 bytes belong to the header, so make offset point to data!
      IF is_mode_array(index) THEN 
        addr_offset OF stack[index] := addr_offset OF stack[index] + 8;
      FI;
      reg OF stack[index] := get_temp_reg(id OF stack[index]);
    FI;

    index := index + 1;
  OD;

  IF ret_regs /= 0 THEN 
    retaddr_reg OF stack_frame := get_var_reg; 
    display_reg OF stack_frame := get_var_reg;
    frameptr_reg OF stack_frame := get_var_reg;
  FI; 

  param_size OF stack_frame := param_offset; 
  localvar_size OF stack_frame := localvar_offset;
  printf("Stack frame produced\n"); 
  IF debug_stop THEN debugger; FI;
END;


# ################################################################################################### #
# get_bp																#
# ################################################################################################### #
PROC get_bp = (INT ptr, REF STRING bp) VOID:
BEGIN
  IF current_nesting = nesting OF stack[ptr] THEN 
    StrAssign(bp, "fp");
  ELSE 
    int2str(nesting OF stack[ptr], bp);
    StrAppend(bp, "disp", bp);
  FI;
END;


# ################################################################################################### #
# mmix_set																#
# ################################################################################################### #
# x - register number														#
# val - integer															#
# ################################################################################################### #
PROC mmix_set = (INT x, INT val) VOID:
BEGIN
  IF val < 0 THEN 
    mmix_set(x, -val);
    fprintf("\tNEGU $%i,0,$%i\n", x, x);
  ELSE
    IF val > max_tetra THEN
      fprintf("\tSETL $%i,%i&#ffff\n", x, val);
      fprintf("\tORML $%i,%i>>16\n", x, val);
    ELSE
      fprintf("\tSETL $%i,%i\n", x, val);
    FI;
  FI;
END;


# ################################################################################################### #
# mmix_sets																#
# ################################################################################################### #
# x - register string														#
# val - integer															#
# ################################################################################################### #
PROC mmix_sets = (STRING x, INT val) VOID:
BEGIN
  IF val < 0 THEN 
    mmix_sets(x, -val);
    fprintf("\tNEGU %s,0,%s\n", x, x);
  ELSE
    IF val > max_tetra THEN
      fprintf("\tSETL %s,%i&#ffff\n", x, val);
      fprintf("\tORML %s,%i>>16\n", x, val);
    ELSE
      fprintf("\tSETL %s,%i\n", x, val);
    FI;
  FI;
END;


# ################################################################################################### #
# mmix_add																#
# ################################################################################################### #
# x - register number														#
# y - register number														#
# z - integer															#
# ################################################################################################### #
PROC mmix_add = (INT x, INT y, INT zz) VOID:
BEGIN
  INT z := zz;
  STRING opcode;

  IF z = 0 THEN 
    IF x /= y THEN fprintf("\tSET $%i,$%i\n", x, y); FI;
  ELSE
    IF z > 0 THEN StrAssign(opcode, "ADDU") ELSE z := -z; StrAssign(opcode, "SUBU"); FI;
    IF z > max_byte THEN mmix_sets("temp1", z); fprintf("\t%s $%i,$%i,temp1\n", opcode, x, y);
    ELSE fprintf("\t%s $%i,$%i,%i\n", opcode, x, y, z); 
    FI;
  FI;
END;


# ################################################################################################### #
# mmix_addssi															#
# ################################################################################################### #
# x - register string														#
# y - register string														#
# z - integer															#
# ################################################################################################### #
PROC mmix_addssi = (STRING x, STRING y, INT zz) VOID:
BEGIN
  INT z := zz;
  STRING opcode;

  IF z = 0 THEN 
    IF NOT StrEqual(x, y) THEN fprintf("\tSET %s,%s\n", x, y); FI;
  ELSE
    IF z > 0 THEN StrAssign(opcode, "ADDU") ELSE z := -z; StrAssign(opcode, "SUBU"); FI;
    IF z > max_byte THEN mmix_sets("$255", z); fprintf("\t%s %s,%s,$255\n", opcode, x, y);
    ELSE fprintf("\t%s %s,%s,%i\n", opcode, x, y, z); 
    FI;
  FI;
END;


# ################################################################################################### #
# mmix_strappend - string concatenation (CAUTION: not updated!)							#
# ################################################################################################### #
# 																	#
# 																	#
# 																	#
# ################################################################################################### #
PROC mmix_strappend = (INT target_symbol, INT left_symbol, INT right_symbol) VOID:
BEGIN
  STRING source, target, val;

  StrAssign(source, "temp1");
  StrAssign(target, "temp2");
  StrAssign(val, "temp3");

# Copy left string operand
  mmix_sets(source, addr_offset OF stack[left_symbol]);
  mmix_sets(target, addr_offset OF stack[target_symbol]);
  fprintf("1H\tLDB %s,fp,%s\n", val, source);
  fprintf("\tSTB %s,fp,%s\n", val, target);
  fprintf("\tADD %s,%s,1\n", source, source);
  fprintf("\tADD %s,%s,1\n", target, target);
  fprintf("\tPBNZ %s,1B\n", val);

# Copy right string operand
  mmix_sets(source, addr_offset OF stack[right_symbol]);
  fprintf("\tSUBU %s,%s,1\n", target, target);
  fprintf("1H\tLDB %s,fp,%s\n", val, source);
  fprintf("\tSTB %s,fp,%s\n", val, target);
  fprintf("\tADD %s,%s,1\n", source, source);
  fprintf("\tADD %s,%s,1\n", target, target);
  fprintf("\tPBNZ %s,1B\n", val);

# write the ending zero to target
  fprintf("\tSTB %s,fp,%s\n", val, target);

END;


# ################################################################################################### #
# mmix_fix8c - handles load/store instructions when the Z value is an integer					#
# ################################################################################################### #
# <opcode> 	- the mmix instruction opcode											#
# <c>		- the storage size ('B', 'W', 'T', or 'O')								#
# <x>		- the X register													#
# <y>		- the Y register													#
# <z>		- the Z value													#
# ################################################################################################### #
# CAUTION: temp10 to be used exclusively by mmix_fix8c!								#
# ################################################################################################### #
PROC mmix_fix8c = (STRING opcode, CHAR c, STRING x, STRING y, INT z) VOID:
BEGIN
  IF z > max_byte THEN 
    mmix_sets("temp10", z); 
    fprintf("\t%s%c %s,%s,temp10\n", opcode, c, x, y);
  ELSE
    fprintf("\t%s%c %s,%s,%i\n", opcode, c, x, y, z);
  FI;
END;


# ################################################################################################### #
# mmix_loadaddr - loads <source>'s absolute address into a register						#
# ################################################################################################### #
# <outreg> 	- returned register where the address will be stored							#
# <inreg>	- register to use, if no register is designated for <source>					#
# <source>	- symbol whose address is needed										#
# ################################################################################################### #
PROC mmix_loadaddr = (REF STRING outreg, STRING inreg, INT source) VOID:
BEGIN
  STRING bp;

  StrAssign(outreg, inreg);

  IF storage_type OF stack[source] = storage_constant THEN
    fprintf("\tGETA %s,STRINGS\n", outreg);
    mmix_addssi(outreg, outreg, addr_offset OF stack[source]);

  ELIF storage_type OF stack[source] = storage_memvalue THEN
    get_bp(source, bp);
    mmix_addssi(outreg, bp, addr_offset OF stack[source]);

  ELIF storage_type OF stack[source] = storage_regaddr THEN
#    int2str(reg OF stack[source], outreg);
#    StrAppend(outreg, "$", outreg);
     fprintf("\tSET %s,$%i\n", outreg, reg OF stack[source]);

  ELSE
    error("mmix_loadaddr: storage type should be <stackframe> or <regaddr>!");
  FI;
END;


# ################################################################################################### #
# mmix_strcmp - compare two strings												#
# ################################################################################################### #
# <opcode>	- appropriate opcode for '=', '/=', '>', '<', '<=', '=>' operations				#
# <result>	- symbol where the result is stored										#
# <lsymbol> - "left" symbol to be compared										#
# <rsymbol> - "right" symbol to be compared										#
# ################################################################################################### #
PROC mmix_strcmp = (STRING opcode, INT result, INT lsymbol, INT rsymbol) VOID:
BEGIN
  STRING lreg, rreg, val1, val2, ireg;

  StrAssign(val1, "temp3");
  StrAssign(val2, "temp4");
  StrAssign(ireg, "temp5");
  fprintf("\tSETL %s,0\n", ireg);
  mmix_loadaddr(lreg, "temp1", lsymbol); 
  mmix_loadaddr(rreg, "temp2", rsymbol); 
  fprintf("1H\tLDBU %s,%s,%s\n", val1, lreg, ireg);
  fprintf("\tLDBU %s,%s,%s\n", val2, rreg, ireg);
  fprintf("\tCMP %s,%s,%s\n", val2, val1, val2);
  fprintf("\tBNZ %s,2F\n", val2);
  fprintf("\tBZ %s,2F\n", val1);
  fprintf("\tADD %s,%s,1\n", ireg, ireg);
  fprintf("\tJMP 1B\n");
  fprintf("2H\t%s $%i,%s,1\n", opcode, reg OF stack[result], val2);
END;


# ################################################################################################### #
# mmix_retcopy -															#
# ################################################################################################### #
# 																	#
# 																	#
# 																	#
# ################################################################################################### #
PROC mmix_retcopy = (INT target_symbol, INT retreg) VOID:
BEGIN
  STRING target, val, n;
  CHAR code := get_storage_code(target_symbol);

# CAUTION: only return STRING implemented
  StrAssign(target, "temp1");
  StrAssign(val, "temp2");
  StrAssign(n, "temp3");
  mmix_sets(n, mode_size OF stack[target_symbol]);
  mmix_loadaddr(target, "temp4", target_symbol); 
  fprintf("1H\tLD%c %s,$%i,0\n", code, val, retreg);
  fprintf("\tST%c %s,%s,0\n", code, val, target);
  fprintf("\tADD $%i,$%i,1\n", retreg, retreg);
  fprintf("\tADD %s,%s,1\n", target, target);
  fprintf("\tSUB %s,%s,1\n", n, n);
  fprintf("\tPBNZ %s,1B\n", n);
END;


# ################################################################################################### #
# mmix_memcopy - copy composite objects											#
# ################################################################################################### #
# <source_symbol> - source symbol to copy from										#
# <target_symbol> - target symbol to copy to										#
# ################################################################################################### #
PROC mmix_memcopy = (INT source_symbol, INT target_symbol) VOID:
BEGIN
  STRING sreg, treg, ireg, val, size;
  INT i, n;
  STRING s;
  CHAR code := get_storage_code(source_symbol);

  IF source_symbol /= target_symbol THEN
    StrAssign(val, "temp3");
    StrAssign(size, "temp4");
    StrAssign(ireg, "temp5");
    fprintf("\tSETL %s,%i\n", size, mode_size OF stack[source_symbol]);
    IF is_mode_array(source_symbol) THEN
      fprintf("\tNEGU %s,0,8\n", ireg);
    ELSE
      fprintf("\tSETL %s,0\n", ireg);
    FI;
    mmix_loadaddr(sreg, "temp1", source_symbol); 
    mmix_loadaddr(treg, "temp2", target_symbol); 
    fprintf("1H\tLDOU %s,%s,%s\n", val, sreg, ireg);
    fprintf("\tSTOU %s,%s,%s\n", val, treg, ireg);
    fprintf("\tBZ %s,2F\n", val);								# zero-octet heuristic
    fprintf("\tADD %s,%s,8\n", ireg, ireg);
    fprintf("\tSUB %s,%s,8\n", size, size);
    fprintf("\tPBNZ %s,1B\n", size);
    fprintf("2H\tSET $255,$255\n");								# dummy instruction
  FI;
END;


# ################################################################################################### #
# mmix_loadref - loads <source>'s value into its designated register						#
# ################################################################################################### #
# <source>	- symbol stored as <regaddr>											#
# ################################################################################################### #
PROC mmix_loadref = (STRING reg, INT source) VOID:
BEGIN
  IF storage_type OF stack[source] /= storage_regaddr THEN 
    error("mmix_loadref: source must be stored as <regaddr>!");
  FI;
  fprintf("\tLD%c %s,$%i,0\n", get_storage_code(source), reg, reg OF stack[source]);
  storage_type OF stack[source] := storage_regvalue;
END;


# ################################################################################################### #
# mmix_loadsource - loads <source>'s value into a register								#
# ################################################################################################### #
# <outreg> 	- returned register where the value will be stored							#
# <inreg>	- register to use, if no register is designated for <source>					#
# <source>	- symbol whose value is needed										#
# ################################################################################################### #
PROC mmix_loadsource = (REF STRING outreg, STRING inreg, INT source) VOID:
BEGIN
  STRING bp;

  StrAssign(outreg, inreg);

  IF storage_type OF stack[source] = storage_regvalue THEN
#    int2str(reg OF stack[source], outreg);
#    StrAppend(outreg, "$", outreg);
     fprintf("\tSET %s,$%i\n", outreg, reg OF stack[source]);

  ELIF storage_type OF stack[source] = storage_constant THEN
    IF StrEqual(mode OF stack[source], "CHAR") THEN
      fprintf("\tSETL %s,%i\n", outreg, ABS (value OF stack[source])[0]);
    ELIF StrEqual(mode OF stack[source], "BOOL") THEN
      IF StrEqual(value OF stack[source], "FALSE") THEN
        fprintf("\tSETL %s,0\n", outreg);
      ELSE
        fprintf("\tSETL %s,1\n", outreg);
      FI;
    ELSE
      mmix_sets(outreg, str2int(value OF stack[source]));
    FI;

  ELIF storage_type OF stack[source] = storage_memvalue THEN
    get_bp(source, bp);
    mmix_fix8c("LD", get_storage_code(source), outreg, bp, addr_offset OF stack[source]);

  ELIF storage_type OF stack[source] = storage_regaddr THEN
#    int2str(reg OF stack[source], outreg);
#    StrAppend(outreg, "$", outreg);
    mmix_loadref(outreg, source);

  ELSE
    error("mmix_loadsource: unexpected storage type!");
  FI;
END;


# ################################################################################################### #
# mmix_alias - implements identity "assignments"									#
# ################################################################################################### #
# <target>	- target symbol 													#
# <source>	- source symbol													#
# ################################################################################################### #
PROC mmix_alias = (INT target, INT source) VOID:
BEGIN
  STRING reg;
  IF NOT is_mode_void(target) AND NOT is_mode_void(source) THEN
    IF storage_type OF stack[source] = storage_regaddr THEN 
      fprintf("\tSET $%i,$%i\n", reg OF stack[target], reg OF stack[source]);
      storage_type OF stack[target] := storage_regaddr;

    ELIF storage_type OF stack[source] = storage_regvalue THEN 
      fprintf("\tSET $%i,$%i\n", reg OF stack[target], reg OF stack[source]);
      storage_type OF stack[target] := storage_regvalue;

    ELIF storage_type OF stack[source] = storage_memvalue THEN
      mmix_loadaddr(reg, "temp1", source);
      fprintf("\tSET $%i,%s\n", reg OF stack[target], reg);
      storage_type OF stack[target] := storage_regaddr;

    ELIF storage_type OF stack[source] = storage_constant THEN
      mmix_loadsource(reg, "temp1", source);
      fprintf("\tSET $%i,%s\n", reg OF stack[target], reg);
      storage_type OF stack[target] := storage_regvalue;
    FI;
  FI;
END;


# ################################################################################################### #
# mmix_store - stores <source> to <target>										#
# ################################################################################################### #
# <target>	- target symbol 													#
# <source>	- source symbol													#
# ################################################################################################### #
PROC mmix_store = (INT target, INT source) VOID:
BEGIN
  STRING reg, bp;
  INT val;

  IF is_mode_composite(source) THEN mmix_memcopy(source, target);

  ELIF NOT is_mode_void(target) THEN
# CAUTION: ad hoc solution
    IF is_mode_ptr(target) THEN
      StrAssign(reg, "temp1");
      fprintf("\tSET %s,$%i\n", reg, reg OF stack[source]);
    ELSE
      mmix_loadsource(reg, "temp1", source);
    FI;

    IF storage_type OF stack[target] = storage_regaddr THEN 
      fprintf("\tST%c %s,$%i,0\n", get_storage_code(target), reg, reg OF stack[target]);

    ELIF storage_type OF stack[target] = storage_regvalue THEN 
      fprintf("\tSET $%i,%s\n", reg OF stack[target], reg);

    ELIF storage_type OF stack[target] = storage_memvalue THEN
      get_bp(target, bp);
      mmix_fix8c("ST", get_storage_code(target), reg, bp, addr_offset OF stack[target]);

    ELSE
      printf("source %s (%s), target %s (%s,%i)\n", name OF stack[source], mode OF stack[source], name OF stack[target], mode OF stack[target], storage_type OF stack[target]);
      error("Code generation 'mmix_store': invalid storage type!");
    FI;

  FI;
END;


# ################################################################################################### #
# mmix_deref - dereference <source> to <target>										#
# ################################################################################################### #
# <target>	- target symbol 													#
# <source>	- source symbol													#
# ################################################################################################### #
PROC mmix_deref = (INT target, INT source) VOID:
BEGIN
  STRING bp;

  IF mode_size OF stack[source] > 8 THEN
    IF storage_type OF stack[source] = storage_memvalue THEN 
      get_bp(source, bp);
      mmix_sets("temp1", addr_offset OF stack[source]); 
      fprintf("\tADDU $%i,%s,temp1\n", reg OF stack[target], bp);
    ELSE
      fprintf("\tSET $%i,$%i\n", reg OF stack[target], reg OF stack[source]);
    FI;
    storage_type OF stack[target] := storage_regaddr;

  ELIF storage_type OF stack[source] = storage_regvalue THEN
    fprintf("\tSET $%i,$%i\n", reg OF stack[target], reg OF stack[source]);

  ELIF storage_type OF stack[source] = storage_memvalue THEN
    get_bp(source, bp);
    mmix_sets("temp1", addr_offset OF stack[source]); 
    fprintf("\tLD%c $%i,%s,temp1\n", get_storage_code(source), reg OF stack[target], bp);
# CAUTION: Ad hoc solution
    IF is_mode_ptr(source) THEN storage_type OF stack[target] := storage_regaddr; FI;

  ELIF storage_type OF stack[source] = storage_regaddr THEN
    fprintf("\tLD%c $%i,$%i,0\n", get_storage_code(source), reg OF stack[target], reg OF stack[source]);

  ELSE
    error("mmix_deref: unexpected storage type!");
  FI;

END;


# ################################################################################################### #
# generate_code -															#
# ################################################################################################### #
# 																	#
# 																	#
# 																	#
# ################################################################################################### #
PROC generate_code = VOID:
BEGIN
  INT ptr, lptr, rptr;
  STRING opcode, lreg, rreg, resreg, bp;
  INT index, quadptr;
  INT reg;
  INT proc_info;
  INT val;
  INT n;

  quadptr := quadptr OF table_proc_info[current_proc];

  process_frame;							# determine address/register allocation 

  index := quadptr;
  WHILE index < quad_index 
  DO
    ptr  := result OF quads[index];
    lptr := left OF quads[index];
    rptr := right OF quads[index];

    IF code_comments THEN
      IF (index > quadptr AND type OF quads[index-1] /= quad_label) OR (index = quadptr) THEN
        fprintf("\n\t%% "); 
        print_quad(index);
        approx_code_lines := approx_code_lines + 10;
        IF approx_code_lines > 60000 THEN 
          fprintf("\n#\t1 \"foo.mms\"\n\n"); 
          approx_code_lines := 0;
        FI;
      FI;
    FI;

# ################################################################################################### #
# QUADS ADDSTR															#
# ################################################################################################### #
    IF type OF quads[index] = quad_addstr THEN mmix_strappend(ptr, lptr, rptr);


# ################################################################################################### #
# QUAD tk_MOD															#
# ################################################################################################### #
    ELIF type OF quads[index] = tk_MOD THEN 
      mmix_loadsource(lreg, "temp1", lptr);
      mmix_loadsource(rreg, "temp2", rptr);
      fprintf("\tDIV $%i,%s,%s\n", reg OF stack[ptr], lreg, rreg);
      fprintf("\tGET $%i,rR\n", reg OF stack[ptr]);


# ################################################################################################### #
# QUADS '+', '-', '*', '/', tk_OR, tk_AND										#
# ################################################################################################### #
    ELIF type OF quads[index] = ABS '+' OR type OF quads[index] = ABS '-' OR
       type OF quads[index] = ABS '/' OR type OF quads[index] = ABS '*' OR
       type OF quads[index] = tk_OR OR type OF quads[index] = tk_AND
    THEN 
      IF type OF quads[index] = ABS '+' THEN StrAssign(opcode, "ADD");
      ELIF type OF quads[index] = ABS '-' THEN StrAssign(opcode, "SUB");
      ELIF type OF quads[index] = ABS '*' THEN StrAssign(opcode, "MUL");
      ELIF type OF quads[index] = ABS '/' THEN StrAssign(opcode, "DIV");
      ELIF type OF quads[index] = tk_OR THEN StrAssign(opcode, "OR");
      ELIF type OF quads[index] = tk_AND THEN StrAssign(opcode, "AND");
      FI;
      mmix_loadsource(lreg, "temp1", lptr);
      mmix_loadsource(rreg, "temp2", rptr);
      fprintf("\t%s $%i,%s,%s\n", opcode, reg OF stack[ptr], lreg, rreg);


# ################################################################################################### #
# QUAD UPB																#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_upb THEN
      mmix_loadaddr(lreg, "temp1", lptr);
      fprintf("\tSUB $%i,%s,4\n", reg OF stack[ptr], lreg);
      fprintf("\tLDT $%i,$%i,0\n", reg OF stack[ptr], reg OF stack[ptr]);


# ################################################################################################### #
# QUAD SUBSCRIPT															#
# --------------------------------------------------------------------------------------------------- #
# 1. If source symbol <lptr> is a pure array (not a string), load the base address from its header	#
# 2. Add the appropriate offset: <rptr> * (<ptr> size)								#
# 3. Mark <storage_type> as pointer, to indicate that <ptr> contains a pointer to the variable		#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_subscript THEN
      mmix_loadsource(rreg, "temp1", rptr);
      mmix_loadaddr(lreg, "temp2", lptr);
      n := calc_mode_size(mode OF stack[ptr], TRUE);
      IF n = 1 THEN
        fprintf("\tADDU $%i,%s,%s\n", reg OF stack[ptr], lreg, rreg);
      ELIF n = 2 OR n = 4 OR n = 8 OR n = 16 THEN
        fprintf("\t%iADDU $%i,%s,%s\n", n, reg OF stack[ptr], rreg, lreg);
      ELSE
        mmix_sets("temp3", n);
        fprintf("\tMULU $%i,%s,temp3\n", reg OF stack[ptr], rreg);
        fprintf("\tADDU $%i,%s,$%i\n", reg OF stack[ptr], lreg, reg OF stack[ptr]);
      FI;
      storage_type OF stack[ptr] := storage_regaddr;


# ################################################################################################### #
# QUAD OF																#
# --------------------------------------------------------------------------------------------------- #
# Add the structure's offset to the field's offset									#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_of THEN
      mmix_loadaddr(rreg, "temp1", rptr);
      int2str(reg OF stack[ptr], resreg);
      StrAppend(resreg, "$", resreg);
      mmix_addssi(resreg, rreg, addr_offset OF stack[ptr]);
      storage_type OF stack[ptr] := storage_regaddr;


# ################################################################################################### #
# QUAD ASSIGN: code to assign symbol <rptr> to symbol <ptr>								#
# ################################################################################################### #
    ELIF type OF quads[index] = tk_ASSIGN THEN mmix_store(ptr, rptr);


# ################################################################################################### #
# QUAD DEREF: dereference symbol <lptr> to symbol <ptr>								#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_deref THEN mmix_deref(ptr, lptr);


# ################################################################################################### #
# QUAD ALIAS: code for aliasing symbol <lptr> to symbol <ptr>							#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_alias THEN mmix_alias(ptr, lptr);


# ################################################################################################### #
# QUADS '>', '<', '=', tk_GEQ, tk_LEQ, tk_NEQ										#
# ################################################################################################### #
    ELIF type OF quads[index] = ABS '>' OR type OF quads[index] = tk_GEQ OR
         type OF quads[index] = ABS '<' OR type OF quads[index] = tk_LEQ OR
         type OF quads[index] = ABS '=' OR type OF quads[index] = tk_NEQ
    THEN 
      IF type OF quads[index] = ABS '>' THEN StrAssign(opcode, "ZSP");
      ELIF type OF quads[index] = ABS '<' THEN StrAssign(opcode, "ZSN");
      ELIF type OF quads[index] = ABS '=' THEN StrAssign(opcode, "ZSZ");
      ELIF type OF quads[index] = tk_GEQ THEN StrAssign(opcode, "ZSNN");
      ELIF type OF quads[index] = tk_LEQ THEN StrAssign(opcode, "ZSNP");
      ELIF type OF quads[index] = tk_NEQ THEN StrAssign(opcode, "ZSNZ");
      FI;
      IF check_mode(lptr, "STRING") THEN mmix_strcmp(opcode, ptr, lptr, rptr);
      ELSE
        mmix_loadsource(lreg, "temp1", lptr);
        mmix_loadsource(rreg, "temp2", rptr);
        fprintf("\tSUB $%i,%s,%s\n", reg OF stack[ptr], lreg, rreg);
        fprintf("\t%s $%i,$%i,1\n", opcode, reg OF stack[ptr], reg OF stack[ptr]);
      FI;


# ################################################################################################### #
# QUAD tk_NOT															#
# ################################################################################################### #
    ELIF type OF quads[index] = tk_NOT THEN 
      mmix_loadsource(lreg, "temp1", lptr);
      fprintf("\tNEGU $%i,1,%s\n", reg OF stack[ptr], lreg);


# ################################################################################################### #
# QUAD NEG																#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_neg THEN 
      mmix_loadsource(lreg, "temp1", lptr);
      fprintf("\tNEG $%i,0,%s\n", reg OF stack[ptr], lreg);


# ################################################################################################### #
# QUAD TEST																#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_test THEN
      mmix_loadsource(lreg, "temp1", lptr);
      fprintf("\tBZ %s,%s\n", lreg, name OF stack[ptr]);				# jump if false


# ################################################################################################### #
# QUAD JUMP																#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_jump THEN 
      fprintf("\tJMP %s\n", name OF stack[ptr]);


# ################################################################################################### #
# QUAD PRINTn: code to print new line on the screen									#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_printn THEN 
	fprintf("\tLDA $255,Printn\n");
      fprintf("\tTRAP 0,Fputs,StdOut\n");


# ################################################################################################### #
# QUAD PRINTc: code to print a character on the screen								#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_printc THEN 
      mmix_loadsource(resreg, "temp1", ptr);
	fprintf("\tLDA $255,Buffer\n");
      fprintf("\tSTBU %s,$255,0\n", resreg);
	fprintf("\tLDA $255,BufArg\n");
      fprintf("\tTRAP 0,Fwrite,StdOut\n");


# ################################################################################################### #
# QUAD PRINTs: code to print a string on the screen									#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_prints THEN
      mmix_loadaddr(resreg, "$255", ptr);
      fprintf("\tTRAP 0,Fputs,StdOut\n");


# ################################################################################################### #
# QUAD OPEN: open a file for reading											#
# --------------------------------------------------------------------------------------------------- #
# 1. Try opening file (mode is TextRead)											#
# 2. Return status														#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_open THEN 
      val := str2int(value OF stack[lptr]);
      IF val > max_files THEN error("Too many files!"); FI; 

      fprintf("\tSETL temp2,%i\n", val - 1);			# temp2 contains file num - 1
      fprintf("\tLDA temp1,FArg0\n");				# temp1 points to table FArgs
      fprintf("\t16ADDU temp1,temp2,temp1\n");			# temp1 points within FArgs

      mmix_loadaddr(rreg, "temp3", rptr);
      fprintf("\tSTOU %s,temp1,0\n", rreg);			# store the file name address

      fprintf("\tSETL temp3,TextRead\n");
      fprintf("\tSTO temp3,temp1,8\n");				# store the file mode
 	
      fprintf("\tLDA $255,temp1\n");				# $255 = file arg address
      fprintf("\tTRAP 0,Fopen,%i\n", val + 2);		 	# open the file
      fprintf("\tSET $%i,$255\n", reg OF stack[ptr]);		# return status


# ################################################################################################### #
# QUAD ESTABLISH: open a file	for writing											#
# --------------------------------------------------------------------------------------------------- #
# 1. Try opening file (mode is TextWrite)											#
# 2. Return status														#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_establish THEN 
      val := str2int(value OF stack[lptr]);
      IF val > max_files THEN error("Too many files!"); FI; 

      fprintf("\tSETL temp2,%i\n", val - 1);			# temp2 contains file num - 1
      fprintf("\tLDA temp1,FArg0\n");				# temp1 points to table FArgs
      fprintf("\t16ADDU temp1,temp2,temp1\n");			# temp1 points within FArgs

      mmix_loadaddr(rreg, "temp3", rptr);
      fprintf("\tSTOU %s,temp1,0\n", rreg);			# store the file name address

      fprintf("\tSETL temp3,TextWrite\n");
      fprintf("\tSTO temp3,temp1,8\n");				# store the file mode
 	
      fprintf("\tLDA $255,temp1\n");				# $255 = file arg address
      fprintf("\tTRAP 0,Fopen,%i\n", val + 2);		 	# open the file
      fprintf("\tSET $%i,$255\n", reg OF stack[ptr]);		# return status


# ################################################################################################### #
# QUAD CLOSE: close a file													#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_close THEN 
      val := str2int(value OF stack[lptr]);
      fprintf("\tTRAP 0,Fclose,%i\n", val + 2);				# close the file
      fprintf("\tSET $%i,$255\n", reg OF stack[ptr]);


# ################################################################################################### #
# QUAD READC: read a character from a file										#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_readc THEN 
      val := str2int(value OF stack[lptr]);
      fprintf("\tSETL temp1,%i\n", val - 1);				# get offset
      fprintf("\tLDA temp2,FArg1\n");					# point to FArg1
      fprintf("\t16ADDU temp2,temp1,temp2\n");				# point to FArg1 + offset
      fprintf("\tSET $255,temp2\n");
      fprintf("\tTRAP 0,Fread,%i\n", val + 2);				# read
      fprintf("\tLDA temp3,FBuffer\n");					# point to FBuffer
      fprintf("\tLDBU $%i,temp3,temp1\n", reg OF stack[ptr]);	# write it to result
      fprintf("\tCSN $%i,$255,0\n", reg OF stack[ptr]);		# if end of file, set to zero
      storage_type OF stack[ptr] := storage_regvalue;


# ################################################################################################### #
# QUAD READCHAR: read a character from standard input									#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_readchar THEN 
	fprintf("\tLDA $255,BufArg\n");
      fprintf("\tTRAP 0,Fread,StdIn\n");					# read from standard input
      fprintf("\tLDA temp1,Buffer\n");					# point to Buffer
      fprintf("\tLDBU $%i,temp1,0\n", reg OF stack[ptr]);		# write it to result
      storage_type OF stack[ptr] := storage_regvalue;


# ################################################################################################### #
# QUAD ARG																#
# --------------------------------------------------------------------------------------------------- #
# - Composite objects: copy arguments to memory if passed by value						#
# - Primitive objects: copy arguments to registers									#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_arg THEN 
      IF id OF stack[ptr] = 0 THEN reset_args; FI;
      IF is_mode_ref(ptr) THEN							# ALL REFs are handled here!
        reg OF stack[ptr] := get_arg_reg;
        mmix_loadaddr(lreg, "temp1", lptr); 
        fprintf("\tSET $%i,%s\n", reg OF stack[ptr], lreg);

      ELIF is_mode_composite(ptr) THEN						# composite non-REFs
        IF code_refs THEN 
          reg OF stack[ptr] := get_arg_reg;					# CAUTION: pass arg by reference!
          mmix_loadaddr(lreg, "temp1", lptr); 
          fprintf("\tSET $%i,%s\n", reg OF stack[ptr], lreg);
        ELSE										# pass by value (make copy)
          reg OF stack[ptr] := get_arg_reg;
          IF is_mode_array(ptr) THEN						# variable size arguments
            fprintf("\tSET $%i,sp\n", reg OF stack[ptr]);		
            # TRICK: adjust address (array convention)
            fprintf("\tADD $%i,$%i,8\n", reg OF stack[ptr], reg OF stack[ptr]);
            mmix_loadaddr(lreg, "temp1", lptr);					# <lptr> address into temp1
            fprintf("\tSUB temp1,temp1,8\n");
            fprintf("\tLDT temp1,temp1,0\n");					# load array size (in octets)
            fprintf("\tSL temp1,temp1,3\n");					# convert to number of bytes
            fprintf("\tADD sp,sp,temp1\n");					# update stack pointer
            mmix_memcopy(lptr, ptr);
          ELSE										# fixed-size arguments
            mmix_memcopy(lptr, ptr);
            mmix_loadaddr(resreg, "temp1", ptr); 
            fprintf("\tSET $%i,%s\n", reg OF stack[ptr], resreg);
          FI;
        FI;

      ELSE											# primitive non-REFs
        reg OF stack[ptr] := get_arg_reg;
        IF reg OF stack[ptr] /= reg OF stack[lptr] THEN 
          mmix_loadsource(lreg, "temp1", lptr);
          fprintf("\tSET $%i,%s\n", reg OF stack[ptr], lreg);
        ELSE
          fprintf("\tSET temp1,temp1\n");						# trick to avoid dangling labels
        FI;
      FI;


# ################################################################################################### #
# QUAD ARGREF															#
# --------------------------------------------------------------------------------------------------- #
# - Composite objects: copy pointer to stack										#
# - Primitive objects: copy value to stack										#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_argref THEN 
      IF is_mode_composite(lptr) THEN
        mmix_loadaddr(lreg, "temp1", lptr);
        fprintf("\tSTOU %s,sp,%i\n", lreg, ptr - 8);			# direct use of ptr (weird one!)
      ELSE
        mmix_loadsource(lreg, "temp1", lptr);
        fprintf("\tSTOU %s,sp,%i\n", lreg, ptr - 8);			# direct use of ptr (weird one!)
      FI;


# ################################################################################################### #
# QUAD ARGSIZE															#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_argsize THEN 
      fprintf("\tSET temp1,%i\n", ptr + 8);				# load arguments' total size
      fprintf("\tSTOU temp1,sp,%i\n", ptr);				# store it!
      fprintf("\tADD sp,sp,%i\n", ptr + 8);				# update stack pointer


# ################################################################################################### #
# QUAD ALLOC: allocate memory for arrays/structures									#
# --------------------------------------------------------------------------------------------------- #
# Arrays: initialize the 8-byte size header (size + upper bound)							#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_alloc THEN
# size in octets (1 tetra)
      mmix_sets("temp1", (mode_size OF stack[ptr])/8);
      mmix_sets("temp2", addr_offset OF stack[ptr] - 8);
      fprintf("\tSTT temp1,fp,temp2\n");
# upper bound (1 tetra)
      mmix_sets("temp1", calc_mode_items(mode OF stack[ptr]));
      mmix_sets("temp2", addr_offset OF stack[ptr] - 4);
      fprintf("\tSTT temp1,fp,temp2\n");


# ################################################################################################### #
# QUAD PROC																#
# --------------------------------------------------------------------------------------------------- #
# 1. print procedure label													#
# 2. store return jump address into reserved <retaddr_reg>								#
# 3. store global display register of appropriate nesting into reserved <display_reg>			#
# 4. store old frame pointer <fp> into reserved <frameptr_reg>							#
# 5. set new frame pointer <fp> to old stack pointer <sp>								#
# 6. set new stack pointer <sp> to point right after fixed-size data area					#
# 7. set global display register to new frame pointer <fp>								#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_proc THEN 
# OPTIMIZE: remove retreg if there is no recursive call!
      IF current_nesting /= nesting OF stack[ptr] THEN error("Unexpected nesting disgreement!") FI;
      proc_info := proc_info OF stack[ptr];
      fprintf("\n%s", label OF table_proc_info[proc_info]);
      fprintf("\tGET $%i,rJ\n", retaddr_reg OF stack_frame);
      fprintf("\tSET $%i,disp%i\n", display_reg OF stack_frame, current_nesting);
      fprintf("\tSET $%i,fp\n", frameptr_reg OF stack_frame);
      fprintf("\tSET fp,sp\n");
      mmix_addssi("sp", "sp", localvar_size OF stack_frame);
      fprintf("\tSET disp%i,fp\n", current_nesting);

# CAUTION: remove later, it initializes stack frame to a series of dot characters
#      fprintf("\tSET temp2,'.'\n");
#      fprintf("\tSET temp1,fp\n");
#      mmix_sets("temp3", localvar_size OF stack_frame);
#      fprintf("1H\tSTB temp2,temp1,0\n");
#      fprintf("\tADD temp1,temp1,1\n");
#      fprintf("\tSUB temp3,temp3,1\n");
#      fprintf("\tBNZ temp3,1B\n");


# ################################################################################################### #
# QUAD RET																#
# --------------------------------------------------------------------------------------------------- #
# 1. restore old stack pointer <sp>												#
# 2. restore old frame pointer <fp>												#
# 3. restore global display register <disp#>										#
# 4. restore return jump register <rJ>											#
# 5. put return value address into register <$0>, if applicable							#
# 6. return to caller 														#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_ret THEN 
      IF NOT is_mode_void(ptr) THEN
        IF storage_type OF stack[ptr] = storage_regvalue THEN 
          fprintf("\tSET $0,$%i\n", reg OF stack[ptr]);
        ELIF storage_type OF stack[ptr] = storage_memvalue THEN 
          IF is_mode_composite(ptr) THEN 
            mmix_loadaddr(lreg, "$0", ptr);					# CAUTION: $0 should be enforced
          ELSE
            mmix_loadsource(lreg, "$0", ptr); 					# CAUTION: $0 should be enforced
          FI;
        ELIF storage_type OF stack[ptr] = storage_regaddr THEN 
          mmix_loadaddr(lreg, "$0", ptr);						# CAUTION: $0 should be enforced
        ELSE
          error("Generate code: unhandled storage type for return value!");
        FI;
        fprintf("\tSET sp,fp\n");
        fprintf("\tSET fp,$%i\n", frameptr_reg OF stack_frame);
        fprintf("\tSET disp%i,$%i\n", current_nesting, display_reg OF stack_frame);
        fprintf("\tPUT rJ,$%i\n", retaddr_reg OF stack_frame);
        fprintf("\tPOP 1,0\n");
      ELSE
        fprintf("\tSET sp,fp\n");
        fprintf("\tSET fp,$%i\n", frameptr_reg OF stack_frame);
        fprintf("\tSET disp%i,$%i\n", current_nesting, display_reg OF stack_frame);
        fprintf("\tPUT rJ,$%i\n", retaddr_reg OF stack_frame);
        fprintf("\tPOP 0,0\n");
      FI;


# ################################################################################################### #
# QUAD CALL																#
# --------------------------------------------------------------------------------------------------- #
# 1. call the function														#
# 2. copy the return value, if applicable								 			#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_call THEN 
      proc_info := proc_info OF stack[lptr];
      fprintf("\tPUSHJ $%i,%s\n", get_last_reg, label OF table_proc_info[proc_info]);
      IF NOT is_mode_void(ptr) THEN
        IF is_mode_composite(ptr) OR is_mode_ref(ptr) THEN 
          fprintf("\tSET $%i,$%i\n", reg OF stack[ptr], get_last_reg);
          storage_type OF stack[ptr] := storage_regaddr;
# ELIF storage_type OF stack[ptr] = storage_memvalue THEN 
# mmix_retcopy(ptr, get_last_reg);
        ELSE
          IF type OF stack[ptr] /= entity_argvar THEN 
            fprintf("\tSET $%i,$%i\n", reg OF stack[ptr], get_last_reg);
          ELSE
            error("Dear parser, you should not assign a returned value directly to an argument!");
          FI;
        FI;
      FI;


# ################################################################################################### #
# QUAD MAIN																#
# --------------------------------------------------------------------------------------------------- #
# 1. Set the global display to the initial stack pointer <sp>							#
# 2. Set the frame pointer <fp> to the initial stack pointer <sp>							#
# 3. Increase <sp> by the size of the space used local variables							#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_main THEN 
      fprintf("Main\tLDA sp,STACK\n");
      mmix_addssi("fp", "sp", param_size OF stack_frame);
      fprintf("\tSET disp1,fp\n");
      mmix_sets("temp1", param_size OF stack_frame + localvar_size OF stack_frame);
      fprintf("\tADD sp,sp,temp1\n");

      ptr := flookup("argc");								# save $0 to argc
      mmix_fix8c("ST", get_storage_code(ptr), "$0", "fp", addr_offset OF stack[ptr]); 
      
      ptr := flookup("argv");								# save contents of $1 to argv[]
      mmix_sets("temp2", addr_offset OF stack[ptr]);				# temp2: pointer to target
      fprintf("1H\tSETL temp3,%i\n", string_size); 				# temp3: size
      fprintf("\tLDOU temp4,$1,0\n");						# temp4: pointer to source
      fprintf("2H\tLDOU temp1,temp4,0\n");					# temp1: octa to be copied
      fprintf("\tSTOU temp1,fp,temp2\n");
      fprintf("\tADD temp4,temp4,8\n");
      fprintf("\tADD temp2,temp2,8\n");
      fprintf("\tSUB temp3,temp3,8\n");
      fprintf("\tPBNZ temp3,2B\n\n");						# done with current argument?
      fprintf("\tADD $1,$1,8\n");
      fprintf("\tSUB $0,$0,1\n");							# one argument less
      fprintf("\tPBNZ $0,1B\n\n");


# CAUTION: remove later, it initializes stack frame to a series of dot characters
#      fprintf("\tSET temp2,'.'\n");
#      fprintf("\tSET temp1,fp\n");
#      mmix_sets("temp3", localvar_size OF stack_frame);
#      fprintf("1H\tSTB temp2,temp1,0\n");
#      fprintf("\tADD temp1,temp1,1\n");
#      fprintf("\tSUB temp3,temp3,1\n");
#      fprintf("\tBNZ temp3,1B\n");


# ################################################################################################### #
# QUAD HALT - End of program													#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_halt THEN 
      fprintf("\tTRAP 0,Halt,0\n");


# ################################################################################################### #
# QUAD DUMP - Dump raw stack frame data											#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_dump THEN 
	fprintf("\tLDA $255,Frame\n");
      fprintf("\tSTO fp,$255,0\n");
      mmix_sets("temp1", localvar_size OF stack_frame);
      fprintf("\tSTO temp1,$255,8\n");
      fprintf("\tTRAP 0,Fwrite,StdOut\n");
	fprintf("\tLDA $255,Printn\n");
      fprintf("\tTRAP 0,Fputs,StdOut\n");


# ################################################################################################### #
# QUAD LABEL - Print it out!													#
# ################################################################################################### #
    ELIF type OF quads[index] = quad_label THEN 
      fprintf("%s", name OF stack[ptr]);

    ELSE
      printf("%i: * other instruction %s\n", index, name OF stack[ptr]);
    FI;
    printf("%i:", index);
    index := index + 1;
  OD;
  quad_index := quadptr;
END;



#MODULE 'a-debug' provides general debugging functionality


PROC dump_stack = VOID:
BEGIN
  INT line := 0;
  INT proc_info;
  INT index := stack_index - 1;
  WHILE index >= 1 
  DO
    line := line + 1;
    IF line > 23 THEN line := 0; printf("More..."); readchar; FI;

# Frame -----------------------------------------------------------------------------------------------
    IF type OF stack[index] = entity_frame THEN 
      printf("%i: START FRAME (nesting %i)\n", index, nesting OF stack[index]);

# Start scope -----------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_startscope THEN 
      printf("%i: START SCOPE _%s_\n", index, name OF stack[index]);

# End scope -------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_endscope THEN 
      printf("%i: END SCOPE _%s_\n", index, name OF stack[index]);

# Variable --------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_var THEN 
      printf("%i: variable '%s' of mode %s and size %i\n", index, name OF stack[index], mode OF stack[index], mode_size OF stack[index]);

# Pointer --------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_ptrvar THEN 
      printf("%i: pointer '%s' of mode %s and size %i\n", index, name OF stack[index], mode OF stack[index], mode_size OF stack[index]);

# Parameter -------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_param THEN 
      printf("%i: parameter '%s' of mode %s and size %i\n", index, name OF stack[index], mode OF stack[index], mode_size OF stack[index]);

# Temporary -------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_tempvar THEN 
      printf("%i: temporary '%s' of mode %s and size %i\n", index, name OF stack[index], mode OF stack[index], mode_size OF stack[index]);

# Argument --------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_argvar THEN 
      printf("%i: argument '%s' of mode %s and size %i\n", index, name OF stack[index], mode OF stack[index], mode_size OF stack[index]);

# Label -----------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_label THEN 
      printf("%i: label '%s'\n", index, name OF stack[index]);

# Procedure -------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_proc THEN 
      proc_info := proc_info OF stack[index];
      printf("%i: procedure '%s' of label %s and mode %s\n", index, name OF stack[index], label OF table_proc_info[proc_info], mode OF stack[index]);

# Mode ------------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_mode THEN 
      printf("%i: mode '%s' is %s\n", index, name OF stack[index], mode OF stack[index]);

# Constant --------------------------------------------------------------------------------------------
    ELIF type OF stack[index] = entity_constant THEN 
      printf("%i: constant '%s' OF mode %s\n", index, name OF stack[index], mode OF stack[index]);

    ELSE
      printf("%i: other\n", index);
      error("Unknown symbol table entry!");
    FI;
    index := index - 1;
  OD;
END;


PROC dump_frame = VOID:
BEGIN
  [5]STRING table_storage;
  INT offset;
  INT storage_type;
  INT line := 2;
  INT index := stack_index - 1;

  StrAssign(table_storage[0], "const");
  StrAssign(table_storage[1], "regval");
  StrAssign(table_storage[2], "regaddr");
  StrAssign(table_storage[3], "memval");
  StrAssign(table_storage[4], "memaddr");

  WHILE type OF stack[index] /= entity_frame DO index := index - 1 OD;
  printf("     ID                   STORAGE   SIZE      OFFSET  REG NST MODE         \n");
  printf("----------------------------------------------------------------------------\n");
  WHILE index < stack_index
  DO
    IF type OF stack[index] = entity_var OR
       type OF stack[index] = entity_tempvar OR
       type OF stack[index] = entity_ptrvar OR
       type OF stack[index] = entity_argvar OR
       type OF stack[index] = entity_param
    THEN 
      line := line + 1;
      IF line > 20 THEN line := 0; printf("More..."); readchar; FI;
      storage_type := storage_type OF stack[index];
      IF type OF stack[index] = entity_param AND is_mode_composite(index) THEN 
        offset := addr_offset OF stack[index] - param_size OF stack_frame; 
      ELSE
        offset := addr_offset OF stack[index]; 
      FI;
      printf("%4i:%-20s %-7s %8i %10i %3i %3i %s\n", index, name OF stack[index], table_storage[storage_type], mode_size OF stack[index], offset, reg OF stack[index], nesting OF stack[index], mode OF stack[index]);
    FI;
    index := index + 1;
  OD;
  printf("----------------------------------------------------------------------------\n");
  printf("FRAME SIZE = %i\n", localvar_size OF stack_frame);
  printf("----------------------------------------------------------------------------\n");
END;


PROC dump_procedures = VOID:
BEGIN
  INT line := 0;
  INT index := 0;
  printf("LABEL      QUADPTR MAXTEMP DONE             \n");
  printf("--------------------------------------------\n");
  WHILE index <= proc_info_index
  DO
    line := line + 1;
    IF line > 20 THEN line := 0; printf("More..."); readchar; FI;
    printf("%-10s %6i %7i %4i\n", label OF table_proc_info[index], quadptr OF table_proc_info[index], max_temp OF table_proc_info[index], done OF table_proc_info[index]);
    index := index + 1;
  OD;
END;


PROC dump_quads = VOID:
BEGIN
  INT resptr, lptr, rptr;
  INT proc_info;
  INT line := 0;
  INT index := 0;
  WHILE index < quad_index 
  DO
    line := line + 1;
    IF line > 23 THEN line := 0; printf("More..."); readchar; FI;
    resptr := result OF quads[index];
    lptr := left OF quads[index];
    rptr := right OF quads[index];
    printf("%i: ", index);
    IF type OF quads[index] = tk_ASSIGN THEN 
      printf("ASSIGN %s (%i) := %s (%i)\n", name OF stack[resptr], resptr, name OF stack[rptr], rptr);
    ELIF type OF quads[index] = quad_deref THEN 
      printf("DEREF %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_alias THEN 
      printf("ALIAS %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_main THEN 
      printf("MAIN\n");
    ELIF type OF quads[index] = quad_halt THEN 
      printf("HALT\n");
    ELIF type OF quads[index] = quad_dump THEN 
      printf("DUMPFRAME\n");
    ELIF type OF quads[index] = ABS '=' THEN 
      printf("EQUAL %s (%i) = %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = ABS '>' THEN 
      printf("GREATER %s (%i) > %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = ABS '<' THEN 
      printf("LESS %s (%i) > %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = tk_GEQ THEN 
      printf("GEQ %s (%i) >= %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = tk_LEQ THEN 
      printf("LEQ %s (%i) <= %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = tk_NEQ THEN 
      printf("NEQ %s (%i) /= %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = tk_NOT THEN 
      printf("NOT %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_neg THEN 
      printf("NEG -%s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = ABS '+' THEN 
      printf("PLUS %s (%i) := %s (%i) + %s (%i)\n", name OF stack[resptr], resptr, name OF stack[lptr], lptr, name OF stack[rptr], rptr);
    ELIF type OF quads[index] = ABS '-' THEN 
      printf("MINUS %s (%i) := %s (%i) - %s (%i)\n", name OF stack[resptr], resptr, name OF stack[lptr], lptr, name OF stack[rptr], rptr);
    ELIF type OF quads[index] = ABS '*' THEN 
      printf("MULT %s (%i) := %s (%i) * %s (%i)\n", name OF stack[resptr], resptr, name OF stack[lptr], lptr, name OF stack[rptr], rptr);
    ELIF type OF quads[index] = ABS '/' THEN 
      printf("DIV %s (%i) := %s (%i) / %s (%i)\n", name OF stack[resptr], resptr, name OF stack[lptr], lptr, name OF stack[rptr], rptr);
    ELIF type OF quads[index] = tk_OR THEN 
      printf("OR %s (%i) := %s (%i) || %s (%i)\n", name OF stack[resptr], resptr, name OF stack[lptr], lptr, name OF stack[rptr], rptr);
    ELIF type OF quads[index] = tk_AND THEN 
      printf("AND %s (%i) := %s (%i) && %s (%i)\n", name OF stack[resptr], resptr, name OF stack[lptr], lptr, name OF stack[rptr], rptr);
    ELIF type OF quads[index] = quad_subscript THEN 
      printf("SUBSCRIPT %s[%s] -> %s (%i)\n", name OF stack[lptr], name OF stack[rptr], name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_of THEN 
      printf("OF %s (%i) OF %s (%i) -> %s (%i)\n", name OF stack[resptr], resptr, name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_jump THEN 
      printf("JUMP %s\n", name OF stack[resptr]);
    ELIF type OF quads[index] = quad_test THEN 
      printf("TEST %s (%i) -> %s\n", name OF stack[lptr], lptr, name OF stack[resptr])
    ELIF type OF quads[index] = quad_label THEN 
      printf("LABEL %s\n", name OF stack[resptr]);
    ELIF type OF quads[index] = quad_printc THEN 
      printf("PRINTc %s (%i)\n", name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_printn THEN 
      printf("PRINTn\n");
    ELIF type OF quads[index] = quad_prints THEN 
      printf("PRINTs %s (%i)\n", name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_printi THEN 
      printf("PRINTi %s (%i)\n", name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_open THEN 
      printf("OPEN %s, %s (%i) -> %s (%i)\n", name OF stack[lptr], name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_establish THEN 
      printf("ESTABLISH %s, %s (%i) -> %s (%i)\n", name OF stack[lptr], name OF stack[rptr], rptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_close THEN 
      printf("CLOSE %s\n", name OF stack[lptr]);
    ELIF type OF quads[index] = quad_readc THEN 
      printf("READC %s -> %s (%i)\n", name OF stack[lptr], name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_readchar THEN 
      printf("READCHAR -> %s (%i)\n", name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_ret THEN 
      printf("RET value %s (%i)\n", name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_upb THEN 
      printf("UPB %s (%i) -> %s (%i)\n", name OF stack[lptr], lptr, name OF stack[resptr], resptr);
    ELIF type OF quads[index] = quad_arg THEN 
      printf("ARG %s (%i) of mode %s -> &%i\n", name OF stack[lptr], lptr, mode OF stack[lptr], id OF stack[resptr]);
    ELIF type OF quads[index] = quad_argref THEN 
      printf("ARGREF %s (%i) of mode %s and offset %i\n", name OF stack[lptr], lptr, mode OF stack[lptr], resptr - 8);
    ELIF type OF quads[index] = quad_argsize THEN 
      printf("ARGSIZE size is %i\n", resptr + 8);
    ELIF type OF quads[index] = quad_call THEN 
      printf("CALL procedure %s of mode %s -> %s (%i)\n", name OF stack[lptr], mode OF stack[lptr], name OF stack[resptr], resptr)
    ELIF type OF quads[index] = quad_proc THEN 
      proc_info := proc_info OF stack[resptr];
      printf("PROC %s of mode %s with label %s\n", name OF stack[resptr], mode OF stack[resptr], label OF table_proc_info[proc_info]);
    ELIF type OF quads[index] = quad_endproc THEN 
      printf("ENDPROC %s\n", name OF stack[resptr]);
    ELSE
      printf("UNKNOWN\n", index);
    FI;
    index := index + 1;
  OD;
END;


PROC debugger = VOID:
BEGIN
  CHAR cmd := REPR 0;
  BOOL flag := debug_stop;

  debug_stop := TRUE;
  printf("\n");
  WHILE cmd /= 'r' AND cmd /= 's' AND cmd /= 'x'
  DO
    printf("> ");
    cmd := readchar;
    readchar;
    IF cmd = 't' THEN printf("Current token is (%s,%s).\n", str OF token, descr OF token);
    ELIF cmd = 'r' THEN debug_stepwise := FALSE; debug_expr := FALSE; debug_stop := flag;
    ELIF cmd = 's' THEN debug_stepwise := TRUE; debug_expr := FALSE;
    ELIF cmd = 'x' THEN debug_stepwise := FALSE; debug_expr := TRUE;
    ELIF cmd = 'd' THEN dump_stack;
    ELIF cmd = 'i' THEN dump_quads;
    ELIF cmd = 'f' THEN dump_frame;
    ELIF cmd = 'p' THEN dump_procedures;
    ELIF cmd = 'q' THEN error("Quit!");
    ELSE
      printf("\n");
      printf("-----------------\n");
      printf(" Command summary \n");
      printf("-----------------\n\n");
      printf("r - continue running the parser\n");
      printf("s - run the parser in stepwise mode\n");
      printf("x - run the parser expression by expression (in series)\n");
      printf("t - print current token\n");
      printf("d - stack dump\n");
      printf("i - show generated intermediate code\n");
      printf("f - dump stack frame\n");
      printf("p - dump procedure info\n");
      printf("q - quit the parser\n");
      printf("\n");
    FI;
  OD;
  printf("\n");
END;

#INLINE #include "a-lex.c"
#INLINE #include "a-symbol.c"
#INLINE #include "a-code.c"
#INLINE #include "a-debug.c"


#INLINE /*
[28]INT set_of_tokens;
set_of_tokens[0] := tk_ELIF;
set_of_tokens[1] := tk_ELSE;
set_of_tokens[2] := tk_FI;
set_of_tokens[3] := 0;
set_of_tokens[4] := ABS '*';
set_of_tokens[5] := ABS '/';
set_of_tokens[6] := ABS '+';
set_of_tokens[7] := ABS '-';
set_of_tokens[8] := tk_POWER;
set_of_tokens[9] := tk_MOD;
set_of_tokens[10] := 0;
set_of_tokens[11] := tk_OR;
set_of_tokens[12] := tk_OR;
set_of_tokens[13] := tk_AND;
set_of_tokens[14] := tk_AND;
set_of_tokens[15] := 0;
set_of_tokens[16] := ABS '=';
set_of_tokens[17] := tk_NEQ;
set_of_tokens[18] := ABS '<';
set_of_tokens[19] := ABS '>';
set_of_tokens[20] := tk_LEQ;
set_of_tokens[21] := tk_GEQ;
set_of_tokens[22] := 0;
set_of_tokens[23] := tk_AMODE;
set_of_tokens[24] := tk_REF;
set_of_tokens[25] := ABS '[';
set_of_tokens[26] := tk_STRUCT;
set_of_tokens[27] := 0;
#INLINE */


#INLINE int set_of_tokens[28] = 
#INLINE {tk_ELIF, tk_ELSE, tk_FI, 0, '*', '/', '+', '-', tk_POWER, tk_MOD, 0,
#INLINE  tk_OR, tk_OR, tk_AND, tk_AND, 0, '=',tk_NEQ,'<','>',tk_LEQ, tk_GEQ, 0, 
#INLINE  tk_AMODE, tk_REF, '[', tk_STRUCT, 0};


INT set_threshold = 2000;
INT set_elif_else_fi = 2000;
INT set_arithm_operators = 2004;
INT set_bool_operators = 2011;
INT set_rel_operators = 2016;
INT set_first_amode = 2023;



# Return operator's priority

PROC priority = (INT token_id) INT:
BEGIN
  INT pr;

  IF token_id = tk_ASSIGN THEN pr := 10;
  ELIF token_id = tk_OR THEN pr := 20;
  ELIF token_id = tk_OR THEN pr := 20;
  ELIF token_id = tk_AND THEN pr := 30;
  ELIF token_id = tk_AND THEN pr := 30;
  ELIF token_id = ABS '+' THEN pr := 40;
  ELIF token_id = ABS '-' THEN pr := 40;
  ELIF token_id = ABS '*' THEN pr := 50;
  ELIF token_id = ABS '/' THEN pr := 50;
  ELIF token_id = tk_MOD THEN pr := 50;
  ELIF token_id = tk_POWER THEN pr := 60;
  ELSE pr := 0;
  FI;
  pr
END;



PROC check_token = (INT tokenId) BOOL:
BEGIN
  IF used OF token THEN GetNextToken FI;
  id OF token = tokenId
END;


PROC check_tokenset = (INT set_index) BOOL:
BEGIN
  BOOL result;
  INT i;
  IF set_index < set_threshold THEN 
    result := check_token(set_index);
  ELSE
    i := set_index - set_threshold;
    WHILE set_of_tokens[i] /= 0 AND NOT check_token(set_of_tokens[i]) DO i := i + 1; OD;
    result := set_of_tokens[i] /= 0;
  FI;
  result
END;


PROC accept_token = (INT tokenId) BOOL:
BEGIN
  BOOL result;

  IF used OF token THEN GetNextToken FI;
  IF id OF token = tokenId THEN
    printf(" %s ", str OF token);
    used OF token := TRUE;
    result := TRUE
  ELSE
    error("wrong token");
    result := FALSE
  FI;
  result
END;


PROC power = (INT x, INT yy) INT:
BEGIN
  INT z := 1;
  INT y := yy;
  WHILE y > 0
  DO
    z := z * x;
    y := y - 1
  OD;
  z
END;


PROC calc = (INT op, INT lval, INT rval) INT:
BEGIN
  INT result;

  IF op = ABS '+' THEN result := lval + rval;
  ELIF op = ABS '-' THEN result := lval + rval; 
  ELIF op = ABS '*' THEN result := lval * rval;
  ELIF op = ABS '/' THEN result := lval / rval; 
  ELIF op = tk_POWER THEN result := power(lval, rval);
  ELIF op = ABS '=' THEN 
    IF lval = rval THEN result := 1; ELSE result = 0; FI;
  ELIF op = ABS '>' THEN
    IF lval > rval THEN result := 1; ELSE result = 0; FI;
  ELIF op = ABS '<' THEN 
    IF lval < rval THEN result := 1; ELSE result = 0; FI;
  ELIF op = tk_NEQ THEN 
    IF lval /= rval THEN result := 1; ELSE result = 0; FI;
  ELIF op = tk_GEQ THEN 
    IF lval >= rval THEN result := 1; ELSE result = 0; FI;
  ELIF op = tk_LEQ THEN 
    IF lval <= rval THEN result := 1; ELSE result = 0; FI;
  ELSE result := rval; 
  FI;
#  IF debug_echo THEN printf("[%i%c%i=%i]", lval, op, rval, result); FI;
  result
END;


# ##################################################################################### #
# FORWARD DECLARATIONS											    #
# ##################################################################################### #
FORWARD PROC unify_modes = (INT rule, INT target, INT source) INT;
FORWARD PROC parse_expression = (INT result) INT; 
FORWARD PROC parse_amode = (REF STRING mode) VOID;
FORWARD PROC parse_expr_factor = (INT result) INT; 


# ##################################################################################### #
# COERCIONS													    #
# ------------------------------------------------------------------------------------- #
# <context>		- the coercion's context							    #
# <symbol>		- the symbol table entry to be coerced					    #
# <mode>		- the mode to which the symbol will be coerced				    #
# <lmode>		- the symbol's final coerced mode						    #
# ------------------------------------------------------------------------------------- #
# voiding:		AMODE => VOID									    #
# dereferencing:	(REF)+ AMODE => AMODE								    #
# rowing:		AMODE => []AMODE									    #
# ##################################################################################### #
PROC coerce = (INT context, INT ptr, STRING mode, REF STRING lmode) INT:
BEGIN
  INT symbol := ptr;
  STRING rmode, tmode;
  INT i, j;
  INT item, subscript, newsymbol := symbol;

# printf("Coercing %s to %s...\n", mode OF stack[symbol], mode);

# CAUTION: remove this?
  IF StrEqual(mode OF stack[symbol], "?") THEN
    StrAssign(mode OF stack[symbol], mode); 

  ELSE
    StrAssign(lmode, "");
    StrAssign(tmode, mode);
    StrAssign(rmode, mode OF stack[symbol]);
    WHILE StrLen(tmode) > 0
    DO
#      printf("Unify(%s,%s,%s) -> \n", lmode, rmode, tmode);
      unify(lmode, rmode, tmode);
#      printf("To (%s,%s,%s)\n", lmode, rmode, tmode);
      IF StrLen(tmode) > 0 THEN
        IF StrEqual(tmode, "VOID") AND context = context_strong THEN 
          # printf("Voiding...\n");
          StrAssign(rmode, "VOID");								# voiding
          StrAssign(mode OF stack[symbol], "VOID");
        ELIF IsPrefix(rmode, "REF") THEN 
          # printf("Dereferencing...\n");
          StrTail(rmode, rmode, 4);								# dereferencing
          newsymbol := new_tempvar(rmode);
          generate_quad(quad_deref, newsymbol, symbol, 0);

        ELIF IsPrefix(tmode, "[") AND context = context_strong THEN 
          # printf("Rowing...\n");
          StrAppend(rmode, "[1] ", rmode);						# rowing
          newsymbol := new_tempvar(rmode);
          subscript := new_const("0", "INT");
          item := new_tempvar("?");
          newsymbol := unify_modes(rule_itemize, item, newsymbol);
          generate_quad(quad_alloc, newsymbol, 0, 0);
          generate_quad(quad_subscript, item, newsymbol, subscript);
          generate_quad(tk_ASSIGN, item, 0, symbol);
          free_temp(item);
        ELSE
          printf("%s cannot be coerced to %s!", mode OF stack[symbol], mode);
          error("");
        FI;
      FI;
      IF newsymbol /= symbol THEN free_temp(symbol); FI;
      symbol := newsymbol;
    OD;
    i := StrLen(lmode) - 1;
    IF lmode[i] = ' ' THEN lmode[i] := REPR 0; FI;
  FI;
  newsymbol
END;


# ##################################################################################### #
# UNIFY MODES												    #
# ------------------------------------------------------------------------------------- #
# <rule>		- the unification rule (<identity>, <assign>, or <itemize>)		    #
# <target>		- the target symbol table entry						    #
# <mode>		- the target symbol table entry						    #
# ------------------------------------------------------------------------------------- #
# assign:		REF AMODE := AMODE								    #
# identity:		AMODE = AMODE									    #
# itemize:		[]AMODE => AMODE									    #
# ##################################################################################### #
PROC unify_modes = (INT rule, INT target, INT source) INT:
BEGIN
  STRING items, lmode, rmode;
  INT i, j;
  INT newsource := source;

  IF target = source THEN error("Tragedy: trying to unifying a symbol with itself!"); FI;

  IF rule = rule_assign THEN
    IF check_mode(target, "?") THEN
      StrAssign(mode OF stack[target], mode OF stack[source]); 
      mode_size OF stack[target] := mode_size OF stack[source];
    ELSE
      IF IsPrefix(mode OF stack[target], "REF") THEN
        StrTail(lmode, mode OF stack[target], 4);
        newsource := coerce(context_strong, source, lmode, dummy);
      ELSE
        printf("unify_modes: left value should be a name, but is %s!", mode OF stack[target]);
        error("");
      FI;
    FI;

  ELIF rule = rule_identity THEN
    IF check_mode(target, "?") THEN
      StrAssign(mode OF stack[target], mode OF stack[source]); 
      mode_size OF stack[target] := mode_size OF stack[source];
    FI;
    newsource := coerce(context_strong, source, mode OF stack[target], dummy);

  ELIF rule = rule_itemize THEN
    IF is_mode_array(source) THEN
      i := StrFind(mode OF stack[source], '[', 0);
      StrSlice(mode OF stack[target], mode OF stack[source], 0, i - 1); 
      j := StrFind(mode OF stack[source], ']', 0);
      StrSlice(items, mode OF stack[source], i + 1, j - 1);
      StrTail(lmode, mode OF stack[source], j + 2); 
      StrAppend(mode OF stack[target], mode OF stack[target], lmode);
      mode_size OF stack[target] := calc_mode_size(mode OF stack[target], TRUE); 
# printf("\nITEMIZE: mode is %s, size is %i\n", mode OF stack[target], mode_size OF stack[target]);


# CAUTION: This is definetely ad hoc!
    ELIF StrEqual(mode OF stack[source], "STRING") THEN
      StrAssign(mode OF stack[target], "CHAR");
      mode_size OF stack[target] := 8;
    ELIF StrEqual(mode OF stack[source], "REF STRING") THEN
      StrAssign(mode OF stack[target], "REF CHAR");
      mode_size OF stack[target] := 8;
    ELSE
      printf("unify_modes: error trying to itemize %s!", mode OF stack[source]);
      error("");
    FI;

  FI;

  IF newsource /= source THEN free_temp(source); FI;						# CAUTION: Right?
  newsource 
END;


# ##################################################################################### #
# PARSE series												    #
# ##################################################################################### #
PROC parse_series = (INT follow_set) INT:
BEGIN
  INT ptr;

  open_scope;

  IF debug_echo THEN printf("\nENTER: series\n"); FI;
  ptr := parse_expression(0);
  IF debug_expr THEN debugger; FI;
  WHILE check_token(ABS ';') AND NOT check_tokenset(follow_set) 
  DO
    accept_token(ABS ';');
    free_temp(ptr); 
    printf("\n");
    IF check_tokenset(follow_set) THEN ptr := new_tempvar("VOID"); ELSE ptr := parse_expression(0); FI;
    IF debug_expr THEN debugger; FI;
  OD;
  IF debug_echo THEN printf("\nEXIT: series\n"); FI;

  close_scope;

  ptr
END;


# ##################################################################################### #
# PARSE arg_list = expression (, expression)*							    #
# ##################################################################################### #
PROC parse_arg_list = (REF []INT args) VOID:
BEGIN
  INT i;

  IF debug_echo THEN printf(" START: arg_list "); FI;
  i := 1;
  args[i] := parse_expression(0); 
  WHILE check_token(ABS ',') 
  DO
    accept_token(ABS ',');
    i := i + 1;
    args[i] := parse_expression(0);
  OD;
  args[0] := i;
  IF d