From 96cc19b207b01ac48fc59a97da36db6a70c69c50 Mon Sep 17 00:00:00 2001
From: Jon Michael Aanes <jonjmaa@gmail.com>
Date: Tue, 4 Dec 2018 15:35:27 +0100
Subject: [PATCH] Working on macros.

---
 tigerscheme.tig | 241 ++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 214 insertions(+), 27 deletions(-)

diff --git a/tigerscheme.tig b/tigerscheme.tig
index 469bd99..72a50a2 100644
--- a/tigerscheme.tig
+++ b/tigerscheme.tig
@@ -48,9 +48,22 @@ let /* Booleans */
     function is_integer_string (s: string): int =
       s = int_to_string(string_to_int(s))
 
+    function max (a: int, b: int): int =
+      if a > b then a else b
+
+    function min (a: int, b: int): int =
+      if a < b then a else b
+
+    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) )
+
     /* Scheme value system */
 
-    type scheme_value = { typ   : int
+    type type_type = int
+
+    type scheme_value = { typ   : type_type
                         , val_i : int
                         , val_s : string
                         , val_e : scheme_environment
@@ -125,22 +138,24 @@ let /* Booleans */
       end
 
     function is_truthy (e: scheme_value): bool =
-      e.typ <> type_false & (IS_NIL_TRUTHY | e.typ <> type_nil)
+        e <> nil
+      & e.typ <> type_false
+      & (IS_NIL_TRUTHY | e.typ <> type_nil)
 
     function is_integer (e: scheme_value): bool =
-      e.typ = type_integer
+      e <> nil & e.typ = type_integer
 
     function is_string (e: scheme_value): bool =
-      e.typ = type_string
+      e <> nil &e.typ = type_string
 
     function is_function (e: scheme_value): bool =
-      e.typ = type_closure
+      e <> nil &e.typ = type_closure
 
     function is_pair (e: scheme_value): bool =
-      e.typ = type_pair
+      e <> nil &e.typ = type_pair
 
     function is_symbol (e: scheme_value): bool =
-      e.typ = type_symbol
+      e <> nil &e.typ = type_symbol
 
     function int_val (i: int): scheme_value =
       scheme_value { typ   = type_integer
@@ -334,9 +349,6 @@ let /* Booleans */
                           var index_start := index
                           var most_right  := index
 
-                          function max (a:int, b:int): int =
-                            if a > b then a else b
-
                       in index := index + 1 /* Position after index */
                        ; while index < size(str) & not(is_right_paren(index))
                             do let var parsed := parse_rec()
@@ -387,8 +399,7 @@ let /* Booleans */
                        /* Continue with stuff */
                        ; index := index + 1
                        ; if sexp = nil
-                         then ( parse_error("Internal assertion failed")
-                              ; sexp_nil(-1, -1))
+                         then sexp_nil(index_start, most_right)
                          else sexp
                       end
               else (parse_error("Error: I don't even!"); nil))
@@ -397,8 +408,10 @@ let /* Booleans */
             let
             in print("Tiger-scheme parse error\n    ")
              ; print(errmsg)
-             ; print("\n    At index ")
+             ; print("\n    At index: ")
              ; print(int_to_string(index))
+             ; print("\n    Nearby:   ")
+             ; print(safe_substring(str, index-10, index+10))
              ; print("\n")
             end
 
@@ -473,7 +486,7 @@ let /* Booleans */
    var OPCODE_CDR    := 16
    var OPCODE_SET    := 21
 
-   var vm_insn_num_opcodes := 0
+   var vm_insn_num_opcodes  := 0
    var vm_insn_info :=
      let var expected_number_opcodes := 30
          var a := vm_insn_info_l [expected_number_opcodes] of nil
@@ -608,6 +621,7 @@ let /* Booleans */
 
 
    var STD_LIB_ENV: vm_env := nil
+   var STD_LIB_ID_FUNCTION: scheme_value := nil
 
    var STD_LIB := let var first_insn := noop_insn(-1, -1)
 
@@ -624,8 +638,11 @@ let /* Booleans */
                                               , value = value
                                               , next  = STD_LIB_ENV }
 
+                      function tape_pos (): int =
+                        insn_list_length(std_insns)
+
                       function stdfun (name: string) =
-                        stdval(name, fun_val(insn_list_length(std_insns), nil))
+                        stdval(name, fun_val(tape_pos(), nil))
 
                   in ()
 
@@ -633,6 +650,10 @@ let /* Booleans */
                    ; if HAS_NIL_SYMBOL
                      then stdval("nil", nil_val())
 
+                    /* Identity function */
+                   ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
+                   ; app(OPCODE_RET,    1, "")
+
                     /* Useful standard functions */
                    ; stdfun("display")
                    ; app(OPCODE_TOSTR,  0, "")
@@ -730,7 +751,6 @@ let /* Booleans */
            in rec(insns.first, 0)
            end
 
-
          function set_tree_positions ( ast: sexp_ast
                                      , pos_l: int
                                      , pos_r: int ) =
@@ -742,17 +762,178 @@ let /* Booleans */
                          then ( set_tree_positions( ast.val_cdr, pos_l, pos_r)
                               ; set_tree_positions( ast.val_car, pos_l, pos_r) ))
 
