Better current module system support.

module/system/base/language.scm

@@ -28,8 +28,7 @@
   :use-module (system vm assemble)
   :use-module (ice-9 regex)
   :export (define-language lookup-language
-	    read-in compile-in print-in compile-file-in load-file-in
-	    hacked-load-in))
+	    read-in compile-in print-in compile-file-in load-file-in))
 
 
 ;;;
@@ -108,10 +107,6 @@
 	  (uniform-vector-read! bytes p)
 	  bytes)))))
 
-(define (hacked-load-in file lang)
-  ((vm-load (make-vm)
-	    (load-file-in file (global-ref 'user) (lookup-language lang)))))
-
 (define (object-file-name file)
   (let ((m (string-match "\\.[^.]*$" file)))
     (string-append (if m (match:prefix m) file) ".go")))

module/system/base/module.scm

@@ -216,7 +216,3 @@
 (let ((core (make-vmodule)))
   (env-define *root-package* 'core core)
   (hash-fold (lambda (s v d) (env-define core s v)) #f (builtin-bindings)))
-
-(let ((module (make-vmodule)))
-  (env-define (global-ref 'System::Base) 'module module)
-  (import-old-module! module (current-module)))

module/system/il/compile.scm

@@ -22,7 +22,6 @@
 (define-module (system il compile)
   :use-module (oop goops)
   :use-syntax (system base syntax)
-  :use-module (system base module)
   :use-module (system il glil)
   :use-module (system il ghil)
   :use-module (ice-9 common-list)

module/system/il/ghil.scm

@@ -22,7 +22,6 @@
 (define-module (system il ghil)
   :use-module (oop goops)
   :use-syntax (system base syntax)
-  :use-module (system base module)
   :use-module (ice-9 match)
   :use-module (ice-9 regex)
   :export
@@ -83,7 +82,8 @@
 
 (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 (env-identifier mod.module) sym 'module)))
+      (let ((var (make-ghil-var #f sym 'module)))
 	(set! mod.table (acons sym var mod.table))
 	var)))
 

module/system/repl/repl.scm

@@ -65,10 +65,10 @@
     error-handler))
 
 (define (error-handler key . args)
-  (case key
-    ((vm-error)
-     (write (frame->call (cadddr args)))
-     (newline)))
+;;   (case key
+;;     ((vm-error)
+;;      (write (frame->call (cadddr args)))
+;;      (newline)))
   (display "ERROR: ")
   (apply format #t (cadr args) (caddr args))
   (newline))

module/system/vm/assemble.scm

@@ -21,7 +21,6 @@
 
 (define-module (system vm assemble)
   :use-syntax (system base syntax)
-  :use-module (system base module)
   :use-module (system il glil)
   :use-module (system vm core)
   :use-module (system vm conv)
@@ -119,15 +118,15 @@
 				   (+ index i))))))
 
 	   (($ <glil-module> op module name)
-	    (let ((mod (make-vmod module)))
 	    (if toplevel
 		(begin
 		  ;; (push-code! `(load-module ,module))
 		  (push-code! `(load-symbol ,name))
 		  (push-code! `(link/current-module)))
-		  (let ((vlink (make-vlink mod name)))
+		;; (let ((vlink (make-vlink (make-vmod module) name)))
+		(let ((vlink (make-vlink #f name)))
 		  (push-code! `(object-ref ,(object-index vlink)))))
-	      (push-code! (list (symbol-append 'variable- op)))))
+	    (push-code! (list (symbol-append 'variable- op))))
 
 	   (($ <glil-label> label)
 	    (label-set label (current-address)))
@@ -263,7 +262,7 @@
 (define (build-object-table bytespec)
   (let ((table '()) (index 0))
     (define (insert! x)
-      (if (vlink? x) (begin (insert! (vlink-module x))))
+      ;; (if (vlink? x) (begin (insert! (vlink-module x))))
       (if (not (object-find table x))
 	  (begin
 	    (set! table (acons x index table))

module/system/vm/load.scm

@@ -0,0 +1,54 @@
+;;; Guile VM compiling loader
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm load)
+  :use-module (system vm core)
+  :autoload (system base module) (global-ref)
+  :autoload (system base language) (compile-file-in lookup-language)
+  :use-module (ice-9 regex)
+  :export (load/compile))
+
+(define *the-vm* (make-vm))
+
+(define (load/compile file)
+  (let* ((file (file-name-full-name file))
+	 (compiled (object-file-name file)))
+    (if (or (not (file-exists? compiled))
+	    (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
+	(compile-file-in file (global-ref 'user) (lookup-language 'r5rs)))
+    (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
+      (call-with-input-file compiled
+	(lambda (p) (uniform-vector-read! bytes p)))
+      ((vm-load *the-vm* bytes)))))
+
+(define (file-name-full-name filename)
+  (let ((oldname (and (current-load-port)
+		      (port-filename (current-load-port)))))
+    (if (and oldname
+	     (> (string-length filename) 0)
+	     (not (char=? (string-ref filename 0) #\/))
+	     (not (string=? (dirname oldname) ".")))
+	(string-append (dirname oldname) "/" filename)
+	filename)))
+
+(define (object-file-name file)
+  (let ((m (string-match "\\.[^.]*$" file)))
+    (string-append (if m (match:prefix m) file) ".go")))

module/system/vm/trace.scm

@@ -20,9 +20,6 @@
 ;;; Code:
 
 (define-module (system vm trace)
-  :use-module (oop goops)
-  :use-syntax (system base syntax)
-  :use-module (system base module)
   :use-module (system vm core)
   :use-module (system vm frame)
   :use-module (ice-9 format)