*** empty log message ***

module/language/scheme/translate.scm

@@ -45,9 +45,21 @@
 	   (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)))
+	((symbol? x)
+	 (let ((y (expand-symbol x)))
+	   (if (eq? x y)
+	       (make-<ghil-ref> e l (ghil-lookup e x))
+	       (trans e l y))))
 	(else (make-<ghil-quote> e l x))))
 
+(define (expand-symbol x)
+  (let loop ((s (symbol->string x)))
+    (let ((i (string-rindex s #\.)))
+      (if i
+	  `(slot ,(loop (substring s 0 i))
+		 (quote ,(string->symbol (substring s (1+ i)))))
+	  (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)))

module/system/base/compile.scm

@@ -68,20 +68,21 @@
 		 (uniform-array-write (objcode->string objcode) port))))
 	   (format #t "Wrote ~A\n" comp))))
       (lambda (key . args)
-	(format #t "ERROR: In ~A:\n" file)
+	(format #t "ERROR: During compiling ~A:\n" file)
 	(display "ERROR: ")
-	(format #t (cadr args) (caddr args))
+	(apply format #t (cadr args) (caddr args))
 	(newline)
+	(format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
 	(delete-file comp)))))
 
 (define-public (load-source-file file . opts)
   (let ((source (read-file-in file scheme)))
-    (vm-load (the-vm) (apply compile-in source (current-module) scheme opts))))
+    (apply compile-in source (current-module) scheme opts)))
 
 (define-public (load-file file . opts)
   (let ((comp (compiled-file-name file)))
     (if (file-exists? comp)
-	(vm-load (the-vm) (load-objcode comp))
+	(load-objcode comp)
 	(apply load-source-file file opts))))
 
 (define-public (compiled-file-name file)

module/system/base/syntax.scm

@@ -24,7 +24,7 @@
   :use-module (ice-9 match)
   :use-module (ice-9 receive)
   :use-module (ice-9 and-let-star)
-  :export (match and-let* receive))
+  :export (match syntax-error and-let* receive))
 
 
 ;;;

module/system/repl/command.scm

@@ -26,7 +26,7 @@
   :use-module (system vm core)
   :autoload (system il glil) (pprint-glil)
   :autoload (system vm disasm) (disassemble-program disassemble-objcode)
-  :autoload (system vm trace) (vm-trace)
+  :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
   :autoload (system vm profile) (vm-profile)
   :use-module (ice-9 format)
   :use-module (ice-9 session)
@@ -45,7 +45,7 @@
 	      (disassemble x) (disassemble-file xx))
     (profile  (time t) (profile pr))
     (debug    (backtrace bt) (debugger db) (trace r) (step st))
-    (system   (gc) (statistics st))))
+    (system   (gc) (statistics stat))))
 
 (define (group-name g) (car g))
 (define (group-commands g) (cdr g))
@@ -109,7 +109,7 @@
 	       (if c
 		   (cond ((memq :h opts) (display-command c))
 			 (else (apply (command-procedure c)
-				      repl (append! args opts))))
+				      repl (append! args (reverse! opts)))))
 		   (user-error "Unknown meta command: ~A" key))))))))
 
 
@@ -159,7 +159,22 @@ Show description/documentation."
 (define (option repl . args)
   "option [KEY VALUE]
 List/show/set options."
-  (display "Not implemented yet\n"))
+  (match args
+    (()
+     (for-each (lambda (key+val)
+		 (format #t "~A\t~A\n" (car key+val) (cdr key+val)))
+	       repl.options))
+    ((key)
+     (display (repl-option-ref repl key))
+     (newline))
+    ((key val)
+     (repl-option-set! repl key val)
+     (case key
+       ((trace)
+	(let ((opts (repl-option-ref repl 'trace-options)))
+	  (if val
+	      (apply vm-trace-on repl.env.vm opts)
+	      (vm-trace-off repl.env.vm))))))))
 
 (define (quit repl)
   "quit
@@ -221,15 +236,12 @@ Import modules / List those imported."
   "load FILE
 Load a file in the current module.
 
-  -f    Load source file (see `compile')
+  -f    Load source file (see `compile')"
-  -r    Trace loading (see `trace')"
   (let* ((file (->string file))
 	 (objcode (if (memq :f opts)
 		      (apply load-source-file file opts)
 		      (apply load-file file opts))))
-    (if (memq :r opts)
+    (vm-load repl.env.vm objcode)))
-	(apply vm-trace repl.env.vm objcode opts)
-	(vm-load repl.env.vm objcode))))
 
 (define (binding repl . opts)
   "binding
@@ -267,10 +279,11 @@ Generate compiled code.
 	  ((memq :c opts) (pprint-glil x))
 	  (else (disassemble-objcode x)))))
 
+(define guile:compile-file compile-file)
 (define (compile-file repl file . opts)
   "compile-file FILE
 Compile a file."
-  (apply repl-compile-file repl (->string file) opts))
+  (apply guile:compile-file (->string file) opts))
 
 (define (disassemble repl prog)
   "disassemble PROGRAM

module/system/repl/common.scm

@@ -32,7 +32,11 @@
 ;;; Repl type
 ;;;
 
-(define-vm-class <repl> () env tm-stats vm-stats gc-stats)
+(define-vm-class <repl> () env options tm-stats gc-stats vm-stats)
+
+(define repl-default-options
+  '((trace . #f)
+    (trace-options . (:s))))
 
 (define-public (make-repl lang)
   (let ((cenv (make-cenv :vm (the-vm)
@@ -40,9 +44,10 @@
 			 :module (current-module))))
     (make <repl>
 	  :env cenv
+	  :options repl-default-options
 	  :tm-stats (times)
-	  :vm-stats (vm-stats cenv.vm)
+	  :gc-stats (gc-stats)
-	  :gc-stats (gc-stats))))
+	  :vm-stats (vm-stats cenv.vm))))
 
 (define-public (repl-welcome repl)
   (format #t "~A interpreter ~A on Guile ~A\n"
@@ -73,6 +78,12 @@
 	(repl.env.language.printer val)
 	(newline))))
 
