Improved bytecode output when calling a locally defined lambda.

tigerscheme.tig

@@ -13,6 +13,8 @@ let /* Booleans */
     var DEBUG_PRINT_TAPE   : bool := false
     var DEBUG_PRINT_PARSED : bool := false
     var DEBUG_PRINT_JUMPS  : bool := false
+    var DEBUG_PRINT_MACRO  : bool := true
+    var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false
 
     var ALLOW_TAPE_RESIZE  : bool := true
 
@@ -116,11 +118,14 @@ let /* Booleans */
     type pos = { at_char: int, line_num: int }
     function new_pos (line_num: int, at_char: int): pos =
       pos { at_char = at_char, line_num = line_num }
-    function line_num (pos: pos): int = pos.line_num
+    function line_num (pos: pos): int =
+      if pos <> nil
+        then pos.line_num
+        else -3
     function at_char  (pos: pos): int =
       if pos <> nil
         then pos.at_char
-        else -1
+        else -3
 
     function pos_delta_char (pos: pos, delta: int): pos =
       new_pos( line_num(pos)
@@ -128,9 +133,12 @@ let /* Booleans */
 
     var pos_unknown : pos := new_pos(-1, -1)
     var pos_preamble: pos := new_pos(-2, -2)
+    var pos_bad     : pos := new_pos(-3, -3)
 
     function pos_to_string (pos: pos): string =
-      if pos = pos_unknown
+      if pos <> nil
+        then "no position"
+      else if pos = pos_unknown
         then "unknown position"
       else if pos = pos_preamble
         then "preamble"
@@ -403,6 +411,13 @@ let /* Booleans */
       & b.typ = type_integer
       & a.val_i = b.val_i
 
+    function scheme_value_is_proper_list (ls: scheme_value): bool =
+      if ls = nil
+        then false
+        else ls.typ = type_nil
+           | ls.typ = type_pair
+           & scheme_value_is_proper_list(ls.val_cdr)
+
     /* evq? See for definition:
      * https://people.csail.mit.edu/jaffer/r5rs/Equivalence-predicates.html
      * */
@@ -594,7 +609,9 @@ let /* Booleans */
 
           function parse_rec (): sexp_ast =
             ( ignore_ws()
-            ; if is_symbol(index)
+            ; if index >= size(str)
+                then (parse_error("Reached end of string"); nil)
+              else if is_symbol(index)
                 then  let var start_pos := new_pos(line_number, index)
                       in while index < size(str) & is_symbol(index)
                             do index := index + 1
@@ -726,7 +743,9 @@ let /* Booleans */
              ; print("\n")
             end
 
-      in parse_rec()
+      in if size(str) > 0
+         then parse_rec()
+         else (parse_error("Nothing to parse. Given string empty!"); nil)
       end
 
    /**** Instructions ****/
@@ -781,6 +800,7 @@ let /* Booleans */
    var OPCODE_EXIT   := 27
    var OPCODE_EQV    := 28
    var OPCODE_CONCAT := 29
+   var OPCODE_FORGET := 32
 
    var OPCODE_DEBUG  := 31
 
@@ -821,6 +841,7 @@ let /* Booleans */
       ; code(OPCODE_RET,    "RET",     1, 0, 0)
 
       ; code(OPCODE_DEF,    "DEF",     0, 1, 0)
+      ; code(OPCODE_FORGET, "FORGET",  1, 0, 0)
       ; code(OPCODE_SETG,   "SETG",    0, 1, 0)
       ; code(OPCODE_DEFFUN, "DEFFUN",  1, 0, 0)
       ; code(OPCODE_POP,    "POP",     0, 0, 0)
@@ -988,6 +1009,7 @@ let /* Booleans */
                                                 , pos_r  = pos_r }))
       ; ())
 
