fixed bug in prepareStackForAbsOpt (rtemgr.c).
[bugg-scheme-compiler.git] / src / sml / cg.sml~
blobe191d5e70100d6652dd697f98dddcab2bb5f6e9c
1 (* Code Generation *)
3 (* Data Segment - initialized data segment (constants) *)
4 structure DataSegment: sig
5     val reset: unit -> unit            (* reset symbol and constant tables between code generations *)
6     val add: Sexpr -> string           (* register a new constant *)
7     val emit: unit -> string           (* emit code for all constants *)
8     val symbols: (string*string) list  (* fetch all constant symbols *)
9 end = struct
10     (* new_name - generate unique names *)
11     val initial_names =
12         ["a", "boot",
13         "sc_undef", "sc_void", "sc_nil", "sc_false_data", "sc_true_data"]
14     val (names:string list ref) = ref initial_names
16     local
17         fun is_new name = not (List.exists (fn n => n=name) (!names)) (* allocate new distinct name *)
18         fun add name = names := name :: !names                        (* add names to the table of existing ones *)
19     in
20         (* if the name is not in the table, register and return it,
21         otherwise, add an increasing number to it until a distinct name is found *)
22         fun new_name name =
23             if is_new name then
24             ( add name
25             ; name )
26             else
27             let fun subname name i =
28                 let val name' = name ^ (Int.toString i)
29                 in if is_new name' then
30                     ( add name'
31                     ; name' )
32                 else
33                     subname name (i + 1) end
34             in subname name 0 end
35     end; (* local *)
37     (* list of constants *)
38     val consts = ref [] : (string*Sexpr) list ref;
40     (* convert the collected consts to global variables in C *)
42     (* table of symbol names and representations;
43     used to
44         - maintain a single representation for all occurences of a symbol
45         - register symbols in run-time symbol table for symbol->string and string->symbol *)
46     val (symbols: (string*string) list ref) = ref []
48     (* return existing name for singletons, otherwise generate a new one;
49     the singletons are hardcoded once and forever, so that they are eq? comparable *)
50     fun const_name (x) =
51         case x of
52         Void => "sc_void"
53         | Nil => "sc_nil"
54         | Bool false => "sc_false"
55         | Bool true => "sc_true"
56         | Symbol s => (* symbols must be eq? comparable *)
57         (case List.find (fn sc => (#1 sc)=s) (!symbols)
58             of SOME sc => #2 sc
59              | NONE => let val name = new_name ("sc_symbol")
60                 in symbols := (s, name) :: (!symbols);
61                    name
62                 end)
63         | _ => (* anything else is just new constant every time *)
64         (new_name (case x 
65                 of (Pair _) => "sc_pair"
66                 | (Vector _) => "sc_vector"
67                 | (String _) => "sc_string"
68                 | (Number _) => "sc_number"
69                 | (Char _) => "sc_char"))
71     (* generate code for a single constant:
72         data definition
73     followed by
74         constant definition - a value of SchemeObject type *)
76     fun const_code (name, scheme_type, data_name, data_variant, data_value) =
77         "SchemeObjectData " ^ data_name ^ " = {" ^ "." ^ data_variant ^ " = {" ^ data_value ^ "}};\n" ^
78         "SchemeObject " ^ name ^ " = {" ^ scheme_type ^ ", &" ^ data_name ^ "};\n"
80     (* symbol representation is written once for every symbol *)
82     val (written_symbols: string list ref) = ref []
84     fun emit_const (name, value) = 
85         case value
86         of Pair (a,d) => emit_pair (name, a, d)
87         | Vector es => emit_vector (name, es)
88         | Symbol s => (* the same symbol may appear several times, but must be emitted only once *)
89         if (List.exists (fn n=>n=name) (!written_symbols))
90         then ""
91         else ( written_symbols := name :: (!written_symbols)
92             ; emit_symbol (name, s) )
93         | String s => emit_string (name, s)
94         | Number i => emit_number (name, i)
95         | Char c => emit_char (name, c)
96         | _ => "" (* singletons *)
98     and emit_pair (name, a, d) = 
99         let
100             val a_name = const_name (a)
101             val d_name = const_name (d)
102             val data_name = new_name (name ^ "_data")
103             (* recusrively define car and cdr *)
104             val a_code = emit_const (a_name, a)
105             val d_code = emit_const (d_name, d)
106         in (a_code ^ d_code ^ (const_code (name, "SCHEME_PAIR", data_name,
107                                 "spd", "&" ^ a_name ^ ", &" ^ d_name))) end
109     (* generates names and statements for a list of constants.
110        returns a list of names and a (matching) list of statements *)
111     and sexprs_to_stmts [] names stmts = (names,stmts)
112       | sexprs_to_stmts (em :: rest) names stmts =
113         let val name = const_name em        (* generate name *)
114             val stmt = emit_const (name,em) (* generate code *)
115         in
116             sexprs_to_stmts rest (names @ [name]) (stmts @ [stmt])
117         end
119     and emit_vector (name, es) =
120         let
121             (* generate names and statements for the vector elements *)
122             val (em_names,em_stmts) = sexprs_to_stmts es [] []
123             (* generate name,statement for the array that holds the elements *)
124             val arr_name = new_name (name^"_arr")
125             val arr_stmt = "SchemeObject* "^arr_name^"[] = {&"^
126                            (String.concatWith ", &" em_names)^"};\n"
127             val data_name = new_name (name^"_data")
128         in
129             (String.concat em_stmts)^
130             arr_stmt^
131             const_code (name, "SCHEME_VECTOR", data_name, "svd",
132                 (Int.toString (List.length es))^", "^arr_name)
133         end
135     and emit_symbol (name, s) =
136         let val data_name = new_name (name ^ "_data")
137             val syment_name = new_name (name ^ "_syment")
138         in ("SymbolEntry "^syment_name^" = {\""^(String.toCString s)^"\",0,NULL};\n"^
139             const_code (name, "SCHEME_SYMBOL", data_name, "smd",
140                 "&"^syment_name))
141         end
143     and emit_string (name, s) =
144         let val data_name = new_name (name ^ "_data")
145         in (const_code (name, "SCHEME_STRING", data_name, "ssd",
146                 (Int.toString (String.size s))^", \""^(String.toCString s)^"\""))
147         end
149     and emit_number (name, i) =
150         let val data_name = new_name (name ^ "_data")
151         in (const_code (name, "SCHEME_INT", data_name, "sid",
152                 "(int)" ^ (if i<0 then "-"^(Int.toString (~i))
153                                   else (Int.toString i))))
154         end
156     and emit_char (name, c) =
157         let val data_name = new_name (name ^ "_data")
158         in (const_code (name, "SCHEME_CHAR", data_name,
159                 "scd", "(char)" ^ (Int.toString (Char.ord c)))) end
161     fun reset () =
162         ( consts := []
163         ; symbols := []
164         ; written_symbols := [] )
166     fun add x =
167         let val name = const_name x
168         in consts := (name, x) :: (!consts) (* repeated symbols are detected in emit_const *)
169         ; name end
171     fun emit () = 
172         "SchemeObject sc_undef = {-1, NULL};\n" ^
173         "SchemeObject sc_void = {SCHEME_VOID, NULL};\n" ^
174         "SchemeObject sc_nil = {SCHEME_NIL, NULL};\n" ^
175         "SchemeObjectData sc_false_data = {.sbd = {0}};\n" ^
176         "SchemeObject sc_false = {SCHEME_BOOL, &sc_false_data};\n" ^
177         "SchemeObjectData sc_true_data = {.sbd = {1}};\n" ^
178         "SchemeObject sc_true = {SCHEME_BOOL, &sc_true_data};\n" ^
179         String.concat (map emit_const (List.rev (!consts)))
181     (* freeze the symbols *)
182     val symbols = !symbols
184 end; (* DataSegment *)
186 structure ErrType = struct
187     datatype Type =
188         None
189         | ArgsCount of string * int
190         | AppNonProc
191         | NotAPair
192         | UndefinedSymbol of string;
194     fun toString None = "\"\""
195         | toString (ArgsCount (proc,formals)) = "MSG_ERR_ARGCOUNT(\""^
196                                                 (String.toCString proc)^"\","^
197                                                 (intToCString formals)^")"
198         | toString AppNonProc = "MSG_ERR_APPNONPROC"
199         | toString NotAPair = "MSG_ERR_NOTPAIR"
200         | toString (UndefinedSymbol name) = "\"Symbol "^(String.toCString name)^" not defined\""
201 end;
203 structure CodeSegment (* : sig
204     val ErrType;
205     type StatementType;
206     val reset : unit -> unit;
207     val add : StatementType -> unit;
208     val emit : unit -> string;
209 end *) = struct
210     datatype StatementType =
211         Comment of string
212       | Debug of string
213       | Label of string
214       | Assertion of string * ErrType.Type
215       | Error of ErrType.Type
216       | ErrorIf of string * ErrType.Type
217       | Branch of string
218       | BranchIf of string * string
219       | Set of string * string
220       | Push of string
221       | Pop of string
222       | Return
223       | Statement of string;
225     fun statementToString (Statement stmt) = "\t"^stmt^";"
226       | statementToString (Set (n,v)) = "\t"^n^" = "^v^";"
227       | statementToString (Branch l) = "\tgoto "^l^";"
228       | statementToString (BranchIf (c,l)) = "\tif ("^c^") goto "^l^";"
229       | statementToString (Comment s) = "\t/* "^s^" */"
230       | statementToString (Debug s) = "\tfprintf(stderr,\"DEBUG: "^(String.toCString s)^"\\n\");"
231       | statementToString (Label s) = s^":"
232       | statementToString (Assertion (p,e)) = "\tASSERT_ALWAYS("^p^","^(ErrType.toString e)^");"
233       | statementToString (Error e) = "\tfprintf(stderr,"^(ErrType.toString e)^"); exit(-1);"
234       | statementToString (ErrorIf (p,e)) = "\tif ("^p^") {fprintf(stderr,"^(ErrType.toString e)^"); fprintf(stderr,\"%s %d\\n\",__FILE__,__LINE__); exit(-1);}"
235       | statementToString (Push s) = "\tpush("^s^");"
236       | statementToString (Pop s) = "\t"^s^" = pop();"
237       | statementToString Return = "\tRETURN();"
238     ;
240     val statements = ref [] : StatementType list ref;
242     fun reset () =
243         statements := [];
245     fun add stmt = statements := !statements @ [stmt];
247     fun emit () =
248         ""^
249         (String.concatWith "\n" (List.map statementToString (!statements)))^
250         "\n\t;";
252 end; (* CodeSegment *)
254 structure Program: sig
255     val reset : unit -> unit;
256     val gen : Expr -> int -> unit;
257     val emit : int * int -> string;
258 end = struct
260     fun makeLabeler prefix =
261         let
262             val number = ref 0;
263         in
264             fn () => (number:= !number + 1
265                      ;prefix^(Int.toString (!number)))
266         end;
268     val makeLabelElse = makeLabeler "else";
269     val makeLabelEndif = makeLabeler "endIf";
270     val makeLabelEndOr = makeLabeler "endOr";
271     val makeLabelSkipBody = makeLabeler "skipBody";
272     val makeLabelBody = makeLabeler "body";
273     val makeLabelRet = makeLabeler "ret";
274     val makeLabelApp = makeLabeler "app";
276     val CSadd = CodeSegment.add;
278     fun addProlog () =
279         (CSadd (CodeSegment.Comment "<push an initial activation frame>")
280         ;CSadd (CodeSegment.Comment "no arguments")
281         ;CSadd (CodeSegment.Push "0")
282         ;CSadd (CodeSegment.Comment "no enviroment")
283         ;CSadd (CodeSegment.Push "(int)NULL")
284         ;CSadd (CodeSegment.Comment "no return address (yet. will be set later)")
285         ;CSadd (CodeSegment.Push "(int)NULL")
286         ;CSadd (CodeSegment.Push "fp")
287         ;CSadd (CodeSegment.Set ("fp","sp"))
288         ;CSadd (CodeSegment.Comment "</push an initial activation frame>")
289         );
291     fun addEpilog () =
292         (CSadd (CodeSegment.Comment "<pop the initial activation frame>")
293         ;CSadd (CodeSegment.Pop "fp")
294         ;CSadd (CodeSegment.Comment "</pop the initial activation frame>")
295         );
297     fun reset () =
298         (DataSegment.reset ()
299         ;CodeSegment.reset ()
300         ;addProlog ()
301         );
303     fun maprtl f l = map f (List.rev l);
305     fun genDebug (App (VarFree name,_))   = CSadd (CodeSegment.Debug ("Applying free-var "^name))
306       | genDebug (AppTP (VarFree name,_)) = CSadd (CodeSegment.Debug ("Applying free-var "^name))
307       | genDebug (App (VarParam (name,_),_))   = CSadd (CodeSegment.Debug ("Applying param "^name))
308       | genDebug (AppTP (VarParam (name,_),_)) = CSadd (CodeSegment.Debug ("Applying param "^name))
309       | genDebug (App (VarBound (name,_,_),_))   = CSadd (CodeSegment.Debug ("Applying bound-var "^name))
310       | genDebug (AppTP (VarBound (name,_,_),_)) = CSadd (CodeSegment.Debug ("Applying bound-var "^name))
311       | genDebug _ = ()
312     ;
314     (* Generate code for a given expression
315        THE INVARIANT:      r_res contains the value of the
316                              expression after execution
317     *)
318     fun genExpr (Const se) absDepth =
319         let
320             val lblConst = DataSegment.add se
321         in
322             CSadd (CodeSegment.Set ("r_res","(int)&"^lblConst))
323         end
324       | genExpr (Var _)         absDepth = raise Match (* shouldn't be here *)
325       | genExpr (VarFree name)  absDepth =
326         let
327             val lblElse = makeLabelElse ()
328             val lblEndif = makeLabelEndif ()
329         in (* probe for symbol in runtime data-structure *)
330             (CSadd (CodeSegment.Set ("r_res","(int)probeSymbolDefined(\""^name^"\",topLevel)"))
331             ;CSadd (CodeSegment.BranchIf ("r_res==0",lblElse))
332             ;CSadd (CodeSegment.BranchIf ("! ((SymbolEntry*)r_res)->isDefined",lblElse))
333             ;CSadd (CodeSegment.Set ("r_res","(int)((SymbolEntry*)r_res)->sob"))
334             ;CSadd (CodeSegment.Branch lblEndif)
335             ;CSadd (CodeSegment.Label lblElse)
336             ;CSadd (CodeSegment.Error (ErrType.UndefinedSymbol name))
337             ;CSadd (CodeSegment.Label lblEndif)
338             )
339         end
340       | genExpr (VarParam (name,ndx))         absDepth =
341         (CSadd (CodeSegment.Assertion ("("^(intToCString ndx)^">=0) & ("^(intToCString ndx)^"<ST_ARG_COUNT())",ErrType.None))
342         ;CSadd (CodeSegment.Set ("r_res",("ST_ARG("^(intToCString ndx)^")")))
343         )
344       | genExpr (VarBound (name,major,minor)) absDepth =
345         CSadd (CodeSegment.Set ("r_res",("((int**)ST_ENV())["^(intToCString major)^"]["^(intToCString minor)^"]")))
346       | genExpr (If (test,dit,dif))           absDepth =
347         let
348             val lblElse = makeLabelElse ()
349             val lblEndif = makeLabelEndif ()
350             val lblFalse = DataSegment.add (Bool false)
351         in
352             (genExpr test absDepth
353             ;CSadd (CodeSegment.BranchIf ("(SchemeObject*)r_res==&"^lblFalse,lblElse))
354             ;genExpr dit absDepth
355             ;CSadd (CodeSegment.Branch lblEndif)
356             ;CSadd (CodeSegment.Label lblElse)
357             ;genExpr dif absDepth
358             ;CSadd (CodeSegment.Label lblEndif)
359             )
360         end
361       | genExpr (abs as Abs _)    absDepth = genAbs abs absDepth
362       | genExpr (abs as AbsOpt _) absDepth = genAbs abs absDepth
363       | genExpr (abs as AbsVar _) absDepth = genAbs abs absDepth
364       | genExpr (App (proc,args)) absDepth =
365         (genDebug (App (proc,args));
366         let
367             val lblRet = makeLabelRet ()
368             val lblApp = makeLabelApp ()
369         in
370             (* for each arg in args (backwards) do:
371                   evaluate arg
372                   push r_res to stack *)
373             ((maprtl (fn arg => (genExpr arg absDepth;
374                                  CSadd (CodeSegment.Push "r_res")))
375                      args)
376             (* push length(args) to stack *)
377             ;CSadd (CodeSegment.Push (intToCString (List.length args)))
378             (* evaluate proc *)
379             ;genExpr proc absDepth
380             (* if r_res is not a closure then: error *)
381             ;CSadd (CodeSegment.BranchIf ("IS_SOB_CLOSURE(r_res)",lblApp))
382             ;CSadd (CodeSegment.Error ErrType.AppNonProc)
383             ;CSadd (CodeSegment.Label lblApp)
384             (* push proc.env to stack *)
385             ;CSadd (CodeSegment.Push "(int)SOB_CLOSURE_ENV(r_res)")
386             (* push return address *)
387             ;CSadd (CodeSegment.Push ("(int)&&"^lblRet))
388             (* goto proc.code *)
389             ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))")
390             (* return address *)
391             ;CSadd (CodeSegment.Label lblRet)
392             (* restore sp - discard:
393                 - enviroment pointer (at sp-1)
394                 - n, the number of arguments (at sp-2)
395                 - n arguments *)
396             ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]"))
397             )
398         end
399         )
400       | genExpr (AppTP (proc,args))         absDepth =
401         (genDebug (AppTP (proc,args));
402         (* for each arg in args (backwards) do:
403                 evaluate arg
404                 push r_res to stack *)
405         ((maprtl (fn arg => (genExpr arg absDepth;
406                                 CSadd (CodeSegment.Push "r_res")))
407                     args)
408         (* push length(args) to stack *)
409         ;CSadd (CodeSegment.Push (intToCString (List.length args)))
410         (* evaluate proc *)
411         ;genExpr proc absDepth
412         (* if r_res is not a closure then: error *)
413         ;CSadd (CodeSegment.ErrorIf ("! IS_SOB_CLOSURE(r_res)",ErrType.AppNonProc))
414         (* push proc.env to stack *)
415         ;CSadd (CodeSegment.Push "(int)SOB_CLOSURE_ENV(r_res)")
416         (* push return address (of current activation frame) *)
417         ;CSadd (CodeSegment.Push "ST_RET()")
418         (* override current activation frame *)
419         ;CSadd (CodeSegment.Statement ("shiftActFrmDown()"))
420         (* goto proc.code *)
421         ;CSadd (CodeSegment.Branch "*(SOB_CLOSURE_CODE(r_res))")
422         (* restore sp - discard:
423                 - enviroment pointer (at sp-1)
424                 - n, the number of arguments (at sp-2)
425                 - n arguments *)
426         ;CSadd (CodeSegment.Set ("sp","sp-2-stack[sp-2]"))
427         )
428         )
429       | genExpr (Seq [])          absDepth = ()
430       | genExpr (Seq (e :: rest)) absDepth = (genExpr e absDepth; genExpr (Seq rest) absDepth)
431       | genExpr (Or preds)        absDepth =
432         let
433             val lblEndOr = makeLabelEndOr ()
434         in
435            (genOrPreds lblEndOr preds absDepth
436            ;CSadd (CodeSegment.Label lblEndOr)
437            )
438         end
439       | genExpr (Set ((VarFree name),value)) absDepth =
440         (* Set on VarFree is just the same as Def on VarFree *)
441         genExpr (Def ((VarFree name),value)) absDepth
442       | genExpr (Set ((VarParam (name,ndx)),value)) absDepth =
443         let val lblVoid = DataSegment.add Void
444         in
445             (genExpr value absDepth
446             ;CSadd (CodeSegment.Assertion ("("^(intToCString ndx)^">=0) & ("^(intToCString ndx)^"<ST_ARG_COUNT())",ErrType.None))
447             ;CSadd (CodeSegment.Set (("ST_ARG("^(intToCString ndx)^")"),"r_res"))
448             ;CSadd (CodeSegment.Set ("r_res","(int)&"^lblVoid))
449             )
450         end
451       | genExpr (Set ((VarBound (name,major,minor)),value)) absDepth =
452         let val lblVoid = DataSegment.add Void
453         in
454             (genExpr value absDepth
455             ;CSadd (CodeSegment.Set (("((int**)ST_ENV())["^(intToCString major)^"]["^(intToCString minor)^"]"),"r_res"))
456             ;CSadd (CodeSegment.Set ("r_res","(int)&"^lblVoid))
457             )
458         end
459       | genExpr (Def ((VarFree name),value)) absDepth =
460         let val lblVoid = DataSegment.add Void
461         in
462             (CSadd (CodeSegment.Debug ("binding symbol: "^name))
463             ;genExpr value absDepth
464             ;CSadd (CodeSegment.Set ("r[0]","(int)getSymbol(\""^name^"\",topLevel)"))
465             ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->isDefined","1"))
466             ;CSadd (CodeSegment.Set ("((SymbolEntry*)r[0])->sob","(SchemeObject*)r_res"))
467             ;CSadd (CodeSegment.Set ("r_res","(int)&"^lblVoid))
468             )
469         end
470       | genExpr (Def (_,_)) absDepth = raise Match (* shouldn't be here *)
471     and genOrPreds _ [] absDepth = ()
472       | genOrPreds lblEndOr (p :: rest) absDepth =
473         let
474             val lblFalse = DataSegment.add (Bool false)
475         in
476             (genExpr p absDepth
477             ;CSadd (CodeSegment.BranchIf ("(SchemeObject*)r_res!=&"^lblFalse,lblEndOr))
478             ;genOrPreds lblEndOr rest absDepth
479             )
480         end
481     and genAbs abs absDepth =
482         let
483             val formalParams = case abs of
484                 Abs    (params,_)   => List.length params
485               | AbsOpt (params,_,_) => List.length params + 1
486               | AbsVar (_,_)        => 1
487               | _ => raise Match (* shouldn't be here *)
488             val body = case abs of
489                 Abs    (_,body)   => body
490               | AbsOpt (_,_,body) => body
491               | AbsVar (_,body)   => body
492               | _ => raise Match (* shouldn't be here *)
493             val lblSkipBody = makeLabelSkipBody ()
494             val lblBody = makeLabelBody ()
495         in
496             (* 1. extend enviroment *)
497             (CSadd (CodeSegment.Set ("r[0]","(int)extendEnviroment( (int**)"^
498                                             (if absDepth=0 then "NULL"
499                                                            else "ST_ENV()")^
500                                             ", "^
501                                             (intToCString absDepth)^
502                                             ")"))
503             (* 2. prepare code *)
504             ;CSadd (CodeSegment.Branch lblSkipBody)
505             ;CSadd (CodeSegment.Label lblBody)
506             (* prolog *)
507             ;CSadd (CodeSegment.Push "fp")
508             ;CSadd (CodeSegment.Set ("fp","sp"))
509             (* fix stack if needed *)
510             ;case abs of
511                 (Abs _)    => ()
512               | (AbsOpt _) => CSadd (CodeSegment.Statement ("prepareStackForAbsOpt("^(intToCString formalParams)^")"))
513               | (AbsVar _) => CSadd (CodeSegment.Statement ("prepareStackForAbsOpt("^(intToCString formalParams)^")"))
514               | _ => raise Match (* shouldn't be here *)
515             (* verify number of actual arguments *)
516             ;CSadd (CodeSegment.ErrorIf ("ST_ARG_COUNT()!="^(intToCString formalParams),
517                                          (ErrType.ArgsCount ("user-procedure",formalParams))))
518             (* body *)
519             ;genExpr body (absDepth+1)
520             (* epilog *)
521             ;CSadd (CodeSegment.Pop ("fp"))
522             ;CSadd CodeSegment.Return
523             ;CSadd (CodeSegment.Label lblSkipBody)
524             (* 3. create closure *)
525             ;CSadd (CodeSegment.Set ("r_res","(int)makeSchemeClosure((void*)r[0],&&"^lblBody^")"))
526             )
527         end
528     ;
530     fun gen expr absDepth =
531         let
532             val lblRet = makeLabelRet ()
533         in
534             (* Set return address - the initial frame contains a dummy
535                return address. Here we set it to instruction after `expr`.
536                In case of several expressions compiled one after the other,
537                we could pop the initial activation frame (it was pushed in
538                addProlog) and push a new one. But since the only thing that
539                changes is the return address, we just hack it.
540             *)
541             (CSadd (CodeSegment.Comment "set return address")
542             ;CSadd (CodeSegment.Set ("ST_RET()","(int)&&"^lblRet))
543             (* Compile the expression *)
544             ;genExpr expr absDepth
545             (* Don't forget the return address.. *)
546             ;CSadd (CodeSegment.Label lblRet)
547             )
548         end
549     ;
551     fun emit (nregs,stacksize) =
552        (addEpilog ();
553         "/* COMP091 Scheme->C Compiler Generated Code */\n\n" ^
554         "#include \"scheme.h\"\n" ^
555         "#include \"assertions.h\"\n" ^
556         "#include \"arch.h\"\n" ^
557         "#include \"rtemgr.h\"\n" ^
558         "#include \"strings.h\"\n" ^
559         "extern SymbolNode *topLevel;\n"^
560         "\n/* Data Segment */\n" ^
561         (DataSegment.emit ()) ^
562         "\n/* Code Segment */\n" ^
563         "void schemeCompiledFunction() {\n" ^
564         "\t#include \"builtins.c\"\n\n"^
565         "\tinitArchitecture("^Int.toString(stacksize)^","^Int.toString(nregs)^");\n" ^
566         "\n" ^
567         (CodeSegment.emit ()) ^
568         "\n}\n"
569        );
571 end; (* Program *)