summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeisuke Nishida <kxn30@po.cwru.edu>2001-04-09 01:50:48 +0000
committerKeisuke Nishida <kxn30@po.cwru.edu>2001-04-09 01:50:48 +0000
commit58995613d97e8d40046366cf19e1840773fd55c0 (patch)
tree2309c691589525dc76e4422a6a0ea11b9fecade8
parentf0c9993564fffb06fcb0a53b7fdb69e6504acfa8 (diff)
downloadguile-58995613d97e8d40046366cf19e1840773fd55c0.tar.gz
*** empty log message ***
-rw-r--r--module/system/base/language.scm12
-rw-r--r--module/system/repl/command.scm4
-rw-r--r--module/system/vm/assemble.scm2
-rw-r--r--module/system/vm/core.scm33
-rw-r--r--module/system/vm/disasm.scm27
-rw-r--r--module/system/vm/load.scm5
6 files changed, 39 insertions, 44 deletions
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index e5588b314..e467d3e77 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -90,21 +90,15 @@
(do ((x (read-in lang in) (read-in lang in))
(l '() (cons (lang.translator (lang.expander x)) l)))
((eof-object? x) (reverse! l))))))
- (asm (apply compile (cons '@begin code) env opts))
- (bytes (apply assemble asm env opts)))
- (call-with-output-file (object-file-name file)
- (lambda (out) (uniform-vector-write bytes out)))))
+ (asm (apply compile (cons '@begin code) env opts)))
+ (save-dumpcode (apply assemble asm env opts) (object-file-name file))))
(define (load-file-in file env lang . opts)
(let ((compiled (object-file-name file)))
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(compile-file-in file env lang :O))
- (call-with-input-file compiled
- (lambda (p)
- (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
- (uniform-vector-read! bytes p)
- bytes)))))
+ (load-dumpcode compiled)))
(define (object-file-name file)
(let ((m (string-match "\\.[^.]*$" file)))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 414c8fe06..583f099e9 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -303,7 +303,7 @@ Generate compiled code.
(let ((x (apply repl-compile repl form opts)))
(cond ((or (memq :e opts) (memq :t opts)) (puts x))
((memq :c opts) (pprint-glil x))
- (else (disassemble-bootcode x)))))
+ (else (disassemble-dumpcode x)))))
(define (compile-file repl file . opts)
"compile-file [options] FILE
@@ -318,7 +318,7 @@ Disassemble a program."
(define (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
- (disassemble-bootcode
+ (disassemble-dumpcode
(load-file-in (->string file) repl.module repl.language)))
(define (->string x)
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index d60f5d9b6..3a4578a58 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -151,7 +151,7 @@
(let ((bytes (stack->bytes stack))
(objs (map car (reverse! object-alist))))
(if toplevel
- (make-bootcode nlocs nexts bytes)
+ (make-dumpcode nlocs nexts bytes)
(make-bytespec nargs nrest nlocs nexts bytes objs)))))))
(define (stack->bytes stack)
diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
index 79e73c0dc..1f7d7ed61 100644
--- a/module/system/vm/core.scm
+++ b/module/system/vm/core.scm
@@ -33,37 +33,48 @@
(module-obarray (current-module)))))
;;;
-;;; Bootcode interface
+;;; Dumpcode interface
;;;
-(export make-bootcode bootcode? bootcode-version
- bootcode-nlocs bootcode-nexts bootcode-bytecode)
+(export make-dumpcode dumpcode? dumpcode-version
+ dumpcode-nlocs dumpcode-nexts dumpcode-bytecode
+ load-dumpcode save-dumpcode)
-(define *bootcode-cookie* (string-append "\0GBC-" (vm-version)))
+(define *dumpcode-cookie* (string-append "\0GBC-" (vm-version)))
-(define (make-bootcode nlocs nexts bytes)
- (string-append *bootcode-cookie*
+(define (make-dumpcode nlocs nexts bytes)
+ (string-append *dumpcode-cookie*
(integer->bytes nlocs)
(integer->bytes nexts)
bytes))
-(define (bootcode? x)
+(define (dumpcode? x)
(and (string? x)
(> (string-length x) 10)
(string=? (substring x 1 4) "GBC")))
-(define (bootcode-version x)
+(define (dumpcode-version x)
(substring x 5 8))
-(define (bootcode-nlocs x)
+(define (dumpcode-nlocs x)
(bytes->integer x 8))
-(define (bootcode-nexts x)
+(define (dumpcode-nexts x)
(bytes->integer x 9))
-(define (bootcode-bytecode x)
+(define (dumpcode-bytecode x)
(substring x 10))
+(define (load-dumpcode file)
+ (let ((bytes (make-uniform-vector (stat:size (stat file)) #\a)))
+ (call-with-input-file file
+ (lambda (p) (uniform-vector-read! bytes p)))
+ bytes))
+
+(define (save-dumpcode dump file)
+ (call-with-output-file file
+ (lambda (out) (uniform-vector-write bytes out))))
+
(define (integer->bytes n)
(string (integer->char n)))
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index 09fcfef29..7c6df92ff 100644
--- a/module/system/vm/disasm.scm
+++ b/module/system/vm/disasm.scm
@@ -27,15 +27,15 @@
:use-module (ice-9 format)
:use-module (ice-9 receive)
:use-module (ice-9 and-let-star)
- :export (disassemble-bootcode disassemble-program))
+ :export (disassemble-dumpcode disassemble-program))
-(define (disassemble-bootcode bytes . opts)
- (if (not (bootcode? bytes)) (error "Invalid bootcode"))
- (format #t "Disassembly of bootcode:\n\n")
- (format #t "Compiled for Guile VM ~A\n\n" (bootcode-version bytes))
+(define (disassemble-dumpcode dumpcode . opts)
+ (if (not (dumpcode? dumpcode)) (error "Invalid dumpcode"))
+ (format #t "Disassembly of dumpcode:\n\n")
+ (format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode))
(format #t "nlocs = ~A nexts = ~A\n\n"
- (bootcode-nlocs bytes) (bootcode-nexts bytes))
- (disassemble-bytecode (bootcode-bytecode bytes) #f))
+ (dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode))
+ (disassemble-bytecode (dumpcode-bytecode dumpcode) #f))
(define (disassemble-program prog . opts)
(let* ((arity (program-arity prog))
@@ -63,14 +63,14 @@
(define (disassemble-bytecode bytes objs)
(let ((decode (make-byte-decoder bytes))
- (rest '()))
+ (programs '()))
(do ((addr+code (decode) (decode)))
((not addr+code) (newline))
(receive (addr code) addr+code
(match code
(('load-program x)
(let ((sym (gensym "")))
- (set! rest (acons sym x rest))
+ (set! programs (acons sym x programs))
(print-info addr (format #f "load-program #~A" sym) #f)))
(else
(let ((info (list->info code))
@@ -79,7 +79,7 @@
(for-each (lambda (sym+bytes)
(format #t "Bytecode #~A:\n\n" (car sym+bytes))
(disassemble-bytecode (cdr sym+bytes) #f))
- (reverse! rest))))
+ (reverse! programs))))
(define (disassemble-objects objs)
(display "Objects:\n\n")
@@ -109,13 +109,6 @@
((make-false) "#f")
((object-ref)
(if objs (object->string (vector-ref objs (car args))) #f))
-;;; ((local-ref local-set)
-;;; ;;'(ref x))
-;;; #f)
-;;; ((module-ref module-set)
-;;; (let ((var (vector-ref objs (car args))))
-;;; (list (if (eq? inst 'module-ref) 'ref 'set)
-;;; (if (pair? var) (car var) var))))
(else #f)))))))
(define (list->info list)
diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm
index 6dca082a5..6214cc95a 100644
--- a/module/system/vm/load.scm
+++ b/module/system/vm/load.scm
@@ -31,10 +31,7 @@
(if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(compile-file-in file #f (lookup-language 'gscheme) #:O))
- (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
- (call-with-input-file compiled
- (lambda (p) (uniform-vector-read! bytes p)))
- (vm-load (the-vm) bytes))))
+ (vm-load (the-vm) (load-dumpcode compiled))))
(define (file-name-full-name filename)
(let ((oldname (and (current-load-port)