*** empty log message ***

.cvsignore

@@ -1,7 +1,7 @@
-misc
 libtool
 config.*
 configure
 Makefile
 Makefile.in
 aclocal.m4
+misc

configure.in

@@ -12,4 +12,15 @@ AC_PROG_LN_S
 AM_PROG_LIBTOOL
 AC_C_LABELS_AS_VALUES
 
-AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile)
+guiledir="\$(datadir)/guile"
+AC_SUBST(guiledir)
+
+GUILEC="GUILE_LOAD_PATH=\$(top_srcdir)/module \
+  LD_LIBRARY_PATH=\$(top_srcdir)/src/.libs \
+  guile -s \$(top_srcdir)/src/guilec"
+AC_SUBST(GUILEC)
+
+AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile
+  module/system/Makefile module/system/base/Makefile
+  module/system/vm/Makefile module/system/il/Makefile
+  module/system/repl/Makefile)

module/Makefile.am

@@ -1,3 +1,5 @@
+SUBDIRS = system
+
 DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib
 EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~
 

module/language/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/elisp/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/ghil/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/r5rs/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/scheme/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/scheme/translate.scm

@@ -29,7 +29,7 @@
 (define (translate x e)
   (call-with-ghil-environment (make-ghil-mod e) '()
     (lambda (env vars)
-      (make-<ghil-lambda> env #f vars 0 (trans env #f x)))))
+      (<ghil-lambda> env #f vars #f (trans env #f x)))))
 
 
 ;;;
@@ -46,25 +46,25 @@
 	     (trans-pair e (or (location x) l) (car x) (cdr x))
 	     (trans e l y))))
 	((symbol? x)
-	 (let ((y (expand-symbol x)))
+	 (let ((y (symbol-expand x)))
-	   (if (eq? x y)
+	   (if (symbol? y)
-	       (make-<ghil-ref> e l (ghil-lookup e x))
+	     (<ghil-ref> e l (ghil-lookup e y))
 	     (trans e l y))))
-	(else (make-<ghil-quote> e l x))))
+	(else (<ghil-quote> e l x))))
 
-(define (expand-symbol x)
+(define (symbol-expand x)
   (let loop ((s (symbol->string x)))
     (let ((i (string-rindex s #\.)))
       (if i
-	  `(slot ,(loop (substring s 0 i))
+	(let ((sym (string->symbol (substring s (1+ i)))))
-		 (quote ,(string->symbol (substring s (1+ i)))))
+	  `(slot ,(loop (substring s 0 i)) (quote ,sym)))
 	(string->symbol s)))))
 
 (define (trans-pair e l head tail)
   (define (trans:x x) (trans e l x))
   (define (trans:pair x) (trans-pair e l (car x) (cdr x)))
   (define (trans:body body) (trans-body e l body))
-  (define (make:void) (make-<ghil-void> e l))
+  (define (make:void) (<ghil-void> e l))
   (define (bad-syntax)
     (syntax-error l (format #f "bad ~A" head) (cons head tail)))
   (case head
@@ -77,26 +77,26 @@
     ;; (quote OBJ)
     ((quote)
      (match tail
-       ((obj) (make-<ghil-quote> e l obj))
+       ((obj) (<ghil-quote> e l obj))
        (else (bad-syntax))))
 
     ;; (quasiquote OBJ)
     ((quasiquote)
      (match tail
-       ((obj) (make-<ghil-quasiquote> e l (trans-quasiquote e l obj)))
+       ((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj)))
        (else (bad-syntax))))
 
     ((define define-private)
      (match tail
        ;; (define NAME VAL)
        (((? symbol? name) val)
-	(make-<ghil-define> e l (ghil-lookup e name) (trans:x val)))
+	(<ghil-define> e l (ghil-lookup e name) (trans:x val)))
 
        ;; (define (NAME FORMALS...) BODY...)
        ((((? symbol? name) . formals) . body)
 	;; -> (define NAME (lambda FORMALS BODY...))
 	(let ((val (trans:x `(lambda ,formals ,@body))))
-	  (make-<ghil-define> e l (ghil-lookup e name) val)))
+	  (<ghil-define> e l (ghil-lookup e name) val)))
 
        (else (bad-syntax))))
 
@@ -104,7 +104,7 @@
      (match tail
        ;; (set! NAME VAL)
        (((? symbol? name) val)
-	(make-<ghil-set> e l (ghil-lookup e name) (trans:x val)))
+	(<ghil-set> e l (ghil-lookup e name) (trans:x val)))
 
        ;; (set! (NAME ARGS...) VAL)
        ((((? symbol? name) . args) val)
@@ -117,22 +117,22 @@
     ((if)
      (match tail
        ((test then)
-	(make-<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
+	(<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
        ((test then else)
-	(make-<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
+	(<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
        (else (bad-syntax))))
 
     ;; (and EXPS...)
     ((and)
-     (make-<ghil-and> e l (map trans:x tail)))
+     (<ghil-and> e l (map trans:x tail)))
 
     ;; (or EXPS...)
     ((or)
-     (make-<ghil-or> e l (map trans:x tail)))
+     (<ghil-or> e l (map trans:x tail)))
 
     ;; (begin EXPS...)
     ((begin)
-     (make-<ghil-begin> e l (map trans:x tail)))
+     (<ghil-begin> e l (map trans:x tail)))
 
     ((let)
      (match tail
@@ -144,14 +144,14 @@
        ;; (let () BODY...)
        ((() body ...)
 	;; NOTE: This differs from `begin'
-	(make-<ghil-begin> e l (list (trans:body body))))
+	(<ghil-begin> e l (list (trans:body body))))
 
        ;; (let ((SYM VAL) ...) BODY...)
        (((((? symbol? sym) val) ...) body ...)
 	(let ((vals (map trans:x val)))
 	  (call-with-ghil-bindings e sym
 	    (lambda (vars)
-	      (make-<ghil-bind> e l vars vals (trans:body body))))))
+	      (<ghil-bind> e l vars vals (trans:body body))))))
 
        (else (bad-syntax))))
 
@@ -171,7 +171,7 @@
 	(call-with-ghil-bindings e sym
 	  (lambda (vars)
 	    (let ((vals (map trans:x val)))
-	      (make-<ghil-bind> e l vars vals (trans:body body))))))
+	      (<ghil-bind> e l vars vals (trans:body body))))))
        (else (bad-syntax))))
 
     ;; (cond (CLAUSE BODY...) ...)
