Improvements

5 files changed, 212 insertions, 157 deletions

diff --git a/atk16_schasm/bootstrap.scm b/atk16_schasm/bootstrap.scm
index d9105f8..30d2324 100644
--- a/atk16_schasm/bootstrap.scm
+++ b/atk16_schasm/bootstrap.scm
@@ -17,7 +17,7 @@
   ;; Set stack pointer to end of heap segment, i.e. one below addr-segment-mmio.
   ;; Stack grows down.
   ;; Heap grows up from addr-segment-heap until it meets the stack.
-  (ld SP ZR (u16 (- addr-segment-mmio 1)))
+  (%ld SP (u16 (- addr-segment-mmio 1)))
   ;; Set graphics mode to disabled.
-  (ld R0 ZR (u16 addr-mmio-graphics-mode))
-  (st R0 ZR (u16 graphics-disabled)))
+  (%ld R0 (u16 addr-mmio-graphics-mode))
+  (%st R0 (u16 graphics-disabled)))
diff --git a/atk16_schasm/core.scm b/atk16_schasm/core.scm
index 32462da..4dd4974 100644
--- a/atk16_schasm/core.scm
+++ b/atk16_schasm/core.scm
@@ -2,60 +2,10 @@
 	(chicken bitwise)
 	(chicken format)
 	(chicken io)
+	(chicken keyword)
 	(only srfi-1 iota))
 
