conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixes bug 162741: hygiene breaks exported macros that introduce define-record-type

This commit is contained in:
Abdulaziz Ghuloum 2007-11-14 17:24:29 -05:00
parent 6c1dbba3de
commit 25aa8d7072
3 changed files with 29 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

29
scheme/ikarus.numerics.ss
View File

@ -21,7 +21,7 @@
(library (ikarus flonums) (library (ikarus flonums)
(export $flonum->exact $flonum-signed-biased-exponent flonum-parts (export $flonum->exact flonum-parts
inexact->exact exact $flonum-rational? $flonum-integer? $flzero? inexact->exact exact $flonum-rational? $flonum-integer? $flzero?
$flnegative? flpositive? flabs fixnum->flonum $flnegative? flpositive? flabs fixnum->flonum
flsin flcos fltan flasin flacos flatan fleven? flodd? flsin flcos fltan flasin flacos flatan fleven? flodd?
@ -31,10 +31,9 @@
(import (import
(ikarus system $bytevectors) (ikarus system $bytevectors)
(ikarus system $fx) (ikarus system $fx)
(only (ikarus system $flonums) $fl>=) (only (ikarus system $flonums) $fl>= $flonum-sbe)
(ikarus system $bignums) (ikarus system $bignums)
(except (ikarus system $flonums) $flonum-signed-biased-exponent (except (ikarus system $flonums) $flonum-rational? $flonum-integer?)
$flonum-rational? $flonum-integer?)
(except (ikarus) inexact->exact exact flpositive? flabs fixnum->flonum (except (ikarus) inexact->exact exact flpositive? flabs fixnum->flonum
flsin flcos fltan flasin flacos flatan fleven? flodd? flsin flcos fltan flasin flacos flatan fleven? flodd?
flfloor flceiling flnumerator fldenominator flexp fllog flfloor flceiling flnumerator fldenominator flexp fllog
@ -76,20 +75,13 @@
($fxzero? ($flonum-u8-ref f 2)) ($fxzero? ($flonum-u8-ref f 2))
($fxzero? ($fxlogand ($flonum-u8-ref f 1) #b1111)))) ($fxzero? ($fxlogand ($flonum-u8-ref f 1) #b1111))))
(define ($flonum-signed-biased-exponent x)
(let ([b0 ($flonum-u8-ref x 0)]
[b1 ($flonum-u8-ref x 1)])
($fxlogor ($fxsll b0 4) ($fxsra b1 4))))
(define ($flonum-rational? x) (define ($flonum-rational? x)
(let ([be ($fxlogand ($flonum-signed-biased-exponent x) (let ([be ($fxlogand ($flonum-sbe x)
($fxsub1 ($fxsll 1 11)))]) ($fxsub1 ($fxsll 1 11)))])
($fx< be 2047))) ($fx< be 2047)))
(define ($flonum-integer? x) (define ($flonum-integer? x)
(let ([be ($fxlogand ($flonum-signed-biased-exponent x) (let ([be ($fxlogand ($flonum-sbe x)
($fxsub1 ($fxsll 1 11)))]) ($fxsub1 ($fxsll 1 11)))])
(cond (cond
[($fx= be 2047) ;;; nans and infs [($fx= be 2047) ;;; nans and infs
@ -156,26 +148,26 @@
(define (flinfinite? x) (define (flinfinite? x)
(if (flonum? x) (if (flonum? x)
(let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))]) (let ([be (fxlogand ($flonum-sbe x) (sub1 (fxsll 1 11)))])
(and (fx= be 2047) ;;; nans and infs (and (fx= be 2047) ;;; nans and infs
($zero-m? x))) ($zero-m? x)))
(error 'flinfinite? "not a flonum" x))) (error 'flinfinite? "not a flonum" x)))
(define (flnan? x) (define (flnan? x)
(if (flonum? x) (if (flonum? x)
(let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))]) (let ([be (fxlogand ($flonum-sbe x) (sub1 (fxsll 1 11)))])
(and (fx= be 2047) ;;; nans and infs (and (fx= be 2047) ;;; nans and infs
(not ($zero-m? x)))) (not ($zero-m? x))))
(error 'flnan? "not a flonum" x))) (error 'flnan? "not a flonum" x)))
(define (flfinite? x) (define (flfinite? x)
(if (flonum? x) (if (flonum? x)
(let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))]) (let ([be (fxlogand ($flonum-sbe x) (sub1 (fxsll 1 11)))])
(not (fx= be 2047))) (not (fx= be 2047)))
(error 'flfinite? "not a flonum" x))) (error 'flfinite? "not a flonum" x)))
(define ($flzero? x) (define ($flzero? x)
(let ([be (fxlogand ($flonum-signed-biased-exponent x) (sub1 (fxsll 1 11)))]) (let ([be (fxlogand ($flonum-sbe x) (sub1 (fxsll 1 11)))])
(and (and
(fx= be 0) ;;; denormalized double, only +/-0.0 is integer (fx= be 0) ;;; denormalized double, only +/-0.0 is integer
(and (fx= ($flonum-u8-ref x 7) 0) (and (fx= ($flonum-u8-ref x 7) 0)
@ -203,6 +195,9 @@
[else #f]))) [else #f])))
(define (inexact->exact x) (define (inexact->exact x)
(cond (cond
[(flonum? x) [(flonum? x)

34
scheme/psyntax.expander.ss
View File

@ -1527,14 +1527,14 @@
(syntax-match spec () (syntax-match spec ()
[(foo make-foo foo?) foo] [(foo make-foo foo?) foo]
[foo foo])) [foo foo]))
(define (get-record-constructor-name spec ctxt) (define (get-record-constructor-name spec)
(syntax-match spec () (syntax-match spec ()
[(foo make-foo foo?) make-foo] [(foo make-foo foo?) make-foo]
[foo (id ctxt "make-" (stx->datum foo))])) [foo (id? foo) (id foo "make-" (stx->datum foo))]))
(define (get-record-predicate-name spec ctxt) (define (get-record-predicate-name spec)
(syntax-match spec () (syntax-match spec ()
[(foo make-foo foo?) foo?] [(foo make-foo foo?) foo?]
[foo (id ctxt (stx->datum foo) "?")])) [foo (id? foo) (id foo (stx->datum foo) "?")]))
(define (get-clause id ls) (define (get-clause id ls)
(syntax-match ls () (syntax-match ls ()
[() #f] [() #f]
@ -1542,7 +1542,7 @@
(if (free-id=? (bless id) x) (if (free-id=? (bless id) x)
`(,x . ,rest) `(,x . ,rest)
(get-clause id ls))])) (get-clause id ls))]))
(define (foo-rtd-code ctxt name clause*) (define (foo-rtd-code name clause*)
(define (convert-field-spec* ls) (define (convert-field-spec* ls)
(list->vector (list->vector
(map (lambda (x) (map (lambda (x)
@ -1601,9 +1601,9 @@
(cons i (f rest (+ i 1)))] (cons i (f rest (+ i 1)))]
[(_ . rest) [(_ . rest)
(f rest (+ i 1))]))) (f rest (+ i 1))])))
(define (get-mutators foo fields ctxt) (define (get-mutators foo fields)
(define (gen-name x) (define (gen-name x)
(datum->syntax ctxt (datum->syntax foo
(string->symbol (string->symbol
(string-append "set-" (string-append "set-"
(symbol->string (syntax->datum foo)) (symbol->string (syntax->datum foo))
@ -1618,9 +1618,9 @@
[((mutable name) . rest) [((mutable name) . rest)
(cons (gen-name name) (f rest))] (cons (gen-name name) (f rest))]
[(_ . rest) (f rest)]))) [(_ . rest) (f rest)])))
(define (get-accessors foo fields ctxt) (define (get-accessors foo fields)
(define (gen-name x) (define (gen-name x)
(datum->syntax ctxt (datum->syntax foo
(string->symbol (string->symbol
(string-append (string-append
(symbol->string (syntax->datum foo)) (symbol->string (syntax->datum foo))
@ -1641,19 +1641,19 @@
(cond (cond
[(null? ls) '()] [(null? ls) '()]
[else (cons i (f (cdr ls) (+ i 1)))]))) [else (cons i (f (cdr ls) (+ i 1)))])))
(define (do-define-record ctxt namespec clause*) (define (do-define-record namespec clause*)
(let* ([foo (get-record-name namespec)] (let* ([foo (get-record-name namespec)]
[foo-rtd (gensym)] [foo-rtd (gensym)]
[foo-rcd (gensym)] [foo-rcd (gensym)]
[protocol (gensym)] [protocol (gensym)]
[make-foo (get-record-constructor-name namespec ctxt)] [make-foo (get-record-constructor-name namespec)]
[fields (get-fields clause*)] [fields (get-fields clause*)]
[idx* (enumerate fields)] [idx* (enumerate fields)]
[foo-x* (get-accessors foo fields ctxt)] [foo-x* (get-accessors foo fields)]
[set-foo-x!* (get-mutators foo fields ctxt)] [set-foo-x!* (get-mutators foo fields)]
[set-foo-idx* (get-mutator-indices fields)] [set-foo-idx* (get-mutator-indices fields)]
[foo? (get-record-predicate-name namespec ctxt)] [foo? (get-record-predicate-name namespec)]
[foo-rtd-code (foo-rtd-code ctxt foo clause*)] [foo-rtd-code (foo-rtd-code foo clause*)]
[foo-rcd-code (foo-rcd-code clause* foo-rtd protocol)] [foo-rcd-code (foo-rcd-code clause* foo-rtd protocol)]
[protocol-code (get-protocol-code clause*)]) [protocol-code (get-protocol-code clause*)])
(bless (bless
@ -1673,8 +1673,8 @@
`(define ,set-foo-x! (record-mutator ,foo-rtd ,idx))) `(define ,set-foo-x! (record-mutator ,foo-rtd ,idx)))
set-foo-x!* set-foo-idx*))))) set-foo-x!* set-foo-idx*)))))
(syntax-match x () (syntax-match x ()
[(ctxt namespec clause* ...) [(_ namespec clause* ...)
(do-define-record ctxt namespec clause*)]))) (do-define-record namespec clause*)])))
(define define-condition-type-macro (define define-condition-type-macro
(lambda (x) (lambda (x)