summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
Diffstat (limited to 'module/system')
-rw-r--r--module/system/base/.cvsignore1
-rw-r--r--module/system/base/compile.scm130
-rw-r--r--module/system/base/language.scm51
-rw-r--r--module/system/il/.cvsignore1
-rw-r--r--module/system/repl/.cvsignore1
-rw-r--r--module/system/repl/command.scm205
-rw-r--r--module/system/repl/common.scm86
-rw-r--r--module/system/repl/describe.scm19
-rw-r--r--module/system/repl/repl.scm6
-rw-r--r--module/system/vm/assemble.scm2
-rw-r--r--module/system/vm/conv.scm2
-rw-r--r--module/system/vm/core.scm68
-rw-r--r--module/system/vm/disasm.scm18
-rw-r--r--module/system/vm/frame.scm36
-rw-r--r--module/system/vm/load.scm60
-rw-r--r--module/system/vm/profile.scm4
-rw-r--r--module/system/vm/trace.scm6
17 files changed, 292 insertions, 404 deletions
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)