diff options
author | Ludovic Courtes <ludovic.courtes@laas.fr> | 2005-11-01 21:29:04 +0000 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2008-04-25 19:09:30 +0200 |
commit | b6368dbbb9af59e6c2df6b8cccc2651a2da8b725 (patch) | |
tree | 6b9a374a3a920d6cbe7ddfe863f00a74258a6120 /module | |
parent | 49edef60dc34fcdb40ba1df3b5136e88796870c0 (diff) | |
download | guile-b6368dbbb9af59e6c2df6b8cccc2651a2da8b725.tar.gz |
Fixed a Scheme translation bug; cleaned compilation with GCC 4.
* module/language/scheme/translate.scm (trans-pair): In the `set!' case,
when a procedure-with-setter is passed, call `trans:pair' with an
actual pair. This fixes a long-lasting bug which prevented compilation
of `set!' statements with procedures-with-setter (this showed up when
compiling `(system vm assemble)').
* module/system/base/compile.scm: Added `objcode->u8vector' to the
`#:select' clause.
* module/system/base/syntax.scm: Cosmetic changes.
* module/system/vm/assemble.scm (preprocess): Removed debugging
statements.
* src/frames.c: Cosmetic changes.
* src/frames.h (SCM_FRAME_SET_DYNAMIC_LINK): New.
* src/objcodes.c: Use `scm_t_uint8' instead of `char' when relevant.
* src/vm.c (vm_heapify_frames_1): Use `SCM_FRAME_SET_DYNAMIC_LINK ()'.
* src/vm_loader.c: Added casts to mute GCC 4 warnings.
* testsuite/run-vm-tests.scm (*scheme*): Renamed to `%scheme'.
(run-test-from-file): Renamed to `compile/run-test-from-file'.
(run-vm-tests): Run each test using both the VM and the interpreter;
compare the results.
* testsuite/t-proc-with-setter.scm: Try out `get/set'.
* doc/Makefile.am (info_TEXINFOS): New.
* doc/guile-vm.texi: Added index entries and indices.
* doc/texinfo.tex: New file.
git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-5
Diffstat (limited to 'module')
-rw-r--r-- | module/language/scheme/translate.scm | 10 | ||||
-rw-r--r-- | module/system/base/compile.scm | 8 | ||||
-rw-r--r-- | module/system/base/syntax.scm | 7 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 14 |
4 files changed, 16 insertions, 23 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index b4fb5e397..03e54047c 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -43,13 +43,13 @@ (cond ((pair? x) (let ((y (macroexpand x))) (if (eq? x y) - (trans-pair e (or (location x) l) (car x) (cdr x)) - (trans e l y)))) + (trans-pair e (or (location x) l) (car x) (cdr x)) + (trans e l y)))) ((symbol? x) (let ((y (symbol-expand x))) (if (symbol? y) - (<ghil-ref> e l (ghil-lookup e y)) - (trans e l y)))) + (<ghil-ref> e l (ghil-lookup e y)) + (trans e l y)))) (else (<ghil-quote> e l x)))) (define (symbol-expand x) @@ -109,7 +109,7 @@ ;; (set! (NAME ARGS...) VAL) ((((? symbol? name) . args) val) ;; -> ((setter NAME) ARGS... VAL) - (trans:pair `((setter ,name) (,@args ,val)))) + (trans:pair `((setter ,name) . (,@args ,val)))) (else (bad-syntax)))) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 6c686505c..bd7f6963c 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -25,7 +25,7 @@ :use-module (system il compile) :use-module (system il glil) :use-module ((system vm core) - #:select (the-vm vm-load)) + #:select (the-vm vm-load objcode->u8vector)) :use-module (system vm assemble) :use-module (ice-9 regex)) @@ -68,9 +68,9 @@ (if (memq :c opts) (pprint-glil objcode port) (uniform-vector-write (objcode->u8vector objcode) port))))) - (format #t "Wrote ~A\n" comp)) + (format #t "wrote ~A\n" comp)) (lambda (key . args) - (format #t "ERROR: During compiling ~A:\n" file) + (format #t "ERROR: during compilation of ~A:\n" file) (display "ERROR: ") (apply format #t (cadr args) (caddr args)) (newline) @@ -128,7 +128,7 @@ (lambda (key val) val))) ;;; -;;; +;;; ;;; (define (compile-and-load file . opts) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index bcc926bee..c28c0dda0 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -102,7 +102,7 @@ (def (if (pair? slot) (cdr slot) *unbound*)) (val (get-key args (symbol->keyword key) def))) (if (eq? val *unbound*) - (error "Slot unbound:" key) + (error "slot unbound" key) (cons key val)))) slots)) @@ -116,14 +116,15 @@ (lambda (struct name) (let ((data (assq name (vector-ref struct 1)))) (cond ((not data) - (error "Unknown slot:" name)) + (error "unknown slot" name)) (else (cdr data))))) (lambda (struct name val) (let ((data (assq name (vector-ref struct 1)))) (cond ((not data) - (error "Unknown slot:" name)) + (error "unknown slot" name)) (else (set-cdr! data val))))))) + ;;; ;;; Variants ;;; diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 49dc1fc09..b2697aac4 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -50,26 +50,18 @@ ;;; (define (preprocess x e) -; (format #t "entering~%") (match x (($ <glil-asm> vars body) -; (format #t "preparing to recurse~%") (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f)) (body (map (lambda (x) (preprocess x venv)) body))) (<vm-asm> :venv venv :glil x :body body))) (($ <glil-external> op depth index) -; (format #t "preparing to return due to external: ~a ~a ~a [e=~a]~%" -; op depth index e) (do ((d depth (- d 1)) - (e e (slot e 'parent))) - ((= d 0)) + (e e (slot e 'parent))) + ((= d 0)) (set! (slot e 'closure?) #t)) -; (format #t "returning due to external~%") x) - (else - (begin -; (format #t "returning~%") - x)))) + (else x))) ;;; |