src/sml/cg.sml~

   1 (* Code Generation *)
   2
   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
  15
  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 *)
  36
  37     (* list of constants *)
  38     val consts = ref [] : (string*Sexpr) list ref;
  39
  40     (* convert the collected consts to global variables in C *)
  41
  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 []
  47
  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"))
  70
  71     (* generate code for a single constant:
  72         data definition
  73     followed by
  74         constant definition - a value of SchemeObject type *)
  75
  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"
  79
  80     (* symbol representation is written once for every symbol *)
  81
  82     val (written_symbols: string list ref) = ref []
  83
  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 *)
  97
  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
 108
 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
 118
 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
 134
 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
 142
 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
 148
 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
 155
 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
 160
 161     fun reset () =
 162         ( consts := []
 163         ; symbols := []
 164         ; written_symbols := [] )
 165
 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
 170
 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)))
 180
 181     (* freeze the symbols *)
 182     val symbols = !symbols
 183
 184 end; (* DataSegment *)
 185
 186 structure ErrType = struct
 187     datatype Type =
 188         None
 189         | ArgsCount of string * int
 190         | AppNonProc
 191         | NotAPair
 192         | UndefinedSymbol of string;
 193
 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;
 202
 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;
 224
 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     ;
 239
 240     val statements = ref [] : StatementType list ref;
 241
 242     fun reset () =
 243         statements := [];
 244
 245     fun add stmt = statements := !statements @ [stmt];
 246
 247     fun emit () =
 248         ""^
 249         (String.concatWith "\n" (List.map statementToString (!statements)))^
 250         "\n\t;";
 251
 252 end; (* CodeSegment *)
 253
 254 structure Program: sig
 255     val reset : unit -> unit;
 256     val gen : Expr -> int -> unit;
 257     val emit : int * int -> string;
 258 end = struct
 259
 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;
 267
 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";
 275
 276     val CSadd = CodeSegment.add;
 277
 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         );
 290
 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         );
 296
 297     fun reset () =
 298         (DataSegment.reset ()
 299         ;CodeSegment.reset ()
 300         ;addProlog ()
 301         );
 302
 303     fun maprtl f l = map f (List.rev l);
 304
 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     ;
 313
 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     ;
 529
 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     ;
 550
 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        );
 570
 571 end; (* Program *)