diff --git a/scmvm/assembler.scm b/scmvm/assembler.scm index 6dc8af3..eb16d89 100644 --- a/scmvm/assembler.scm +++ b/scmvm/assembler.scm @@ -6,7 +6,7 @@ #:use-module ((scheme base) #:select (write-bytevector)) #:export ((make-assembler* . make-assembler) assembler? - assembler-pos + assembler-pos assembler-pos-set! assembler-buf assembler-labels emit-label diff --git a/scmvm/language/assembly.scm b/scmvm/language/assembly.scm index 4c82741..b29b8a5 100644 --- a/scmvm/language/assembly.scm +++ b/scmvm/language/assembly.scm @@ -13,8 +13,7 @@ (define (lookup-instruction inst) (define inst-obj (assq (or-alias inst) *instruction-set*)) - (if inst-obj - inst-obj + (or inst-obj (error (format #f "could not find instruction ~a" inst)))) (define label? (negate pair?)) diff --git a/scmvm/language/scheme.scm b/scmvm/language/scheme.scm index 8da0017..d2d1753 100644 --- a/scmvm/language/scheme.scm +++ b/scmvm/language/scheme.scm @@ -1,6 +1,9 @@ (define-module (scmvm language scheme) #:use-module (scmvm assembler) - #:use-module (ice-9 match)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (compile decompile ir-convert)) ;; Scheme compiler ;; Scheme subset we're targeting @@ -29,7 +32,6 @@ (name (cdr v*) (lambda (t*) (k (cons t t*))))))))) - ;; Desugaring ;; Transforms to simplify the language @@ -47,7 +49,7 @@ (define (desugar-prgm prgm) (map (lambda (top) - (if (eq? (car top) 'define) + (if (and (pair? top) (eq? (car top) 'define)) (desugar-define top) (desugar-exp top))) prgm)) @@ -94,14 +96,15 @@ ;; ::= ( ...) ;; | (if ) ;; | (set-then! ) +;; | (define-then! ) ;; ::= (lambda ( ...) exp) -;; | | | | #t | #f +;; | | | #t | #f ;; ;; We choose a hybrid transformation based on https://matt.might.net/articles/cps-conversion/ (define undefined-value (make-symbol "undefined")) -(define (cps-convert expr ktail) +(define (cps-convert-prgm prgm ktail) ;; M : expr -> aexp ;; T-k : expr, (aexp -> cexp) -> cexp ;; T-c : expr, aexp -> cexp @@ -165,17 +168,7 @@ (T*-k e* (lambda ($e*) `(,$f ,@$e* ,c)))))])) (define-cps-loop T*-k T-k) - (T-k expr ktail)) + (T-c prgm ktail)) -(define (cps-convert-prgm prgm) - (if (pair? prgm) - (cons (cps-convert-top (car prgm)) - (cps-convert-prgm (cdr prgm))) - '())) - -(define (cps-convert-top top) - (match top - [`(define ,v ,e) - (cps-convert e (lambda ($rv) `(define ,v ,$rv)))] - [_ - (cps-convert top (lambda _ `(nop)))])) +(define* (ir-convert prgm #:key (ktail 'ktail)) + (cps-convert-prgm (desugar-prgm prgm) ktail)) diff --git a/scmvm/vm.scm b/scmvm/vm.scm index 277ac7e..b69ee62 100644 --- a/scmvm/vm.scm +++ b/scmvm/vm.scm @@ -58,6 +58,9 @@ [(->list) (lambda () (reverse-vector->list the-stack 0 top))] + [(set!) + (lambda (k obj) + (vector-set! the-stack k obj))] [else (error "stack dispatch unknown value")]))) (define (push stack v) @@ -81,6 +84,9 @@ (define (stack->list stack) ((stack '->list))) +(define (stack-set! stack k obj) + ((stack 'set!) k obj)) + ;;; IO (define (read-word) @@ -116,6 +122,7 @@ (rot #x18) (over #x19) (not #x1a) + (set! #x1b) (bye #xff))) (define instruction-name car) @@ -243,6 +250,11 @@ (push data-stack b) (push data-stack a) (push data-stack b))] + [(set!) + ;; use let* to induce an order of evaluation + (let* ([idx (pop data-stack)] + [obj (pop data-stack)]) + (stack-set! data-stack idx obj))] [(bye) (set! exit? #t)]) (when (not exit?) (run-vm vm)))