*** empty log message ***

README

@@ -7,10 +7,12 @@ Installation
 
   % configure
   % make install
-  % ln -s module/{system,language} /usr/local/share/guile/site/
+  % ln -s module/{guile,system,language} /usr/local/share/guile/
 
 3. Add the following lines to your ~/.guile:
 
+  (use-modules (system vm core)
+
   (cond ((string=? (car (command-line)) "guile-vm")
 	 (use-modules (system repl repl))
 	 (start-repl 'scheme)
@@ -20,79 +22,63 @@ Example Session
 ---------------
 
   % guile-vm
-  Guile Scheme interpreter 0.4 on Guile 1.4.1
+  Guile Scheme interpreter 0.5 on Guile 1.4.1
   Copyright (C) 2001 Free Software Foundation, Inc.
 
   Enter `,help' for help.
-  gscheme@guile> (+ 1 2)
+  scheme@guile-user> (+ 1 2)
-  $1 = 3
+  3
-  gscheme@guile> ,c -c (+ 1 2)		;; Compile into GLIL
+  scheme@guile-user> ,c -c (+ 1 2)	;; Compile into GLIL
-  (@asm (0 0 0 0)
+  (@asm (0 1 0 0)
+    (module-ref #f +)
     (const 1)
     (const 2)
-    (add 2)
+    (tail-call 2))
-    (return 0))
+  scheme@guile-user> ,c (+ 1 2)		;; Compile into object code
-  gscheme@guile> ,c (+ 1 2)		;; Compile into bootcode
+  Disassembly of #<objcode 403c5fb0>:
-  Disassembly of bootcode:
-
-  Compiled for Guile VM 0.4
 
   nlocs = 0  nexts = 0
 
-     0    make-int8:1                     ;; 1
+     0    link "+"                        ;; (+ . ???)
-     1    make-int8 2                     ;; 2
+     3    variable-ref
-     3    add
+     4    make-int8:1                     ;; 1
-     4    return
+     5    make-int8 2                     ;; 2
+     7    tail-call 2
 
-  gscheme@guile> (define (add x y) (+ x y))
+  scheme@guile-user> (define (add x y) (+ x y))
-  gscheme@guile> (add 1 2)
+  scheme@guile-user> (add 1 2)
-  $2 = 3
+  3
-  gscheme@guile> ,x add			;; Disassemble
+  scheme@guile-user> ,x add		;; Disassemble
   Disassembly of #<program add>:
 
   nargs = 2  nrest = 0  nlocs = 0  nexts = 0
 
   Bytecode:
 
-     0    local-ref 0
+     0    object-ref 0                    ;; (+ . #<primitive-procedure +>)
-     2    local-ref 1
+     2    variable-ref
-     4    add
+     3    local-ref 0
-     5    return
+     5    local-ref 1
+     7    tail-call 2
 
-  gscheme@guile> 
+  Objects:
 
-Write Modules
+     0    (+ . #<primitive-procedure +>)
--------------
 
-  ---- fib.scm ---------------------------
+  scheme@guile-user> 
-  (define-module (fib)
-    :use-module (system vm load)
-    :export (fib))
 
-  (load/compile "fib.gs")
+Compile Modules
-  ----------------------------------------
+---------------
 
-  ---- fib.gs ----------------------------
+Use `guilec' to compile your modules:
-  (define (fib n)
-    (if (< n 2)
-	1
-	(+ (fib (- n 1)) (fib (- n 2)))))
-  ----------------------------------------
 
-Now, expressions in fib.gsm are automatically compiled and
+  % cat fib.scm
-executed by the Guile VM:
+  (define-module (fib) :export (fib))
+  (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
 
+  % guilec fib.scm
+  Wrote fib.go
   % guile
   guile> (use-modules (fib))
-  guile> (time (fib 30))
+  guile> (fib 8)
-  clock utime stime cutime cstime gctime
+  34
-   2.80  2.79  0.00   0.00   0.00   0.00
-  $1 = 1346269
-  guile> (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
-  guile> (time (fib 30))
-  clock utime stime cutime cstime gctime
-  26.05 25.01  0.17   0.00   0.00  14.33
-  $2 = 1346269
-
-If you don't want to compile your code (e.g., for debugging purpose),
-just change `load/compile' to `load'.

configure.in

@@ -12,4 +12,4 @@ AC_PROG_LN_S
 AM_PROG_LIBTOOL
 AC_C_LABELS_AS_VALUES
 
-AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile src/guilec)
+AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile)

module/Makefile.am

@@ -1,5 +1,5 @@
-DISTDIRS = $(srcdir)/language $(srcdir)/system $(srcdir)/slib
+DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib
-EXCLUDES = --exclude=CVS --exclude='*~'
+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 -)

module/language/scheme/spec.scm

@@ -30,15 +30,11 @@
 
 (read-enable 'positions)
 
-;;;
+(define (read-file port)
-;;; Compiler
-;;;
-
-(define (compile port env . opts)
   (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
   )

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)

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"))

module/system/base/.cvsignore

@@ -0,0 +1 @@
+*.go

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)
+  :use-module (system il compile)
-  :export (compile-file object-file-name))
+  :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)
+(define-public (compile-file file . opts)
-  (let ((comp (object-file-name file)))
+  (let ((comp (compiled-file-name file)))
-    (call-with-compile-error-catch
+    (catch #t
-     (lambda ()
+      (lambda ()
-       (catch #t
+	(call-with-compile-error-catch
 	 (lambda ()
 	   (call-with-output-file comp
 	     (lambda (port)
-	       (uniform-array-write (compile-file-in file scheme) port))))
+	       (let* ((source (read-file-in file scheme))
-	 (lambda (key . args)
+		      (objcode (apply compile-in source (current-module)
-	   (format #t "ERROR: In ~A:\n" file)
+				      scheme opts)))
-	   (display "ERROR: ")
+		 (uniform-array-write (objcode->string objcode) port))))
-	   (format #t (cadr args) (caddr args))
+	   (format #t "Wrote ~A\n" comp))))
-	   (newline)
+      (lambda (key . args)
-	   (delete-file comp)))))
+	(format #t "ERROR: In ~A:\n" file)
-    (format #t "Wrote ~A\n" comp)))
+	(display "ERROR: ")
+	(format #t (cadr args) (caddr args))
+	(newline)
+	(delete-file comp)))))
 
-(define (object-file-name file)
+(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)))

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)
+  :export (define-language lookup-language))
-  :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))
 
 
 ;;;
@@ -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))))

