Implemented basic macros

example.scm

@@ -143,8 +143,26 @@
 (display "* Testing Macro system *")
 (newline)
 
+; Test define-syntax
+
+(display "Test define-syntax:\n    Expect: 4 ()\n    Gotten: ")
+
+(define-syntax const
+  (lambda (so)
+    (cons 'lambda (cons '() (cdr so)))))
+
+(define x (const 4))
+(display (x))
+(display " ")
+(define x (const '()))
+(display (x))
+(display "\n")
+
 ; Test syntax-rules
 
+
+
+
 (define-syntax and
  (syntax-rules ()
     ((and) #t)

tigerscheme.tig

@@ -10,6 +10,9 @@ let /* Booleans */
     var IS_NIL_TRUTHY     : bool := false
     var HAS_NIL_SYMBOL    : bool := false
     var DEBUG_PRINT_STACK : bool := false
+    var DEBUG_PRINT_TAPE  : bool := false
+
+    var TRIGGERED_EXIT : bool := false
 
     /* Basic utility */
 
@@ -66,7 +69,9 @@ let /* Booleans */
     function safe_substring (str: string, i_start: int, i_end: int): string =
       ( i_start := max(0, i_start)
       ; i_end   := min(size(str) - 1, i_end)
-      ; substring(str, i_start, i_end - i_start + 1) )
+      ; if i_start > i_end
+        then ""
+        else substring(str, i_start, i_end - i_start + 1) )
 
     /* Source positioning */
 
@@ -74,16 +79,23 @@ let /* Booleans */
     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 at_char  (pos: pos): int = pos.at_char
+    function at_char  (pos: pos): int =
+      if pos <> nil
+        then pos.at_char
+        else -1
+
     function pos_delta_char (pos: pos, delta: int): pos =
       new_pos( line_num(pos)
              , at_char (pos) + delta)
 
-    var pos_unknown: pos := nil
+    var pos_unknown : pos := new_pos(-1, -1)
+    var pos_preamble: pos := new_pos(-2, -2)
 
     function pos_to_string (pos: pos): string =
       if pos = pos_unknown
         then "unknown position"
+      else if pos = pos_preamble
+        then "preamble"
       else
         concat("line ", int_to_string(line_num(pos)))
 
@@ -531,32 +543,6 @@ let /* Booleans */
       in parse_rec()
       end
 
-    function sexp_ast_to_string (ast: sexp_ast): string =
-      let function tostr_rec (ast: sexp_ast, nil_implicit: int): string =
-            if ast = nil then "SOMEBODY FUCKED UP"
-            else if ast.typ = type_nil & nil_implicit
-                 then ""
-            else if ast.typ = type_pair & ast.val_car.typ <> type_pair
-                 then let var s_left  := tostr_rec(ast.val_car, 0)
-                          var s_right := tostr_rec(ast.val_cdr, 1)
-                      in concat(s_left, if s_right <> ""
-                                        then concat(" ", s_right)
-                                        else "")
-                      end
-
-            else if ast.typ = type_pair
-                 then let var s_left  := tostr_rec(ast.val_car, 0)
-                          var s_right := tostr_rec(ast.val_cdr, 1)
-                      in concat("(",
-                         concat(s_left,
-                         concat(")", if s_right <> ""
-                                     then concat(" ", s_right)
-                                     else "")))
-                      end
-            else ast.val_s
-      in concat("(", concat(tostr_rec(ast, 0), ")"))
-      end
-
    /**** Instructions ****/
 
    type vm_insn = { opcode: int
@@ -605,6 +591,7 @@ let /* Booleans */
    var OPCODE_SETENV := 24
    var OPCODE_NUMEQ  := 25
    var OPCODE_TYPEOF := 26
+   var OPCODE_EXIT   := 27
 
    var vm_insn_num_opcodes  := 0
    var vm_insn_info :=
@@ -661,6 +648,7 @@ let /* Booleans */
 
       ; code(OPCODE_COMPILE,"COMPILE",  0, 0, 0)
       ; code(OPCODE_SETENV, "SETENV",   0, 0, 0)
+      ; code(OPCODE_EXIT,   "EXIT",     1, 0, 0)
 
       ; for i := 1 to expected_number_opcodes - 1
         do if a[i] <> nil & a[i-1] = nil
@@ -707,6 +695,12 @@ let /* Booleans */
               ; index := index + 1
               ; head  := head.next )
       ; tape.filled := index
+      ; if DEBUG_PRINT_TAPE
+        then ( print("Appended new to tape: ")
+             ; print(int_to_string(index_start))
+             ; print(" to ")
+             ; print(int_to_string(index))
+             ; print("\n") )
       ; index_start
      end
 
@@ -775,15 +769,13 @@ let /* Booleans */
    var ENV_STD   : vm_env  := ENV_EMPTY
    var STD_LIB_ID_FUNCTION: scheme_value := nil
 
-   var STD_LIB := let var first_insn := noop_insn(pos_unknown, pos_unknown)
+   var STD_LIB := let var std_insns := vm_insn_list { first = nil, last = nil }
-
-                      var std_insns  := single_insn(first_insn)
 
                       function app (opcode: int, arg1: int, arg2: string) =
-                           app_insn(std_insns, opcode, arg1, arg2, pos_unknown, pos_unknown)
+                           app_insn(std_insns, opcode, arg1, arg2, pos_preamble, pos_preamble)
 
                       function app2 (opcode: int, arg3: scheme_value) =
-                           app_insn2(std_insns, opcode, arg3, pos_unknown, pos_unknown)
+                           app_insn2(std_insns, opcode, arg3, pos_preamble, pos_preamble)
 
                       function stdval (name: string, value: scheme_value) =
                         ENV_STD := pair_val( pair_val( sym_val(name), value)
@@ -802,6 +794,8 @@ let /* Booleans */
                      then stdval("nil", nil_val())
 
                     /* Identity function */
+                   ; stdfun("syntax->datum")
+                   ; stdfun("datum->syntax")
                    ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
                    ; app(OPCODE_RET,    1, "")
 
@@ -949,12 +943,119 @@ let /* Booleans */
                    ; app(OPCODE_SETENV,  0, "")
                    ; app(OPCODE_RET,     1, "")
 
-                   ; first_insn.arg1 := insn_list_length(std_insns)
+                   ; stdfun("exit")
+                   ; app(OPCODE_EXIT, true, "")
+
                    ; std_insns
                   end
 
+   /**** Virtual Machine ****/
 
-   function compile_to_vm (ast: sexp_ast): vm_insn_list =
+   /* Stack */
+
+   type vm_stack_elem = scheme_value
+   type vm_stack_list = { value: vm_stack_elem, below: vm_stack_list }
+   type vm_stack = { list: vm_stack_list }
+   function stack_new(): vm_stack = vm_stack { list = nil }
+   function stack_peak(stack: vm_stack): vm_stack_elem =
+     if stack = nil
+       then (print("Error in stack_peak: Not given stack!\n"); nil)
+     else if stack.list = nil
+       then nil
+     else stack.list.value
+   function stack_pop(stack: vm_stack): vm_stack_elem =
+     if stack = nil
+       then (print("Error in stack_pop: Not given stack!\n"); nil)
+     else if stack.list = nil
+       then nil
+     else
+       let var head  := stack.list.value
+       in stack.list := stack.list.below
+        ; head
+       end
+   function stack_seek_elem(stack: vm_stack, index: int): vm_stack_list =
+     let var head  := stack.list
+     in for index := 1 to index
+           do if head <> nil
+               then head := head.below
+      ; head
+     end
+   function stack_destroy_elem(stack: vm_stack, index: int): vm_stack_elem =
+     if index <= 0
+       then let var value   := stack.list.value
+            in stack.list   := stack.list.below
+             ; value
+            end
+       else let var before  := stack_seek_elem(stack, index - 1)
+            in if before = nil | before.below = nil
+               then nil
+               else let var value   := before.below.value
+                     in before.below := before.below.below
+                      ; value
+                    end
+            end
+   function stack_push(stack: vm_stack, elem: vm_stack_elem) =
+     stack.list := vm_stack_list { value = elem
+                                 , below = stack.list }
+
+   function stack_to_string (stack: vm_stack): string =
+     let function iter (list: vm_stack_list): string =
+            if list = nil then ""
+            else concat(value_to_string(list.value), if list.below <> nil
+                                                     then concat(", ", iter(list.below))
+                                                     else "")
+
+     in concat("[", concat(iter(stack.list), "]"))
+     end
+
+   /* Environments */
+
+   var GLOBAL_ENV_SENTINEL := ""
+
+   function env_new(base_env: scheme_value): vm_env =
+       pair_val( pair_val( sym_val(GLOBAL_ENV_SENTINEL)
+                         , bool_val(0))
+               , base_env )
+
+   function env_seek_elem(env: vm_env, key: string): vm_env =
+     let var head  := env
+     in while head <> nil
+            & head.typ <> type_nil
+            & head.val_car.val_car.val_s <> key
+
+           do head := head.val_cdr
+      ; if head <> nil
+         & head.typ <> type_nil
+            then head
+        else nil
+     end
+
+   function env_push(env: vm_env, key: string, value: vm_env_elem): vm_env =
+       pair_val( pair_val( sym_val(key)
+                         , value)
+               , env )
+
+   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
+           then print("Attempting to perform global push to non-global environment")
+           else env.val_cdr := pair_val( pair_val( sym_val(key)
+                                                 , value)
+                                       , env.val_cdr )
+        ; env
+       end
+
+
+   function env_to_string (env: vm_env): string =
+     value_to_string(env)
+
+
+   /**** Compilation ****/
+
+   function compile_to_vm ( ast: sexp_ast
+                          , env_macro: scheme_environment
+                          , macro_tape: vm_tape
+                          , env_global: scheme_environment): vm_insn_list =
      let function list (head: vm_insn_list_link): vm_insn_list =
            let var tail := head
            in while tail <> nil & tail.next <> nil
@@ -1164,17 +1265,8 @@ let /* Booleans */
            end
 
          function compile_define_syntax (ast: sexp_ast): vm_insn_list =
-           let var symbol     := ast.val_cdr.val_car.val_s
+           ( compile_error("Please do not compile define-syntax", ast)
-               var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false)
+           ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)))
-
-               var pos_l := ast.pos_l
-               var pos_r := ast.pos_r
-
-           /* TODO: Improve below */
-           in app_insn(insns_body, OPCODE_POP, 0, "", pos_l, pos_r)
-            ; app_insn2(insns_body, OPCODE_PUSH, VALUE_UNSPECIFIED, pos_l, pos_r)
-            ; insns_body
-           end
 
          function compile_define (ast: sexp_ast): vm_insn_list =
 
@@ -1349,6 +1441,24 @@ let /* Booleans */
                   ; insns
                  end
 
+             /* Macro applications */
+           else if ast.val_car <> nil
+                 & ast.val_car.typ = type_symbol
+                 & env_seek_elem(env_macro, ast.val_car.val_s) <> nil
+            then let var stack    := stack_new()
+                     var env_elem := env_seek_elem(env_macro, ast.val_car.val_s)
+                     var fun      := env_elem.val_car.val_cdr
+                 in stack_push(stack, ast)
+                  /*; print("Running ")
+                  ; print(value_to_string(fun))
+                  ; print(" as macro\n")*/
+                  ; if fun <> nil & fun.typ <> type_closure
+                    then compile_error("Attempting to use non-function as macro function.", ast)
+                  ; vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global)
+                    /* TODO: Assert that there is something on the stack */
+                  ; compile_rec(stack_pop(stack), can_tail_call)
+                 end
+
              /* Call expressions */
            else  let var num_args   := 0
                      var args_insns := vm_insn_list { first = nil, last = nil }
@@ -1389,7 +1499,9 @@ let /* Booleans */
            ; print("\n")
           end
 
-     in compile_rec(ast, true)
+        var base_insns := compile_rec(ast, false)
+     in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
+      ; base_insns
      end
 
    function optimize_vm_tape (real_tape: vm_tape): vm_tape =
@@ -1417,7 +1529,7 @@ let /* Booleans */
 
    function insn_to_string (insn: vm_insn): string =
      if insn = nil
-         then ( print("Encountered missing opcode in insn_to_string!\n")
+         then ( print("Encountered missing instruction in insn_to_string!\n")
               ; "!!!" )
      else if insn.opcode < 0
            | vm_insn_num_opcodes <= insn.opcode
@@ -1445,12 +1557,13 @@ let /* Booleans */
                  , "")
        end
 
-   function tape_to_string (tape: vm_tape): string =
+   function tape_to_string_range (tape: vm_tape, first:int, last:int): string =
      let var str   := "TAPE\n"
-         var index := 0
+         var index := first
          var real_tape := tape.tape
-         var length    := tape.filled
+         var last      := if last < 0 then tape.filled + last
-         var ln_width  := size(int_to_string(tape.length))
+                                      else last
+         var ln_width  := size(int_to_string(last))
 
          function repeat (str: string, i: int): string =
            if i <= 0
@@ -1462,7 +1575,7 @@ let /* Booleans */
            in concat(repeat(" ", ln_width-size(num_str)), num_str)
            end
 
-     in while index < length
+     in while index <= last
            do ( str := concat5( str
                               , line_number(index)
                               , "  "
@@ -1473,101 +1586,8 @@ let /* Booleans */
       ; str
      end
 
-   /**** Virtual Machine ****/
+   function tape_to_string (tape: vm_tape): string =
-
+     tape_to_string_range(tape, 0, tape.filled)
-   /* Stack */
-
-   type vm_stack_elem = scheme_value
-   type vm_stack_list = { value: vm_stack_elem, below: vm_stack_list }
-   type vm_stack = { list: vm_stack_list }
-   function stack_new(): vm_stack = vm_stack { list = nil }
-   function stack_pop(stack: vm_stack): vm_stack_elem =
-     if stack = nil
-       then (print("Error in stack_pop: Not given stack!\n"); nil)
-     else if stack.list = nil
-       then nil
-     else
-       let var head  := stack.list.value
-       in stack.list := stack.list.below
-        ; head
-       end
-   function stack_seek_elem(stack: vm_stack, index: int): vm_stack_list =
-     let var head  := stack.list
-     in for index := 1 to index
-           do if head <> nil
-               then head := head.below
-      ; head
-     end
-   function stack_destroy_elem(stack: vm_stack, index: int): vm_stack_elem =
-     if index <= 0
-       then let var value   := stack.list.value
-            in stack.list   := stack.list.below
-             ; value
-            end
-       else let var before  := stack_seek_elem(stack, index - 1)
-            in if before = nil | before.below = nil
-               then nil
-               else let var value   := before.below.value
-                     in before.below := before.below.below
-                      ; value
-                    end
-            end
-   function stack_push(stack: vm_stack, elem: vm_stack_elem) =
-     stack.list := vm_stack_list { value = elem
-                                 , below = stack.list }
-
-   function stack_to_string (stack: vm_stack): string =
-     let function iter (list: vm_stack_list): string =
-            if list = nil then ""
-            else concat(value_to_string(list.value), if list.below <> nil
-                                                     then concat(", ", iter(list.below))
-                                                     else "")
-
-     in concat("[", concat(iter(stack.list), "]"))
-     end
-
-   /* Environments */
-
-   var GLOBAL_ENV_SENTINEL := ""
-
-   function env_new(): vm_env =
-       pair_val( pair_val( sym_val(GLOBAL_ENV_SENTINEL)
-                         , bool_val(0))
-               , ENV_STD )
-
-   function env_seek_elem(env: vm_env, key: string): vm_env =
-     let var head  := env
-     in while head <> nil
-            & head.typ <> type_nil
-            & head.val_car.val_car.val_s <> key
-
-           do head := head.val_cdr
-      ; if head <> nil
-         & head.typ <> type_nil
-            then head
-        else nil
-     end
-
-   function env_push(env: vm_env, key: string, value: vm_env_elem): vm_env =
-       pair_val( pair_val( sym_val(key)
-                         , value)
-               , env )
-
-   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
-           then print("Attempting to perform global push to non-global environment")
-           else env.val_cdr := pair_val( pair_val( sym_val(key)
-                                                 , value)
-                                       , env.val_cdr )
-        ; env
-       end
-
-
-   function env_to_string (env: vm_env): string =
-     value_to_string(env)
-
-   /* Tape */
 
   /* Virtual Machine execution */
 
@@ -1581,6 +1601,9 @@ let /* Booleans */
      let var tape_info := tape
          var tape      := tape.tape
          var continue  := true
+         var ignore := ( if DEBUG_PRINT_STACK
+                         then print("Entered VM instance\n")
+                       ; "")
 
          function expect_type(value: scheme_value, typ: type_type, name: string) =
            if value.typ <> typ
@@ -1709,7 +1732,8 @@ let /* Booleans */
             else if tape[ip].opcode = OPCODE_RET
                   then let var return_to  := stack_destroy_elem(stack, tape[ip].arg1)
                        in if return_to = nil
-                              then run_error("Stack too shallow!")
+                              then /*run_error("Stack too shallow!")*/
+                                /* TODO: Improve */ continue := false
                           else if not(is_function(return_to))
                               then run_error(concat("Cannot return to non-function value ", value_to_string(return_to)))
                           else ( ip                  := return_to.val_i
@@ -1795,7 +1819,8 @@ let /* Booleans */
                        in if ast = nil
                               then run_error("Stack too shallow!")
                           else
-                            let var pos_of_fun := tape_append(tape_info, compile_to_vm(ast))
+                            let var pos_of_fun :=
+                            tape_append(tape_info, compile_to_vm(ast, nil, nil, nil)) /* TODO: env_macro */
                             in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY))
                              ; ip := ip + 1
                             end
@@ -1823,32 +1848,44 @@ let /* Booleans */
                                ; ip := ip + 1 )
                        end
 
+            else if tape[ip].opcode = OPCODE_EXIT
+                  then ( if tape[ip].arg1
+                         then TRIGGERED_EXIT := true
+                       ; continue       := false )
+
             else run_error(concat("Encountered unknown opcode "
                                  , int_to_string(tape[ip].opcode)))
 
-        function run_error(errmsg: string) =
+        function run_error (errmsg: string) =
-          let var repr_pos_l := pos_to_string(tape[ip].pos_l)
+          let
-              var repr_pos_r := pos_to_string(tape[ip].pos_r)
           in print("Tiger-scheme runtime error\n    ")
            ; print(errmsg)
            ; print("\n    At instruction ")
            ; print(int_to_string(ip))
            ; print(": ")
            ; print(insn_to_string(tape[ip]))
-           ; print("\n    Scheme: ")
+           ; print("\n")
+           ; if tape[ip] <> nil then
+               let var repr_pos_l := pos_to_string(tape[ip].pos_l)
+                   var repr_pos_r := pos_to_string(tape[ip].pos_r)
+               in ()
+                ; print("    Scheme: ")
                 ; print(safe_substring( source
                                       , at_char(tape[ip].pos_l)
                                       , at_char(tape[ip].pos_r) ))
-           ; print("\n    Source: ")
+                ; print("\n")
+                ; print("    Source: ")
                 ; print(repr_pos_l)
                 ; if repr_pos_l <> repr_pos_r
                   then ( print(" to ")
                        ; print(repr_pos_r) )
                 ; print("\n")
+               end
            ; continue       := false
+           ; TRIGGERED_EXIT := true
           end
 
-     in while continue
+     in while continue & ip < tape_info.filled & not(TRIGGERED_EXIT)
         do ( vm_update()
            ; if DEBUG_PRINT_STACK
              then  ( print("[")
@@ -1856,49 +1893,92 @@ let /* Booleans */
                    ; print("]: ")
                    ; print(stack_to_string(stack))
                    ; print("\n") ))
+
+      ; if DEBUG_PRINT_STACK
+        then print("Exit VM instance\n")
      end
 
-   /* Do stuff */
+   /* Ready for running toplevel */
 
-   var test_text :=
-     /* TODO: Improve top-level parsing */
-     let var text := "(begin "
-         var char := "BAD SHIT HAPPENED"
-     in while char <> ""
-           do ( char := getchar()
-              ; text := concat(text, char) )
-      ; concat(text, " )")
-     end
-
-   var ignore     := ( print("** Parsing **\n")
-                     ; print("Original : ")
-                     ; print(test_text)
-                     ; print("\n")
-                     ; 1)
-   var sexp_ast   := parse_string(test_text)
-   var ignore     := ( print("Parsed   : ")
-                     ; print(value_to_string(sexp_ast))
-                     ; print("\n")
-                     ; print("** Compilation **\n")
-                     ; 1)
    var tape       := tape_new(1000)
    var ignore     := ( tape_append(tape, STD_LIB)
-                     ; tape_append(tape, compile_to_vm(sexp_ast))
                      ; "Ignore!" )
 
-   /*var tape       := optimize_vm_tape(tape)
-   var ignore     := ( print("Compiled!:\n")
-                     ; print(tape_to_string(tape))
-                     ; print("\n")
-                     ; 1) */
-
    var stack      := stack_new()
-   var env        := env_new()
 
-in ()
+   /* Perform reading of toplevel */
+
+   function read_matching_parantheses (): string =
+     let var depth := 0
+         var char  := "BAD SHIT HAPPENED"
+         var text  := ""
+     in while char <> ""
+           do ( char := getchar()
+              ; text := concat(text, char)
+              ; if char = "("
+                  then depth := depth + 1
+                else if char = ")"
+                  then ( depth := depth - 1
+                       ; if depth = 0 then break ))
+      ; text
+     end
+
+   var env_global := env_new(ENV_STD)
+   var env_macro  := env_new(nil_val())
+
+in print("Ready for the scheming Tiger?\n")
+ ; let var text  := "BAD SHIT HAPPENED"
+       var env   := env_global
+
+   in while text <> "" & not(TRIGGERED_EXIT)
+         do let var text := read_matching_parantheses()
+
+                var macro_name  := "" /* Not macro is "" */
+
+                var sexp  := parse_string(text)
+                var sexp_compile :=
+                  if 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
+                         ; sexp.val_cdr.val_cdr.val_car )
+                    else sexp
+
+                var insns := compile_to_vm(sexp_compile, env_macro, tape, env_global)
+                var start_index := tape_append(tape, insns)
+            in ()
+             /*print("Parsed: ")
+             ; print(value_to_string(sexp))
+             ; print("\n") */
+
+             ; if DEBUG_PRINT_TAPE
+               then ( print("Tape:\n")
+                    ; print(tape_to_string_range(tape, start_index, -1))
+                    ; print("\n") )
+
+             ; let var stack := stack_new()
+                   var value : scheme_value := nil
+               in if 0 <= start_index
+                  then vm_run(tape, start_index, stack, env, text, env_global)
+
+                ; if macro_name <> ""
+                  then ( value := stack_pop(stack)
+                       /*; print("New macro \"")
+                       ; print(macro_name)
+                       ; print("\": ")
+                       ; print(value_to_string(value))
+                       ; print("\n")*/
+                       ; if value <> nil & value.typ <> type_closure
+                          then ( print("Attempting to save non-function as macro!\n")
+                               ; TRIGGERED_EXIT := true )
+                       ; global_env_push( env_macro
+                                        , macro_name
+                                        , value )
+                       ; macro_name := "")
+               end
+            end
+   end
 
- ; print("\n** VM **\n")
- ; vm_run(tape, 0, stack, env, test_text, env)
  ; print("Stack: ")
  ; print(stack_to_string(stack))
  ; print("\n")