added scheme/fixnum

svn: r17391

collects/scheme/fixnum.ss

@@ -0,0 +1,93 @@
+#lang at-exp scheme/base
+
+(require scheme/contract
+         scribble/srcdoc
+         (only-in rnrs/arithmetic/fixnums-6 fixnum-width)
+         (prefix-in r6: rnrs/arithmetic/fixnums-6))
+
+(require/doc scheme/base
+             scribble/manual
+             (for-label scheme/unsafe/ops))
+
+(define fx->fl exact->inexact)
+(define fxabs abs)
+(define (fx- a b) (- a b))
+(define (fx+ a b) (+ a b))
+(define (fx* a b) (* a b))
+(define (fxnot a) (r6:fxnot a))
+
+(define (fx>= a b) (>= a b))
+(define (fx> a b) (> a b))
+(define (fx= a b) (= a b))
+(define (fx< a b) (< a b))
+(define (fx<= a b) (<= a b))
+
+(define fxquotient quotient)
+(define fxremainder remainder)
+(define (fxrshift x y) (arithmetic-shift x (- y)))
+(define (fxlshift x y) (arithmetic-shift x y))
+
+(define (fxand x y) (r6:fxand x y))
+(define (fxior x y) (r6:fxior x y))
+(define (fxxor x y) (r6:fxxor x y))
+
+(provide/doc
+ [proc-doc/names 
+  fx>= (-> fixnum? fixnum? boolean?) (x y)
+  @{A safe version of @scheme[unsafe-fx>=].}]
+ 
+ [proc-doc/names fx> (-> fixnum? fixnum? boolean?) (x y)
+                 @{A safe version of @scheme[unsafe-fx>].}]
+ [proc-doc/names fx= (-> fixnum? fixnum? boolean?) (x y)
+                 @{A safe version of @scheme[unsafe-fx=].}]
+ [proc-doc/names fx< (-> fixnum? fixnum? boolean?) (x y)
+                 @{A safe version of @scheme[unsafe-fx<].}]
+ [proc-doc/names fx<= (-> fixnum? fixnum? boolean?) (x y)
+                 @{A safe version of @scheme[unsafe-fx<=].}]
+ [proc-doc/names fxnot (-> fixnum? fixnum?) (x)
+                 @{A safe version of @scheme[unsafe-fxnot].}]
+ [proc-doc/names fxand (-> fixnum? fixnum? fixnum?) (x y)
+                 @{A safe version of @scheme[unsafe-fxand].}]
+ [proc-doc/names fxior (-> fixnum? fixnum? fixnum?) (x y)
+                 @{A safe version of @scheme[unsafe-fxior].}]
+ [proc-doc/names fxxor (-> fixnum? fixnum? fixnum?) (x y)
+                 @{A safe version of @scheme[unsafe-fxxor].}]
+ 
+ [proc-doc fx+ 
+           (->d ([x fixnum?] [y fixnum?])
+                ()
+                #:pre-cond (fixnum? (+ x y))
+                [result fixnum?])
+           @{A safe version of @scheme[unsafe-fx+].}]
+ 
+ [proc-doc fx* (->d ([x fixnum?] [y fixnum?])
+                    ()
+                    #:pre-cond (fixnum? (* x y))
+                    [result fixnum?])
+           @{A safe version of @scheme[unsafe-fx*].}]
+ [proc-doc fx- (->d ([x fixnum?] [y fixnum?])
+                    ()
+                    #:pre-cond (fixnum? (- x y))
+                    [result fixnum?])
+           @{A safe version of @scheme[unsafe-fx-].}]
+ 
+ [proc-doc/names fx->fl (-> fixnum? inexact-real?) (x)
+                 @{A safe version of @scheme[unsafe-fx->fl].}]
+ [proc-doc/names fxabs (-> fixnum? fixnum?) (x)
+                 @{A safe version of @scheme[unsafe-fxabs]}]
+ [proc-doc/names fxquotient (-> fixnum? fixnum? fixnum?) (x y) 
+                 @{A safe version of @scheme[unsafe-fxquotient].}]
+ [proc-doc/names fxremainder (-> fixnum? fixnum? fixnum?) (x y)
+                 @{A safe version of @scheme[unsafe-fxremainder].}]
+ [proc-doc/names fxlshift 
+                 (-> fixnum? 
+                     (and/c fixnum? (between/c 0 (fixnum-width)))
+                     fixnum?)
+                 (x y)
+                 @{A safe version of @scheme[unsafe-fxlshift].}]
+ [proc-doc/names fxrshift
+                 (-> fixnum? 
+                     (and/c fixnum? (between/c 0 (fixnum-width)))
+                     fixnum?)
+                 (x y)
+                 @{A safe version of @scheme[unsafe-fxrshift].}])

collects/scribble/srcdoc.ss

