mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
23988e8c50
* module/rnrs/arithmetic/fixnums.scm (fixnum-width): Make this return an an exact integer instead of an inexact number. * module/rnrs/base.scm (assertion-violation): Implement. * module/rnrs/conditions.scm (simple-conditions): Allow also simple conditions as argument. * module/rnrs/enums.scm (define-enumeration): Properly construct empty enumeration sets. * module/rnrs/exceptions.scm (guard): Don't restrict the body to a single expression. * module/rnrs/records/syntactic.scm (define-record-type0): Expand into a series of definitions only.
268 lines
7 KiB
Scheme
268 lines
7 KiB
Scheme
;;; fixnums.scm --- The R6RS fixnums arithmetic library
|
||
|
||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||
;;
|
||
;; This library is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU Lesser General Public
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 3 of the License, or (at your option) any later version.
|
||
;;
|
||
;; This library is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(library (rnrs arithmetic fixnums (6))
|
||
(export fixnum?
|
||
|
||
fixnum-width
|
||
least-fixnum
|
||
greatest-fixnum
|
||
|
||
fx=?
|
||
fx>?
|
||
fx<?
|
||
fx>=?
|
||
fx<=?
|
||
|
||
fxzero?
|
||
fxpositive?
|
||
fxnegative?
|
||
fxodd?
|
||
fxeven?
|
||
|
||
fxmax
|
||
fxmin
|
||
|
||
fx+
|
||
fx*
|
||
fx-
|
||
|
||
fxdiv-and-mod
|
||
fxdiv
|
||
fxmod
|
||
fxdiv0-and-mod0
|
||
fxdiv0
|
||
fxmod0
|
||
|
||
fx+/carry
|
||
fx-/carry
|
||
fx*/carry
|
||
|
||
fxnot
|
||
fxand
|
||
fxior
|
||
fxxor
|
||
fxif
|
||
|
||
fxbit-count
|
||
fxlength
|
||
fxfirst-bit-set
|
||
fxbit-set?
|
||
fxcopy-bit
|
||
fxbit-field
|
||
fxcopy-bit-field
|
||
|
||
fxarithmetic-shift
|
||
fxarithmetic-shift-left
|
||
fxarithmetic-shift-right
|
||
|
||
fxrotate-bit-field
|
||
fxreverse-bit-field)
|
||
(import (only (guile) ash
|
||
cons*
|
||
inexact->exact
|
||
logand
|
||
logbit?
|
||
logcount
|
||
logior
|
||
lognot
|
||
logxor
|
||
most-positive-fixnum
|
||
most-negative-fixnum)
|
||
(ice-9 optargs)
|
||
(rnrs base (6))
|
||
(rnrs arithmetic bitwise (6))
|
||
(rnrs conditions (6))
|
||
(rnrs exceptions (6))
|
||
(rnrs lists (6)))
|
||
|
||
(define fixnum-width
|
||
(let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2))))))
|
||
(lambda () w)))
|
||
|
||
(define (greatest-fixnum) most-positive-fixnum)
|
||
(define (least-fixnum) most-negative-fixnum)
|
||
|
||
(define (fixnum? obj)
|
||
(and (integer? obj)
|
||
(exact? obj)
|
||
(>= obj most-negative-fixnum)
|
||
(<= obj most-positive-fixnum)))
|
||
|
||
(define (assert-fixnum . args)
|
||
(or (for-all fixnum? args) (raise (make-assertion-violation))))
|
||
|
||
(define (fx=? fx1 fx2 . rst)
|
||
(let ((args (cons* fx1 fx2 rst)))
|
||
(apply assert-fixnum args)
|
||
(apply = args)))
|
||
|
||
(define (fx>? fx1 fx2 . rst)
|
||
(let ((args (cons* fx1 fx2 rst)))
|
||
(apply assert-fixnum args)
|
||
(apply > args)))
|
||
|
||
(define (fx<? fx1 fx2 . rst)
|
||
(let ((args (cons* fx1 fx2 rst)))
|
||
(apply assert-fixnum rst)
|
||
(apply < args)))
|
||
|
||
(define (fx>=? fx1 fx2 . rst)
|
||
(let ((args (cons* fx1 fx2 rst)))
|
||
(apply assert-fixnum rst)
|
||
(apply >= args)))
|
||
|
||
(define (fx<=? fx1 fx2 . rst)
|
||
(let ((args (cons* fx1 fx2 rst)))
|
||
(apply assert-fixnum rst)
|
||
(apply <= args)))
|
||
|
||
(define (fxzero? fx) (assert-fixnum fx) (zero? fx))
|
||
(define (fxpositive? fx) (assert-fixnum fx) (positive? fx))
|
||
(define (fxnegative? fx) (assert-fixnum fx) (negative? fx))
|
||
(define (fxodd? fx) (assert-fixnum fx) (odd? fx))
|
||
(define (fxeven? fx) (assert-fixnum fx) (even? fx))
|
||
|
||
(define (fxmax fx1 fx2 . rst)
|
||
(let ((args (cons* fx1 fx2 rst)))
|
||
(apply assert-fixnum args)
|
||
(apply max args)))
|
||
|
||
(define (fxmin fx1 fx2 . rst)
|
||
(let ((args (cons* fx1 fx2 rst)))
|
||
(apply assert-fixnum args)
|
||
(apply min args)))
|
||
|
||
(define (fx+ fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(let ((r (+ fx1 fx2)))
|
||
(or (fixnum? r) (raise (make-implementation-restriction-violation)))
|
||
r))
|
||
|
||
(define (fx* fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(let ((r (* fx1 fx2)))
|
||
(or (fixnum? r) (raise (make-implementation-restriction-violation)))
|
||
r))
|
||
|
||
(define* (fx- fx1 #:optional fx2)
|
||
(assert-fixnum fx1)
|
||
(if fx2
|
||
(begin
|
||
(assert-fixnum fx2)
|
||
(let ((r (- fx1 fx2)))
|
||
(or (fixnum? r) (raise (make-assertion-violation)))
|
||
r))
|
||
(let ((r (- fx1)))
|
||
(or (fixnum? r) (raise (make-assertion-violation)))
|
||
r)))
|
||
|
||
(define (fxdiv fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(if (zero? fx2) (raise (make-assertion-violation)))
|
||
(let ((r (div fx1 fx2))) r))
|
||
|
||
(define (fxmod fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(if (zero? fx2) (raise (make-assertion-violation)))
|
||
(let ((r (mod fx1 fx2))) r))
|
||
|
||
(define (fxdiv-and-mod fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(if (zero? fx2) (raise (make-assertion-violation)))
|
||
(div-and-mod fx1 fx2))
|
||
|
||
(define (fxdiv0 fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(if (zero? fx2) (raise (make-assertion-violation)))
|
||
(let ((r (div0 fx1 fx2))) r))
|
||
|
||
(define (fxmod0 fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(if (zero? fx2) (raise (make-assertion-violation)))
|
||
(let ((r (mod0 fx1 fx2))) r))
|
||
|
||
(define (fxdiv0-and-mod0 fx1 fx2)
|
||
(assert-fixnum fx1 fx2)
|
||
(if (zero? fx2) (raise (make-assertion-violation)))
|
||
(call-with-values (lambda () (div0-and-mod0 fx1 fx2))
|
||
(lambda (q r) (values q r))))
|
||
|
||
(define (fx+/carry fx1 fx2 fx3)
|
||
(assert-fixnum fx1 fx2 fx3)
|
||
(let* ((s (+ fx1 fx2 fx3))
|
||
(s0 (mod0 s (inexact->exact (expt 2 (fixnum-width)))))
|
||
(s1 (div0 s (inexact->exact (expt 2 (fixnum-width))))))
|
||
(values s0 s1)))
|
||
|
||
(define (fx-/carry fx1 fx2 fx3)
|
||
(assert-fixnum fx1 fx2 fx3)
|
||
(let* ((d (- fx1 fx2 fx3))
|
||
(d0 (mod0 d (expt 2 (fixnum-width))))
|
||
(d1 (div0 d (expt 2 (fixnum-width)))))
|
||
(values d0 d1)))
|
||
|
||
(define (fx*/carry fx1 fx2 fx3)
|
||
(assert-fixnum fx1 fx2 fx3)
|
||
(let* ((s (+ (* fx1 fx2) fx3))
|
||
(s0 (mod0 s (expt 2 (fixnum-width))))
|
||
(s1 (div0 s (expt 2 (fixnum-width)))))
|
||
(values s0 s1)))
|
||
|
||
(define (fxnot fx) (assert-fixnum fx) (lognot fx))
|
||
(define (fxand . args) (apply assert-fixnum args) (apply logand args))
|
||
(define (fxior . args) (apply assert-fixnum args) (apply logior args))
|
||
(define (fxxor . args) (apply assert-fixnum args) (apply logxor args))
|
||
|
||
(define (fxif fx1 fx2 fx3)
|
||
(assert-fixnum fx1 fx2 fx3)
|
||
(bitwise-if fx1 fx2 fx3))
|
||
|
||
(define (fxbit-count fx) (assert-fixnum fx) (logcount fx))
|
||
(define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
|
||
(define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
|
||
(define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
|
||
|
||
(define (fxcopy-bit fx1 fx2 fx3)
|
||
(assert-fixnum fx1 fx2 fx3)
|
||
(bitwise-copy-bit fx1 fx2 fx3))
|
||
|
||
(define (fxbit-field fx1 fx2 fx3)
|
||
(assert-fixnum fx1 fx2 fx3)
|
||
(bitwise-bit-field fx1 fx2 fx3))
|
||
|
||
(define (fxcopy-bit-field fx1 fx2 fx3 fx4)
|
||
(assert-fixnum fx1 fx2 fx3 fx4)
|
||
(bitwise-copy-bit-field fx1 fx2 fx3 fx4))
|
||
|
||
(define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
|
||
(define fxarithmetic-shift-left fxarithmetic-shift)
|
||
|
||
(define (fxarithmetic-shift-right fx1 fx2)
|
||
(assert-fixnum fx1 fx2) (ash fx1 (- fx2)))
|
||
|
||
(define (fxrotate-bit-field fx1 fx2 fx3 fx4)
|
||
(assert-fixnum fx1 fx2 fx3 fx4)
|
||
(bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
|
||
|
||
(define (fxreverse-bit-field fx1 fx2 fx3)
|
||
(assert-fixnum fx1 fx2 fx3)
|
||
(bitwise-reverse-bit-field fx1 fx2 fx3))
|
||
|
||
)
|