~ chicken-r7rs (master) f26fa02acd5737e0b872cd1dd3a63b77f37f4179
commit f26fa02acd5737e0b872cd1dd3a63b77f37f4179
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Mon May 26 19:53:42 2014 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon May 26 19:53:42 2014 +0000
Generative d-r-t, remove ports dep, misc cleanup
diff --git a/NOTES.org b/NOTES.org
index 65f8931..100b899 100644
--- a/NOTES.org
+++ b/NOTES.org
@@ -1,12 +1,5 @@
NOTES
-
-* Redefinition of "import" may be tricky, as it is implicit and not in any module.
- - possible reimplement using core functionality.
-
-* Use of "define-values" is elegant but loses lambda-info for the defined procedures.
- - Removed.
-
* "export" does not support "(rename ...)" specifier yet.
- this needs extensions to the core module system.
@@ -23,10 +16,9 @@ NOTES
* Should bytevectors be implemented over blobs instead of srfi-4 (or something else)?
* I think library forms (i.e. ".sld" files) should look for includes relative to themselves
+ - this seems to be the standard amongst other Schemes that support R7RS-style libs
- not sure how to get that info when expanding define-library
-* UTF8? Not required, but should (use r7rs) include this extension, like it includes numbers?
-
* get-environment-variable: "It is also an error to mutate the resulting string" ...
- can we just ignore this?
diff --git a/r7rs-compile-time-module.scm b/r7rs-compile-time-module.scm
index 0ff9be8..5f004d3 100644
--- a/r7rs-compile-time-module.scm
+++ b/r7rs-compile-time-module.scm
@@ -3,6 +3,7 @@
process-cond-expand
fixup-import/export-spec
parse-library-name
+ wrap-er-macro-transformer
import-transformer
read-forms
register-r7rs-module
diff --git a/r7rs-compile-time.scm b/r7rs-compile-time.scm
index 854df7d..cc4eba4 100644
--- a/r7rs-compile-time.scm
+++ b/r7rs-compile-time.scm
@@ -80,19 +80,26 @@
(else
(syntax-error loc "invalid import/export specifier" spec))))
-(define (import-transformer type)
+(define (wrap-er-macro-transformer name handler)
(er-macro-transformer
- (let ((%import (caddr (assq type (##sys#macro-environment))))) ; XXX safe?
+ (let ((orig (caddr (assq name (##sys#macro-environment)))))
(lambda (x r c)
- `(##core#begin
- ,@(map (lambda (spec)
- (let ((spec (fixup-import/export-spec spec type))
- (name (import/export-spec-feature-name spec type)))
- (%import (list type spec) '() (##sys#current-environment))
- (if (memq name '(scheme foreign)) ; XXX others?
- '(##core#undefined)
- `(##core#require-extension (,name) #f))))
- (strip-syntax (cdr x))))))))
+ (let ((e (##sys#current-environment)))
+ (handler x r c (lambda (x*) (orig x* '() e))))))))
+
+(define (import-transformer type)
+ (wrap-er-macro-transformer
+ type
+ (lambda (x r c import)
+ `(##core#begin
+ ,@(map (lambda (spec)
+ (let ((spec (fixup-import/export-spec spec type))
+ (name (import/export-spec-feature-name spec type)))
+ (import (list type spec))
+ (if (memq name '(scheme foreign)) ; XXX others?
+ '(##core#undefined)
+ `(##core#require-extension (,name) #f))))
+ (strip-syntax (cdr x)))))))
(define (read-forms filename ci?)
(parameterize ((case-sensitive (not ci?)))
@@ -162,7 +169,7 @@
(##core#module
,real-name ((,dummy-export))
;; gruesome hack: we add a dummy export for adding indirect exports
- (##core#define-syntax ,dummy-export (##core#lambda () #f))
+ (##core#define-syntax ,dummy-export (##core#lambda _ '(##core#undefined)))
;; Another gruesome hack: provide feature so "use" works properly
(##sys#provide (##core#quote ,real-name))
;; Set up an R7RS environment for the module's body.
@@ -172,7 +179,7 @@
(_ (syntax-error 'define-library "invalid library definition" form))))
(define (register-r7rs-module name)
- (let ((dummy (string->symbol (string-append (symbol->string name) "-dummy-export"))))
+ (let ((dummy (string->symbol (conc "\x04r7rs" name))))
(put! name '##r7rs#module dummy)
dummy))
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 9f9cc5a..0dd0025 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -7,7 +7,7 @@
apply
assoc assq assv
begin
- binary-port? ; XXX
+ binary-port?
boolean? boolean=?
bytevector
bytevector-append
@@ -33,9 +33,9 @@
cons
current-input-port current-output-port current-error-port
define
- define-record-type ; TODO
+ define-record-type
define-syntax
- define-values ; TODO
+ define-values
denominator numerator
do
dynamic-wind
@@ -143,7 +143,7 @@
#|
syntax-rules ; provided by the "r7rs" module
|#
- textual-port? ; XXX
+ textual-port?
truncate
truncate/ truncate-quotient truncate-remainder
u8-ready?
diff --git a/scheme.base.scm b/scheme.base.scm
index 3074371..f87b183 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -6,8 +6,7 @@
assoc list-set! list-tail member
char=? char<? char>? char<=? char>=?
string=? string<? string>? string<=? string>=?
- string-copy string->list
- vector->list))
+ string-copy string->list vector->list))
(import (prefix (only scheme char=? char<? char>? char<=? char>=?
string=? string<? string>? string<=? string>=?)
%))
@@ -23,8 +22,6 @@
(make-u8vector make-bytevector)
(write-u8vector write-bytevector)))
-(import (only ports make-input-port make-output-port))
-
(%include "scheme.base-interface.scm")
;; For syntax definition helpers.
@@ -53,6 +50,9 @@
(import (prefix (only srfi-13 string-for-each string-map) %))
(import (only srfi-13 string-copy string-copy! string-fill! string->list))
+;; For d-r-t redefinition.
+(import-for-syntax (only chicken define-record-type))
+
;;;
;;; 4.1.7. Inclusion
;;;
@@ -143,6 +143,26 @@
(lambda ()
(apply values args))))))))))))))
+;;;
+;;; 5.5 Record-type definitions
+;;;
+
+;; Rewrite the standard d-r-t expansion so that each newly-defined
+;; record type has a unique type tag. This is every kind of hacky.
+(define-syntax define-record-type
+ (wrap-er-macro-transformer
+ 'define-record-type
+ (lambda (e r c define-record-type)
+ (let ((name (cadr e))
+ (tag (gensym "\x04r7rsrecord-type-tag")))
+ `(##core#begin
+ (##core#set! ,(r tag)
+ (##sys#make-symbol ,(symbol->string name)))
+ ,(let lp ((x (define-record-type e)))
+ (cond ((equal? x `(##core#quote ,name)) (r tag))
+ ((pair? x) (cons (lp (car x)) (lp (cdr x))))
+ (else x))))))))
+
;;;
;;; 6.2.6 Numerical operations
;;;
@@ -155,21 +175,9 @@
;;; 6.3 Booleans
;;;
-;(: boolean=? ((procedure #:enforce) (boolean boolean #!rest boolean) boolean))
(: boolean=? (boolean boolean #!rest boolean -> boolean))
-(define (boolean=? b1 b2 . rest)
- (##sys#check-boolean b1 'boolean=?)
- ;; Loop across all args, checking for booleans. Don't shortcut and
- ;; stop when we find nonequality.
- (let lp ((b1 b1)
- (b2 b2)
- (rest rest)
- (result (eq? b1 b2)))
- (##sys#check-boolean b2 'boolean=?)
- (if (null? rest)
- (and result (eq? b1 b2))
- (lp b2 (car rest) (cdr rest) (and result (eq? b1 b2))))))
+(define-extended-arity-comparator boolean=? eq? ##sys#check-boolean)
;;;
@@ -647,7 +655,7 @@
(: error-object-message ((struct condition) -> string))
(: error-object-irritants ((struct condition) -> list))
-(define error-object? condition?)
+(define (error-object? o) (condition? o))
(define error-object-message (condition-property-accessor 'exn 'message))
(define error-object-irritants (condition-property-accessor 'exn 'arguments))
@@ -675,7 +683,7 @@
;;; 6.13. Input and Output
;;;
-(: binary-port? (* --> boolean))
+(: binary-port? (* --> boolean : port?))
(: call-with-port (port (port -> . *) -> . *))
(: close-port (port -> void))
(: eof-object (--> eof))
@@ -686,15 +694,14 @@
(: read-bytevector! (bytevector #!optional input-port number number -> fixnum))
(: read-string (number #!optional input-port -> (or string eof)))
(: read-u8 (#!optional input-port -> fixnum))
-(: textual-port? (* --> boolean))
+(: textual-port? (* --> boolean : port?))
(: u8-ready? (#!optional input-port -> boolean))
(: write-string (string #!optional input-port fixnum fixnum -> void))
(: write-u8 (fixnum #!optional output-port -> void))
-;; sic, TODO
-
-(define binary-port? port?)
-(define textual-port? port?)
+;; CHICKEN's ports can handle both.
+(define (binary-port? port) (port? port))
+(define (textual-port? port) (port? port))
(define (call-with-port port proc)
(receive ret
@@ -713,6 +720,7 @@
(define (output-port-open? port)
(##sys#check-output-port port #f 'output-port-open?)
(not (port-closed? port)))
+
(define (input-port-open? port)
(##sys#check-input-port port #f 'input-port-open?)
(not (port-closed? port)))
@@ -787,22 +795,33 @@
(read-u8vector!/eof (fx- end start) bv port start)))))
(define (open-input-bytevector bv)
- (let ((index 0)
- (bv-len (bytevector-length bv)))
- (make-input-port
- (lambda () ; read-char
- (if (= index bv-len)
- (eof-object)
- (let ((c (bytevector-u8-ref bv index)))
- (set! index (+ index 1))
- (integer->char c))))
- (lambda () ; char-ready?
- (not (= index bv-len)))
- (lambda () #t) ; close
- (lambda () ; peek-char
- (if (= index bv-len)
- (eof-object)
- (bytevector-u8-ref bv index))))))
+ (let ((port (##sys#make-port #t #f "(bytevector)" 'custom)))
+ (##sys#setslot
+ port
+ 2
+ (let ((index 0)
+ (bv-len (bytevector-length bv)))
+ (vector (lambda (_) ; read-char
+ (if (fx= index bv-len)
+ (eof-object)
+ (let ((c (bytevector-u8-ref bv index)))
+ (set! index (fx+ index 1))
+ (integer->char c))))
+ (lambda (_) ; peek-char
+ (if (fx= index bv-len)
+ (eof-object)
+ (bytevector-u8-ref bv index)))
+ #f ; write-char
+ #f ; write-string
+ (lambda (_) ; close
+ (##sys#setislot port 8 #t))
+ #f ; flush-output
+ (lambda (_) ; char-ready?
+ (not (fx= index bv-len)))
+ #f ; read-string!
+ #f ; read-line
+ #f))) ; read-buffered
+ port))
(define (open-output-bytevector) (open-output-string))
diff --git a/tests/run.scm b/tests/run.scm
index 66e93b4..e6abac7 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -973,6 +973,12 @@
(import (scheme base))
(begin (eq? numbers#+ +)))))
+(test-group "define-record-type"
+ (define-record-type foo (make-foo) foo?)
+ (define foo (make-foo))
+ (test-assert "Record instances satisfy their predicates" (foo? foo))
+ (define-record-type foo (make-foo) foo?)
+ (test-assert "Record type definitions are generative" (not (foo? foo))))
(test-group "open-input-bytevector"
(test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
Trap