diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index f13040314..7ba07b34b 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -45,9 +45,21 @@ (if (eq? x y) (trans-pair e (or (location x) l) (car x) (cdr x)) (trans e l y)))) - ((symbol? x) (make- e l (ghil-lookup e x))) + ((symbol? x) + (let ((y (expand-symbol x))) + (if (eq? x y) + (make- e l (ghil-lookup e x)) + (trans e l y)))) (else (make- e l x)))) +(define (expand-symbol x) + (let loop ((s (symbol->string x))) + (let ((i (string-rindex s #\.))) + (if i + `(slot ,(loop (substring s 0 i)) + (quote ,(string->symbol (substring s (1+ i))))) + (string->symbol s))))) + (define (trans-pair e l head tail) (define (trans:x x) (trans e l x)) (define (trans:pair x) (trans-pair e l (car x) (cdr x))) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 32c36c892..adc7e2d90 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -68,20 +68,21 @@ (uniform-array-write (objcode->string objcode) port)))) (format #t "Wrote ~A\n" comp)))) (lambda (key . args) - (format #t "ERROR: In ~A:\n" file) + (format #t "ERROR: During compiling ~A:\n" file) (display "ERROR: ") - (format #t (cadr args) (caddr args)) + (apply format #t (cadr args) (caddr args)) (newline) + (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args)) (delete-file comp))))) (define-public (load-source-file file . opts) (let ((source (read-file-in file scheme))) - (vm-load (the-vm) (apply compile-in source (current-module) scheme opts)))) + (apply compile-in source (current-module) scheme opts))) (define-public (load-file file . opts) (let ((comp (compiled-file-name file))) (if (file-exists? comp) - (vm-load (the-vm) (load-objcode comp)) + (load-objcode comp) (apply load-source-file file opts)))) (define-public (compiled-file-name file) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index fab3f0bd0..f14b924b7 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -24,7 +24,7 @@ :use-module (ice-9 match) :use-module (ice-9 receive) :use-module (ice-9 and-let-star) - :export (match and-let* receive)) + :export (match syntax-error and-let* receive)) ;;; diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 1d374722a..013e50912 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -26,7 +26,7 @@ :use-module (system vm core) :autoload (system il glil) (pprint-glil) :autoload (system vm disasm) (disassemble-program disassemble-objcode) - :autoload (system vm trace) (vm-trace) + :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off) :autoload (system vm profile) (vm-profile) :use-module (ice-9 format) :use-module (ice-9 session) @@ -45,7 +45,7 @@ (disassemble x) (disassemble-file xx)) (profile (time t) (profile pr)) (debug (backtrace bt) (debugger db) (trace r) (step st)) - (system (gc) (statistics st)))) + (system (gc) (statistics stat)))) (define (group-name g) (car g)) (define (group-commands g) (cdr g)) @@ -109,7 +109,7 @@ (if c (cond ((memq :h opts) (display-command c)) (else (apply (command-procedure c) - repl (append! args opts)))) + repl (append! args (reverse! opts))))) (user-error "Unknown meta command: ~A" key)))))))) @@ -159,7 +159,22 @@ Show description/documentation." (define (option repl . args) "option [KEY VALUE] List/show/set options." - (display "Not implemented yet\n")) + (match args + (() + (for-each (lambda (key+val) + (format #t "~A\t~A\n" (car key+val) (cdr key+val))) + repl.options)) + ((key) + (display (repl-option-ref repl key)) + (newline)) + ((key val) + (repl-option-set! repl key val) + (case key + ((trace) + (let ((opts (repl-option-ref repl 'trace-options))) + (if val + (apply vm-trace-on repl.env.vm opts) + (vm-trace-off repl.env.vm)))))))) (define (quit repl) "quit @@ -221,15 +236,12 @@ Import modules / List those imported." "load FILE Load a file in the current module. - -f Load source file (see `compile') - -r Trace loading (see `trace')" + -f Load source file (see `compile')" (let* ((file (->string file)) (objcode (if (memq :f opts) (apply load-source-file file opts) (apply load-file file opts)))) - (if (memq :r opts) - (apply vm-trace repl.env.vm objcode opts) - (vm-load repl.env.vm objcode)))) + (vm-load repl.env.vm objcode))) (define (binding repl . opts) "binding @@ -267,10 +279,11 @@ Generate compiled code. ((memq :c opts) (pprint-glil x)) (else (disassemble-objcode x))))) +(define guile:compile-file compile-file) (define (compile-file repl file . opts) "compile-file FILE Compile a file." - (apply repl-compile-file repl (->string file) opts)) + (apply guile:compile-file (->string file) opts)) (define (disassemble repl prog) "disassemble PROGRAM diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 4bd8986a9..23d4e76da 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -32,7 +32,11 @@ ;;; Repl type ;;; -(define-vm-class () env tm-stats vm-stats gc-stats) +(define-vm-class () env options tm-stats gc-stats vm-stats) + +(define repl-default-options + '((trace . #f) + (trace-options . (:s)))) (define-public (make-repl lang) (let ((cenv (make-cenv :vm (the-vm) @@ -40,9 +44,10 @@ :module (current-module)))) (make :env cenv + :options repl-default-options :tm-stats (times) - :vm-stats (vm-stats cenv.vm) - :gc-stats (gc-stats)))) + :gc-stats (gc-stats) + :vm-stats (vm-stats cenv.vm)))) (define-public (repl-welcome repl) (format #t "~A interpreter ~A on Guile ~A\n" @@ -73,6 +78,12 @@ (repl.env.language.printer val) (newline)))) +(define-public (repl-option-ref repl key) + (assq-ref repl.options key)) + +(define-public (repl-option-set! repl key val) + (set! repl.options (assq-set! repl.options key val))) + ;;; ;;; Utilities diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 73473af8c..a77213280 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -23,6 +23,7 @@ :use-syntax (system base syntax) :use-module (system repl common) :use-module (system repl command) + :use-module (system vm core) :use-module (ice-9 rdelim) :export (start-repl)) @@ -60,10 +61,10 @@ error-handler)) (define (error-handler key . args) -;; (case key -;; ((vm-error) -;; (write (frame->call (cadddr args))) -;; (newline))) + (case key + ((vm-error) + (write (frame->call (cadddr args))) + (newline))) (display "ERROR: ") (apply format #t (cadr args) (caddr args)) (newline)) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index 5e246eb96..c36222e88 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -83,7 +83,6 @@ (('load-string s) s) (('load-symbol s) (string->symbol s)) (('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s))) - (('link s) (cons (string->symbol s) '???)) (else #f))) (define (code->bytes code) diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm index a5679d08b..a4a0ef4fc 100644 --- a/module/system/vm/core.scm +++ b/module/system/vm/core.scm @@ -57,8 +57,9 @@ ((= i nargs) (cons (program-name prog) (reverse! r)))))) (define (program-name x) - (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x - (module-obarray (current-module)))) + (or (object-property x 'name) + (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x + (module-obarray (current-module))))) ;;; diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 2e3c1ac87..b8574286e 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -134,3 +134,11 @@ (if extra (format #t "~4@A ~32A;; ~A\n" addr info extra) (format #t "~4@A ~A\n" addr info))) + +(define (simplify x) + (cond ((string? x) + (cond ((string-index x #\newline) => + (lambda (i) (set! x (substring x 0 i))))) + (cond ((> (string-length x) 16) + (set! x (string-append (substring x 0 13) "...")))))) + x) diff --git a/src/vm.c b/src/vm.c index d09602075..ae2b7f120 100644 --- a/src/vm.c +++ b/src/vm.c @@ -328,7 +328,7 @@ vm_mark (SCM obj) if (SCM_NIMP (*sp)) scm_gc_mark (*sp); fp = SCM_VM_STACK_ADDRESS (sp[-1]); /* dynamic link */ - /* Mark frame variables + program */ + /* Mark external link, frame variables, and program */ for (sp -= 2; sp >= lower; sp--) if (SCM_NIMP (*sp)) scm_gc_mark (*sp); diff --git a/src/vm_engine.h b/src/vm_engine.h index 37320d901..f15e6d71c 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -135,16 +135,6 @@ objects = SCM_VELTS (bp->objs); \ } -#define CACHE_EXTERNAL() \ -{ \ - external = fp[bp->nargs + bp->nlocs]; \ -} - -#define SYNC_EXTERNAL() \ -{ \ - fp[bp->nargs + bp->nlocs] = external; \ -} - #define SYNC_BEFORE_GC() \ { \ SYNC_REGISTER (); \ @@ -305,16 +295,16 @@ do { \ CHECK_OVERFLOW (); \ sp[0] = ra; \ sp[-1] = dl; \ - sp[-2] = bp->external; \ + sp[-2] = external; \ } #define FREE_FRAME() \ { \ - SCM *new_sp = fp - 2; \ - sp = fp + bp->nargs + bp->nlocs; \ - ip = SCM_VM_BYTE_ADDRESS (sp[2]); \ - fp = SCM_VM_STACK_ADDRESS (sp[1]); \ - sp = new_sp; \ + SCM *p = fp + bp->nargs + bp->nlocs; \ + sp = fp - 2; \ + ip = SCM_VM_BYTE_ADDRESS (p[2]); \ + fp = SCM_VM_STACK_ADDRESS (p[1]); \ + external = p[0]; \ } /* diff --git a/src/vm_system.c b/src/vm_system.c index c0f14e444..1d7064a6e 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -351,10 +351,9 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1) LOCAL_SET (i, SCM_UNDEFINED); /* Create external variables */ - CACHE_EXTERNAL (); + external = bp->external; for (i = 0; i < bp->nexts; i++) CONS (external, SCM_UNDEFINED, external); - SYNC_EXTERNAL (); ENTER_HOOK (); APPLY_HOOK (); @@ -365,9 +364,10 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1) */ if (!SCM_FALSEP (scm_procedure_p (x))) { + SCM args; POP_LIST (nargs); - sp[-1] = scm_apply (x, *sp, SCM_EOL); - sp--; + POP (args); + *sp = scm_apply (x, args, SCM_EOL); NEXT; } /* @@ -406,18 +406,16 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1) */ if (SCM_EQ_P (x, program)) { - INIT_ARGS (); + int i; /* Move arguments */ - if (bp->nargs) - { - int i; - sp -= bp->nargs - 1; - for (i = 0; i < bp->nargs; i++) - LOCAL_SET (i, sp[i]); - sp -= 2; - } + INIT_ARGS (); + sp -= bp->nargs - 1; + for (i = 0; i < bp->nargs; i++) + LOCAL_SET (i, sp[i]); + sp--; + /* Call itself */ ip = bp->base; APPLY_HOOK (); NEXT; @@ -447,9 +445,10 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1) */ if (!SCM_FALSEP (scm_procedure_p (x))) { + SCM args; POP_LIST (nargs); - sp[-1] = scm_apply (x, *sp, SCM_EOL); - sp--; + POP (args); + *sp = scm_apply (x, args, SCM_EOL); goto vm_return; } /* @@ -504,7 +503,6 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1) /* Restore the last program */ program = SCM_VM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); - CACHE_EXTERNAL (); PUSH (ret); NEXT; }