module/system/il/.cvsignore

@@ -0,0 +1 @@
+*.go

module/system/repl/.cvsignore

@@ -0,0 +1 @@
+*.go

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))
+  :use-module (ice-9 documentation))
-
-(define (puts x) (display x) (newline))
-
-(define (user-error msg . args)
-  (throw 'user-error #f msg args #f))
 
 
 ;;;
-;;; 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))
+    (module   (module m) (use u) (import i) (load l) (binding b))
-    (package  (package p) (lspkg lp) (autopackage) (globals g))
     (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))
+    (debug    (backtrace bt) (debugger db) (trace r) (step st))
-    (system   (statistics stat) (gc))))
+    (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.
+List available meta commands.
-The optional argument can be either one of command groups or
+A command group name can be given as an optional argument.
-command names.  Without argument, a list of help commands and
+Without any argument, a list of help commands and command groups
-all command groups are displayed, as you have already seen :)"
+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 FILE
-Load a file in the current module."
+Load a file in the current module.
-  (apply repl-load-file repl (->string file) opts))
+
+  -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))
+  (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.env.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))
 
 
 ;;;
@@ -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))))
+  (disassemble-objcode (load-objcode (->string file))))
-
-(define (->string x)
-  (object->string x display))
 
 
 ;;;
 ;;; 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 FORM
-Trace execution."
+Trace execution.
-  (apply vm-trace repl.vm (repl-compile repl form) opts))
+
+  -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)
+(define guile:gc gc)
-  "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 (gc repl)
   "gc
 Garbage collection."
