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

34
scheme/psyntax.expander.ss
View File

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