*** empty log message ***

.cvsignore

@@ -1,8 +1,6 @@
 misc
 libtool
-config.log
+config.*
-config.cache
-config.status
 configure
 Makefile
 Makefile.in

configure.in

@@ -1,5 +1,5 @@
 AC_INIT(src/guile-vm.c)
-AM_INIT_AUTOMAKE(guile-vm, 0.4)
+AM_INIT_AUTOMAKE(guile-vm, 0.5)
 AM_CONFIG_HEADER(src/config.h)
 
 GUILE_FLAGS
@@ -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)
+AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile src/guilec)

module/Makefile.am

@@ -1,5 +1,13 @@
-DISTDIRS = $(srcdir)/language $(srcdir)/system
+DISTDIRS = $(srcdir)/language $(srcdir)/system $(srcdir)/slib
 EXCLUDES = --exclude=CVS --exclude='*~'
 
+all: slibcat
+
+clean:
+	rm -f slibcat slib/*.go
+
+slibcat:
+	guile -s slib-comp.scm
+
 dist-hook:
 	$(TAR) cf - $(EXCLUDES) $(DISTDIRS) | (cd $(distdir); $(TAR) xf -)

module/system/base/compile.scm

@@ -0,0 +1,48 @@
+;;; High-level compiler interface
+
+;; 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 base compile)
+  :use-module (system base language)
+  :use-module (ice-9 regex)
+  :export (compile-file object-file-name))
+
+(define scheme (lookup-language 'scheme))
+
+(define (compile-file file)
+  (let ((comp (object-file-name file)))
+    (call-with-compile-error-catch
+     (lambda ()
+       (catch #t
+	 (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 ((m (string-match "\\.[^.]*$" file)))
+    (string-append (if m (match:prefix m) file) ".go")))

module/system/base/language.scm

@@ -26,8 +26,8 @@
   :use-module (system vm core)
   :use-module (system vm assemble)
   :use-module (ice-9 regex)
-  :export (define-language lookup-language
+  :export (define-language lookup-language read-in compile-in print-in
-	    read-in compile-in print-in compile-file-in load-file-in))
+	    compile-file-in))
 
 
 ;;;
@@ -37,10 +37,11 @@
 (define-vm-class <language> ()
   name title version environment
   (reader)
-  (expander (lambda (x) x))
+  (expander (lambda (x e) x))
-  (translator (lambda (x) x))
+  (translator (lambda (x e) x))
-  (evaler #f)
+  (evaluator #f)
   (printer)
+  (compiler)
   )
 
 (define-method (write (lang <language>) port)
@@ -65,41 +66,34 @@
 (define (read-in lang . port)
   (lang.reader (if (null? port) (current-input-port) (car port))))
 
-(define (compile-in form env lang . opts)
+(define (compile-in x e lang . opts)
   (catch 'result
     (lambda ()
       ;; expand
-      (set! form (lang.expander form))
+      (set! x (lang.expander x e))
-      (if (memq :e opts) (throw 'result form))
+      (if (memq :e opts) (throw 'result x))
       ;; translate
-      (set! form (lang.translator form))
+      (set! x (lang.translator x e))
-      (if (memq :t opts) (throw 'result form))
+      (if (memq :t opts) (throw 'result x))
       ;; compile
-      (set! form (apply compile form env opts))
+      (set! x (apply compile x e opts))
-      (if (memq :c opts) (throw 'result form))
+      (if (memq :c opts) (throw 'result x))
       ;; assemble
-      (apply assemble form env opts))
+      (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 env lang . opts)
+(define (compile-file-in file lang . opts)
-  (let* ((code (call-with-input-file file
+  (call-with-input-file file
-		 (lambda (in)
+    (lambda (port) (apply lang.compiler port (current-module) opts))))
-		   (do ((x (read-in lang in) (read-in lang in))
-			(l '() (cons (lang.translator (lang.expander x)) l)))
-		       ((eof-object? x) (reverse! l))))))
-	 (asm (apply compile (cons '@begin code) env opts)))
-    (save-dumpcode (apply assemble asm env opts) (object-file-name file))))
 
-(define (load-file-in file env lang . opts)
+(define-public (syntax-error loc msg exp)
-  (let ((compiled (object-file-name file)))
+  (throw 'syntax-error loc msg exp))
-    (if (or (not (file-exists? compiled))
-	    (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
-	(compile-file-in file env lang :O))
-    (load-dumpcode compiled)))
 
-(define (object-file-name file)
+(define-public (call-with-compile-error-catch thunk)
-  (let ((m (string-match "\\.[^.]*$" file)))
+  (catch 'syntax-error
-    (string-append (if m (match:prefix m) file) ".go")))
+    thunk
+    (lambda (key loc msg exp)
+      (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))

module/system/il/compile.scm

@@ -24,11 +24,11 @@
   :use-syntax (system base syntax)
   :use-module (system il glil)
   :use-module (system il ghil)
+  :use-module (ice-9 match)
   :use-module (ice-9 common-list)
   :export (compile))
 
 (define (compile x e . opts)
-  (set! x (parse-ghil x e))
   (if (memq :O opts) (set! x (optimize x)))
   (codegen x))
 
@@ -103,36 +103,75 @@
     (define (push-code! code)
       (set! stack (cons code stack)))
     (define (comp tree tail drop)
+      (define (push-label! label)
+	(push-code! (make-<glil-label> label)))
+      (define (push-branch! inst label)
+	(push-code! (make-<glil-branch> inst label)))
+      (define (push-call! inst args)
+	(for-each comp-push args)
+	(push-code! (make-<glil-call> inst (length args))))
       ;; possible tail position
       (define (comp-tail tree) (comp tree tail drop))
       ;; push the result
       (define (comp-push tree) (comp tree #f #f))
       ;; drop the result
       (define (comp-drop tree) (comp tree #f #t))
+      ;; drop the result if unnecessary
+      (define (maybe-drop)
+	(if drop (push-code! *ia-drop*)))
+      ;; return here if necessary
+      (define (maybe-return)
+	(if tail (push-code! *ia-return*)))
       ;; return this code if necessary
       (define (return-code! code)
 	(if (not drop) (push-code! code))
-	(if tail (push-code! *ia-return*)))
+	(maybe-return))
       ;; return void if necessary
-      (define (return-void!) (return-code! *ia-void*))
+      (define (return-void!)
+	(return-code! *ia-void*))
+      ;; return object if necessary
+      (define (return-object! obj)
+	(return-code! (make-<glil-const> obj)))
       ;;
       ;; dispatch
       (match tree
 	(($ <ghil-void>)
 	 (return-void!))
 
-	(($ <ghil-quote> obj)
+	(($ <ghil-quote> env loc obj)
-	 (return-code! (make-<glil-const> obj)))
+	 (return-object! obj))
 
-	(($ <ghil-ref> env var)
+	(($ <ghil-quasiquote> env loc exp)
+	 (let loop ((x exp))
+	   (match x
+	     ((? list? ls)
+	      (push-call! 'mark '())
+	      (for-each loop ls)
+	      (push-call! 'list-mark '()))
+	     ((? pair? pp)
+	      (loop (car pp))
+	      (loop (cdr pp))
+	      (push-code! (make-<glil-call> 'cons 2)))
+	     (($ <ghil-unquote> env loc exp)
+	      (comp-push exp))
+	     (($ <ghil-unquote-splicing> env loc exp)
+	      (comp-push exp)
+	      (push-call! 'list-break '()))
+	     (else
+	      (push-code! (make-<glil-const> x)))))
+	 (maybe-drop)
+	 (maybe-return))
+
+	(($ <ghil-ref> env loc var)
 	 (return-code! (make-glil-var 'ref env var)))
 
-	(($ <ghil-set> env var val)
+	((or ($ <ghil-set> env loc var val)
+	     ($ <ghil-define> env loc var val))
 	 (comp-push val)
 	 (push-code! (make-glil-var 'set env var))
 	 (return-void!))
 
-	(($ <ghil-if> test then else)
+	(($ <ghil-if> env loc test then else)
 	 ;;     TEST
 	 ;;     (br-if-not L1)
 	 ;;     THEN
@@ -141,14 +180,59 @@
 	 ;; L2:
 	 (let ((L1 (make-label)) (L2 (make-label)))
 	   (comp-push test)
-	   (push-code! (make-<glil-branch> 'br-if-not L1))
+	   (push-branch! 'br-if-not L1)
 	   (comp-tail then)
-	   (if (not tail) (push-code! (make-<glil-branch> 'br L2)))
+	   (if (not tail) (push-branch! 'br L2))
-	   (push-code! (make-<glil-label> L1))
+	   (push-label! L1)
 	   (comp-tail else)
-	   (if (not tail) (push-code! (make-<glil-label> L2)))))
+	   (if (not tail) (push-label! L2))))
 
-	(($ <ghil-begin> exps)
+	(($ <ghil-and> env loc exps)
+	 ;;     EXP
+	 ;;     (br-if-not L1)
+	 ;;     ...
+	 ;;     TAIL
+	 ;;     (br L2)
+	 ;; L1: (const #f)
+	 ;; L2:
+	 (let ((L1 (make-label)) (L2 (make-label)))
+	   (if (null? exps)
+	       (return-object! #t)
+	       (do ((exps exps (cdr exps)))
+		   ((null? (cdr exps))
+		    (comp-tail (car exps))
+		    (if (not tail) (push-branch! 'br L2))
+		    (push-label! L1)
+		    (return-object! #f)
+		    (if (not tail) (push-label! L2))
+		    (maybe-drop)
+		    (maybe-return))
+		 (comp-push (car exps))
+		 (push-branch! 'br-if-not L1)))))
+
+	(($ <ghil-or> env loc exps)
+	 ;;     EXP
+	 ;;     (dup)
+	 ;;     (br-if L1)
+	 ;;     (drop)
+	 ;;     ...
+	 ;;     TAIL
+	 ;; L1:
+	 (let ((L1 (make-label)))
+	   (if (null? exps)
+	       (return-object! #f)
+	       (do ((exps exps (cdr exps)))
+		   ((null? (cdr exps))
+		    (comp-tail (car exps))
+		    (push-label! L1)
+		    (maybe-drop)
+		    (maybe-return))
+		 (comp-push (car exps))
+		 (push-call! 'dup '())
+		 (push-branch! 'br-if L1)
+		 (push-call! 'drop '())))))
+
+	(($ <ghil-begin> env loc exps)
 	 ;; EXPS...
 	 ;; TAIL
 	 (if (null? exps)
@@ -158,7 +242,7 @@
 		  (comp-tail (car exps)))
 	       (comp-drop (car exps)))))
 
-	(($ <ghil-bind> env vars vals body)
+	(($ <ghil-bind> env loc vars vals body)
 	 ;; VALS...
 	 ;; (set VARS)...
 	 ;; BODY
@@ -167,30 +251,27 @@
 		   (reverse vars))
 	 (comp-tail body))
 
-	(($ <ghil-lambda> env vars rest body)
+	(($ <ghil-lambda> env loc vars rest body)
 	 (return-code! (codegen tree)))
 
-	(($ <ghil-inst> inst args)
+	(($ <ghil-inline> env loc inst args)
 	 ;; ARGS...
 	 ;; (INST NARGS)
-	 (for-each comp-push args)
+	 (push-call! inst args)
-	 (push-code! (make-<glil-call> inst (length args)))
+	 (maybe-drop)
-	 (if drop (push-code! *ia-drop*))
+	 (maybe-return))
-	 (if tail (push-code! *ia-return*)))
 
-	(($ <ghil-call> env proc args)
+	(($ <ghil-call> env loc proc args)
 	 ;; PROC
 	 ;; ARGS...
 	 ;; ([tail-]call NARGS)
 	 (comp-push proc)
-	 (for-each comp-push args)
+	 (push-call! (if tail 'tail-call 'call) args)
-	 (let ((inst (if tail 'tail-call 'call)))
+	 (maybe-drop))))
-	   (push-code! (make-<glil-call> inst (length args))))
-	 (if drop (push-code! *ia-drop*)))))
     ;;
     ;; main
     (match ghil
-      (($ <ghil-lambda> env args rest body)
+      (($ <ghil-lambda> env loc args rest body)
        (let* ((vars env.variables)
 	      (locs (pick (lambda (v) (eq? v.kind 'local)) vars))
 	      (exts (pick (lambda (v) (eq? v.kind 'external)) vars)))

module/system/il/ghil.scm

@@ -26,19 +26,37 @@
   :use-module (ice-9 regex)
   :export
   (parse-ghil
-   ghil-primitive?
+   ghil-lookup ghil-primitive?
-   make-<ghil-void> <ghil-void>?
+   make-<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
-   make-<ghil-quote> <ghil-quote>? <ghil-quote>-1
+   make-<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
-   make-<ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2
+   make-<ghil-quasiquote> <ghil-quasiquote>?
-   make-<ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3
+   <ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
-   make-<ghil-if> <ghil-if>? <ghil-if>-1 <ghil-if>-2 <ghil-if>-3
+   make-<ghil-unquote> <ghil-unquote>?
-   make-<ghil-begin> <ghil-begin>? <ghil-begin>-1
+   <ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
+   make-<ghil-unquote-splicing> <ghil-unquote-splicing>?
+   <ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2
+   <ghil-unquote-splicing>-3
+
+   make-<ghil-ref> <ghil-ref>?
+   <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
+   make-<ghil-set> <ghil-set>?
+   <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
+   make-<ghil-define> <ghil-define>?
+   <ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4
+
+   make-<ghil-if> <ghil-if>?
+   <ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5
+   make-<ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
+   make-<ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
+   make-<ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
    make-<ghil-bind> <ghil-bind>?
-   <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4
+   <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
-   make-<ghil-lambda> <ghil-lambda>?
+   make-<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
-   <ghil-lambda>-1 <ghil-lambda>-2 <ghil-lambda>-3 <ghil-lambda>-4
+   <ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
-   make-<ghil-call> <ghil-call>? <ghil-call>-1 <ghil-call>-2 <ghil-call>-3
+   make-<ghil-inline> <ghil-inline>?
-   make-<ghil-inst> <ghil-inst>? <ghil-inst>-1 <ghil-inst>-2
+   <ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
+   make-<ghil-call> <ghil-call>?
+   <ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
    ))
 
 
@@ -46,16 +64,27 @@
 ;;; Parse tree
 ;;;
 
-(define-structure (<ghil-void>))
+(define-structure (<ghil-void> env loc))
-(define-structure (<ghil-quote> obj))
+(define-structure (<ghil-quote> env loc obj))
-(define-structure (<ghil-ref> env var))
+(define-structure (<ghil-quasiquote> env loc exp))
-(define-structure (<ghil-set> env var val))
+(define-structure (<ghil-unquote> env loc exp))
-(define-structure (<ghil-if> test then else))
+(define-structure (<ghil-unquote-splicing> env loc exp))
-(define-structure (<ghil-begin> exps))
+
-(define-structure (<ghil-bind> env vars vals body))
+(define-structure (<ghil-ref> env loc var))
-(define-structure (<ghil-lambda> env vars rest body))
+(define-structure (<ghil-set> env loc var val))
-(define-structure (<ghil-call> env proc args))
+(define-structure (<ghil-define> env loc var val))
-(define-structure (<ghil-inst> inst args))
+
+(define-structure (<ghil-if> env loc test then else))
+(define-structure (<ghil-and> env loc exps))
+(define-structure (<ghil-or> env loc exps))
+(define-structure (<ghil-begin> env loc exps))
+(define-structure (<ghil-bind> env loc vars vals body))
+(define-structure (<ghil-lambda> env loc vars rest body))
+(define-structure (<ghil-call> env loc proc args))
+(define-structure (<ghil-inline> env loc inline args))
+
+(define-public (ghil-env ghil) (vector-ref ghil 1))
+(define-public (ghil-loc ghil) (vector-ref ghil 2))
 
 
 ;;;
@@ -86,9 +115,14 @@
 (define-vm-class <ghil-var> ()
   env name kind type value index)
 
-(define (make-ghil-var env name kind)
+(define-public (make-ghil-var env name kind)
   (make <ghil-var> :env env :name name :kind kind))
 
+(define-method (write (var <ghil-var>) port)
+  (display "#<ghil:var " port)
+  (display var.name port)
+  (display ">" port))
+
 
 ;;;
 ;;; Modules
@@ -99,9 +133,14 @@
   (table '())
   (imports '()))
 
-(define (make-ghil-mod module)
+(define-public (make-ghil-mod module)
   (make <ghil-mod> :module module))
 
+(define-method (write (mod <ghil-mod>) port)
+  (display "#<ghil:mod " port)
+  (display (module-name mod.module) port)
+  (display ">" port))
+
 (define-method (ghil-lookup (mod <ghil-mod>) (sym <symbol>))
   (or (assq-ref mod.table sym)
       ;; (let ((var (make-ghil-var (env-identifier mod.module) sym 'module)))
@@ -120,6 +159,7 @@
   (table '())
   (variables '()))
 
+(export make-ghil-env)
 (define-method (make-ghil-env (m <ghil-mod>))
   (make <ghil-env> :mod m :parent m))
 
@@ -148,6 +188,23 @@
 	       (lambda (var) (set! var.kind 'external) var))
 	      (else (loop e.parent))))))
 
+(define-public (call-with-ghil-environment e syms func)
+  (let* ((e (make-ghil-env e))
+	 (vars (map (lambda (s)
+		      (let ((v (make-ghil-var e s 'argument)))
+			(ghil-env-add! e v) v))
+		    syms)))
+    (func e vars)))
+
+(define-public (call-with-ghil-bindings e syms func)
+  (let* ((vars (map (lambda (s)
+		      (let ((v (make-ghil-var e s 'local)))
+			(ghil-env-add! e v) v))
+		    syms))
+	 (ret (func vars)))
+    (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+    ret))
+
 
 ;;;
 ;;; Parser
@@ -189,11 +246,11 @@
 	(receive (module name) (identifier-split identifier)
 	  (make-<ghil-ref> e (make-ghil-var module name 'module))))))
 
-    ;; (@@ INST ARGS...)
+    ;; (@@ OP ARGS...)
     ((@@)
      (match args
-       ((inst . args)
+       ((op . args)
-	(make-<ghil-inst> inst (map-parse args e)))))
+	(make-<ghil-inline> op (map-parse args e)))))
 
     ;; (@void)
     ((@void)
@@ -272,17 +329,14 @@
 
     ;; (@eval-case CLAUSE...)
     ((@eval-case)
-     (match args
+     (let loop ((clauses args))
-       ((clause . rest)
+       (cond ((null? clauses) (make-<ghil-void>))
-	(match clause
+	     ((or (eq? (caar clauses) '@else)
-	  (() (make-<ghil-void>))
+		  (and (memq 'load-toplevel (caar clauses))
-	  (((key ...) . body)
+		       (ghil-env-toplevel? e)))
-	   (cond ((and (ghil-env-toplevel? e) (memq 'load-toplevel key))
+	      (parse-body (cdar clauses) e))
-		  (parse-body body e))
 	     (else
-		  (error "No match clause"))))
+	      (loop (cdr clauses))))))
-	  (else
-	   (error "No match clause"))))))
 
     (else (error "Unknown primitive:" prim))))
 

module/system/il/macros.scm

@@ -65,8 +65,8 @@
 ;;; 6.1 Equivalence predicates
 
 (define (@eq? x y)	`(@@ eq? ,x ,y))
-(define (@eqv? x y)	`(@@ eqv? ,x ,y))
+;(define (@eqv? x y)	`(@@ eqv? ,x ,y))
-(define (@equal? x y)	`(@@ equal? ,x ,y))
+;(define (@equal? x y)	`(@@ equal? ,x ,y))
 
 ;;; 6.2 Numbers
 
@@ -79,7 +79,7 @@
 (define (@exact? x)	`((@ Core::exact?) ,x))
 (define (@inexact? x)	`((@ Core::inexact?) ,x))
 
-(define (@= x y)	`(@@ ee? ,x ,y))
+;(define (@= x y)	`(@@ ee? ,x ,y))
 ;(define (@< x y)	`(@@ lt? ,x ,y))
 ;(define (@> x y)	`(@@ gt? ,x ,y))
 ;(define (@<= x y)	`(@@ le? ,x ,y))

module/system/repl/command.scm

@@ -20,19 +20,16 @@
 ;;; Code:
 
 (define-module (system repl command)
-  :use-module (oop goops)
   :use-syntax (system base syntax)
   :use-module (system base language)
   :use-module (system repl common)
   :use-module (system il glil)
   :use-module (system vm core)
-  :use-module (system vm load)
+  :autoload (system vm trace) (vm-trace)
-  :use-module (system vm trace)
+  :autoload (system vm disasm) (disassemble-program disassemble-dumpcode)
-  :use-module (system vm disasm)
+  :autoload (system vm profile) (vm-profile)
-  :use-module (system vm profile)
   :use-module (ice-9 format)
   :use-module (ice-9 session)
-  :use-module (ice-9 debugger)
   :export (meta-command))
 
 (define (puts x) (display x) (newline))
@@ -318,8 +315,7 @@ Disassemble a program."
 (define (disassemble-file repl file)
   "disassemble-file FILE
 Disassemble a file."
-  (disassemble-dumpcode
+  (disassemble-dumpcode (load-dumpcode (->string file))))
-   (load-file-in (->string file) repl.module repl.language)))
 
 (define (->string x)
   (object->string x display))
@@ -388,37 +384,15 @@ Time execution."
 	    (get id gc-start gc-end))
     result))
 
-;;;
-;;; Statistics
-;;;
-
 (define guile-gc gc)
 (define (gc repl)
   "gc
 Garbage collection."
   (guile-gc))
 
-(define (display-stat title flag field1 field2 unit)
+;;;
-  (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+;;; Statistics
-    (format #t str title field1 field2 unit)))
+;;;
-
-(define (display-stat-title title field1 field2)
-  (display-stat title #t field1 field2 ""))
-
-(define (display-diff-stat title flag this last unit)
-  (display-stat title flag (- this last) this unit))
-
-(define (display-time-stat title this last)
-  (define (conv num)
-    (format #f "~10,2F" (/ num internal-time-units-per-second)))
-  (display-stat title #f (conv (- this last)) (conv this) "s"))
-
-(define (display-mips-stat title this-time this-clock last-time last-clock)
-  (define (mips time clock)
-    (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
-  (display-stat title #f
-		(mips (- this-time last-time) (- this-clock last-clock))
-		(mips this-time this-clock) "mips"))
 
 (define (statistics repl)
   "statistics
@@ -494,3 +468,25 @@ Display statistics."
     (set! repl.tm-stats this-tms)
     (set! repl.vm-stats this-vms)
     (set! repl.gc-stats this-gcs)))
+
+(define (display-stat title flag field1 field2 unit)
+  (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+    (format #t str title field1 field2 unit)))
+
+(define (display-stat-title title field1 field2)
+  (display-stat title #t field1 field2 ""))
+
+(define (display-diff-stat title flag this last unit)
+  (display-stat title flag (- this last) this unit))
+
+(define (display-time-stat title this last)
+  (define (conv num)
+    (format #f "~10,2F" (/ num internal-time-units-per-second)))
+  (display-stat title #f (conv (- this last)) (conv this) "s"))
+
+(define (display-mips-stat title this-time this-clock last-time last-clock)
+  (define (mips time clock)
+    (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
+  (display-stat title #f
+		(mips (- this-time last-time) (- this-clock last-clock))
+		(mips this-time this-clock) "mips"))

module/system/repl/common.scm

@@ -41,7 +41,7 @@
     (make <repl>
 	  :vm vm
 	  :language (lookup-language lang)
-	  :module #f ;; (global-ref 'user)
+	  :module (current-module) ;; (global-ref 'user)
 	  :value-count 0
 ;	  :value-history (make-vmodule)
 	  :tm-stats (times)
@@ -66,9 +66,9 @@
   (apply compile-in form repl.module repl.language opts))
 
 (define (repl-eval repl form)
-  (let ((evaler repl.language.evaler))
+  (let ((eval repl.language.evaluator))
-    (if evaler
+    (if eval
-	(evaler form repl.module)
+	(eval form repl.module)
 	(vm-load repl.vm (repl-compile repl form)))))
 
 (define (repl-print repl val)
@@ -81,11 +81,11 @@
 	(newline)
 	(set! repl.value-count num))))
 
-(define (repl-compile-file repl form . opts)
+(define (repl-compile-file repl file . opts)
-  (apply compile-file-in form repl.module repl.language opts))
+  (apply compile-file-in file repl.language opts))
 
 (define (repl-load-file repl file . opts)
-  (let ((bytes (apply load-file-in file repl.module repl.language opts)))
+  (let ((bytes (apply repl-compile-file repl file opts)))
-    (if (memq :t opts)
+    (if (or (memq :b opts) (memq :r opts))
-	(vm-trace repl.vm bytes :a)
+	(apply vm-trace repl.vm bytes opts)
 	(vm-load repl.vm bytes))))

module/system/vm/.cvsignore

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

module/system/vm/assemble.scm

@@ -20,7 +20,6 @@
 ;;; Code:
 
 (define-module (system vm assemble)
-  :use-syntax (system base syntax)
   :use-module (system il glil)
   :use-module (system vm core)
   :use-module (system vm conv)
@@ -210,8 +209,7 @@
 	 (push-code! `(load-program ,bytes)))))
      ((vlink? x)
       ;;; (dump! (vlink-module x))  ;; FIXME: no module support now
-      (dump! (vlink-name x))
+      (push-code! `(link ,(symbol->string (vlink-name x)))))
-      (push-code! `(link)))
      ((vmod? x)
       (push-code! `(load-module ,(vmod-id x))))
      ((and (integer? x) (exact? x))

module/system/vm/conv.scm

@@ -83,6 +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))
     (else #f)))
 
 (define (code->bytes code)

module/system/vm/load.scm

@@ -20,22 +20,34 @@
 ;;; Code:
 
 (define-module (system vm load)
+  :autoload (system base compile) (compile-file)
   :use-module (system vm core)
-  :autoload (system base language) (compile-file-in lookup-language)
   :use-module (ice-9 regex)
-  :export (load/compile))
+  :export (load-compiled-file compile-and-load load/compile))
 
-(define (load/compile file)
+(define (load-compiled-file file . opts)
-  (let* ((file (file-name-full-name file))
+  (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))))
-	(compile-file-in file #f (lookup-language 'gscheme) #:O))
+	(apply compile-file file #f opts))
-    (vm-load (the-vm) (load-dumpcode compiled))))
+    (if (memq #:b opts)
+	(apply vm-trace (the-vm) (load-dumpcode compiled) opts)
+	(vm-load (the-vm) (load-dumpcode compiled)))))
 
-(define (file-name-full-name filename)
+(define (file-full-name filename)
-  (let ((oldname (and (current-load-port)
+  (let* ((port (current-load-port))
-		      (port-filename (current-load-port)))))
+	 (oldname (and port (port-filename port))))
     (if (and oldname
 	     (> (string-length filename) 0)
 	     (not (char=? (string-ref filename 0) #\/))
@@ -43,6 +55,6 @@
 	(string-append (dirname oldname) "/" filename)
 	filename)))
 
-(define (object-file-name file)
+(define-public (object-file-name file)
   (let ((m (string-match "\\.[^.]*$" file)))
     (string-append (if m (match:prefix m) file) ".go")))

module/system/vm/slib.scm

@@ -1,251 +0,0 @@
-;;;; slib.scm --- definitions needed to get SLIB to work with Guile
-;;;;
-;;;;  	Copyright (C) 1997, 1998, 2000 Free Software Foundation, Inc.
-;;;;
-;;;;   This file is part of GUILE.
-;;;;   
-;;;;   GUILE 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.
-;;;;   
-;;;;   GUILE 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 GUILE; see the file COPYING.  If not, write
-;;;;   to the Free Software Foundation, Inc., 59 Temple Place, Suite
-;;;;   330, Boston, MA 02111-1307 USA
-;;;;
-(define-module (system vm slib)
-  :use-module (system vm load)
-  :no-backtrace)
-
-
-
-(define (eval-load <filename> evl)
-  (if (not (file-exists? <filename>))
-      (set! <filename> (string-append <filename> (scheme-file-suffix))))
-  (call-with-input-file <filename>
-    (lambda (port)
-      (let ((old-load-pathname *load-pathname*))
-	(set! *load-pathname* <filename>)
-	(do ((o (read port) (read port)))
-	    ((eof-object? o))
-	  (evl o))
-	(set! *load-pathname* old-load-pathname)))))
-
-
-
-(define slib:exit quit)
-(define slib:error error)
-(define slib:warn warn)
-(define slib:eval (lambda (x) (eval x slib-module)))
-(define defmacro:eval (lambda (x) (eval x (interaction-environment))))
-(define logical:logand logand)
-(define logical:logior logior)
-(define logical:logxor logxor)
-(define logical:lognot lognot)
-(define logical:ash ash)
-(define logical:logcount logcount)
-(define logical:integer-length integer-length)
-(define logical:bit-extract bit-extract)
-(define logical:integer-expt integer-expt)
-(define logical:ipow-by-squaring ipow-by-squaring)
-(define slib:eval-load eval-load)
-(define slib:tab #\tab)
-(define slib:form-feed #\page)
-
-(define slib-module (current-module))
-
-(define (defined? symbol)
-  (module-defined? slib-module symbol))
-
-(define slib:features
-  (append '(source
-	    eval
-	    abort
-	    alist
-	    defmacro
-	    delay
-	    dynamic-wind
-	    full-continuation
-	    hash
-	    hash-table
-	    line-i/o
-	    logical
-	    multiarg/and-
-	    multiarg-apply
-	    promise
-	    rev2-procedures
-	    rev4-optional-procedures
-	    string-port
-	    with-file)
-
-	  (if (defined? 'getenv)
-	      '(getenv)
-	      '())
-
-	  (if (defined? 'current-time)
-	      '(current-time)
-	      '())
-
-	  (if (defined? 'system)
-	      '(system)
-	      '())
-
-	  (if (defined? 'array?)
-	      '(array)
-	      '())
-
-	  (if (defined? 'char-ready?)
-	      '(char-ready?)
-	      '())
-
-	  (if (defined? 'array-for-each)
-	      '(array-for-each)
-	      '())
-
-	  (if (and (string->number "0.0") (inexact? (string->number "0.0")))
-	      '(inexact)
-	      '())
-
-	  (if (rational? (string->number "1/19"))
-	      '(rational)
-	      '())
-
-	  (if (real? (string->number "0.0"))
-	      '(real)
-	      ())
-
-	  (if (complex? (string->number "1+i"))
-	      '(complex)
-	      '())
-
-	  (let ((n (string->number "9999999999999999999999999999999")))
-	    (if (and n (exact? n))
-		'(bignum)
-		'()))))
-
-
-;;; FIXME: Because uers want require to search the path, this uses
-;;; load-from-path, which probably isn't a hot idea.  slib
-;;; doesn't expect this function to search a path, so I expect to get
-;;; bug reports at some point complaining that the wrong file gets
-;;; loaded when something accidentally appears in the path before
-;;; slib, etc. ad nauseum.  However, the right fix seems to involve
-;;; changing catalog:get in slib/require.scm, and I don't expect
-;;; Aubrey will integrate such a change.  So I'm just going to punt
-;;; for the time being.
-(define-public (slib:load name)
-  (save-module-excursion
-   (lambda ()
-     (define (try-load name)
-       (catch 'system-error
-	 (lambda () (load/compile (%search-load-path name)) #f)
-	 (lambda args args)))
-     ;; (set-current-module slib-module)
-     (let ((errinfo (try-load name)))
-       (if (and errinfo (try-load (string-append name ".scm")))
-	   (apply throw errinfo))))))
-
-(define slib:load-source slib:load)
-(define defmacro:load slib:load)
-
-(define slib-parent-dir
-  (let* ((path (%search-load-path "slib/require.scm")))
-    (if path
-	(substring path 0 (- (string-length path) 17))
-	(error "Could not find slib/require.scm in " %load-path))))
-
-(define-public (implementation-vicinity)
-  (string-append slib-parent-dir "/"))
-(define-public (library-vicinity)
-  (string-append (implementation-vicinity) "slib/"))
-(define-public home-vicinity
-  (let ((home-path (getenv "HOME")))
-    (lambda () home-path)))
-(define-public (scheme-implementation-type) 'guile)
-(define-public (scheme-implementation-version) "")
-
-(define (output-port-width . arg) 80)
-(define (output-port-height . arg) 24)
-(define (identity x) x)
-
-;;; {Random numbers}
-;;;
-(define-public (make-random-state . args)
-  (let ((seed (if (null? args) *random-state* (car args))))
-    (cond ((string? seed))
-	  ((number? seed) (set! seed (number->string seed)))
-	  (else (let ()
-		  (require 'object->string)
-		  (set! seed (object->limited-string seed 50)))))
-    (seed->random-state seed)))
-
-;;; {Time}
-;;;
-
-(define difftime -)
-(define offset-time +)
-
-
-(define %system-define define)
-
-(define define
-  (procedure->memoizing-macro
-   (lambda (exp env)
-     (if (= (length env) 1)
-	 `(define-public ,@(cdr exp))
-	 `(%system-define ,@(cdr exp))))))
-
-;;; Hack to make syncase macros work in the slib module
-(if (nested-ref the-root-module '(app modules ice-9 syncase))
-    (set-object-property! (module-local-variable (current-module) 'define)
-			  '*sc-expander*
-			  '(define)))
-
-(define (software-type)
-  "Return a symbol describing the current platform's operating system.
-This may be one of AIX, VMS, UNIX, COHERENT, WINDOWS, MS-DOS, OS/2,
-THINKC, AMIGA, ATARIST, MACH, or ACORN.
-
-Note that most varieties of Unix are considered to be simply \"UNIX\".
-That is because when a program depends on features that are not present
-on every operating system, it is usually better to test for the presence
-or absence of that specific feature.  The return value of
-@code{software-type} should only be used for this purpose when there is
-no other easy or unambiguous way of detecting such features."
- 'UNIX)
-
-(slib:load (in-vicinity (library-vicinity) "require.scm"))
-
-(define-public require require:require)
-
-;; {Extensions to the require system so that the user can add new
-;;  require modules easily.}
-
-(define *vicinity-table*
-  (list
-   (cons 'implementation (implementation-vicinity))
-   (cons 'library (library-vicinity))))
-
-(define (install-require-vicinity name vicinity)
-  (let ((entry (assq name *vicinity-table*)))
-    (if entry
-	(set-cdr! entry vicinity)
-	(set! *vicinity-table*
-	      (acons name vicinity *vicinity-table*)))))
-
-(define (install-require-module name vicinity-name file-name)
-  (if (not *catalog*)	     ;Fix which loads catalog in slib
-      (catalog:get 'random)) ;(doesn't load the feature 'random)
-  (let ((entry (assq name *catalog*))
-	(vicinity (cdr (assq vicinity-name *vicinity-table*))))
-    (let ((path-name (in-vicinity vicinity file-name)))
-      (if entry
-	  (set-cdr! entry path-name)
-	  (set! *catalog*
-		(acons name path-name *catalog*))))))

src/.cvsignore

@@ -1,5 +1,6 @@
 .libs
 .deps
+guilec
 guile-vm
 stamp-h
 config.h

src/Makefile.am

@@ -1,4 +1,5 @@
 bin_PROGRAMS = guile-vm
+bin_SCRIPTS = guilec
 guile_vm_SOURCES = guile-vm.c
 guile_vm_LDADD = libguilevm.la 
 guile_vm_LDFLAGS = $(GUILE_LDFLAGS)

src/guilec.in

@@ -0,0 +1,5 @@
+#!@bindir@/guile					-*- scheme -*-
+!#
+
+(use-modules (system base compile))
+(for-each compile-file (cdr (command-line)))

src/vm_engine.h

@@ -219,6 +219,19 @@ do {						\
   PUSH (l);					\
 } while (0)
 
+#define POP_LIST_MARK()				\
+do {						\
+  SCM o;					\
+  SCM l = SCM_EOL;				\
+  POP (o);					\
+  while (!SCM_UNBNDP (o))			\
+    {						\
+      CONS (l, o, l);				\
+      POP (o);					\
+    }						\
+  PUSH (l);					\
+} while (0)
+
 
 /*
  * Instruction operation
@@ -256,7 +269,6 @@ do {						\
 #define ARGS1(a1)	SCM a1 = sp[0];
 #define ARGS2(a1,a2)	SCM a1 = sp[-1], a2 = sp[0]; sp--;
 #define ARGS3(a1,a2,a3)	SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
-#define ARGSN(an)	int an = FETCH ();
 
 #define RETURN(x)	do { *sp = x; NEXT; } while (0)
 

src/vm_expand.h

@@ -64,7 +64,7 @@
 #define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \
   {VM_OPCODE (tag), name, len, npop, npush},
 #define VM_DEFINE_FUNCTION(tag,name,nargs) \
-  {VM_OPCODE (tag), name, (nargs < 0) ? 1 : 0, nargs, 1},
+  {VM_OPCODE (tag), name, 0, nargs, 1},
 #define VM_DEFINE_LOADER(tag,name) \
   {VM_OPCODE (tag), name, -1, 0, 1},
 

src/vm_loader.c

@@ -159,22 +159,30 @@ VM_DEFINE_LOADER (load_program, "load-program")
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (link, "link", 0, 1, 1)
+VM_DEFINE_LOADER (link, "link")
 {
+  SCM sym;
+  size_t len;
+
+  FETCH_LENGTH (len);
+  sym = scm_mem2symbol (ip, len);
+  ip += len;
+
 #if 0
-  sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1);
+  *sp = scm_c_env_vcell (*sp, sym, 1);
-  sp--;
 #endif
+  {
     /* Temporary hack that supports the current module system */
     SCM mod = scm_current_module ();
     SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
