summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorKeisuke Nishida <kxn30@po.cwru.edu>2001-04-19 03:09:27 +0000
committerKeisuke Nishida <kxn30@po.cwru.edu>2001-04-19 03:09:27 +0000
commitf21dfea6599c976f1fe6a752c516f3fca9586dd4 (patch)
treef209d3c8503dd720a11d3d7bafb241dde188caef /module
parent8f5cfc810fb19fdfbeaa55d59d47dc5ab50c416b (diff)
downloadguile-f21dfea6599c976f1fe6a752c516f3fca9586dd4.tar.gz
*** empty log message ***
Diffstat (limited to 'module')
-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
9 files changed, 72 insertions, 26 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)