diff --git a/module/language/gscheme/spec.scm b/module/language/gscheme/spec.scm index e5a23b88e..c40e80466 100644 --- a/module/language/gscheme/spec.scm +++ b/module/language/gscheme/spec.scm @@ -22,7 +22,6 @@ (define-module (language gscheme spec) :use-module (system base language) :use-module (system il ghil) - :use-module (language r5rs expand) :use-module (ice-9 match) :use-module (ice-9 and-let-star) :export (gscheme)) @@ -32,7 +31,8 @@ ;;; Macro expander ;;; -(define expand-syntax expand) +(define (expand x) + (expand-macro x (current-module))) (define (expand-macro x m) (if (pair? x) @@ -43,9 +43,6 @@ (cons (expand-macro (car x) m) (expand-macro (cdr x) m)))) x)) -(define (expand x) - (expand-syntax (expand-macro x (current-module)))) - ;;; ;;; Translator @@ -56,9 +53,18 @@ (define (translate-pair x) (let ((head (car x)) (rest (cdr x))) (case head - ((quote) (cons '@quote rest)) - ((define set! if and or begin) + ((quote) `(@quote ,@rest)) + ((set! if and or begin) (cons (symbol-append '@ head) (map translate rest))) + ((define) + (match rest + ((((? symbol? name) . args) . body) + `(@define ,name (@lambda ,args ,@(map translate body)))) + (((? symbol? name) val) + `(@define ,name ,(translate val))) + (else (error "Syntax error:" x)))) + ((lambda) + `(@lambda ,(car rest) ,@(map translate (cdr rest)))) ((let let* letrec) (match x (('let (? symbol? f) ((s v) ...) body ...) @@ -69,8 +75,41 @@ (map (lambda (b) (cons (car b) (map translate (cdr b)))) (car rest)) (map translate (cdr rest)))))) - ((lambda) - (cons* '@lambda (car rest) (map translate (cdr rest)))) + ((cond) + (let loop ((x rest)) + (match x + (() '(@void)) + ((('else . body)) `(@begin ,@(map translate body))) + (((test) . rest) `(@or ,(translate test) ,(loop rest))) + (((test '=> proc) . rest) + `(@let ((_t ,(translate test))) + (@if _t (,(translate proc) _t) ,(loop rest)))) + (((test . body) . rest) + `(@if ,(translate test) + (@begin ,@(map translate body)) + ,(loop rest))) + (else (error "bad cond" x))))) + ((case) + `(@let ((_t ,(translate (car rest)))) + ,(let loop ((x (cdr rest))) + (match x + (() '(@void)) + ((('else . body)) `(@begin ,@(map translate body))) + ((((keys ...) . body) . rest) + `(@if (@memv _t (@quote ,keys)) + (@begin ,@(map translate body)) + ,(loop rest))) + (else (error "bad cond" x)))))) + ((do) + (match rest + ((((sym init update) ...) (test . result) body ...) + `(@letrec ((_loop (@lambda + ,sym + (@if ,(translate test) + (@begin ,@(map translate result)) + (@begin ,@(map translate body) + (_loop ,@(map translate update))))))) + (_loop ,@(map translate init)))))) (else (let ((prim (and (symbol? head) (symbol-append '@ head)))) (if (and prim (ghil-primitive? prim)) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index a107f8216..341b90659 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -64,6 +64,7 @@ (($ 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- env vars args body))) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index 470960a8b..bcd396069 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -228,6 +228,19 @@ ((@begin) (parse-body args e)) + ;; (@let ((SYM INIT)...) BODY...) + ((@let) + (match args + ((((sym init) ...) body ...) + (let* ((vals (map-parse init e)) + (vars (map (lambda (s) + (let ((v (make-ghil-var e s 'local))) + (ghil-env-add! e v) v)) + sym)) + (body (parse-body body e))) + (for-each (lambda (v) (ghil-env-remove! e v)) vars) + (make- e vars vals body))))) + ;; (@letrec ((SYM INIT)...) BODY...) ((@letrec) (match args diff --git a/module/system/il/macros.scm b/module/system/il/macros.scm index b5ee342bb..5c742f0d1 100644 --- a/module/system/il/macros.scm +++ b/module/system/il/macros.scm @@ -216,14 +216,14 @@ ;;; length ;;; append ;;; reverse -;;; -;;; memq -;;; memv -;;; member -;;; -;;; assq -;;; assv -;;; assoc + +(define (@memq x l) `((@ Core::memq) ,x ,l)) +(define (@memv x l) `((@ Core::memv) ,x ,l)) +(define (@member x l) `((@ Core::member) ,x ,l)) + +(define (@assq x l) `((@ Core::assq) ,x ,l)) +(define (@assv x l) `((@ Core::assv) ,x ,l)) +(define (@assber x l) `((@ Core::assber) ,x ,l)) ;;;; 6.3.3 Symbols diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index b7e9e19b2..582b4ac3a 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -232,10 +232,12 @@ (push-code! `(load-program ,bytes))))) ((vlink? x) ;; (push-code! `(local-ref ,(object-index (vlink-module x)))) + ;; FIXME: Temporary hack + (push-code! (object->code #f)) (dump! (vlink-name x)) - (push-code! `(link/current-module))) - ;;((vmod? x) - ;; (push-code! `(load-module ,(vmod-id x)))) + (push-code! `(link))) + ((vmod? x) + (push-code! `(load-module ,(vmod-id x)))) ((and (integer? x) (exact? x)) (let ((str (do ((n x (quotient n 256)) (l '() (cons (modulo n 256) l))) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 7d34df722..588671222 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -31,7 +31,7 @@ (lambda () (set-vm-option! vm 'trace-first #t) (if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next)) - (set-vm-option! vm 'trace-variables (if (memq :v opts) #t #f)) + (set-vm-option! vm 'trace-options opts) (add-hook! (vm-apply-hook vm) trace-apply) (add-hook! (vm-return-hook vm) trace-return)) (lambda () @@ -44,9 +44,12 @@ (define (trace-next vm) (let ((frame (vm-current-frame vm))) (format #t "0x~8X ~20S" (vm:ip vm) (vm-fetch-code vm)) - (if (vm-option vm 'trace-variables) - (format #t "~S\t" (frame-variables frame))) - (format #t "~S\n" (vm-fetch-stack vm)))) + (do ((opts (vm-option vm 'trace-options) (cdr opts))) + ((null? opts) (newline)) + (case (car opts) + ((:s) (format #t "~20S" (vm-fetch-stack vm))) + ((:v) (format #t "~20S" (frame-variables frame))) + ((:e) (format #t "~20S" (program-external (frame-program frame)))))))) (define (trace-apply vm) (if (vm-option vm 'trace-first) diff --git a/src/vm.c b/src/vm.c index 5896ed5c3..c336744c3 100644 --- a/src/vm.c +++ b/src/vm.c @@ -245,7 +245,7 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp) * VM */ -#define VM_DEFAULT_STACK_SIZE (4 * 1024) +#define VM_DEFAULT_STACK_SIZE (16 * 1024) #define VM_REGULAR_ENGINE 0 #define VM_DEBUG_ENGINE 1 diff --git a/src/vm_loader.c b/src/vm_loader.c index 6548d5a10..d9f7a1169 100644 --- a/src/vm_loader.c +++ b/src/vm_loader.c @@ -161,21 +161,22 @@ VM_DEFINE_LOADER (load_program, "load-program") VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1) { +#if 0 sp--; *sp = scm_c_env_vcell (sp[0], sp[1], 1); - NEXT; -} - -VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0, 1, 1) -{ - SCM mod = scm_current_module (); - SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), - *sp, SCM_BOOL_F); - if (SCM_FALSEP (var)) - /* Create a new variable if not defined yet */ - var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), - *sp, SCM_BOOL_T); - *sp = SCM_VARVCELL (var); +#else + { + /* Temporary hack to support the current module system */ + SCM mod = scm_current_module (); + SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), + *sp, SCM_BOOL_F); + if (SCM_FALSEP (var)) + /* Create a new variable if not defined yet */ + var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), + *sp, SCM_BOOL_T); + *--sp = SCM_VARVCELL (var); + } +#endif NEXT; }