Slow work on syntax-rules macro system.

example.scm

@@ -1,4 +1,6 @@
 
+
+
 ;;; Standard lib, in scheme
 
 ; Lists
@@ -28,6 +30,7 @@
 (define (append l1 l2)
   (foldr cons l2 l1))
 
+
 (define list-tail; Taken from https://people.csail.mit.edu/jaffer/r5rs/Pairs-and-lists.html
        (lambda (x k)
          (if (zero? k)
@@ -48,6 +51,42 @@
 (define (odd?      x) (= (mod x 2) 1))
 (define (even?     x) (= (mod x 2) 0))
 
+;;;;;;;; Testing stuff ;;;;;;;;;;
+
+
+; Test some compilation stuff
+
+(define f (lambda (x) ((lambda (y) (+ y 2)) (car x))))
+
+(define g (lambda (x) (if ((lambda (y) (= y 2)) (car x))
+                          y
+                          'fuck)))
+
+(define fac_fucked
+  ( (lambda (f) (lambda (v) (f f v)))
+    (lambda (f v)
+      (if (= v 0)
+          1
+          (* v (f f (+ v -1)))))))
+
+(display "Recursive combinator used on factorial.\n\tExpect: 120\n\tGotten: ")
+(display (fac_fucked 5))
+(newline)
+
+; Test that function arguments are in correct order
+
+(define (test-arg-order a b c)
+  (begin (display a)
+         (display " ")
+         (display b)
+         (display " ")
+         (display c)
+         (newline)))
+
+(display "Testing that argument order is correct:\n\tExpect: 1 2 3\n\tGotten: ")
+(test-arg-order 1 2 3)
+(display "\n")
+
 ; Test string
 
 (display "Hello World") (newline)
@@ -78,6 +117,7 @@
 (display y)          (newline)
 (display (car y))    (newline)
 (display (cdr y))    (newline)
+
 (display (append '(1 2 3) '(4 5 6)))    (newline)
 
 ; Test system
@@ -142,6 +182,11 @@
 (display (f 1 5))
 (newline)
 
+(display "Testing quasi-notation advanced!\n\tExpect: ((1 2) . 3)\n\tGotten: ")
+(define (f) (cons `(1 2) 3))
+(display (f))
+(newline)
+
 ; Check set!
 
 (set! x 10)
@@ -290,8 +335,22 @@
 (display (x))
 (display "\n")
 
+(display "Test defining let using macroes:\n    Expect: 23 82 105\n    Gotten: ")
 
-(display "\n* R5RS: Lexical convention *\n")
+(define-syntax let
+  (lambda (vo)
+    `( (lambda ,(map car (cadr vo)) ,(caddr vo))
+       ,@(map cadr (cadr vo)))))
+
+(let ((a 23)
+      (b 82))
+  (begin (display a)
+         (display " ")
+         (display b)
+         (display " ")
+         (display (+ a b))))
+
+(display "\n* R5RS: Lexical conventions *\n")
 
 (define a-variable 20)
 (if #f (begin
@@ -318,22 +377,107 @@
 
 ; Test syntax-rules
 
-(newline)
+(header "Testing syntax-rules (move to macro once implemented)")
-(display "* Testing syntax-rules (move to macro once implemented) *")
-(newline)
 
-(display "Attempting to define true using syntax rules.\n\tExpect: #t #f\n\tGotten: ")
+(define equal? eqv?)
+
+(define construct-pattern-predicate
+  (lambda (name pat)
+    (if (if (symbol? pat) #t (number? pat))
+        `(equal? ,name ',pat)
+    (if (null? pat)
+        `(null? ,name)
+    (if (pair? pat)
+        `(if (pair? ,name)
+             (if ,(construct-pattern-predicate `(car ,name) (car pat))
+                 ,(construct-pattern-predicate `(cdr ,name) (cdr pat))
+                 #f)
+             #f)
+    'fuck )))))
+
+(define syntax-rules-rec
+  (lambda (macro-name var-name rules)
+    (if (null? rules)
+        'doublefuck
+        (let ((pattern  (caar rules))
+              (result   (cadar rules)))
+          (if (eqv? macro-name (car pattern))
+              `(if ,(construct-pattern-predicate var-name pattern)
+                   ',result
+                   ,(syntax-rules-rec macro-name var-name (cdr rules)))
+
+              (begin (display "Incorrect usage of syntax-rules-rec: Each rule must have same first symbol.")
+                     (display "\n\tFirst had ")
+                     (display macro-name)
+                     (display "\n\tBut one of them had ")
+                     (display (car pattern))
+                     (newline)))))))
+
+
+
+(define-syntax syntax-rules
+  (lambda (vo)
+    (let ((literals  (cadr vo))
+          (rules     (cddr vo))
+          (name      (car (caaddr vo))))
+
+      `(lambda (vo2)
+         ,( syntax-rules-rec name 'vo2 rules))
+      )))
+
+; Define true
+
+(syntax-rules ()
+  ((name ...) ...))
 
 (define-syntax true
  (syntax-rules ()
     ((true) #t)))
 
-(display (true))
+(test "Attempting to define true using syntax rules."
-(display " ")
+      `(
-(display (not (true)))
+        ( #t . ,(true))
+        ( #f . ,(not (true)))
+       ))
+
+;
 
 
-(display "Attempting to define and using syntax rules.\n\tExpect: #t #f #f #f\n\tGotten: ")
+; Below should produce an error:
+;(define-syntax bad-rule
+ ;(syntax-rules ()
+    ;((bad-rule-1) #t)
+    ;((bad-rule-2) #f)))
+
+(define-syntax bool
+ (syntax-rules ()
+    ((bool) #t)
+    ((bool 0) #f)
+    ((bool 1) #t)
+    ))
+
+(test "Attempting to define bool ? using syntax rules."
+      `(
+        ( #t . ,(bool))
+        ( #f . ,(bool 0))
+        ( #t . ,(bool 1))
+       ))
+
+(define-syntax derp
+ (syntax-rules ()
+    ((derp) 1)
+    ((derp two) (+ (derp) (derp)))
+    ))
+
+(test "Defining weird macroes using syntax-rules."
+      `(
+        ( 1 . ,(derp))
+        ( 2 . ,(derp two))
+       ))
+
+;;;;; ;
+
+(exit)
 
 (define-syntax and
  (syntax-rules ()
@@ -342,10 +486,21 @@
     ((and test1 test2 ...)
      (if test1 (and test2 ...) #f))))
 
-(display (and #t #t)) (display " ")
+(test "Attempting to define and using syntax rules."
-(display (and #f #t)) (display " ")
+      `(
-(display (and #f #f)) (display " ")
+        (#t . ,(and))
-(display (and #t #f)) (newline)
+        (#f . ,(and #f))
+        (#t . ,(and #t))
+        (#f . ,(and #f #f))
+        (#f . ,(and #t #f))
+        (#f . ,(and #f #t))
+        (#t . ,(and #t #t))
+        (#f . ,(and #t #f #t))
+        (#f . ,(and #f #f #f))
+        (#t . ,(and #t #t #t))
+        (#f . ,(and #f #t #f #f #f #f))
+        (#t . ,(and #t #t #t #t #t #t))
+       ))
 
 ; TODO: Use syntax-rules to implement let and or.
 

tigerscheme.tig

@@ -1024,11 +1024,12 @@ let /* Booleans */
        then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r)
 
    function tail_position_one (insn: vm_insn, return_now: bool): vm_insn_list =
-     let var insns := single_insn(insn)
+     if insn = nil
-     in tail_position(insns, return_now, insn.pos_l, insn.pos_r)
+       then nil
-      ; insns
+       else let var insns := single_insn(insn)
-     end
+            in tail_position(insns, return_now, insn.pos_l, insn.pos_r)
-
+             ; insns
+            end
 
    var ENV_EMPTY : vm_env  := nil_val()
    var ENV_STD   : vm_env  := ENV_EMPTY
@@ -1108,10 +1109,53 @@ let /* Booleans */
                    ; app(OPCODE_CONS,   0, "")
                    ; app(OPCODE_RET,    1, "")
 
+                   ; stdfun("caaaar")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; stdfun("caaar")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; stdfun("caar")
+                   ; app(OPCODE_CAR,    0, "")
                    ; stdfun("car")
                    ; app(OPCODE_CAR,    0, "")
                    ; app(OPCODE_RET,    1, "")
 
+                   ; stdfun("cadddr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; stdfun("caddr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; stdfun("cadr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; app(OPCODE_RET,    1, "")
+
+                   ; stdfun("caadar")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; app(OPCODE_DGOTO,  2, "")
+                   ; stdfun("caaddr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; stdfun("caadr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; app(OPCODE_RET,    1, "")
+
+                   ; stdfun("cadadr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; app(OPCODE_DGOTO,  2, "")
+                   ; stdfun("cadaar")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; stdfun("cadar")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; app(OPCODE_CAR,    0, "")
+                   ; app(OPCODE_RET,    1, "")
+
+                   ; stdfun("cddddr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; stdfun("cdddr")
+                   ; app(OPCODE_CDR,    0, "")
+                   ; stdfun("cddr")
+                   ; app(OPCODE_CDR,    0, "")
                    ; stdfun("cdr")
                    ; app(OPCODE_CDR,    0, "")
                    ; app(OPCODE_RET,    1, "")
@@ -1272,9 +1316,24 @@ let /* Booleans */
                    ; app2(OPCODE_PUSH,  VALUE_UNSPECIFIED)
                    ; app(OPCODE_RET,    1, "")
 
+                   ; stdfun("debug-show-env")
+                   ; app(OPCODE_DEBUG,  3, "")
+                   ; app2(OPCODE_PUSH,  VALUE_UNSPECIFIED)
+                   ; app(OPCODE_RET,    1, "")
+
+
                    ; stdfun("exit")
                    ; app(OPCODE_EXIT, true, "")
 
+                   /* Should never be called as function! */
+                   ; stdfun("quote")
+                   ; stdfun("quasiquote")
+                   ; stdfun("unquote")
+                   ; stdfun("unquote-splicing")
+                   ; app2(OPCODE_PUSH, string_val("Error! This is a macro and cannot be called as an actual function!\n"))
+                   ; app(OPCODE_OUTPUT, 0, "")
+                   ; app(OPCODE_EXIT, true, "")
+
                    /* Misc??? */
                    ; stdfun("symbol?")
                    ; app(OPCODE_TYPEOF,  0, "")
@@ -1401,6 +1460,12 @@ let /* Booleans */
      | symbol = "quasiquote" | symbol = "unquote" | symbol = "unquote-splicing"
      | symbol = "define" | symbol = "define-syntax"
 
+   function is_not_variable (symbol: string): bool =
+       symbol = "if" | symbol = "let" | symbol = "unquote"
+     | symbol = "lambda" | symbol = "quote" | symbol = "quasiquote"
+     | symbol = "unquote" | symbol = "unquote-splicing"
+     | symbol = ""
+
    /**** Compilation ****/
 
    function compile_to_vm ( ast: sexp_ast
@@ -1428,11 +1493,21 @@ let /* Booleans */
             else if expected_type <> 0
                   & sym.typ <> type_symbol
                   & sym.typ <> expected_type
-                then ( print(concat5( "Error in atom_to_list: Expected "
+                then ( compile_error( concat5("Error in atom_to_list: Expected "
-                                    , type_id_to_name(expected_type)
+                                             , type_id_to_name(expected_type)
-                                    , " but got "
+                                             , " but got "
-                                    , value_to_string(sym)
+                                             , value_to_string(sym)
-                                    , "!\n"))
+                                             , "!\n")
+                                    , sym)
+                     ; nil )
+
+            else if is_symbol(sym) & is_not_variable(sym.val_s)
+                then ( compile_error(concat5( "Error in atom_to_list: Impossible to load variable "
+                                            , sym.val_s
+                                            , " because it is not a variable!\n"
+                                            , ""
+                                            , "")
+                                    , sym)
                      ; nil )
 
             else if is_symbol(sym)
@@ -1455,7 +1530,9 @@ let /* Booleans */
            let function rec (insns: vm_insn_list_link, sum: int): int =
                  if insns = nil then sum
                                 else rec(insns.next, 1 + sum)
-           in rec(insns.first, 0)
+           in if insns = nil
+              then 0
+              else rec(insns.first, 0)
            end
 
          function set_tree_positions ( ast: sexp_ast
@@ -1784,6 +1861,16 @@ let /* Booleans */
              ( compile_error("Attempting to compile free-standing (). This is not allowed.\n    Must use \"'()\", if nil value is wanted.", ast)
              ; nil )
 
+             /* Throw error if encountering unquote or
+              * unquote-splicing outside of quasiquote */
+           else if ast.typ   = type_symbol
+                 & (ast.val_s = "unquote" | ast.val_s = "unquote-splicing")
+             then ( compile_error(concat5( "Attempting to use \""
+                                         , ast.val_s
+                                         , "\" outside of a quasiquote!  It may be some misplaced brackets."
+                                         , "", ""), ast)
+                  ; nil )
+
              /* Handle numbers and other constants */
            else if ast.typ <> type_pair then
              tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r, expected_type)
@@ -2467,6 +2554,8 @@ let /* Booleans */
                             then DEBUG_PRINT_TAPE  := val_b
                           else if tape[ip].arg1 = 2
                             then DEBUG_PRINT_STACK := val_b
+                          else if tape[ip].arg1 = 3
+                            then DEBUG_SHOW_FULL_ENVIRONMENT  := val_b
                           else run_error("Attempting to use unknown debug option!")
 
                         ; ip := ip + 1