suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

R6RS fixes; fix for <, >, <=, and >= with +nan.0 and a bignum or rational; compile two-byte regexp patterns (common for hand-rolled case-insensitivity, as in the R6RS parser) to a more compact and efficient representation

Browse Source 
svn: r8898
This commit is contained in:
Matthew Flatt 2008-03-06 04:56:47 +00:00
parent c72b0017ca
commit f3d74fa4c8
21 changed files with 1533 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/r5rs/main.ss
View File

@ -193,9 +193,7 @@
(if (zero? depth)
#'e
#`(mcons 'unquote
(mcons
#,(loop #'e (sub1 depth))
null)))]
#,(loop (cdr (syntax-e form)) (sub1 depth))))]
[unquote
(zero? depth)
(raise-syntax-error
@ -207,8 +205,7 @@
(if (zero? depth)
#`(mappend e #,(loop #'rest depth))
#`(mcons (mcons 'unquote-splicing
(mcons #,(loop #'e (sub1 depth))
null))
#,(loop #'(e) (sub1 depth)))
#,(loop #'rest depth)))]
[unquote-splicing
(zero? depth)
@ -222,8 +219,7 @@
[(a . b)
#`(mcons #,(loop #'a depth) #,(loop #'b depth))]
[#(a ...)
#`(vector . #,(map (lambda (e) (loop e depth))
(syntax->list #'(a ...))))]
#`(mlist->vector #,(loop (syntax->list #'(a ...)) depth))]
[other #'(r5rs:quote other)]))
;; None, so just use R5RS quote:
#'(r5rs:quote form))]))

3
collects/r6rs/private/identifier-syntax.ss
View File

@ -5,7 +5,8 @@
(provide identifier-syntax)
(define-syntax (identifier-syntax stx)
(syntax-case stx (set!)
(syntax-case* stx (set!) (lambda (a b)
(free-template-identifier=? a b))
[(identifier-syntax template)
#'(...
(make-set!-transformer

29
collects/r6rs/private/qq-gen.ss
View File

@ -17,8 +17,9 @@
(let loop ([tmpl #'tmpl][level 0])
(syntax-case tmpl (r6rs:quasiquote)
[((u expr ...) . rest)
(or (free-identifier=? #'u #'unquote)
(free-identifier=? #'u #'unquote-splicing))
(and (identifier? #'u)
(or (free-identifier=? #'u #'unquote)
(free-identifier=? #'u #'unquote-splicing)))
(let ([new-rest (loop #'rest level)])
(if (zero? level)
(if (and (eq? new-rest #'rest)
@ -46,13 +47,15 @@
(cons new-first new-rest)
tmpl tmpl tmpl)))))]
[(r6rs:quasiquote expr)
(let ([new-expr (loop #'expr (add1 level))])
(if (eq? new-expr #'expr)
tmpl
(datum->syntax
tmpl
(cons (car (syntax-e tmpl) new-expr))
tmpl tmpl tmpl)))]
(let ([new-expr (loop #'(expr) (add1 level))])
;; We have to replace the old qq with the new one:
(datum->syntax
tmpl
(cons (datum->syntax #'quasiquote
'quasiquote
(car (syntax-e tmpl)))
new-expr)
tmpl tmpl tmpl))]
[(a . b)
(let ([new-a (loop #'a level)]
[new-b (loop #'b level)])
@ -65,10 +68,8 @@
tmpl tmpl tmpl)))]
[#(a ...)
(let* ([as (syntax->list #'(a ...))]
[new-as (map (lambda (a)
(loop a level))
as)])
(if (andmap eq? as new-as)
[new-as (loop as level)])
(if (eq? as new-as)
tmpl
(datum->syntax
tmpl
@ -77,5 +78,5 @@
[_ tmpl]))])
(datum->syntax
stx
(list #'r5rs:quasiquote new-tmpl)
(list #'quasiquote new-tmpl)
stx stx stx))]))))

26
collects/r6rs/private/readtable.ss
View File

@ -411,24 +411,24 @@
(define (ureal R) (or (uinteger R)
(seq (uinteger R) "/" (uinteger R))
(seq (decimal R) mantissa-width)))
(define naninf (or "nan[.]0" "inf[.]0"))
(define naninf (or "[nN][aA][nN][.]0" "[iI][nN][fF][.]0"))
(define (real R) (or (seq sign (ureal R))
(seq "[+]" naninf)
(seq "-" naninf)))
(define (complex R) (or (real R)
(seq (real R) "@" (real R))
(seq (real R) "[+]" (ureal R) "i")
(seq (real R) "-" (ureal R) "i")
(seq (real R) "[+]" naninf "i")
(seq (real R) "-" naninf "i")
(seq (real R) "[+]i")
(seq (real R) "-i")
(seq "[+]" (ureal R) "i")
(seq "-" (ureal R) "i")
(seq "[+]" naninf "i")
(seq "-" naninf "i")
"[+]i"
"-i"))
(seq (real R) "[+]" (ureal R) "[iI]")
(seq (real R) "-" (ureal R) "[iI]")
(seq (real R) "[+]" naninf "[iI]")
(seq (real R) "-" naninf "[iI]")
(seq (real R) "[+][iI]")
(seq (real R) "-[iI]")
(seq "[+]" (ureal R) "[iI]")
(seq "-" (ureal R) "[iI]")
(seq "[+]" naninf "[iI]")
(seq "-" naninf "[iI]")
"[+][iI]"
"-[iI]"))
(define (num R) (seq (prefix R) (complex R)))
(define number (or (num 10)
(num 16)

12
collects/r6rs/scribblings/r6rs.scrbl
View File

@ -176,12 +176,12 @@ Beware that a @defterm{pair} in @|r6rs| corresponds to a
@defterm{mutable pair} in @schememodname[scheme/base]. Otherwise,
@|r6rs| libraries and @schememodname[scheme/base] share the same
datatype for numbers, characters, strings, bytevectors (a.k.a. byte
strings), vectors, hash tables, and so on. Input and output
ports from @schememodname[scheme/base] can be used directly as binary
ports with @|r6rs| libraries, and all @|r6rs| ports can be used as
ports in @schememodname[scheme/base] programs, but only textual ports
created via @|r6rs| libraries can be used by other @|r6rs| operations
that expect textual ports.
strings), vectors, and so on. Hash tables are different. Input and
output ports from @schememodname[scheme/base] can be used directly as
binary ports with @|r6rs| libraries, and all @|r6rs| ports can be used
as ports in @schememodname[scheme/base] programs, but only textual
ports created via @|r6rs| libraries can be used by other @|r6rs|
operations that expect textual ports.
@; ----------------------------------------------------------------------

158
collects/rnrs/base-6.ss
View File

@ -33,8 +33,9 @@
;; 11.4.6
let let*
(rename-out [r5rs:letrec letrec]
[letrec letrec*])
let-values let*-values
[letrec letrec*]
[r6rs:let-values let-values]
[r6rs:let*-values let*-values])
;; 11.4.7
begin
@ -55,7 +56,8 @@
zero? positive? negative? odd?
even? finite? infinite? nan?
min max
+ * - /
+ * -
(rename-out [r6rs:/ /])
abs
div-and-mod div mod
div0-and-mod0 div0 mod0
@ -66,8 +68,9 @@
exp log sin cos tan asin acos atan
sqrt (rename-out [integer-sqrt/remainder exact-integer-sqrt])
expt
make-rectangular make-polar real-part imag-part magnitude angle
(rename-out [r6rs:number->string number->string]
make-rectangular make-polar real-part imag-part magnitude
(rename-out [r6rs:angle angle]
[r6rs:number->string number->string]
[r6rs:string->number string->number])
;; 11.8
@ -160,7 +163,8 @@
unquote unquote-splicing
;; 11.18
let-syntax letrec-syntax
(rename-out [r6rs:let-syntax let-syntax]
[r6rs:letrec-syntax letrec-syntax])
;; 11.19
(for-syntax syntax-rules
@ -245,6 +249,51 @@
(let ([d (div0 x y)])
(values d (- x (* d y)))))
(define-syntax r6rs:/
;; R6RS says that division with exact zero is treated like
;; division by inexact zero if any of the other arguments are inexact.
;; We use a macro to inline tests in binary mode, since the JIT
;; can inline for flonum arithmetic.
(make-set!-transformer
(lambda (stx)
(if (identifier? stx)
(syntax/loc stx r6rs-/)
(syntax-case stx (set!)
[(set! . _)
(raise-syntax-error #f
"cannot mutate imported identifier"
stx)]
[(_ expr) #'(/ expr)]
[(_ expr1 expr2)
#'(let ([a expr1]
[b expr2])
(cond
[(and (eq? b 0) (inexact-real? a))
(/ a 0.0)]
[(and (eq? a 0) (inexact-real? b))
(/ 0.0 b)]
[else (/ a b)]))]
[(_ . args)
#'(r6rs-/ . args)])))))
(define r6rs-/
(case-lambda
[(n) (/ n)]
[(a b) (r6rs:/ a b)]
[args (if (ormap inexact-real? args)
(apply /
(map (lambda (v) (if (eq? v 0)
0.0
v))
args))
(apply / args))]))
(define (r6rs:angle n)
; because `angle' produces exact 0 for reals:
(if (and (inexact-real? n) (positive? n))
0.0
(angle n)))
(define (r6rs:number->string z [radix 10] [precision #f])
(number->string z radix))
@ -298,7 +347,7 @@
(define (assertion-violation who msg . irritants)
(raise
(make-exn:fail:r6rs
(make-exn:fail:contract:r6rs
(format "~a: ~a" who msg)
(current-continuation-marks)
who
@ -312,7 +361,57 @@
;; quasiquote generalization
(define-generalized-qq r6rs:quasiquote
quasiquote unquote unquote-splicing)
r5rs:quasiquote unquote unquote-splicing)
;; ----------------------------------------
;; let[*]-values
(define-syntax (r6rs:let-values stx)
#`(letX-values let-values #,stx))
(define-syntax (r6rs:let*-values stx)
#`(letX-values let*-values #,stx))
(define-syntax (letX-values stx)
(syntax-case stx ()
[(_ dest:let-values orig)
(let ([orig #'orig])
(syntax-case orig ()
[(_ ([formals expr] ...) body0 body ...)
(with-syntax ([bindings
(map (lambda (formals expr)
(if (syntax->list formals)
(list formals expr)
(let ([ids (let loop ([formals formals])
(cond
[(identifier? formals)
(list formals)]
[(and (syntax? formals)
(pair? (syntax-e formals)))
(loop (syntax-e formals))]
[(pair? formals)
(unless (identifier? (car formals))
(raise-syntax-error
#f
"not an identifier for binding"
orig
(car formals)))
(cons (car formals) (loop (cdr formals)))]
[else
(unless (identifier? (car formals))
(raise-syntax-error
#f
"not an identifier for binding"
orig
formals))]))])
#`[#,ids
(call-with-values
(lambda () #,expr)
(r5rs:lambda #,formals
(values . #,ids)))])))
(syntax->list #'(formals ...))
(syntax->list #'(expr ...)))])
#'(dest:let-values bindings body0 body ...))]))]))
;; ----------------------------------------
;; define
@ -370,6 +469,49 @@
;; ----------------------------------------
;; let[rec]-syntax needs to be splicing, ad it needs the
;; same transformer wrapper as in `define-syntax'
(define-for-syntax (do-let-syntax stx rec?)
(syntax-case stx ()
[(_ ([id expr] ...) body ...)
(let ([sli (if (list? (syntax-local-context))
syntax-local-introduce
values)])
(let ([ids (map sli (syntax->list #'(id ...)))]
[def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(let* ([add-context
(lambda (expr)
(let ([q (local-expand #`(quote #,expr)
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ expr) #'expr])))])
(with-syntax ([(id ...)
(map sli (map add-context ids))]
[(expr ...)
(let ([exprs (syntax->list #'(expr ...))])
(if rec?
(map add-context exprs)
exprs))]
[(body ...)
(map add-context (syntax->list #'(body ...)))])
#'(begin
(define-syntax id (wrap-as-needed expr))
...
body ...)))))]))
(define-syntax (r6rs:let-syntax stx)
(do-let-syntax stx #f))
(define-syntax (r6rs:letrec-syntax stx)
(do-let-syntax stx #t))
;; ----------------------------------------
(define detect-tail-key (gensym))
(define (mk-k full-k tag)

15
collects/rnrs/bytevectors-6.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require rnrs/enums-6)
(require rnrs/enums-6
scheme/mpair)
(provide endianness
native-endianness
@ -10,9 +11,9 @@
[bytes-copy! bytevector-copy!]
[bytes-copy bytevector-copy]
[bytes-ref bytevector-u8-ref]
[bytes-set! bytevector-u8-set!]
[bytes->list bytevector->u8-list]
[list->bytes u8-list->bytevector])
[bytes-set! bytevector-u8-set!])
bytevector->u8-list
u8-list->bytevector
make-bytevector
bytevector-fill!
bytevector-s8-ref
@ -64,6 +65,12 @@
(endianness big)
(endianness little)))
(define (bytevector->u8-list bv)
(list->mlist (bytes->list bv)))
(define (u8-list->bytevector l)
(list->bytes (mlist->list l)))
(define (make-bytevector k [fill 0])
(make-bytes k (convert-fill 'make-bytevector fill)))

3
collects/rnrs/conditions-6.ss
View File

@ -113,7 +113,8 @@
(list (make-irritants-condition (exn:fail:contract:r6rs-irritants c))))
null)
(list (make-non-continuable-violation))
(if (exn:fail:unsupported? c)
(if (or (exn:fail:unsupported? c)
(exn:fail:contract:divide-by-zero? c))
(list (make-implementation-restriction-violation))
null)
(if (exn:fail:read? c)

12
collects/rnrs/records/syntactic-6.ss
View File

@ -160,6 +160,18 @@
"-set!")))))
(syntax
(mutable ?field-name ?accessor-name ?mutator-name))))
(?field-name
(identifier? (syntax ?field-name))
(with-syntax ((?accessor-name
(datum->syntax
(syntax ?field-name)
(string->symbol
(string-append record-name "-"
(symbol->string
(syntax->datum
(syntax ?field-name))))))))
(syntax
(immutable ?field-name ?accessor-name))))
(?clause
clause)))
(syntax (?field-clause ...)))))

21
collects/scheme/private/misc.ss
View File

@ -45,14 +45,19 @@
(/ (find-between (/ (- hi lo-int)) (/ (- lo lo-int)))))))))])
(lambda (x within)
(check x) (check within)
(let* ([delta (abs within)]
[lo (- x delta)]
[hi (+ x delta)])
(cond
[(not (= x x)) +nan.0]
[(<= lo 0 hi) (if (exact? x) 0 0.0)]
[(negative? lo) (- (find-between (- hi) (- lo)))]
[else (find-between lo hi)])))))
(let* ([delta (abs within)]
[lo (- x delta)]
[hi (+ x delta)])
(cond
[(equal? x +nan.0) x]
[(or (equal? x +inf.0)
(equal? x -inf.0))
(if (equal? delta +inf.0) +nan.0 x)]
[(equal? delta +inf.0) 0.0]
[(not (= x x)) +nan.0]
[(<= lo 0 hi) (if (exact? x) 0 0.0)]
[(negative? lo) (- (find-between (- hi) (- lo)))]
[else (find-between lo hi)])))))
;; -------------------------------------------------------------------------

2
collects/scribblings/foreign/types.scrbl
View File

@ -206,7 +206,7 @@ the parameter should be set before any interface definition that uses
@defparam[default-_string-type type ctype?]{
A parameter that determines the current meaning of @scheme[_string].
It is initially set to @scheme[_string/*utf-8]. If you change it, do
It is initially set to @scheme[_string*/utf-8]. If you change it, do
so @italic{before} interfaces are defined.}

25
collects/tests/mzscheme/number.ss
View File

@ -280,6 +280,7 @@
(test-nan +nan.0)
(test-nan +inf.0)
(test-nan -inf.0)
(test-nan (expt 2 90))
(err/rt-test (test-nan 0.3+0.0i))
(test #f = +nan.0 1+2i)
(test #f = +nan.0 (make-rectangular +inf.0 -inf.0))
@ -1247,18 +1248,18 @@
(err/rt-test (ceiling 2.6+0.0i))
(err/rt-test (round 2.6+0.0i))
(err/rt-test (truncate 2.6+0.0i))
(err/rt-test (floor +inf.0))
(err/rt-test (ceiling +inf.0))
(err/rt-test (round +inf.0))
(err/rt-test (truncate +inf.0))
(err/rt-test (floor -inf.0))
(err/rt-test (ceiling -inf.0))
(err/rt-test (round -inf.0))
(err/rt-test (truncate -inf.0))
(err/rt-test (floor +nan0))
(err/rt-test (ceiling +nan0))
(err/rt-test (round +nan0))
(err/rt-test (truncate +nan0))
(test +inf.0 floor +inf.0)
(test +inf.0 ceiling +inf.0)
(test +inf.0 round +inf.0)
(test +inf.0 truncate +inf.0)
(test -inf.0 floor -inf.0)
(test -inf.0 ceiling -inf.0)
(test -inf.0 round -inf.0)
(test -inf.0 truncate -inf.0)
(test +nan.0 floor +nan.0)
(test +nan.0 ceiling +nan.0)
(test +nan.0 round +nan.0)
(test +nan.0 truncate +nan.0)
(define (test-fcrt-int v)
(test v floor v)

5
collects/tests/mzscheme/numstrs.ss
View File

@ -187,6 +187,11 @@
(0.5+nan.0i "1/2+nan.0i")
(1+inf.0i "1+inf.0i")
(1-inf.0i "1-inf.0i")
(+inf.0i "+inf.0i")
(-inf.0i "-inf.0i")
(+nan.0i "+nan.0i")
(-nan.0i "-nan.0i")
(+inf.0i "+INF.0i")
(-inf.0-nan.0i "-inf.0-nan.0i")
(#f "1++inf.0i")
(+nan.0@1 "+nan.0@1")

1015
collects/tests/r6rs/base.ss Normal file
View File

File diff suppressed because it is too large Load Diff

9
collects/tests/r6rs/report.ss Normal file
View File

@ -0,0 +1,9 @@
#!r6rs
(import (rnrs)
(tests r6rs test)
(tests r6rs base))
(run-base-tests)
(report-test-results)

127
collects/tests/r6rs/test.ss Normal file
View File

@ -0,0 +1,127 @@
#!r6rs
(library (tests r6rs test)
(export test
test/approx
test/exn
test/values
test/output
test/unspec
test/unspec-or-exn
test/output/unspec
report-test-results)
(import (rnrs))
(define-record-type err
(fields err-c))
(define-record-type expected-exception
(fields))
(define-syntax test
(syntax-rules ()
[(_ expr expected)
(check-test 'expr
(guard (c [#t (make-err c)])
expr)
expected)]))
(define-syntax test/approx
(syntax-rules ()
[(_ expr expected)
(test (approx expr) (approx expected))]))
(define (approx v)
(let ([n (* (inexact v) 1000.0)])
(+ (round (real-part n))
(* (round (imag-part n)) +1i))))
(define-syntax test/exn
(syntax-rules ()
[(_ expr condition)
(test (guard (c [((condition-predicate condition) c)
(make-expected-exception)])
expr)
(make-expected-exception))]))
(define-syntax test/values
(syntax-rules ()
[(_ expr val ...)
(test (call-with-values
(lambda () expr)
list)
(list val ...))]))
(define-syntax test/output
(syntax-rules ()
[(_ expr expected str)
(check-test 'expr
(capture-output
(lambda ()
(check-test 'expr
(guard (c [#t (make-err c)])
expr)
expected)))
str)]))
(define-syntax test/unspec
(syntax-rules ()
[(_ expr)
(test (begin expr 'unspec) 'unspec)]))
(define-syntax test/unspec-or-exn
(syntax-rules ()
[(_ expr condition)
(test (guard (c [((condition-predicate condition) c)
'unspec])
(begin expr 'unspec))
'unspec)]))
(define-syntax test/output/unspec
(syntax-rules ()
[(_ expr str)
(test/output (begin expr 'unspec) 'unspec str)]))
(define checked 0)
(define failures '())
(define (capture-output thunk)
(if (file-exists? "tmp-catch-out")
(delete-file "tmp-catch-out"))
(with-output-to-file "tmp-catch-out"
thunk)
(call-with-input-file "tmp-catch-out"
(lambda (p)
(get-string-n p 1024))))
(define (check-test expr got expected)
(set! checked (+ 1 checked))
(unless (equal? got expected)
(set! failures
(cons (list expr got expected)
failures))))
(define (report-test-results)
(if (null? failures)
(begin
(display checked)
(display " tests passed\n"))
(begin
(display (length failures))
(display " tests failed:\n")
(for-each (lambda (t)
(display "Expression:\n ")
(write (car t))
(display "\nResult:\n ")
(write (cadr t))
(display "\nExpected:\n ")
(write (caddr t))
(newline))
(reverse failures))
(display (length failures))
(display " of ")
(display checked)
(display " tests failed.\n")))))

108
src/mzscheme/src/number.c
View File

@ -1094,14 +1094,12 @@ floor_prim (int argc, Scheme_Object *argv[])
#ifdef MZ_USE_SINGLE_FLOATS
if (t == scheme_float_type) {
float d = SCHEME_FLT_VAL(o);
if (rational_flt_p((double)d))
return scheme_make_float(floor(d));
return scheme_make_float(floor(d));
}
#endif
if (t == scheme_double_type) {
double d = SCHEME_DBL_VAL(o);
if (rational_dbl_p(d))
return scheme_make_double(floor(d));
return scheme_make_double(floor(d));
}
if (t == scheme_bignum_type)
return o;
@ -1125,14 +1123,12 @@ ceiling (int argc, Scheme_Object *argv[])
#ifdef MZ_USE_SINGLE_FLOATS
if (t == scheme_float_type) {
float d = SCHEME_FLT_VAL(o);
if (rational_flt_p(d))
return scheme_make_float(ceil(d));
return scheme_make_float(ceil(d));
}
#endif
if (t == scheme_double_type) {
double d = SCHEME_DBL_VAL(o);
if (rational_dbl_p(d))
return scheme_make_double(ceil(d));
return scheme_make_double(ceil(d));
}
if (t == scheme_bignum_type)
return o;
@ -1156,24 +1152,20 @@ sch_truncate (int argc, Scheme_Object *argv[])
#ifdef MZ_USE_SINGLE_FLOATS
if (t == scheme_float_type) {
float v = SCHEME_FLT_VAL(o);
if (rational_flt_p(v)) {
if (v > 0)
v = floor(v);
else
v = ceil(v);
return scheme_make_float(v);
}
if (v > 0)
v = floor(v);
else
v = ceil(v);
return scheme_make_float(v);
}
#endif
if (t == scheme_double_type) {
double v = SCHEME_DBL_VAL(o);
if (rational_dbl_p(v)) {
if (v > 0)
v = floor(v);
else
v = ceil(v);
return scheme_make_double(v);
}
if (v > 0)
v = floor(v);
else
v = ceil(v);
return scheme_make_double(v);
}
if (t == scheme_bignum_type)
return o;
@ -1200,28 +1192,26 @@ sch_round (int argc, Scheme_Object *argv[])
double i, frac;
int invert;
if (rational_flt_p(d)) {
if (d < 0) {
d = -d;
invert = 1;
} else
invert = 0;
if (d < 0) {
d = -d;
invert = 1;
} else
invert = 0;
frac = modf(d, &i);
if (frac < 0.5)
d = i;
else if (frac > 0.5)
d = i + 1;
else if (fmod(i, 2.0) != 0.0)
d = i + 1;
else
d = i;
frac = modf(d, &i);
if (frac < 0.5)
d = i;
else if (frac > 0.5)
d = i + 1;
else if (fmod(i, 2.0) != 0.0)
d = i + 1;
else
d = i;
if (invert)
d = -d;
if (invert)
d = -d;
return scheme_make_float((float)d);
}
return scheme_make_float((float)d);
}
#endif
if (t == scheme_double_type) {
@ -1229,28 +1219,26 @@ sch_round (int argc, Scheme_Object *argv[])
double i, frac;
int invert;
if (rational_dbl_p(d)) {
if (d < 0) {
d = -d;
invert = 1;
} else
invert = 0;
if (d < 0) {
d = -d;
invert = 1;
} else
invert = 0;
frac = modf(d, &i);
if (frac < 0.5)
d = i;
else if (frac > 0.5)
d = i + 1;
else if (fmod(i, 2.0) != 0.0)
d = i + 1;
else
d = i;
frac = modf(d, &i);
if (frac < 0.5)
d = i;
else if (frac > 0.5)
d = i + 1;
else if (fmod(i, 2.0) != 0.0)
d = i + 1;
else
d = i;
if (invert)
d = -d;
if (invert)
d = -d;
return scheme_make_double(d);
}
return scheme_make_double(d);
}
if (t == scheme_bignum_type)
return o;

34
src/mzscheme/src/nummacs.h
View File

@ -104,7 +104,7 @@ static Scheme_Object *name (const Scheme_Object *n1, const Scheme_Object *n2)
waybigf, swaybigf, waysmallf, swaysmallf, \
waybigs, swaybigs, waysmalls, swaysmalls, \
combinezero, firstzero, sfirstzero, secondzero, ssecondzero, \
nanchk, snanchk, \
nanchk, snanchk, nanchk_more, snanchk_more, \
complexwrap, noniziwrap, exactzerowrapl, exactzerowrapr, numbertype,\
toi_or_toe) \
rettype name (const Scheme_Object *n1, const Scheme_Object *n2); \
@ -136,7 +136,7 @@ static MZ_INLINE rettype name ## __int_comp(const Scheme_Object *n1, const Schem
FLOATWRAP( \
static MZ_INLINE rettype name ## __flt_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
Small_Rational sr2; \
snanchk(d1); \
snanchk_more(d1); \
wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \
wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \
return toi_or_toe(fsop(d1, scheme_bignum_to_float(n2)), \
@ -145,7 +145,7 @@ static MZ_INLINE rettype name ## __flt_big(const Scheme_Object *n1, const Scheme
FLOATWRAP( \
static MZ_INLINE rettype name ## __flt_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \
Small_Rational sr3; \
snanchk(d1); \
snanchk_more(d1); \
wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \
wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \
wrap(if (d1 == 0.0) return combinezero(sfirstzero, n2, d1);) \
@ -155,13 +155,13 @@ static MZ_INLINE rettype name ## __flt_rat(const Scheme_Object *n1, const Scheme
FLOATWRAP(complexwrap( \
static MZ_INLINE rettype name ## __flt_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \
Small_Complex sc; \
snanchk(d1); \
snanchk_more(d1); \
return cxop((scheme_make_small_complex(n1, &sc)), \
(n2)); \
})) \
static MZ_INLINE rettype name ## __dbl_big(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \
toi_or_toe(,Small_Rational sr4); \
nanchk(d1); \
nanchk_more(d1); \
wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \
wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \
return toi_or_toe(fop(d1, scheme_bignum_to_double(n2)), \
@ -169,7 +169,7 @@ static MZ_INLINE rettype name ## __dbl_big(double d1, const Scheme_Object *n1, c
} \
static MZ_INLINE rettype name ## __dbl_rat(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \
toi_or_toe(,Small_Rational sr5); \
nanchk(d1); \
nanchk_more(d1); \
wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \
wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \
wrap(if (d1 == 0.0) return combinezero(firstzero, n2, d1);) \
@ -179,7 +179,7 @@ static MZ_INLINE rettype name ## __dbl_rat(double d1, const Scheme_Object *n1, c
complexwrap( \
static MZ_INLINE rettype name ## __dbl_comp(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \
Small_Complex sc; \
nanchk(d1); \
nanchk_more(d1); \
return cxop((scheme_make_small_complex(n1, &sc)), \
(n2)); \
}) \
@ -192,7 +192,7 @@ static MZ_INLINE rettype name ## __big_flt(double d1, const Scheme_Object *n1, c
Small_Rational sr6; \
float d2; \
d2 = SCHEME_FLT_VAL(n2); \
snanchk(d2); \
snanchk_more(d2); \
wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \
wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \
return toi_or_toe(fsop(scheme_bignum_to_float(n1), d2), \
@ -202,7 +202,7 @@ static MZ_INLINE rettype name ## __big_dbl(const Scheme_Object *n1, const Scheme
double d2; \
toi_or_toe(,Small_Rational sr7); \
d2 = SCHEME_DBL_VAL(n2); \
nanchk(d2); \
nanchk_more(d2); \
wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \
wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \
return toi_or_toe(fop(scheme_bignum_to_double(n1), d2), \
@ -226,7 +226,7 @@ static MZ_INLINE rettype name ## __rat_flt(const Scheme_Object *n1, const Scheme
Small_Rational sr9; \
float d2; \
d2 = SCHEME_FLT_VAL(n2); \
snanchk(d2); \
snanchk_more(d2); \
wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \
wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \
wrap(if (d2 == 0.0) return combinezero(ssecondzero, n1, d2);) \
@ -237,7 +237,7 @@ static MZ_INLINE rettype name ## __rat_dbl(const Scheme_Object *n1, const Scheme
double d2; \
toi_or_toe(,Small_Rational sr10); \
d2 = SCHEME_DBL_VAL(n2); \
nanchk(d2); \
nanchk_more(d2); \
wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \
wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \
wrap(if (d2 == 0.0) return combinezero(secondzero, n1, d2);) \
@ -260,13 +260,13 @@ static MZ_INLINE rettype name ## __comp_int(const Scheme_Object *n1, const Schem
FLOATWRAP(complexwrap( \
static MZ_INLINE rettype name ## __comp_flt(const Scheme_Object *n1, const Scheme_Object *n2) { \
Small_Complex sc; \
snanchk(SCHEME_FLT_VAL(n2)); \
snanchk_more(SCHEME_FLT_VAL(n2)); \
return cxop((n1), (scheme_make_small_complex(n2, &sc))); \
})) \
complexwrap( \
static MZ_INLINE rettype name ## __comp_dbl(const Scheme_Object *n1, const Scheme_Object *n2) { \
Small_Complex sc; \
nanchk(SCHEME_DBL_VAL(n2)); \
nanchk_more(SCHEME_DBL_VAL(n2)); \
return cxop((n1), (scheme_make_small_complex(n2, &sc))); \
}) \
complexwrap( \
@ -515,6 +515,8 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
# define SNAN_CHECK_NAN_IF_WEIRD(x) /* empty */
#endif
# define NAN_CHECK_0(x) if (MZ_IS_NAN(x)) return 0
#define GEN_BIN_OP(name, scheme_name, iop, fop, fsop, bn_op, rop, cxop, exzeopl, exzeopr, nanckop, snanckop) \
GEN_BIN_THING(Scheme_Object *, name, scheme_name, \
iop, fop, fsop, bn_op, rop, cxop, \
@ -522,7 +524,7 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
0, 0, 0, 0, \
0, 0, 0, 0, \
GEN_SCHEME_BOOL_APPLY, badfunc, badfunc, badfunc, badfunc, \
nanckop, snanckop, \
nanckop, snanckop, nanckop, snanckop, \
GEN_IDENT, GEN_IDENT, exzeopl, exzeopr, "number", GEN_TOI)
#define GEN_BIN_DIV_OP(name, scheme_name, iop, fop, fsop, bn_op, rop, cxop) \
@ -532,7 +534,7 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
GEN_SAME_INF, GEN_SAME_SINF, GEN_OPP_INF, GEN_OPP_SINF, \
GEN_MAKE_NZERO, GEN_MAKE_NSZERO, GEN_MAKE_PZERO, GEN_MAKE_PSZERO, \
GEN_APPLY3, GEN_MAKE_ZERO_Z, GEN_MAKE_SZERO_Z, GEN_SAME_INF_Z, GEN_SAME_SINF_Z, \
NAN_CHECK_NAN_IF_WEIRD, SNAN_CHECK_NAN_IF_WEIRD, \
NAN_CHECK_NAN_IF_WEIRD, SNAN_CHECK_NAN_IF_WEIRD, NAN_CHECK_NAN_IF_WEIRD, SNAN_CHECK_NAN_IF_WEIRD, \
GEN_IDENT, GEN_IDENT, GEN_RETURN_0, GEN_OMIT, "number", GEN_TOI)
#define GEN_BIN_COMP(name, scheme_name, iop, fop, bn_op, rop, cxop, waybig, waysmall, firstzero, secondzero, complexwrap, noniziwrap, numbertype) \
@ -542,7 +544,7 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
waybig, waybig, waysmall, waysmall, \
waybig, waybig, waysmall, waysmall, \
GEN_SCHEME_BOOL_APPLY, firstzero, firstzero, secondzero, secondzero, \
NAN_CHECK_0_IF_WEIRD, NAN_CHECK_0_IF_WEIRD, \
NAN_CHECK_0_IF_WEIRD, NAN_CHECK_0_IF_WEIRD, NAN_CHECK_0, NAN_CHECK_0, \
complexwrap, noniziwrap, GEN_OMIT, GEN_OMIT, numbertype, GEN_TOE)
#define GEN_BIN_INT_OP(name, scheme_name, op, bigop) \

17
src/mzscheme/src/numstr.c
View File

@ -528,6 +528,23 @@ Scheme_Object *scheme_read_number(const mzchar *str, long len,
if (!complain)
return scheme_false;
}
} else if ((len-delta == 7) && str[len-1] == 'i') {
/* Try <special>i */
Scheme_Object *special;
special = read_special_number(str, delta);
if (special) {
special = scheme_make_complex(scheme_make_integer(0), special);
if (is_not_float) {
if (report)
scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
"read-number: no exact representation for %V",
special);
return scheme_false;
}
return special;
}
}
/* Look for <special>@... and ...@<special> */

51
src/mzscheme/src/regexp.c
View File

@ -395,6 +395,10 @@ static unsigned char *extract_regstart(rxpos scan, int *_anch)
case EXACTLY1:
map = map_start(map, UCHAR(regstr[OPERAND(scan)]));
break;
case EXACTLY2:
map = map_start(map, UCHAR(regstr[OPERAND(scan)]));
map = map_start(map, UCHAR(regstr[OPERAND(scan)+1]));
break;
case RANGE:
map = map_range(map, regstr, OPERAND(scan), 0);
break;
@ -1721,7 +1725,7 @@ regranges(int parse_flags, int at_start)
{
int c;
rxpos ret, save_regparse = 0;
int count, all_ci, num_ci, off_ranges, on_ranges, now_on, last_on, use_ci;
int count, all_ci, num_ci, off_ranges, on_ranges, now_on, last_on, prev_last_on, use_ci;
char *new_map = NULL, *accum_map = NULL;
count = 0;
@ -1828,12 +1832,14 @@ regranges(int parse_flags, int at_start)
off_ranges = 0;
now_on = 0;
last_on = -1;
prev_last_on = -1;
for (c = 0; c < 256; c++) {
if (accum_map[c]) {
if (now_on < 0)
off_ranges++;
now_on = 1;
count++;
prev_last_on = last_on;
last_on = c;
if (c != rx_tolower(c)) {
@ -1865,6 +1871,11 @@ regranges(int parse_flags, int at_start)
ret = regnode(EXACTLY1);
regc(last_on);
return ret;
} else if (count == 2) {
ret = regnode(EXACTLY2);
regc(last_on);
regc(prev_last_on);
return ret;
} else if ((on_ranges == 1)
|| (off_ranges == 1)) {
int rs = 255, re = 255, on;
@ -3034,6 +3045,16 @@ regmatch(Regwork *rw, rxpos prog)
is++;
scan = NEXT_OP(scan);
break;
case EXACTLY2:
NEED_INPUT(rw, is, 1);
if (is == rw->input_end)
return 0;
if (rw->instr[is] != regstr[OPERAND(scan)])
if (rw->instr[is] != regstr[OPERAND(scan)+1])
return 0;
is++;
scan = NEXT_OP(scan);
break;
case RANGE:
{
int c;
@ -3704,6 +3725,34 @@ regrepeat(Regwork *rw, rxpos p, int maxc)
count = scan - init;
}
break;
case EXACTLY2:
{
rxpos init = scan;
char c1, c2;
c1 = regstr[opnd];
c2 = regstr[opnd+1];
if (rw->port || maxc) {
/* Slow but general version */
NEED_INPUT(rw, scan, 1);
while ((scan != rw->input_end)
&& ((rw->instr[scan] == c1)
|| (rw->instr[scan] == c2))) {
scan++;
if (maxc) { maxc--; if (!maxc) break; }
NEED_INPUT(rw, scan, 1);
}
} else {
/* Fast version */
int e = rw->input_end;
while ((scan != e)
&& ((rw->instr[scan] == c1)
|| (rw->instr[scan] == c2))) {
scan++;
}
}
count = scan - init;
}
break;
case RANGE:
{
rxpos init = scan;

5
src/mzscheme/src/schrx.h
View File

@ -127,9 +127,10 @@ typedef struct regexp {
#define EOL 40 /* no Match "" at end of line. */
#define UNIPROP 41
#define CONDITIONAL 42
#define OPEN 43 /* no Mark this point in input as start of #n. */
#define EXACTLY2 43 /* byte,byte Match either byte (useful for some CI cases) */
#define OPEN 44 /* no Mark this point in input as start of #n. */
/* OPEN+1 is number 1, etc. */
#define CLOSE 77 /* no Analogous to OPEN. */
#define CLOSE 78 /* no Analogous to OPEN. */
# define OPSTR(o) (o + 2)
# define OPSTRx(o) (o + 1)