schasm updates

5 files changed, 134 insertions, 93 deletions

diff --git a/atk16_schasm/core.scm b/atk16_schasm/core.scm
index 4dd4974..32a8b70 100644
--- a/atk16_schasm/core.scm
+++ b/atk16_schasm/core.scm
@@ -105,21 +105,16 @@
 
 ;; Directives
 
-(begin
-  (define (def-label-fn sym)
-    (when (assoc sym *labels*)
-      (error "label already defined" sym))
+(define-syntax def-label
+  (syntax-rules ()
+    ((_ sym exprs* ...)
+     (begin
+       (when (assoc sym *labels*)
+	 (error "label already defined" sym))
 
-    (set! *labels* (cons (cons sym *cursor*) *labels*))
-    )
-  (define-syntax def-label
-    (syntax-rules ()
-      ((_ sym exprs* ...)
-       (begin
-	 (def-label-fn sym)
-	 exprs* ...))))
+       (set! *labels* (cons (cons sym *cursor*) *labels*))
 
-  )
+       exprs* ...))))
 
 (define-syntax at-addr
   (syntax-rules ()
@@ -152,25 +147,29 @@
 (define R3  (reg 3))
 (define R4  (reg 4))
 (define R5  (reg 5))
-;; R6..R11 callee saved arguments, generic
+;; R6..R9 callee saved arguments, generic
 (define R6  (reg 6))
 (define R7  (reg 7))
 (define R8  (reg 8))
 (define R9  (reg 9))
+;; Special (see below)
 (define R10 (reg 10))
 (define R11 (reg 11))
-;; Special (see below)
 (define R12 (reg 12))
 (define R13 (reg 13))
 (define R14 (reg 14))
 (define R15 (reg 15))
 
+;; Assembler temp register (clobbered in some macros)
+(define TMP (reg 10))
 ;; Zero register (hardwired to 0)
-(define ZR (reg 12))
+(define ZR (reg 11))
 ;; Flag register (only lowest 4 bits set by ALU)
-(define FL (reg 13))
+(define FL (reg 12))
 ;; Program counter
-(define PC (reg 14))
+(define PC (reg 13))
+;; Base pointer
+(define BP (reg 14))
 ;; Stack pointer
 (define SP (reg 15))
 
@@ -273,9 +272,6 @@
 
 ;; 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.
-
-;; 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))
diff --git a/atk16_schasm/macros.scm b/atk16_schasm/macros.scm
index a2091b3..9253eeb 100644
--- a/atk16_schasm/macros.scm
+++ b/atk16_schasm/macros.scm
@@ -4,7 +4,6 @@
 (define (next-unique)
   (inc! *unique-counter*)
   *unique-counter*)
-(define *macro-scratch-reg* R11)
 
 (define (%packed-string s)
   ;; emit length
@@ -60,12 +59,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 TMP lhs)
 
-       (emit-inverted-test *macro-scratch-reg* op rhs sym-false)
+       (emit-inverted-test TMP op rhs sym-false)
 
        tb
-       (%ld PC ZR (label sym-end))
+       (%ld PC (label sym-end))
        (def-label sym-false)
        fb
        (def-label sym-end)))))
@@ -78,9 +77,9 @@
 	    (rhs  (eval (caddr `pred)))
 	    (n    (next-unique))
 	    (sym-end   (string->symbol (format "~A-end"   n))))
-       (%ld *macro-scratch-reg* lhs)
+       (%ld TMP lhs)
 
-       (emit-inverted-test *macro-scratch-reg* op rhs sym-end)
+       (emit-inverted-test TMP op rhs sym-end)
 
        body body* ...
 
@@ -95,16 +94,80 @@
 	    (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 TMP lhs)
 
        (def-label sym-test)
-       (emit-inverted-test *macro-scratch-reg* op rhs sym-end)
+       (emit-inverted-test TMP op rhs sym-end)
 
        body body* ...
 
        (%ld PC ZR (label sym-test))
        (def-label sym-end)))))
 
+;; Stack push and pop
+
+(define (%spush word)
+  (cond
+   ((eq? 'reg (type-of word))
+    (%st word SP #:postdec #t))
+   (else
+    (%ld TMP word)
+    (%st TMP SP #:postdec #t #:indirect 1))))
+
+(define (%spop reg)
+  (unless (eq? 'reg (type-of reg))
+    (error "not a register" reg))
+  (%ld reg SP #:preinc #t #:indirect 1))
+
+;; Stack variables and parameter registers
+
+(define *params*   '())
+(define *soffsets* '())
+(define *ssizes*   '())
+(define *proc?*    #f)
+
+(define (get-param name)
+  (or (assocdr name *params*)
+      (error "no such param" name)))
+
+(define (get-soffset name)
+  (or (assocdr name *soffsets*)
+      (error "no such svar" name)))
+
+(define (get-ssize name)
+  (or (assocdr name *ssizes*)
+      (error "no such svar" name)))
+
+(define-syntax param
+  (syntax-rules ()
+    ((_ name)
+     (get-param `name))))
+
+(define-syntax soffset
+  (syntax-rules ()
+    ((_ name)
+     (get-soffset `name))))
+
+(define-syntax ssize
+  (syntax-rules ()
+    ((_ name)
+     (get-ssize `name))))
+
+(define (svars-size)
+  (apply + (map (@ cdr) *ssizes*)))
+
+(define (def-svar name size)
+  (set! *soffsets* (cons `(,name . ,(svars-size)) *soffsets*))
+  (set! *ssizes*   (cons `(,name . ,size)         *ssizes*))
+  (%sub SP (u16 size)))
+
+(define-syntax %svar
+  (syntax-rules ()
+    ((_ name size)
+     (def-svar `name size))))
+
+;; Procedure definitions and calls
+
 (define *procedures* '())
 
 (define-syntax decl-proc
@@ -114,18 +177,18 @@
        (cons `signature *procedures*))
      )))
 