+
    function app_insn2 (insns: vm_insn_list, opcode:int, arg3: scheme_value, pos_l: pos, pos_r: pos) =
       ( concat_lists(insns, single_insn(vm_insn { opcode = opcode
                                                 , arg1   = 0
@@ -1253,6 +1275,15 @@ let /* Booleans */
                    ; stdfun("exit")
                    ; app(OPCODE_EXIT, true, "")
 
+                   /* Misc??? */
+                   ; stdfun("symbol?")
+                   ; app(OPCODE_TYPEOF,  0, "")
+                   ; app2(OPCODE_PUSH,  int_val(type_symbol))
+                   ; app(OPCODE_NUMEQ,   0, "")
+                   ; app(OPCODE_RET,     1, "")
+
+
+
                    ; std_insns
                   end
 
@@ -1348,6 +1379,9 @@ let /* Booleans */
                          , value)
                , env )
 
+   function env_pop(env: vm_env): vm_env =
+       env.val_cdr
+
    function global_env_push (env: vm_env, key: string, value: vm_env_elem): vm_env =
        let
        in  if env.val_car.val_s <> GLOBAL_ENV_SENTINEL
@@ -1728,6 +1762,17 @@ let /* Booleans */
                      ; insns_car )
              end
 
+         function compile_load_of_arguments ( insns: vm_insn_list
+                                            , sexp_args: sexp_ast
+                                            , pos_l: pos
+                                            , pos_r: pos) =
+            if sexp_args = nil
+             | sexp_args.typ = type_nil
+             | sexp_args.val_car = nil
+             then ()
+            else ( compile_load_of_arguments(insns, sexp_args.val_cdr, pos_l, pos_r)
+                 ; app_insn(insns, OPCODE_DEF, 0, sexp_args.val_car.val_s, pos_l, pos_r) )
+
          function compile_rec ( ast: sexp_ast
                               , can_tail_call: bool
                               , expected_type: type_type ): vm_insn_list =
@@ -1744,8 +1789,13 @@ let /* Booleans */
              tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r, expected_type)
                               , can_tail_call)
 
+           else if ast.val_car = nil
+                 | ast.val_cdr = nil
+             then ( compile_error("Attemping to compile malformed ast", ast)
+                  ; nil )
+
              /* If statements */
-           else if ast.val_car <> nil
+           else if ast.val_car.typ   = type_symbol
                  & ast.val_car.val_s = "if"
              then let var insns_test := compile_rec(ast.val_cdr.val_car, false, type_any)
                       var insns_then := compile_rec(ast.val_cdr.val_cdr.val_car, can_tail_call, type_any)
@@ -1754,36 +1804,43 @@ let /* Booleans */
                                         else tail_position_one( atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)
                                                               , can_tail_call)
 
-                      var jump_then := sexp_ast_length(insns_then) + 1
+                      var jump_then := sexp_ast_length(insns_then) + 1 + (if can_tail_call then 0 else 1)
-                      var jump_else := sexp_ast_length(insns_else) + 1 + 1
+                      var jump_else := sexp_ast_length(insns_else) + 1
 
                       var pos_l := ast.pos_l
                       var pos_r := ast.pos_r
 
-                 in app_insn(insns_test, OPCODE_CSKIP, 2, "" , pos_l, pos_r)
+                 in app_insn(insns_test, OPCODE_CSKIP, jump_then, "" , pos_l, pos_r)
-                  ; app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
-                  ; concat_lists(insns_test, insns_else)
-                  ; app_insn(insns_test, OPCODE_DGOTO, jump_then, "" , pos_l, pos_r)
                   ; concat_lists(insns_test, insns_then)
+                  ; if not(can_tail_call)
+                    then app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
+                  ; concat_lists(insns_test, insns_else)
                   ; insns_test
                  end
 
              /* Define statements */
-           else if ast.val_car <> nil & ast.val_car.val_s = "define"
+           else if ast.val_car.typ   = type_symbol
+                 & ast.val_car.val_s = "define"
              then compile_define(ast)
 
              /* Syntax define statements */
-           else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
+           else if ast.val_car.typ   = type_symbol
+                 & ast.val_car.val_s = "define-syntax"
              then ( compile_error("Please do not compile define-syntax", ast)
                   ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r, 0)))
 
 
              /* Syntax rules expression */
+           /*
            else if ast.val_car <> nil & ast.val_car.val_s = "syntax-rules"
              then compile_syntax_rules(ast)
+             */
 
              /* Begin expressions */
-           else if ast.val_car <> nil & ast.val_car.val_s = "begin"
+             /* TODO: Implement using macroes, when those are
+              * available. */
+           else if ast.val_car.typ   = type_symbol
+                 & ast.val_car.val_s = "begin"
              then let var insns := vm_insn_list { first = nil, last = nil }
                       var head  := ast.val_cdr
 
@@ -1798,7 +1855,8 @@ let /* Booleans */
                  end
 
              /* Quote expressions */
