Permalink
Browse files

updating test suite

  • Loading branch information...
ecraven committed Apr 7, 2012
1 parent 3c7dd5c commit eb9b1fc26fd5e92a4537aba1da914d5a6ec11fc3
Showing with 288 additions and 227 deletions.
  1. +2 −72 assembler.scm
  2. +52 −3 compiler.scm
  3. +234 −152 test-assembler.scm
View
@@ -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
View
@@ -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)))
Oops, something went wrong.

0 comments on commit eb9b1fc

Please sign in to comment.