+(define-public (repl-option-ref repl key)
+  (assq-ref repl.options key))
+
+(define-public (repl-option-set! repl key val)
+  (set! repl.options (assq-set! repl.options key val)))
+
 
 ;;;
 ;;; Utilities

module/system/repl/repl.scm

@@ -23,6 +23,7 @@
   :use-syntax (system base syntax)
   :use-module (system repl common)
   :use-module (system repl command)
+  :use-module (system vm core)
   :use-module (ice-9 rdelim)
   :export (start-repl))
 
@@ -60,10 +61,10 @@
     error-handler))
 
 (define (error-handler key . args)
-;;   (case key
+  (case key
-;;     ((vm-error)
+    ((vm-error)
-;;      (write (frame->call (cadddr args)))
+     (write (frame->call (cadddr args)))
-;;      (newline)))
+     (newline)))
   (display "ERROR: ")
   (apply format #t (cadr args) (caddr args))
   (newline))

module/system/vm/conv.scm

@@ -83,7 +83,6 @@
     (('load-string s) s)
     (('load-symbol s) (string->symbol s))
     (('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s)))
-    (('link s) (cons (string->symbol s) '???))
     (else #f)))
 
 (define (code->bytes code)

module/system/vm/core.scm

@@ -57,8 +57,9 @@
 	((= 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))))
+		 (module-obarray (current-module)))))
 
 
 ;;;

module/system/vm/disasm.scm

@@ -134,3 +134,11 @@
   (if extra
       (format #t "~4@A    ~32A;; ~A\n" addr info extra)
       (format #t "~4@A    ~A\n" addr info)))
+
+(define (simplify x)
+  (cond ((string? x)
+	 (cond ((string-index x #\newline) =>
+		(lambda (i) (set! x (substring x 0 i)))))
+	 (cond ((> (string-length x) 16)
+		(set! x (string-append (substring x 0 13) "..."))))))
+  x)

src/vm.c

@@ -328,7 +328,7 @@ vm_mark (SCM obj)
 	if (SCM_NIMP (*sp))
 	  scm_gc_mark (*sp);
       fp = SCM_VM_STACK_ADDRESS (sp[-1]);	/* dynamic link */
-      /* Mark frame variables + program */
+      /* Mark external link, frame variables, and program */
       for (sp -= 2; sp >= lower; sp--)
 	if (SCM_NIMP (*sp))
 	  scm_gc_mark (*sp);

src/vm_engine.h

@@ -135,16 +135,6 @@
   objects = SCM_VELTS (bp->objs);		\
 }
 
-#define CACHE_EXTERNAL()			\
-{						\
-  external = fp[bp->nargs + bp->nlocs];		\
-}
-
-#define SYNC_EXTERNAL()				\
-{						\
-  fp[bp->nargs + bp->nlocs] = external;		\
-}
-
 #define SYNC_BEFORE_GC()			\
 {						\
   SYNC_REGISTER ();				\
@@ -305,16 +295,16 @@ do {						\
   CHECK_OVERFLOW ();				\
   sp[0]  = ra;					\
   sp[-1] = dl;					\
-  sp[-2] = bp->external;			\
+  sp[-2] = external;				\
 }
 
 #define FREE_FRAME()				\
 {						\
-  SCM *new_sp = fp - 2;				\
+  SCM *p = fp + bp->nargs + bp->nlocs;		\
-  sp = fp + bp->nargs + bp->nlocs;		\
+  sp = fp - 2;					\
-  ip = SCM_VM_BYTE_ADDRESS (sp[2]);		\
+  ip = SCM_VM_BYTE_ADDRESS (p[2]);		\
-  fp = SCM_VM_STACK_ADDRESS (sp[1]);		\
+  fp = SCM_VM_STACK_ADDRESS (p[1]);		\
-  sp = new_sp;					\
+  external = p[0];				\
 }
 
 /*

src/vm_system.c

@@ -351,10 +351,9 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 	LOCAL_SET (i, SCM_UNDEFINED);
 
       /* Create external variables */
-      CACHE_EXTERNAL ();
+      external = bp->external;
       for (i = 0; i < bp->nexts; i++)
 	CONS (external, SCM_UNDEFINED, external);
-      SYNC_EXTERNAL ();
 
       ENTER_HOOK ();
       APPLY_HOOK ();
@@ -365,9 +364,10 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
    */
   if (!SCM_FALSEP (scm_procedure_p (x)))
     {
+      SCM args;
       POP_LIST (nargs);
-      sp[-1] = scm_apply (x, *sp, SCM_EOL);
+      POP (args);
-      sp--;
+      *sp = scm_apply (x, args, SCM_EOL);
       NEXT;
     }
   /*
@@ -406,18 +406,16 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
    */
   if (SCM_EQ_P (x, program))
     {
-      INIT_ARGS ();
+      int i;
 
       /* Move arguments */
-      if (bp->nargs)
+      INIT_ARGS ();
-	{
-	  int i;
       sp -= bp->nargs - 1;
       for (i = 0; i < bp->nargs; i++)
 	LOCAL_SET (i, sp[i]);
-	  sp -= 2;
+      sp--;
-	}
 
+      /* Call itself */
       ip = bp->base;
       APPLY_HOOK ();
       NEXT;
@@ -447,9 +445,10 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
    */
   if (!SCM_FALSEP (scm_procedure_p (x)))
     {
+      SCM args;
       POP_LIST (nargs);
-      sp[-1] = scm_apply (x, *sp, SCM_EOL);
+      POP (args);
-      sp--;
+      *sp = scm_apply (x, args, SCM_EOL);
       goto vm_return;
     }
   /*
@@ -504,7 +503,6 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
   /* Restore the last program */
   program = SCM_VM_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
-  CACHE_EXTERNAL ();
   PUSH (ret);
   NEXT;
 }