-(define *proc-scope* (make-parameter #f))
+(define (%return #!optional word)
+  ;; Load word into R0 (return value register)
+  (when word
+    (%ld R0 word))
 
-(define (param pname)
-  (let* ((scope (or (*proc-scope*)
-		    (error "cannot use params outside a procedure context"))))
-    (or (assocdr pname (*proc-scope*))
-	(error "no such param" pname))))
+  ;; Free up stack memory that was used in this proc
+  ;; by setting SP to base pointer
+  (%ld SP BP)
 
-(define-syntax %param
-  (syntax-rules ()
-    ((_ pname)
-     (param 'pname))))
+  ;; Pop the base pointer and return address from the stack
+  (%spop BP)
+  (%spop PC))
 
 (define-syntax %proc
   (syntax-rules ()
@@ -137,11 +200,27 @@
 	    (n-max-params 12))
        (unless (<= (length params) n-max-params)
 	 (error (format "proc has too many params (~A > ~A)" (length params) n-max-params)))
+
+       (unless (not *proc?*)
+	 (error "nested procs not supported" name))
+
        (decl-proc signature)
        (def-label name)
-       (parameterize ((*proc-scope* bindings))
-	 body* ...)
-       (%ld PC SP #f preinc: #t indirect: 1)
+
+       (define old-offsets *soffsets*)
+       (define old-sizes   *ssizes*)
+       (set! *soffsets* '())
+       (set! *ssizes*   '())
+       (set! *proc?*    #t)
+       (set! *params*   bindings)
+
+       body* ...
+
+       (%return)
+
+       (set! *soffsets* old-offsets)
+       (set! *ssizes*   old-sizes)
+       (set! *proc?* #f)
        ))))
 
 (define-syntax %call
@@ -184,22 +263,16 @@
 	      (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 PC ZR (label `name))
-       (def-label sym-ret)
-       ))))
+       ;; Push the return address and base pointer to the stack
+       (%spush (label sym-ret))
+       (%spush BP)
 
-(define (spush datum)
-  (cond
-   ((eq? 'reg (type-of datum))
-    (%st datum SP #:postdec #t))
-   (else
-    (%ld *macro-scratch-reg* datum)
-    (%st *macro-scratch-reg* SP #:postdec #t #:indirect 1))))
+       ;; Update base pointer to current stack pointer
+       (%ld BP SP)
 
-(define (spop reg)
-  (unless (eq? 'reg (type-of reg))
-    (error "not a register" reg))
-  (%ld reg SP #:preinc #t #:indirect 1))
+       ;; Jump to the procedure address
+       (%ld PC (label `name))
+
+       ;; Define the return address
+       (def-label sym-ret)
+       ))))
diff --git a/atk16_schasm/main.scm b/atk16_schasm/main.scm
index 62d2919..cdaa3dd 100644
--- a/atk16_schasm/main.scm
+++ b/atk16_schasm/main.scm
@@ -57,10 +57,10 @@
 ;; procedures
 (%proc (println *str)
 
-       (%param *str) ;; => evaluates to R0
-       ;;(%svar x 1)   ;; allocate a word on the stack
-       ;;(%svar y 1)   ;; allocate another word on the stack
-       ;;(%soffset y)  ;; => evaluates to frame offset 1
+       (%ld R3 (param *str)) ;; => evaluates to R0
+       (%svar x 1)   ;; allocate a word on the stack
+       (%svar y 1)   ;; allocate another word on the stack
+       (%ld R2 (u16 (soffset y)))  ;; => evaluates to frame offset 1
 
        ;; %proc epilogue fees the %svars
        )
diff --git a/atk16_schasm/structs_idea.scm b/atk16_schasm/structs_idea.scm
deleted file mode 100644
index d2fcc86..0000000
--- a/atk16_schasm/structs_idea.scm
+++ /dev/null
@@ -1,28 +0,0 @@
-# This buffer is for notes you don’t want to save, and for Chicken Scheme code.
-
-;; define structs
-(%def-struct point
-	     (x  u16)
-	     (y  u16))
-
-;; static struct instances
-(%static global-point
-	 point (u16 10) (u16 20))
-
-;; use static address as load offset
-(ld R0 ZR (global-point:x))
-
-;; stack allocated instances
-(%def-proc (main)
-	   ;; alloc some space on the stack
-	   (%svar my-point (point:size))
-	   ;; use stack offset as load offset
-	   (ld R0 SP (my-point:x)))
-
-;; a vector of static instances
-(let loop ((i 0))
-  (when (< i 10)
-    (%static (string->symbol (format "global-points/~A" i))
-	     point (u16 i) (u16 i))))
-
-(ld R0 ZR (global-points/0:x))
diff --git a/atk16_schasm/utils.scm b/atk16_schasm/utils.scm
index f5e74e3..06160ab 100644
--- a/atk16_schasm/utils.scm
+++ b/atk16_schasm/utils.scm
@@ -41,8 +41,8 @@
   (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)))
+  (define rhs    (if (null? regs)    ZR (car regs)))
+  (define offset (if (null? offsets) #f (car offsets)))
 
   (cons rhs offset))