updating test suite

assembler.scm

@@ -201,10 +201,10 @@
   (apply append lst))
 
 (define (assemble lst)
-  (flatten-once (map assemble-one lst)))
+  (incorporate-labels (fixup-labels   (flatten-once (map assemble-one lst)))))
 
 (define (pa lst)
-  (map (lambda (x) (if (number? x) (format #f "~x" x) x)) (incorporate-labels (fixup-labels (assemble lst)))))
+  (map (lambda (x) (if (number? x) (format #f "~x" x) x)) (assemble lst)))
 
 (define (label-index lst lbl)
   (let loop ((lst lst)
@@ -303,76 +303,6 @@
 		       (loop (cdr lst) result))
 		     (loop (cdr lst) (cons offset result)))))))))
 
-(define test-program '((set a #x30)
-      (set (ref #x1000) #x20)
-      (sub a (ref #x1000))
-      (ifn a #x10)
-      (set pc crash)
-      (set i 10)
-      (set a #x2000)
-      loop
-      (set (ref (+ i #x2000)) (ref a))
-      (sub i 1)
-      (ifn i 0)
-;; trying this
-      (sub pc (relative loop))
-;      (set pc loop)
-      (set x #x4)
-      (jsr testsub)
-      (set pc crash)
-      testsub
-      (shl x 4)
-      (set pc pop)
-      crash
-      (set pc crash)))
 
-(define fibonacci '((set a 0)
-		    (set b 1)
-		    (set i 0)
-		    loop
-		    (add a b)
-		    (set x a)
-		    (set a b)
-		    (set b x)
-		    (add i 1)
-		    (ifg 15 i)
-		    (jb loop)
-		    (brk)))
-
-(define video-output 
-  '((set a #xbeef)
-    (set (ref #x1000) a)
-    (ifn a (ref #x1000))
-    (set pc end)
-    (set i 0)
-    nextchar
-    (ife (ref (+ data i)) 0)
-    (set pc end)
-    (set (ref (+ #x8000 i)) (ref (+ data i)))
-    (add i 1)
-    (set pc nextchar)
-    data
-    "Hello World!"
-    0
-    end
-    (sub pc 1)))
-
-(define read-input '((set push i)
-		     (set i (ref keypointer))
-		     (add i #x9000)
-		     (set target (ref i))
-		     (ife target 0)
-;		     (set pc end)
-		     (jf end)
-		     (set (ref i) 0)
-		     (add (ref keypointer) 1)
-		     (and (ref keypointer) #xf)
-		     end
-		     (set i pop)
-		     (brk)
-		     keypointer
-		     0
-		     target 
-		     0))
 
 ;; foo: add PC, 1 (7dc2 0001)   ->  PC is foo+3

compiler.scm

@@ -49,9 +49,9 @@
   (emit '(add a pop)))
 
 (define-primitive (fx- si env arg1 arg2)
-  (emit-expr si env arg1)
-  (emit '(push a))
   (emit-expr si env arg2)
+  (emit '(push a))
+  (emit-expr si env arg1)
   (emit '(sub a pop)))
 
 (define-primitive (fx< si env arg1 arg2)
@@ -66,6 +66,16 @@
   (emit `(set c ,special/false))
   (emit `(set a c)))
 
+(define-primitive (fx= si env arg1 arg2)
+  (emit-expr si env arg2)
+  (emit `(push a))
+  (emit-expr si env arg1)
+  (emit `(pop b))
+  (emit `(set c ,special/false))
+  (emit `(ife a b))
+  (emit `(set c ,special/true))
+  (emit `(set a c)))
+
 (define (primitive? x)
   (and (symbol? x)
        (hashtable-ref *primitives* x #f)))
@@ -79,13 +89,45 @@
   (cond ((immediate? expr) (emit-immediate expr))
 	((primcall? expr) (emit-primcall si env expr))
 	((if? expr) (emit-if si env expr))
+	((let? expr) (emit-let si env expr))
 	(else (raise-error "unknown expression: ~a" expr))))
 
+
+(define (emit-let si env expr)
+  (let loop ((bindings (let-bindings expr))
+	     (si si)
+	     (new-env env))
+    (cond ((null? bindings)
+	   (emit-expr si new-env (let-body expr)))
+	  (else
+	   (let ((b (car bindings)))
+	     (emit-expr si env (rhs b))
+	     (emit-stack-save si)
+	     (format #t "new binding: ~a ~a~%" (lhs b) si)
+	     (loop (cdr bindings)
+		   (next-stack-index si)
+		   (extend-env new-env (lhs b) si)))))))
+
+(define (extend-env env key value)
+  (cons (cons key value) env))
+
 (define (compile-program form)
   (set! *result* '())
-  (emit-expr 0 #f form)
+  (emit-expr (- word-size) '() form)
   (reverse *result*))
 
+(define (let? expr)
+  (and (list? expr)
+       (eq? (car expr) 'let)))
+(define lhs car)
+(define rhs cadr)
+(define let-bindings cadr)
+(define let-body caddr) ;; TODO: beginify
+(define (next-stack-index si)
+  (- si word-size))
+
+(define word-size 1)
+
 (define (if? expr)
   (and (list? expr)
        (eq? (car expr) 'if)))
@@ -96,6 +138,13 @@
       (set! count (+ count 1))
       (string->symbol (string-append "label-" (number->string count))))))
 
+;; these assume z is set correctly
+(define (emit-stack-save si)
+  (emit `(set (ref (+ z ,si)) a)))
+
+(define (emit-stack-load si)
+  (emit `(set a (ref (+ z ,si)))))
+
 (define (emit-if si env expr)
   (let ((alt-label (unique-label))
 	(end-label (unique-label)))