-;; Utils
-
-(define-syntax comment
-  (syntax-rules ()
-    ((_ expr* ...)
-     (begin))))
-
-(define-syntax @
-  (syntax-rules ()
-    ((_ 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)
-  (if (pair? pair) (cdr pair) (error "not a pair" pair)))
-
-(define (assocar k alist)
-  (let ((v (assoc k alist)))
-    (and v (car v))))
-(define (assocdr k alist)
-  (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 '()))
-         (tail dummy))
-    (do ((i 0 (+ i 1)))
-        ((= i len))
-      (set-cdr! tail (cons (char->integer (string-ref s i)) '()))
-      (set! tail (cdr tail)))
-    (cdr dummy)))
+(load "utils.scm")
 
 ;; State
 
@@ -101,10 +51,12 @@
 
 ;; Encode and emit
 
+(define (foobar x y . rest) #f)
+
 (define (encode-byte . chunks)
   (let ((total-bits (apply + (map car chunks))))
     (unless (= total-bits 8)
-      (error "emit: total bits in chunks must equal 8, got" total-bits)))
+      (error "total bits in chunks must equal 8, got" total-bits)))
 
   (let loop ((chs chunks) (acc 0))
     (if (null? chs)
@@ -153,15 +105,21 @@
 
 ;; Directives
 
-(define-syntax def-label
-  (syntax-rules ()
-    ((_ sym exprs* ...)
-     (begin
-       (when (assoc sym *labels*)
-	 (error "label already defined" sym))
+(begin
+  (define (def-label-fn sym)
+    (when (assoc sym *labels*)
+      (error "label already defined" sym))
 
-       (set! *labels* (cons (cons sym *cursor*) *labels*))
-       exprs* ...))))
+    (set! *labels* (cons (cons sym *cursor*) *labels*))
+    )
+  (define-syntax def-label
+    (syntax-rules ()
+      ((_ sym exprs* ...)
+       (begin
+	 (def-label-fn sym)
+	 exprs* ...))))
+
+  )
 
 (define-syntax at-addr
   (syntax-rules ()
@@ -271,66 +229,64 @@
 
 ;; Instructions
 
-(define (hlt)
+(define (%hlt)
   ;; just full zeros
   (emit-word 0))
 
-(define (alu op lhs rhs)
-  (unless (eq? 'alu-op (type-of op)) (error "invalid op" op))
-  (unless (eq? 'reg (type-of lhs)) (error "invalid lhs" lhs))
+(define (%alu op lhs rhs1 #!optional rhs2)
+  (unless (eq? 'reg (type-of lhs)) (error "invalid lhs register" lhs))
+  (define rhs-offset-pair (parse-rhs-offset rhs1 rhs2))
+  (define rhs    (car rhs-offset-pair))
+  (define offset (cdr rhs-offset-pair))
 
-  (define rhs-type (type-of rhs))
   ;; Addressing modes
   ;; 0: reg        (1 word)
-  ;; 1: reg + word (2 words)
-  (define m-mode
-    (cond ((eq? 'reg rhs-type)   0)
-	  ((eq? 'imm rhs-type)   1)
-	  ((eq? 'label rhs-type) 1)
-	  (else (error "invalid rhs" rhs))))
+  ;; 1: reg + word (2 words
 
-  (if (= m-mode 0)
-      ;; reg mode
-      (begin
-	(emit-byte-chunks `(4 . 1)
-			  `(3 . ,(val-of op))
-			  `(1 . ,m-mode))
-	(emit-byte-chunks `(4 . ,(val-of lhs))
-	                  `(4 . ,(val-of rhs))))
+  (define m-mode (if offset 1 0))
 
-      ;; immediate mode
-      (begin
-	(emit-byte-chunks `(4 . 1)
-			  `(3 . ,(val-of op))
-			  `(1 . ,m-mode))
-	(emit-byte-chunks `(4 . ,(val-of lhs))
-			  `(4 . 0))
+  (emit-byte-chunks `(4 . 1)
+		    `(3 . ,(val-of op))
+		    `(1 . ,m-mode))
+  (emit-byte-chunks `(4 . ,(val-of lhs))
+	            `(4 . ,(val-of rhs)))
 
-	(if (eq? 'label rhs-type)
-	    ;; if label, emit a label reference
-	    (begin (emit-deferred-sexpr `(label . (hi ,(val-of rhs))))
-		   (emit-deferred-sexpr `(label . (lo ,(val-of rhs)))))
-	    ;; otherwise, emit the value
-	    (emit-word (val-of rhs))))))
+  (cond
+   ;; in reg+word mode, if label, emit a label reference
+   ((and offset (eq? 'label (type-of offset)))
+    (emit-deferred-sexpr `(label . (hi ,(val-of offset))))
+    (emit-deferred-sexpr `(label . (lo ,(val-of offset)))))
+   ;; in reg+word mode, if imm, emit the value
+   ((and offset (eq? 'imm (type-of offset)))
+    (emit-word (val-of offset)))
+   (offset
+    (error "invalid offset in reg+word addressing mode" offset))))
 
-(define (add lhs rhs) (alu (alu-op 0) lhs rhs))
-(define (sub lhs rhs) (alu (alu-op 1) lhs rhs))
-(define (and lhs rhs) (alu (alu-op 2) lhs rhs))
-(define (or  lhs rhs) (alu (alu-op 3) lhs rhs))
-(define (xor lhs rhs) (alu (alu-op 4) lhs rhs))
-(define (shl lhs rhs) (alu (alu-op 5) lhs rhs))
-(define (shr lhs rhs) (alu (alu-op 6) lhs rhs))
-(define (sar lhs rhs) (alu (alu-op 7) lhs rhs))
+(define (%add lhs rhs1 #!optional rhs2) (%alu (alu-op 0) lhs rhs1 rhs2))
+(define (%sub lhs rhs1 #!optional rhs2) (%alu (alu-op 1) lhs rhs1 rhs2))
+(define (%and lhs rhs1 #!optional rhs2) (%alu (alu-op 2) lhs rhs1 rhs2))
+(define (%or  lhs rhs1 #!optional rhs2) (%alu (alu-op 3) lhs rhs1 rhs2))
+(define (%xor lhs rhs1 #!optional rhs2) (%alu (alu-op 4) lhs rhs1 rhs2))
+(define (%shl lhs rhs1 #!optional rhs2) (%alu (alu-op 5) lhs rhs1 rhs2))
+(define (%shr lhs rhs1 #!optional rhs2) (%alu (alu-op 6) lhs rhs1 rhs2))
+(define (%sar lhs rhs1 #!optional rhs2) (%alu (alu-op 7) lhs rhs1 rhs2))
 
 ;; Load data to to-reg from memory pointed by from-reg + offset.
 ;; With indirect = 0, copies the value from-reg + offset to to-reg without memory access.
-(define (ld to-reg from-reg #!optional offset #!key (indirect 0) (preinc #f))
-  (unless (eq? 'reg (type-of to-reg)) (error "invalid target register" to-reg))
-  (unless (eq? 'reg (type-of from-reg)) (error "invalid source register" from-reg))
-  (unless (or (not offset)
-	      (eq? 'imm (type-of offset))
-	      (eq? 'label (type-of offset)))
-    (error "invalid offset" offset))
+
+;; TODO tää ei toimi niinkun kuvittelis. key arg menee optionaalin paikalle.
+
+(define (%ld lhs rhs1 . rest)
+  (define-values (pos kws) (rest-args rest))
+  (define rhs2 (if (> (length pos) 0) (car pos) #f))
+  (define indirect (or (assocdr #:indirect kws) 0))
+  (define preinc   (or (assocdr #:preinc   kws) #f))
+
+  (unless (eq? 'reg (type-of lhs)) (error "invalid lhs register" lhs))
+  (define rhs-offset-pair (parse-rhs-offset rhs1 rhs2))
+  (define rhs    (car rhs-offset-pair))
+  (define offset (cdr rhs-offset-pair))
+
   (unless (and (number? indirect)
 	       (>= indirect 0)
 	       (<  indirect 4))
@@ -349,8 +305,8 @@
 		    `(2 . ,indirect)
 		    `(1 . ,m-mode)
 		    `(1 . ,p-mode))
-  (emit-byte-chunks `(4 . ,(val-of to-reg))
-		    `(4 . ,(val-of from-reg)))
+  (emit-byte-chunks `(4 . ,(val-of lhs))
+		    `(4 . ,(val-of rhs)))
 
   (cond
    ;; in reg+word mode, if label, emit a label reference
@@ -364,13 +320,17 @@
     (error "invalid offset in reg+word addressing mode" offset))))
 
 ;; Store data in from-reg to memory pointed by to-reg + offset.
-(define (st from-reg to-reg #!optional offset #!key (indirect 1) (postdec #f))
-  (unless (eq? 'reg (type-of to-reg)) (error "invalid target register" to-reg))
-  (unless (eq? 'reg (type-of from-reg)) (error "invalid source register" from-reg))
-  (unless (or (not offset)
-	      (eq? 'imm (type-of offset))
-	      (eq? 'label (type-of offset)))
-    (error "invalid offset" offset))
+(define (%st lhs rhs1 . rest)
+  (define-values (pos kws) (rest-args rest))
+  (define rhs2 (if (> (length pos) 0) (car pos) #f))
+  (define indirect (or (assocdr #:indirect kws) 1))
+  (define postdec  (or (assocdr #:postdec  kws) #f))
+
+  (unless (eq? 'reg (type-of lhs)) (error "invalid lhs register" lhs))
+  (define rhs-offset-pair (parse-rhs-offset rhs1 rhs2))
+  (define rhs    (car rhs-offset-pair))
+  (define offset (cdr rhs-offset-pair))
+
   (unless (and (number? indirect)
 	       (>= indirect 1)
 	       (<  indirect 4))
@@ -389,8 +349,8 @@
 		    `(2 . ,indirect)
 		    `(1 . ,m-mode)
 		    `(1 . ,p-mode))
-  (emit-byte-chunks `(4 . ,(val-of from-reg))
-		    `(4 . ,(val-of to-reg)))
+  (emit-byte-chunks `(4 . ,(val-of lhs))
+		    `(4 . ,(val-of rhs)))
 
   (cond
    ;; in reg+word mode, if label, emit a label reference
@@ -403,7 +363,7 @@
    (offset
     (error "invalid offset in reg+word addressing mode" offset))))
 
-(define (br flag offset #!key (asserted #t))
+(define (%br flag offset #!key (asserted #t))
   (unless (eq? 'flag (type-of flag)) (error "invalid flag selector" flag))
 
   (define set
diff --git a/atk16_schasm/macros.scm b/atk16_schasm/macros.scm
index fb1ed3e..a2091b3 100644
--- a/atk16_schasm/macros.scm
+++ b/atk16_schasm/macros.scm
@@ -18,21 +18,21 @@
 (define-syntax emit-test-eq
   (syntax-rules ()
     ((_ lhs rhs dest set)
-     (begin (sub lhs rhs)
-	    (br flag-zero (label dest) set: set)))))
+     (begin (%sub lhs rhs)
+	    (%br flag-zero (label dest) #:asserted set)))))
 
 (define-syntax emit-test-lt
   (syntax-rules ()
     ((_ lhs rhs dest set)
-     (begin (sub lhs rhs)
-	    (br flag-sign (label dest) set: set)))))
+     (begin (%sub lhs rhs)
+	    (%br flag-sign (label dest) #:asserted set)))))
 
 (define-syntax emit-test-lte
   (syntax-rules ()
     ((_ lhs rhs dest set)
-     (begin (sub lhs rhs)
-	    (sub lhs (u16 1))
-	    (br flag-sign (label dest) set: set)))))
+     (begin (%sub lhs rhs)
+	    (%sub lhs ZR (u16 1))
+	    (%br flag-sign (label dest) #:asserted set)))))
 
 (define-syntax emit-inverted-test
   ;; jump to dest if <lhs op rhs> is NOT true.
@@ -60,12 +60,12 @@
 	    (n    (next-unique))
 	    (sym-false (string->symbol (format "~A-false" n)))
 	    (sym-end   (string->symbol (format "~A-end"   n))))
-       (ld *macro-scratch-reg* lhs)
+       (%ld *macro-scratch-reg* lhs)
 
        (emit-inverted-test *macro-scratch-reg* op rhs sym-false)
 
        tb
-       (ld PC ZR (label sym-end))
+       (%ld PC ZR (label sym-end))
        (def-label sym-false)
        fb
        (def-label sym-end)))))
@@ -78,7 +78,7 @@
 	    (rhs  (eval (caddr `pred)))
 	    (n    (next-unique))
 	    (sym-end   (string->symbol (format "~A-end"   n))))
-       (ld *macro-scratch-reg* lhs)
+       (%ld *macro-scratch-reg* lhs)
 
        (emit-inverted-test *macro-scratch-reg* op rhs sym-end)
 
@@ -95,19 +95,19 @@
 	    (n   (next-unique))
 	    (sym-test (string->symbol (format "~A-test" n)))
 	    (sym-end  (string->symbol (format "~A-end"  n))))
-       (ld *macro-scratch-reg* lhs)
+       (%ld *macro-scratch-reg* lhs)
 
        (def-label sym-test)
        (emit-inverted-test *macro-scratch-reg* op rhs sym-end)
 
        body body* ...
 
-       (ld PC ZR (label sym-test))
+       (%ld PC ZR (label sym-test))
        (def-label sym-end)))))
 
 (define *procedures* '())
 
-(define-syntax %decl-proc
+(define-syntax decl-proc
   (syntax-rules ()
     ((_ signature)
      (set! *procedures*
@@ -137,11 +137,11 @@
 	    (n-max-params 12))
        (unless (<= (length params) n-max-params)
 	 (error (format "proc has too many params (~A > ~A)" (length params) n-max-params)))
-       (%decl-proc signature)
+       (decl-proc signature)
        (def-label name)
        (parameterize ((*proc-scope* bindings))
 	 body* ...)
-       (ld PC SP #f preinc: #t indirect: 1)
+       (%ld PC SP #f preinc: #t indirect: 1)
        ))))
 
 (define-syntax %call
@@ -177,29 +177,29 @@
 		  (itype (type-of argi)))
 	     (cond
 	      ((eq? 'reg itype)
-	       (ld rn argi))
+	       (%ld rn argi))
 	      ((or (eq? 'imm itype)
 		   (eq? 'label itype))
-	       (ld rn ZR argi))
+	       (%ld rn ZR argi))
 	      (else (error "invalid argument" argi))))
 	   (loop (+ 1 i))))
 
-       (ld *macro-scratch-reg* ZR (label sym-ret))
-       (st *macro-scratch-reg* SP #f postdec: #t)
+       (%ld *macro-scratch-reg* ZR (label sym-ret))
+       (%st *macro-scratch-reg* SP #f #:postdec #t)
        
-       (ld PC ZR (label `name))
+       (%ld PC ZR (label `name))
        (def-label sym-ret)
        ))))
 
 (define (spush datum)
   (cond
    ((eq? 'reg (type-of datum))
-    (st datum SP push: #t))
+    (%st datum SP #:postdec #t))
    (else
-    (ld *macro-scratch-reg* datum)
-    (st *macro-scratch-reg* SP push: #t indirect: 1))))
+    (%ld *macro-scratch-reg* datum)
+    (%st *macro-scratch-reg* SP #:postdec #t #:indirect 1))))
 
 (define (spop reg)
   (unless (eq? 'reg (type-of reg))
     (error "not a register" reg))
-  (ld reg SP pop: #t indirect: 1))
+  (%ld reg SP #:preinc #t #:indirect 1))
diff --git a/atk16_schasm/main.scm b/atk16_schasm/main.scm
index 4dc353a..62d2919 100644
--- a/atk16_schasm/main.scm
+++ b/atk16_schasm/main.scm
@@ -8,7 +8,7 @@
 (emit-word #x1234)
 
 ;; compile instructions
-(ld SP ZR (u16 0))
+(%ld SP ZR (u16 0))
 
 ;; set labels
 (def-label 'some-data
@@ -18,19 +18,19 @@
 ;; set the current emit address
 (at-addr #x20)
 (def-label 'main
-  (add R1 R2)
-  (add R3 (u16 #xFF)))
+  (%add R1 R2)
+  (%add R3 (u16 #xFE)))
 
 ;; abs jump
-(ld PC ZR (label 'main))
+(%ld PC (label 'main))
 
 ;; rel jump
-(add PC (i16 10))
+(%add PC (i16 10))
 
 ;; jump forward to a currently undefined label
-(ld PC ZR (label 'forward))
+(%ld PC (label 'forward))
 (def-label 'forward
-  (hlt))
+  (%hlt))
 
 ;; store string data in memory
 (def-label 'text-data
@@ -39,7 +39,7 @@
 (at-addr #x50)
 
 ;; branch based on an ALU flag
-(br flag-carry (label 'branch-true) set: #t)
+(%br flag-carry (label 'branch-true) #:asserted #t)
 (def-label 'branch-false
   (emit-word 1))
 (def-label 'branch-true
@@ -66,10 +66,10 @@
        )
 
 ;; procedure calls
-(ld R1 ZR (u16 10))
+(%ld R1 (u16 10))
 (%while (R1 > (u16 0))
 	(%call println (label 'text-data))
-	(sub R1 (u16 1)))
+	(%sub R1 (u16 1)))
 
 ;; compile to a 128KB image file
 (write-image-to "out.bin")
diff --git a/atk16_schasm/utils.scm b/atk16_schasm/utils.scm
new file mode 100644
index 0000000..f5e74e3
--- /dev/null
+++ b/atk16_schasm/utils.scm
@@ -0,0 +1,95 @@
+;; Utils
+
+(define-syntax comment
+  (syntax-rules ()
+    ((_ expr* ...)
+     (begin))))
+
+(define-syntax @
+  (syntax-rules ()
+    ((_ 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)
+  (if (pair? pair) (cdr pair) (error "not a pair" pair)))
+
+(define (parse-rhs-offset rhs1 rhs2)
+  (define t1 (and rhs1 (type-of rhs1)))
+  (define t2 (and rhs2 (type-of rhs2)))
+
+  (define regs '())
+  (when (eq? 'reg t1)
+    (set! regs (cons rhs1 regs)))
+  (when (eq? 'reg t2)
+    (set! regs (cons rhs2 regs)))
+  (unless (<= (length regs) 1)
+    (error "only one register can be supplied as rhs"))
+
+  (define offsets '())
+  (when (or (eq? 'imm t1) (eq? 'label t1))
+    (set! offsets (cons rhs1 offsets)))
+  (when (or (eq? 'imm t2) (eq? 'label t2))
+    (set! offsets (cons rhs2 offsets)))
+  (unless (<= (length offsets) 1)
+    (error "only one imm or label can be supplied as rhs"))
+
+  (define rhs    (if (null? regs)    ZR      (car regs)))
+  (define offset (if (null? offsets) (imm 0) (car offsets)))
+
+  (cons rhs offset))
+
+(define (assocar k alist)
+  (let ((v (assoc k alist)))
+    (and v (car v))))
+(define (assocdr k alist)
+  (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 '()))
+         (tail dummy))
+    (do ((i 0 (+ i 1)))
+        ((= i len))
+      (set-cdr! tail (cons (char->integer (string-ref s i)) '()))
+      (set! tail (cdr tail)))
+    (cdr dummy)))
+
+(define (rest-args args)
+  (define pos '())
+  (define kws '())
+
+  (let loop ((as args))
+    (when (not (null? as))
+      (let ((head (car as))
+	    (tail (cdr as)))
+	(cond
+	 ((keyword? head)
+	  (set! kws (cons (cons head (car tail)) kws))
+	  (loop (cdr tail)))
+	 (else
+	  (set! pos (append pos (list head)))
+	  (loop tail))))))
+
+  (values pos kws))