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

svn: r8898

collects/r5rs/main.ss

@@ -193,9 +193,7 @@
                  (if (zero? depth)
                      #'e
                      #`(mcons 'unquote
-                              (mcons
+                              #,(loop (cdr (syntax-e form)) (sub1 depth))))]
-                               #,(loop #'e (sub1 depth))
-                               null)))]
                 [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))
+                                     #,(loop #'(e) (sub1 depth)))
-                                            null))
                               #,(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))
+                 #`(mlist->vector #,(loop (syntax->list #'(a ...)) depth))]
-                                    (syntax->list #'(a ...))))]
                 [other #'(r5rs:quote other)]))
             ;; None, so just use R5RS quote:
             #'(r5rs:quote form))]))

collects/r6rs/private/identifier-syntax.ss

@@ -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

collects/r6rs/private/qq-gen.ss

@@ -17,8 +17,9 @@
                (let loop ([tmpl #'tmpl][level 0])
                  (syntax-case tmpl (r6rs:quasiquote)
                    [((u expr ...) . rest)
-                    (or (free-identifier=? #'u #'unquote)
+                    (and (identifier? #'u)
-                        (free-identifier=? #'u #'unquote-splicing))
+                         (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))])
+                    (let ([new-expr (loop #'(expr) (add1 level))])
-                      (if (eq? new-expr #'expr)
+                      ;; We have to replace the old qq with the new one:
-                          tmpl
+                      (datum->syntax
-                          (datum->syntax
+                       tmpl
-                           tmpl
+                       (cons (datum->syntax #'quasiquote
-                           (cons (car (syntax-e tmpl) new-expr))
+                                            'quasiquote
-                           tmpl tmpl tmpl)))]
+                                            (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)
+                           [new-as (loop as level)])
-                                          (loop a level))
+                      (if (eq? as new-as)
-                                        as)])
-                      (if (andmap 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))]))))

collects/r6rs/private/readtable.ss

@@ -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) "[iI]")
-                            (seq (real R) "-" (ureal R) "i")
+                            (seq (real R) "-" (ureal R) "[iI]")
-                            (seq (real R) "[+]" naninf "i")
+                            (seq (real R) "[+]" naninf "[iI]")
-                            (seq (real R) "-" naninf "i")
+                            (seq (real R) "-" naninf "[iI]")
-                            (seq (real R) "[+]i")
+                            (seq (real R) "[+][iI]")
-                            (seq (real R) "-i")
+                            (seq (real R) "-[iI]")
-                            (seq "[+]" (ureal R) "i")
+                            (seq "[+]" (ureal R) "[iI]")
-                            (seq "-" (ureal R) "i")
+                            (seq "-" (ureal R) "[iI]")
-                            (seq "[+]" naninf "i")
+                            (seq "[+]" naninf "[iI]")
-                            (seq "-" naninf "i")
+                            (seq "-" naninf "[iI]")
-                            "[+]i"
+                            "[+][iI]"
-                            "-i"))
+                            "-[iI]"))
     (define (num R) (seq (prefix R) (complex R)))
     (define number (or (num 10)
                        (num 16)

collects/r6rs/scribblings/r6rs.scrbl

@@ -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
+strings), vectors, and so on. Hash tables are different. Input and
-ports from @schememodname[scheme/base] can be used directly as binary
+output ports from @schememodname[scheme/base] can be used directly as
-ports with @|r6rs| libraries, and all @|r6rs| ports can be used as
+binary ports with @|r6rs| libraries, and all @|r6rs| ports can be used
-ports in @schememodname[scheme/base] programs, but only textual ports
+as ports in @schememodname[scheme/base] programs, but only textual
-created via @|r6rs| libraries can be used by other @|r6rs| operations
+ports created via @|r6rs| libraries can be used by other @|r6rs|
-that expect textual ports.
+operations that expect textual ports.
 
 @; ----------------------------------------------------------------------
 

collects/rnrs/base-6.ss

@@ -33,8 +33,9 @@
  ;; 11.4.6
  let let*
  (rename-out [r5rs:letrec letrec]
-             [letrec letrec*])
+             [letrec letrec*]
- let-values let*-values
+             [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
+ make-rectangular make-polar real-part imag-part magnitude 
- (rename-out [r6rs:number->string number->string]
+ (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)

collects/rnrs/bytevectors-6.ss

@@ -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-set! bytevector-u8-set!])
-                     [bytes->list bytevector->u8-list]
+         bytevector->u8-list
-                     [list->bytes u8-list->bytevector])
+         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)))
 

