source: project/release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm @ 13762

Last change on this file since 13762 was 13762, checked in by Kon Lovett, 11 years ago

Experimental macros for many-arg routines.

File size: 17.8 KB
Line 
1;;;; err5rs-arithmetic-fixnums.scm
2;;;; Kon Lovett, Mar '09
3
4;;; Prelude
5
6(declare
7  (usual-integrations)
8  (disable-interrupts)
9  (fixnum)
10  (inline)
11  (local)
12  (no-procedure-checks)
13  (bound-to-procedure
14    ##sys#signal-hook
15    ##sys#string-append ) )
16
17;;
18
19(include "chicken-primitive-object-inlines")
20
21;;
22
23(define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
24
25(define-inline (%check-cardinal-fixnum loc obj)
26  (unless (and (%fixnum? obj) (%fxcardinal? obj))
27    (error-type-cardinal-fixnum loc obj) ) )
28
29;;
30
31(define-inline (%check-fixnum-bounds-order loc start end)
32  (unless (%fx<= start end)
33    (error-bounds-order loc start end) ) )
34
35(define-inline (%check-fixnum-range loc lfx fx hfx)
36  (unless (%fxclosed? lfx fx hfx)
37    (error-outside-range loc fx lfx hfx) ) )
38
39;;
40
41(define-inline (%check-word-bits-range loc obj)
42   (%check-fixnum loc obj)
43   (%check-fixnum-range loc 0 obj fixnum-precision))
44
45(define-inline (%check-bits-range loc start end)
46  (%check-fixnum loc start)
47  (%check-fixnum loc end)
48  (%check-fixnum-bounds-order loc start end)
49  ; Inclusive start
50  (%check-fixnum-range loc 0 start fixnum-precision)
51  ; Exclusive end
52  (%check-fixnum-range loc 0 end fixnum-width) )
53
54(define-inline (%check-fixnum-bits-count loc count start end)
55  (unless (%fx< count (%fx- end start))
56    (error-bits-count loc count start end) ) )
57
58;;
59
60(define-inline (%check-zero-division loc fx1 fx2)
61  (when (%fxzero? fx2)
62    (error-zero-division loc fx1 fx2) ) )
63
64;;
65
66;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
67
68(define-inline (%fxfold loc func init lyst)
69  (%check-fixnum loc init)
70  (let loop ((ls lyst) (acc init))
71    (if (%null? ls) acc
72        (let ((cur (%car ls)))
73          (%check-fixnum loc cur)
74          (loop (%cdr ls) (func acc cur)) ) ) ) )
75
76(define-inline (%fxand-fold loc func init lyst)
77  (%check-fixnum loc init)
78  (let loop ((ls lyst) (acc init))
79    (or (%null? ls)
80        (let ((cur (%car ls)))
81          (%check-fixnum loc cur)
82          (and (func acc cur)
83               (loop (%cdr ls) cur) ) ) ) ) )
84
85;;
86
87(define-inline (%fxdiv0-and-mod0 fxn fxd)
88  (let* ((quo (%quotient fxn fxd))
89         (rem (%- fxn (%* quo fxd))))
90    (cond ((%<= 0 fxd)
91           (if (%< (%* rem 2) fxd)
92               (if (%<= (%* rem -2) fxd) (values quo rem)
93                   (values (%- quo 1) (%+ rem fxd)) )
94               (values (%+ quo 1) (%- rem fxd)) ) )
95          ((%< fxd (%* rem -2))
96           (if (%<= fxd (%* rem 2)) (values quo rem)
97               (values (%+ quo 1) (%- rem fxd)) ) )
98          (else
99           (values (%- quo 1) (%+ rem fxd)) ) ) ) )
100
101(define-inline (%fxdiv0 fxn fxd)
102  (let* ((quo (%quotient fxn fxd))
103         (rem (%- fxn (%* quo fxd))))
104    (cond ((%<= 0 fxd)
105           (if (%< (%* rem 2) fxd)
106               (if (%<= (%* rem -2) fxd) quo
107                   (%- quo 1) )
108               (%+ quo 1) ) )
109          ((%< fxd (%* rem -2))
110           (if (%<= fxd (%* rem 2)) quo
111               (%+ quo 1) ) )
112          (else
113           (%- quo 1) ) ) ) )
114
115(define-inline (%fxmod0 fxn fxd)
116  (let* ((quo (%quotient fxn fxd))
117         (rem (%- fxn (%* quo fxd))))
118    (cond ((%<= 0 fxd)
119           (if (%< (%* rem 2) fxd)
120               (if (%<= (%* rem -2) fxd) rem
121                   (%+ rem fxd) )
122               (%- rem fxd) ) )
123          ((%< fxd (%* rem -2))
124           (if (%<= fxd (%* rem 2)) rem
125               (%- rem fxd) ) )
126          (else
127           (%+ rem fxd) ) ) ) )
128
129(define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
130
131;;
132
133(define-inline (%string-append s1 s2) (##sys#string-append s1 s2))
134
135;;;
136
137(require-library data-structures err5rs-arithmetic-bitwise)
138
139(module err5rs-arithmetic-fixnums (;export
140  ; ERR5RS
141  ;;fixnum? - from chicken
142  fixnum-width least-fixnum greatest-fixnum
143  fx=? fx<? fx>? fx<=? fx>=? fxcompare
144  fxzero? fxpositive? fxnegative? fxodd? fxeven?
145  fxmax fxmin fxmax-and-min
146  fxabs
147  fxdiv fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0
148  fx*/carry fx+/carry fx-/carry
149  fxadd1 fxsub1
150  fxmodulo fxquotient fxremainder
151  fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right
152  fx- ;;fx+ fx* fx/ - from chicken
153  fxand fxior fxxor ;;fxnot - from chicken
154  fxif
155  fxbit-count
156  fxlength
157  fxfirst-bit-set fxlast-bit-set
158  fxbit-set?
159  fxcopy-bit
160  fxbit-field
161  fxcopy-bit-field
162  fxrotate-bit-field
163  fxreverse-bit-field
164  ; Extras
165  fixnum->string
166  fxif-not
167  fxnegate
168  fxpow2log2
169  fx=?# fx<?# fx>?# fx<=?# fx>=?#
170  fx-# fx+# fx*# fx/#
171  *fx=
172  *fx<
173  *fx>
174  *fx>=
175  *fx<=
176  *fx+
177  *fx-
178  *fx*
179  *fx/)
180
181(import scheme
182        (rename chicken
183          (fxmax chicken:fxmax)
184          (fxmin chicken:fxmin)
185          (fx- chicken:fx-)
186          (fxand chicken:fxand)
187          (fxior chicken:fxior)
188          (fxxor chicken:fxxor))
189        data-structures
190        foreign
191        err5rs-arithmetic-bitwise)
192
193;;; Errors
194
195(define (error-type-fixnum loc obj)
196  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
197
198(define (error-type-cardinal-fixnum loc obj)
199  (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal fixnum" obj) )
200
201(define (error-type-radix loc radix)
202  (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
203
204(define (error-outside-range loc obj low high)
205  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
206
207(define (error-zero-division loc fx1 fx2)
208  (##sys#signal-hook #:arithmetic-error loc "division by zero" fx1 fx2) )
209
210(define (error-fixnum-representation loc fx1 fx2)
211  (##sys#signal-hook #:arithmetic-error loc "results not representable as fixnums" fx1 fx2) )
212
213(define (error-bounds-order loc start end)
214  (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
215
216(define (error-bits-count loc count start end)
217  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
218
219;;; Constants
220
221(define *fixnum-negated-precision* (%fxneg fixnum-precision))
222
223;;; Procedures wrapping primitive-inlines for fold operations
224
225(define (*fx= x y) (%fx= x y))
226(define (*fx< x y) (%fx< x y))
227(define (*fx> x y) (%fx> x y))
228(define (*fx>= x y) (%fx>= x y))
229(define (*fx<= x y) (%fx<= x y))
230(define (*fxmax x y) (%fxmax x y))
231(define (*fxmin x y) (%fxmin x y))
232(define (*fxand x y) (%fxand x y))
233(define (*fxior x y) (%fxior x y))
234(define (*fxxor x y) (%fxxor x y))
235(define (*fx+ x y) (%fx+ x y))
236(define (*fx- x y) (%fx- x y))
237(define (*fx* x y) (%fx* x y))
238(define (*fx/ x y) (%fx/ x y))
239
240;;;
241
242(define (fixnum-width) fixnum-bits)
243(define (least-fixnum) most-negative-fixnum)
244(define (greatest-fixnum) most-positive-fixnum)
245
246;;;
247
248(define (fx=? fx . fxs) (%fxand-fold 'fx=? *fx= fx fxs))
249(define (fx<? fx . fxs) (%fxand-fold 'fx<? *fx< fx fxs))
250(define (fx>? fx . fxs) (%fxand-fold 'fx>? *fx> fx fxs))
251(define (fx<=? fx . fxs) (%fxand-fold 'fx<=? *fx<= fx fxs))
252(define (fx>=? fx . fxs) (%fxand-fold 'fx>=? *fx>= fx fxs))
253
254(define (fxcompare fx1 fx2)
255  (%check-fixnum 'fxcompare fx1)
256  (%check-fixnum 'fxcompare fx2)
257  (cond ((%fx= fx1 fx2)   0)
258        ((%fx< fx1 fx2)   -1)
259        (else             1) ) )
260
261(define (fxmax fx . fxs) (%fxfold 'fxmax *fxmax fx fxs))
262(define (fxmin fx . fxs) (%fxfold 'fxmin *fxmin fx fxs))
263
264(define (fxmax-and-min fx . fxs)
265  (%check-fixnum 'fxmax-and-min fx)
266  (let loop ((fxs fxs) (mx fx) (mn fx))
267    (if (%null? fxs) (values mx mn)
268        (let ((cur (%car fxs)))
269          (%check-fixnum 'fxmax-and-min cur)
270          (loop (%cdr fxs) (%fxmax mx cur) (%fxmin mn cur)) ) ) ) )
271
272;;;
273
274(define (fxzero? fx)
275  (%check-fixnum 'fxzero? fx)
276  (%fxzero? fx) )
277
278(define (fxpositive? fx)
279  (%check-fixnum 'fxpositive? fx)
280  (%fxpositive? fx) )
281
282(define (fxnegative? fx)
283  (%check-fixnum 'fxnegative? fx)
284  (%fxnegative? fx) )
285
286(define (fxodd? fx)
287  (%check-fixnum 'fxodd? fx)
288  (%fxodd? fx) )
289
290(define (fxeven? fx)
291  (%check-fixnum 'fxeven? fx)
292  (%fxeven? fx) )
293
294;;;
295
296(define (fxabs fx)
297  (%check-fixnum 'fxabs fx)
298  (%fxabs fx) )
299
300(define (fxdiv fxn fxd)
301  (%check-fixnum 'fxdiv fxn)
302  (%check-fixnum 'fxdiv fxd)
303  (%check-zero-division 'fxdiv fxn fxd)
304  (%fx/ fxn fxd) )
305
306(define (fxdiv-and-mod fxn fxd)
307  (%check-fixnum 'fxdiv-and-mod fxn)
308  (%check-fixnum 'fxdiv-and-mod fxd)
309  (%check-zero-division 'fxdiv fxn fxd)
310  (values (%fx/ fxn fxd) (%fxmod fxn fxd)) )
311
312(define (fxdiv0 fxn fxd)
313  (%check-fixnum 'fxdiv0 fxn)
314  (%check-fixnum 'fxdiv0 fxd)
315  (%check-zero-division 'fxdiv0 fxn fxd)
316  (let ((d (%fxdiv0 fxn fxd)))
317    (if (%fixnum? d) d
318        (error-fixnum-representation 'fxdiv0 fxn fxd) ) ) )
319
320(define (fxmod0 fxn fxd)
321  (%check-fixnum 'fxmod0 fxn)
322  (%check-fixnum 'fxmod0 fxd)
323  (%check-zero-division 'fxmod0 fxn fxd)
324  (let ((m (%fxmod0 fxn fxd)))
325    (if (%fixnum? m) m
326        (error-fixnum-representation 'fxmod0 fxn fxd) ) ) )
327
328(define (fxdiv0-and-mod0 fxn fxd)
329  (%check-fixnum 'fxdiv0-and-mod0 fxn)
330  (%check-fixnum 'fxdiv0-and-mod0 fxd)
331  (%check-zero-division 'fxdiv0-and-mod0 fxn fxd)
332  (let-values (((d m) (%fxdiv0-and-mod0 fxn fxd)))
333    (if (and (%fixnum? d) (%fixnum? m)) (values d m)
334        (error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd) ) ) )
335
336(define (fx*/carry fx1 fx2 fx3)
337  (%check-fixnum 'fx*/carry fx1)
338  (%check-fixnum 'fx*/carry fx2)
339  (%check-fixnum 'fx*/carry fx3)
340  (let ((res (%fx+ (%fx* fx1 fx2) fx3)))
341    (values res (%fxcarry-bit (%+ (%* fx1 fx2) (%- fx3 res)))) ) )
342
343(define (fx+/carry fx1 fx2 fx3)
344  (%check-fixnum 'fx+/carry fx1)
345  (%check-fixnum 'fx+/carry fx2)
346  (%check-fixnum 'fx+/carry fx3)
347  (let ((res (%fx+ (%fx+ fx1 fx2) fx3)))
348    (values res (%fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) )
349
350(define (fx-/carry fx1 fx2 fx3)
351  (%check-fixnum 'fx-/carry fx1)
352  (%check-fixnum 'fx-/carry fx2)
353  (%check-fixnum 'fx-/carry fx3)
354  (let ((res (%fx- (%fx- fx1 fx2) fx3)))
355    (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
356
357(define (fxadd1 fx)
358  (%check-fixnum 'fxadd1 fx)
359  (%fxadd1 fx) )
360
361(define (fxsub1 fx)
362  (%check-fixnum 'fxsub1 fx)
363  (%fxsub1 fx) )
364
365(define (fxquotient fxn fxd)
366  (%check-fixnum 'fxquotient fxn)
367  (%check-fixnum 'fxquotient fxd)
368  (%check-zero-division 'fxquotient fxn fxd)
369  (%fx/ fxn fxd) )
370
371(define (fxremainder fxn fxd)
372  (%check-fixnum 'fxremainder fxn)
373  (%check-fixnum 'fxremainder fxd)
374  (%check-zero-division 'fxremainder fxn fxd)
375  (%fx- fxn (%fx* (%fx/ fxn fxd) fxd)) )
376
377(define (fxmodulo fxn fxd)
378  (%check-fixnum 'fxmodulo fxn)
379  (%check-fixnum 'fxmodulo fxd)
380  (%check-zero-division 'fxmodulo fxn fxd)
381  (%fxmod fxn fxd) )
382
383(define (fxarithmetic-shift fx amount)
384  (%check-fixnum 'fxarithmetic-shift fx)
385  (%check-fixnum 'fxarithmetic-shift amount)
386  (if (%fxpositive? amount) (%fxshr fx (%fxneg amount))
387      (%fxshl fx amount) ) )
388
389(define (fxarithmetic-shift-left fx amount)
390  (%check-fixnum 'fxarithmetic-shift-left fx)
391  (%check-cardinal-fixnum 'fxarithmetic-shift-left amount)
392  (%fxshl fx amount) )
393
394(define (fxarithmetic-shift-right fx amount)
395  (%check-fixnum 'fxarithmetic-shift-right fx)
396  (%check-cardinal-fixnum 'fxarithmetic-shift-right amount)
397  (%fxshr fx amount) )
398
399(define (fx- fx #!optional fx2)
400  (%check-fixnum 'fx- fx)
401  (if (not fx2) (%fxneg fx)
402      (begin
403        (%check-fixnum 'fx- fx2)
404        (%fx- fx fx2) ) ) )
405
406;;;
407
408(define (fxand fx . fxs) (%fxfold 'fxand *fxand fx fxs))
409(define (fxior fx . fxs) (%fxfold 'fxior *fxior fx fxs))
410(define (fxxor fx . fxs) (%fxfold 'fxxor *fxxor fx fxs))
411
412;;;
413
414(define (fxif mask true false)
415  (%check-fixnum 'fxif mask)
416  (%check-fixnum 'fxif true)
417  (%check-fixnum 'fxif false)
418  (*bitwise-if mask true false) )
419
420(define (fxbit-count fx)
421  (%check-fixnum 'fxbit-count fx)
422  (*bitwise-bit-count fx) )
423
424(define (fxlength fx)
425  (%check-fixnum 'fxlength fx)
426  (*bitwise-length fx) )
427
428(define (fxfirst-bit-set fx)
429  (%check-fixnum 'fxfirst-bit-set fx)
430  (*bitwise-first-bit-set fx) )
431
432(define (fxlast-bit-set fx)
433  (%check-fixnum 'fxlast-bit-set fx)
434  (*bitwise-last-bit-set fx) )
435
436(define (fxbit-set? fx index)
437  (%check-fixnum 'fxbit-set? fx)
438  (%check-word-bits-range 'fxbit-set? index)
439  (*bitwise-bit-set? fx index) )
440
441(define (fxcopy-bit fx index bit)
442  (%check-fixnum 'fxcopy-bit fx)
443  (%check-word-bits-range 'fxcopy-bit index)
444  (%check-fixnum 'fxcopy-bit bit)
445  (*bitwise-copy-bit fx index bit) )
446
447(define (fxbit-field fx start end)
448  (%check-fixnum 'fxbit-field fx)
449  (%check-bits-range 'fxbit-field start end)
450  (*bitwise-bit-field fx start end) )
451
452(define (fxcopy-bit-field fxto start end fxfrom)
453  (%check-fixnum 'fxcopy-bit-field fxto)
454  (%check-bits-range 'fxcopy-bit-field start end)
455  (%check-fixnum 'fxcopy-bit-field fxfrom)
456  (*bitwise-copy-bit-field fxto start end fxfrom) )
457
458(define (fxrotate-bit-field fx start end count)
459  (%check-fixnum 'fxrotate-bit-field fx)
460  (%check-bits-range 'fxrotate-bit-field start end)
461  (%check-cardinal-fixnum 'fxrotate-bit-field count)
462  (%check-fixnum-bits-count 'fxrotate-bit-field count start end)
463  (*bitwise-rotate-bit-field fx start end count) )
464
465(define (fxreverse-bit-field fx start end)
466  (%check-fixnum 'fxreverse-bit-field fx)
467  (%check-bits-range 'fxreverse-bit-field start end)
468  (*bitwise-reverse-bit-field fx start end) )
469
470;;; Extras
471
472;;
473
474(define fixnum->string
475  (let ((digits "0123456789ABCDEF"))
476    (lambda (fx #!optional (radix 10))
477      (define (fx-digits fx from to)
478        (if (%fxzero? fx) (values (%make-string from #\#) to)
479            (let* ((quo (%fx/ fx radix))
480                   (digit (%string-ref digits (%fx- fx (%fx* quo radix)))))
481              (let-values (((str to) (fx-digits quo (%fx+ from 1) to)))
482                (%string-set! str to digit)
483                (values str (%fx+ to 1)) ) ) ) )
484      (define (fx->str fx)
485        (cond ((%fxzero? fx)
486               (%make-string 1 #\0))
487              ((%fxpositive? fx)
488               (let ((str (fx-digits fx 0 0)))
489                 (noop str) ; force reference
490                 str ) )
491              ((%fx= most-negative-fixnum fx)
492               (%string-append (fx->str (%fx/ fx radix)) (fx->str (%fx- radix (%fxmod fx radix)))) )
493              (else
494               (let ((str (fx-digits (%fxneg fx) 1 1)))
495                 (%string-set! str 0 #\-)
496                 str ) ) ) )
497      (%check-fixnum 'fixnum->string fx)
498      (case radix
499        ((2 8 10 16)
500          (fx->str fx))
501        (else
502          (error-type-radix 'fixnum->string radix) ) ) ) ) )
503
504;;
505
506(define (fxnegate fx)
507  (%check-fixnum 'fxnegate fx)
508  (%fxneg fx) )
509
510;;
511
512(define (fxif-not mask true false)
513  (%check-fixnum 'fxif-not mask)
514  (%check-fixnum 'fxif-not true)
515  (%check-fixnum 'fxif-not false)
516  (*bitwise-if-not mask true false) )
517
518;;
519
520(define (fxpow2log2 fx)
521  (%check-fixnum 'fxpow2log2 fx)
522  (*pow2log2 fx) )
523
524;;
525
526(define-syntax fx=?#
527  (syntax-rules ()
528    ((_ ?x)
529      #t )
530    ((_ ?x ?y)
531      (*fx= ?x ?y) )
532    ((_ ?x ?y ?rest ...)
533      (and (*fx= ?x ?y) (fx=?# ?y ?rest ...)) ) ) )
534
535(define-syntax fx<?#
536  (syntax-rules ()
537    ((_ ?x)
538      #t )
539    ((_ ?x ?y)
540      (*fx< ?x ?y) )
541    ((_ ?x ?y ?rest ...)
542      (and (*fx< ?x ?y) (fx<?# ?y ?rest ...)) ) ) )
543
544(define-syntax fx>?#
545  (syntax-rules ()
546    ((_ ?x)
547      #t )
548    ((_ ?x ?y)
549      (*fx> ?x ?y) )
550    ((_ ?x ?y ?rest ...)
551      (and (*fx> ?x ?y) (fx>?# ?y ?rest ...)) ) ) )
552
553(define-syntax fx<=?#
554  (syntax-rules ()
555    ((_ ?x)
556      #t )
557    ((_ ?x ?y)
558      (*fx<= ?x ?y) )
559    ((_ ?x ?y ?rest ...)
560      (and (*fx<= ?x ?y) (fx<=?# ?y ?rest ...)) ) ) )
561
562(define-syntax fx>=?#
563  (syntax-rules ()
564    ((_ ?x)
565      #t )
566    ((_ ?x ?y)
567      (*fx>= ?x ?y) )
568    ((_ ?x ?y ?rest ...)
569      (and (*fx>= ?x ?y) (fx>=?# ?y ?rest ...)) ) ) )
570
571;;
572
573(define-syntax fx-#
574  (syntax-rules ()
575    ((_ ?x)
576      (*fxneg ?x) )
577    ((_ ?x ?y)
578      (*fx- ?x ?y) )
579    ((_ ?x ?y ?rest ...)
580      (*fx- ?x (fx-# ?y ?rest ...) ) ) ) )
581
582(define-syntax fx+#
583  (syntax-rules ()
584    ((_ ?x)
585      ?x )
586    ((_ ?x ?y)
587      (*fx+ ?x ?y) )
588    ((_ ?x ?y ?rest ...)
589      (*fx+ ?x (fx+# ?y ?rest ...) ) ) ) )
590
591(define-syntax fx*#
592  (syntax-rules ()
593    ((_ ?x)
594      ?x )
595    ((_ ?x ?y)
596      (*fx* ?x ?y) )
597    ((_ ?x ?y ?rest ...)
598      (*fx* ?x (fx*# ?y ?rest ...) ) ) ) )
599
600(define-syntax fx/#
601  (syntax-rules ()
602    ((_ ?x)
603      ?x )
604    ((_ ?x ?y)
605      (*fx/ ?x ?y) )
606    ((_ ?x ?y ?rest ...)
607      (*fx/ ?x (fx/# ?y ?rest ...) ) ) ) )
608
609#|
610;;
611
612(define (fx=?# fx . fxs)
613  (%check-fixnum 'fx=?# fx)
614  (cond ((%null? fxs)         #t)
615        ((%null? (%cdr fxs))  (%fx= fx (%car fxs)))
616        (else                 (%fxand-fold 'fx=?# *fx= fx fxs) ) ) )
617
618(define (fx<?# fx . fxs)
619  (%check-fixnum 'fx<?# fx)
620  (cond ((%null? fxs)         #t)
621        ((%null? (%cdr fxs))  (%fx< fx (%car fxs)))
622        (else                 (%fxand-fold 'fx<?# *fx< fx fxs) ) ) )
623
624(define (fx>?# fx . fxs)
625  (%check-fixnum 'fx>?# fx)
626  (cond ((%null? fxs)         #t)
627        ((%null? (%cdr fxs))  (%fx> fx (%car fxs)))
628        (else                 (%fxand-fold 'fx>?# *fx> fx fxs) ) ) )
629
630(define (fx<=?# fx . fxs)
631  (%check-fixnum 'fx<=?# fx)
632  (cond ((%null? fxs)         #t)
633        ((%null? (%cdr fxs))  (%fx<= fx (%car fxs)))
634        (else                 (%fxand-fold 'fx<=?# *fx<= fx fxs) ) ) )
635
636(define (fx>=?# fx . fxs)
637  (%check-fixnum 'fx>=?# fx)
638  (cond ((%null? fxs)         #t)
639        ((%null? (%cdr fxs))  (%fx>= fx (%car fxs)))
640        (else                 (%fxand-fold 'fx>=?# *fx>= fx fxs) ) ) )
641
642;;
643
644(define (fx-# fx . fxs)
645  (%check-fixnum 'fx-# fx)
646  (cond ((%null? fxs)         (%fxneg fx))
647        ((%null? (%cdr fxs))  (%fx- fx (%car fxs)))
648        (else                 (%fxfold 'fx-# *fx- fx fxs) ) ) )
649
650(define (fx+# fx . fxs)
651  (%check-fixnum 'fx+# fx)
652  (cond ((%null? fxs)         fx)
653        ((%null? (%cdr fxs))  (%fx+ fx (%car fxs)))
654        (else                 (%fxfold 'fx+# *fx+ fx fxs) ) ) )
655
656(define (fx*# fx . fxs)
657  (%check-fixnum 'fx*# fx)
658  (cond ((%null? fxs)         fx)
659        ((%null? (%cdr fxs))  (%fx* fx (%car fxs)))
660        (else                 (%fxfold 'fx*# *fx* fx fxs) ) ) )
661
662(define (fx/# fx . fxs)
663  (%check-fixnum 'fx/# fx)
664  (cond ((%null? fxs)         fx)
665        ((%null? (%cdr fxs))  (%fx/ fx (%car fxs)))
666        (else                 (%fxfold 'fx/# *fx/ fx fxs) ) ) )
667|#
668
669) ;module err5rs-arithmetic-fixnums
Note: See TracBrowser for help on using the repository browser.