-         function compile_define_syntax (ast: sexp_ast): vm_insn_list =
-           let var syntax_name := ast.val_cdr.val_car.val_s
-               var variables   := ast.val_cdr.val_cdr.val_car.val_cdr.val_car
-               var rules       := ast.val_cdr.val_cdr.val_car.val_cdr.val_cdr
+         function sexp_is_list_of_type ( ast: sexp_ast
+                                       , subtype: type_type ): bool =
+           if ast = nil
+             then false
+           else if ast.typ = type_nil
+             then true
+           else ast.typ = type_pair
+              & ast.val_car <> nil
+              & ast.val_car.typ = subtype
+              & sexp_is_list_of_type(ast.val_cdr, subtype)
 
-               var check_1  := ( ast.val_cdr.val_cdr.val_cdr.typ = type_nil )
-               var check_2  := ( ast.val_cdr.val_cdr.val_car.val_car.typ   = type_symbol
-                               & ast.val_cdr.val_cdr.val_car.val_car.val_s = "define-syntax")
-           /* TODO */
-           in ( compile_error("define-syntax not implemented!", ast)
-              ; list(nil) )
+         function sexp_is_literals_list ( ast: sexp_ast ): bool =
+           sexp_is_list_of_type(ast, type_symbol)
+
+         function sexp_is_ellipsis ( ast: sexp_ast ): bool =
+             ast <> nil
+           & ast.typ = type_symbol
+           & ast.val_s = "..."
+
+         function sexp_list_length (ast: sexp_ast): bool =
+           if ast = nil | not(ast.typ = type_pair | ast.typ = type_nil)
+             then false
+           else if ast.typ = type_nil
+             then 0
+           else  let var len := sexp_list_length(ast.val_cdr)
+                 in if len < 0
+                    then len
+                    else len + 1
+                 end
+
+         function sexp_is_pattern_datum (ast: sexp_ast): bool =
+             ast <> nil
+           & ( ast.typ = type_integer
+             | ast.typ = type_string
+             | ast.typ = type_true
+             | ast.typ = type_false
+             /* TODO: character */)
+
+         function sexp_is_pattern_id (ast: sexp_ast): bool =
+           ast <> nil & ast.typ = type_symbol
+                      & not(sexp_is_ellipsis(ast))
+
+         function sexp_is_pattern ( ast: sexp_ast ): bool =
+           if ast = nil
+             then false
+
+           /* Pattern Datum */
+           else if sexp_is_pattern_datum(ast)
+             then true
+
+           /* The empty list '() is a pattern */
+           else if ast.typ = type_nil
+             then true
+
+           /* Ensure it is a pair */
+           else if ast.typ <> type_pair
+                 | ast.val_car = nil
+                 | ast.val_cdr = nil
+             then false
+
+           /* List of patterns: (<pattern> ...) */
+           /* Non-proper list of patterns: (<pattern> ... . <pattern>) */
+           else if ast.typ = type_pair
+                 & sexp_is_pattern(ast.val_car)
+                 & sexp_is_pattern(ast.val_cdr)
+             then true
+
+           /* (<pattern> ... <pattern> <ellipsis>) */
+           else if ast.typ = type_pair
+                 & sexp_is_pattern (ast.val_car)
+                 & sexp_is_ellipsis(ast.val_cdr.val_car)
+                 & ast.val_cdr.val_cdr.typ = type_nil
+             then true
+
+             /* TODO: Hashtag notation
+                (https://people.csail.mit.edu/jaffer/r5rs/Pattern-language.html)
+             */
+
+           else false
+
+         function sexp_is_template ( ast: sexp_ast ): bool =
+           if ast = nil
+             then false
+
+           /* Pattern Datum */
+           else if sexp_is_pattern_datum(ast)
+             then true
+
+           /* The empty list '() is a template */
+           else if ast.typ = type_nil
+             then true
+
+           /* Ensure it is a pair */
+           else if ast.typ <> type_pair
+                 | ast.val_car = nil
+                 | ast.val_cdr = nil
+             then false
+
+           /* List of templates: (<template_element> ...) */
+           /* Pair of templates: (<template_element> . <template>) */
+           /* Where <template_element> is <template> */
+           else if ast.typ = type_pair
+                 & sexp_is_template(ast.val_car)
+                 & ast.val_cdr.typ = type_pair
+                 & sexp_is_ellipsis(ast.val_cdr.val_car)
+                 & sexp_is_pattern(ast.val_cdr.val_cdr)
+             then true
+
+           /* List of templates: (<template_element> ...) */
+           /* Pair of templates: (<template_element> . <template>) */
+           /* Where <template_element> is <template> <ellipsis> */
+           else if ast.typ = type_pair
+                 & sexp_is_template(ast.val_car)
+                 & sexp_is_pattern(ast.val_cdr)
+             then true
+
+             /* TODO: Hashtag notation
+                (https://people.csail.mit.edu/jaffer/r5rs/Pattern-language.html)
+             */
+
+           else false
+
+         function sexp_is_syntax_rule (ast: sexp_ast): bool =
+             ast <> nil
+           & ast.typ = type_pair
+           & sexp_is_pattern(ast.val_car)
+           & ast.val_cdr <> nil
+           & ast.val_cdr.typ = type_pair
+           & ast.val_cdr.val_cdr.typ = type_nil
+           & sexp_is_template(ast.val_cdr.val_car)
+
+         function sexp_is_syntax_rules (ast: sexp_ast): bool =
+           if ast <> nil | ast.typ <> type_pair
+             then false
+
+           else if ast.val_car.typ   = type_symbol
+                 & ast.val_car.val_s = "syntax-rules"
+                 & ast.val_cdr.typ   = type_pair
+                 & sexp_is_literals_list(ast.val_cdr.val_car)
+             then let var rule_head := ast.val_cdr.val_cdr
+                      var correct   := true
+                  in while correct
+                         & rule_head.typ <> type_nil
+
+                        do ( if not( rule_head.typ = type_pair
+                                   & sexp_is_syntax_rule(rule_head.val_car) )
+                             then correct := false
+                           ; rule_head := rule_head.val_cdr )
+                   ; correct
+                  end
+
+           else false
+
+         function compile_syntax_rules (ast: sexp_ast): vm_insn_list =
+           let
+           in if sexp_is_syntax_rules(ast)
+              then  compile_rec(STD_LIB_ID_FUNCTION, false)
+              else ( compile_error("Syntax of syntax-rules usage is incorrect.", ast)
+                   ; compile_rec(VALUE_UNSPECIFIED, false) )
+           end
+
+         function compile_define_syntax (ast: sexp_ast): vm_insn_list =
+           let var symbol     := ast.val_cdr.val_car.val_s
+               var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false)
+
+               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 =
@@ -849,6 +1030,10 @@ let /* Booleans */
            else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
              then compile_define_syntax(ast)
 
+             /* 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"
              then let var insns := vm_insn_list { first = nil, last = nil }
@@ -1357,7 +1542,7 @@ let /* Booleans */
            ; print(": ")
            ; print(insn_to_string(tape[ip]))
            ; print("\n    Scheme: ")
-           ; print(substring(source, tape[ip].pos_l, 1 + tape[ip].pos_r - tape[ip].pos_l))
+           ; print(safe_substring(source, tape[ip].pos_l, tape[ip].pos_r))
            ; print("\n")
            ; ip := -1
           end
@@ -1393,12 +1578,14 @@ let /* Booleans */
                      \       (display (cdr y)) (newline) \
                      \       (set! x 10)  \
                      \       (display x) (newline) \
+
                      \ (define-syntax and \
                      \ (syntax-rules ()\
                      \    ((and) #t)\
                      \    ((and test) test)\
                      \    ((and test1 test2 ...)\
                      \     (if test1 (and test2 ...) #f))))\
+
                      \       (display (and #t #t)) (newline) \
                      \       (display (and #f #t)) (newline) \
                      \       (display (and #f #f)) (newline) \