Develop procedure macros

3 files changed, 56 insertions, 17 deletions

diff --git a/atk16_schasm/core.scm b/atk16_schasm/core.scm
index 08a0bd5..7c292f1 100644
--- a/atk16_schasm/core.scm
+++ b/atk16_schasm/core.scm
@@ -1,7 +1,8 @@
 (import (chicken base)
 	(chicken bitwise)
 	(chicken format)
-	(chicken io))
+	(chicken io)
+	(only srfi-1 iota))
 
 ;; Utils
 
@@ -15,6 +16,12 @@
     ((_ fn-body expr ...)
      (lambda (x) (fn-body expr ... x)))))
 
+(define (zip alist blist)
+  (if (null? alist)
+      '()
+      ;; else, cons and recurse
+      (cons (cons (car alist) (car blist)) (zip (cdr alist) (cdr blist)))))
+
 (define (type-of pair)
   (if (pair? pair) (car pair) (error "not a pair" pair)))
 (define (val-of pair)
@@ -27,6 +34,19 @@
   (let ((v (assoc k alist)))
     (and v (cdr v))))
 
+(define-syntax inc!
+  (syntax-rules ()
+    ((_ n)
+     (set! n (+ n 1)))
+    ((_ n m)
+     (set! n (+ n m)))))
+(define-syntax sub!
+  (syntax-rules ()
+    ((_ n)
+     (set! n (- n 1)))
+    ((_ n m)
+     (set! n (- n m)))))
+
 (define (string->ascii-list s)
   (let* ((len (string-length s))
          (dummy (cons #f '()))
diff --git a/atk16_schasm/macros.scm b/atk16_schasm/macros.scm
index 7ae4cc1..31cc91e 100644
--- a/atk16_schasm/macros.scm
+++ b/atk16_schasm/macros.scm
@@ -2,7 +2,7 @@
 
 (define *unique-counter* 0)
 (define (next-unique)
-  (set! *unique-counter* (+ 1 *unique-counter*))
+  (inc! *unique-counter*)
   *unique-counter*)
 (define *macro-scratch-reg* R12)
 
@@ -54,9 +54,9 @@
 (define-syntax %if-else
   (syntax-rules ()
     ((_ pred tb fb)
-     (let* ((lhs  (eval (car 'pred)))
+     (let* ((lhs  (eval (car `pred)))
 	    (op   (cadr 'pred))
-	    (rhs  (eval (caddr 'pred)))
+	    (rhs  (eval (caddr `pred)))
 	    (n    (next-unique))
 	    (sym-false (string->symbol (format "~A-false" n)))
 	    (sym-end   (string->symbol (format "~A-end"   n))))
@@ -73,9 +73,9 @@
 (define-syntax %when
   (syntax-rules ()
     ((_ pred body body* ...)
-     (let* ((lhs  (eval (car 'pred)))
+     (let* ((lhs  (eval (car `pred)))
 	    (op   (cadr 'pred))
-	    (rhs  (eval (caddr 'pred)))
+	    (rhs  (eval (caddr `pred)))
 	    (n    (next-unique))
 	    (sym-end   (string->symbol (format "~A-end"   n))))
        (ld *macro-scratch-reg* lhs)
@@ -89,9 +89,9 @@
 (define-syntax %while
   (syntax-rules ()
     ((_ pred body body* ...)
-     (let* ((lhs (eval (car 'pred)))
+     (let* ((lhs (eval (car `pred)))
 	    (op  (cadr 'pred))
-	    (rhs (eval (caddr 'pred)))
+	    (rhs (eval (caddr `pred)))
 	    (n   (next-unique))
 	    (sym-test (string->symbol (format "~A-test" n)))
 	    (sym-end  (string->symbol (format "~A-end"  n))))
@@ -107,17 +107,38 @@
 
 (define *procedures* '())
 
-(define-syntax %def-proc
+(define-syntax %decl-proc
   (syntax-rules ()
-    ((_ name params* ...)
+    ((_ signature)
      (set! *procedures*
-       (cons (list 'name 'params* ...) *procedures*)))))
+       (cons `signature *procedures*))
+     )))
+
+(define *proc-scope* (make-parameter #f))
+
+(define (param pname)
+  (or (assocdr pname (*proc-scope*))
+      (error "no such param" pname)))
+
+(define-syntax %def-proc
+  (syntax-rules ()
+    ((_ signature body* ...)
+     (let* ((name     (car `signature))
+	    (params   (cdr `signature))
+	    (bindings (zip params
+                           (map (@ reg) (iota (length params) 0)))))
+       (%decl-proc signature)
+       (print name)
+       (def-label name)
+       (parameterize ((*proc-scope* bindings))
+	 body* ...)
+       ))))
 
 (define-syntax %call
   (syntax-rules ()
     ((_ name args* ...)
      (let* ((params  (or (assocdr 'name *procedures*)
-		        (error "proc not defined" 'name)))
+			 (error "proc not defined" 'name)))
 	    (args    (list args* ...))
 	    (n       (next-unique))
 	    (sym-ret (string->symbol (format "~A-ret" n))))
diff --git a/atk16_schasm/main.scm b/atk16_schasm/main.scm
index fbae70c..931a9db 100644
--- a/atk16_schasm/main.scm
+++ b/atk16_schasm/main.scm
@@ -54,11 +54,9 @@
 (%when (R1 <= (u16 #xFF))
      (emit-word #xbeef))
 
-;; procedure declarations
-(%def-proc println str)
-(def-label 'println
-  ;; R0 := str
-  ;; ...
+;; procedures
+(%def-proc (println *str)
+  (param '*str) ;; => R0
   (ld PC SP pop: #t indirect: 1))
 
 ;; procedure calls