-           else if ast.val_car <> nil & ast.val_car.val_s = "quote"
+           else if ast.val_car.typ   = type_symbol
+                 & ast.val_car.val_s = "quote"
              then let var datum := ast.val_cdr.val_car
 
                  in tail_position_one( vm_insn { opcode = OPCODE_PUSH
@@ -1811,7 +1869,8 @@ let /* Booleans */
                  end
 
              /* Quasi-Quote expressions */
-           else if ast.val_car <> nil & ast.val_car.val_s = "quasiquote"
+           else if ast.val_car.typ   = type_symbol
+                 & ast.val_car.val_s = "quasiquote"
              then let var datum := ast.val_cdr.val_car
                       var insns := compile_quasiquote(datum)
 
@@ -1827,7 +1886,8 @@ let /* Booleans */
                  end
 
              /* Set statements */
-           else if ast.val_car <> nil & ast.val_car.val_s = "set!"
+           else if ast.val_car.typ   = type_symbol
+                 & ast.val_car.val_s = "set!"
              then let var sym       := ast.val_cdr.val_car.val_s
                       var exp_insns := compile_rec(ast.val_cdr.val_cdr.val_car, false, type_any)
 
@@ -1837,46 +1897,30 @@ let /* Booleans */
                  end
 
              /* Lambda expressions */
-           else if ast.val_car <> nil & ast.val_car.val_s = "lambda"
+           else if ast.val_car.typ = type_symbol
+                 & ast.val_car.val_s  = "lambda"
+
              then let var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, true, type_any)
 
                       var pos_l := ast.pos_l
                       var pos_r := ast.pos_r
 
-                      function build_insns_arguments (args: sexp_ast, derp: vm_insn_list_link): vm_insn_list_link =
-                        if args = nil
-                         | args.typ = type_nil
-                         | args.val_car = nil
-                         then derp
-                        else
-                          build_insns_arguments( args.val_cdr
-                                               , vm_insn_list_link { insn = vm_insn { opcode = OPCODE_DEF
-                                                                                    , arg1 = 0
-                                                                                    , arg2 = args.val_car.val_s
-                                                                                    , arg3 = nil
-                                                                                    , pos_l = pos_l
-                                                                                    , pos_r = pos_r }
-                                                                   , next = derp })
-
-                      var insns_ass_args := list(build_insns_arguments(ast.val_cdr.val_car, nil))
-
                       var jump_lambda := sexp_ast_length(insns_body)
-                                       + sexp_ast_length(insns_ass_args)
+                                       + sexp_list_length(ast.val_cdr.val_car)
                                        + 1
 
                       var insns := vm_insn_list { first = nil, last = nil }
 
                  in app_insn(insns, OPCODE_DEFFUN, 2, "", pos_l, pos_r)
                   ; app_insn(insns, OPCODE_DGOTO, jump_lambda, "" , pos_l, pos_r)
-                  ; concat_lists(insns, insns_ass_args)
+                  ; compile_load_of_arguments(insns, ast.val_cdr.val_car, pos_l, pos_r)
                   ; concat_lists(insns, insns_body)
                   ; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r)
                   ; insns
                  end
 
              /* Macro applications */
-           else if ast.val_car <> nil
+           else if ast.val_car.typ = type_symbol
-                 & ast.val_car.typ = type_symbol
                  & ast.val_car.val_s <> ""
                  & env_seek_elem(env_macro, ast.val_car.val_s) <> nil
             then let var stack    := stack_new()
@@ -1895,9 +1939,59 @@ let /* Booleans */
                                         , ast)
                          ; TRIGGERED_EXIT := true
                          ; nil )
-                    else ( vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global)
+                    else let var derp: scheme_value := nil
-                            /* TODO: Assert that there is something on the stack */
+                         in vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global)
-                         ; compile_rec(stack_pop(stack), can_tail_call, type_any) )
+                          ; /* TODO: Assert that there is something on the stack */
+                            derp := stack_pop(stack)
+                          ; if DEBUG_PRINT_MACRO
+                            then ( print("Macro expanded to: ")
+                                 ; print(value_to_string(derp))
+                                 ; print("\n") )
+                          ; compile_rec(derp, can_tail_call, type_any)
+                         end
+                 end
+
+             /* Call-lambda expressions: A system for binding local
+              * variables */
+             /* Lambda expressions */
+           else if ast.val_car.typ = type_pair
+                 & ast.val_car.val_car.typ    = type_symbol
+                 & ast.val_car.val_car.val_s  = "lambda"
+
+                 /* Does not support non-proper lists, currently: */
+                 & scheme_value_is_proper_list (ast.val_car.val_cdr.val_car)
+             then
+             let var pos_l := ast.pos_l
+                 var pos_r := ast.pos_r
+
+                 var insns := vm_insn_list { first = nil, last = nil }
+
+                 var num_required_args := sexp_list_length (ast.val_car.val_cdr.val_car)
+                 var num_given_args    := sexp_list_length (ast.val_cdr)
+                 /* TODO: Give error when numbers of arguments does
+                  * not match */
+
+                 var ast_iter   := ast.val_cdr
+
+             in ()
+
+              /* First compile arguments onto stack */
+              ; while ast_iter <> nil & ast_iter.typ = type_pair
+                   do ( concat_lists(insns, compile_rec(ast_iter.val_car, false, type_any))
+                      ; ast_iter := ast_iter.val_cdr )
+
+              /* Then assign them to variables */
+              ; print(concat(value_to_string(ast.val_car.val_cdr.val_car), "\n"))
+              ; compile_load_of_arguments(insns, ast.val_car.val_cdr.val_car, pos_l, pos_r)
+
+              /* Perform body */
+              ; concat_lists(insns, compile_rec(ast.val_car.val_cdr.val_cdr.val_car, can_tail_call, type_any))
+
+              /* Forget variables again */
+              ; app_insn(insns, OPCODE_FORGET, num_required_args, "", pos_l, pos_r)
+
+              /* Return instructions */
+              ; insns
              end
 
              /* Call expressions */