collects/rnrs/conditions-6.ss

@@ -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)

collects/rnrs/records/syntactic-6.ss

@@ -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 ...)))))

collects/scheme/private/misc.ss

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

collects/scribblings/foreign/types.scrbl

@@ -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.}
 
 

collects/tests/mzscheme/number.ss

@@ -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))
+(test +inf.0 floor +inf.0)
-(err/rt-test (ceiling +inf.0))
+(test +inf.0 ceiling +inf.0)
-(err/rt-test (round +inf.0))
+(test +inf.0 round +inf.0)
-(err/rt-test (truncate +inf.0))
+(test +inf.0 truncate +inf.0)
-(err/rt-test (floor -inf.0))
+(test -inf.0 floor -inf.0)
-(err/rt-test (ceiling -inf.0))
+(test -inf.0 ceiling -inf.0)
-(err/rt-test (round -inf.0))
+(test -inf.0 round -inf.0)
-(err/rt-test (truncate -inf.0))
+(test -inf.0 truncate -inf.0)
-(err/rt-test (floor +nan0))
+(test +nan.0 floor +nan.0)
-(err/rt-test (ceiling +nan0))
+(test +nan.0 ceiling +nan.0)
-(err/rt-test (round +nan0))
+(test +nan.0 round +nan.0)
-(err/rt-test (truncate +nan0))
+(test +nan.0 truncate +nan.0)
 
 (define (test-fcrt-int v)
   (test v floor v)

collects/tests/mzscheme/numstrs.ss

@@ -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")

collects/tests/r6rs/report.ss

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

collects/tests/r6rs/test.ss

@@ -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")))))
+
+          
+

src/mzscheme/src/number.c

@@ -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)
-      if (v > 0)
+      v = floor(v);
-        v = floor(v);
+    else
-      else
+      v = ceil(v);
-        v = ceil(v);
+    return scheme_make_float(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)
-      if (v > 0)
+      v = floor(v);
-        v = floor(v);
+    else
-      else
+      v = ceil(v);
-        v = ceil(v);
+    return scheme_make_double(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) {
-      if (d < 0) {
+      d = -d;
-        d = -d;
+      invert = 1;
-        invert = 1;
+    } else
-      } else
+      invert = 0;
-        invert = 0;
 
-      frac = modf(d, &i);
+    frac = modf(d, &i);
-      if (frac < 0.5)
+    if (frac < 0.5)
-        d = i;
+      d = i;
-      else if (frac > 0.5)
+    else if (frac > 0.5)
-        d = i + 1;
+      d = i + 1;
-      else if (fmod(i, 2.0) != 0.0)
+    else if (fmod(i, 2.0) != 0.0)
-	d = i + 1;
+      d = i + 1;
-      else
+    else
-        d = i;
+      d = i;
 
-      if (invert)
+    if (invert)
-        d = -d;
+      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) {
-      if (d < 0) {
+      d = -d;
-        d = -d;
+      invert = 1;
-        invert = 1;
+    } else
-      } else
+      invert = 0;
-        invert = 0;
 
-      frac = modf(d, &i);
+    frac = modf(d, &i);
-      if (frac < 0.5)
+    if (frac < 0.5)
-        d = i;
+      d = i;
-      else if (frac > 0.5)
+    else if (frac > 0.5)
-        d = i + 1;
+      d = i + 1;
-      else if (fmod(i, 2.0) != 0.0)
+    else if (fmod(i, 2.0) != 0.0)
-	d = i + 1;
+      d = i + 1;
-      else
+    else
-        d = i;
+      d = i;
 
-      if (invert)
+    if (invert)
-        d = -d;
+      d = -d;
 
-      return scheme_make_double(d);
+    return scheme_make_double(d);
-    }
   }
   if (t == scheme_bignum_type)
     return o;

src/mzscheme/src/nummacs.h

@@ -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) \

src/mzscheme/src/numstr.c

@@ -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> */

src/mzscheme/src/regexp.c

@@ -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;

src/mzscheme/src/schrx.h

@@ -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)