diff options
author | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-16 03:43:48 +0000 |
---|---|---|
committer | Keisuke Nishida <kxn30@po.cwru.edu> | 2001-04-16 03:43:48 +0000 |
commit | 8f5cfc810fb19fdfbeaa55d59d47dc5ab50c416b (patch) | |
tree | b5435b4d55e8645240fdb0f555599ae3c4038491 /module | |
parent | 78591ef5c3c4dd44cac912704696cf77c2cbbf73 (diff) | |
download | guile-8f5cfc810fb19fdfbeaa55d59d47dc5ab50c416b.tar.gz |
*** empty log message ***
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 6 | ||||
-rw-r--r-- | module/language/scheme/spec.scm | 10 | ||||
-rw-r--r-- | module/language/scheme/translate.scm | 13 | ||||
-rw-r--r-- | module/slib/guile.init | 4 | ||||
-rw-r--r-- | module/system/base/.cvsignore | 1 | ||||
-rw-r--r-- | module/system/base/compile.scm | 130 | ||||
-rw-r--r-- | module/system/base/language.scm | 51 | ||||
-rw-r--r-- | module/system/il/.cvsignore | 1 | ||||
-rw-r--r-- | module/system/repl/.cvsignore | 1 | ||||
-rw-r--r-- | module/system/repl/command.scm | 205 | ||||
-rw-r--r-- | module/system/repl/common.scm | 86 | ||||
-rw-r--r-- | module/system/repl/describe.scm | 19 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 6 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 2 | ||||
-rw-r--r-- | module/system/vm/conv.scm | 2 | ||||
-rw-r--r-- | module/system/vm/core.scm | 68 | ||||
-rw-r--r-- | module/system/vm/disasm.scm | 18 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 36 | ||||
-rw-r--r-- | module/system/vm/load.scm | 60 | ||||
-rw-r--r-- | module/system/vm/profile.scm | 4 | ||||
-rw-r--r-- | module/system/vm/trace.scm | 6 |
21 files changed, 309 insertions, 420 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 0e2b9dfcd..4c26fc3e2 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,5 +1,5 @@ -DISTDIRS = $(srcdir)/language $(srcdir)/system $(srcdir)/slib -EXCLUDES = --exclude=CVS --exclude='*~' +DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib +EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~ all: slibcat @@ -7,7 +7,7 @@ clean: rm -f slibcat slib/*.go slibcat: - guile -s slib-comp.scm + guile -s $(top_srcdir)/src/guilec slib/*.scm dist-hook: $(TAR) cf - $(EXCLUDES) $(DISTDIRS) | (cd $(distdir); $(TAR) xf -) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index d0281512b..765a70009 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -30,15 +30,11 @@ (read-enable 'positions) -;;; -;;; Compiler -;;; - -(define (compile port env . opts) +(define (read-file port) (do ((x (read port) (read port)) (l '() (cons x l))) ((eof-object? x) - (apply compile-in (cons 'begin (reverse! l)) env scheme opts)))) + (cons 'begin (reverse! l))))) ;;; ;;; Language definition @@ -48,7 +44,7 @@ :title "Guile Scheme" :version "0.5" :reader read + :read-file read-file :translator translate :printer write - :compiler compile ) diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 5b3585b08..f13040314 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -36,6 +36,9 @@ ;;; Translator ;;; +(define scheme-primitives + '(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!)) + (define (trans e l x) (cond ((pair? x) (let ((y (macroexpand x))) @@ -216,15 +219,17 @@ (() (make:void)) ((('else . body)) (trans:pair `(begin ,@body))) (((((? symbol? key) ...) body ...) rest ...) - (if (memq 'compile key) - (primitive-eval `(begin ,@(copy-tree body)))) (if (memq 'load-toplevel key) - (trans:pair `(begin ,@body)) + (begin + (primitive-eval `(begin ,@(copy-tree body))) + (trans:pair `(begin ,@body))) (loop rest))) (else (bad-syntax))))) (else - (make-<ghil-call> e l (trans:x head) (map trans:x tail))))) + (if (memq head scheme-primitives) + (make-<ghil-inline> e l head (map trans:x tail)) + (make-<ghil-call> e l (trans:x head) (map trans:x tail)))))) (define (trans-quasiquote e l x) (cond ((not (pair? x)) x) diff --git a/module/slib/guile.init b/module/slib/guile.init index 2d53c5d59..167988352 100644 --- a/module/slib/guile.init +++ b/module/slib/guile.init @@ -223,10 +223,10 @@ ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. -(define slib:load-compiled load-compiled) +(define (slib:load-compiled f) (load-compiled-file (string-append f ".go"))) ;;; At this point SLIB:LOAD must be able to load SLIB files. -(define slib:load slib:load-compiled) +(define slib:load slib:load) (slib:load (in-vicinity (library-vicinity) "require")) diff --git a/module/system/base/.cvsignore b/module/system/base/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/system/base/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 686931948..32c36c892 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -20,29 +20,125 @@ ;;; Code: (define-module (system base compile) + :use-module (oop goops) + :use-syntax (system base syntax) :use-module (system base language) - :use-module (ice-9 regex) - :export (compile-file object-file-name)) + :use-module (system il compile) + :use-module (system vm core) + :use-module (system vm assemble) + :use-module (ice-9 regex)) + +;;; +;;; Compiler environment +;;; + +(define-vm-class <cenv> () + vm language module optimize) + +(define-public (make-cenv . rest) + (apply make <cenv> rest)) + +(define-public (syntax-error loc msg exp) + (throw 'syntax-error loc msg exp)) + +(define-public (call-with-compile-error-catch thunk) + (catch 'syntax-error + thunk + (lambda (key loc msg exp) + (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp)))) + + +;;; +;;; Compiler +;;; (define scheme (lookup-language 'scheme)) -(define (compile-file file) - (let ((comp (object-file-name file))) - (call-with-compile-error-catch - (lambda () - (catch #t +(define-public (compile-file file . opts) + (let ((comp (compiled-file-name file))) + (catch #t + (lambda () + (call-with-compile-error-catch (lambda () (call-with-output-file comp (lambda (port) - (uniform-array-write (compile-file-in file scheme) port)))) - (lambda (key . args) - (format #t "ERROR: In ~A:\n" file) - (display "ERROR: ") - (format #t (cadr args) (caddr args)) - (newline) - (delete-file comp))))) - (format #t "Wrote ~A\n" comp))) - -(define (object-file-name file) + (let* ((source (read-file-in file scheme)) + (objcode (apply compile-in source (current-module) + scheme opts))) + (uniform-array-write (objcode->string objcode) port)))) + (format #t "Wrote ~A\n" comp)))) + (lambda (key . args) + (format #t "ERROR: In ~A:\n" file) + (display "ERROR: ") + (format #t (cadr args) (caddr args)) + (newline) + (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)))) + +(define-public (load-file file . opts) + (let ((comp (compiled-file-name file))) + (if (file-exists? comp) + (vm-load (the-vm) (load-objcode comp)) + (apply load-source-file file opts)))) + +(define-public (compiled-file-name file) (let ((m (string-match "\\.[^.]*$" file))) (string-append (if m (match:prefix m) file) ".go"))) + + +;;; +;;; Scheme compiler interface +;;; + +(define-public (read-file-in file lang) + (call-with-input-file file lang.read-file)) + +(define-public (compile-in x e lang . opts) + (catch 'result + (lambda () + ;; expand + (set! x (lang.expander x e)) + (if (memq :e opts) (throw 'result x)) + ;; translate + (set! x (lang.translator x e)) + (if (memq :t opts) (throw 'result x)) + ;; compile + (set! x (apply compile x e opts)) + (if (memq :c opts) (throw 'result x)) + ;; assemble + (apply assemble x e opts)) + (lambda (key val) val))) + +;;; +;;; +;;; + +(define (compile-and-load file . opts) + (let ((comp (object-file-name file))) + (if (or (not (file-exists? comp)) + (> (stat:mtime (stat file)) (stat:mtime (stat comp)))) + (compile-file file)) + (load-compiled-file comp))) + +(define (load/compile file . opts) + (let* ((file (file-full-name file)) + (compiled (object-file-name file))) + (if (or (not (file-exists? compiled)) + (> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) + (apply compile-file file #f opts)) + (if (memq #:b opts) + (apply vm-trace (the-vm) (load-objcode compiled) opts) + ((the-vm) (load-objcode compiled))))) + +(define (file-full-name filename) + (let* ((port (current-load-port)) + (oldname (and port (port-filename port)))) + (if (and oldname + (> (string-length filename) 0) + (not (char=? (string-ref filename 0) #\/)) + (not (string=? (dirname oldname) "."))) + (string-append (dirname oldname) "/" filename) + filename))) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 83014584e..5ac1eb3ee 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -22,12 +22,7 @@ (define-module (system base language) :use-module (oop goops) :use-syntax (system base syntax) - :use-module (system il compile) - :use-module (system vm core) - :use-module (system vm assemble) - :use-module (ice-9 regex) - :export (define-language lookup-language read-in compile-in print-in - compile-file-in)) + :export (define-language lookup-language)) ;;; @@ -36,12 +31,10 @@ (define-vm-class <language> () name title version environment - (reader) + reader printer read-file (expander (lambda (x e) x)) (translator (lambda (x e) x)) (evaluator #f) - (printer) - (compiler) ) (define-method (write (lang <language>) port) @@ -57,43 +50,3 @@ (if (module-bound? m name) (module-ref m name) (error "No such language:" name)))) - - -;;; -;;; Evaluation interface -;;; - -(define (read-in lang . port) - (lang.reader (if (null? port) (current-input-port) (car port)))) - -(define (compile-in x e lang . opts) - (catch 'result - (lambda () - ;; expand - (set! x (lang.expander x e)) - (if (memq :e opts) (throw 'result x)) - ;; translate - (set! x (lang.translator x e)) - (if (memq :t opts) (throw 'result x)) - ;; compile - (set! x (apply compile x e opts)) - (if (memq :c opts) (throw 'result x)) - ;; assemble - (apply assemble x e opts)) - (lambda (key val) val))) - -(define (print-in val lang . port) - (lang.printer val (if (null? port) (current-output-port) (car port)))) - -(define (compile-file-in file lang . opts) - (call-with-input-file file - (lambda (port) (apply lang.compiler port (current-module) opts)))) - -(define-public (syntax-error loc msg exp) - (throw 'syntax-error loc msg exp)) - -(define-public (call-with-compile-error-catch thunk) - (catch 'syntax-error - thunk - (lambda (key loc msg exp) - (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp)))) diff --git a/module/system/il/.cvsignore b/module/system/il/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/system/il/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/system/repl/.cvsignore b/module/system/repl/.cvsignore new file mode 100644 index 000000000..e796b66a8 --- /dev/null +++ b/module/system/repl/.cvsignore @@ -0,0 +1 @@ +*.go diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index c665499d1..1d374722a 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -21,37 +21,31 @@ (define-module (system repl command) :use-syntax (system base syntax) - :use-module (system base language) + :use-module (system base compile) :use-module (system repl common) - :use-module (system il glil) :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 disasm) (disassemble-program disassemble-dumpcode) :autoload (system vm profile) (vm-profile) :use-module (ice-9 format) :use-module (ice-9 session) - :export (meta-command)) - -(define (puts x) (display x) (newline)) - -(define (user-error msg . args) - (throw 'user-error #f msg args #f)) + :use-module (ice-9 documentation)) ;;; -;;; Meta command +;;; Meta command interface ;;; (define *command-table* '((help (help h) (apropos a) (describe d) (option o) (quit q)) - (module (module m) (use u) (import i) (load l) (binding b) (lsmod lm)) - (package (package p) (lspkg lp) (autopackage) (globals g)) + (module (module m) (use u) (import i) (load l) (binding b)) (language (language L)) (compile (compile c) (compile-file cc) (disassemble x) (disassemble-file xx)) (profile (time t) (profile pr)) - (debug (backtrace bt) (debugger db) (trace tr) (step st)) - (system (statistics stat) (gc)))) + (debug (backtrace bt) (debugger db) (trace r) (step st)) + (system (gc) (statistics st)))) (define (group-name g) (car g)) (define (group-commands g) (cdr g)) @@ -102,7 +96,7 @@ (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) ""))) (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary))) -(define (meta-command repl line) +(define-public (meta-command repl line) (let ((input (call-with-input-string (string-append "(" line ")") read))) (if (not (null? input)) (do ((key (car input)) @@ -125,10 +119,10 @@ (define (help repl . args) "help [GROUP] -Show help messages. -The optional argument can be either one of command groups or -command names. Without argument, a list of help commands and -all command groups are displayed, as you have already seen :)" +List available meta commands. +A command group name can be given as an optional argument. +Without any argument, a list of help commands and command groups +are displayed, as you have already seen ;)" (match args (() (display-group (lookup-group 'help)) @@ -141,27 +135,29 @@ all command groups are displayed, as you have already seen :)" (display-summary usage #f header))) (cdr *command-table*)) (newline) - (display "Enter `,COMMAND -h' to display documentation of each command.") + (display "Type `,COMMAND -h' to show documentation of each command.") (newline)) (('all) (for-each display-group *command-table*)) ((? lookup-group group) (display-group (lookup-group group))) - (else (user-error "Unknown command group: ~A" (car args))))) + (else + (user-error "Unknown command group: ~A" (car args))))) -(define guile-apropos apropos) +(define guile:apropos apropos) (define (apropos repl regexp) - "apropos [options] REGEXP + "apropos REGEXP Find bindings/modules/packages." - (guile-apropos (object->string regexp display))) + (guile:apropos (->string regexp))) (define (describe repl obj) "describe OBJ Show description/documentation." - (display "Not implemented yet\n")) + (display (object-documentation (repl-eval repl obj))) + (newline)) (define (option repl . args) - "option [KEY [VALUE]] + "option [KEY VALUE] List/show/set options." (display "Not implemented yet\n")) @@ -179,7 +175,7 @@ Quit this session." "module [MODULE] Change modules / Show current module." (match args - (() (puts (binding repl.module))))) + (() (puts (binding repl.env.module))))) (define (use repl . args) "use [MODULE ...] @@ -187,11 +183,12 @@ Use modules." (define (use name) (let ((mod (resolve-interface name))) (if mod - (module-use! repl.module mod) + (module-use! repl.env.module mod) (user-error "No such module: ~A" name)))) (if (null? args) (for-each puts (map module-name - (cons repl.module (module-uses repl.module)))) + (cons repl.env.module + (module-uses repl.env.module)))) (for-each (lambda (name) (cond ((pair? name) (use name)) @@ -206,11 +203,11 @@ Import modules / List those imported." (define (use name) (let ((mod (resolve-interface name))) (if mod - (module-use! repl.module mod) + (module-use! repl.env.module mod) (user-error "No such module: ~A" name)))) (if (null? args) (for-each puts (map module-name - (cons repl.module (module-uses repl.module)))) + (cons repl.env.module (module-uses repl.env.module)))) (for-each (lambda (name) (cond ((pair? name) (use name)) @@ -221,55 +218,23 @@ Import modules / List those imported." args))) (define (load repl file . opts) - "load [options] FILE -Load a file in the current module." - (apply repl-load-file repl (->string file) opts)) + "load FILE +Load a file in the current module. + + -f Load source file (see `compile') + -r Trace loading (see `trace')" + (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)))) (define (binding repl . opts) - "binding [-a] + "binding List current bindings." - (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.module)) - -(define (lsmod repl . args) - "lsmod -." - (define (use name) - (set! repl.module (resolve-module name)) - (module-use! repl.module repl.value-history)) - (if (null? args) - (use '(guile-user)) - (let ((name (car args))) - (cond - ((pair? name) (use name)) - ((symbol? name) - (and-let* ((m (find-one-module (symbol->string name)))) - (puts m) (use m))) - (else (user-error "Invalid module name: ~A" name)))))) - - -;;; -;;; Package commands -;;; - -(define (package repl) - "package [PACKAGE] -List available packages/modules." - (for-each puts (find-module ""))) - -(define (lspkg repl) - "lspkg -List available packages/modules." - (for-each puts (find-module ""))) - -(define (autopackage repl) - "autopackage -List available packages/modules." - (for-each puts (find-module ""))) - -(define (globals repl) - "globals -List all global variables." - (global-fold (lambda (s v d) (format #t "~A\t~S\n" s v)) #f)) + (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.env.module)) ;;; @@ -279,7 +244,7 @@ List all global variables." (define (language repl name) "language LANGUAGE Change languages." - (set! repl.language (lookup-language name)) + (set! repl.env.language (lookup-language name)) (repl-welcome repl)) @@ -288,7 +253,7 @@ Change languages." ;;; (define (compile repl form . opts) - "compile [options] FORM + "compile FORM Generate compiled code. -e Stop after expanding syntax/macro @@ -300,10 +265,10 @@ Generate compiled code. (let ((x (apply repl-compile repl form opts))) (cond ((or (memq :e opts) (memq :t opts)) (puts x)) ((memq :c opts) (pprint-glil x)) - (else (disassemble-dumpcode x))))) + (else (disassemble-objcode x))))) (define (compile-file repl file . opts) - "compile-file [options] FILE + "compile-file FILE Compile a file." (apply repl-compile-file repl (->string file) opts)) @@ -315,31 +280,51 @@ Disassemble a program." (define (disassemble-file repl file) "disassemble-file FILE Disassemble a file." - (disassemble-dumpcode (load-dumpcode (->string file)))) - -(define (->string x) - (object->string x display)) + (disassemble-objcode (load-objcode (->string file)))) ;;; ;;; Profile commands ;;; +(define (time repl form) + "time FORM +Time execution." + (let* ((vms-start (vm-stats repl.env.vm)) + (gc-start (gc-run-time)) + (tms-start (times)) + (result (repl-eval repl form)) + (tms-end (times)) + (gc-end (gc-run-time)) + (vms-end (vm-stats repl.env.vm))) + (define (get proc start end) + (/ (- (proc end) (proc start)) internal-time-units-per-second)) + (repl-print repl result) + (display "clock utime stime cutime cstime gctime\n") + (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" + (get tms:clock tms-start tms-end) + (get tms:utime tms-start tms-end) + (get tms:stime tms-start tms-end) + (get tms:cutime tms-start tms-end) + (get tms:cstime tms-start tms-end) + (get identity gc-start gc-end)) + result)) + (define (profile repl form . opts) "profile FORM Profile execution." - (apply vm-profile repl.vm (repl-compile repl form) opts)) + (apply vm-profile repl.env.vm (repl-compile repl form) opts)) ;;; ;;; Debug commands ;;; -(define guile-backtrace backtrace) +(define guile:backtrace backtrace) (define (backtrace repl) "backtrace Show backtrace (if any)." - (guile-backtrace)) + (guile:backtrace)) (define (debugger repl) "debugger @@ -347,9 +332,14 @@ Start debugger." (debug)) (define (trace repl form . opts) - "trace [-b] FORM -Trace execution." - (apply vm-trace repl.vm (repl-compile repl form) opts)) + "trace FORM +Trace execution. + + -s Display stack + -l Display local variables + -e Display external variables + -b Bytecode level trace" + (apply vm-trace repl.env.vm (repl-compile repl form) opts)) (define (step repl) "step FORM @@ -361,44 +351,17 @@ Step execution." ;;; System commands ;;; -(define (time repl form) - "time FORM -Time execution." - (let* ((vms-start (vm-stats repl.vm)) - (gc-start (gc-run-time)) - (tms-start (times)) - (result (repl-eval repl form)) - (tms-end (times)) - (gc-end (gc-run-time)) - (vms-end (vm-stats repl.vm))) - (define (get proc start end) - (/ (- (proc end) (proc start)) internal-time-units-per-second)) - (repl-print repl result) - (display "clock utime stime cutime cstime gctime\n") - (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" - (get tms:clock tms-start tms-end) - (get tms:utime tms-start tms-end) - (get tms:stime tms-start tms-end) - (get tms:cutime tms-start tms-end) - (get tms:cstime tms-start tms-end) - (get id gc-start gc-end)) - result)) - -(define guile-gc gc) +(define guile:gc gc) (define (gc repl) "gc Garbage collection." - (guile-gc)) - -;;; -;;; Statistics -;;; + (guile:gc)) (define (statistics repl) "statistics Display statistics." (let ((this-tms (times)) - (this-vms (vm-stats repl.vm)) + (this-vms (vm-stats repl.env.vm)) (this-gcs (gc-stats)) (last-tms repl.tm-stats) (last-vms repl.vm-stats) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 651bd5205..4bd8986a9 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -22,70 +22,66 @@ (define-module (system repl common) :use-module (oop goops) :use-syntax (system base syntax) + :use-module (system base compile) :use-module (system base language) :use-module (system vm core) - :use-module (system vm trace) - :export (make-repl repl-welcome repl-prompt repl-read repl-compile - repl-eval repl-print repl-compile-file repl-load-file)) + :use-module (system vm trace)) ;;; -;;; Repl +;;; Repl type ;;; -(define-vm-class <repl> () - vm language module value-count value-history tm-stats vm-stats gc-stats) +(define-vm-class <repl> () env tm-stats vm-stats gc-stats) -(define (make-repl lang) - (let ((vm (the-vm))) +(define-public (make-repl lang) + (let ((cenv (make-cenv :vm (the-vm) + :language (lookup-language lang) + :module (current-module)))) (make <repl> - :vm vm - :language (lookup-language lang) - :module (current-module) ;; (global-ref 'user) - :value-count 0 -; :value-history (make-vmodule) + :env cenv :tm-stats (times) - :vm-stats (vm-stats vm) + :vm-stats (vm-stats cenv.vm) :gc-stats (gc-stats)))) -(define (repl-welcome repl) +(define-public (repl-welcome repl) (format #t "~A interpreter ~A on Guile ~A\n" - repl.language.title repl.language.version (version)) + repl.env.language.title repl.env.language.version (version)) (display "Copyright (C) 2001 Free Software Foundation, Inc.\n\n") (display "Enter `,help' for help.\n")) -(define (repl-prompt repl) - (format #t "~A@~A> " repl.language.name 'guile) - ;; (env-identifier repl.module)) - (force-output)) +(define-public (repl-prompt repl) + (let ((module-name (car (last-pair (module-name repl.env.module))))) + (format #t "~A@~A> " repl.env.language.name module-name) + (force-output))) -(define (repl-read repl . args) - (apply read-in repl.language args)) +(define-public (repl-read repl) + (repl.env.language.reader)) -(define (repl-compile repl form . opts) - (apply compile-in form repl.module repl.language opts)) +(define-public (repl-compile repl form . opts) + (apply compile-in form repl.env.module repl.env.language opts)) -(define (repl-eval repl form) - (let ((eval repl.language.evaluator)) +(define-public (repl-eval repl form) + (let ((eval repl.env.language.evaluator)) (if eval - (eval form repl.module) - (vm-load repl.vm (repl-compile repl form))))) + (eval form repl.env.module) + (vm-load repl.env.vm (repl-compile repl form))))) -(define (repl-print repl val) +(define-public (repl-print repl val) (if (not (eq? val *unspecified*)) - (let* ((num (1+ repl.value-count)) - (sym (string->symbol (format #f "$~A" num)))) -; (vmodule-define repl.value-history sym val) - (format #t "~A = " sym) - (print-in val repl.language) - (newline) - (set! repl.value-count num)))) - -(define (repl-compile-file repl file . opts) - (apply compile-file-in file repl.language opts)) - -(define (repl-load-file repl file . opts) - (let ((bytes (apply repl-compile-file repl file opts))) - (if (or (memq :b opts) (memq :r opts)) - (apply vm-trace repl.vm bytes opts) - (vm-load repl.vm bytes)))) + (begin + (repl.env.language.printer val) + (newline)))) + + +;;; +;;; Utilities +;;; + +(define-public (puts x) (display x) (newline)) + +(define-public (->string x) + (object->string x display)) + +(define-public (user-error msg . args) + (throw 'user-error #f msg args #f)) diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm index 966ea7d46..15f0b0b04 100644 --- a/module/system/repl/describe.scm +++ b/module/system/repl/describe.scm @@ -22,16 +22,15 @@ (define-module (system repl describe) :use-module (oop goops) :use-module (ice-9 regex) - :use-module (ice-9 format)) + :use-module (ice-9 format) + :use-module (ice-9 and-let-star) + :export (describe)) -(define *describe-format* #t) - -(define-public (describe symbol) - (assert symbol? symbol) +(define-method (describe (symbol <symbol>)) (format #t "`~s' is " symbol) (if (not (defined? symbol)) (display "not defined in the current module.\n") - (describe-object (eval symbol)))) + (describe-object (module-ref (current-module) symbol)))) ;;; @@ -302,13 +301,13 @@ ;;; Instances ;;; -(define-method display-type ((obj <object>)) +(define-method (display-type (obj <object>)) (display-class <object> "an instance") (display " of class ") (display-class (class-of obj)) (display ".\n")) -(define-method display-value ((obj <object>)) +(define-method (display-value (obj <object>)) (display-slot-list #f obj (class-slots (class-of obj)))) @@ -316,13 +315,13 @@ ;;; Generic functions ;;; -(define-method display-type ((obj <generic>)) +(define-method (display-type (obj <generic>)) (display-class <generic> "a generic function") (display " of class ") (display-class (class-of obj)) (display ".\n")) -(define-method display-value ((obj <generic>)) +(define-method (display-value (obj <generic>)) (display-list #f (generic-function-methods obj))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 5c01c8b3a..73473af8c 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -23,14 +23,11 @@ :use-syntax (system base syntax) :use-module (system repl common) :use-module (system repl command) - :use-module (system vm frame) :use-module (ice-9 rdelim) :export (start-repl)) (define (start-repl lang) (let ((repl (make-repl lang))) -;; (set-current-vmodule! repl.module) -;; (set-current-evaluator! repl.vm) (repl-welcome repl) (let prompt-loop () (repl-prompt repl) @@ -38,8 +35,7 @@ (lambda () (if (eq? (next-char #t) #\,) ;; meta command - (begin (read-char) - (meta-command repl (read-line))) + (begin (read-char) (meta-command repl (read-line))) ;; evaluation (let rep-loop () (repl-print repl (repl-eval repl (repl-read repl))) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 7cd8c1dd4..1e9e2d6f8 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -146,7 +146,7 @@ (for-each generate-code body) (let ((bytes (stack->bytes (reverse! stack) label-alist))) (if toplevel - (make-dumpcode nlocs nexts bytes) + (bytecode->objcode bytes nlocs nexts) (let ((objs (map car (reverse! object-alist)))) (make-bytespec nargs nrest nlocs nexts bytes objs (venv-closure? venv))))))))) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index a21d1c843..5e246eb96 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -83,7 +83,7 @@ (('load-string s) s) (('load-symbol s) (string->symbol s)) (('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s))) - (('link s) (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 87810c914..a5679d08b 100644 --- a/module/system/vm/core.scm +++ b/module/system/vm/core.scm @@ -21,6 +21,7 @@ (define-module (system vm core)) + ;;; ;;; Core procedures ;;; @@ -32,60 +33,37 @@ (hash-fold (lambda (k v d) (cons k d)) '() (module-obarray (current-module))))) + ;;; -;;; Dumpcode interface +;;; Loader ;;; -(export make-dumpcode dumpcode? dumpcode-version - dumpcode-nlocs dumpcode-nexts dumpcode-bytecode - load-dumpcode save-dumpcode) +(define-public (vm-load vm objcode) + (vm (objcode->program objcode))) -(define *dumpcode-cookie* (string-append "\0GBC-" (vm-version))) +(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file)))) -(define (make-dumpcode nlocs nexts bytes) - (string-append *dumpcode-cookie* - (integer->bytes nlocs) - (integer->bytes nexts) - bytes)) - -(define (dumpcode? x) - (and (string? x) - (> (string-length x) 10) - (string=? (substring x 1 4) "GBC"))) - -(define (dumpcode-version x) - (substring x 5 8)) - -(define (dumpcode-nlocs x) - (bytes->integer x 8)) - -(define (dumpcode-nexts x) - (bytes->integer x 9)) - -(define (dumpcode-bytecode x) - (substring x 10)) - -(define (load-dumpcode file) - (let ((bytes (make-uniform-vector (stat:size (stat file)) #\a))) - (call-with-input-file file - (lambda (p) (uniform-vector-read! bytes p))) - bytes)) - -(define (save-dumpcode dump file) - (call-with-output-file file - (lambda (out) (uniform-vector-write dump out)))) + +;;; +;;; Frame interface +;;; -(define (integer->bytes n) - (string (integer->char n))) +(define-public (frame->call frame) + (let* ((prog (frame-program frame)) + (nargs (car (program-arity prog)))) + (do ((i 0 (1+ i)) + (l (vector->list (frame-variables frame)) (cdr l)) + (r '() (cons (car l) r))) + ((= i nargs) (cons (program-name prog) (reverse! r)))))) -(define (bytes->integer bytes start) - (char->integer (string-ref bytes start))) +(define (program-name x) + (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x + (module-obarray (current-module)))) + ;;; ;;; Statistics interface ;;; -(export vms:time vms:clock) - -(define (vms:time stat) (vector-ref stat 0)) -(define (vms:clock stat) (vector-ref stat 1)) +(define-public (vms:time stat) (vector-ref stat 0)) +(define-public (vms:clock stat) (vector-ref stat 1)) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 0ab0a83d7..2e3c1ac87 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -27,15 +27,17 @@ :use-module (ice-9 format) :use-module (ice-9 receive) :use-module (ice-9 and-let-star) - :export (disassemble-dumpcode disassemble-program)) + :export (disassemble-objcode disassemble-program)) -(define (disassemble-dumpcode dumpcode . opts) - (if (not (dumpcode? dumpcode)) (error "Invalid dumpcode")) - (format #t "Disassembly of dumpcode:\n\n") - (format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode)) - (format #t "nlocs = ~A nexts = ~A\n\n" - (dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode)) - (disassemble-bytecode (dumpcode-bytecode dumpcode) #f)) +(define (disassemble-objcode objcode . opts) + (let* ((prog (objcode->program objcode)) + (arity (program-arity prog)) + (nlocs (caddr arity)) + (nexts (cadddr arity)) + (bytes (program-bytecode prog))) + (format #t "Disassembly of ~A:\n\n" objcode) + (format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts) + (disassemble-bytecode bytes #f))) (define (disassemble-program prog . opts) (let* ((arity (program-arity prog)) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm deleted file mode 100644 index be696bc37..000000000 --- a/module/system/vm/frame.scm +++ /dev/null @@ -1,36 +0,0 @@ -;;; Guile VM frame utilities - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (system vm frame) - :use-module (system vm core) - :export (frame->call)) - -(define (frame->call frame) - (let* ((prog (frame-program frame)) - (nargs (car (program-arity prog)))) - (do ((i 0 (1+ i)) - (l (vector->list (frame-variables frame)) (cdr l)) - (r '() (cons (car l) r))) - ((= 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)))) diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm deleted file mode 100644 index d440854fb..000000000 --- a/module/system/vm/load.scm +++ /dev/null @@ -1,60 +0,0 @@ -;;; Guile VM compiling loader - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (system vm load) - :autoload (system base compile) (compile-file) - :use-module (system vm core) - :use-module (ice-9 regex) - :export (load-compiled-file compile-and-load load/compile)) - -(define (load-compiled-file file . opts) - (vm-load (the-vm) (load-dumpcode file))) - -(define (compile-and-load file . opts) - (let ((comp (object-file-name file))) - (if (or (not (file-exists? comp)) - (> (stat:mtime (stat file)) (stat:mtime (stat comp)))) - (compile-file file)) - (load-compiled-file comp))) - -(define (load/compile file . opts) - (let* ((file (file-full-name file)) - (compiled (object-file-name file))) - (if (or (not (file-exists? compiled)) - (> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) - (apply compile-file file #f opts)) - (if (memq #:b opts) - (apply vm-trace (the-vm) (load-dumpcode compiled) opts) - (vm-load (the-vm) (load-dumpcode compiled))))) - -(define (file-full-name filename) - (let* ((port (current-load-port)) - (oldname (and port (port-filename port)))) - (if (and oldname - (> (string-length filename) 0) - (not (char=? (string-ref filename 0) #\/)) - (not (string=? (dirname oldname) "."))) - (string-append (dirname oldname) "/" filename) - filename))) - -(define-public (object-file-name file) - (let ((m (string-match "\\.[^.]*$" file))) - (string-append (if m (match:prefix m) file) ".go"))) diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm index 114b7524c..1b29850f1 100644 --- a/module/system/vm/profile.scm +++ b/module/system/vm/profile.scm @@ -24,7 +24,7 @@ :use-module (ice-9 format) :export (vm-profile)) -(define (vm-profile vm bytes . opts) +(define (vm-profile vm objcode . opts) (let ((flag (vm-option vm 'debug))) (dynamic-wind (lambda () @@ -34,7 +34,7 @@ (add-hook! (vm-enter-hook vm) profile-enter) (add-hook! (vm-exit-hook vm) profile-exit)) (lambda () - (let ((val (vm-load vm bytes))) + (let ((val (vm (objcode->program objcode)))) (display-result vm) val)) (lambda () diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index d7b074cdc..364069156 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -22,15 +22,13 @@ (define-module (system vm trace) :use-syntax (system base syntax) :use-module (system vm core) - :use-module (system vm frame) :use-module (ice-9 format) - :use-module (ice-9 and-let-star) :export (vm-trace vm-trace-on vm-trace-off)) -(define (vm-trace vm bytes . opts) +(define (vm-trace vm objcode . opts) (dynamic-wind (lambda () (apply vm-trace-on vm opts)) - (lambda () (vm-load vm bytes)) + (lambda () (vm (objcode->program objcode))) (lambda () (apply vm-trace-off vm opts)))) (define (vm-trace-on vm . opts) |