*** empty log message ***

module/language/gscheme/spec.scm

@@ -22,7 +22,6 @@
 (define-module (language gscheme spec)
   :use-module (system base language)
   :use-module (system il ghil)
-  :use-module (language r5rs expand)
   :use-module (ice-9 match)
   :use-module (ice-9 and-let-star)
   :export (gscheme))
@@ -32,7 +31,8 @@
 ;;; Macro expander
 ;;;
 
-(define expand-syntax expand)
+(define (expand x)
+  (expand-macro x (current-module)))
 
 (define (expand-macro x m)
   (if (pair? x)
@@ -43,9 +43,6 @@
 	    (cons (expand-macro (car x) m) (expand-macro (cdr x) m))))
       x))
 
-(define (expand x)
-  (expand-syntax (expand-macro x (current-module))))
-
 
 ;;;
 ;;; Translator
@@ -56,9 +53,18 @@
 (define (translate-pair x)
   (let ((head (car x)) (rest (cdr x)))
     (case head
-      ((quote) (cons '@quote rest))
-      ((define set! if and or begin)
+      ((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 ...)
@@ -69,8 +75,41 @@
 		 (map (lambda (b) (cons (car b) (map translate (cdr b))))
 		      (car rest))
 		 (map translate (cdr rest))))))
-      ((lambda)
-       (cons* '@lambda (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 ...)
+	  `(@letrec ((_loop (@lambda
+			     ,sym
+			     (@if ,(translate test)
+				  (@begin ,@(map translate result))
+				  (@begin ,@(map translate body)
+					  (_loop ,@(map translate update)))))))
+		    (_loop ,@(map translate init))))))
       (else
        (let ((prim (and (symbol? head) (symbol-append '@ head))))
 	 (if (and prim (ghil-primitive? prim))

module/system/il/compile.scm

@@ -64,6 +64,7 @@
        (($ <ghil-lambda> lambda-env vars #f body)
 	(for-each (lambda (v)
 		    (if (eq? v.kind 'argument) (set! v.kind 'local))
+		    (set! v.env env)
 		    (ghil-env-add! env v))
 		  lambda-env.variables)
 	(optimize (make-<ghil-bind> env vars args body)))

module/system/il/ghil.scm

@@ -228,6 +228,19 @@
     ((@begin)
      (parse-body args e))
 
+    ;; (@let ((SYM INIT)...) BODY...)
+    ((@let)
+     (match args
+       ((((sym init) ...) body ...)
+	(let* ((vals (map-parse init e))
+	       (vars (map (lambda (s)
+			    (let ((v (make-ghil-var e s 'local)))
+			      (ghil-env-add! e v) v))
+			  sym))
+	       (body (parse-body body e)))
+	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+	  (make-<ghil-bind> e vars vals body)))))
+
     ;; (@letrec ((SYM INIT)...) BODY...)
     ((@letrec)
      (match args

module/system/il/macros.scm

@@ -216,14 +216,14 @@
 ;;; length
 ;;; append
 ;;; reverse
-;;; 
-;;; memq
-;;; memv
-;;; member
-;;; 
-;;; assq
-;;; assv
-;;; assoc
+
+(define (@memq x l) `((@ Core::memq) ,x ,l))
+(define (@memv x l) `((@ Core::memv) ,x ,l))
+(define (@member x l) `((@ Core::member) ,x ,l))
+
+(define (@assq x l) `((@ Core::assq) ,x ,l))
+(define (@assv x l) `((@ Core::assv) ,x ,l))
+(define (@assber x l) `((@ Core::assber) ,x ,l))
 
 ;;;; 6.3.3 Symbols
 

module/system/vm/assemble.scm

@@ -232,10 +232,12 @@
 	 (push-code! `(load-program ,bytes)))))
      ((vlink? x)
       ;; (push-code! `(local-ref ,(object-index (vlink-module x))))
+      ;; FIXME: Temporary hack
+      (push-code! (object->code #f))
       (dump! (vlink-name x))
-      (push-code! `(link/current-module)))
-     ;;((vmod? x)
-     ;;  (push-code! `(load-module ,(vmod-id x))))
+      (push-code! `(link)))
+     ((vmod? x)
+      (push-code! `(load-module ,(vmod-id x))))
      ((and (integer? x) (exact? x))
       (let ((str (do ((n x (quotient n 256))
 		      (l '() (cons (modulo n 256) l)))

module/system/vm/trace.scm

@@ -31,7 +31,7 @@
       (lambda ()
 	(set-vm-option! vm 'trace-first #t)
 	(if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next))
-	(set-vm-option! vm 'trace-variables (if (memq :v opts) #t #f))
+	(set-vm-option! vm 'trace-options opts)
 	(add-hook! (vm-apply-hook vm) trace-apply)
 	(add-hook! (vm-return-hook vm) trace-return))
       (lambda ()
@@ -44,9 +44,12 @@
 (define (trace-next vm)
   (let ((frame (vm-current-frame vm)))
     (format #t "0x~8X  ~20S" (vm:ip vm) (vm-fetch-code vm))
-    (if (vm-option vm 'trace-variables)
-	(format #t "~S\t" (frame-variables frame)))
-    (format #t "~S\n" (vm-fetch-stack 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)))
+	((:e) (format #t "~20S" (program-external (frame-program frame))))))))
 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)

src/vm.c

@@ -245,7 +245,7 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp)
  * VM
  */
 
-#define VM_DEFAULT_STACK_SIZE	(4 * 1024)
+#define VM_DEFAULT_STACK_SIZE	(16 * 1024)
 
 #define VM_REGULAR_ENGINE	0
 #define VM_DEBUG_ENGINE		1

src/vm_loader.c

@@ -161,13 +161,12 @@ VM_DEFINE_LOADER (load_program, "load-program")
 
 VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
 {
+#if 0
   sp--;
   *sp = scm_c_env_vcell (sp[0], sp[1], 1);
-  NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0, 1, 1)
+#else
   {
+    /* Temporary hack to support the current module system */
     SCM mod = scm_current_module ();
     SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
 				       *sp, SCM_BOOL_F);
@@ -175,7 +174,9 @@ VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0, 1, 1)
       /* Create a new variable if not defined yet */
       var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
 				     *sp, SCM_BOOL_T);
-  *sp = SCM_VARVCELL (var);
+    *--sp = SCM_VARVCELL (var);
+  }
+#endif
   NEXT;
 }