@@ -222,7 +222,7 @@
 	(receive (syms rest) (parse-formals formals)
 	  (call-with-ghil-environment e syms
 	    (lambda (env vars)
-	      (make-<ghil-lambda> env l vars rest (trans-body env l body))))))
+	      (<ghil-lambda> env l vars rest (trans-body env l body))))))
        (else (bad-syntax))))
 
     ((eval-case)
@@ -240,8 +240,8 @@
 
     (else
      (if (memq head scheme-primitives)
-	 (make-<ghil-inline> e l head (map trans:x tail))
+       (<ghil-inline> e l head (map trans:x tail))
-	 (make-<ghil-call> e l (trans:x head) (map trans:x tail))))))
+       (<ghil-call> e l (trans:x head) (map trans:x tail))))))
 
 (define (trans-quasiquote e l x)
   (cond ((not (pair? x)) x)
@@ -250,8 +250,8 @@
 	   (match (cdr x)
 	     ((obj)
 	      (if (eq? (car x) 'unquote)
-		  (make-<ghil-unquote> e l (trans e l obj))
+		  (<ghil-unquote> e l (trans e l obj))
-		  (make-<ghil-unquote-splicing> e l (trans e l obj))))
+		  (<ghil-unquote-splicing> e l (trans e l obj))))
 	     (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 	(else (cons (trans-quasiquote e l (car x))
 		    (trans-quasiquote e l (cdr x))))))

module/system/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/system/Makefile.am

@@ -0,0 +1 @@
+SUBDIRS = vm

module/system/base/.cvsignore

@@ -1 +1,3 @@
+Makefile
+Makefile.in
 *.go

module/system/base/Makefile.am

@@ -0,0 +1,12 @@
+SOURCES = syntax.scm language.scm compile.scm
+OBJECTS = syntax.go  language.go  compile.go
+
+vmdir = $(guiledir)/system/vm
+vm_DATA = $(SOURCES) $(OBJECTS)
+
+DISTCLEANFILES = $(OBJECTS)
+MAINTAINERCLEANFILES = Makefile.in
+
+SUFFIXES = .scm .go
+.scm.go:
+	$(GUILEC) $<

module/system/base/compile.scm

@@ -20,10 +20,10 @@
 ;;; Code:
 
 (define-module (system base compile)
-  :use-module (oop goops)
   :use-syntax (system base syntax)
   :use-module (system base language)
   :use-module (system il compile)
+  :use-module (system il glil)
   :use-module (system vm core)
   :use-module (system vm assemble)
   :use-module (ice-9 regex))
@@ -32,19 +32,17 @@
 ;;; Compiler environment
 ;;;
 
-(define-vm-class <cenv> ()
+(define-record (<cenv> vm language module))
-  vm language module optimize)
 
 (define-public (make-cenv . rest)
-  (apply make <cenv> rest))
+  (apply <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
+  (try (thunk)
-    thunk
+    ((syntax-error loc msg exp)
-    (lambda (key loc msg exp)
      (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp))))
 
 
@@ -65,7 +63,9 @@
 	       (let* ((source (read-file-in file scheme))
 		      (objcode (apply compile-in source (current-module)
 				      scheme opts)))
-		 (uniform-array-write (objcode->string objcode) port))))
+		 (if (memq :c opts)
+		   (pprint-glil objcode port)
+		   (uniform-array-write (objcode->string objcode) port)))))
 	   (format #t "Wrote ~A\n" comp))))
       (lambda (key . args)
 	(format #t "ERROR: During compiling ~A:\n" file)

module/system/base/language.scm

@@ -20,7 +20,6 @@
 ;;; Code:
 
 (define-module (system base language)
-  :use-module (oop goops)
   :use-syntax (system base syntax)
   :export (define-language lookup-language))
 
@@ -29,21 +28,15 @@
 ;;; Language class
 ;;;
 
-(define-vm-class <language> ()
+(define-record (<language> name title version reader printer read-file
-  name title version environment
-  reader printer read-file
 			   (expander (lambda (x e) x))
 			   (translator (lambda (x e) x))
 			   (evaluator #f)
-  )
+			   (environment #f)
-
+			   ))
-(define-method (write (lang <language>) port)
-  (display "#<language " port)
-  (display lang.name port)
-  (display ">"))
 
 (define-macro (define-language name . spec)
-  `(define ,name (,make ,<language> :name ',name ,@spec)))
+  `(define ,name (,<language> :name ',name ,@spec)))
 
 (define (lookup-language name)
   (let ((m (resolve-module `(language ,name spec))))

module/system/base/syntax.scm

@@ -1,34 +1,34 @@
 ;;; Guile VM specific syntaxes and utilities
 
-;; Copyright (C) 2001 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
 ;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; 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.
+;; 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.
+;; Boston, MA 02111-1307, USA
 
 ;;; Code:
 
 (define-module (system base syntax)
-  :use-module (oop goops)
+  :use-module (ice-9 try)
   :use-module (ice-9 match)
   :use-module (ice-9 receive)
   :use-module (ice-9 and-let-star)
-  :export (match syntax-error and-let* receive))
+  :export (try stack-catch match syntax-error receive and-let*))
 
 
 ;;;
-;;; Keywords by `:KEYWORD'
+;;; Keywords by `:KEYWORD
 ;;;
 
 (read-set! keywords 'prefix)
@@ -41,9 +41,9 @@
 ;; FOO.BAR -> (slot FOO 'BAR)
 
 (define (expand-dot! x)
-  (cond ((and (symbol? x) (not (eq? x '...))) (expand-symbol x))
+  (cond ((symbol? x) (expand-symbol x))
 	((pair? x)
-	 (cond ((memq (car x) '(quote quasiquote)) x)
+	 (cond ((eq? (car x) 'quote) x)
 	       (else (set-car! x (expand-dot! (car x)))
 		     (set-cdr! x (expand-dot! (cdr x)))
 		     x)))
@@ -57,39 +57,110 @@
 		 (quote ,(string->symbol (substring s (1+ i)))))
 	  (string->symbol s)))))
 
-(define syntax expand-dot!)
 (export-syntax syntax)
-
+(define syntax expand-dot!)
-;; slot accessor
-(define slot (make-procedure-with-setter slot-ref slot-set!))
-(export slot)
 
 
 ;;;
-;;; Simplified define-class
+;;; Type
 ;;;
 
-;; (define-vm-class <foo> () (x 1) (y 2)) =>
+(export-syntax define-type)
-;; 
+(define-macro (define-type name sig) sig)
-;;   (define-class <foo> ()
-;;     (a :init-keyword :a :init-form 1)
-;;     (b :init-keyword :b :init-form 2))
-
-(define-macro (define-vm-class name supers . rest)
-  `(define-class ,name ,supers
-     ,@(map (lambda (def)
-	      (if (not (pair? def)) (set! def (list def)))
-	      (let ((name (car def)) (rest (cdr def)))
-		(cons* name :init-keyword (symbol->keyword name)
-		       (if (or (null? rest) (keyword? (car rest)))
-			   rest
-			   (cons :init-form rest)))))
-	    rest)))
-
-(export-syntax define-vm-class)
 
 ;;;
-;;; Other utilities
+;;; Record
+;;;
+
+(export-syntax define-record)
+(define-macro (define-record def)
+  (let ((name (car def)) (slots (cdr def)))
+    `(begin
+       (define (,name . args)
+	 (vector ',name (%make-struct
+			 args
+			 (list ,@(map (lambda (slot)
+					(if (pair? slot)
+					  `(cons ',(car slot) ,(cadr slot))
+					  `',slot))
+				      slots)))))
+       (define (,(symbol-append name '?) x)
+	 (and (vector? x) (eq? (vector-ref x 0) ',name)))
+       ,@(do ((n 1 (1+ n))
+	      (slots (cdr def) (cdr slots))
+	      (ls '() (cons (let* ((slot (car slots))
+				   (slot (if (pair? slot) (car slot) slot)))
+			      `(define ,(string->symbol
+					 (format #f "~A-~A" name n))
+				 (lambda (x) (slot x ',slot))))
+			    ls)))
+	     ((null? slots) (reverse! ls))))))
+
+(define *unbound* "#<unbound>")
+
+(define-public (%make-struct args slots)
+  (map (lambda (slot)
+	 (let* ((key (if (pair? slot) (car slot) slot))
+		(def (if (pair? slot) (cdr slot) *unbound*))
+		(val (get-key args (symbol->keyword key) def)))
+	   (if (eq? val *unbound*)
+	     (error "Slot unbound:" key)
+	     (cons key val))))
+       slots))
+
+(define (get-key klist key def)
+  (do ((ls klist (cddr ls)))
+      ((or (null? ls) (eq? (car ls) key))
+       (if (null? ls) def (cadr ls)))))
+
+(define-public slot
+  (make-procedure-with-setter
+   (lambda (struct name)
+     (let ((data (assq name (vector-ref struct 1))))
+       (cond ((not data)
+	      (error "Unknown slot:" name))
+	     (else (cdr data)))))
+   (lambda (struct name val)
+     (let ((data (assq name (vector-ref struct 1))))
+       (cond ((not data)
+	      (error "Unknown slot:" name))
+	     (else (set-cdr! data val)))))))
+
+;;;
+;;; Variants
+;;;
+
+(export-syntax |)
+(define-macro (| . rest)
+  `(begin ,@(map %make-variant-type rest)))
+
+(define (%make-variant-type def)
+  (let ((name (car def)) (slots (cdr def)))
+    `(begin
+       (define ,def (vector ',name ,@slots))
+       (define (,(symbol-append name '?) x)
+	 (and (vector? x) (eq? (vector-ref x 0) ',name)))
+       ,@(do ((n 1 (1+ n))
+	      (slots slots (cdr slots))
+	      (ls '() (cons `(define ,(string->symbol
+				       (format #f "~A-~A" name n))
+			       ,(string->symbol (format #f "%slot-~A" n)))
+			    ls)))
+	     ((null? slots) (reverse! ls))))))
+
+(define-public (%slot-1 x) (vector-ref x 1))
+(define-public (%slot-2 x) (vector-ref x 2))
+(define-public (%slot-3 x) (vector-ref x 3))
+(define-public (%slot-4 x) (vector-ref x 4))
+(define-public (%slot-5 x) (vector-ref x 5))
+(define-public (%slot-6 x) (vector-ref x 6))
+(define-public (%slot-7 x) (vector-ref x 7))
+(define-public (%slot-8 x) (vector-ref x 8))
+(define-public (%slot-9 x) (vector-ref x 9))
+
+
+;;;
+;;; Utilities
 ;;;
 
 (define-public (list-fold f d l)

module/system/il/.cvsignore

@@ -1 +1,3 @@
+Makefile
+Makefile.in
 *.go

module/system/il/Makefile.am

@@ -0,0 +1,12 @@
+SOURCES = glil.scm ghil.scm macros.scm compile.scm
+OBJECTS = glil.go  ghil.go  macros.go  compile.go
+
+vmdir = $(guiledir)/system/il
+vm_DATA = $(SOURCES) $(OBJECTS)
+
+DISTCLEANFILES = $(OBJECTS)
+MAINTAINERCLEANFILES = Makefile.in
+
+SUFFIXES = .scm .go
+.scm.go:
+	$(GUILEC) $<

module/system/il/compile.scm

@@ -20,7 +20,6 @@
 ;;; Code:
 
 (define-module (system il compile)
-  :use-module (oop goops)
   :use-syntax (system base syntax)
   :use-module (system il glil)
   :use-module (system il ghil)
@@ -40,22 +39,22 @@
 (define (optimize x)
   (match x
     (($ <ghil-set> env var val)
-     (make-<ghil-set> env var (optimize val)))
+     (<ghil-set> env var (optimize val)))
 
     (($ <ghil-if> test then else)
-     (make-<ghil-if> (optimize test) (optimize then) (optimize else)))
+     (<ghil-if> (optimize test) (optimize then) (optimize else)))
 
     (($ <ghil-begin> exps)
-     (make-<ghil-begin> (map optimize exps)))
+     (<ghil-begin> (map optimize exps)))
 
     (($ <ghil-bind> env vars vals body)
-     (make-<ghil-bind> env vars (map optimize vals) (optimize body)))
+     (<ghil-bind> env vars (map optimize vals) (optimize body)))
 
     (($ <ghil-lambda> env vars rest body)
-     (make-<ghil-lambda> env vars rest (optimize body)))
+     (<ghil-lambda> env vars rest (optimize body)))
 
     (($ <ghil-inst> inst args)
-     (make-<ghil-inst> inst (map optimize args)))
+     (<ghil-inst> inst (map optimize args)))
 
     (($ <ghil-call> env proc args)
      (match proc
@@ -67,9 +66,9 @@
 		    (set! v.env env)
 		    (ghil-env-add! env v))
 		  lambda-env.variables)
-	(optimize (make-<ghil-bind> env vars args body)))
+	(optimize (<ghil-bind> env vars args body)))
        (else
-	(make-<ghil-call> env (optimize proc) (map optimize args)))))
+	(<ghil-call> env (optimize proc) (map optimize args)))))
     (else x)))
 
 
@@ -77,25 +76,25 @@
 ;;; Stage 3: Code generation
 ;;;
 
-(define *ia-void* (make-<glil-void>))
+(define *ia-void* (<glil-void>))
-(define *ia-drop* (make-<glil-call> 'drop 0))
+(define *ia-drop* (<glil-call> 'drop 0))
-(define *ia-return* (make-<glil-call> 'return 0))
+(define *ia-return* (<glil-call> 'return 0))
 
 (define (make-label) (gensym ":L"))
 
 (define (make-glil-var op env var)
   (case var.kind
     ((argument)
-     (make-<glil-argument> op var.index))
+     (<glil-argument> op var.index))
     ((local)
-     (make-<glil-local> op var.index))
+     (<glil-local> op var.index))
     ((external)
      (do ((depth 0 (1+ depth))
 	  (e env e.parent))
 	 ((eq? e var.env)
-	  (make-<glil-external> op depth var.index))))
+	  (<glil-external> op depth var.index))))
     ((module)
-     (make-<glil-module> op var.env var.name))
+     (<glil-module> op var.env var.name))
     (else (error "Unknown kind of variable:" var))))
 
 (define (codegen ghil)
@@ -104,12 +103,13 @@
       (set! stack (cons code stack)))
     (define (comp tree tail drop)
       (define (push-label! label)
-	(push-code! (make-<glil-label> label)))
+	(push-code! (<glil-label> label)))
       (define (push-branch! inst label)
-	(push-code! (make-<glil-branch> inst label)))
+	(push-code! (<glil-branch> inst label)))
-      (define (push-call! inst args)
+      (define (push-call! loc inst args)
 	(for-each comp-push args)
-	(push-code! (make-<glil-call> inst (length args))))
+	(push-code! (<glil-call> inst (length args)))
+	(push-code! (<glil-source> loc)))
       ;; possible tail position
       (define (comp-tail tree) (comp tree tail drop))
       ;; push the result
@@ -131,7 +131,7 @@
 	(return-code! *ia-void*))
       ;; return object if necessary
       (define (return-object! obj)
-	(return-code! (make-<glil-const> obj)))
+	(return-code! (<glil-const> obj)))
       ;;
       ;; dispatch
       (match tree
@@ -145,28 +145,32 @@
 	 (let loop ((x exp))
 	   (match x
 	     ((? list? ls)
-	      (push-call! 'mark '())
+	      (push-call! #f 'mark '())
 	      (for-each loop ls)
-	      (push-call! 'list-mark '()))
+	      (push-call! #f 'list-mark '()))
 	     ((? pair? pp)
 	      (loop (car pp))
 	      (loop (cdr pp))
-	      (push-code! (make-<glil-call> 'cons 2)))
+	      (push-code! (<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 '()))
+	      (push-call! #f 'list-break '()))
 	     (else
-	      (push-code! (make-<glil-const> x)))))
+	      (push-code! (<glil-const> x)))))
 	 (maybe-drop)
 	 (maybe-return))
 
 	(($ <ghil-ref> env loc var)
 	 (return-code! (make-glil-var 'ref env var)))
 
-	((or ($ <ghil-set> env loc var val)
+	(($ <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-define> env loc var val)
 	 (comp-push val)
 	 (push-code! (make-glil-var 'set env var))
 	 (return-void!))
@@ -228,9 +232,9 @@
 		    (maybe-drop)
 		    (maybe-return))
 		 (comp-push (car exps))
-		 (push-call! 'dup '())
+		 (push-call! #f 'dup '())
 		 (push-branch! 'br-if L1)
-		 (push-call! 'drop '())))))
+		 (push-call! #f 'drop '())))))
 
 	(($ <ghil-begin> env loc exps)
 	 ;; EXPS...
@@ -249,7 +253,10 @@
 	 (for-each comp-push vals)
 	 (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
 		   (reverse vars))
-	 (comp-tail body))
+	 (let ((vars (map (lambda (v) (list v.name v.kind v.index)) vars)))
+	   (if (not (null? vars)) (push-code! (<glil-bind> vars))))
+	 (comp-tail body)
+	 (push-code! (<glil-unbind>)))
 
 	(($ <ghil-lambda> env loc vars rest body)
 	 (return-code! (codegen tree)))
@@ -257,7 +264,7 @@
 	(($ <ghil-inline> env loc inst args)
 	 ;; ARGS...
 	 ;; (INST NARGS)
-	 (push-call! inst args)
+	 (push-call! loc inst args)
 	 (maybe-drop)
 	 (maybe-return))
 
@@ -266,7 +273,7 @@
 	 ;; ARGS...
 	 ;; ([tail-]call NARGS)
 	 (comp-push proc)
-	 (push-call! (if tail 'tail-call 'call) args)
+	 (push-call! loc (if tail 'tail-call 'call) args)
 	 (maybe-drop))))
     ;;
     ;; main
@@ -279,19 +286,25 @@
 	 (finalize-index! args)
 	 (finalize-index! locs)
 	 (finalize-index! exts)
+	 ;; meta bindings
+	 (let ((vars (map (lambda (v) (list v.name v.kind v.index)) args)))
+	   (if (not (null? vars)) (push-code! (<glil-bind> vars))))
 	 ;; export arguments
 	 (do ((n 0 (1+ n))
 	      (l args (cdr l)))
 	     ((null? l))
 	   (let ((v (car l)))
-	     (if (eq? v.kind 'external)
+	     (cond ((eq? v.kind 'external)
-		 (begin (push-code! (make-<glil-argument> 'ref n))
+		    (push-code! (<glil-argument> 'ref n))
-			(push-code! (make-<glil-external> 'set 0 v.index))))))
+		    (push-code! (<glil-external> 'set 0 v.index))))))
 	 ;; compile body
 	 (comp body #t #f)
 	 ;; create GLIL
-	 (make-<glil-asm> (length args) (if rest 1 0) (length locs)
+	 (let ((vars (<glil-vars> :nargs (length args)
-			  (length exts) (reverse! stack)))))))
+				  :nrest (if rest 1 0)
+				  :nlocs (length locs)
+				  :nexts (length exts))))
+	   (<glil-asm> vars (reverse! stack))))))))
 
 (define (finalize-index! list)
   (do ((n 0 (1+ n))

module/system/il/ghil.scm

@@ -20,42 +20,38 @@
 ;;; Code:
 
 (define-module (system il ghil)
-  :use-module (oop goops)
   :use-syntax (system base syntax)
   :use-module (ice-9 match)
   :use-module (ice-9 regex)
   :export
-  (parse-ghil
+  (
-   ghil-lookup ghil-primitive?
+   <ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
-   make-<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
+   <ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
-   make-<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
+   <ghil-quasiquote> <ghil-quasiquote>?
-   make-<ghil-quasiquote> <ghil-quasiquote>?
    <ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
-   make-<ghil-unquote> <ghil-unquote>?
+   <ghil-unquote> <ghil-unquote>?
    <ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
-   make-<ghil-unquote-splicing> <ghil-unquote-splicing>?
+   <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> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
-   <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
+   <ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
-   make-<ghil-set> <ghil-set>?
+   <ghil-define> <ghil-define>?
-   <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> <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
+   <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
+   <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
+   <ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
-   make-<ghil-bind> <ghil-bind>?
+   <ghil-bind> <ghil-bind>?
    <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
-   make-<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
+   <ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
    <ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
-   make-<ghil-inline> <ghil-inline>?
+   <ghil-inline> <ghil-inline>?
    <ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
-   make-<ghil-call> <ghil-call>?
+   <ghil-call> <ghil-call>?
    <ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
    ))
 
@@ -64,27 +60,30 @@
 ;;; Parse tree
 ;;;
 
-(define-structure (<ghil-void> env loc))
+(define-type <ghil>
-(define-structure (<ghil-quote> env loc obj))
+  (|
-(define-structure (<ghil-quasiquote> env loc exp))
+   ;; Objects
-(define-structure (<ghil-unquote> env loc exp))
+   (<ghil-void> env loc)
-(define-structure (<ghil-unquote-splicing> env loc exp))
+   (<ghil-quote> env loc obj)
+   (<ghil-quasiquote> env loc exp)
+   (<ghil-unquote> env loc exp)
+   (<ghil-unquote-splicing> env loc exp)
+   ;; Variables
+   (<ghil-ref> env loc var)
+   (<ghil-set> env loc var val)
+   (<ghil-define> env loc var val)
+   ;; Controls
+   (<ghil-if> env loc test then else)
+   (<ghil-and> env loc exps)
+   (<ghil-or> env loc exps)
+   (<ghil-begin> env loc exps)
+   (<ghil-bind> env loc vars vals body)
+   (<ghil-lambda> env loc vars rest body)
+   (<ghil-call> env loc proc args)
+   (<ghil-inline> env loc inline args)))
 
-(define-structure (<ghil-ref> env loc var))
+(define-public ghil-env %slot-1)
-(define-structure (<ghil-set> env loc var val))
+(define-public ghil-loc %slot-2)
-(define-structure (<ghil-define> env loc var val))
-
-(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))
 
 
 ;;;
@@ -96,7 +95,7 @@
 
 (define *macro-module* (resolve-module '(system il macros)))
 
-(define (ghil-primitive-macro? x)
+(define-public (ghil-primitive-macro? x)
   (and (module-defined? *macro-module* x)
        (procedure? (module-ref *macro-module* x))))
 
@@ -112,78 +111,59 @@
 ;;; Variables
 ;;;
 
-(define-vm-class <ghil-var> ()
+(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
-  env name kind type value index)
 
 (define-public (make-ghil-var env name kind)
-  (make <ghil-var> :env env :name name :kind kind))
+  (<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
 ;;;
 
-(define-vm-class <ghil-mod> ()
+(define-record (<ghil-mod> module (table '()) (imports '())))
-  (module)
-  (table '())
-  (imports '()))
 
 (define-public (make-ghil-mod module)
-  (make <ghil-mod> :module module))
+  (<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)))
-      (let ((var (make-ghil-var #f sym 'module)))
-	(set! mod.table (acons sym var mod.table))
-	var)))
 
 
 ;;;
 ;;; Environments
 ;;;
 
-(define-vm-class <ghil-env> ()
+(define-record (<ghil-env> mod parent (table '()) (variables '())))
-  (mod)
-  (parent #f)
-  (table '())
-  (variables '()))
 
-(export make-ghil-env)
+(define-public (make-ghil-env e)
-(define-method (make-ghil-env (m <ghil-mod>))
+  (match e
-  (make <ghil-env> :mod m :parent m))
+    (($ <ghil-mod>) (<ghil-env> :mod e :parent e))
-
+    (($ <ghil-env> m) (<ghil-env> :mod m :parent e))))
-(define-method (make-ghil-env (e <ghil-env>))
-  (make <ghil-env> :mod e.mod :parent e))
 
 (define (ghil-env-toplevel? e)
   (eq? e.mod e.parent))
 
-(define-method (ghil-env-ref (env <ghil-env>) (sym <symbol>))
+(define (ghil-env-ref env sym)
   (assq-ref env.table sym))
 
-(export ghil-env-add!)
+(define-public (ghil-env-add! env var)
-(define-method (ghil-env-add! (env <ghil-env>) (var <ghil-var>))
   (set! env.table (acons var.name var env.table))
   (set! env.variables (cons var env.variables)))
 
-(define-method (ghil-env-remove! (env <ghil-env>) (var <ghil-var>))
+(define (ghil-env-remove! env var)
   (set! env.table (assq-remove! env.table var.name)))
 
-(define-method (ghil-lookup (env <ghil-env>) (sym <symbol>))
+
+;;;
+;;; Public interface
+;;;
+
+(define-public (ghil-lookup env sym)
   (or (ghil-env-ref env sym)
       (let loop ((e env.parent))
-	(cond ((is-a? e <ghil-mod>) (ghil-lookup e sym))
+	(cond ((<ghil-mod>? e)
+	       (or (assq-ref e.table sym)
+		   (let ((var (make-ghil-var #f sym 'module)))
+		     (set! e.table (acons sym var e.table))
+		     var)))
 	      ((ghil-env-ref e sym) =>
 	       (lambda (var) (set! var.kind 'external) var))
 	      (else (loop e.parent))))))
@@ -210,156 +190,156 @@
 ;;; Parser
 ;;;
 
-(define (parse-ghil x e)
+;;; (define-public (parse-ghil x e)
-  (parse `(@lambda () ,x) (make-ghil-mod e)))
+;;;   (parse `(@lambda () ,x) (make-ghil-mod e)))
-
+;;; 
-(define (parse x e)
+;;; (define (parse x e)
-  (cond ((pair? x) (parse-pair x e))
+;;;   (cond ((pair? x) (parse-pair x e))
-	((symbol? x)
+;;; 	((symbol? x)
-	 (let ((str (symbol->string x)))
+;;; 	 (let ((str (symbol->string x)))
-	   (case (string-ref str 0)
+;;; 	   (case (string-ref str 0)
-	     ((#\@) (error "Invalid use of IL primitive" x))
+;;; 	     ((#\@) (error "Invalid use of IL primitive" x))
-	     ((#\:) (let ((sym (string->symbol (substring str 1))))
+;;; 	     ((#\:) (let ((sym (string->symbol (substring str 1))))
-		      (make-<ghil-quote> (symbol->keyword sym))))
+;;; 		      (<ghil-quote> (symbol->keyword sym))))
-	     (else (make-<ghil-ref> e (ghil-lookup e x))))))
+;;; 	     (else (<ghil-ref> e (ghil-lookup e x))))))
-	(else (make-<ghil-quote> x))))
+;;; 	(else (<ghil-quote> x))))
-
+;;; 
-(define (map-parse x e)
+;;; (define (map-parse x e)
-  (map (lambda (x) (parse x e)) x))
+;;;   (map (lambda (x) (parse x e)) x))
-
+;;; 
-(define (parse-pair x e)
+;;; (define (parse-pair x e)
-  (let ((head (car x)) (tail (cdr x)))
+;;;   (let ((head (car x)) (tail (cdr x)))
-    (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
+;;;     (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
-	(if (ghil-primitive-macro? head)
+;;; 	(if (ghil-primitive-macro? head)
-	    (parse (apply (ghil-macro-expander head) tail) e)
+;;; 	    (parse (apply (ghil-macro-expander head) tail) e)
-	    (parse-primitive head tail e))
+;;; 	    (parse-primitive head tail e))
-	(make-<ghil-call> e (parse head e) (map-parse tail e)))))
+;;; 	(<ghil-call> e (parse head e) (map-parse tail e)))))
-
+;;; 
-(define (parse-primitive prim args e)
+;;; (define (parse-primitive prim args e)
-  (case prim
+;;;   (case prim
-    ;; (@ IDENTIFIER)
+;;;     ;; (@ IDENTIFIER)
-    ((@)
+;;;     ((@)
-     (match args
+;;;      (match args
-       (()
+;;;        (()
-	(make-<ghil-ref> e (make-ghil-var '@ '@ 'module)))
+;;; 	(<ghil-ref> e (make-ghil-var '@ '@ 'module)))
-       ((identifier)
+;;;        ((identifier)
-	(receive (module name) (identifier-split identifier)
+;;; 	(receive (module name) (identifier-split identifier)
-	  (make-<ghil-ref> e (make-ghil-var module name 'module))))))
+;;; 	  (<ghil-ref> e (make-ghil-var module name 'module))))))
-
+;;; 
-    ;; (@@ OP ARGS...)
+;;;     ;; (@@ OP ARGS...)
-    ((@@)
+;;;     ((@@)
-     (match args
+;;;      (match args
-       ((op . args)
+;;;        ((op . args)
-	(make-<ghil-inline> op (map-parse args e)))))
+;;; 	(<ghil-inline> op (map-parse args e)))))
-
+;;; 
-    ;; (@void)
+;;;     ;; (@void)
-    ((@void)
+;;;     ((@void)
-     (match args
+;;;      (match args
-       (() (make-<ghil-void>))))
+;;;        (() (<ghil-void>))))
-
+;;; 
-    ;; (@quote OBJ)
+;;;     ;; (@quote OBJ)
-    ((@quote)
+;;;     ((@quote)
-     (match args
+;;;      (match args
-       ((obj)
+;;;        ((obj)
-	(make-<ghil-quote> obj))))
+;;; 	(<ghil-quote> obj))))
-
+;;; 
-    ;; (@define NAME VAL)
+;;;     ;; (@define NAME VAL)
-    ((@define)
+;;;     ((@define)
-     (match args
+;;;      (match args
-       ((name val)
+;;;        ((name val)
-	(let ((v (ghil-lookup e name)))
+;;; 	(let ((v (ghil-lookup e name)))
-	  (make-<ghil-set> e v (parse val e))))))
+;;; 	  (<ghil-set> e v (parse val e))))))
-
+;;; 
-    ;; (@set! NAME VAL)
+;;;     ;; (@set! NAME VAL)
-    ((@set!)
+;;;     ((@set!)
-     (match args
+;;;      (match args
-       ((name val)
+;;;        ((name val)
-	(let ((v (ghil-lookup e name)))
+;;; 	(let ((v (ghil-lookup e name)))
-	  (make-<ghil-set> e v (parse val e))))))
+;;; 	  (<ghil-set> e v (parse val e))))))
-
+;;; 
-    ;; (@if TEST THEN [ELSE])
+;;;     ;; (@if TEST THEN [ELSE])
-    ((@if)
+;;;     ((@if)
-     (match args
+;;;      (match args
-       ((test then)
+;;;        ((test then)
-	(make-<ghil-if> (parse test e) (parse then e) (make-<ghil-void>)))
+;;; 	(<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
-       ((test then else)
+;;;        ((test then else)
-	(make-<ghil-if> (parse test e) (parse then e) (parse else e)))))
+;;; 	(<ghil-if> (parse test e) (parse then e) (parse else e)))))
-
+;;; 
-    ;; (@begin BODY...)
+;;;     ;; (@begin BODY...)
-    ((@begin)
+;;;     ((@begin)
-     (parse-body args e))
+;;;      (parse-body args e))
-
+;;; 
-    ;; (@let ((SYM INIT)...) BODY...)
+;;;     ;; (@let ((SYM INIT)...) BODY...)
-    ((@let)
+;;;     ((@let)
-     (match args
+;;;      (match args
-       ((((sym init) ...) body ...)
+;;;        ((((sym init) ...) body ...)
-	(let* ((vals (map-parse init e))
+;;; 	(let* ((vals (map-parse init e))
-	       (vars (map (lambda (s)
+;;; 	       (vars (map (lambda (s)
-			    (let ((v (make-ghil-var e s 'local)))
+;;; 			    (let ((v (make-ghil-var e s 'local)))
-			      (ghil-env-add! e v) v))
+;;; 			      (ghil-env-add! e v) v))
-			  sym))
+;;; 			  sym))
-	       (body (parse-body body e)))
+;;; 	       (body (parse-body body e)))
-	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+;;; 	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
-	  (make-<ghil-bind> e vars vals body)))))
+;;; 	  (<ghil-bind> e vars vals body)))))
-
+;;; 
-    ;; (@letrec ((SYM INIT)...) BODY...)
+;;;     ;; (@letrec ((SYM INIT)...) BODY...)
-    ((@letrec)
+;;;     ((@letrec)
-     (match args
+;;;      (match args
-       ((((sym init) ...) body ...)
+;;;        ((((sym init) ...) body ...)
-	(let* ((vars (map (lambda (s)
+;;; 	(let* ((vars (map (lambda (s)
-			    (let ((v (make-ghil-var e s 'local)))
+;;; 			    (let ((v (make-ghil-var e s 'local)))
-			      (ghil-env-add! e v) v))
+;;; 			      (ghil-env-add! e v) v))
-			  sym))
+;;; 			  sym))
-	       (vals (map-parse init e))
+;;; 	       (vals (map-parse init e))
-	       (body (parse-body body e)))
+;;; 	       (body (parse-body body e)))
-	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+;;; 	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
-	  (make-<ghil-bind> e vars vals body)))))
+;;; 	  (<ghil-bind> e vars vals body)))))
-
+;;; 
-    ;; (@lambda FORMALS BODY...)
+;;;     ;; (@lambda FORMALS BODY...)
-    ((@lambda)
+;;;     ((@lambda)
-     (match args
+;;;      (match args
-       ((formals . body)
+;;;        ((formals . body)
-	(receive (syms rest) (parse-formals formals)
+;;; 	(receive (syms rest) (parse-formals formals)
-	  (let* ((e (make-ghil-env e))
+;;; 	  (let* ((e (make-ghil-env e))
-		 (vars (map (lambda (s)
+;;; 		 (vars (map (lambda (s)
-			      (let ((v (make-ghil-var e s 'argument)))
+;;; 			      (let ((v (make-ghil-var e s 'argument)))
-				(ghil-env-add! e v) v))
+;;; 				(ghil-env-add! e v) v))
-			    syms)))
+;;; 			    syms)))
-	    (make-<ghil-lambda> e vars rest (parse-body body e)))))))
+;;; 	    (<ghil-lambda> e vars rest (parse-body body e)))))))
-
+;;; 
-    ;; (@eval-case CLAUSE...)
+;;;     ;; (@eval-case CLAUSE...)
-    ((@eval-case)
+;;;     ((@eval-case)
-     (let loop ((clauses args))
+;;;      (let loop ((clauses args))
-       (cond ((null? clauses) (make-<ghil-void>))
+;;;        (cond ((null? clauses) (<ghil-void>))
-	     ((or (eq? (caar clauses) '@else)
+;;; 	     ((or (eq? (caar clauses) '@else)
-		  (and (memq 'load-toplevel (caar clauses))
+;;; 		  (and (memq 'load-toplevel (caar clauses))
-		       (ghil-env-toplevel? e)))
+;;; 		       (ghil-env-toplevel? e)))
-	      (parse-body (cdar clauses) e))
+;;; 	      (parse-body (cdar clauses) e))
-	     (else
+;;; 	     (else
-	      (loop (cdr clauses))))))
+;;; 	      (loop (cdr clauses))))))
-
+;;; 
-    (else (error "Unknown primitive:" prim))))
+;;;     (else (error "Unknown primitive:" prim))))
-
+;;; 
-(define (parse-body x e)
+;;; (define (parse-body x e)
-  (make-<ghil-begin> (map-parse x e)))
+;;;   (<ghil-begin> (map-parse x e)))
-
+;;; 
-(define (parse-formals formals)
+;;; (define (parse-formals formals)
-  (cond
+;;;   (cond
-   ;; (@lambda x ...)
+;;;    ;; (@lambda x ...)
-   ((symbol? formals) (values (list formals) #t))
+;;;    ((symbol? formals) (values (list formals) #t))
-   ;; (@lambda (x y z) ...)
+;;;    ;; (@lambda (x y z) ...)
-   ((list? formals) (values formals #f))
+;;;    ((list? formals) (values formals #f))
-   ;; (@lambda (x y . z) ...)
+;;;    ;; (@lambda (x y . z) ...)
-   ((pair? formals)
+;;;    ((pair? formals)
-    (let loop ((l formals) (v '()))
+;;;     (let loop ((l formals) (v '()))
-      (if (pair? l)
+;;;       (if (pair? l)
-	  (loop (cdr l) (cons (car l) v))
+;;; 	  (loop (cdr l) (cons (car l) v))
-	  (values (reverse! (cons l v)) #t))))
+;;; 	  (values (reverse! (cons l v)) #t))))
-   (else (error "Invalid formals:" formals))))
+;;;    (else (error "Invalid formals:" formals))))
-
+;;; 
-(define (identifier-split identifier)
+;;; (define (identifier-split identifier)
-  (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
+;;;   (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
-    (if m
+;;;     (if m
-	(values (string->symbol (match:prefix m))
+;;; 	(values (string->symbol (match:prefix m))
-		(string->symbol (match:substring m 1)))
+;;; 		(string->symbol (match:substring m 1)))
-	(values #f identifier))))
+;;; 	(values #f identifier))))

module/system/il/glil.scm

@@ -20,54 +20,59 @@
 ;;; Code:
 
 (define-module (system il glil)
+  :use-syntax (system base syntax)
   :use-module (ice-9 match)
   :export
   (pprint-glil
-   make-<glil-asm> <glil-asm>?
+   <glil-vars>
+   <glil-asm> <glil-asm>?
    <glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5
-   make-<glil-vars> <glil-vars>? <glil-vars>-1 <glil-vars>-2
+   <glil-bind> <glil-bind>? <glil-bind>-1
+   <glil-unbind> <glil-unbind>?
+   <glil-source> <glil-source>? <glil-source>-1 <glil-source>-2
 
-   make-<glil-void> <glil-void>?
+   <glil-void> <glil-void>?
-   make-<glil-const> <glil-const>? <glil-const>-1
+   <glil-const> <glil-const>? <glil-const>-1
 
-   make-<glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
+   <glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
-   make-<glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
+   <glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
-   make-<glil-external> <glil-external>?
+   <glil-external> <glil-external>?
    <glil-external>-1 <glil-external>-2 <glil-external>-3
-   make-<glil-module> <glil-module>?
+   <glil-module> <glil-module>?
    <glil-module>-1 <glil-module>-2 <glil-module>-3
 
-   make-<glil-label> <glil-label>? <glil-label>-1
+   <glil-label> <glil-label>? <glil-label>-1
-   make-<glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
+   <glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
-   make-<glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
+   <glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
    ))
 
-;; Meta operations
+(define-record (<glil-vars> nargs nrest nlocs nexts))
-(define-structure (<glil-asm> nargs nrest nlocs nexts body))
-(define-structure (<glil-vars> type syms))
 
-;; Constants
+(define-type <glil>
-(define-structure (<glil-void>))
+  (|
-(define-structure (<glil-const> obj))
+   ;; Meta operations
-
+   (<glil-asm> vars body)
-;; Variables
+   (<glil-bind> vars)
-(define-structure (<glil-argument> op index))
+   (<glil-unbind>)
-(define-structure (<glil-local> op index))
+   (<glil-source> loc)
-(define-structure (<glil-external> op depth index))
+   ;; Objects
-(define-structure (<glil-module> op module name))
+   (<glil-void>)
-
+   (<glil-const> obj)
-;; Controls
+   ;; Variables
-(define-structure (<glil-label> label))
+   (<glil-argument> op index)
-(define-structure (<glil-branch> inst label))
+   (<glil-local> op index)
-(define-structure (<glil-call> inst nargs))
+   (<glil-external> op depth index)
+   (<glil-module> op module name)
+   ;; Controls
+   (<glil-label> label)
+   (<glil-branch> inst label)
+   (<glil-call> inst nargs)))
 
 
 ;;;
 ;;; Parser
 ;;;
 
-;; FIXME: This is not working now
-
 ;;; (define (parse-glil x)
 ;;;   (match x
 ;;;     (('@asm args . body)
@@ -140,9 +145,12 @@
 (define (unparse glil)
   (match glil
     ;; meta
-    (($ <glil-asm> nargs nrest nlocs nexts body)
+    (($ <glil-asm> vars body)
-     `(@asm (,nargs ,nrest ,nlocs ,nexts) ,@(map unparse body)))
+     `(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts)
-    (($ <glil-vars> type syms) `(,type ,@syms))
+	    ,@(map unparse body)))
+    (($ <glil-bind> vars) `(@bind ,@vars))
+    (($ <glil-unbind>) `(@unbind))
+    (($ <glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
     ;; constants
     (($ <glil-void>) `(void))
     (($ <glil-const> obj) `(const ,obj))
@@ -165,16 +173,17 @@
 ;;; Printer
 ;;;
 
-(define (pprint-glil glil)
+(define (pprint-glil glil . port)
+  (let ((port (if (pair? port) (car port) (current-output-port))))
     (let print ((code (unparse glil)) (column 0))
-    (display (make-string column #\space))
+      (display (make-string column #\space) port)
       (cond ((and (pair? code) (eq? (car code) '@asm))
-	   (format #t "(@asm ~A\n" (cadr code))
+	     (format port "(@asm ~A\n" (cadr code))
 	     (let ((col (+ column 2)))
 	       (let loop ((l (cddr code)))
 		 (print (car l) col)
 		 (if (null? (cdr l))
-		   (display ")")
+		   (display ")" port)
-		   (begin (newline) (loop (cdr l)))))))
+		   (begin (newline port) (loop (cdr l)))))))
-	  (else (write code))))
+	    (else (write code port))))
-  (newline))
+    (newline port)))

module/system/repl/.cvsignore

@@ -1 +1,3 @@
+Makefile
+Makefile.in
 *.go

module/system/repl/Makefile.am

@@ -0,0 +1,12 @@
+SOURCES = repl.scm common.scm command.scm
+OBJECTS = repl.go  common.go  command.go
+
+vmdir = $(guiledir)/system/repl
+vm_DATA = $(SOURCES) $(OBJECTS)
+
+DISTCLEANFILES = $(OBJECTS)
+MAINTAINERCLEANFILES = Makefile.in
+
+SUFFIXES = .scm .go
+.scm.go:
+	$(GUILEC) $<

module/system/repl/command.scm

@@ -24,10 +24,13 @@
   :use-module (system base compile)
   :use-module (system repl common)
   :use-module (system vm core)
+  :autoload (system base language) (lookup-language)
   :autoload (system il glil) (pprint-glil)
   :autoload (system vm disasm) (disassemble-program disassemble-objcode)
   :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
   :autoload (system vm profile) (vm-profile)
+  :autoload (system vm debugger) (vm-debugger)
+  :autoload (system vm backtrace) (vm-backtrace)
   :use-module (ice-9 format)
   :use-module (ice-9 session)
   :use-module (ice-9 documentation))
@@ -44,7 +47,7 @@
     (compile  (compile c) (compile-file cc)
 	      (disassemble x) (disassemble-file xx))
     (profile  (time t) (profile pr))
-    (debug    (backtrace bt) (debugger db) (trace r) (step st))
+    (debug    (backtrace bt) (debugger db) (trace tr) (step st))
     (system   (gc) (statistics stat))))
 
 (define (group-name g) (car g))
@@ -332,16 +335,15 @@ Profile execution."
 ;;; Debug commands
 ;;;
 
-(define guile:backtrace backtrace)
 (define (backtrace repl)
   "backtrace
-Show backtrace (if any)."
+Display backtrace."
-  (guile:backtrace))
+  (vm-backtrace repl.env.vm))
 
 (define (debugger repl)
   "debugger
 Start debugger."
-  (debug))
+  (vm-debugger repl.env.vm))
 
 (define (trace repl form . opts)
   "trace FORM

module/system/repl/common.scm

@@ -20,19 +20,17 @@
 ;;; Code:
 
 (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 core))
-  :use-module (system vm trace))
 
 
 ;;;
 ;;; Repl type
 ;;;
 
-(define-vm-class <repl> () env options tm-stats gc-stats vm-stats)
+(define-record (<repl> env options tm-stats gc-stats vm-stats))
 
 (define repl-default-options
   '((trace . #f)))
@@ -41,8 +39,7 @@
   (let ((cenv (make-cenv :vm (the-vm)
 			 :language (lookup-language lang)
 			 :module (current-module))))
-    (make <repl>
+    (<repl> :env cenv
-	  :env cenv
 	    :options repl-default-options
 	    :tm-stats (times)
 	    :gc-stats (gc-stats)

module/system/repl/repl.scm

@@ -32,7 +32,7 @@
     (repl-welcome repl)
     (let prompt-loop ()
       (repl-prompt repl)
-      (call-with-error-handlers
+      (catch 'vm-error
 	(lambda ()
 	  (if (eq? (next-char #t) #\,)
 	    ;; meta command
@@ -40,7 +40,11 @@
 	    ;; evaluation
 	    (let rep-loop ()
 	      (repl-print repl (repl-eval repl (repl-read repl)))
-	       (if (next-char #f) (rep-loop))))))
+	      (if (next-char #f) (rep-loop)))))
+	(lambda (key fun msg args)
+	  (display "ERROR: ")
+	  (apply format #t msg args)
+	  (newline)))
       (prompt-loop))))
 
 (define (next-char wait)
@@ -50,21 +54,3 @@
 	      ((char-whitespace? ch) (read-char) (next-char wait))
 	      (else ch)))
       #f))
-
-;;;
-;;; Error handler
-;;;
-
-(define (call-with-error-handlers thunk)
-  (catch 'vm-error
-    (lambda () (catch 'user-error thunk error-handler))
-    error-handler))
-
-(define (error-handler key . args)
-  (case key
-    ((vm-error)
-     (write (frame->call (cadddr args)))
-     (newline)))
-  (display "ERROR: ")
-  (apply format #t (cadr args) (caddr args))
-  (newline))

module/system/vm/.cvsignore

@@ -1 +1,3 @@
+Makefile
+Makefile.in
 *.go

module/system/vm/Makefile.am

@@ -0,0 +1,12 @@
+SOURCES = assemble.scm conv.scm core.scm disasm.scm profile.scm trace.scm
+OBJECTS = assemble.go  conv.go  core.go  disasm.go  profile.go  trace.go
+
+vmdir = $(guiledir)/system/vm
+vm_DATA = $(SOURCES) $(OBJECTS)
+
+DISTCLEANFILES = $(OBJECTS)
+MAINTAINERCLEANFILES = Makefile.in
+
+SUFFIXES = .scm .go
+.scm.go:
+	$(GUILEC) $<

module/system/vm/assemble.scm

@@ -20,6 +20,7 @@
 ;;; 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)
@@ -36,11 +37,11 @@
 ;;; Types
 ;;;
 
-(define-structure (<vm-asm> venv glil body))
+(define-record (<vm-asm> venv glil body))
-(define-structure (venv parent nexts closure?))
+(define-record (<venv> parent nexts closure?))
-(define-structure (vmod id))
+(define-record (<vmod> id))
-(define-structure (vlink module name))
+(define-record (<vlink> module name))
-(define-structure (bytespec nargs nrest nlocs nexts bytes objs closure?))
+(define-record (<bytespec> vars bytes meta objs closure?))
 
 
 ;;;
@@ -49,15 +50,15 @@
 
 (define (preprocess x e)
   (match x
-    (($ <glil-asm> nargs nrest nlocs nexts body)
+    (($ <glil-asm> vars body)
-     (let* ((venv (make-venv e nexts #f))
+     (let* ((venv (<venv> :parent e :nexts vars.nexts :closure? #f))
 	    (body (map (lambda (x) (preprocess x venv)) body)))
-       (make-<vm-asm> venv x body)))
+       (<vm-asm> :venv venv :glil x :body body)))
     (($ <glil-external> op depth index)
      (do ((d depth (1- d))
-	  (e e (venv-parent e)))
+	  (e e e.parent))
 	 ((= d 0))
-       (set-venv-closure?! e #t))
+       (set! e.closure? #t))
      x)
     (else x)))
 
@@ -68,8 +69,10 @@
 
 (define (codegen glil toplevel)
   (match glil
-    (($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
+    (($ <vm-asm> venv ($ <glil-asm> vars _) body)
      (let ((stack '())
+	   (bind-alist '())
+	   (source-alist '())
 	   (label-alist '())
 	   (object-alist '()))
        (define (push-code! code)
@@ -84,11 +87,32 @@
 				  (set! object-alist (acons x i object-alist))
 				  i)))))
 		  (push-code! `(object-ref ,i))))))
+       (define (current-address)
+	 (define (byte-length x)
+	   (cond ((string? x) (string-length x))
+		 (else 3)))
+	 (apply + (map byte-length stack)))
        (define (generate-code x)
 	 (match x
 	   (($ <vm-asm> venv)
 	    (push-object! (codegen x #f))
-	    (if (venv-closure? venv) (push-code! `(make-closure))))
+	    (if venv.closure? (push-code! `(make-closure))))
+
+	   (($ <glil-bind> binds)
+	    (let ((binds (map (lambda (v)
+				(case (cadr v)
+				  ((argument) (list (car v) #f (caddr v)))
+				  ((local) (list (car v) #f
+						 (+ vars.nargs (caddr v))))
+				  ((external) (list (car v) #t (caddr v)))))
+			      binds)))
+	      (set! bind-alist (acons (current-address) binds bind-alist))))
+
+	   (($ <glil-unbind>)
+	    (set! bind-alist (acons (current-address) #f bind-alist)))
+
+	   (($ <glil-source> loc)
+	    (set! source-alist (acons (current-address) loc source-alist)))
 
 	   (($ <glil-void>)
 	    (push-code! '(void)))
@@ -103,30 +127,26 @@
 
 	   (($ <glil-local> op index)
 	    (if (eq? op 'ref)
-		(push-code! `(local-ref ,(+ nargs index)))
+		(push-code! `(local-ref ,(+ vars.nargs index)))
-		(push-code! `(local-set ,(+ nargs index)))))
+		(push-code! `(local-set ,(+ vars.nargs index)))))
 
 	   (($ <glil-external> op depth index)
-	    (do ((e venv (venv-parent e))
+	    (do ((e venv e.parent)
 		 (d depth (1- d))
-		 (n 0 (+ n (venv-nexts e))))
+		 (n 0 (+ n e.nexts)))
 		((= d 0)
 		 (if (eq? op 'ref)
 		     (push-code! `(external-ref ,(+ n index)))
 		     (push-code! `(external-set ,(+ n index)))))))
 
 	   (($ <glil-module> op module name)
-	    (push-object! (make-vlink #f name))	;; FIXME: (make-vmod module)
+	    (push-object! (<vlink> :module #f :name name))
 	    (if (eq? op 'ref)
 		(push-code! '(variable-ref))
 		(push-code! '(variable-set))))
 
 	   (($ <glil-label> label)
-	    (define (byte-length x)
+	    (set! label-alist (assq-set! label-alist label (current-address))))
-	      (cond ((string? x) (string-length x))
-		    (else 3)))
-	    (let ((addr (apply + (map byte-length stack))))
-	      (set! label-alist (assq-set! label-alist label addr))))
 
 	   (($ <glil-branch> inst label)
 	    (set! stack (cons (list inst label) stack)))
@@ -146,13 +166,21 @@
        (for-each generate-code body)
        (let ((bytes (stack->bytes (reverse! stack) label-alist)))
 	 (if toplevel
-	     (bytecode->objcode bytes nlocs nexts)
+	     (bytecode->objcode bytes vars.nlocs vars.nexts)
-	     (let ((objs (map car (reverse! object-alist))))
+	     (<bytespec> :vars vars :bytes bytes
-	       (make-bytespec nargs nrest nlocs nexts bytes objs
+			 :meta (if (and (null? bind-alist)
-			      (venv-closure? venv)))))))))
+					(null? source-alist))
+				 #f
+				 (cons (reverse! bind-alist)
+				       (reverse! source-alist)))
+			 :objs (let ((objs (map car (reverse! object-alist))))
+				 (if (null? objs) #f (list->vector objs)))
+			 :closure? venv.closure?)))))))
 
 (define (object-assoc x alist)
-  (if (vlink? x) (assoc x alist) (assq x alist)))
+  (match x
+    (($ <vlink>) (assoc x alist))
+    (else        (assq x alist))))
 
 (define (stack->bytes stack label-alist)
   (let loop ((result '()) (stack stack) (addr 0))
@@ -181,10 +209,12 @@
   (let dump! ((x x))
     (cond
      ((object->code x) => push-code!)
-     ((bytespec? x)
+     (else
       (match x
-	(($ bytespec nargs nrest nlocs nexts bytes objs closure?)
+	(($ <bytespec> vars bytes meta objs closure?)
 	 ;; dump parameters
+	 (let ((nargs vars.nargs) (nrest vars.nrest)
+	       (nlocs vars.nlocs) (nexts vars.nexts))
 	   (cond
 	     ((and (< nargs 4) (< nlocs 8) (< nexts 4))
 	      ;; 8-bit representation
@@ -200,41 +230,42 @@
 	      (push-code! (object->code nrest))
 	      (push-code! (object->code nlocs))
 	      (push-code! (object->code nexts))
-	   (push-code! (object->code #f))))
+	      (push-code! (object->code #f)))))
 	 ;; dump object table
-	 (cond ((not (null? objs))
+	 (if objs (dump! objs))
-		(for-each dump! objs)
+	 ;; dump meta data
-		(push-code! `(vector ,(length objs)))))
+	 (if meta (dump! meta))
 	 ;; dump bytecode
-	 (push-code! `(load-program ,bytes)))))
+	 (push-code! `(load-program ,bytes)))
-     ((vlink? x)
+	(($ <vlink> module name)
-      ;;; (dump! (vlink-module x))  ;; FIXME: no module support now
+	 ;; FIXME: dump module
-      (push-code! `(link ,(symbol->string (vlink-name x)))))
+	 (push-code! `(link ,(symbol->string name))))
-     ((vmod? x)
+	(($ <vmod> id)
-      (push-code! `(load-module ,(vmod-id x))))
+	 (push-code! `(load-module ,id)))
-     ((and (integer? x) (exact? x))
+	((and ($ integer) ($ exact))
 	 (let ((str (do ((n x (quotient n 256))
 			 (l '() (cons (modulo n 256) l)))
 			((= n 0)
 			 (list->string (map integer->char l))))))
 	   (push-code! `(load-integer ,str))))
-     ((number? x)
+	(($ number)
 	 (push-code! `(load-number ,(number->string x))))
-     ((string? x)
+	(($ string)
 	 (push-code! `(load-string ,x)))
-     ((symbol? x)
+	(($ symbol)
 	 (push-code! `(load-symbol ,(symbol->string x))))
-     ((keyword? x)
+	(($ keyword)
-      (push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
+	 (push-code! `(load-keyword
-     ((list? x)
+		       ,(symbol->string (keyword-dash-symbol x)))))
+	(($ list)
 	 (for-each dump! x)
 	 (push-code! `(list ,(length x))))
-     ((pair? x)
+	(($ pair)
 	 (dump! (car x))
 	 (dump! (cdr x))
 	 (push-code! `(cons)))
-     ((vector? x)
+	(($ vector)
 	 (for-each dump! (vector->list x))
 	 (push-code! `(vector ,(vector-length x))))
 	(else
-      (error "Cannot dump:" x)))))
+	 (error "Cannot dump:" x)))))))

module/system/vm/backtrace.scm

@@ -0,0 +1,33 @@
+;;; Guile VM backtrace
+
+;; 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 backtrace)
+  :use-syntax (system base syntax)
+  :use-module (system vm core)
+  :use-module (system vm frame)
+  :use-module (ice-9 format)
+  :export (vm-backtrace))
+
+(define (vm-backtrace vm)
+  (let ((stack (vm-last-frame-stack vm)))
+    (if (null? stack)
+      (display "No backtrace available\n")
+      (for-each print-frame (reverse! stack)))))

module/system/vm/core.scm

@@ -35,36 +35,21 @@
 
 
 ;;;
-;;; Loader
+;;; High-level procedures
 ;;;
 
+(define-public (program-bindings prog)
+  (cond ((program-meta prog) => car)
+	(else '())))
+
+(define-public (program-sources prog)
+  (cond ((program-meta prog) => cdr)
+	(else '())))
+
+(define-public (vms:time stat) (vector-ref stat 0))
+(define-public (vms:clock stat) (vector-ref stat 1))
+
 (define-public (vm-load vm objcode)
   (vm (objcode->program objcode)))
 
 (set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file))))
-
-
-;;;
-;;; Frame interface
-;;;
-
-(define-public (frame->call frame)
-  (let* ((prog (frame-program frame))
-	 (nargs (car (program-arity prog))))
-    (do ((i 0 (1+ i))
-	 (l (vector->list (frame-variables frame)) (cdr l))
-	 (r '() (cons (car l) r)))
-	((= i nargs) (cons (program-name prog) (reverse! r))))))
-
-(define (program-name x)
-  (or (object-property x 'name)
-      (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
-		 (module-obarray (current-module)))))
-
-
-;;;
-;;; Statistics interface
-;;;
-
-(define-public (vms:time stat) (vector-ref stat 0))
-(define-public (vms:clock stat) (vector-ref stat 1))

module/system/vm/disasm.scm

@@ -127,8 +127,7 @@
 	       (else #f)))))))
 
 (define (list->info list)
-  (let ((str (object->string list)))
+  (object->string list))
-    (substring str 1 (1- (string-length str)))))
 
 (define (print-info addr info extra)
   (if extra

module/system/vm/frame.scm

@@ -0,0 +1,125 @@
+;;; Guile VM frame functions
+
+;; 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))
+
+(define-public (vm-return-value vm)
+  (car (vm-fetch-stack vm)))
+
+(define-public (frame-local-ref frame index)
+  (vector-ref (frame-local-variables frame) index))
+
+(define-public (frame-external-ref frame index)
+  (list-ref (frame-external-link frame) index))
+
+
+;;;
+;;; Debug frames
+;;;
+
+(define-public frame-index (make-object-property))
+(define-public frame-address (make-object-property))
+
+(define-public (vm-last-frame-stack vm)
+  (make-frame-stack (vm-last-frame vm) (vm:ip vm)))
+
+(define-public (vm-current-frame-stack vm)
+  (make-frame-stack (vm-current-frame vm) (vm:ip vm)))
+
+(define (make-frame-stack frame addr)
+  (cond ((frame-dynamic-link frame) =>
+	 (lambda (link)
+	   (let ((stack (make-frame-stack link (frame-return-address frame)))
+		 (base (program-base (frame-program frame))))
+	     (set! (frame-index frame) (1+ (length stack)))
+	     (set! (frame-address frame) (- addr base))
+	     (cons frame stack))))
+	(else '())))
+
+(define-public (frame-bindings frame addr)
+  (do ((bs (program-bindings (frame-program frame)) (cdr bs))
+       (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
+      ((or (null? bs) (> (caar bs) addr))
+       (apply append ls))))
+
+(define-public (frame-environment frame addr)
+  (map (lambda (binding)
+	 (let ((name (car binding))
+	       (extp (cadr binding))
+	       (index (caddr binding)))
+	   (cons name (if extp
+			(frame-external-ref frame index)
+			(frame-local-ref frame index)))))
+       (frame-bindings frame addr)))
+
+(define (frame-variable-ref frame sym)
+  (cond ((assq sym (frame-environment frame)) => cdr)
+	(else (error "Unbound"))))
+
+(define (frame-object-name frame obj)
+  (display (frame-address frame))
+  (let loop ((alist (frame-environment frame (frame-address frame))))
+    (cond ((null? alist) #f)
+	  ((eq? obj (cdar alist)) (caar alist))
+	  (else (loop (cdr alist))))))
+
+
+;;;
+;;; Pretty printing
+;;;
+
+(define-public (frame-call-list frame)
+  (let* ((prog (frame-program frame))
+	 (locs (vector->list (frame-local-variables frame)))
+	 (args (list-truncate locs (car (program-arity prog))))
+	 (name (or (frame-object-name (frame-dynamic-link frame) prog)
+		   (object-name prog))))
+    (cons name args)))
+
+(define-public (print-frame-call frame)
+  (define (abbrev x)
+    (cond ((list? x)   (if (> (length x) 3)
+			 (list (abbrev (car x)) (abbrev (cadr x)) '...)
+			 (map abbrev x)))
+	  ((pair? x)   (cons (abbrev (car x)) (abbrev (cdr x))))
+	  ((vector? x) (case (vector-length x)
+			 ((0) x)
+			 ((1) (vector (abbrev (vector-ref x 0))))
+			 (else (vector (abbrev (vector-ref x 0)) '...))))
+	  (else x)))
+  (write (abbrev (frame-call-list frame))))
+
+(define-public (print-frame frame)
+  (format #t "#~A " (frame-index frame))
+  (print-frame-call frame)
+  (newline))
+
+(define (list-truncate l n)
+  (do ((i 0 (1+ i))
+       (l l (cdr l))
+       (r '() (cons (car l) r)))
+      ((= i n) (reverse! r))))
+
+(define (object-name x)
+  (or (object-property x 'name)
+      (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d))
+		 x (module-obarray (current-module)))))

module/system/vm/profile.scm

@@ -34,7 +34,7 @@
 	  (add-hook! (vm-enter-hook vm) profile-enter)
 	  (add-hook! (vm-exit-hook vm) profile-exit))
 	(lambda ()
-	  (let ((val (vm (objcode->program objcode))))
+	  (let ((val (vm-load vm objcode)))
 	    (display-result vm)
 	    val))
 	(lambda ()

module/system/vm/trace.scm

@@ -22,13 +22,14 @@
 (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)
   :export (vm-trace vm-trace-on vm-trace-off))
 
 (define (vm-trace vm objcode . opts)
   (dynamic-wind
       (lambda () (apply vm-trace-on vm opts))
-      (lambda () (vm (objcode->program objcode)))
+      (lambda () (vm-load vm objcode))
       (lambda () (apply vm-trace-off vm opts))))
 
 (define (vm-trace-on vm . opts)
@@ -44,30 +45,32 @@
   (remove-hook! (vm-return-hook vm) trace-return))
 
 (define (trace-next vm)
-  (let ((frame (vm-current-frame vm)))
   (format #t "0x~8X  ~20S" (vm:ip vm) (vm-fetch-code vm))
   (do ((opts (vm-option vm 'trace-options) (cdr opts)))
       ((null? opts) (newline))
     (case (car opts)
       ((:s) (format #t "~20S" (vm-fetch-stack vm)))
-	((:v) (format #t "~20S" (frame-variables frame)))
+      ((:v) (let ((stack (vm-current-frame-stack vm)))
-	((:e) (format #t "~20A" (object->string (frame-external-link frame))))))))
+	      (if (pair? stack)
+		(format #t "~20S" (frame-environment (car stack))))))
+      ((:l)
+       (format #t "~20S" (frame-local-variables (vm-current-frame vm))))
+      ((:e)
+       (format #t "~20A" (frame-external-link (vm-current-frame vm)))))))
 
 (define (trace-apply vm)
-  (if (vm-option vm 'trace-first)
+  ;;  (if (vm-option vm 'trace-first)
-      (set-vm-option! vm 'trace-first #f)	;; skip the initial program
+  ;;    (set-vm-option! vm 'trace-first #f)
-      (let ((frame (vm-current-frame vm)))
+  (let ((stack (vm-current-frame-stack vm)))
-	(print-prefix (frame-dynamic-link frame))
+    (print-indent stack)
-	(write (frame->call frame))
+    (print-frame-call (car stack))
-	(newline))))
-
-(define (trace-return vm)
-  (let ((frame (vm-current-frame vm)))
-    (print-prefix (frame-dynamic-link frame))
-    (write (car (vm-fetch-stack vm)))
     (newline)))
 
-(define (print-prefix frame)
+(define (trace-return vm)
-  (and-let* ((link (frame-dynamic-link frame)))
+  (let ((stack (vm-current-frame-stack vm)))
-    (display "| ")
+    (print-indent stack)
-    (print-prefix link)))
+    (write (vm-return-value vm))
+    (newline)))
+
+(define (print-indent stack)
+  (cond ((pair? stack) (display "| ") (print-indent (cdr stack)))))

src/Makefile.am

@@ -6,13 +6,13 @@ guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
 
 lib_LTLIBRARIES = libguilevm.la
 libguilevm_la_SOURCES =							\
-	envs.c instructions.c objcodes.c programs.c vm.c	\
+	envs.c frames.c instructions.c objcodes.c programs.c vm.c	\
-	envs.h instructions.h objcodes.h programs.h vm.h	\
+	envs.h frames.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 objcodes.x programs.x vm.x
+	envs.x frames.x instructions.x objcodes.x programs.x vm.x
 
 INCLUDES = $(GUILE_CFLAGS)
 DISTCLEANFILES = $(BUILT_SOURCES)

src/frames.c

@@ -0,0 +1,184 @@
+/* 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 "frames.h"
+
+
+scm_bits_t scm_tc16_heap_frame;
+
+SCM
+scm_c_make_heap_frame (SCM *fp)
+{
+  struct scm_heap_frame *p =
+    scm_must_malloc (sizeof (struct scm_heap_frame), "make_heap_frame");
+  p->fp            = fp;
+  p->program       = SCM_UNDEFINED;
+  p->variables     = SCM_UNDEFINED;
+  p->dynamic_link  = SCM_UNDEFINED;
+  p->external_link = SCM_UNDEFINED;
+  SCM_RETURN_NEWSMOB (scm_tc16_heap_frame, p);
+}
+
+static SCM
+heap_frame_mark (SCM obj)
+{
+  struct scm_heap_frame *p = SCM_HEAP_FRAME_DATA (obj);
+  scm_gc_mark (p->program);
+  scm_gc_mark (p->variables);
+  scm_gc_mark (p->dynamic_link);
+  return p->external_link;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_frame_p
+{
+  return SCM_BOOL (SCM_HEAP_FRAME_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_program
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  return SCM_STACK_FRAME_PROGRAM (SCM_HEAP_FRAME_DATA (frame)->fp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_local_variables, "frame-local-variables", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_local_variables
+{
+  struct scm_heap_frame *p;
+
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  p = SCM_HEAP_FRAME_DATA (frame);
+
+  if (SCM_UNBNDP (p->variables))
+    {
+      SCM prog = scm_frame_program (frame);
+      struct scm_program *pp = SCM_PROGRAM_DATA (prog);
+      int i, size = pp->nargs + pp->nlocs;
+      p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
+      for (i = 0; i < size; i++)
+	SCM_VELTS (p->variables)[i] = SCM_STACK_FRAME_VARIABLE (p->fp, i);
+    }
+  return p->variables;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_return_address
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+
+  return scm_long2num ((long) SCM_VM_BYTE_ADDRESS
+		       (SCM_STACK_FRAME_RETURN_ADDRESS
+			(SCM_HEAP_FRAME_DATA (frame)->fp)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_dynamic_link
+{
+  struct scm_heap_frame *p;
+
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  p = SCM_HEAP_FRAME_DATA (frame);
+
+  if (SCM_UNBNDP (p->dynamic_link))
+    {
+      SCM *fp = SCM_VM_STACK_ADDRESS (SCM_STACK_FRAME_DYNAMIC_LINK (p->fp));
+      if (fp)
+	p->dynamic_link = scm_c_make_heap_frame (fp);
+      else
+	p->dynamic_link = SCM_BOOL_F;
+    }
+
+  return p->dynamic_link;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_external_link
+{
+  struct scm_heap_frame *p;
+
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  p = SCM_HEAP_FRAME_DATA (frame);
+
+  if (SCM_UNBNDP (p->external_link))
+    p->external_link = SCM_STACK_FRAME_EXTERNAL_LINK (p->fp);
+
+  return p->external_link;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_frames (void)
+{
+  scm_tc16_heap_frame = scm_make_smob_type ("heap_frame", 0);
+  scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "frames.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/frames.h

@@ -0,0 +1,126 @@
+/* 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_FRAMES_H_
+#define _SCM_FRAMES_H_
+
+#include <libguile.h>
+#include "config.h"
+#include "programs.h"
+
+/*
+ * VM Address
+ */
+
+#define SCM_VM_MAKE_STACK_ADDRESS(ptr)	SCM_PACK (ptr)
+#define SCM_VM_STACK_ADDRESS(addr)	((SCM *) SCM_UNPACK (addr))
+
+#define SCM_VM_MAKE_BYTE_ADDRESS(ptr)	SCM_PACK (ptr)
+#define SCM_VM_BYTE_ADDRESS(addr)	((scm_byte_t *) SCM_UNPACK (addr))
+
+
+/*
+ * VM Stack frames
+ */
+
+/* Stack frames are allocated on the VM stack as follows:
+
+   |                  | <- fp + bp->nargs + bp->nlocs + 3
+   +------------------+    = SCM_STACK_FRAME_UPPER_ADDRESS (fp)
+   | Return address   |
+   | Dynamic link     |
+   | External link    | <- fp + bp->nargs + bp->nlocs
+   | Local varialbe 1 |    = SCM_STACK_FRAME_DATA_ADDRESS (fp)
+   | Local variable 0 | <- fp + bp->nargs
+   | Argument 1       |
+   | Argument 0       | <- fp
+   | Program          | <- fp - 1
+   +------------------+    = SCM_STACK_FRAME_LOWER_ADDRESS (fp)
+   |                  |
+*/
+
+#define SCM_STACK_FRAME_DATA_ADDRESS(fp)			\
+  (fp + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nargs	\
+      + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_STACK_FRAME_UPPER_ADDRESS(fp)			\
+  (SCM_STACK_FRAME_DATA_ADDRESS (fp) + 3)
+#define SCM_STACK_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
+
+#define SCM_STACK_FRAME_RETURN_ADDRESS(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[2]
+#define SCM_STACK_FRAME_DYNAMIC_LINK(fp)   SCM_STACK_FRAME_DATA_ADDRESS (fp)[1]
+#define SCM_STACK_FRAME_EXTERNAL_LINK(fp)  SCM_STACK_FRAME_DATA_ADDRESS (fp)[0]
+#define SCM_STACK_FRAME_VARIABLE(fp,i)	   fp[i]
+#define SCM_STACK_FRAME_PROGRAM(fp)	   fp[-1]
+
+
+/*
+ * VM Heap frames
+ */
+
+struct scm_heap_frame {
+  SCM *fp;
+  SCM program;
+  SCM variables;
+  SCM dynamic_link;
+  SCM external_link;
+};
+
+extern scm_bits_t scm_tc16_heap_frame;
+
+#define SCM_HEAP_FRAME_P(x)	SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
+#define SCM_HEAP_FRAME_DATA(f) ((struct scm_heap_frame *) SCM_SMOB_DATA (f))
+#define SCM_VALIDATE_HEAP_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
+
+#define SCM_HEAP_FRAME_PROGRAM(f)	SCM_HEAP_FRAME_DATA (f)->program
+#define SCM_HEAP_FRAME_VARIABLES(f)	SCM_HEAP_FRAME_DATA (f)->variables
+#define SCM_HEAP_FRAME_DYNAMIC_LINK(f)	SCM_HEAP_FRAME_DATA (f)->dynamic_link
+#define SCM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_HEAP_FRAME_DATA (f)->external_link
+
+extern SCM scm_c_make_heap_frame (SCM *fp);
+extern void scm_init_frames (void);
+
+#endif /* _SCM_FRAMES_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/objcodes.c

@@ -194,14 +194,16 @@ SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
   SCM prog;
   size_t size;
   char *base;
+  struct scm_program *p;
 
   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];
+  p = SCM_PROGRAM_DATA (prog);
-  SCM_PROGRAM_NEXTS (prog) = base[9];
+  p->nlocs = base[8];
+  p->nexts = base[9];
   return prog;
 }
 #undef FUNC_NAME

src/programs.c

@@ -59,6 +59,7 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
   p->nrest    = 0;
   p->nlocs    = 0;
   p->nexts    = 0;
+  p->meta     = SCM_BOOL_F;
   p->objs     = zero_vector;
   p->external = SCM_EOL;
   p->holder   = holder;
@@ -78,7 +79,7 @@ scm_c_make_closure (SCM program, SCM external)
 {
   SCM prog = scm_c_make_program (0, 0, program);
   *SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program);
-  SCM_PROGRAM_EXTERNAL (prog) = external;
+  SCM_PROGRAM_DATA (prog)->external = external;
   return prog;
 }
 
@@ -86,6 +87,7 @@ static SCM
 program_mark (SCM obj)
 {
   struct scm_program *p = SCM_PROGRAM_DATA (obj);
+  scm_gc_mark (p->meta);
   scm_gc_mark (p->objs);
   scm_gc_mark (p->external);
   return p->holder;
@@ -105,19 +107,6 @@ program_free (SCM obj)
   return size;
 }
 
-static int
-program_print (SCM obj, SCM port, scm_print_state *pstate)
-{
-  SCM name = scm_object_property (obj, scm_sym_name);
-  scm_puts ("#<program ", port);
-  if (SCM_FALSEP (name))
-    scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
-  else
-    scm_display (name, port);
-  scm_putc ('>', port);
-  return 1;
-}
-
 static SCM
 program_apply (SCM program, SCM args)
 {
@@ -138,16 +127,41 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_base
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  return scm_long2num ((long) SCM_PROGRAM_DATA (program)->base);
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
 	    (SCM program),
 	    "")
 #define FUNC_NAME s_scm_program_arity
 {
+  struct scm_program *p;
+
   SCM_VALIDATE_PROGRAM (1, program);
-  return SCM_LIST4 (SCM_MAKINUM (SCM_PROGRAM_NARGS (program)),
+
-		    SCM_MAKINUM (SCM_PROGRAM_NREST (program)),
+  p = SCM_PROGRAM_DATA (program);
-		    SCM_MAKINUM (SCM_PROGRAM_NLOCS (program)),
+  return SCM_LIST4 (SCM_MAKINUM (p->nargs),
-		    SCM_MAKINUM (SCM_PROGRAM_NEXTS (program)));
+		    SCM_MAKINUM (p->nrest),
+		    SCM_MAKINUM (p->nlocs),
+		    SCM_MAKINUM (p->nexts));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_meta
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return SCM_PROGRAM_DATA (program)->meta;
 }
 #undef FUNC_NAME
 
@@ -157,7 +171,7 @@ SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
 #define FUNC_NAME s_scm_program_objects
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  return SCM_PROGRAM_OBJS (program);
+  return SCM_PROGRAM_DATA (program)->objs;
 }
 #undef FUNC_NAME
 
@@ -167,7 +181,7 @@ SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
 #define FUNC_NAME s_scm_program_external
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  return SCM_PROGRAM_EXTERNAL (program);
+  return SCM_PROGRAM_DATA (program)->external;
 }
 #undef FUNC_NAME
 
@@ -177,8 +191,8 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
 #define FUNC_NAME s_scm_program_bytecode
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  return scm_makfromstr (SCM_PROGRAM_BASE (program),
+  return scm_makfromstr (SCM_PROGRAM_DATA (program)->base,
-			 SCM_PROGRAM_SIZE (program), 0);
+			 SCM_PROGRAM_DATA (program)->size, 0);
 }
 #undef FUNC_NAME
 
@@ -191,7 +205,6 @@ scm_init_programs (void)
   scm_tc16_program = scm_make_smob_type ("program", 0);
   scm_set_smob_mark (scm_tc16_program, program_mark);
   scm_set_smob_free (scm_tc16_program, program_free);
-  scm_set_smob_print (scm_tc16_program, program_print);
   scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
 
 #ifndef SCM_MAGIC_SNARFER

src/programs.h

@@ -58,6 +58,7 @@ struct scm_program {
   unsigned char nlocs;		/* the number of local variables */
   unsigned char nexts;		/* the number of external variables */
   scm_byte_t *base;		/* program base address */
+  SCM meta;			/* meta data */
   SCM objs;			/* constant objects */
   SCM external;			/* external environment */
   SCM holder;			/* the owner of bytecode */
@@ -69,18 +70,6 @@ extern scm_bits_t scm_tc16_program;
 #define SCM_PROGRAM_DATA(x)	((struct scm_program *) SCM_SMOB_DATA (x))
 #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
 
-#define SCM_PROGRAM_SIZE(x)	(SCM_PROGRAM_DATA (x)->size)
-#define SCM_PROGRAM_NARGS(x)	(SCM_PROGRAM_DATA (x)->nargs)
-#define SCM_PROGRAM_NREST(x)	(SCM_PROGRAM_DATA (x)->nrest)
-#define SCM_PROGRAM_NLOCS(x)	(SCM_PROGRAM_DATA (x)->nlocs)
-#define SCM_PROGRAM_NEXTS(x)	(SCM_PROGRAM_DATA (x)->nexts)
-#define SCM_PROGRAM_BASE(x)	(SCM_PROGRAM_DATA (x)->base)
-#define SCM_PROGRAM_META(x)	(SCM_PROGRAM_DATA (x)->meta)
-#define SCM_PROGRAM_OBJS(x)	(SCM_PROGRAM_DATA (x)->objs)
-#define SCM_PROGRAM_LINKS(x)	(SCM_PROGRAM_DATA (x)->links)
-#define SCM_PROGRAM_EXTERNAL(x)	(SCM_PROGRAM_DATA (x)->external)
-#define SCM_PROGRAM_HOLDER(x)	(SCM_PROGRAM_DATA (x)->holder)
-
 extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
 extern SCM scm_c_make_closure (SCM program, SCM external);
 

src/vm.c

@@ -40,10 +40,11 @@
  * If you do not wish that, delete this exception notice.  */
 
 #include <string.h>
-#include "instructions.h"
-#include "programs.h"
-#include "objcodes.h"
 #include "envs.h"
+#include "frames.h"
+#include "instructions.h"
+#include "objcodes.h"
+#include "programs.h"
 #include "vm.h"
 
 /* I sometimes use this for debugging. */
@@ -53,119 +54,6 @@
   scm_newline (scm_def_errp);			\
 }
 
-
-/*
- * VM Heap frame
- */
-
-scm_bits_t scm_tc16_vm_heap_frame;
-
-static SCM
-make_vm_heap_frame (SCM *fp)
-{
-  struct scm_vm_heap_frame *p =
-    scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame");
-  p->fp            = fp;
-  p->program       = SCM_UNDEFINED;
-  p->variables     = SCM_UNDEFINED;
-  p->dynamic_link  = SCM_UNDEFINED;
-  p->external_link = SCM_UNDEFINED;
-  SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p);
-}
-
-static SCM
-vm_heap_frame_mark (SCM obj)
-{
-  struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj);
-  scm_gc_mark (p->program);
-  scm_gc_mark (p->variables);
-  scm_gc_mark (p->dynamic_link);
-  return p->external_link;
-}
-
-/* Scheme interface */
-
-SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
-	    (SCM obj),
-	    "")
-#define FUNC_NAME s_scm_frame_p
-{
-  return SCM_BOOL (SCM_VM_HEAP_FRAME_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
-	    (SCM frame),
-	    "")
-#define FUNC_NAME s_scm_frame_program
-{
-  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
-  return SCM_VM_FRAME_PROGRAM (SCM_VM_HEAP_FRAME_DATA (frame)->fp);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
-	    (SCM frame),
-	    "")
-#define FUNC_NAME s_scm_frame_variables
-{
-  struct scm_vm_heap_frame *p;
-
-  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
-  p = SCM_VM_HEAP_FRAME_DATA (frame);
-
-  if (SCM_UNBNDP (p->variables))
-    {
-      SCM prog = scm_frame_program (frame);
-      int i, size = SCM_PROGRAM_NARGS (prog) + SCM_PROGRAM_NLOCS (prog);
-      p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
-      for (i = 0; i < size; i++)
-	SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (p->fp, i);
-    }
-  return p->variables;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
-	    (SCM frame),
-	    "")
-#define FUNC_NAME s_scm_frame_dynamic_link
-{
-  struct scm_vm_heap_frame *p;
-
-  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
-  p = SCM_VM_HEAP_FRAME_DATA (frame);
-
-  if (SCM_UNBNDP (p->dynamic_link))
-    {
-      SCM *fp = SCM_VM_STACK_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (p->fp));
-      if (fp)
-	p->dynamic_link = make_vm_heap_frame (fp);
-      else
-	p->dynamic_link = SCM_BOOL_F;
-    }
-
-  return p->dynamic_link;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
-	    (SCM frame),
-	    "")
-#define FUNC_NAME s_scm_frame_external_link
-{
-  struct scm_vm_heap_frame *p;
-
-  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
-  p = SCM_VM_HEAP_FRAME_DATA (frame);
-
-  if (SCM_UNBNDP (p->external_link))
-    p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (p->fp);
-
-  return p->external_link;
-}
-#undef FUNC_NAME
-
 
 /*
  * VM Continuation
@@ -303,6 +191,7 @@ make_vm (void)
   vp->time        = 0;
   vp->clock       = 0;
   vp->options     = SCM_EOL;
+  vp->last_frame  = SCM_BOOL_F;
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
     vp->hooks[i] = SCM_BOOL_F;
   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
@@ -321,8 +210,8 @@ vm_mark (SCM obj)
   fp = vp->fp;
   while (fp)
     {
-      SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp);
+      SCM *upper = SCM_STACK_FRAME_UPPER_ADDRESS (fp);
-      SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp);
+      SCM *lower = SCM_STACK_FRAME_LOWER_ADDRESS (fp);
       /* Mark intermediate data */
       for (; sp >= upper; sp--)
 	if (SCM_NIMP (*sp))
@@ -337,6 +226,7 @@ vm_mark (SCM obj)
   /* Mark the options */
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
     scm_gc_mark (vp->hooks[i]);
+  scm_gc_mark (vp->last_frame);
   return vp->options;
 }
 
@@ -553,7 +443,17 @@ SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
 {
   SCM_VALIDATE_VM (1, vm);
   VM_CHECK_RUNNING (vm);
-  return make_vm_heap_frame (SCM_VM_DATA (vm)->fp);
+  return scm_c_make_heap_frame (SCM_VM_DATA (vm)->fp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_last_frame
+{
+  SCM_VALIDATE_VM (1, vm);
+  return SCM_VM_DATA (vm)->last_frame;
 }
 #undef FUNC_NAME
 
@@ -593,7 +493,7 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
   VM_CHECK_RUNNING (vm);
 
   vp = SCM_VM_DATA (vm);
-  for (sp = SCM_VM_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
+  for (sp = SCM_STACK_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
     ls = scm_cons (*sp, ls);
   return ls;
 }
@@ -607,12 +507,10 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
 void
 scm_init_vm (void)
 {
+  scm_init_frames ();
   scm_init_instructions ();
-  scm_init_programs ();
   scm_init_objcodes ();
-
+  scm_init_programs ();
-  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);
 
   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
   scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);

src/vm.h

@@ -44,76 +44,6 @@
 
 #include <libguile.h>
 #include "config.h"
-#include "programs.h"
-
-/*
- * VM Address
- */
-
-#define SCM_VM_MAKE_STACK_ADDRESS(ptr)	SCM_PACK (ptr)
-#define SCM_VM_STACK_ADDRESS(addr)	((SCM *) SCM_UNPACK (addr))
-
-#define SCM_VM_MAKE_BYTE_ADDRESS(ptr)	SCM_PACK (ptr)
-#define SCM_VM_BYTE_ADDRESS(addr)	((scm_byte_t *) SCM_UNPACK (addr))
-
-/*
- * VM Stack frame
- */
-
-/*
-   |                  | <- fp + bp->nargs + bp->nlocs + 3
-   +------------------+    = SCM_VM_FRAME_UPPER_ADDRESS (fp)
-   | Return address   |
-   | Dynamic link     |
-   | External link    | <- fp + bp->nargs + bp->nlocs
-   | Local varialbe 1 |    = SCM_VM_FRAME_DATA_ADDRESS (fp)
-   | Local variable 0 | <- fp + bp->nargs
-   | Argument 1       |
-   | Argument 0       | <- fp
-   | Program          | <- fp - 1
-   +------------------+    = SCM_VM_FRAME_LOWER_ADDRESS (fp)
-   |                  |
-*/
-
-#define SCM_VM_FRAME_DATA_ADDRESS(fp)			\
-  (fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp))	\
-      + SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp)))
-#define SCM_VM_FRAME_UPPER_ADDRESS(fp)			\
-  (SCM_VM_FRAME_DATA_ADDRESS (fp) + 3)
-#define SCM_VM_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
-
-#define SCM_VM_FRAME_RETURN_ADDRESS(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[2]
-#define SCM_VM_FRAME_DYNAMIC_LINK(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[1]
-#define SCM_VM_FRAME_EXTERNAL_LINK(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[0]
-#define SCM_VM_FRAME_VARIABLE(fp,i)	fp[i]
-#define SCM_VM_FRAME_PROGRAM(fp)	fp[-1]
-
-/*
- * VM Heap frame
- */
-
-struct scm_vm_heap_frame {
-  SCM *fp;
-  SCM program;
-  SCM variables;
-  SCM dynamic_link;
-  SCM external_link;
-};
-
-extern scm_bits_t scm_tc16_vm_heap_frame;
-
-#define SCM_VM_HEAP_FRAME_P(x)	SCM_SMOB_PREDICATE (scm_tc16_vm_heap_frame, x)
-#define SCM_VM_HEAP_FRAME_DATA(f) ((struct scm_vm_heap_frame *) SCM_SMOB_DATA (f))
-#define SCM_VALIDATE_VM_HEAP_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, VM_HEAP_FRAME_P)
-
-#define SCM_VM_HEAP_FRAME_PROGRAM(f)	SCM_VM_HEAP_FRAME_DATA (f)->program
-#define SCM_VM_HEAP_FRAME_VARIABLES(f)	SCM_VM_HEAP_FRAME_DATA (f)->variables
-#define SCM_VM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->dynamic_link
-#define SCM_VM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->external_link
-
-/*
- * VM
- */
 
 #define SCM_VM_BOOT_HOOK	0
 #define SCM_VM_HALT_HOOK	1
@@ -133,6 +63,7 @@ struct scm_vm {
   SCM *stack_limit;		/* stack limit address */
   SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
   SCM options;			/* options */
+  SCM last_frame;		/* last frame */
   unsigned long time;		/* time spent */
   unsigned long clock;		/* bogos clock */
 };

src/vm_engine.c

@@ -88,7 +88,7 @@ vm_run (SCM vm, SCM program, SCM args)
 
     /* Boot program */
     scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
-    bytes[1] = scm_ilength (args);
+    bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
     program = scm_c_make_program (bytes, 3, SCM_BOOL_T);
 
     /* Initial frame */
@@ -167,10 +167,8 @@ vm_run (SCM vm, SCM program, SCM args)
 
   vm_error:
     SYNC_ALL ();
-    scm_ithrow (sym_vm_error,
+    vp->last_frame = scm_vm_current_frame (vm);
-		SCM_LIST4 (sym_vm_run, err_msg, err_args,
+    scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1);
-			   scm_vm_current_frame (vm)),
-		1);
   }
 
   abort (); /* never reached */

src/vm_engine.h

@@ -286,7 +286,7 @@ do {						\
     }						\
 }
 
-/* See vm.h for the layout of stack frames */
+/* See frames.h for the layout of stack frames */
 
 #define NEW_FRAME()				\
 {						\

src/vm_loader.c

@@ -109,18 +109,27 @@ VM_DEFINE_LOADER (load_program, "load-program")
 {
   size_t len;
   SCM prog, x;
+  struct scm_program *p;
 
   FETCH_LENGTH (len);
   prog = scm_c_make_program (ip, len, program);
+  p = SCM_PROGRAM_DATA (prog);
   ip += len;
 
+  POP (x);
+
+  /* init meta data */
+  if (SCM_CONSP (x))
+    {
+      p->meta = x;
+      POP (x);
+    }
+
   /* init object table */
-  x = *sp;
   if (SCM_VECTORP (x))
     {
-      SCM_PROGRAM_OBJS (prog) = x;
+      p->objs = x;
-      DROP ();
+      POP (x);
-      x = *sp;
     }
 
   /* init parameters */
@@ -131,31 +140,31 @@ VM_DEFINE_LOADER (load_program, "load-program")
       if (-128 <= i && i <= 127)
 	{
 	  /* 8-bit representation */
-	  SCM_PROGRAM_NARGS (prog) = (i >> 6) & 0x03;	/* 7-6 bits */
+	  p->nargs = (i >> 6) & 0x03;	/* 7-6 bits */
-	  SCM_PROGRAM_NREST (prog) = (i >> 5) & 0x01;	/*   5 bit  */
+	  p->nrest = (i >> 5) & 0x01;	/*   5 bit  */
-	  SCM_PROGRAM_NLOCS (prog) = (i >> 2) & 0x07;	/* 4-2 bits */
+	  p->nlocs = (i >> 2) & 0x07;	/* 4-2 bits */
-	  SCM_PROGRAM_NEXTS (prog) = i & 0x03;		/* 1-0 bits */
+	  p->nexts = i & 0x03;		/* 1-0 bits */
 	}
       else
 	{
 	  /* 16-bit representation */
-	  SCM_PROGRAM_NARGS (prog) = (i >> 12) & 0x07;	/* 15-12 bits */
+	  p->nargs = (i >> 12) & 0x07;	/* 15-12 bits */
-	  SCM_PROGRAM_NREST (prog) = (i >> 11) & 0x01;	/*    11 bit  */
+	  p->nrest = (i >> 11) & 0x01;	/*    11 bit  */
-	  SCM_PROGRAM_NLOCS (prog) = (i >> 4)  & 0x7f;	/* 10-04 bits */
+	  p->nlocs = (i >> 4)  & 0x7f;	/* 10-04 bits */
-	  SCM_PROGRAM_NEXTS (prog) = i & 0x0f;		/* 03-00 bits */
+	  p->nexts = i & 0x0f;		/* 03-00 bits */
 	}
     }
   else
     {
       /* Other cases */
       sp -= 4;
-      SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[1]);
+      p->nargs = SCM_INUM (sp[0]);
-      SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
+      p->nrest = SCM_INUM (sp[1]);
-      SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[3]);
+      p->nlocs = SCM_INUM (sp[2]);
-      SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[4]);
+      p->nexts = SCM_INUM (sp[3]);
     }
 
-  *sp = prog;
+  PUSH (prog);
   NEXT;
 }
 

src/vm_system.c

@@ -187,8 +187,8 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
 #define OBJECT_REF(i)		objects[i]
 #define OBJECT_SET(i,o)		objects[i] = o
 
-#define LOCAL_REF(i)		SCM_VM_FRAME_VARIABLE (fp, i)
+#define LOCAL_REF(i)		SCM_STACK_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o)		SCM_VM_FRAME_VARIABLE (fp, i) = o
+#define LOCAL_SET(i,o)		SCM_STACK_FRAME_VARIABLE (fp, i) = o
 
 #define VARIABLE_REF(v)		SCM_CDR (v)
 #define VARIABLE_SET(v,o)	SCM_SETCDR (v, o)
@@ -379,7 +379,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
       EXIT_HOOK ();
       reinstate_vm_cont (vp, x);
       CACHE_REGISTER ();
-      program = SCM_VM_FRAME_PROGRAM (fp);
+      program = SCM_STACK_FRAME_PROGRAM (fp);
       CACHE_PROGRAM ();
       NEXT;
     }
@@ -496,7 +496,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
   FREE_FRAME ();
 
   /* Restore the last program */
-  program = SCM_VM_FRAME_PROGRAM (fp);
+  program = SCM_STACK_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
   external = fp[bp->nargs + bp->nlocs];
   PUSH (ret);