-  (guile-gc))
+  (guile:gc))
-
-;;;
-;;; Statistics
-;;;
 
 (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)

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)
+  :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))
 
 
 ;;;
-;;; Repl
+;;; Repl type
 ;;;
 
-(define-vm-class <repl> ()
+(define-vm-class <repl> () env tm-stats vm-stats gc-stats)
-  vm language module value-count value-history tm-stats vm-stats gc-stats)
 
-(define (make-repl lang)
+(define-public (make-repl lang)
-  (let ((vm (the-vm)))
+  (let ((cenv (make-cenv :vm (the-vm)
+			 :language (lookup-language lang)
+			 :module (current-module))))
     (make <repl>
-	  :vm vm
+	  :env cenv
-	  :language (lookup-language lang)
-	  :module (current-module) ;; (global-ref 'user)
-	  :value-count 0
-;	  :value-history (make-vmodule)
 	  :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)
+(define-public (repl-prompt repl)
-  (format #t "~A@~A> " repl.language.name 'guile)
+  (let ((module-name (car (last-pair (module-name repl.env.module)))))
-  ;; (env-identifier repl.module))
+    (format #t "~A@~A> " repl.env.language.name module-name)
-  (force-output))
+    (force-output)))
 
-(define (repl-read repl . args)
+(define-public (repl-read repl)
-  (apply read-in repl.language args))
+  (repl.env.language.reader))
 
-(define (repl-compile repl form . opts)
+(define-public (repl-compile repl form . opts)
-  (apply compile-in form repl.module repl.language opts))
+  (apply compile-in form repl.env.module repl.env.language opts))
 
-(define (repl-eval repl form)
+(define-public (repl-eval repl form)
-  (let ((eval repl.language.evaluator))
+  (let ((eval repl.env.language.evaluator))
     (if eval
-	(eval form repl.module)
+	(eval form repl.env.module)
-	(vm-load repl.vm (repl-compile repl form)))))
+	(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))
+      (begin
-	     (sym (string->symbol (format #f "$~A" num))))
+	(repl.env.language.printer val)
-;	(vmodule-define repl.value-history sym val)
+	(newline))))
-	(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))
+;;;
+;;; Utilities
+;;;
 
-(define (repl-load-file repl file . opts)
+(define-public (puts x) (display x) (newline))
-  (let ((bytes (apply repl-compile-file repl file opts)))
+
-    (if (or (memq :b opts) (memq :r opts))
+(define-public (->string x)
-	(apply vm-trace repl.vm bytes opts)
+  (object->string x display))
-	(vm-load repl.vm bytes))))
+
+(define-public (user-error msg . args)
+  (throw 'user-error #f msg args #f))

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-method (describe (symbol <symbol>))
-
-(define-public (describe symbol)
-  (assert 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)))
 
 

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)
+	     (begin (read-char) (meta-command repl (read-line)))
-		    (meta-command repl (read-line)))
 	     ;; evaluation
 	     (let rep-loop ()
 	       (repl-print repl (repl-eval repl (repl-read repl)))

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)))))))))

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)

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
+(define-public (vm-load vm objcode)
-	dumpcode-nlocs dumpcode-nexts dumpcode-bytecode
+  (vm (objcode->program objcode)))
-	load-dumpcode save-dumpcode)
 
-(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)
+;;; Frame interface
-		 (integer->bytes nexts)
+;;;
-		 bytes))
 
-(define (dumpcode? x)
+(define-public (frame->call frame)
-  (and (string? x)
+  (let* ((prog (frame-program frame))
-       (> (string-length x) 10)
+	 (nargs (car (program-arity prog))))
-       (string=? (substring x 1 4) "GBC")))
+    (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 (dumpcode-version x)
+(define (program-name x)
-  (substring x 5 8))
+  (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
-
+	     (module-obarray (current-module))))
-(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))))
-
-(define (integer->bytes n)
-  (string (integer->char n)))
-
-(define (bytes->integer bytes start)
-  (char->integer (string-ref bytes start)))
 