@@ -57,14 +57,18 @@
   (lambda (stx)
     (syntax-case stx ()
       [(_ id contract desc)
-       (with-syntax ([(header result)
+       (with-syntax ([(header result (body-stuff ...))
                       (syntax-case #'contract (->d -> values)
                         [(->d (req ...) () (values [name res] ...))
-                         #'((id req ...) (values res ...))]
+                         #'((id req ...) (values res ...) ())]
+                        [(->d (req ...) () #:pre-cond condition (values [name res] ...))
+                         #'((id req ...) (values res ...) ((bold "Pre-condition: ") (scheme condition) "\n" "\n"))]
                         [(->d (req ...) () [name res])
-                         #'((id req ...) res)]
+                         #'((id req ...) res ())]
+                        [(->d (req ...) () #:pre-cond condition [name res])
+                         #'((id req ...) res ((bold "Pre-condition: ")  (scheme condition) "\n" "\n" ))]
                         [(->d (req ...) () #:rest rest rest-ctc [name res])
-                         #'((id req ... [rest rest-ctc] (... ...)) res)]
+                         #'((id req ... [rest rest-ctc] (... ...)) res ())]
                         [(->d (req ...) (one more ...) whatever)
                          (raise-syntax-error
                           #f
@@ -79,7 +83,7 @@
                           stx
                           #'contract)]
                         [(-> result)
-                         #'((id) result)]
+                         #'((id) result ())]
                         [(-> whatever ...) 
                          (raise-syntax-error
                           #f
@@ -95,7 +99,7 @@
                           #'contract)])])
          (values
           #'[id contract]
-          #'(defproc header result . desc)
+          #'(defproc header result body-stuff ... . desc)
           #'(scribble/manual)
           #'id))])))
 

collects/scribblings/reference/numbers.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require "mz.ss"
           scheme/math
+          scribble/extract
           (for-label scheme/math
                      scheme/flonum))
 
@@ -65,7 +66,10 @@ infinity, or @scheme[+nan.0] if no such limit exists.
 
 A @deftech{fixnum} is an exact integer whose two's complement
 representation fit into 31 bits on a 32-bit platform or 63 bits on a
-64-bit platform. Two fixnums that are @scheme[=] are also the same
+64-bit platform; furthermore, no allocation is required when computing
+with fixnums. See also the @schememodname[scheme/fixnum] module, below.
+
+Two fixnums that are @scheme[=] are also the same
 according to @scheme[eq?]. Otherwise, the result of @scheme[eq?]
 applied to two numbers is undefined.
 
@@ -950,6 +954,25 @@ first slot is position @scheme[0], and the last slot is one less than
 @scheme[(flvector-length vec)].}
 
                        
+@section{Fixnum Operations}
+
+@defmodule[scheme/fixnum]
+
+The @schememodname[scheme/fixnum] library provides operations like
+@scheme[fx+] that consume and produce only fixnums. The
+operations in this library are meant to be safe versions of the
+unsafe fixnum operations like @scheme[unsafe-fx+]. The expected
+usecase for this library to develop some code using it and then
+to replace the @scheme[require] of @schememodname[scheme/fixnum]
+with 
+@schemeblock[(require (filtered-in
+                       (λ (name) (and (regexp-match #rx"unsafe-" name)
+                                      (regexp-replace #rx"unsafe-" name "")))
+                       scheme/unsafe/ops))]
+to drop in this library's unsafe cousins.
+
+@(include-extracted (lib "fixnum.ss" "scheme"))
+
 @; ------------------------------------------------------------------------
 @section{Extra Constants and Functions}
 

collects/scribblings/scribble/srcdoc.scrbl

@@ -108,7 +108,9 @@ form.}
               (proc-doc id contract desc-expr)
               ([contract (-> result)
                          (->d (arg ...) () (values [id result] ...))
+                         (->d (arg ...) () #:pre-cond expression (values [id result] ...))
                          (->d (arg ...) () [id result])
+                         (->d (arg ...) () #:pre-cond expression [id result])
                          (->d (arg ...) () #:rest id rest [id result])])]{
 
 Like @scheme[proc-doc], but supporting contract forms that embed

collects/tests/mzscheme/fixnum.ss

@@ -0,0 +1,153 @@
+(load-relative "loadtest.ss")
+(Section 'fixnum)
+(require scheme/fixnum
+         scheme/unsafe/ops
+         (prefix-in r6: rnrs/arithmetic/fixnums-6))
+
+(define unary-table 
+  (list (list fxnot unsafe-fxnot)
+        (list fxabs unsafe-fxabs)
+        (list fx->fl unsafe-fx->fl)))
+
+(define binary-table
+  (list (list fx+ unsafe-fx+)
+        (list fx- unsafe-fx-)
+        (list fx* unsafe-fx*)
+
+        (list fxquotient unsafe-fxquotient)
+        (list fxremainder unsafe-fxremainder)
+        
+        (list fxand unsafe-fxand)
+        (list fxior unsafe-fxior)
+        (list fxxor unsafe-fxxor)
+
+        (list fx>= unsafe-fx>=)
+        (list fx> unsafe-fx>)
+        (list fx= unsafe-fx=)
+        (list fx<= unsafe-fx<=)
+        (list fx< unsafe-fx<)))
+
+(define binary/small-second-arg-table
+  (list (list fxlshift unsafe-fxlshift)
+        (list fxrshift unsafe-fxrshift)))
+
+;; the unsafe versions of these functions seem to be broken.
+(define nary-table
+  (list ;(list fxand unsafe-fxand)
+        ;(list fxior unsafe-fxior)
+        ;(list fxxor unsafe-fxxor)
+   ))
+
+(define table (append binary/small-second-arg-table binary-table unary-table nary-table))
+
+(define (normalize-arity a)
+  (cond
+    [(list? a)
+     (let ([at-least (ormap (λ (x) (and (arity-at-least? x) x)) a)])
+       (if at-least
+           (let ([new-a
+                  (filter (λ (x) (or (not (number? x))
+                                     (< x (arity-at-least-value at-least))))
+                          a)])
+             (if (pair? (cdr new-a))
+                 new-a
+                 (car new-a)))
+           (if (pair? (cdr a))
+               a
+               (car a))))]
+    [else a]))
+  
+(define (check-arity fx unsafe-fx)
+  (let ([same-arities? (λ (x y) (equal? (normalize-arity (procedure-arity x))
+                                        (normalize-arity (procedure-arity y))))])
+    (test #t
+          same-arities?
+          fx
+          unsafe-fx)))
+
+
+;; same-results : (fixnum ... -> any) (fixnum ... -> any) (listof fixnum) -> #t
+;; applies fx to args; if it raises an error, the function returns #t.
+;;                     if it returns a result, the function applies args
+;;                     to unsafe-fx and makes sure the results are either eq? or
+;;                     (if the results are flonums), =
+;; raises an exception when it finds a bug.
+(define (same-results fx unsafe-fx args) 
+  (let/ec k
+    (let* ([fx-result (with-handlers ((exn:fail? (λ (x) (k #t))))
+                        (apply fx args))]
+           [unsafe-result (apply unsafe-fx args)]
+           [ans
+            (or (eq? fx-result unsafe-result)
+                (and (flonum? fx-result)
+                     (flonum? unsafe-result)
+                     (= fx-result unsafe-result)))])
+      (unless ans
+        (newline)
+        (error 'same-results "better die now, rather than continue, what with unsafe ops around:\n     fx-result ~s\n unsafe-result ~s"
+               fx-result
+               unsafe-result))
+      #t)))
+
+(define (flonum? x) (inexact-real? x))
+
+(define (same-results/range/table)
+  (for ([line (in-list unary-table)])
+    (for ([i (in-range (- (expt 2 8)) (expt 2 8))])
+      (test #t same-results (list-ref line 0) (list-ref line 1) (list i))))
+  
+  (for ([line (in-list (append binary/small-second-arg-table 
+                               binary-table
+                               nary-table))])
+    (for ([i (in-range (- (expt 2 4)) (expt 2 4))])
+      (for ([j (in-range (- (expt 2 4)) (expt 2 4))])
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i j))))))
+
+(define (same-results/extremum)
+  (let ([interesting-values (list (r6:least-fixnum) -1 0 1 (r6:greatest-fixnum))])
+    (for ([line (in-list unary-table)])
+      (for ([i (in-list interesting-values)])
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i))))
+    
+    (for ([line (in-list (append binary/small-second-arg-table
+                                 binary-table
+                                 nary-table))])
+      (for ([i (in-list interesting-values)])
+        (for ([j (in-list interesting-values)])
+          (test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))))))
+
+(define (same-results/random/table)
+  (for ([ignore (in-range 0 800)])
+    (let ([i (random-fixnum)]
+          [j (random-fixnum)]
+          [k (random (r6:fixnum-width))]
+          [more-fixnums (build-list (random 20) (λ (i) (random-fixnum)))])
+      (for ([line (in-list unary-table)])
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i)))
+      (for ([line (in-list binary-table)])
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i j)))
+      (for ([line (in-list binary/small-second-arg-table)])
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i k)))
+      (for ([line (in-list nary-table)])
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i))
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i j))
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i j k))
+        (test #t same-results (list-ref line 0) (list-ref line 1) (list i k j))
+        (test #t same-results (list-ref line 0) (list-ref line 1) more-fixnums)))))
+
+(define (random-fixnum)
+  (+ (r6:least-fixnum) (random (- (r6:greatest-fixnum) (r6:least-fixnum)))))
+
+;; check the arities
+(for-each (λ (x) (apply check-arity x)) table)
+
+;; check the extreme values (against themselves and few other values)
+(same-results/extremum)
+
+;; check randomly
+(same-results/random/table)
+
+;; check a small range
+(same-results/range/table)
+
+(report-errs)

collects/tests/mzscheme/scheme-tests.ss

@@ -8,4 +8,5 @@
 (load-in-sandbox "function.ss")
 (load-in-sandbox "dict.ss")
 (load-in-sandbox "contract-test.ss")
+(load-in-sandbox "fixnum.ss")