diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 27baa5558..672fa210d 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -93,13 +93,15 @@ (and (vector? x) (eq? (vector-ref x 0) ',name))) ,@(do ((n 1 (1+ n)) (slots (cdr def) (cdr slots)) - (ls '() (append (let* ((slot (car slots)) - (slot (if (pair? slot) (car slot) slot))) + (ls '() (append (let* ((sdef (car slots)) + (sname (if (pair? sdef) (car sdef) sdef))) `((define ,(string->symbol (format #f "~A-~A" name n)) - (lambda (x) (slot x ',slot))) - (define ,(symbol-append stem '- slot) - (lambda (x) (slot x ',slot))))) + (lambda (x) (slot x ',sname))) + (define ,(symbol-append stem '- sname) + ,(make-procedure-with-setter + (lambda (x) (get-slot x sname)) + (lambda (x v) (set-slot! x sname v)))))) ls))) ((null? slots) (reverse! ls)))))) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 43b5d6cd0..3e134a0c1 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -37,38 +37,44 @@ (define (optimize x) (record-case x - (( env var val) + (( env loc var val) (make-ghil-set env var (optimize val))) - (( test then else) + (( env loc test then else) (make-ghil-if (optimize test) (optimize then) (optimize else))) - (( exps) + (( env loc exps) (make-ghil-begin (map optimize exps))) - (( env vars vals body) + (( env loc vars vals body) (make-ghil-bind env vars (map optimize vals) (optimize body))) - (( env vars rest body) + (( env loc vars rest body) (make-ghil-lambda env vars rest (optimize body))) ;; FIXME: does not exist. -- Ludo'. ; (($ inst args) ; (make-ghil-inst inst (map optimize args))) - (( env proc args) - (record-case proc - ;; ((@lambda (VAR...) BODY...) ARG...) => - ;; (@let ((VAR ARG) ...) BODY...) - (( lambda-env vars #f body) - (for-each (lambda (v) - (if (eq? v.kind 'argument) (set! v.kind 'local)) - (set! v.env env) - (ghil-env-add! env v)) - lambda-env.variables) - (optimize (make-ghil-bind env vars args body))) - (else - (make-ghil-call env (optimize proc) (map optimize args))))) + (( env loc proc args) + (let ((parent-env env)) + (record-case proc + ;; ((@lambda (VAR...) BODY...) ARG...) => + ;; (@let ((VAR ARG) ...) BODY...) + (( env loc vars rest body) + (cond + ((not rest) + (for-each (lambda (v) + (case (ghil-var-kind v) + ((argument) (set! (ghil-var-kind v) 'local))) + (set! (ghil-var-env v) parent-env) + (ghil-env-add! parent-env v)) + (ghil-env-variables env))) + (else + (make-ghil-call parent-env (optimize proc) (map optimize args))))) + (else + (make-ghil-call parent-env (optimize proc) (map optimize args)))))) + (else x))) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 5b42c63f9..408b917bd 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -61,7 +61,6 @@ ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body make-ghil-lambda ? -1 -2 -3 -4 -5 - ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body make-ghil-inline ? -1 -2 -3 -4 @@ -152,34 +151,45 @@ (( m) (%make-ghil-env :mod m :parent e)))) (define (ghil-env-toplevel? e) - (eq? e.mod e.parent)) + (eq? (ghil-env-mod e) (gil-env-parent e))) (define (ghil-env-ref env sym) - (assq-ref env.table sym)) + (assq-ref (ghil-env-table env) sym)) + +(define-macro (push! item loc) + `(set! ,loc (cons ,item ,loc))) +(define-macro (apush! k v loc) + `(set! ,loc (acons ,k ,v ,loc))) +(define-macro (apopq! k loc) + `(set! ,loc (assq-remove! ,k ,loc))) (define-public (ghil-env-add! env var) - (set! env.table (acons var.name var env.table)) - (set! env.variables (cons var env.variables))) + (apush! (ghil-var-name var) var (ghil-env-table env)) + (push! var (ghil-env-variables env))) (define (ghil-env-remove! env var) - (set! env.table (assq-remove! env.table var.name))) + (apopq! (ghil-var-name var) (ghil-env-table env))) ;;; ;;; Public interface ;;; +;; looking up a var has side effects? (define-public (ghil-lookup env sym) (or (ghil-env-ref env sym) - (let loop ((e env.parent)) - (cond ((? e) - (or (assq-ref e.table sym) - (let ((var (make-ghil-var #f sym 'module))) - (set! e.table (acons sym var e.table)) - var))) - ((ghil-env-ref e sym) => - (lambda (var) (set! var.kind 'external) var)) - (else (loop e.parent)))))) + (let loop ((e (ghil-env-parent env))) + (record-case e + (( module table imports) + (or (assq-ref table sym) + (let ((var (make-ghil-var #f sym 'module))) + (apush! sym var (ghil-mod-table e)) + var))) + (( mod parent table variables) + (let ((found (assq-ref table sym))) + (if found + (begin (set! (ghil-var-kind found) 'external) found) + (loop parent)))))))) (define-public (call-with-ghil-environment e syms func) (let* ((e (make-ghil-env e)) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index 33c44b1e7..a83535b2a 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -157,7 +157,8 @@ (record-case glil ;; meta (( vars body) - `(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts) + `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars) + ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars)) ,@(map unparse body))) (( vars) `(@bind ,@vars)) (() `(@unbind)) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 686d89714..cf72df3b7 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -46,9 +46,9 @@ (display "debug> ") (let ((cmd (read))) (case cmd - ((bt) (vm-backtrace db.vm)) + ((bt) (vm-backtrace (debugger-vm db))) ((stack) - (write (vm-fetch-stack db.vm)) + (write (vm-fetch-stack (debugger-vm db))) (newline)) (else (format #t "Unknown command: ~A" cmd))))))