summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/scheme/translate.scm14
-rw-r--r--module/system/base/compile.scm9
-rw-r--r--module/system/base/syntax.scm2
-rw-r--r--module/system/repl/command.scm33
-rw-r--r--module/system/repl/common.scm17
-rw-r--r--module/system/repl/repl.scm9
-rw-r--r--module/system/vm/conv.scm1
-rw-r--r--module/system/vm/core.scm5
-rw-r--r--module/system/vm/disasm.scm8
-rw-r--r--src/vm.c2
-rw-r--r--src/vm_engine.h22
-rw-r--r--src/vm_system.c30
12 files changed, 93 insertions, 59 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index f13040314..7ba07b34b 100644
--- a/module/language/scheme/translate.scm
+++ b/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)))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 32c36c892..adc7e2d90 100644
--- a/module/system/base/compile.scm
+++ b/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)
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index fab3f0bd0..f14b924b7 100644
--- a/module/system/base/syntax.scm
+++ b/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))
;;;
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 1d374722a..013e50912 100644
--- a/module/system/repl/command.scm
+++ b/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')
- -r Trace loading (see `trace')"
+ -f Load source file (see `compile')"
(let* ((file (->string file))
(objcode (if (memq :f opts)
(apply load-source-file file opts)
(apply load-file file opts))))
- (if (memq :r opts)
- (apply vm-trace repl.env.vm objcode opts)
- (vm-load repl.env.vm objcode))))
+ (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
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 4bd8986a9..23d4e76da 100644
--- a/module/system/repl/common.scm
+++ b/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
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 73473af8c..a77213280 100644
--- a/module/system/repl/repl.scm
+++ b/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
-;; ((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))
diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm
index 5e246eb96..c36222e88 100644
--- a/module/system/vm/conv.scm
+++ b/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)
diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
index a5679d08b..a4a0ef4fc 100644
--- a/module/system/vm/core.scm
+++ b/module/system/vm/core.scm
@@ -57,8 +57,9 @@
((= i nargs) (cons (program-name prog) (reverse! r))))))
(define (program-name x)
- (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
- (module-obarray (current-module))))
+ (or (object-property x 'name)
+ (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
+ (module-obarray (current-module)))))
;;;
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index 2e3c1ac87..b8574286e 100644
--- a/module/system/vm/disasm.scm
+++ b/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)
diff --git a/src/vm.c b/src/vm.c
index d09602075..ae2b7f120 100644
--- a/src/vm.c
+++ b/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);
diff --git a/src/vm_engine.h b/src/vm_engine.h
index 37320d901..f15e6d71c 100644
--- a/src/vm_engine.h
+++ b/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; \
- sp = fp + bp->nargs + bp->nlocs; \
- ip = SCM_VM_BYTE_ADDRESS (sp[2]); \
- fp = SCM_VM_STACK_ADDRESS (sp[1]); \
- sp = new_sp; \
+ SCM *p = fp + bp->nargs + bp->nlocs; \
+ sp = fp - 2; \
+ ip = SCM_VM_BYTE_ADDRESS (p[2]); \
+ fp = SCM_VM_STACK_ADDRESS (p[1]); \
+ external = p[0]; \
}
/*
diff --git a/src/vm_system.c b/src/vm_system.c
index c0f14e444..1d7064a6e 100644
--- a/src/vm_system.c
+++ b/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);
- sp--;
+ POP (args);
+ *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)
- {
- int i;
- sp -= bp->nargs - 1;
- for (i = 0; i < bp->nargs; i++)
- LOCAL_SET (i, sp[i]);
- sp -= 2;
- }
+ INIT_ARGS ();
+ sp -= bp->nargs - 1;
+ for (i = 0; i < bp->nargs; i++)
+ LOCAL_SET (i, sp[i]);
+ 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);
- sp--;
+ POP (args);
+ *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;
}