-				     *sp, SCM_BOOL_F);
+				       sym, SCM_BOOL_F);
     if (SCM_FALSEP (var))
       /* Create a new variable if not defined yet */
       var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
-				   *sp, SCM_BOOL_T);
+				     sym, SCM_BOOL_T);
-  *sp = SCM_VARVCELL (var);
+    PUSH (SCM_VARVCELL (var));
     NEXT;
+  }
 }
 
 /*

src/vm_scheme.c

@@ -158,20 +158,6 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
   RETURN (SCM_UNSPECIFIED);
 }
 
-VM_DEFINE_FUNCTION (list, "list", -1)
-{
-  ARGSN (n);
-  POP_LIST (n);
-  NEXT;
-}
-
-VM_DEFINE_FUNCTION (vector, "vector", -1)
-{
-  ARGSN (n);
-  POP_LIST (n);
-  RETURN (scm_vector (*sp));
-}
-
 
 /*
  * Numeric relational tests

src/vm_system.c

@@ -68,6 +68,12 @@ VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
+{
+  PUSH (SCM_UNDEFINED);
+  NEXT;
+}
+
 VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
 {
   SCM x = *sp;
@@ -136,6 +142,43 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (list, "list", 1, -1, 1)
+{
+  int n = FETCH ();
+  POP_LIST (n);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector, "vector", 1, -1, 1)
+{
+  int n = FETCH ();
+  POP_LIST (n);
+  *sp = scm_vector (*sp);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
+{
+  POP_LIST_MARK ();
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
+{
+  POP_LIST_MARK ();
+  *sp = scm_vector (*sp);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
+{
+  SCM l;
+  POP (l);
+  for (; !SCM_NULLP (l); l = SCM_CDR (l))
+    PUSH (SCM_CAR (l));
+  NEXT;
+}
+
 
 /*
  * Variable access
@@ -180,7 +223,6 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
   SCM o = VARIABLE_REF (x);
   if (SCM_UNBNDP (o))
     {
-      /* Try autoload here */
       err_args = SCM_LIST1 (SCM_CAR (x));
       goto vm_error_unbound;
     }