@@ -1926,8 +2020,8 @@ let /* Booleans */
                  end
 
          function compile_error(errmsg: string, errast: sexp_ast) =
-          let var repr_pos_l := pos_to_string(errast.pos_l)
+          let var repr_pos_l := pos_to_string(if errast = nil then nil else errast.pos_l)
-              var repr_pos_r := pos_to_string(errast.pos_r)
+              var repr_pos_r := pos_to_string(if errast = nil then nil else errast.pos_r)
           in print("Tiger-scheme compile error\n    ")
            ; print(errmsg)
            ; print("\n    For scheme: ")
@@ -1940,8 +2034,12 @@ let /* Booleans */
            ; print("\n")
           end
 
-        var base_insns := compile_rec(ast, false, type_any)
+        var base_insns :=
-     in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
+            if ast = nil
+              then (compile_error("Given ast was nil!", ast); nil)
+              else compile_rec(ast, false, type_any)
+     in if ast <> nil
+        then app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
       ; base_insns
      end
 
@@ -2163,9 +2261,12 @@ let /* Booleans */
                           if value = nil
                           then run_error(concat5( "Attempting to access unknown variable \""
                                                 , tape[ip].arg2
-                                                , "\"\n    Environment looks like "
+                                                , "\"\n"
-                                                , env_to_string(env)
+                                                , ""
-                                                , ""))
+                                                , if DEBUG_SHOW_FULL_ENVIRONMENT
+                                                  then concat( "\tEnvironment looks like "
+                                                              , env_to_string(env))
+                                                  else ""))
                           else if tape[ip].arg1 <> 0
                                 & tape[ip].arg1 <> value.typ
                           then run_error(concat6( "Attempting to access variable \""
@@ -2185,6 +2286,11 @@ let /* Booleans */
                         ; ip  := ip + 1
                        end
 
+            else if tape[ip].opcode = OPCODE_FORGET
+                  then ( for i := 1 to tape[ip].arg1
+                            do env := env_pop(env)
+                       ; ip := ip + 1 )
+
             else if tape[ip].opcode = OPCODE_SETG
                   then let var value    := stack_pop(stack)
                            var new_env  := global_env_push(global_env, tape[ip].arg2, value)
@@ -2450,14 +2556,26 @@ let /* Booleans */
      let var depth := 0
          var char  := "BAD SHIT HAPPENED"
          var text  := ""
+         var comment_mode := false
      in while char <> ""
            do ( char := getchar()
               ; text := concat(text, char)
-              ; if char = "("
+              ; if comment_mode
+                 & char = "\n"
+                  then comment_mode := false
+                else if comment_mode
+                  then () /* Do nothing */
+
+              /* We can assume that comment mode is not enabled for
+               * these: */
+                else if char = "("
                   then depth := depth + 1
                 else if char = ")"
                   then ( depth := depth - 1
-                       ; if depth = 0 then break ))
+                       ; if depth = 0 then break )
+                else if char = ";"
+                  then comment_mode := true
+              )
       ; text
      end
 
@@ -2473,9 +2591,12 @@ in print("Ready for the scheming Tiger?\n")
 
                 var macro_name  := "" /* Not macro is "" */
 
-                var sexp  := parse_string(text)
+                var sexp  := if size(text) > 0
+                             then parse_string(text)
+                             else nil
                 var sexp_compile :=
-                  if sexp.typ = type_pair
+                  if sexp <> nil
+                   & sexp.typ = type_pair
                    & sexp.val_car.typ   = type_symbol
                    & sexp.val_car.val_s = "define-syntax"
                     then ( macro_name := sexp.val_cdr.val_car.val_s