Syntax-rules macroes can now capture variables and use them in the template. Ellipsis not implemented yet.

example.scm

@@ -3,6 +3,10 @@
 
 ;;; Standard lib, in scheme
 
+; TODO: Fix below
+(define eq? eqv?)
+(define equal? eqv?)
+
 ; Lists
 
 (define (foldl f i l)
@@ -37,6 +41,30 @@
              x
              (list-tail (cdr x) (- k 1)))))
 
+(define generic-member
+  (lambda (compare obj ls)
+    (if (null? ls)
+      #f
+      (if (compare obj (car ls))
+          ls
+          (generic-member compare obj (cdr ls))))))
+
+(define (memq   obj ls) (generic-member eq?    obj ls))
+(define (memv   obj ls) (generic-member eqv?   obj ls))
+(define (member obj ls) (generic-member equal? obj ls))
+
+(define (generic-assoc compare key als)
+  (if (null? als)
+      #f
+      (if (compare key (caar als))
+          (cdr (car als))
+          (generic-assoc compare key (cdr als)))))
+
+(define (assq  obj ls) (generic-assoc eq?    obj ls))
+(define (assv  obj ls) (generic-assoc eqv?   obj ls))
+(define (assoc obj ls) (generic-assoc equal? obj ls))
+
+
 
 ; Math
 
@@ -379,32 +407,86 @@
 
 (header "Testing syntax-rules (move to macro once implemented)")
 
-(define equal? eqv?)
-
 (define construct-pattern-predicate
-  (lambda (name pat)
+  (lambda (name pat literals)
-    (if (if (symbol? pat) #t (number? pat))
+    (if (number? pat)
-        `(equal? ,name ',pat)
+        `(equal? ,name ,pat)
+
+    ; Is symbol
+    (if (symbol? pat)
+        (if (member pat literals)
+            ; Is literal
+            `(equal? ,name ',pat)
+            ; Or is variable binding
+            #t)
+
     (if (null? pat)
         `(null? ,name)
+
     (if (pair? pat)
         `(if (pair? ,name)
-             (if ,(construct-pattern-predicate `(car ,name) (car pat))
+             (if ,(construct-pattern-predicate `(car ,name)
-                 ,(construct-pattern-predicate `(cdr ,name) (cdr pat))
+                                               (car pat)
+                                               literals)
+                 ,(construct-pattern-predicate `(cdr ,name)
+                                               (cdr pat)
+                                               literals)
                  #f)
              #f)
-    'fuck )))))
+    'fuck ))))))
+
+(define (find-variable-bindings literals path pattern)
+    ; Is symbol
+    (if (if (symbol? pattern) (not (member pattern literals)) #f)
+        `((,pattern ,path))
+
+    ; Is pair
+
+    (if (pair? pattern)
+        (append (find-variable-bindings literals `(car ,path) (car pattern))
+                (find-variable-bindings literals `(cdr ,path) (cdr pattern)))
+
+    ; Is anything else
+    ; TODO: Vector patterns
+
+    '() )))
+
+(define (construct-result bindings template)
+    ; Is symbol
+    (if (if (symbol? template) (assoc template bindings) #f)
+        (cons 'unquote (cons template '()))
+
+    ; Is pair
+
+    (if (pair? template)
+        (cons (construct-result bindings (car template))
+              (construct-result bindings (cdr template)))
+
+    ; Is anything else
+    ; TODO: Vector patterns
+
+    template )))
 
 (define syntax-rules-rec
-  (lambda (macro-name var-name rules)
+  (lambda (macro-name var-name literals rules)
     (if (null? rules)
         'doublefuck
         (let ((pattern  (caar rules))
-              (result   (cadar rules)))
+              (result   (cadar rules))
+              (bindings (find-variable-bindings literals var-name (caar rules)))
+             )
           (if (eqv? macro-name (car pattern))
-              `(if ,(construct-pattern-predicate var-name pattern)
+              `(if ,(construct-pattern-predicate var-name
-                   ',result
+                                                 pattern
-                   ,(syntax-rules-rec macro-name var-name (cdr rules)))
+                                                 literals )
+                   (let ,bindings
+                     ,(let ((sefijoesfeji (construct-result bindings result)))
+                        (begin (display "Mjerf: ")
+                               (display sefijoesfeji)
+                               (newline)
+                               (cons 'quasiquote (cons sefijoesfeji '()))))
+                     )
+                   ,(syntax-rules-rec macro-name var-name literals (cdr rules)))
 
               (begin (display "Incorrect usage of syntax-rules-rec: Each rule must have same first symbol.")
                      (display "\n\tFirst had ")
@@ -417,19 +499,16 @@
 
 (define-syntax syntax-rules
   (lambda (vo)
-    (let ((literals  (cadr vo))
+    (let ((literals  (cons (car (caaddr vo)) (cadr vo)))
           (rules     (cddr vo))
           (name      (car (caaddr vo))))
 
       `(lambda (vo2)
-         ,( syntax-rules-rec name 'vo2 rules))
+         ,( syntax-rules-rec name 'vo2 literals rules ))
       )))
 
 ; Define true
 
-(syntax-rules ()
-  ((name ...) ...))
-
 (define-syntax true
  (syntax-rules ()
     ((true) #t)))
@@ -464,7 +543,7 @@
        ))
 
 (define-syntax derp
- (syntax-rules ()
+ (syntax-rules (two)
     ((derp) 1)
     ((derp two) (+ (derp) (derp)))
     ))
@@ -475,6 +554,20 @@
         ( 2 . ,(derp two))
        ))
 
+(define-syntax +1
+  (syntax-rules ()
+    ((+1 n) (+ 1 n))))
+
+(test "Defining +1 using syntax-rules."
+      `(
+        ( 6 . ,(+1 5))
+        ( 1 . ,(+1 0))
+        ( 0 . ,(+1 -1))
+       ))
+
+(exit)
+
+
 ;;;;; ;
 
 (exit)

tigerscheme.tig

@@ -9,6 +9,9 @@ let /* Booleans */
 
     var IS_NIL_TRUTHY      : bool := false
     var HAS_NIL_SYMBOL     : bool := false
+    var ALLOW_TAPE_RESIZE  : bool := true
+    var ASSUME_NO_OVERWRITE_STDLIB  : bool := true
+
     var DEBUG_PRINT_STACK  : bool := false
     var DEBUG_PRINT_TAPE   : bool := false
     var DEBUG_PRINT_PARSED : bool := false
@@ -16,8 +19,6 @@ let /* Booleans */
     var DEBUG_PRINT_MACRO  : bool := true
     var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false
 
-    var ALLOW_TAPE_RESIZE  : bool := true
-
     var TRIGGERED_EXIT : bool := false
 
     /* Basic utility */
@@ -2031,7 +2032,9 @@ let /* Booleans */
                           ; /* TODO: Assert that there is something on the stack */
                             derp := stack_pop(stack)
                           ; if DEBUG_PRINT_MACRO
-                            then ( print("Macro expanded to: ")
+                            then ( print("Macro \"")
+                                 ; print(ast.val_car.val_s )
+                                 ; print("\" expanded to: ")
                                  ; print(value_to_string(derp))
                                  ; print("\n") )
                           ; compile_rec(derp, can_tail_call, type_any)