From 6eca9fe5bf4e35e10245517974e337143e7913ce Mon Sep 17 00:00:00 2001 From: Itamar Date: Tue, 10 Mar 2009 00:41:25 +0200 Subject: [PATCH] fixed SP restoration. Changed to: sp <- sp-2-stack[sp-2] It was simply: sp <- fp Which is a problem if we have an application in the middle of evaluating arguments for another application, like: (f 5 (g 12) 6). If we use sp<-fp we override the already evaluated "6" and the stack turns to a big pile of shit.. --- compiler.sml | 29 +++++++------ src/c/arch.h | 2 +- src/c/arch.h~ | 9 ++-- src/c/builtins.c | 106 +++++++++++++++++++++++++++++++++++++-------- src/c/builtins.c~ | 107 ++++++++++++++++++++++++++++++++++++++-------- src/scm/support-code.scm | 18 ++++---- src/scm/support-code.scm~ | 18 ++++---- src/sml/cg.sml | 42 +++++++++++++----- src/sml/cg.sml~ | 42 +++++++++++++----- 9 files changed, 282 insertions(+), 91 deletions(-) diff --git a/compiler.sml b/compiler.sml index 38cd0df..1342680 100644 --- a/compiler.sml +++ b/compiler.sml @@ -74,19 +74,24 @@ fun fileToString (filename : string) = structure CodeGen : CODE_GEN = struct -fun cg (e : Expr) : string = - (Program.reset (); - (Program.gen e 0); - Program.emit (8,1024*10)) + fun cg (e : Expr) : string = + (Program.reset (); + (Program.gen e 0); + Program.emit (8,1024*10)) -fun compile str = - (Program.reset () - ;map (fn expr => (Program.gen (SemanticAnalysis.semanticAnalysis expr) 0)) - (TagParser.stringToPEs str) - ;Program.emit (8,1024*10) - ); + fun compile str = + (Program.reset () + ;map (fn expr => (Program.gen (SemanticAnalysis.semanticAnalysis expr) 0)) + (TagParser.stringToPEs str) + ;Program.emit (8,1024*10) + ); -fun compileSchemeFile (infile:string, outfile:string) : unit = - stringToFile (outfile, (compile (fileToString infile))); + fun compileSchemeFile (infile:string, outfile:string) : unit = + stringToFile ( + outfile, + (compile ( (fileToString "./src/scm/support-code.scm")^ + (fileToString infile)))); end; (* of struct CodeGen *) + + diff --git a/src/c/arch.h b/src/c/arch.h index 367622e..59e83c6 100644 --- a/src/c/arch.h +++ b/src/c/arch.h @@ -15,7 +15,7 @@ int pop(); /* The stack when in a user procedure: fp -> | | - | fp | - points to the old fp (before this application) + | fp | - the old fp (before this application) | ret | - return address | env | - points to the enviroment vector | n | - number of arguments diff --git a/src/c/arch.h~ b/src/c/arch.h~ index 367622e..c0d18c1 100644 --- a/src/c/arch.h~ +++ b/src/c/arch.h~ @@ -15,8 +15,9 @@ int pop(); /* The stack when in a user procedure: fp -> | | - | fp | - points to the old fp (before this application) + | fp | - the old fp (before this application) | ret | - return address + | sp | - the old sp (before entering this procedure) | env | - points to the enviroment vector | n | - number of arguments | A0 | - argument 0 @@ -30,11 +31,11 @@ int pop(); Macros for user procedures: */ -#define ST_ARG(n) (stack[fp-5-(n)]) -#define ST_ARG_COUNT() (stack[fp-4]) +#define ST_ARG(n) (stack[fp-6-(n)]) +#define ST_ARG_COUNT() (stack[fp-5]) #define ST_OLDFP() (stack[fp-1]) #define ST_RET() (stack[fp-2]) -#define ST_ENV() (stack[fp-3]) +#define ST_ENV() (stack[fp-4]) #define RETURN() goto *pop() /* General Purpose Registers */ diff --git a/src/c/builtins.c b/src/c/builtins.c index 354a4a0..ea48a48 100644 --- a/src/c/builtins.c +++ b/src/c/builtins.c @@ -29,21 +29,21 @@ goto Lstart; /* skip all definitions */ Lcar: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT(1) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("car",1) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); r_res = (int)SOB_PAIR_CAR(r[0]); BI_RETURN(); Lcdr: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT(1) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("cdr",1) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); r_res = (int)SOB_PAIR_CDR(r[0]); BI_RETURN(); Lsymbol: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT(1) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("symbol?",1) ); r[0] = BI_ST_ARG(0); if ( IS_SOB_SYMBOL(r[0]) ) goto Lsymbol_true; r_res = (int)&sc_false; @@ -53,7 +53,7 @@ Lsymbol_true: BI_RETURN(); Lset_car: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("set-car!",2) ); r[0] = BI_ST_ARG(0); r[1] = BI_ST_ARG(1); ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); @@ -62,7 +62,7 @@ Lset_car: BI_RETURN(); Lmake_vector: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT(1) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT("make-vector",1) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); r[0] = SOB_INT_VALUE(r[0]); @@ -74,7 +74,7 @@ Lmake_vector: BI_RETURN(); Lvector_set: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT(3) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT("vector-set!",3) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), ""); r[1] = BI_ST_ARG(1); @@ -86,7 +86,7 @@ Lvector_set: BI_RETURN(); Lvector_ref: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("vector-ref",2) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), ""); r[1] = BI_ST_ARG(1); @@ -96,7 +96,7 @@ Lvector_ref: BI_RETURN(); LbinaryEQ: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary=?",2) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); @@ -111,7 +111,7 @@ LbinaryEQ_false: BI_RETURN(); LbinaryADD: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT(2) ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-add",2) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); @@ -122,16 +122,86 @@ LbinaryADD: r_res = (int)makeSchemeInt( r_res ); BI_RETURN(); +LbinarySUB: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-sub",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); + r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), ""); + r[1] = SOB_INT_VALUE((SchemeObject*)r[1]); + r_res = r[0] - r[1]; + r_res = (int)makeSchemeInt( r_res ); + BI_RETURN(); + +LbinaryMUL: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-mul",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); + r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), ""); + r[1] = SOB_INT_VALUE((SchemeObject*)r[1]); + r_res = (int)r[0] * (int)r[1]; /* multiply as signed integers */ + r_res = (int)makeSchemeInt( r_res ); + BI_RETURN(); + +LbinaryDIV: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-div",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); + r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), ""); + r[1] = SOB_INT_VALUE((SchemeObject*)r[1]); + r_res = (int)r[0] / (int)r[1]; /* divide as signed integers */ + r_res = (int)makeSchemeInt( r_res ); + BI_RETURN(); + +LbinaryLT: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary */ diff --git a/src/c/builtins.c~ b/src/c/builtins.c~ index 29b6e73..801ee2a 100644 --- a/src/c/builtins.c~ +++ b/src/c/builtins.c~ @@ -13,6 +13,7 @@ /* The stack when in a built-in precedure (there is no fp): sp -> | | | ret | - return address + | sp | - the old sp (before entering this procedure) | env | - points to the enviroment vector | n | - number of arguments | A0 | - argument 0 @@ -29,21 +30,21 @@ goto Lstart; /* skip all definitions */ Lcar: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("car",1) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); r_res = (int)SOB_PAIR_CAR(r[0]); BI_RETURN(); Lcdr: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("cdr",1) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); r_res = (int)SOB_PAIR_CDR(r[0]); BI_RETURN(); Lsymbol: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("symbol?",1) ); r[0] = BI_ST_ARG(0); if ( IS_SOB_SYMBOL(r[0]) ) goto Lsymbol_true; r_res = (int)&sc_false; @@ -53,7 +54,7 @@ Lsymbol_true: BI_RETURN(); Lset_car: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("set-car!",2) ); r[0] = BI_ST_ARG(0); r[1] = BI_ST_ARG(1); ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR ); @@ -62,7 +63,7 @@ Lset_car: BI_RETURN(); Lmake_vector: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT("make-vector",1) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); r[0] = SOB_INT_VALUE(r[0]); @@ -74,7 +75,7 @@ Lmake_vector: BI_RETURN(); Lvector_set: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT("vector-set!",3) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), ""); r[1] = BI_ST_ARG(1); @@ -86,7 +87,7 @@ Lvector_set: BI_RETURN(); Lvector_ref: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("vector-ref",2) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), ""); r[1] = BI_ST_ARG(1); @@ -96,7 +97,7 @@ Lvector_ref: BI_RETURN(); LbinaryEQ: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary=?",2) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); @@ -111,7 +112,7 @@ LbinaryEQ_false: BI_RETURN(); LbinaryADD: - ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT ); + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-add",2) ); r[0] = BI_ST_ARG(0); ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); @@ -122,16 +123,86 @@ LbinaryADD: r_res = (int)makeSchemeInt( r_res ); BI_RETURN(); +LbinarySUB: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-sub",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); + r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), ""); + r[1] = SOB_INT_VALUE((SchemeObject*)r[1]); + r_res = r[0] - r[1]; + r_res = (int)makeSchemeInt( r_res ); + BI_RETURN(); + +LbinaryMUL: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-mul",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); + r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), ""); + r[1] = SOB_INT_VALUE((SchemeObject*)r[1]); + r_res = (int)r[0] * (int)r[1]; /* multiply as signed integers */ + r_res = (int)makeSchemeInt( r_res ); + BI_RETURN(); + +LbinaryDIV: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-div",2) ); + r[0] = BI_ST_ARG(0); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), ""); + r[0] = SOB_INT_VALUE((SchemeObject*)r[0]); + r[1] = BI_ST_ARG(1); + ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), ""); + r[1] = SOB_INT_VALUE((SchemeObject*)r[1]); + r_res = (int)r[0] / (int)r[1]; /* divide as signed integers */ + r_res = (int)makeSchemeInt( r_res ); + BI_RETURN(); + +LbinaryLT: + ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary */ diff --git a/src/scm/support-code.scm b/src/scm/support-code.scm index 8f2921d..847a9f2 100644 --- a/src/scm/support-code.scm +++ b/src/scm/support-code.scm @@ -22,10 +22,10 @@ (define foldr (lambda (binop final s) - (letrec ((loop - (lambda (s) - (if (null? s) final - (binop (car s) (loop (cdr s))))))) + (letrec ((loop (lambda (s) + (if (null? s) + final + (binop (car s) (loop (cdr s))))))) (loop s)))) (define add1 (lambda (n) (binary-add n 1))) @@ -425,8 +425,8 @@ o(define ormap (/ (apply * s) (apply gcd s)))) -(define box - (lambda (x) - (let ((v (make-vector 1))) - (vector-set! v 0 x) - v))) \ No newline at end of file +;(define box +; (lambda (x) +; (let ((v (make-vector 1))) +; (vector-set! v 0 x) +; v))) diff --git a/src/scm/support-code.scm~ b/src/scm/support-code.scm~ index 8f2921d..847a9f2 100644 --- a/src/scm/support-code.scm~ +++ b/src/scm/support-code.scm~ @@ -22,10 +22,10 @@ (define foldr (lambda (binop final s) - (letrec ((loop - (lambda (s) - (if (null? s) final - (binop (car s) (loop (cdr s))))))) + (letrec ((loop (lambda (s) + (if (null? s) + final + (binop (car s) (loop (cdr s))))))) (loop s)))) (define add1 (lambda (n) (binary-add n 1))) @@ -425,8 +425,8 @@ o(define ormap (/ (apply * s) (apply gcd s)))) -(define box - (lambda (x) - (let ((v (make-vector 1))) - (vector-set! v 0 x) - v))) \ No newline at end of file +;(define box +; (lambda (x) +; (let ((v (make-vector 1))) +; (vector-set! v 0 x) +; v))) diff --git a/src/sml/cg.sml b/src/sml/cg.sml index c16c8f1..0b1d9b3 100644 --- a/src/sml/cg.sml +++ b/src/sml/cg.sml @@ -186,13 +186,15 @@ end; (* DataSegment *) structure ErrType = struct datatype Type = None - | ArgsCount of int + | ArgsCount of string * int | AppNonProc | NotAPair | UndefinedSymbol of string; fun toString None = "\"\"" - | toString (ArgsCount expected) = "MSG_ERR_ARGCOUNT("^(intToCString expected)^")" + | toString (ArgsCount (proc,formals)) = "MSG_ERR_ARGCOUNT(\""^ + (String.toCString proc)^"\","^ + (intToCString formals)^")" | toString AppNonProc = "MSG_ERR_APPNONPROC" | toString NotAPair = "MSG_ERR_NOTPAIR" | toString (UndefinedSymbol name) = "\"Symbol "^(String.toCString name)^" not defined\"" @@ -207,6 +209,7 @@ structure CodeSegment (* : sig end *) = struct datatype StatementType = Comment of string + | Debug of string | Label of string | Assertion of string * ErrType.Type | Error of ErrType.Type @@ -224,10 +227,11 @@ end *) = struct | statementToString (Branch l) = "\tgoto "^l^";" | statementToString (BranchIf (c,l)) = "\tif ("^c^") goto "^l^";" | statementToString (Comment s) = "\t/* "^s^" */" + | statementToString (Debug s) = "" (* "\tfprintf(stderr,\"DEBUG: "^(String.toCString s)^"\\n\");" *) | statementToString (Label s) = s^":" | statementToString (Assertion (p,e)) = "\tASSERT_ALWAYS("^p^","^(ErrType.toString e)^");" | statementToString (Error e) = "\tfprintf(stderr,"^(ErrType.toString e)^"); exit(-1);" - | statementToString (ErrorIf (p,e)) = "\tif ("^p^") {fprintf(stderr,"^(ErrType.toString e)^"); exit(-1);}" + | statementToString (ErrorIf (p,e)) = "\tif ("^p^") {fprintf(stderr,"^(ErrType.toString e)^"); fprintf(stderr,\"%s %d\\n\",__FILE__,__LINE__); exit(-1);}" | statementToString (Push s) = "\tpush("^s^");" | statementToString (Pop s) = "\t"^s^" = pop();" | statementToString Return = "\tRETURN();" @@ -298,6 +302,15 @@ end = struct fun maprtl f l = map f (List.rev l); + fun genDebug (App (VarFree name,_)) = CSadd (CodeSegment.Debug ("Applying free-var "^name)) + | genDebug (AppTP (VarFree name,_)) = CSadd (CodeSegment.Debug ("Applying free-var "^name)) + | genDebug (App (VarParam (name,_),_)) = CSadd (CodeSegment.Debug ("Applying param "^name)) + | genDebug (AppTP (VarParam (name,_),_)) = CSadd (CodeSegment.Debug ("Applying param "^name)) + | genDebug (App (VarBound (name,_,_),_)) = CSadd (CodeSegment.Debug ("Applying bound-var "^name)) + | genDebug (AppTP (VarBound (name,_,_),_)) = CSadd (CodeSegment.Debug ("Applying bound-var "^name)) + | genDebug _ = () + ; + (* Generate code for a given expression THE INVARIANT: r_res contains the value of the expression after execution @@ -349,6 +362,7 @@ end = struct | genExpr (abs as AbsOpt _) absDepth = genAbs abs absDepth | genExpr (abs as AbsVar _) absDepth = genAbs abs absDepth | genExpr (App (proc,args)) absDepth = + (genDebug (App (proc,args)); let val lblRet = makeLabelRet () val lblApp = makeLabelApp () @@ -375,10 +389,16 @@ end = struct ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))") (* return address *) ;CSadd (CodeSegment.Label lblRet) - ;CSadd (CodeSegment.Set ("sp","fp")) + (* restore sp - discard: + - enviroment pointer (at sp-1) + - n, the number of arguments (at sp-2) + - n arguments *) + ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]")) ) end + ) | genExpr (AppTP (proc,args)) absDepth = + (genDebug (AppTP (proc,args)); (* for each arg in args (backwards) do: evaluate arg push r_res to stack *) @@ -400,13 +420,14 @@ end = struct (* goto proc.code *) ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))") ) - | genExpr (Seq []) absDepth = () - | genExpr (Seq (e :: rest)) absDepth = (genExpr e absDepth; genExpr (Seq rest) absDepth) - | genExpr (Or preds) absDepth = + ) + | genExpr (Seq []) absDepth = () + | genExpr (Seq (e :: rest)) absDepth = (genExpr e absDepth; genExpr (Seq rest) absDepth) + | genExpr (Or preds) absDepth = let val lblEndOr = makeLabelEndOr () in - (genOrPreds lblEndOr preds + (genOrPreds lblEndOr preds absDepth ;CSadd (CodeSegment.Label lblEndOr) ) end @@ -433,7 +454,8 @@ end = struct | genExpr (Def ((VarFree name),value)) absDepth = let val lblVoid = DataSegment.add Void in - (genExpr value absDepth + (CSadd (CodeSegment.Debug ("binding symbol: "^name)) + ;genExpr value absDepth ;CSadd (CodeSegment.Set ("r[0]","(int)getSymbol(\""^name^"\",topLevel)")) ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->isDefined","1")) ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->sob","(SchemeObject*)r_res")) @@ -487,7 +509,7 @@ end = struct | _ => raise Match (* shouldn't be here *) (* verify number of actual arguments *) ;CSadd (CodeSegment.ErrorIf ("ST_ARG_COUNT()!="^(intToCString formalParams), - (ErrType.ArgsCount formalParams))) + (ErrType.ArgsCount ("user-procedure",formalParams)))) (* body *) ;genExpr body (absDepth+1) (* epilog *) diff --git a/src/sml/cg.sml~ b/src/sml/cg.sml~ index c16c8f1..db5d1c6 100644 --- a/src/sml/cg.sml~ +++ b/src/sml/cg.sml~ @@ -186,13 +186,15 @@ end; (* DataSegment *) structure ErrType = struct datatype Type = None - | ArgsCount of int + | ArgsCount of string * int | AppNonProc | NotAPair | UndefinedSymbol of string; fun toString None = "\"\"" - | toString (ArgsCount expected) = "MSG_ERR_ARGCOUNT("^(intToCString expected)^")" + | toString (ArgsCount (proc,formals)) = "MSG_ERR_ARGCOUNT(\""^ + (String.toCString proc)^"\","^ + (intToCString formals)^")" | toString AppNonProc = "MSG_ERR_APPNONPROC" | toString NotAPair = "MSG_ERR_NOTPAIR" | toString (UndefinedSymbol name) = "\"Symbol "^(String.toCString name)^" not defined\"" @@ -207,6 +209,7 @@ structure CodeSegment (* : sig end *) = struct datatype StatementType = Comment of string + | Debug of string | Label of string | Assertion of string * ErrType.Type | Error of ErrType.Type @@ -224,10 +227,11 @@ end *) = struct | statementToString (Branch l) = "\tgoto "^l^";" | statementToString (BranchIf (c,l)) = "\tif ("^c^") goto "^l^";" | statementToString (Comment s) = "\t/* "^s^" */" + | statementToString (Debug s) = "\tfprintf(stderr,\"DEBUG: "^(String.toCString s)^"\\n\");" | statementToString (Label s) = s^":" | statementToString (Assertion (p,e)) = "\tASSERT_ALWAYS("^p^","^(ErrType.toString e)^");" | statementToString (Error e) = "\tfprintf(stderr,"^(ErrType.toString e)^"); exit(-1);" - | statementToString (ErrorIf (p,e)) = "\tif ("^p^") {fprintf(stderr,"^(ErrType.toString e)^"); exit(-1);}" + | statementToString (ErrorIf (p,e)) = "\tif ("^p^") {fprintf(stderr,"^(ErrType.toString e)^"); fprintf(stderr,\"%s %d\\n\",__FILE__,__LINE__); exit(-1);}" | statementToString (Push s) = "\tpush("^s^");" | statementToString (Pop s) = "\t"^s^" = pop();" | statementToString Return = "\tRETURN();" @@ -298,6 +302,15 @@ end = struct fun maprtl f l = map f (List.rev l); + fun genDebug (App (VarFree name,_)) = CSadd (CodeSegment.Debug ("Applying free-var "^name)) + | genDebug (AppTP (VarFree name,_)) = CSadd (CodeSegment.Debug ("Applying free-var "^name)) + | genDebug (App (VarParam (name,_),_)) = CSadd (CodeSegment.Debug ("Applying param "^name)) + | genDebug (AppTP (VarParam (name,_),_)) = CSadd (CodeSegment.Debug ("Applying param "^name)) + | genDebug (App (VarBound (name,_,_),_)) = CSadd (CodeSegment.Debug ("Applying bound-var "^name)) + | genDebug (AppTP (VarBound (name,_,_),_)) = CSadd (CodeSegment.Debug ("Applying bound-var "^name)) + | genDebug _ = () + ; + (* Generate code for a given expression THE INVARIANT: r_res contains the value of the expression after execution @@ -349,6 +362,7 @@ end = struct | genExpr (abs as AbsOpt _) absDepth = genAbs abs absDepth | genExpr (abs as AbsVar _) absDepth = genAbs abs absDepth | genExpr (App (proc,args)) absDepth = + (genDebug (App (proc,args)); let val lblRet = makeLabelRet () val lblApp = makeLabelApp () @@ -375,10 +389,16 @@ end = struct ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))") (* return address *) ;CSadd (CodeSegment.Label lblRet) - ;CSadd (CodeSegment.Set ("sp","fp")) + (* restore sp - discard: + - enviroment pointer (at sp-1) + - n, the number of arguments (at sp-2) + - n arguments *) + ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]")) ) end + ) | genExpr (AppTP (proc,args)) absDepth = + (genDebug (AppTP (proc,args)); (* for each arg in args (backwards) do: evaluate arg push r_res to stack *) @@ -400,13 +420,14 @@ end = struct (* goto proc.code *) ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))") ) - | genExpr (Seq []) absDepth = () - | genExpr (Seq (e :: rest)) absDepth = (genExpr e absDepth; genExpr (Seq rest) absDepth) - | genExpr (Or preds) absDepth = + ) + | genExpr (Seq []) absDepth = () + | genExpr (Seq (e :: rest)) absDepth = (genExpr e absDepth; genExpr (Seq rest) absDepth) + | genExpr (Or preds) absDepth = let val lblEndOr = makeLabelEndOr () in - (genOrPreds lblEndOr preds + (genOrPreds lblEndOr preds absDepth ;CSadd (CodeSegment.Label lblEndOr) ) end @@ -433,7 +454,8 @@ end = struct | genExpr (Def ((VarFree name),value)) absDepth = let val lblVoid = DataSegment.add Void in - (genExpr value absDepth + (CSadd (CodeSegment.Debug ("binding symbol: "^name)) + ;genExpr value absDepth ;CSadd (CodeSegment.Set ("r[0]","(int)getSymbol(\""^name^"\",topLevel)")) ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->isDefined","1")) ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->sob","(SchemeObject*)r_res")) @@ -487,7 +509,7 @@ end = struct | _ => raise Match (* shouldn't be here *) (* verify number of actual arguments *) ;CSadd (CodeSegment.ErrorIf ("ST_ARG_COUNT()!="^(intToCString formalParams), - (ErrType.ArgsCount formalParams))) + (ErrType.ArgsCount ("user-procedure",formalParams)))) (* body *) ;genExpr body (absDepth+1) (* epilog *) -- 2.11.4.GIT