+
 ;;;
 ;;; Statistics interface
 ;;;
 
-(export vms:time vms:clock)
+(define-public (vms:time stat) (vector-ref stat 0))
-
+(define-public (vms:clock stat) (vector-ref stat 1))
-(define (vms:time stat) (vector-ref stat 0))
-(define (vms:clock stat) (vector-ref stat 1))

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)
+(define (disassemble-objcode objcode . opts)
-  (if (not (dumpcode? dumpcode)) (error "Invalid dumpcode"))
+  (let* ((prog  (objcode->program objcode))
-  (format #t "Disassembly of dumpcode:\n\n")
+	 (arity (program-arity prog))
-  (format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode))
+	 (nlocs (caddr arity))
-  (format #t "nlocs = ~A  nexts = ~A\n\n"
+	 (nexts (cadddr arity))
-	  (dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode))
+	 (bytes (program-bytecode prog)))
-  (disassemble-bytecode (dumpcode-bytecode dumpcode) #f))
+    (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))

module/system/vm/frame.scm

@@ -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))))

module/system/vm/load.scm

@@ -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")))

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 ()

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)

src/Makefile.am

@@ -5,12 +5,14 @@ guile_vm_LDADD = libguilevm.la
 guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
 
 lib_LTLIBRARIES = libguilevm.la
-libguilevm_la_SOURCES = envs.c instructions.c programs.c vm.c	\
+libguilevm_la_SOURCES =						\
-	envs.h instructions.h programs.h vm.h vm_engine.h vm_expand.h
+	envs.c instructions.c objcodes.c programs.c vm.c	\
+	envs.h instructions.h objcodes.h programs.h vm.h	\
+	vm_engine.h vm_expand.h
 libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
 EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c
 BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
-	envs.x instructions.x programs.x vm.x
+	envs.x instructions.x objcodes.x programs.x vm.x
 
 INCLUDES = $(GUILE_CFLAGS)
 DISTCLEANFILES = $(BUILT_SOURCES)
@@ -27,4 +29,9 @@ SUFFIXES = .i .x
 	$(SNARF) $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
 	|| { rm $@; false; }
 
+GUILE = "$(bindir)/guile"
+guilec: guilec.in
+	sed "s!@guile@!$(GUILE)!" guilec.in > guilec
+	@chmod 755 guilec
+
 $(BUILT_SOURCES): config.h vm_expand.h

src/envs.h

@@ -39,8 +39,8 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
-#ifndef _ENVS_H_
+#ifndef _SCM_ENVS_H_
-#define _ENVS_H_
+#define _SCM_ENVS_H_
 
 #include <libguile.h>
 #include "config.h"
@@ -64,7 +64,7 @@ extern SCM scm_c_env_vcell (SCM env, SCM name, int intern);
 
 extern void scm_init_envs (void);
 
