/* Yacc grammar (and 95% of the compiler) for GMC (Grendel MudC) */ %{ {$APPTYPE CONSOLE} uses SysUtils, Classes, {$IFDEF WIN32} Windows, {$ENDIF} YaccLib, LexLib, strip; const CONV_TO_INT = 1; CONV_TO_FLOAT = 2; CONV_TO_STRING = 3; SPECIAL_TRAP = 1; SPECIAL_SLEEP = 2; SPECIAL_WAIT = 3; SPECIAL_SIGNAL = 4; VARTYPE_FUNCTION = 1; VARTYPE_GLOBAL = 2; VARTYPE_LOCAL = 3; VARTYPE_PARAM = 4; VARTYPE_STATIC = 5; type Root = class lineNum : integer; fname : string; typ : integer; constructor Create(); end; Expr = class(Root) end; Expr_ConstInt = class(Expr) value : Integer; end; Expr_ConstFloat = class(Expr) value : Single; end; Expr_String = class(Expr) value : string; end; Expr_Neg = class(Expr) ex : Expr; end; Expr_Op = class(Expr) op : char; le, re : Expr; end; Expr_Seq = class(Expr) ex, seq : Expr; end; Expr_If = class(Expr) ce : Expr; le, re : Expr; lThen, lElse, lAfter : Integer; end; Expr_Id = class(Expr) id : string; end; Expr_Assign = class(Expr) id, ex : Expr; end; Expr_Asm = class(Expr) line : string; end; Expr_Func = class(Expr) id : string; displ : integer; body : Expr; lStart : integer; end; Expr_Return = class(Expr) id : string; ret : Expr; end; Expr_Call = class(Expr) id : string; params : Expr; end; Expr_External = class(Expr) id : string; assoc : string; end; Expr_Conv = class(expr) ex : Expr; cnv : integer; originaltyp : integer; end; Expr_Cast = class(expr) ex : Expr; desttype : integer; end; Expr_Special = class(Expr) spec : integer; ex : Expr; end; Expr_Loop = class(Expr) lStart : integer; init : Expr; ce : Expr; step : Expr; body : Expr; end; Expr_Rel = class(Expr) op : string; le, re : Expr; end; Expr_And = class(Expr) le, re : Expr; end; Expr_Or = class(Expr) le, re : Expr; end; Expr_Not = class(Expr) ex : Expr; end; Env_Entry = class(Root) id : string; lbl : integer; displ : integer; varTyp : integer; used : boolean; end; var labelNum : integer; globalCount : integer; tmp, varName, varGlob : string; curFunction : string; varType : integer; includeList : TStringList; environment : TList; f : textfile; procedure startCompiler(root : Expr); forward; procedure updateLabel(id : string; lbl : integer); forward; procedure addEnvironment(id : string; typ, lbl, varTyp : integer); forward; function lookupEnv(id : string; lookupCounts : boolean = false) : Env_Entry; forward; procedure compilerError(lineNum : integer; const fname, msg : string); forward; procedure compilerWarning(lineNum : integer; const fname, msg : string); forward; %} %token IDENTIFIER %token LINE %token <Integer> INT /* constants */ %token <Single> FLOAT /* constants */ %type <Integer> type_specifier %type <Expr> expr %type <Expr> stop_statement %type <Expr> function_definition %type <Expr> function_body %type <Expr> basic %type <Expr> basic_list %type <Expr> statement %type <Expr> statement_list %type <Expr> parameter_specifiers %type <Expr> parameter_specifier %type <Expr> parameter_list %type <Expr> function_body %type <Expr> compound_statement %type <Expr> declaration %type <Expr> declaration_list %type <Expr> declaration_specifiers %type <Expr> varname %type <Expr> asm_list %type <Expr> asm_statement %type <ShortString> declarator %type <ShortString> funcname %type <ShortString> idlist %left '|' %left '&' %left '+' '-' /* operators */ %left '*' '/' '%' %right UMINUS %start input %token ILLEGAL /* illegal token */ %token _IF _ELSE _ASM %token _TRUE _FALSE %token _AND _OR _NOT %token _RELGT _RELLT _RELGTE _RELLTE _RELEQ %token _RETURN _BREAK _CONTINUE %token _DO _SLEEP _WAIT _SIGNAL _WHILE _FOR _REQUIRE _EXPORT %token _VOID _INT _FLOAT _STRING _EXTERNAL %% input : /* empty */ | input '\n' { yyaccept; } | input basic_list { startCompiler($2); } | error '\n' { yyerrok; } ; basic_list : { $$ := nil; } | basic { $$ := $1; } | basic_list basic { $$ := Expr_Seq.Create; Expr_Seq($$).seq := $2; Expr_Seq($$).ex := $1; } ; statement_list : { $$ := nil; } | statement { $$ := $1; } | statement_list statement { $$ := Expr_Seq.Create; Expr_Seq($$).seq := $2; Expr_Seq($$).ex := $1; } ; stop_statement : { $$ := nil; } | _BREAK ';' { $$ := nil; } | _CONTINUE ';' { $$ := nil; } | _RETURN ';' { $$ := Expr_Return.Create; Expr_Return($$).ret := nil; Expr_Return($$).id := curFunction; } | _RETURN expr ';' { $$ := Expr_Return.Create; Expr_Return($$).ret := $2; Expr_Return($$).id := curFunction; } | _RETURN '(' expr ')' ';' { $$ := Expr_Return.Create; Expr_Return($$).ret := $3; Expr_Return($$).id := curFunction; } ; basic : { $$ := nil; } | declaration_list { $$ := $1; } | _EXPORT IDENTIFIER { $$ := nil; lookupEnv(varName, true); } | _REQUIRE '"' LINE '"' { $$ := nil; if (not FileExists(varName)) then compilerError(yylineno, yyfname, 'could not open include file ' + varName) else begin if (includeList.IndexOf(varName) > -1) then compilerWarning(yylineno, yyfname, 'ignoring previously included file ' + varName) else begin includeList.Add(varName); yyopen(varName); end; end; } ; statement : { $$ := nil; } | compound_statement { $$ := $1; if ($$ <> nil) then $$.lineNum := yylineno; } | expr ';' { $$ := $1; if ($$ <> nil) then $$.lineNum := yylineno; } | _IF '(' expr ')' statement _ELSE statement { $$ := Expr_If.Create; Expr_If($$).ce := $3; Expr_If($$).le := $5; Expr_If($$).re := $7; Expr_If($$).lThen := labelNum; inc(labelNum); Expr_If($$).lElse := labelNum; inc(labelNum); Expr_If($$).lAfter := labelNum; inc(labelNum); } | _IF '(' expr ')' statement { $$ := Expr_If.Create; Expr_If($$).ce := $3; Expr_If($$).le := $5; Expr_If($$).re := nil; Expr_If($$).lThen := labelNum; inc(labelNum); Expr_If($$).lAfter := labelNum; inc(labelNum); } | _FOR '('expr ';' expr ';' expr ')' statement { $$ := Expr_Loop.Create; Expr_Loop($$).init := $3; Expr_Loop($$).ce := $5; Expr_Loop($$).lStart := labelNum; inc(labelNum); Expr_Loop($$).step := $7; Expr_Loop($$).body := $9; } | _DO expr ';' { $$ := Expr_Special.Create; Expr_Special($$).spec := SPECIAL_TRAP; Expr_Special($$).ex := $2; } | _SLEEP expr ';' { $$ := Expr_Special.Create; Expr_Special($$).spec := SPECIAL_SLEEP; Expr_Special($$).ex := $2; } | _WAIT expr ';' { $$ := Expr_Special.Create; Expr_Special($$).spec := SPECIAL_WAIT; Expr_Special($$).ex := $2; } | _SIGNAL expr ';' { $$ := Expr_Special.Create; Expr_Special($$).spec := SPECIAL_SIGNAL; Expr_Special($$).ex := $2; } | _ASM '{' asm_list '}' { $$ := $3; } | stop_statement { $$ := $1; } | ';' { $$ := nil; } ; parameter_specifiers : { $$ := nil; } | parameter_specifier { $$ := $1; } | parameter_specifiers ',' parameter_specifier { $$ := nil; } ; parameter_specifier : type_specifier IDENTIFIER { $$ := nil; addEnvironment(curFunction + ':' + varName, varType, -1, VARTYPE_PARAM); } ; parameter_list : { $$ := nil; } | expr { $$ := $1; } | parameter_list ',' expr { $$ := Expr_Seq.Create; Expr_Seq($$).seq := $1; Expr_Seq($$).ex := $3; } ; asm_list : asm_statement { $$ := $1; } | asm_list asm_statement { $$ := Expr_Seq.Create; Expr_Seq($$).seq := $2; Expr_Seq($$).ex := $1; } ; asm_statement : '\"' LINE '\"' { $$ := Expr_Asm.Create; Expr_Asm($$).line := varName; } ; compound_statement : '{' '}' { $$ := Expr_Seq.Create; Expr_Seq($$).seq := nil; Expr_Seq($$).ex := nil; } | '{' declaration_list statement_list '}' { $$ := $3; } ; declaration_list : { $$ := nil; } | declaration { $$ := $1; } | declaration_list declaration { $$ := Expr_Seq.Create; Expr_Seq($$).seq := $2; Expr_Seq($$).ex := $1; } ; function_definition : type_specifier IDENTIFIER { curFunction := varName; $$ := Expr_Func.Create; Expr_Func($$).id := curFunction; Expr_Func($$).lStart := labelNum; inc(labelNum); addEnvironment(varName, varType, Expr_Func($$).lStart, VARTYPE_FUNCTION); } ; function_body : ';' { $$ := nil; } | compound_statement { $$ := $1; } ; declaration : type_specifier init_declarator_list ';' { $$ := nil; } | function_definition '(' parameter_specifiers ')' function_body { $$ := $1; Expr_Func($$).body := $5; if ($5 = nil) then updateLabel(curFunction, -1); curFunction := ''; } ; init_declarator_list : declarator | init_declarator_list ',' declarator ; declarator : IDENTIFIER { varName := curFunction + ':' + varName; $$ := varName; if (curFunction = '') then addEnvironment(varName, varType, -1, VARTYPE_GLOBAL) else addEnvironment(varName, varType, -1, VARTYPE_LOCAL); } type_specifier : _VOID { varType := _VOID; $$ := _VOID; } | _INT { varType := _INT; $$ := _INT; } | _FLOAT { varType := _FLOAT; $$ := _FLOAT; } | _STRING { varType := _STRING; $$ := _STRING; } | _EXTERNAL { varType := _EXTERNAL; $$ := _EXTERNAL; } ; expr : { $$ := nil; } | expr '+' expr { $$ := Expr_Op.Create; Expr_Op($$).op := '+'; Expr_Op($$).le := $1; Expr_Op($$).re := $3; } | expr '-' expr { $$ := Expr_Op.Create; Expr_Op($$).op := '-'; Expr_Op($$).le := $1; Expr_Op($$).re := $3; } | expr '*' expr { $$ := Expr_Op.Create; Expr_Op($$).op := '*'; Expr_Op($$).le := $1; Expr_Op($$).re := $3; } | expr '/' expr { $$ := Expr_Op.Create; Expr_Op($$).op := '/'; Expr_Op($$).le := $1; Expr_Op($$).re := $3; } | expr '%' expr { $$ := Expr_Op.Create; Expr_Op($$).op := '%'; Expr_Op($$).le := $1; Expr_Op($$).re := $3; } | expr '&' expr { $$ := Expr_Op.Create; Expr_Op($$).op := '&'; Expr_Op($$).le := $1; Expr_Op($$).re := $3; } | expr '|' expr { $$ := Expr_Op.Create; Expr_Op($$).op := '|'; Expr_Op($$).le := $1; Expr_Op($$).re := $3; } | '(' expr ')' { $$ := $2; } | '-' expr { $$ := Expr_Neg.Create; Expr_Neg($$).ex := $2; } %prec UMINUS | INT { $$ := Expr_ConstInt.Create; Expr_ConstInt($$).value := $1; } | FLOAT { $$ := Expr_ConstFloat.Create; Expr_ConstFloat($$).value := $1; } | '\"' '\"' { $$ := Expr_String.Create; Expr_String($$).value := ''; } | '\"' LINE '\"' { $$ := Expr_String.Create; Expr_String($$).value := varName; } | '(' type_specifier ')' expr { $$ := Expr_Cast.Create; Expr_Cast($$).ex := $4; Expr_Cast($$).desttype := $2; } | varname '=' expr { if ($1 <> nil) then begin $$ := Expr_Assign.Create; Expr_Assign($$).id := $1; Expr_Assign($$).ex := $3; end else $$ := nil; } | varname { $$ := $1; } | funcname '(' parameter_list ')' { if (lookupEnv($1) = nil) then begin compilerError(yylineno, yyfname, 'undefined function "' + $1 + '"'); $$ := nil; yyabort; end; $$ := Expr_Call.Create; Expr_Call($$).id := $1; Expr_Call($$).params := $3; } | expr _RELGT expr { $$ := Expr_Rel.Create; Expr_Rel($$).le := $1; Expr_Rel($$).op := '>'; Expr_Rel($$).re := $3; } | expr _RELLT expr { $$ := Expr_Rel.Create; Expr_Rel($$).le := $1; Expr_Rel($$).op := '<'; Expr_Rel($$).re := $3; } | expr _RELGTE expr { $$ := Expr_Rel.Create; Expr_Rel($$).le := $1; Expr_Rel($$).op := '>='; Expr_Rel($$).re := $3; } | expr _RELLTE expr { $$ := Expr_Rel.Create; Expr_Rel($$).le := $1; Expr_Rel($$).op := '=<'; Expr_Rel($$).re := $3; } | expr _RELEQ expr { $$ := Expr_Rel.Create; Expr_Rel($$).le := $1; Expr_Rel($$).op := '=='; Expr_Rel($$).re := $3; } | expr _AND expr { $$ := Expr_And.Create; Expr_And($$).le := $1; Expr_And($$).re := $3; $$.lineNum := yylineno;} | expr _OR expr { $$ := Expr_Or.Create; Expr_Or($$).le := $1; Expr_Or($$).re := $3; $$.lineNum := yylineno;} | _NOT expr { $$ := Expr_Not.Create; Expr_Not($$).ex := $2; }; | _TRUE { $$ := Expr_ConstInt.Create; Expr_ConstInt($$).value := 1; } | _FALSE { $$ := Expr_ConstInt.Create; Expr_ConstInt($$).value := 0; } ; funcname : IDENTIFIER { $$ := varName; } ; varname : idlist { varGlob := ':' + $1; tmp := curFunction + varGlob; varGlob := left(varGlob, '.'); varName := left(tmp, '.'); if (varName <> tmp) then begin if (lookupEnv(varName) <> nil) then begin $$ := Expr_External.Create; Expr_External($$).id := varName; Expr_External($$).assoc := right(tmp, '.'); end else begin compilerError(yylineno, yyfname, 'undeclared identifier "' + right(varGlob, ':') + '"'); $$ := nil; yyabort; end; end else if (lookupEnv(varName) <> nil) then begin $$ := Expr_Id.Create; Expr_Id($$).id := varName; end else if (lookupEnv(varGlob) <> nil) then begin $$ := Expr_Id.Create; Expr_Id($$).id := varGlob; end else begin compilerError(yylineno, yyfname, 'undeclared identifier "' + right(varGlob, ':') + '"'); $$ := nil; yyabort; end; } ; idlist : | IDENTIFIER { $$ := varName; } | idlist '.' IDENTIFIER { $$ := $1 + '.' + varName; } ; %% {$I gmclex.pas} var output : textfile; function typeExpr(expr : Expr) : Expr; forward; function optimizeExpr(expr : Expr) : Expr; forward; procedure showExpr(expr : Expr); forward; function typeToString(typ : integer) : string; forward; constructor Root.Create(); begin inherited Create(); lineNum := yylineno; fname := yyfname; end; procedure emit(line : string); begin writeln(output, line); end; procedure compilerError(lineNum : integer; const fname, msg : string); begin writeln('error (line ', lineNum, ', file ', fname, '): ', msg); yyerrors := true; end; procedure compilerWarning(lineNum : integer; const fname, msg : string); begin writeln('warning (line ', lineNum, ', file ', fname, '): ', msg); end; procedure updateLabel(id : string; lbl : integer); var a : integer; e : Env_Entry; begin for a := 0 to environment.count - 1 do begin e := environment[a]; if (e.id = id) then begin e.lbl := lbl; break; end; end; end; procedure addEnvironment(id : string; typ, lbl, varTyp : integer); var e : Env_Entry; begin if (lookupEnv(id) <> nil) then begin compilerError(yylineno, yyfname, 'identifier redeclared'); exit; end; e := Env_Entry.Create; e.id := id; e.typ := typ; e.lbl := lbl; e.varTyp := varTyp; e.used := false; e.lineNum := yylineno; e.fname := yyfname; if (varTyp = VARTYPE_GLOBAL) then begin e.displ := globalCount; inc(globalCount); end else e.displ := 0; environment.add(e); end; function lookupEnv(id : string; lookupCounts : boolean = false) : Env_Entry; var a : integer; e : Env_Entry; begin Result := nil; for a := 0 to environment.count - 1 do begin e := environment[a]; if (e.id = id) then begin if (lookupCounts) then e.used := true; Result := e; break; end; end; end; function typeToString(typ : integer) : string; begin case typ of _INT : Result := 'int'; _STRING : Result := 'string'; _FLOAT : Result := 'float'; _VOID : Result := 'void'; _EXTERNAL : Result := 'external'; else Result := 'unknown (' + IntToStr(typ) + ')'; end; end; function cleanIdentifier(const id : string) : string; begin Result := right(id, ':'); end; function reportEnvEntry(e : Env_Entry) : string; var typ : string; begin case e.varTyp of VARTYPE_LOCAL: typ := 'local variable'; VARTYPE_GLOBAL: typ := 'global variable'; VARTYPE_PARAM: typ := 'parameter'; VARTYPE_FUNCTION: typ := 'function'; VARTYPE_STATIC: typ := 'static variabel'; end; Result := typ + ' "' + cleanIdentifier(e.id) + '"'; end; function coerce(expr : Expr; src, dest: integer) : Expr; var cn : Expr_Conv; begin if ((src = _INT) or (src = _EXTERNAL)) and (dest = _FLOAT) then begin cn := Expr_Conv.Create; cn.ex := expr; cn.cnv := CONV_TO_FLOAT; cn.originaltyp := src; cn.typ := _FLOAT; Result := cn; end else if ((src = _INT) or (src = _FLOAT) or (src = _EXTERNAL)) and (dest = _STRING) then begin cn := Expr_Conv.Create; cn.ex := expr; cn.cnv := CONV_TO_STRING; cn.originaltyp := src; cn.typ := _STRING; Result := cn; end else begin compilerError(expr.lineNum, expr.fname, 'no appropriate conversion from ''' + typeToString(src) + ''' to ''' + typeToString(dest) + ''''); Result := expr; end; end; function typeExpr(expr : Expr) : Expr; var t1, t2 : integer; begin Result := expr; if (expr = nil) then exit; Result.typ := _VOID; if (expr is Expr_Op) then begin Expr_Op(expr).le := typeExpr(Expr_Op(expr).le); Expr_Op(expr).re := typeExpr(Expr_Op(expr).re); t1 := Expr_Op(expr).le.typ; t2 := Expr_Op(expr).re.typ; if (t1 <> t2) and (t1 <> _EXTERNAL) and (t2 <> _EXTERNAL) then Expr_Op(expr).re := coerce(Expr_Op(expr).re, t2, t1); expr.typ := t1; end else if (expr is Expr_Func) then begin Expr_Func(expr).body := typeExpr(Expr_Func(expr).body); expr.typ := lookupEnv(Expr_Func(expr).id).typ; end else if (expr is Expr_Return) then begin t1 := lookupEnv(Expr_Func(expr).id, true).typ; if (t1 = _VOID) then begin if (Expr_Return(expr).ret <> nil) then compilerError(expr.lineNum, expr.fname, 'can not assign return value to void function'); end else begin Expr_Return(expr).ret := typeExpr(Expr_Return(expr).ret); t2 := Expr_Return(expr).ret.typ; if (t1 <> t2) and (t1 <> _EXTERNAL) and (t2 <> _EXTERNAL) then Expr_Return(expr).ret := coerce(Expr_Return(expr).ret, t2, t1); end; end else if (expr is Expr_Call) then begin Expr_Call(expr).params := typeExpr(Expr_Call(expr).params); t1 := lookupEnv(Expr_Call(expr).id, true).typ; if (t1 <> -1) then expr.typ := t1 else expr.typ := _VOID; end else if (expr is Expr_ConstInt) then expr.typ := _INT else if (expr is Expr_ConstFloat) then expr.typ := _FLOAT else if (expr is Expr_External) then expr.typ := _EXTERNAL else if (expr is Expr_String) then expr.typ := _STRING else if (expr is Expr_Id) then begin t1 := lookupEnv(Expr_Id(expr).id, true).typ; if (t1 <> -1) then expr.typ := t1 else expr.typ := _VOID; end else if (expr is Expr_If) then begin Expr_If(expr).ce := typeExpr(Expr_If(expr).ce); Expr_If(expr).le := typeExpr(Expr_If(expr).le); Expr_If(expr).re := typeExpr(Expr_If(expr).re); expr.typ := _VOID; end else if (expr is Expr_Seq) then begin Expr_Seq(expr).ex := typeExpr(Expr_Seq(expr).ex); Expr_Seq(expr).seq := typeExpr(Expr_Seq(expr).seq); expr.typ := _VOID; end else if (expr is Expr_Assign) then begin Expr_Assign(expr).id := typeExpr(Expr_Assign(expr).id); Expr_Assign(expr).ex := typeExpr(Expr_Assign(expr).ex); t1 := Expr_Assign(expr).id.typ; t2 := Expr_Assign(expr).ex.typ; if (t1 <> t2) and (t1 <> _EXTERNAL) and (t2 <> _EXTERNAL) then Expr_Assign(expr).ex := coerce(Expr_Assign(expr).ex, t2, t1); expr.typ := _VOID; end else if (expr is Expr_Special) then begin Expr_Special(expr).ex := typeExpr(Expr_Special(expr).ex); expr.typ := Expr_Special(expr).ex.typ; end else if (expr is Expr_Loop) then begin Expr_Loop(expr).init := typeExpr(Expr_Loop(expr).init); Expr_Loop(expr).ce := typeExpr(Expr_Loop(expr).ce); Expr_Loop(expr).step := typeExpr(Expr_Loop(expr).step); Expr_Loop(expr).body := typeExpr(Expr_Loop(expr).body); end else if (expr is Expr_Cast) then begin Expr_Cast(expr).ex := typeExpr(Expr_Cast(expr).ex); t1 := Expr_Cast(expr).ex.typ; Result := coerce(Expr_Cast(expr).ex, t1, Expr_Cast(expr).desttype); Expr_Cast(expr).Free; end else if (expr is Expr_Rel) then begin Expr_Rel(expr).le := typeExpr(Expr_Rel(expr).le); Expr_Rel(expr).re := typeExpr(Expr_Rel(expr).re); t1 := Expr_Rel(expr).le.typ; t2 := Expr_Rel(expr).re.typ; if (t1 <> t2) and (t1 <> _EXTERNAL) and (t2 <> _EXTERNAL) then compilerError(expr.lineNum, expr.fname, 'no appropriate conversion from ''' + typeToString(t1) + ''' to ''' + typeToString(t2) + ''''); expr.typ := _INT; end else if (expr is Expr_Not) then begin Expr_Not(expr).ex := typeExpr(Expr_Not(expr).ex); t1 := Expr_Not(expr).ex.typ; if (t1 <> _INT) then compilerError(expr.lineNum, expr.fname, 'impossible to negate non-integer value'); expr.typ := _INT; end else if (expr is Expr_And) then begin Expr_And(expr).le := typeExpr(Expr_And(expr).le); Expr_And(expr).re := typeExpr(Expr_And(expr).re); t1 := Expr_And(expr).le.typ; t2 := Expr_And(expr).re.typ; if (t1 <> _INT) or (t2 <> _INT) then compilerError(expr.lineNum, expr.fname, 'impossible to and non-integer value'); expr.typ := _INT; end else if (expr is Expr_Or) then begin Expr_Or(expr).le := typeExpr(Expr_Or(expr).le); Expr_Or(expr).re := typeExpr(Expr_Or(expr).re); t1 := Expr_Or(expr).le.typ; t2 := Expr_Or(expr).re.typ; if (t1 <> _INT) or (t2 <> _INT) then compilerError(expr.lineNum, expr.fname, 'impossible to or non-integer value'); expr.typ := _INT; end; end; function optimizeExpr(expr : Expr) : Expr; var bval, lval, rval : integer; begin Result := expr; if (expr = nil) then exit; if (expr is Expr_Op) then begin Expr_Op(expr).le := optimizeExpr(Expr_Op(expr).le); Expr_Op(expr).re := optimizeExpr(Expr_Op(expr).re); if (Expr_Op(expr).le is Expr_ConstInt) and (Expr_Op(expr).re is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_Op(expr).le).value; rval := Expr_ConstInt(Expr_Op(expr).re).value; case Expr_Op(expr).op of '+': begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval + rval; end; '-': begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval - rval; end; '*': begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval * rval; end; '/': begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval div rval; end; '%': begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval mod rval; end; '&': begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval and rval; end; '|': begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval or rval; end; end; Expr_Op(expr).le.Free; Expr_Op(expr).re.Free; expr.Free; end; end else if (expr is Expr_Seq) then begin Expr_Seq(expr).ex := optimizeExpr(Expr_Seq(expr).ex); Expr_Seq(expr).seq := optimizeExpr(Expr_Seq(expr).seq); end else if (expr is Expr_Func) then begin if (not lookupEnv(Expr_Func(expr).id).used) then begin Result := nil; exit; end; Expr_Func(expr).body := optimizeExpr(Expr_Func(expr).body); end else if (expr is Expr_Return) then begin Expr_Return(expr).ret := optimizeExpr(Expr_Return(expr).ret); end else if (expr is Expr_Assign) then begin Expr_Assign(expr).ex := optimizeExpr(Expr_Assign(expr).ex); end else if (expr is Expr_Call) then begin Expr_Call(expr).params := optimizeExpr(Expr_Call(expr).params); end else if (expr is Expr_Conv) then begin Expr_Conv(expr).ex := optimizeExpr(Expr_Conv(expr).ex); case Expr_Conv(expr).cnv of CONV_TO_FLOAT : if (Expr_Conv(expr).ex is Expr_ConstInt) then begin Result := Expr_ConstFloat.Create; Expr_ConstFloat(Result).value := Expr_ConstInt(Expr_Conv(expr).ex).value; Expr_Conv(expr).ex.Free; expr.Free; end; CONV_TO_INT : if (Expr_Conv(expr).ex is Expr_ConstFloat) then begin Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := trunc(Expr_ConstFloat(Expr_Conv(expr).ex).value); Expr_Conv(expr).ex.Free; expr.Free; end; end; end else if (expr is Expr_If) then begin Expr_If(expr).ce := optimizeExpr(Expr_If(expr).ce); if (Expr_If(expr).ce is Expr_ConstInt) then begin bval := Expr_ConstInt(Expr_If(expr).ce).value; if (bval = 1) then Result := Expr_If(expr).le else Result := Expr_If(expr).re; end; end else if (expr is Expr_Loop) then begin Expr_Loop(expr).init := optimizeExpr(Expr_Loop(expr).init); Expr_Loop(expr).ce := optimizeExpr(Expr_Loop(expr).ce); Expr_Loop(expr).step := optimizeExpr(Expr_Loop(expr).step); Expr_Loop(expr).body := optimizeExpr(Expr_Loop(expr).body); end else if (expr is Expr_Rel) then begin Expr_Rel(expr).le := optimizeExpr(Expr_Rel(expr).le); Expr_Rel(expr).re := optimizeExpr(Expr_Rel(expr).re); end else if (expr is Expr_And) then begin Expr_And(expr).le := optimizeExpr(Expr_And(expr).le); Expr_And(expr).re := optimizeExpr(Expr_And(expr).re); if (Expr_And(expr).le is Expr_ConstInt) and (Expr_And(expr).re is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_And(expr).le).value; rval := Expr_ConstInt(Expr_And(expr).re).value; Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval and rval; Expr_And(expr).le.Free; Expr_And(expr).re.Free; expr.Free; end else if (Expr_And(expr).le is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_And(expr).le).value; if (lval = 1) then begin Result := Expr_And(expr).re; Expr_And(expr).le.Free; expr.Free; end else begin Result := Expr_And(expr).le; Expr_And(expr).re.Free; expr.Free; end; end else if (Expr_And(expr).re is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_And(expr).re).value; if (lval = 1) then begin Result := Expr_And(expr).le; Expr_And(expr).re.Free; expr.Free; end else begin Result := Expr_And(expr).re; Expr_And(expr).le.Free; expr.Free; end; end; end else if (expr is Expr_Or) then begin Expr_Or(expr).le := optimizeExpr(Expr_Or(expr).le); Expr_Or(expr).re := optimizeExpr(Expr_Or(expr).re); if (Expr_Or(expr).le is Expr_ConstInt) and (Expr_Or(expr).re is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_Or(expr).le).value; rval := Expr_ConstInt(Expr_Or(expr).re).value; Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := lval and rval; Expr_Or(expr).le.Free; Expr_Or(expr).re.Free; expr.Free; end else if (Expr_Or(expr).le is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_Or(expr).le).value; if (lval = 1) then begin Result := Expr_Or(expr).le; Expr_Or(expr).re.Free; expr.Free; end else begin Result := Expr_Or(expr).re; Expr_Or(expr).le.Free; expr.Free; end; end else if (Expr_Or(expr).re is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_Or(expr).re).value; if (lval = 1) then begin Result := Expr_Or(expr).re; Expr_Or(expr).le.Free; expr.Free; end else begin Result := Expr_Or(expr).le; Expr_Or(expr).re.Free; expr.Free; end; end; end else if (expr is Expr_Not) then begin Expr_Not(expr).ex := optimizeExpr(Expr_Not(expr).ex); if (Expr_Not(expr).ex is Expr_ConstInt) then begin lval := Expr_ConstInt(Expr_Not(expr).ex).value; Result := Expr_ConstInt.Create; Expr_ConstInt(Result).value := not lval; Expr_Not(expr).ex.Free; expr.Free; end; end; end; procedure showExpr(expr : Expr); var t : integer; num, displ, pdispl : integer; e : Env_Entry; begin if (expr = nil) then exit; if (expr is Expr_Op) then begin showExpr(Expr_Op(expr).le); showExpr(Expr_Op(expr).re); case Expr_Op(expr).op of '+': emit('ADD'); '-': emit('SUB'); '*': emit('MUL'); '/': emit('DIV'); '%': emit('MOD'); '&': emit('AND'); '|': emit('OR'); end; end else if (expr is Expr_ConstInt) then emit('PUSHI ' + IntToStr(Expr_ConstInt(expr).value)) else if (expr is Expr_ConstFloat) then emit('PUSHF ' + FloatToStr(Expr_ConstFloat(expr).value)) else if (expr is Expr_String) then emit('PUSHS ' + Expr_String(expr).value) else if (expr is Expr_If) then begin showExpr(Expr_If(expr).ce); if (Expr_If(expr).re = nil) and (Expr_If(expr).le = nil) then begin end else if (Expr_If(expr).re <> nil) then begin emit('JZ L' + IntToStr(Expr_If(expr).lElse)); emit('L' + IntToStr(Expr_If(expr).lThen) + ':'); showExpr(Expr_If(expr).le); emit('JMP L' + IntToStr(Expr_If(expr).lAfter)); emit('L' + IntToStr(Expr_If(expr).lElse) + ':'); showExpr(Expr_If(expr).re); end else begin emit('JZ L' + IntToStr(Expr_If(expr).lAfter)); emit('L' + IntToStr(Expr_If(expr).lThen) + ':'); showExpr(Expr_If(expr).le); end; emit('L' + IntToStr(Expr_If(expr).lAfter) + ':'); end else if (expr is Expr_Func) then begin if (Expr_Func(expr).body <> nil) then begin displ := 1; pdispl := -2; num := 0; for t := 0 to environment.count - 1 do begin e := environment[t]; if (pos(Expr_Func(expr).id + ':', e.id) > 0) then begin if (e.varTyp = VARTYPE_PARAM) then begin inc(num); e.displ := pdispl; dec(pdispl); end else if (e.varTyp = VARTYPE_LOCAL) then begin e.displ := displ; inc(displ); end; end; end; emit('L' + IntToStr(Expr_Func(expr).lStart) + ':'); emit('PUSHBP'); emit('MSPBP'); if (displ > 1) then emit('ADDSP ' + IntToStr(displ - 1)); showExpr(Expr_Func(expr).body); if (expr.typ <> _VOID) then begin emit('POPDISP ' + IntToStr(pdispl + 1)); dec(num); end; emit('MBPSP'); emit('POPBP'); if (num > 0) then begin emit('MTSD ' + IntToStr(num)); emit('SUBSP ' + IntToStr(num)); end; emit('RET'); end; end else if (expr is Expr_Return) then begin showExpr(Expr_Return(expr).ret); end else if (expr is Expr_Call) then begin t := lookupEnv(Expr_Call(expr).id, true).lbl; if (t > 0) then begin showExpr(Expr_Call(expr).params); emit('CALL L' + IntToStr(t)); end else if (t = -1) then begin showExpr(Expr_Call(expr).params); emit('CALLE ' + Expr_Call(expr).id); end; end else if (expr is Expr_Seq) then begin showExpr(Expr_Seq(expr).ex); showExpr(Expr_Seq(expr).seq); end else if (expr is Expr_Id) then begin e := lookupEnv(Expr_Id(expr).id, true); if (e.varTyp = VARTYPE_GLOBAL) then emit('PUSHR R' + IntToStr(e.displ)) else emit('PUSHDISP ' + IntToStr(e.displ)); end else if (expr is Expr_External) then begin e := lookupEnv(Expr_External(expr).id, true); if (e.varTyp = VARTYPE_GLOBAL) then emit('PUSHR R' + IntToStr(e.displ)) else emit('PUSHDISP ' + IntToStr(e.displ)); emit('PUSHS ' + Expr_External(expr).assoc); emit('GET'); end else if (expr is Expr_Assign) then begin showExpr(Expr_Assign(expr).ex); e := lookupEnv(Expr_Id(Expr_Assign(expr).id).id, true); { if (e.typ = _EXTERNAL) then emit('GET'); } if (e.varTyp = VARTYPE_GLOBAL) then emit('POPR R' + IntToStr(e.displ)) else emit('POPDISP ' + IntToStr(e.displ)); end else if (expr is Expr_Asm) then begin emit(Expr_Asm(expr).line); end else if (expr is Expr_Special) then begin showExpr(Expr_Special(expr).ex); case Expr_Special(expr).spec of SPECIAL_TRAP: emit('TRAP'); SPECIAL_SLEEP: emit('SLEEP'); SPECIAL_WAIT: emit('WAIT'); SPECIAL_SIGNAL: emit('SIGNAL'); end; end else if (expr is Expr_Conv) then begin showExpr(Expr_Conv(expr).ex); case Expr_Conv(expr).cnv of CONV_TO_INT : emit('TOI'); CONV_TO_FLOAT : emit('TOF'); CONV_TO_STRING : emit('TOS'); end; end else if (expr is Expr_Loop) then begin showExpr(Expr_Loop(Expr).init); emit('L' + IntToStr(Expr_Loop(expr).lStart) + ':'); showExpr(Expr_Loop(Expr).body); showExpr(Expr_Loop(Expr).step); showExpr(Expr_Loop(Expr).ce); emit('JNZ L' + IntToStr(Expr_Loop(expr).lStart)); end else if (expr is Expr_Rel) then begin showExpr(Expr_Rel(expr).le); showExpr(Expr_Rel(expr).re); if (Expr_Rel(expr).op = '>') then emit('GT') else if (Expr_Rel(expr).op = '<') then emit('LT') else if (Expr_Rel(expr).op = '>=') then emit('GTE') else if (Expr_Rel(expr).op = '=<') then emit('LTE') else if (Expr_Rel(expr).op = '==') then emit('EQ'); end else if (expr is Expr_Not) then begin showExpr(Expr_Not(expr).ex); emit('NOT'); end else if (expr is Expr_And) then begin showExpr(Expr_And(expr).le); showExpr(Expr_And(expr).re); emit('AND'); end else if (expr is Expr_Or) then begin showExpr(Expr_Or(expr).le); showExpr(Expr_Or(expr).re); emit('OR'); end; end; procedure optimizeEnvironment(); var e : Env_Entry; x : integer; begin for x := 0 to environment.Count - 1 do begin e := Env_Entry(environment[x]); if (e.varTyp in [VARTYPE_LOCAL,VARTYPE_GLOBAL,VARTYPE_STATIC]) and (not e.used) then begin compilerWarning(e.lineNum, e.fname, reportEnvEntry(e) + ' unused'); end; if (e.varTyp in [VARTYPE_FUNCTION]) and (e.lbl > -1) and (not e.used) then begin compilerWarning(e.lineNum, e.fname, reportEnvEntry(e) + ' unused, if incorrect add "export ' + cleanIdentifier(e.id) + '" at the end of the file'); end; end; environment.Pack(); end; procedure startCompiler(root : Expr); var a : integer; e : Env_Entry; begin root := typeExpr(root); optimizeEnvironment(); if (not yyerrors) then root := optimizeExpr(root); if (not yyerrors) then begin emit('$DATA ' + IntToStr(globalCount)); for a := 0 to environment.count - 1 do begin e := environment[a]; if (e.lbl > 0) and (e.used) then begin emit('$SYMBOL ' + e.id + ' L' + IntToStr(e.lbl)); end; end; showExpr(root); writeln('Output file written, datasize is ', globalCount, ' element(s).'); end; end; var ifname : string; ofname : string; {$IFDEF WIN32} SI : TStartupInfo; PI : TProcessInformation; ex : DWORD; {$ENDIF} begin DecimalSeparator := '.'; writeln('GMCC - GMC ''Elise'' compiler v0.3'#13#10); if (paramcount < 1) then begin writeln('gmcc <input file>'#13#10); { writeln(' -o turn optimizations on (not implemented at the moment)'); writeln(' -c just compile, do not call assembler'); } exit; end; ifname := paramstr(1); ofname := ChangeFileExt(ifname, '.asm'); if (not FileExists(ifname)) then begin writeln('Could not open ', ifname); exit; end; yyopen(ifname); assignfile(output, ofname); {$I-} rewrite(output); {$I+} if (IOresult <> 0) then begin writeln('Could not open ', ofname); exit; end; environment := TList.Create; includeList := TStringList.Create(); labelNum := 1; globalCount := 0; yylineno := 1; start(INITIAL); if yyparse=0 then { done; }; closefile(output); if (not yyerrors) then begin {$IFDEF WIN32} FillChar(SI, SizeOf(SI), 0); SI.cb := SizeOf(SI); CreateProcess(nil, PChar('gasm ' + ofname), nil, nil, false, NORMAL_PRIORITY_CLASS, nil, nil, SI, PI); repeat GetExitCodeProcess(PI.hProcess, ex); until (ex <> STILL_ACTIVE); {$ENDIF} end; end.