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

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

Save.

File size: 18.6 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-fixnum-cardinal 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(require-library data-structures err5rs-arithmetic-bitwise)
134
135(module err5rs-arithmetic-fixnums (;export
136  ;; ERR5RS
137  ;fixnum? - from chicken
138  fixnum-width least-fixnum greatest-fixnum
139  fx=? fx<? fx>? fx<=? fx>=?
140  fxzero? fxpositive? fxnegative? fxodd? fxeven?
141  fxmax fxmin fxmax-and-min
142  fxdiv fxmod fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0
143  fx*/carry fx+/carry fx-/carry
144  fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right
145  fx+ fx- fx*
146  fxand fxior fxxor ;fxnot - from chicken
147  fxif
148  fxbit-count
149  fxlength
150  fxfirst-bit-set fxlast-bit-set
151  fxbit-set?
152  fxcopy-bit
153  fxbit-field
154  fxcopy-bit-field
155  fxrotate-bit-field
156  fxreverse-bit-field
157  ;; Extras
158  fxcompare
159  fxabs
160  fxnegate
161  fxadd1 fxsub1
162  fx/ fxquotient fxremainder
163  fxif-not
164  fxpow2log2
165  fixnum->string
166  fx#- fx#+ fx#* fx#/
167  ; Macros
168  *fx=? *fx<? *fx>? *fx<=? *fx>=?
169  *fxmax *fxmin
170  *fx- *fx+ *fx* *fx/
171  *fxand *fxior *fxxor
172  ; Macro helpers
173  $fx= $fx< $fx> $fx>= $fx<=
174  $fxmax $fxmin
175  $fxand $fxior $fxxor
176  $fx+ $fx- $fx* $fx/)
177
178(import scheme
179        (rename chicken
180          (fxmax chicken:fxmax)
181          (fxmin chicken:fxmin)
182          (fxand chicken:fxand)
183          (fxior chicken:fxior)
184          (fxxor chicken:fxxor)
185          (fx+ chicken:fx+)
186          (fx- chicken:fx-)
187          (fx* chicken:fx*)
188          (fx/ chicken:fx/)
189          (fxmod chicken:fxmod))
190        data-structures
191        foreign
192        err5rs-arithmetic-bitwise)
193
194;;; Conditions
195
196(define (make-exn-condition loc msg args)
197  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
198
199(define (make-arithmetic-condition loc msg args)
200  (make-composite-condition
201    (make-exn-condition loc msg args)
202    (make-property-condition 'arithmetic)) )
203
204(define (make-zero-division-condition loc fx1 fx2)
205  (make-arithmetic-condition loc "division by zero" (list fx1 fx2)) )
206
207; &implementation-restriction
208(define (make-fixnum-representation-condition loc fx1 fx2)
209  (make-arithmetic-condition loc "result not representable as fixnum" (list fx1 fx2)) )
210
211;;; Errors
212
213(define (error-type-fixnum loc obj)
214  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
215
216(define (error-type-cardinal-fixnum loc obj)
217  (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal fixnum" obj) )
218
219(define (error-type-radix loc radix)
220  (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
221
222(define (error-outside-range loc obj low high)
223  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
224
225(define (error-bounds-order loc start end)
226  (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
227
228(define (error-bits-count loc count start end)
229  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
230
231(define (error-zero-division loc fx1 fx2)
232  (abort (make-zero-division-condition loc fx1 fx2)) )
233
234(define (error-fixnum-representation loc fx1 fx2)
235  (abort (make-fixnum-representation-condition loc fx1 fx2)) )
236
237;;; Constants
238
239(define *fixnum-negated-precision* (%fxneg fixnum-precision))
240
241;;; Procedures wrapping primitive-inlines for fold operations
242
243(define ($fx= x y) (%fx= x y))
244(define ($fx< x y) (%fx< x y))
245(define ($fx> x y) (%fx> x y))
246(define ($fx>= x y) (%fx>= x y))
247(define ($fx<= x y) (%fx<= x y))
248(define ($fx+ x y) (%fx+ x y))
249(define ($fx- x y) (%fx- x y))
250(define ($fx* x y) (%fx* x y))
251(define ($fx/ x y) (%fx/ x y))
252(define ($fxneg x) (%fxneg x))
253(define ($fxmax x y) (%fxmax x y))
254(define ($fxmin x y) (%fxmin x y))
255(define ($fxand x y) (%fxand x y))
256(define ($fxior x y) (%fxior x y))
257(define ($fxxor x y) (%fxxor x y))
258
259;;; ERR5RS
260
261;;
262
263(define (fixnum-width) fixnum-bits)
264(define (least-fixnum) most-negative-fixnum)
265(define (greatest-fixnum) most-positive-fixnum)
266
267;;
268
269(define (fx=? fx . fxs) (%fxand-fold 'fx=? $fx= fx fxs))
270(define (fx<? fx . fxs) (%fxand-fold 'fx<? $fx< fx fxs))
271(define (fx>? fx . fxs) (%fxand-fold 'fx>? $fx> fx fxs))
272(define (fx<=? fx . fxs) (%fxand-fold 'fx<=? $fx<= fx fxs))
273(define (fx>=? fx . fxs) (%fxand-fold 'fx>=? $fx>= fx fxs))
274
275(define (fxmax fx . fxs) (%fxfold 'fxmax $fxmax fx fxs))
276(define (fxmin fx . fxs) (%fxfold 'fxmin $fxmin fx fxs))
277
278(define (fxmax-and-min fx . fxs)
279  (%check-fixnum 'fxmax-and-min fx)
280  (let loop ((fxs fxs) (mx fx) (mn fx))
281    (if (%null? fxs) (values mx mn)
282        (let ((cur (%car fxs)))
283          (%check-fixnum 'fxmax-and-min cur)
284          (loop (%cdr fxs) (%fxmax mx cur) (%fxmin mn cur)) ) ) ) )
285
286;;
287
288(define (fxand fx . fxs) (%fxfold 'fxand $fxand fx fxs))
289(define (fxior fx . fxs) (%fxfold 'fxior $fxior fx fxs))
290(define (fxxor fx . fxs) (%fxfold 'fxxor $fxxor fx fxs))
291
292;;
293
294(define (fxzero? fx)
295  (%check-fixnum 'fxzero? fx)
296  (%fxzero? fx) )
297
298(define (fxpositive? fx)
299  (%check-fixnum 'fxpositive? fx)
300  (%fxpositive? fx) )
301
302(define (fxnegative? fx)
303  (%check-fixnum 'fxnegative? fx)
304  (%fxnegative? fx) )
305
306(define (fxodd? fx)
307  (%check-fixnum 'fxodd? fx)
308  (%fxodd? fx) )
309
310(define (fxeven? fx)
311  (%check-fixnum 'fxeven? fx)
312  (%fxeven? fx) )
313
314;;
315
316(define (fx+ fx1 fx2)
317  (%check-fixnum 'fx+ fx1)
318  (%check-fixnum 'fx+ fx2)
319  (%fx+ fx1 fx2) )
320
321(define (fx- fx1 #!optional fx2)
322  (%check-fixnum 'fx- fx1)
323  (if (not fx2) (%fxneg fx1)
324      (begin
325        (%check-fixnum 'fx- fx2)
326        (%fx- fx1 fx2) ) ) )
327
328(define (fx* fx1  fx2)
329  (%check-fixnum 'fx* fx1)
330  (%check-fixnum 'fx* fx2)
331  (%fx* fx1 fx2) )
332
333(define (fxdiv fxn fxd)
334  (%check-fixnum 'fxdiv fxn)
335  (%check-fixnum 'fxdiv fxd)
336  (%check-zero-division 'fxdiv fxn fxd)
337  (%fx/ fxn fxd) )
338
339(define (fxmod fxn fxd)
340  (%check-fixnum 'fxmod fxn)
341  (%check-fixnum 'fxmod fxd)
342  (%check-zero-division 'fxmod fxn fxd)
343  (%fxmod fxn fxd) )
344
345(define (fxdiv-and-mod fxn fxd)
346  (%check-fixnum 'fxdiv-and-mod fxn)
347  (%check-fixnum 'fxdiv-and-mod fxd)
348  (%check-zero-division 'fxdiv fxn fxd)
349  (values (%fx/ fxn fxd) (%fxmod fxn fxd)) )
350
351(define (fxdiv0 fxn fxd)
352  (%check-fixnum 'fxdiv0 fxn)
353  (%check-fixnum 'fxdiv0 fxd)
354  (%check-zero-division 'fxdiv0 fxn fxd)
355  (let ((d (%fxdiv0 fxn fxd)))
356    (if (%fixnum? d) d
357        (error-fixnum-representation 'fxdiv0 fxn fxd) ) ) )
358
359(define (fxmod0 fxn fxd)
360  (%check-fixnum 'fxmod0 fxn)
361  (%check-fixnum 'fxmod0 fxd)
362  (%check-zero-division 'fxmod0 fxn fxd)
363  (let ((m (%fxmod0 fxn fxd)))
364    (if (%fixnum? m) m
365        (error-fixnum-representation 'fxmod0 fxn fxd) ) ) )
366
367(define (fxdiv0-and-mod0 fxn fxd)
368  (%check-fixnum 'fxdiv0-and-mod0 fxn)
369  (%check-fixnum 'fxdiv0-and-mod0 fxd)
370  (%check-zero-division 'fxdiv0-and-mod0 fxn fxd)
371  (let-values (((d m) (%fxdiv0-and-mod0 fxn fxd)))
372    (if (and (%fixnum? d) (%fixnum? m)) (values d m)
373        (error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd) ) ) )
374
375(define (fx*/carry fx1 fx2 fx3)
376  (%check-fixnum 'fx*/carry fx1)
377  (%check-fixnum 'fx*/carry fx2)
378  (%check-fixnum 'fx*/carry fx3)
379  (let ((res (%fx+ (%fx* fx1 fx2) fx3)))
380    (values res (%fxcarry-bit (%+ (%* fx1 fx2) (%- fx3 res)))) ) )
381
382(define (fx+/carry fx1 fx2 fx3)
383  (%check-fixnum 'fx+/carry fx1)
384  (%check-fixnum 'fx+/carry fx2)
385  (%check-fixnum 'fx+/carry fx3)
386  (let ((res (%fx+ (%fx+ fx1 fx2) fx3)))
387    (values res (%fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) )
388
389(define (fx-/carry fx1 fx2 fx3)
390  (%check-fixnum 'fx-/carry fx1)
391  (%check-fixnum 'fx-/carry fx2)
392  (%check-fixnum 'fx-/carry fx3)
393  (let ((res (%fx- (%fx- fx1 fx2) fx3)))
394    (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
395
396(define (fxarithmetic-shift fx amount)
397  (%check-fixnum 'fxarithmetic-shift fx)
398  (%check-fixnum 'fxarithmetic-shift amount)
399  (if (%fxpositive? amount) (%fxshr fx (%fxneg amount))
400      (%fxshl fx amount) ) )
401
402(define (fxarithmetic-shift-left fx amount)
403  (%check-fixnum 'fxarithmetic-shift-left fx)
404  (%check-fixnum-cardinal 'fxarithmetic-shift-left amount)
405  (%fxshl fx amount) )
406
407(define (fxarithmetic-shift-right fx amount)
408  (%check-fixnum 'fxarithmetic-shift-right fx)
409  (%check-fixnum-cardinal 'fxarithmetic-shift-right amount)
410  (%fxshr fx amount) )
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-fixnum-cardinal '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 (fxcompare fx1 fx2)
475  (%check-fixnum 'fxcompare fx1)
476  (%check-fixnum 'fxcompare fx2)
477  (cond ((%fx= fx1 fx2)   0)
478        ((%fx< fx1 fx2)   -1)
479        (else             1) ) )
480
481;;
482
483(define (fxabs fx)
484  (%check-fixnum 'fxabs fx)
485  (%fxabs fx) )
486
487(define (fxnegate fx)
488  (%check-fixnum 'fxnegate fx)
489  (%fxneg fx) )
490
491(define (fxadd1 fx)
492  (%check-fixnum 'fxadd1 fx)
493  (%fxadd1 fx) )
494
495(define (fxsub1 fx)
496  (%check-fixnum 'fxsub1 fx)
497  (%fxsub1 fx) )
498
499(define (fx/ fx1  fx2)
500  (%check-fixnum 'fx/ fxn)
501  (%check-fixnum 'fx/ fxd)
502  (%check-zero-division 'fx/ fxn fxd)
503  (%fx/ fxn fxd) )
504
505(define (fxquotient fxn fxd)
506  (%check-fixnum 'fxquotient fxn)
507  (%check-fixnum 'fxquotient fxd)
508  (%check-zero-division 'fxquotient fxn fxd)
509  (%fx/ fxn fxd) )
510
511(define (fxremainder fxn fxd)
512  (%check-fixnum 'fxremainder fxn)
513  (%check-fixnum 'fxremainder fxd)
514  (%check-zero-division 'fxremainder fxn fxd)
515  (%fx- fxn (%fx* (%fx/ fxn fxd) fxd)) )
516
517;;
518
519(define fixnum->string
520  (let ((digits "0123456789ABCDEF"))
521    (lambda (fx #!optional (radix 10))
522      (define (fx-digits fx from to)
523        (if (%fxzero? fx) (values (%make-string from #\#) to)
524            (let* ((quo (%fx/ fx radix))
525                   (digit (%string-ref digits (%fx- fx (%fx* quo radix)))))
526              (let-values (((str to) (fx-digits quo (%fx+ from 1) to)))
527                (%string-set! str to digit)
528                (values str (%fx+ to 1)) ) ) ) )
529      (define (fx->str fx)
530        (cond ((%fxzero? fx)
531               (%make-string 1 #\0))
532              ((%fxpositive? fx)
533               (let ((str (fx-digits fx 0 0)))
534                 (noop str) ; force reference
535                 str ) )
536              ((%fx= most-negative-fixnum fx)
537               (##sys#string-append
538                (fx->str (%fx/ fx radix))
539                (fx->str (%fx- radix (%fxmod fx radix)))) )
540              (else
541               (let ((str (fx-digits (%fxneg fx) 1 1)))
542                 (%string-set! str 0 #\-)
543                 str ) ) ) )
544      (%check-fixnum 'fixnum->string fx)
545      (case radix
546        ((2 8 10 16)
547          (fx->str fx))
548        (else
549          (error-type-radix 'fixnum->string radix) ) ) ) ) )
550
551;;
552
553(define (fxif-not mask true false)
554  (%check-fixnum 'fxif-not mask)
555  (%check-fixnum 'fxif-not true)
556  (%check-fixnum 'fxif-not false)
557  (*bitwise-if-not mask true false) )
558
559;;
560
561(define (fxpow2log2 fx)
562  (%check-fixnum 'fxpow2log2 fx)
563  (*pow2log2 fx) )
564
565;;
566
567(define (fx#- fx . fxs)
568  (%check-fixnum 'fx#- fx)
569  (cond ((%null? fxs)         (%fxneg fx))
570        ((%null? (%cdr fxs))  (%fx- fx (%car fxs)))
571        (else                 (%fxfold 'fx#- $fx- fx fxs) ) ) )
572
573(define (fx#+ fx . fxs)
574  (%check-fixnum 'fx#+ fx)
575  (cond ((%null? fxs)         fx)
576        ((%null? (%cdr fxs))  (%fx+ fx (%car fxs)))
577        (else                 (%fxfold 'fx#+ $fx+ fx fxs) ) ) )
578
579(define (fx#* fx . fxs)
580  (%check-fixnum 'fx#* fx)
581  (cond ((%null? fxs)         fx)
582        ((%null? (%cdr fxs))  (%fx* fx (%car fxs)))
583        (else                 (%fxfold 'fx#* $fx* fx fxs) ) ) )
584
585(define (fx#/ fx . fxs)
586  (%check-fixnum 'fx#/ fx)
587  (cond ((%null? fxs)         fx)
588        ((%null? (%cdr fxs))  (%fx/ fx (%car fxs)))
589        (else                 (%fxfold 'fx#/ $fx/ fx fxs) ) ) )
590
591;;
592
593(define-syntax *fx=?
594  (syntax-rules ()
595    ((_ ?x)
596      #t )
597    ((_ ?x ?y)
598      ($fx= ?x ?y) )
599    ((_ ?x ?y ?rest ...)
600      (and ($fx= ?x ?y) (*fx=? ?y ?rest ...)) ) ) )
601
602(define-syntax *fx<?
603  (syntax-rules ()
604    ((_ ?x)
605      #t )
606    ((_ ?x ?y)
607      ($fx< ?x ?y) )
608    ((_ ?x ?y ?rest ...)
609      (and ($fx< ?x ?y) (*fx<? ?y ?rest ...)) ) ) )
610
611(define-syntax *fx>?
612  (syntax-rules ()
613    ((_ ?x)
614      #t )
615    ((_ ?x ?y)
616      ($fx> ?x ?y) )
617    ((_ ?x ?y ?rest ...)
618      (and ($fx> ?x ?y) (*fx>? ?y ?rest ...)) ) ) )
619
620(define-syntax *fx<=?
621  (syntax-rules ()
622    ((_ ?x)
623      #t )
624    ((_ ?x ?y)
625      ($fx<= ?x ?y) )
626    ((_ ?x ?y ?rest ...)
627      (and ($fx<= ?x ?y) (*fx<=? ?y ?rest ...)) ) ) )
628
629(define-syntax *fx>=?
630  (syntax-rules ()
631    ((_ ?x)
632      #t )
633    ((_ ?x ?y)
634      ($fx>= ?x ?y) )
635    ((_ ?x ?y ?rest ...)
636      (and ($fx>= ?x ?y) (*fx>=? ?y ?rest ...)) ) ) )
637
638;;
639
640(define-syntax *fxmax
641  (syntax-rules ()
642    ((_ ?x)
643      ?x )
644    ((_ ?x ?y)
645      ($fxmax ?x ?y) )
646    ((_ ?x ?y ?rest ...)
647      ($fxmax ?x (*fxmax ?y ?rest ...)) ) ) )
648
649(define-syntax *fxmin
650  (syntax-rules ()
651    ((_ ?x)
652      ?x )
653    ((_ ?x ?y)
654      ($fxmin ?x ?y) )
655    ((_ ?x ?y ?rest ...)
656      ($fxmin ?x (*fxmin ?y ?rest ...)) ) ) )
657
658;;
659
660(define-syntax *fxand
661  (syntax-rules ()
662    ((_ ?x)
663      ?x )
664    ((_ ?x ?y)
665      ($fxand ?x ?y) )
666    ((_ ?x ?y ?rest ...)
667      ($fxand ?x (*fxand ?y ?rest ...)) ) ) )
668
669(define-syntax *fxior
670  (syntax-rules ()
671    ((_ ?x)
672      ?x )
673    ((_ ?x ?y)
674      ($fxior ?x ?y) )
675    ((_ ?x ?y ?rest ...)
676      ($fxior ?x (*fxior ?y ?rest ...)) ) ) )
677
678(define-syntax *fxxor
679  (syntax-rules ()
680    ((_ ?x)
681      ?x )
682    ((_ ?x ?y)
683      ($fxxor ?x ?y) )
684    ((_ ?x ?y ?rest ...)
685      ($fxxor ?x (*fxxor ?y ?rest ...)) ) ) )
686
687;;
688
689(define-syntax *fx-
690  (syntax-rules ()
691    ((_ ?x)
692      ($fxneg ?x) )
693    ((_ ?x ?y)
694      ($fx- ?x ?y) )
695    ((_ ?x ?y ?rest ...)
696      ($fx- ?x (*fx- ?y ?rest ...) ) ) ) )
697
698(define-syntax *fx+
699  (syntax-rules ()
700    ((_ ?x)
701      ?x )
702    ((_ ?x ?y)
703      ($fx+ ?x ?y) )
704    ((_ ?x ?y ?rest ...)
705      ($fx+ ?x (*fx+ ?y ?rest ...) ) ) ) )
706
707(define-syntax *fx*
708  (syntax-rules ()
709    ((_ ?x)
710      ?x )
711    ((_ ?x ?y)
712      ($fx* ?x ?y) )
713    ((_ ?x ?y ?rest ...)
714      ($fx* ?x (*fx* ?y ?rest ...) ) ) ) )
715
716(define-syntax *fx/
717  (syntax-rules ()
718    ((_ ?x)
719      ?x )
720    ((_ ?x ?y)
721      ($fx/ ?x ?y) )
722    ((_ ?x ?y ?rest ...)
723      ($fx/ ?x (*fx/ ?y ?rest ...) ) ) ) )
724
725) ;module err5rs-arithmetic-fixnums
Note: See TracBrowser for help on using the repository browser.