-#endif /* _ENVS_H_ */
+#endif /* _SCM_ENVS_H_ */
 
 /*
   Local Variables:

src/guile-vm.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/guilec.in

@@ -1,4 +1,4 @@
-#!@bindir@/guile					-*- scheme -*-
+#!@guile@ -s
 !#
 
 (use-modules (system base compile))

src/instructions.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/instructions.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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
@@ -39,8 +39,8 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
-#ifndef _INSTRUCTIONS_H_
+#ifndef _SCM_INSTRUCTIONS_H_
-#define _INSTRUCTIONS_H_
+#define _SCM_INSTRUCTIONS_H_
 
 #include <libguile.h>
 #include "config.h"
@@ -78,7 +78,7 @@ extern struct scm_instruction *scm_lookup_instruction (SCM name);
 
 extern void scm_init_instructions (void);
 
-#endif /* _INSTRUCTIONS_H_ */
+#endif /* _SCM_INSTRUCTIONS_H_ */
 
 /*
   Local Variables:

src/objcodes.c

@@ -0,0 +1,225 @@
+/* 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 software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#include <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+
+#include "programs.h"
+#include "objcodes.h"
+
+#define OBJCODE_COOKIE "GOOF-0.5"
+
+
+/*
+ * Objcode type
+ */
+
+scm_bits_t scm_tc16_objcode;
+
+static SCM
+make_objcode (size_t size)
+#define FUNC_NAME "make_objcode"
+{
+  struct scm_objcode *p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
+  p->size = size;
+  p->base = SCM_MUST_MALLOC (size);
+  p->fd   = -1;
+  SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static SCM
+make_objcode_by_mmap (int fd)
+#define FUNC_NAME "make_objcode_by_mmap"
+{
+  int ret;
+  char *addr;
+  struct stat st;
+  struct scm_objcode *p;
+
+  ret = fstat (fd, &st);
+  if (ret < 0) SCM_SYSERROR;
+
+  addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
+  if (addr == MAP_FAILED) SCM_SYSERROR;
+
+  p = SCM_MUST_MALLOC (sizeof (struct scm_objcode));
+  p->size = st.st_size;
+  p->base = addr;
+  p->fd   = fd;
+  SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static scm_sizet
+objcode_free (SCM obj)
+#define FUNC_NAME "objcode_free"
+{
+  size_t size = (sizeof (struct scm_objcode));
+  struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
+
+  if (p->fd >= 0)
+    {
+      int rv;
+      rv = munmap (p->base, p->size);
+      if (rv < 0) SCM_SYSERROR;
+      rv = close (p->fd);
+      if (rv < 0) SCM_SYSERROR;
+    }
+  else
+    {
+      size += p->size;
+      scm_must_free (p->base);
+    }
+
+  scm_must_free (p);
+  return size;
+}
+#undef FUNC_NAME
+
+
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_objcode_p
+{
+  return SCM_BOOL (SCM_OBJCODE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
+	    (SCM bytecode, SCM nlocs, SCM nexts),
+	    "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+  size_t size;
+  char *base;
+  SCM objcode;
+
+  SCM_VALIDATE_STRING (1, bytecode);
+  SCM_VALIDATE_INUM (2, nlocs);
+  SCM_VALIDATE_INUM (3, nexts);
+
+  size = SCM_STRING_LENGTH (bytecode) + 10;
+  objcode = make_objcode (size);
+  base = SCM_OBJCODE_BASE (objcode);
+
+  memcpy (base, OBJCODE_COOKIE, 8);
+  base[8] =  SCM_INUM (nlocs);
+  base[9] =  SCM_INUM (nexts);
+  memcpy (base + 10, SCM_STRING_CHARS (bytecode), size - 10);
+  return objcode;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
+	    (SCM file),
+	    "")
+#define FUNC_NAME s_scm_load_objcode
+{
+  int fd;
+
+  SCM_VALIDATE_STRING (1, file);
+
+  fd = open (SCM_STRING_CHARS (file), O_RDONLY);
+  if (fd < 0) SCM_SYSERROR;
+
+  return make_objcode_by_mmap (fd);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_string, "objcode->string", 1, 0, 0,
+	    (SCM objcode),
+	    "")
+#define FUNC_NAME s_scm_objcode_to_string
+{
+  SCM_VALIDATE_OBJCODE (1, objcode);
+  return scm_makfromstr (SCM_OBJCODE_BASE (objcode),
+			 SCM_OBJCODE_SIZE (objcode),
+			 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
+	    (SCM objcode),
+	    "")
+#define FUNC_NAME s_scm_objcode_to_program
+{
+  SCM prog;
+  size_t size;
+  char *base;
+
+  SCM_VALIDATE_OBJCODE (1, objcode);
+
+  base = SCM_OBJCODE_BASE (objcode);
+  size = SCM_OBJCODE_SIZE (objcode);
+  prog = scm_c_make_program (base + 10, size - 10, objcode);
+  SCM_PROGRAM_NLOCS (prog) = base[8];
+  SCM_PROGRAM_NEXTS (prog) = base[9];
+  return prog;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_objcodes (void)
+{
+  scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+  scm_set_smob_free (scm_tc16_objcode, objcode_free);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "objcodes.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/objcodes.h

@@ -0,0 +1,72 @@
+/* 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 software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_OBJCODES_H_
+#define _SCM_OBJCODES_H_
+
+#include <libguile.h>
+#include "config.h"
+
+struct scm_objcode {
+  size_t size;			/* objcode size */
+  char *base;			/* objcode base address */
+  int fd;			/* file descriptor when mmap'ed */
+};
+
+extern scm_bits_t scm_tc16_objcode;
+
+#define SCM_OBJCODE_P(x)	(SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
+#define SCM_OBJCODE_DATA(x)	((struct scm_objcode *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
+
+#define SCM_OBJCODE_SIZE(x)	(SCM_OBJCODE_DATA (x)->size)
+#define SCM_OBJCODE_BASE(x)	(SCM_OBJCODE_DATA (x)->base)
+#define SCM_OBJCODE_FD(x)	(SCM_OBJCODE_DATA (x)->fd)
+
+extern void scm_init_objcodes (void);
+
+#endif /* _SCM_OBJCODES_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/programs.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/programs.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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
@@ -39,8 +39,8 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
-#ifndef _PROGRAM_H_
+#ifndef _SCM_PROGRAMS_H_
-#define _PROGRAM_H_
+#define _SCM_PROGRAMS_H_
 
 #include <libguile.h>
 #include "config.h"
@@ -87,7 +87,7 @@ extern SCM scm_c_make_closure (SCM program, SCM external);
 
 extern void scm_init_programs (void);
 
-#endif /* _PROGRAM_H_ */
+#endif /* _SCM_PROGRAMS_H_ */
 
 /*
   Local Variables:

src/vm.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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
@@ -42,6 +42,7 @@
 #include <string.h>
 #include "instructions.h"
 #include "programs.h"
+#include "objcodes.h"
 #include "envs.h"
 #include "vm.h"
 
@@ -598,35 +599,6 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0,
-	    (SCM vm, SCM bootcode),
-	    "")
-#define FUNC_NAME s_scm_vm_load
-{
-  SCM prog;
-  int len;
-  char *base;
-
-  SCM_VALIDATE_VM (1, vm);
-  SCM_VALIDATE_STRING (2, bootcode);
-
-  base = SCM_STRING_CHARS (bootcode);
-  len  = SCM_STRING_LENGTH (bootcode);
-
-  /* Check bootcode */
-  if (strncmp (base, "\0GBC", 4) != 0)
-    SCM_MISC_ERROR ("Invalid bootcode: ~S", SCM_LIST1 (bootcode));
-
-  /* Create program */
-  prog  = scm_c_make_program (base + 10, len - 10, bootcode);
-  SCM_PROGRAM_NLOCS (prog) = base[8];
-  SCM_PROGRAM_NEXTS (prog) = base[9];
-
-  /* Load it */
-  return scm_vm_apply (vm, prog, SCM_EOL);
-}
-#undef FUNC_NAME
-
 
 /*
  * Initialize
@@ -637,6 +609,7 @@ scm_init_vm (void)
 {
   scm_init_instructions ();
   scm_init_programs ();
+  scm_init_objcodes ();
 
   scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0);
   scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark);

src/vm.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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
@@ -39,8 +39,8 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
-#ifndef _VM_H_
+#ifndef _SCM_VM_H_
-#define _VM_H_
+#define _SCM_VM_H_
 
 #include <libguile.h>
 #include "config.h"
@@ -151,7 +151,7 @@ extern SCM scm_vm_current_frame (SCM vm);
 
 extern void scm_init_vm (void);
 
-#endif /* _VM_H_ */
+#endif /* _SCM_VM_H_ */
 
 /*
   Local Variables:

src/vm_engine.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/vm_engine.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/vm_expand.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/vm_loader.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/vm_scheme.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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

src/vm_system.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* 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