From 0c5103cffe6e1baccaad62d0ab61375be3fdc2f9 Mon Sep 17 00:00:00 2001 From: Itamar Ben Zaken Date: Wed, 18 Mar 2009 00:12:59 +0200 Subject: [PATCH] another update in support-code.scm --- compiler.sml | 2 +- makefile | 4 ++-- src/c/rtemgr.h | 10 ++++++++++ src/scm/support-code.scm | 48 +++++++++++++++++++++++++++++++++++++++------ src/sml/cg.sml | 51 +++++++++++++++++++----------------------------- 5 files changed, 75 insertions(+), 40 deletions(-) diff --git a/compiler.sml b/compiler.sml index cff755e..51a0df9 100644 --- a/compiler.sml +++ b/compiler.sml @@ -89,7 +89,7 @@ struct fun compileSchemeFile (infile:string, outfile:string) : unit = stringToFile ( outfile, - (compile ((fileToString "./src/scm/support-code.scm")^ + (compile ((*(fileToString "./src/scm/support-code.scm")^*) (fileToString infile)))); end; (* of struct CodeGen *) diff --git a/makefile b/makefile index 7b70734..fd09d05 100644 --- a/makefile +++ b/makefile @@ -1,4 +1,4 @@ -COMPILE=@gcc -c -g -Wall -ansi +COMPILE=@gcc -c -Wall -ansi LINK=@gcc ./build: @@ -26,6 +26,6 @@ LINK=@gcc %: %.c ./build ./build/scheme.o ./build/arch.o ./build/main.o ./build/rtemgr.o @echo Compiling $*.o - $(COMPILE) -I ./src/c/ -o $*.o $*.c + $(COMPILE) -I ./src/c/ -I ./inc/ -o $*.o $*.c @echo Linking: $* $(LINK) -o $* $*.o ./build/main.o ./build/scheme.o ./build/arch.o ./build/rtemgr.o diff --git a/src/c/rtemgr.h b/src/c/rtemgr.h index 53568c2..5c528af 100644 --- a/src/c/rtemgr.h +++ b/src/c/rtemgr.h @@ -13,4 +13,14 @@ void prepareStackForAbsOpt(int formalParams); SchemeObject* reverseSchemeList( SchemeObject* list ); void pushArgsList(SchemeObject* list); +#define PUSH_INITIAL_ACTFRM() \ + push(0); /* no arguments */ \ + push((int)NULL); /* no enviroment */ \ + push((int)NULL); /* no return address (yet. will be set later) */ \ + push(fp); \ + fp = sp; + +#define POP_INITIAL_ACTFRM() \ + fp = pop(); + #endif diff --git a/src/scm/support-code.scm b/src/scm/support-code.scm index f75b8b4..2145df2 100644 --- a/src/scm/support-code.scm +++ b/src/scm/support-code.scm @@ -22,11 +22,11 @@ ;;; Use this procedure for boxing your variables ;;; when removing set! during the semantic analysis -;(define box -; (lambda (x) -; (let ((v (make-vector 1))) -; (vector-set! v 0 x) -; v))) +(define box + (lambda (x) + (let ((v (make-vector 1))) + (vector-set! v 0 x) + v))) (define foldr (lambda (binop final s) @@ -152,6 +152,7 @@ (lambda (ch1 ch2) (int-op (char->integer ch1) (char->integer ch2))))) +(define char=? (order (^char-op =))) (define char<=? (order (^char-op <=))) (define char=? (order (^char-op >=))) @@ -290,6 +291,41 @@ (lambda (str) (loop str (- (string-length str) 1) '())))) +(define binary-string=? + (lambda (str1 str2) + (let ((n1 (string-length str1)) + (n2 (string-length str2))) + (and (= n1 n2) + (let ((s1 (string->list str1)) + (s2 (string->list str2))) + (andmap char=? s1 s2)))))) + +(define binary-stringlist str1) + (string->list str2))))) + +(define binary-string>? (lambda (str1 str2) (binary-string? str1 str2)))) + +(define binary-string>=? + (lambda (str1 str2) (not (binary-string? (order binary-string>?)) +(define string<=? (order binary-string<=?)) +(define string>=? (order binary-string>=?)) + (define vector->list (letrec ((loop (lambda (v n s) @@ -327,7 +363,7 @@ (define member (lambda (a s) (cond ((null? s) #f) - ((eq? (car s) a) s) + ((equal? (car s) a) s) (else (member a (cdr s)))))) (define assoc diff --git a/src/sml/cg.sml b/src/sml/cg.sml index f87f3d7..dd9f2de 100644 --- a/src/sml/cg.sml +++ b/src/sml/cg.sml @@ -1,5 +1,7 @@ (* Code Generation *) +val namesPrefix = ""; (* Prefix all generated names with this string *) + (* Data Segment - initialized data segment (constants) *) structure DataSegment: sig val reset: unit -> unit (* reset symbol and constant tables between code generations *) @@ -21,6 +23,8 @@ end = struct (* if the name is not in the table, register and return it, otherwise, add an increasing number to it until a distinct name is found *) fun new_name name = + let val name = namesPrefix^name + in if is_new name then ( add name ; name ) @@ -33,6 +37,7 @@ end = struct else subname name (i + 1) end in subname name 0 end + end end; (* local *) (* list of constants *) @@ -55,12 +60,12 @@ end = struct | Bool false => "sc_false" | Bool true => "sc_true" | Symbol s => (* symbols must be eq? comparable *) - (case List.find (fn sc => (#1 sc)=s) (!symbols) - of SOME sc => #2 sc - | NONE => let val name = new_name ("sc_symbol") - in symbols := (s, name) :: (!symbols); - name - end) + (case List.find (fn sc => (#1 sc)=s) (!symbols) + of SOME sc => #2 sc + | NONE => let val name = new_name ("sc_symbol") + in symbols := (s, name) :: (!symbols); + name + end) | _ => (* anything else is just new constant every time *) (new_name (case x of (Pair _) => "sc_pair" @@ -296,7 +301,7 @@ end = struct val number = ref 0; in fn () => (number:= !number + 1 - ;prefix^(Int.toString (!number))) + ;namesPrefix^prefix^(Int.toString (!number))) end; val makeLabelElse = makeLabeler "else"; @@ -309,29 +314,9 @@ end = struct val CSadd = CodeSegment.add; - fun addProlog () = - (CSadd (CodeSegment.Comment "") - ;CSadd (CodeSegment.Comment "no arguments") - ;CSadd (CodeSegment.Push "0") - ;CSadd (CodeSegment.Comment "no enviroment") - ;CSadd (CodeSegment.Push "(int)NULL") - ;CSadd (CodeSegment.Comment "no return address (yet. will be set later)") - ;CSadd (CodeSegment.Push "(int)NULL") - ;CSadd (CodeSegment.Push "fp") - ;CSadd (CodeSegment.Set ("fp","sp")) - ;CSadd (CodeSegment.Comment "") - ); - - fun addEpilog () = - (CSadd (CodeSegment.Comment "") - ;CSadd (CodeSegment.Pop "fp") - ;CSadd (CodeSegment.Comment "") - ); - fun reset () = (DataSegment.reset () ;CodeSegment.reset () - ;addProlog () ); fun maprtl f l = map f (List.rev l); @@ -583,8 +568,7 @@ end = struct ; fun emit (nregs,stacksize) = - (addEpilog (); - "/* COMP091 Scheme->C Compiler Generated Code */\n\n" ^ + ("/* COMP091 Scheme->C Compiler Generated Code */\n\n" ^ "#include \"scheme.h\"\n" ^ "#include \"assertions.h\"\n" ^ "#include \"arch.h\"\n" ^ @@ -594,15 +578,20 @@ end = struct "\n/* Data Segment Declerations */\n" ^ (DataSegment.emitDeclerations ()) ^ "/* End of Data Segment Declerations */\n" ^ + "#include \"initial.dseg\"\n"^ "\n/* Code Segment */\n" ^ "void schemeCompiledFunction() {\n" ^ "\t#include \"builtins.c\"\n\n"^ "\tinitArchitecture("^Int.toString(stacksize)^","^Int.toString(nregs)^");\n" ^ "\n" ^ - "/* Data Segment initialization */\n"^ + "\t/* Data Segment initialization */\n"^ (DataSegment.emitInitializers ()) ^"\n"^ - "/* End of Data Segment initialization */\n"^ + "\t/* End of Data Segment initialization */\n"^ + "\tPUSH_INITIAL_ACTFRM();\n"^ + "\t#include \"initial.cseg\"\n"^ (CodeSegment.emit ()) ^ + "\n"^ + "\tPOP_INITIAL_ACTFRM();\n"^ "\n}\n" ); -- 2.11.4.GIT