module/rnrs/arithmetic/fixnums.scm

   1 ;;; fixnums.scm --- The R6RS fixnums arithmetic library
   2
   3 ;;      Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19
  20 (library (rnrs arithmetic fixnums (6))
  21   (export fixnum?
  22
  23           fixnum-width
  24           least-fixnum
  25           greatest-fixnum
  26
  27           fx=?
  28           fx>?
  29           fx<?
  30           fx>=?
  31           fx<=?
  32
  33           fxzero?
  34           fxpositive?
  35           fxnegative?
  36           fxodd?
  37           fxeven?
  38
  39           fxmax
  40           fxmin
  41
  42           fx+
  43           fx*
  44           fx-
  45
  46           fxdiv-and-mod
  47           fxdiv
  48           fxmod
  49           fxdiv0-and-mod0
  50           fxdiv0
  51           fxmod0
  52
  53           fx+/carry
  54           fx-/carry
  55           fx*/carry
  56
  57           fxnot
  58           fxand
  59           fxior
  60           fxxor
  61           fxif
  62
  63           fxbit-count
  64           fxlength
  65           fxfirst-bit-set
  66           fxbit-set?
  67           fxcopy-bit
  68           fxbit-field
  69           fxcopy-bit-field
  70
  71           fxarithmetic-shift
  72           fxarithmetic-shift-left
  73           fxarithmetic-shift-right
  74
  75           fxrotate-bit-field
  76           fxreverse-bit-field)
  77   (import (only (guile) ash
  78                         cons*
  79                         define-inlinable
  80                         inexact->exact
  81                         logand
  82                         logbit?
  83                         logcount
  84                         logior
  85                         lognot
  86                         logxor
  87                         most-positive-fixnum
  88                         most-negative-fixnum
  89                         object-address)
  90           (ice-9 optargs)
  91           (rnrs base (6))
  92           (rnrs control (6))
  93           (rnrs arithmetic bitwise (6))
  94           (rnrs conditions (6))
  95           (rnrs exceptions (6))
  96           (rnrs lists (6)))
  97
  98   (define fixnum-width
  99     (let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2))))))
 100       (lambda () w)))
 101
 102   (define (greatest-fixnum) most-positive-fixnum)
 103   (define (least-fixnum) most-negative-fixnum)
 104
 105   (define (fixnum? obj)
 106     (not (= 0 (logand 2 (object-address obj)))))
 107
 108   (define-inlinable (inline-fixnum? obj)
 109     (not (= 0 (logand 2 (object-address obj)))))
 110
 111   (define-syntax assert-fixnum
 112     (syntax-rules ()
 113       ((_ arg ...)
 114        (or (and (inline-fixnum? arg) ...)
 115            (raise (make-assertion-violation))))))
 116
 117   (define (assert-fixnums args)
 118     (or (for-all inline-fixnum? args) (raise (make-assertion-violation))))
 119
 120   (define-syntax define-fxop*
 121     (syntax-rules ()
 122       ((_ name op)
 123        (define name
 124         (case-lambda
 125           ((x y)
 126            (assert-fixnum x y)
 127            (op x y))
 128           (args
 129            (assert-fixnums args)
 130            (apply op args)))))))
 131
 132   ;; All these predicates don't check their arguments for fixnum-ness,
 133   ;; as this doesn't seem to be strictly required by R6RS.
 134
 135   (define fx=? =)
 136   (define fx>? >)
 137   (define fx<? <)
 138   (define fx>=? >=)
 139   (define fx<=? <=)
 140
 141   (define fxzero? zero?)
 142   (define fxpositive? positive?)
 143   (define fxnegative? negative?)
 144   (define fxodd? odd?)
 145   (define fxeven? even?)
 146
 147   (define-fxop* fxmax max)
 148   (define-fxop* fxmin min)
 149
 150   (define (fx+ fx1 fx2)
 151     (assert-fixnum fx1 fx2)
 152     (let ((r (+ fx1 fx2)))
 153       (or (inline-fixnum? r)
 154           (raise (make-implementation-restriction-violation)))
 155       r))
 156
 157   (define (fx* fx1 fx2)
 158     (assert-fixnum fx1 fx2)
 159     (let ((r (* fx1 fx2)))
 160       (or (inline-fixnum? r)
 161           (raise (make-implementation-restriction-violation)))
 162       r))
 163
 164   (define* (fx- fx1 #:optional fx2)
 165     (assert-fixnum fx1)
 166     (if fx2
 167         (begin
 168           (assert-fixnum fx2)
 169           (let ((r (- fx1 fx2)))
 170             (or (inline-fixnum? r) (raise (make-assertion-violation)))
 171             r))
 172         (let ((r (- fx1)))
 173           (or (inline-fixnum? r) (raise (make-assertion-violation)))
 174           r)))
 175
 176   (define (fxdiv fx1 fx2)
 177     (assert-fixnum fx1 fx2)
 178     (div fx1 fx2))
 179
 180   (define (fxmod fx1 fx2)
 181     (assert-fixnum fx1 fx2)
 182     (mod fx1 fx2))
 183
 184   (define (fxdiv-and-mod fx1 fx2)
 185     (assert-fixnum fx1 fx2)
 186     (div-and-mod fx1 fx2))
 187
 188   (define (fxdiv0 fx1 fx2)
 189     (assert-fixnum fx1 fx2)
 190     (div0 fx1 fx2))
 191
 192   (define (fxmod0 fx1 fx2)
 193     (assert-fixnum fx1 fx2)
 194     (mod0 fx1 fx2))
 195
 196   (define (fxdiv0-and-mod0 fx1 fx2)
 197     (assert-fixnum fx1 fx2)
 198     (div0-and-mod0 fx1 fx2))
 199
 200   (define (fx+/carry fx1 fx2 fx3)
 201     (assert-fixnum fx1 fx2 fx3)
 202     (let* ((s (+ fx1 fx2 fx3))
 203            (s0 (mod0 s (expt 2 (fixnum-width))))
 204            (s1 (div0 s (expt 2 (fixnum-width)))))
 205       (values s0 s1)))
 206
 207   (define (fx-/carry fx1 fx2 fx3)
 208     (assert-fixnum fx1 fx2 fx3)
 209     (let* ((d (- fx1 fx2 fx3))
 210            (d0 (mod0 d (expt 2 (fixnum-width))))
 211            (d1 (div0 d (expt 2 (fixnum-width)))))
 212       (values d0 d1)))
 213
 214   (define (fx*/carry fx1 fx2 fx3)
 215     (assert-fixnum fx1 fx2 fx3)
 216     (let* ((s (+ (* fx1 fx2) fx3))
 217            (s0 (mod0 s (expt 2 (fixnum-width))))
 218            (s1 (div0 s (expt 2 (fixnum-width)))))
 219       (values s0 s1)))
 220
 221   (define (fxnot fx) (assert-fixnum fx) (lognot fx))
 222   (define-fxop* fxand logand)
 223   (define-fxop* fxior logior)
 224   (define-fxop* fxxor logxor)
 225
 226   (define (fxif fx1 fx2 fx3)
 227     (assert-fixnum fx1 fx2 fx3)
 228     (bitwise-if fx1 fx2 fx3))
 229
 230   (define (fxbit-count fx)
 231     (assert-fixnum fx)
 232     (if (negative? fx)
 233         (bitwise-not (logcount fx))
 234         (logcount fx)))
 235
 236   (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
 237   (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
 238   (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
 239
 240   (define (fxcopy-bit fx1 fx2 fx3)
 241     (assert-fixnum fx1 fx2 fx3)
 242     (bitwise-copy-bit fx1 fx2 fx3))
 243
 244   (define (fxbit-field fx1 fx2 fx3)
 245     (assert-fixnum fx1 fx2 fx3)
 246     (bitwise-bit-field fx1 fx2 fx3))
 247
 248   (define (fxcopy-bit-field fx1 fx2 fx3 fx4)
 249     (assert-fixnum fx1 fx2 fx3 fx4)
 250     (bitwise-copy-bit-field fx1 fx2 fx3 fx4))
 251
 252   (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
 253   (define fxarithmetic-shift-left fxarithmetic-shift)
 254
 255   (define (fxarithmetic-shift-right fx1 fx2)
 256     (assert-fixnum fx1 fx2) (ash fx1 (- fx2)))
 257
 258   (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
 259     (assert-fixnum fx1 fx2 fx3 fx4)
 260     (bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
 261
 262   (define (fxreverse-bit-field fx1 fx2 fx3)
 263     (assert-fixnum fx1 fx2 fx3)
 264     (bitwise-reverse-bit-field fx1 fx2 fx3))
 265
 266 )