*** empty log message ***

README

@@ -3,19 +3,17 @@ Installation
 
 1. Install the latest Guile from CVS.
 
-2. Install slib.
+2. Install Guile VM:
-
-3. Install Guile VM:
 
   % configure
   % make install
   % ln -s module/{system,language} /usr/local/share/guile/site/
 
-4. Add the following lines to your ~/.guile:
+3. Add the following lines to your ~/.guile:
 
   (cond ((string=? (car (command-line)) "guile-vm")
 	 (use-modules (system repl repl))
-	 (start-repl 'gscheme)
+	 (start-repl 'scheme)
 	 (quit)))
 
 Example Session

module/language/gscheme/spec.scm

@@ -1,139 +0,0 @@
-;;; Guile Scheme specification
-
-;; 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 (language gscheme spec)
-  :use-module (system base language)
-  :use-module (system il ghil)
-  :use-module (ice-9 match)
-  :use-module (ice-9 and-let-star)
-  :export (gscheme))
-
-
-;;;
-;;; Translator
-;;;
-
-(define (translate x) (if (pair? x) (translate-pair x) x))
-
-(define (translate-pair x)
-  (let ((head (car x)) (rest (cdr x)))
-    (case head
-      ((quote) `(@quote ,@rest))
-      ((set! if and or begin)
-       (cons (symbol-append '@ head) (map translate rest)))
-      ((define)
-       (match rest
-	 ((((? symbol? name) . args) . body)
-	  `(@define ,name (@lambda ,args ,@(map translate body))))
-	 (((? symbol? name) val)
-	  `(@define ,name ,(translate val)))
-	 (else (error "Syntax error:" x))))
-      ((lambda)
-       `(@lambda ,(car rest) ,@(map translate (cdr rest))))
-      ((let let* letrec)
-       (match x
-	 (('let (? symbol? f) ((s v) ...) body ...)
-	  `(@letrec ((,f (@lambda ,s ,@(map translate body))))
-		    (,f ,@(map translate v))))
-	 (else
-	  (cons* (symbol-append '@ head)
-		 (map (lambda (b) (cons (car b) (map translate (cdr b))))
-		      (car rest))
-		 (map translate (cdr rest))))))
-      ((cond)
-       (let loop ((x rest))
-	 (match x
-	   (() '(@void))
-	   ((('else . body)) `(@begin ,@(map translate body)))
-	   (((test) . rest) `(@or ,(translate test) ,(loop rest)))
-	   (((test '=> proc) . rest)
-	    `(@let ((_t ,(translate test)))
-		   (@if _t (,(translate proc) _t) ,(loop rest))))
-	   (((test . body) . rest)
-	    `(@if ,(translate test)
-		  (@begin ,@(map translate body))
-		  ,(loop rest)))
-	   (else (error "bad cond" x)))))
-      ((case)
-       `(@let ((_t ,(translate (car rest))))
-	      ,(let loop ((x (cdr rest)))
-		 (match x
-		   (() '(@void))
-		   ((('else . body)) `(@begin ,@(map translate body)))
-		   ((((keys ...) . body) . rest)
-		    `(@if (@memv _t (@quote ,keys))
-			  (@begin ,@(map translate body))
-			  ,(loop rest)))
-		   (else (error "bad cond" x))))))
-      ((do)
-       (match rest
-	 ((((sym init . update) ...) (test . result) body ...)
-	  (define (translate-update s x)
-	    (if (pair? x) (translate (car x)) s))
-	  `(@letrec ((_loop (@lambda
-			     ,sym
-			     (@if ,(translate test)
-				  (@begin ,@(map translate result))
-				  (@begin ,@(map translate body)
-					  (_loop ,@(map translate-update
-							sym update)))))))
-		    (_loop ,@(map translate init))))))
-
-      ((eval-case)
-       `(@eval-case
-	 ,@(let loop ((x rest))
-	     (match x
-	       (() '(()))
-	       ((('else . body)) `((@else ,@(map translate body))))
-	       (((keys . body) . rest)
-		`((,keys ,@(map translate body)) ,@(loop rest)))
-	       (else (error "bad eval-case" x))))))
-
-      (else
-       (let ((e (expand x)))
-	 (if (eq? e x)
-	     (let ((prim (and (symbol? head) (symbol-append '@ head))))
-	       (if (and prim (ghil-primitive? prim))
-		   (cons prim (map translate rest))
-		   (cons (translate head) (map translate rest))))
-	     (translate e)))))))
-
-(define (expand x)
-  (if (and (symbol? (car x))
-	   (module-defined? (current-module) (car x)))
-      (let ((v (module-ref (current-module) (car x))))
-	(if (defmacro? v)
-	    (apply (defmacro-transformer v) (cdr x))
-	    x))
-      x))
-
-
-;;;
-;;; Language definition
-;;;
-
-(define-language gscheme
-  :title	"Guile Scheme"
-  :version	"0.4"
-  :reader	read
-  :translator	translate
-  :printer	write
-  )

module/language/scheme/spec.scm

@@ -0,0 +1,54 @@
+;;; Guile Scheme specification
+
+;; 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 (language scheme spec)
+  :use-module (language scheme translate)
+  :use-module (system base language)
+  :export (scheme))
+
+;;;
+;;; Reader
+;;;
+
+(read-enable 'positions)
+
+;;;
+;;; Compiler
+;;;
+
+(define (compile port env . opts)
+  (do ((x (read port) (read port))
+       (l '() (cons x l)))
+      ((eof-object? x)
+       (apply compile-in (cons 'begin (reverse! l)) env scheme opts))))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language scheme
+  :title	"Guile Scheme"
+  :version	"0.5"
+  :reader	read
+  :translator	translate
+  :printer	write
+  :compiler	compile
+  )

module/language/scheme/translate.scm

@@ -0,0 +1,277 @@
+;;; Guile Scheme specification
+
+;; 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 (language scheme translate)
+  :use-module (system base language)
+  :use-module (system il ghil)
+  :use-module (ice-9 match)
+  :use-module (ice-9 receive)
+  :export (translate))
+
+(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)))))
+
+
+;;;
+;;; Translator
+;;;
+
+(define (trans e l x)
+  (cond ((pair? x)
+	 (let ((y (macroexpand x)))
+	   (if (eq? x y)
+	       (trans-pair e (or (location x) l) (car x) (cdr x))
+	       (trans e l y))))
+	((symbol? x) (make-<ghil-ref> e l (ghil-lookup e x)))
+	(else (make-<ghil-quote> e l x))))
+
+(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 (bad-syntax)
+    (syntax-error l (format #f "bad ~A" head) (cons head tail)))
+  (case head
+    ;; (void)
+    ((void)
+     (match tail
+       (() (make:void))
+       (else (bad-syntax))))
+
+    ;; (quote OBJ)
+    ((quote)
+     (match tail
+       ((obj) (make-<ghil-quote> e l obj))
+       (else (bad-syntax))))
+
+    ;; (quasiquote OBJ)
+    ((quasiquote)
+     (match tail
+       ((obj) (make-<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)))
+
+       ;; (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)))
+
+       (else (bad-syntax))))
+
+    ((set!)
+     (match tail
+       ;; (set! NAME VAL)
+       (((? symbol? name) val)
+	(make-<ghil-set> e l (ghil-lookup e name) (trans:x val)))
+
+       ;; (set! (NAME ARGS...) VAL)
+       ((((? symbol? name) . args) val)
+	;; -> ((setter NAME) ARGS... VAL)
+	(trans:pair `((setter ,name) (,@args ,val))))
+
+       (else (bad-syntax))))
+
+    ;; (if TEST THEN [ELSE])
+    ((if)
+     (match tail
+       ((test then)
+	(make-<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)))
+       (else (bad-syntax))))
+
+    ;; (and EXPS...)
+    ((and)
+     (make-<ghil-and> e l (map trans:x tail)))
+
+    ;; (or EXPS...)
+    ((or)
+     (make-<ghil-or> e l (map trans:x tail)))
+
+    ;; (begin EXPS...)
+    ((begin)
+     (make-<ghil-begin> e l (map trans:x tail)))
+
+    ((let)
+     (match tail
+       ;; (let NAME ((SYM VAL) ...) BODY...)
+       (((? symbol? name) (((? symbol? sym) val) ...) body ...)
+	;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
+	(trans:pair `(letrec ((,name (lambda ,sym ,@body))) (,name ,@val))))
+
+       ;; (let () BODY...)
+       ((() body ...)
+	;; NOTE: This differs from `begin'
+	(make-<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))))))
+
+       (else (bad-syntax))))
+
+    ;; (let* ((SYM VAL) ...) BODY...)
+    ((let*)
+     (match tail
+       (((def ...) body ...)
+	(if (null? def)
+	    (trans:pair `(let () ,@body))
+	    (trans:pair `(let (,(car def)) (let* ,(cdr def) ,@body)))))
+       (else (bad-syntax))))
+
+    ;; (letrec ((SYM VAL) ...) BODY...)
+    ((letrec)
+     (match tail
+       (((((? symbol? sym) val) ...) body ...)
+	(call-with-ghil-bindings e sym
+	  (lambda (vars)
+	    (let ((vals (map trans:x val)))
+	      (make-<ghil-bind> e l vars vals (trans:body body))))))
+       (else (bad-syntax))))
+
+    ;; (cond (CLAUSE BODY...) ...)
+    ((cond)
+     (match tail
+       (() (make:void))
+       ((('else . body)) (trans:body body))
+       (((test) . rest) (trans:pair `(or ,test (cond ,@rest))))
+       (((test '=> proc) . rest)
+	(trans:pair `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
+       (((test . body) . rest)
+	(trans:pair `(if ,test (begin ,@body) (cond ,@rest))))
+       (else (bad-syntax))))
+
+    ;; (case EXP ((KEY...) BODY...) ...)
+    ((case)
+     (match tail
+       ((exp . clauses)
+	(trans:pair
+	 `(let ((_t ,exp))
+	    ,(let loop ((ls clauses))
+	       (cond ((null? ls) '(void))
+		     ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
+		     (else `(if (memv _t ',(caar ls))
+				(begin ,@(cdar ls))
+				,(loop (cdr ls)))))))))
+       (else (bad-syntax))))
+
+    ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
+    ((do)
+     (let ()
+       (define (next s x) (if (pair? x) (car x) s))
+       (match tail
+	 ((((sym init . update) ...) (test . result) body ...)
+	  (trans:pair
+	   `(letrec ((_l (lambda ,sym
+			   (if ,test
+			       (let () (void) ,@result)
+			       (let () (void) ,@body
+				    (_l ,@(map next sym update)))))))
+	      (_l ,@init))))
+	 (else (bad-syntax)))))
+
+    ;; (lambda FORMALS BODY...)
+    ((lambda)
+     (match tail
+       ((formals body ...)
+	(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))))))
+       (else (bad-syntax))))
+
+    ((eval-case)
+     (let loop ((x tail))
+       (match x
+	 (() (make:void))
+	 ((('else . body)) (trans:pair `(begin ,@body)))
+	 (((((? symbol? key) ...) body ...) rest ...)
+	  (if (memq 'compile key)
+	      (primitive-eval `(begin ,@(copy-tree body))))
+	  (if (memq 'load-toplevel key)
+	      (trans:pair `(begin ,@body))
+	      (loop rest)))
+	 (else (bad-syntax)))))
+
+    (else
+     (make-<ghil-call> e l (trans:x head) (map trans:x tail)))))
+
+(define (trans-quasiquote e l x)
+  (cond ((not (pair? x)) x)
+	((memq (car x) '(unquote unquote-splicing))
+	 (let ((l (location x)))
+	   (match (cdr x)
+	     ((obj)
+	      (if (eq? (car x) 'unquote)
+		  (make-<ghil-unquote> e l (trans e l obj))
+		  (make-<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))))))
+
+(define (trans-body e l body)
+  (define (define->binding df)
+    (match (cdr df)
+      (((? symbol? name) val) (list name val))
+      ((((? symbol? name) . formals) . body)
+       (list name `(lambda ,formals ,@body)))
+      (else (syntax-error (location df) "bad define" df))))
+  ;; main
+  (let loop ((ls body) (ds '()))
+    (cond ((null? ls) (syntax-error l "bad body" body))
+	  ((and (pair? (car ls)) (eq? (caar ls) 'define))
+	   (loop (cdr ls) (cons (car ls) ds)))
+	  (else
+	   (if (null? ds)
+	       (trans-pair e l 'begin ls)
+	       (trans-pair e l 'letrec (cons (map define->binding ds) ls)))))))
+
+(define (parse-formals formals)
+  (cond
+   ;; (lambda x ...)
+   ((symbol? formals) (values (list formals) #t))
+   ;; (lambda (x y z) ...)
+   ((list? formals) (values formals #f))
+   ;; (lambda (x y . z) ...)
+   ((pair? formals)
+    (let loop ((l formals) (v '()))
+      (if (pair? l)
+	  (loop (cdr l) (cons (car l) v))
+	  (values (reverse! (cons l v)) #t))))
+   (else (syntax-error (location formals) "bad formals" formals))))
+
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (not (null? props))
+	      (cons (assq-ref props 'line) (assq-ref props 'column))))))

module/slib/.cvsignore

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

module/slib/guile.init

@@ -88,8 +88,8 @@
 					;CALL-WITH-OUTPUT-STRING
 ;	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
 	char-ready?
-	macro				;has R4RS high level macros
+;	macro				;has R4RS high level macros
-	macro-by-example
+;	macro-by-example
 	defmacro			;has Common Lisp DEFMACRO
 	eval				;R5RS two-argument eval
 	record				;has user defined data structures
@@ -126,7 +126,7 @@
 	logical
 	promise
 	string-case
-	syntax-case
+;	syntax-case
 	))
 
 ;; time
@@ -223,7 +223,7 @@
 ;;; by compiling "foo.scm" if this implementation can compile files.
 ;;; See feature 'COMPILED.
 
-(define slib:load-compiled load)
+(define slib:load-compiled load-compiled)
 
 ;;; At this point SLIB:LOAD must be able to load SLIB files.