[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-58-g524
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-7-58-g524aa8a |
|
Date: |
Tue, 09 Feb 2010 23:45:23 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=524aa8ae6830d0f471f0c86431d5da87c8a0a534
The branch, master has been updated
via 524aa8ae6830d0f471f0c86431d5da87c8a0a534 (commit)
via dad6817f7d9581264891c6ad8954369d01f3d0b7 (commit)
via bde92e6b3bbd15c7abaf29bc0557041b88df8d74 (commit)
via 0c368d2b2811fb856c9551e7ad217f8e5636024f (commit)
from d8873dfe4754daf031a6709738bd31afa8edb443 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 524aa8ae6830d0f471f0c86431d5da87c8a0a534
Author: Ludovic Courtès <address@hidden>
Date: Wed Feb 10 00:39:25 2010 +0100
Fix documentation of the `string->utf' and `utf->string' functions.
* doc/ref/api-data.texi (Bytevectors as Strings): Describe optional
parameter of `string->utf{16,32}' and `utf{16,32}->string'.
commit dad6817f7d9581264891c6ad8954369d01f3d0b7
Author: Ludovic Courtès <address@hidden>
Date: Wed Feb 10 00:34:05 2010 +0100
Use the R6RS I/O API in `write-bytecode'.
* module/language/assembly/compile-bytecode.scm
(write-bytecode)[u32-bv]: New variable.
[write-char, write-uint16-be, write-uint16-le, write-uint32-le]:
Remove.
[write-string, write-uint32-be, write-uint32, write-wide-string,
write-bytevector]: Rewrite using the `(rnrs io ports)' API.
[write-uint24-be]: Rename to...
[write-int24-be]: ... this. Use `(rnrs io ports)' API. Callers
updated.
[write-uint16]: Remove.
commit bde92e6b3bbd15c7abaf29bc0557041b88df8d74
Author: Ludovic Courtès <address@hidden>
Date: Fri Feb 5 11:11:56 2010 +0100
Change `write-bytecode' to accept a bytevector.
* module/language/assembly/compile-bytecode.scm (write-bytecode):
Replace the WRITE-BYTE and GET-ADDR parameters with PORT. New ADDRESS
and EMIT-OPCODE? parameters. Callers updated.
[write-byte, get-addr]: New procedures.
Adjust to write to PORT.
(compile-bytecode): Update accordingly.
* test-suite/tests/asm-to-bytecode.test (munge-bytecode): Return a
bytevector instead of a u8vector.
(comp-test): Deal with bytevectors.
commit 0c368d2b2811fb856c9551e7ad217f8e5636024f
Author: Ludovic Courtès <address@hidden>
Date: Fri Feb 5 10:38:38 2010 +0100
vlist: Slightly improve readability and consistency.
* module/ice-9/vlist.scm (define-inline): Fix case with non-singleton
body.
(make-vhash-assoc): Remove. Change to...
(%vhash-assoc): ... this, using `define-inline'.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-data.texi | 24 +++---
module/ice-9/vlist.scm | 73 ++++++++---------
module/language/assembly/compile-bytecode.scm | 108 ++++++++++---------------
test-suite/tests/asm-to-bytecode.test | 20 +++--
4 files changed, 103 insertions(+), 122 deletions(-)
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 64c1381..d413567 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -4422,23 +4422,27 @@ assume that Guile strings are Latin-1-encoded.}.
@end lisp
@deffn {Scheme Procedure} string->utf8 str
address@hidden {Scheme Procedure} string->utf16 str
address@hidden {Scheme Procedure} string->utf32 str
address@hidden {Scheme Procedure} string->utf16 str [endianness]
address@hidden {Scheme Procedure} string->utf32 str [endianness]
@deffnx {C Function} scm_string_to_utf8 (str)
address@hidden {C Function} scm_string_to_utf16 (str)
address@hidden {C Function} scm_string_to_utf32 (str)
address@hidden {C Function} scm_string_to_utf16 (str, endianness)
address@hidden {C Function} scm_string_to_utf32 (str, endianness)
Return a newly allocated bytevector that contains the UTF-8, UTF-16, or
-UTF-32 (aka. UCS-4) encoding of @var{str}.
+UTF-32 (aka. UCS-4) encoding of @var{str}. For UTF-16 and UTF-32,
address@hidden should be the symbol @code{big} or @code{little}; when omitted,
+it defaults to big endian.
@end deffn
@deffn {Scheme Procedure} utf8->string utf
address@hidden {Scheme Procedure} utf16->string utf
address@hidden {Scheme Procedure} utf32->string utf
address@hidden {Scheme Procedure} utf16->string utf [endianness]
address@hidden {Scheme Procedure} utf32->string utf [endianness]
@deffnx {C Function} scm_utf8_to_string (utf)
address@hidden {C Function} scm_utf16_to_string (utf)
address@hidden {C Function} scm_utf32_to_string (utf)
address@hidden {C Function} scm_utf16_to_string (utf, endianness)
address@hidden {C Function} scm_utf32_to_string (utf, endianness)
Return a newly allocated string that contains from the UTF-8-, UTF-16-,
-or UTF-32-decoded contents of bytevector @var{utf}.
+or UTF-32-decoded contents of bytevector @var{utf}. For UTF-16 and UTF-32,
address@hidden should be the symbol @code{big} or @code{little}; when omitted,
+it defaults to big endian.
@end deffn
@node Bytevectors as Generalized Vectors
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index dd62661..0c92976 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -73,7 +73,7 @@
(define-syntax name
(syntax-rules ()
((_ formals ...)
- body ...))))))
+ (begin body ...)))))))
(define-inline (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to BASE
@@ -408,55 +408,52 @@ with @var{value}. Use @var{hash} to compute @var{key}'s
hash."
(define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv))
-(define-syntax make-vhash-assoc
- ;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction
- ;; instead of calling the `eq?' subr.
- (syntax-rules ()
- ((_ key vhash equal? hash)
- (begin
- (define khash
- (let ((size (block-size (vlist-base vhash))))
- (and (> size 0) (hash key size))))
-
- (let loop ((base (vlist-base vhash))
- (khash khash)
- (offset (and khash
- (block-hash-table-ref (vlist-base vhash)
- khash)))
- (max-offset (vlist-offset vhash)))
- (let ((answer (and offset (block-ref base offset))))
- (cond ((and (pair? answer)
- (<= offset max-offset)
- (let ((answer-key (caar answer)))
- (equal? key answer-key)))
- (car answer))
- ((and (pair? answer) (cdr answer))
- =>
- (lambda (next-offset)
- (loop base khash next-offset max-offset)))
- (else
- (let ((next-base (block-base base)))
- (and next-base
- (> (block-size next-base) 0)
- (let* ((khash (hash key (block-size next-base)))
- (offset (block-hash-table-ref next-base
khash)))
- (loop next-base khash offset
- (block-offset base)))))))))))))
+;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction
instead
+;; of calling the `eq?' subr.
+(define-inline (%vhash-assoc key vhash equal? hash)
+ (define khash
+ (let ((size (block-size (vlist-base vhash))))
+ (and (> size 0) (hash key size))))
+
+ (let loop ((base (vlist-base vhash))
+ (khash khash)
+ (offset (and khash
+ (block-hash-table-ref (vlist-base vhash)
+ khash)))
+ (max-offset (vlist-offset vhash)))
+ (let ((answer (and offset (block-ref base offset))))
+ (cond ((and (pair? answer)
+ (<= offset max-offset)
+ (let ((answer-key (caar answer)))
+ (equal? key answer-key)))
+ (car answer))
+ ((and (pair? answer) (cdr answer))
+ =>
+ (lambda (next-offset)
+ (loop base khash next-offset max-offset)))
+ (else
+ (let ((next-base (block-base base)))
+ (and next-base
+ (> (block-size next-base) 0)
+ (let* ((khash (hash key (block-size next-base)))
+ (offset (block-hash-table-ref next-base khash)))
+ (loop next-base khash offset
+ (block-offset base))))))))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from @var{vhash} whose key is equal to
@var{key} according to the @var{equal?} equality predicate."
- (make-vhash-assoc key vhash equal? hash))
+ (%vhash-assoc key vhash equal? hash))
(define (vhash-assq key vhash)
"Return the first key/value pair from @var{vhash} whose key is @code{eq?} to
@var{key}."
- (make-vhash-assoc key vhash eq? hashq))
+ (%vhash-assoc key vhash eq? hashq))
(define (vhash-assv key vhash)
"Return the first key/value pair from @var{vhash} whose key is @code{eqv?} to
@var{key}."
- (make-vhash-assoc key vhash eqv? hashv))
+ (%vhash-assoc key vhash eqv? hashv))
(define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash))
"Remove all associations from @var{vhash} with @var{key}, comparing keys
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index f045148..98fb27f 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -24,59 +24,46 @@
#:use-module (system vm instruction)
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevector)
+ #:use-module (rnrs io ports)
#:use-module ((srfi srfi-1) #:select (fold))
- #:use-module ((system vm objcode) #:select (byte-order))
+ #:use-module ((srfi srfi-26) #:select (cut))
#:export (compile-bytecode write-bytecode))
(define (compile-bytecode assembly env . opts)
(pmatch assembly
((load-program . _)
- ;; the 1- and -1 are so that we drop the load-program byte
- (letrec ((v (make-u8vector (1- (byte-length assembly))))
- (i -1)
- (write-byte (lambda (b)
- (if (>= i 0) (u8vector-set! v i b))
- (set! i (1+ i))))
- (get-addr (lambda () i)))
- (write-bytecode assembly write-byte get-addr '())
- (if (= i (u8vector-length v))
- (values v env env)
- (error "incorrect length in assembly" i (u8vector-length v)))))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ ;; Don't emit the `load-program' byte.
+ (write-bytecode assembly port '() 0 #f)
+ (values (get-bytevector) env env))))
(else (error "bad assembly" assembly))))
-(define (write-bytecode asm write-byte get-addr labels)
- (define (write-char c)
- (write-byte (char->integer c)))
+(define (write-bytecode asm port labels address emit-opcode?)
+ ;; Write ASM's bytecode to PORT, a (binary) output port. If EMIT-OPCODE? is
+ ;; false, don't emit bytecode for the first opcode encountered. Assume code
+ ;; starts at ADDRESS (an integer). LABELS is assumed to be an alist mapping
+ ;; labels to addresses.
+ (define u32-bv (make-bytevector 4))
+ (define write-byte (cut put-u8 port <>))
+ (define get-addr
+ (let ((start (port-position port)))
+ (lambda ()
+ (+ address (- (port-position port) start)))))
(define (write-string s)
- (string-for-each write-char s))
- (define (write-uint16-be x)
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand x 255)))
- (define (write-uint16-le x)
- (write-byte (logand x 255))
- (write-byte (logand (ash x -8) 255)))
- (define (write-uint24-be x)
- (write-byte (logand (ash x -16) 255))
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand x 255)))
+ (put-bytevector port (string->utf8 s)))
+ (define (write-int24-be x)
+ (bytevector-s32-set! u32-bv 0 x (endianness big))
+ (put-bytevector port u32-bv 1 3))
(define (write-uint32-be x)
- (write-byte (logand (ash x -24) 255))
- (write-byte (logand (ash x -16) 255))
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand x 255)))
- (define (write-uint32-le x)
- (write-byte (logand x 255))
- (write-byte (logand (ash x -8) 255))
- (write-byte (logand (ash x -16) 255))
- (write-byte (logand (ash x -24) 255)))
+ (bytevector-u32-set! u32-bv 0 x (endianness big))
+ (put-bytevector port u32-bv))
(define (write-uint32 x)
- (case byte-order
- ((1234) (write-uint32-le x))
- ((4321) (write-uint32-be x))
- (else (error "unknown endianness" byte-order))))
+ (bytevector-u32-native-set! u32-bv 0 x)
+ (put-bytevector port u32-bv))
(define (write-wide-string s)
(write-loader-len (* 4 (string-length s)))
- (string-for-each (lambda (c) (write-uint32 (char->integer c))) s))
+ (put-bytevector port (string->utf32 s (native-endianness))))
(define (write-loader-len len)
(write-byte (ash len -16))
(write-byte (logand (ash len -8) 255))
@@ -86,44 +73,35 @@
(write-string str))
(define (write-bytevector bv)
(write-loader-len (bytevector-length bv))
- ;; Ew!
- (for-each write-byte (bytevector->u8-list bv)))
+ (put-bytevector port bv))
(define (write-break label)
(let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
(cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
- (else (write-uint24-be offset)))))
+ (else (write-int24-be offset)))))
(let ((inst (car asm))
- (args (cdr asm))
- (write-uint16 (case byte-order
- ((1234) write-uint16-le)
- ((4321) write-uint16-be)
- (else (error "unknown endianness" byte-order)))))
+ (args (cdr asm)))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
- (write-byte opcode)
+ (if emit-opcode?
+ (write-byte opcode))
(pmatch asm
((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
- (letrec ((i 0)
- (write (lambda (x) (set! i (1+ i)) (write-byte x)))
- (get-addr (lambda () i)))
- (for-each (lambda (asm)
- (write-bytecode asm write get-addr labels))
- code))
+ (fold (lambda (asm address)
+ (let ((start (port-position port)))
+ (write-bytecode asm port labels address #t)
+ (+ address (- (port-position port) start))))
+ 0
+ code)
(if meta
- ;; don't write the load-program byte for metadata
- (letrec ((i -1)
- (write (lambda (x)
- (set! i (1+ i))
- (if (> i 0) (write-byte x))))
- (get-addr (lambda () i)))
- ;; META's bytecode meets the alignment requirements of
- ;; `scm_objcode', thanks to the alignment computed in
- ;; `(language assembly)'.
- (write-bytecode meta write get-addr '()))))
+ ;; Don't emit the `load-program' byte for metadata. Note that
+ ;; META's bytecode meets the alignment requirements of
+ ;; `scm_objcode', thanks to the alignment computed in `(language
+ ;; assembly)'.
+ (write-bytecode meta port '() 0 #f)))
((make-char32 ,x) (write-uint32-be x))
((load-number ,str) (write-loader str))
((load-string ,str) (write-loader str))
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index 304a84d..6e89d86 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -16,6 +16,7 @@
(define-module (test-suite tests asm-to-bytecode)
#:use-module (rnrs bytevector)
+ #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
#:use-module (system vm instruction)
#:use-module (language assembly compile-bytecode))
@@ -32,7 +33,7 @@
(define (munge-bytecode v)
(let lp ((i 0) (out '()))
(if (= i (vector-length v))
- (list->u8vector (reverse out))
+ (u8-list->bytevector (reverse out))
(let ((x (vector-ref v i)))
(cond
((symbol? x)
@@ -44,16 +45,17 @@
(else (error "bad test bytecode" x)))))))
(define (comp-test x y)
- (let* ((y (munge-bytecode y))
- (len (u8vector-length y))
- (v (make-u8vector len))
- (i 0))
- (define (write-byte b) (u8vector-set! v i b) (set! i (1+ i)))
- (define (get-addr) i)
+ (let* ((y (munge-bytecode y))
+ (len (bytevector-length y))
+ (v #f))
+
(run-test `(length ,x) #t
(lambda ()
- (write-bytecode x write-byte get-addr '())
- (= i len)))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ (write-bytecode x port '() 0 #t)
+ (set! v (get-bytevector))
+ (= (bytevector-length v) len)))))
(run-test `(compile-equal? ,x ,y) #t
(lambda ()
(equal? v y)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-7-58-g524aa8a,
Ludovic Courtès <=