source: trunk/source/level-0/l0-int.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (require "NUMBER-MACROS")
21  (require "NUMBER-CASE-MACRO")
22)
23
24
25(defun lsh (fixnum count)
26  (require-type fixnum 'fixnum)
27  (require-type count 'fixnum)
28  (if (> count 0) 
29    (%ilsl count fixnum)
30    (%ilsr (- count) fixnum)))
31
32; this called with fixnum
33(defun %iabs  (n)
34  (declare (fixnum n))
35  (if (minusp  n) (- n) n))
36
37; called with any integer - is there a cmu version of integer/bignum-abs?
38(defun %integer-abs (n)
39  (number-case n
40    (fixnum
41     (locally
42         (declare (fixnum n))
43       (if (minusp n) (- n) n)))
44    (bignum
45     (if (minusp n) (- n) n))))
46
47
48(eval-when (:compile-toplevel :execute)
49  (assert (< (char-code #\9) (char-code #\A) (char-code #\a))))
50
51(defun token2int (string start len radix)
52  ; simple minded in case you hadn't noticed
53  (let* ((n start)
54         (end (+ start len))
55         (char0 (schar string n))
56         (val 0)
57         minus)
58    (declare (fixnum n end start len radix)) ; as if it mattered
59    (when (or (eq char0 #\+)(eq char0 #\-))
60      (setq n (1+ n))
61      (if (eq char0 #\-)(setq minus t)))
62    (while (< n end)
63      (let ((code (%scharcode string n)))
64        (if (<= code (char-code #\9)) 
65          (setq code (- code (char-code #\0)))
66          (progn
67            (when (>= code (char-code #\a))
68              (setq code (- code (- (char-code #\a) (char-code #\A)))))
69            (setq code (- code (- (char-code #\A) 10)))))
70        (setq val (+ (* val radix) code))
71        (setq n (1+ n))))
72    (if minus (- val) val)))
73 
74
75(defun %integer-to-string (int &optional (radix 10))
76  (%pr-integer int radix nil t))
77
78
79;;; it may be hard to believe, but this is much faster than the lap
80;;; version (3 or 4X) for fixnums that is (stream-write-string vs
81;;; stream-tyo ???)
82
83(defun %pr-integer (int &optional (radix 10) (stream *standard-output*) return-it  negate-it)
84  (declare (fixnum radix)) ; assume caller has checked
85  (if stream 
86    (if (eq stream t) (setq stream *terminal-io*))
87    (setq stream *standard-output*))
88  (let ((digit-string "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))   
89    (cond ((fixnump int)  ; ugh                     
90           (let ((temstring (make-string (- target::nbits-in-word target::fixnumshift) :element-type 'base-char))
91                 (i (- target::nbits-in-word  target::fixnumshift 1))
92                 (neg (< int 0))
93                 (rem 0))
94             (declare (fixnum i rem))
95             (declare (dynamic-extent temstring))
96             (when neg (setq int (- int)))
97             (when (not (fixnump int))
98               (return-from %pr-integer (%pr-integer int radix stream return-it t)))
99             (locally (declare (fixnum int)) 
100               (loop
101                 (multiple-value-setq  (int rem) (%fixnum-truncate int radix))                 
102                 (setf (%schar temstring i)(%schar digit-string rem))
103                 (when (eq 0 int)
104                   (return))
105                 (setq i (1- i)))
106               (when neg 
107                 (setf (%schar temstring (setq i (1- i))) #\-))
108               (if return-it
109                 (%substr temstring i (- target::nbits-in-word
110                                         target::fixnumshift))
111                 (write-string temstring stream :start i :end (- target::nbits-in-word target::fixnumshift))))))         
112          (t (let* ((size-vect #(nil nil 32 21 16 14 13 12 11
113                                 11   10 10  9  9  9  9  8  8
114                                 8     8  8  8  8  8  7  7  7
115                                 7     7  7  7  7  7  7  7  7 7))
116                    ;; overestimate # digits by a little for weird
117                    ;; radix
118                    (bigwords (uvsize int))
119                    (strlen (1+ (* bigwords (svref size-vect radix))))
120                    (temstring (make-string strlen :element-type 'base-char))
121                    (i (1- strlen))
122                    (neg (< int 0))
123                    ; ;(rem 0)
124                    ;; ;better-bignum-print?
125                    )  ; warn
126               (declare (dynamic-extent temstring)
127                        (fixnum i strlen))
128               (flet ((do-it (newbig)
129                        (print-bignum-2 newbig radix temstring digit-string)))
130                 (declare (dynamic-extent #'do-it))
131                 (setq i (with-one-negated-bignum-buffer int do-it)))                           
132               (when (or neg negate-it) 
133                 (setf (%schar temstring (setq i (1- i))) #\-))
134               (if return-it
135                 (%substr temstring i strlen)
136                 (write-string temstring stream :start i :end strlen)))))))
137
138
139
140;;; *BASE-POWER* holds the number that we keep dividing into the bignum for
141;;; each *print-base*.  We want this number as close to *most-positive-fixnum*
142;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)).
143;;;
144(defparameter *base-power* ())
145
146;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that
147;;; fit in the corresponding *base-power*.
148;;;
149(defparameter *fixnum-power--1* ())
150
151(do* ((b (make-array 37 :initial-element nil))
152      (f (make-array 37 :initial-element nil))
153      (base 2 (1+ base)))
154     ((= base 37) (setq *base-power* b *fixnum-power--1* f))
155  (do ((power-1 -1 (1+ power-1))
156       (new-divisor base (* new-divisor base))
157       (divisor 1 new-divisor))
158      ((not (fixnump new-divisor))
159       (setf (aref b base) divisor)
160       (setf (aref f base) power-1))))
161
162
163(defun print-bignum-2 (big radix string digit-string)
164  (declare (optimize (speed 3) (safety 0))
165           (simple-base-string string digit-string))
166  (let* ((divisor (aref *base-power* radix))
167         (power (aref *fixnum-power--1* radix))
168         (index (1- (length string)))
169         (rem 0))
170    (declare (fixnum index divisor power))
171    ;;(print index)
172    (loop
173      (multiple-value-setq (big rem) (truncate big divisor))
174      (let* ((int rem)
175             (rem 0)
176             (final-index (- index power 1)))
177        (loop
178          (multiple-value-setq (int rem) (%fixnum-truncate int radix))
179          (setf (schar string index)(schar digit-string rem))
180          (when (eql 0 int)
181            (return index))
182          (setq index (1- index)))
183        (if (zerop big)
184          (return index)
185          (dotimes (i (- index final-index) index)
186            (declare (fixnum i))
187            (setq index (1- index))
188            (setf (schar string index) #\0)))))))
189
190#+x8664-target
191(defun %bignum-hex-digits (b string)
192  (let* ((size (uvsize b))
193         (temp-string (make-string 8))
194         (end 0))
195    (declare (type fixnum size end))
196    (declare (dynamic-extent temp-string))
197    (locally (declare (optimize (speed 3) (safety 0)))
198      (loop for i of-type fixnum from (the fixnum (1- size)) downto 0
199            for start2 of-type fixnum by 32
200            do (%ub-fixnum-hex-digits 7 (bignum-ref b i) temp-string)
201            (setq end (%i+ end 8))
202            (%copy-ivector-to-ivector temp-string 0 string start2 32)))
203    (values string end)))
204
205(defun write-unsigned-byte-hex-digits (u stream)
206  (setq u (require-type u '(unsigned-byte)))
207  #-x8664-target
208  (write u :stream stream :base 16)
209  #+x8664-target
210  (if (fixnump u)
211    (let* ((scratch (make-string 15)))
212      (declare (dynamic-extent scratch))
213      (%ub-fixnum-hex-digits 14 u scratch)
214      (let ((start (dotimes (i 15 nil)
215                     (declare (fixnum i)
216                              (optimize (speed 3) (safety 0)))
217                     (unless (char= #\0 (schar scratch i))
218                       (return i)))))
219        (if start
220          (write-string scratch stream :start start)
221          (write-string "0" stream))))
222    (let* ((scratch (make-string (the fixnum (ash (the fixnum (uvsize u)) 3))))
223           (start 0))
224      (declare (dynamic-extent scratch)
225               (fixnum start))
226      (multiple-value-bind (string end)
227          (%bignum-hex-digits u scratch)
228        ;; skip leading zeros (there will be a non-zero digit)
229        (let ((i 0))
230          (declare (type (unsigned-byte 56) i))
231          (loop
232            (if (char= #\0 (schar string i))
233              (setq start (%i+ start 1))
234              (return))
235            (setq i (%i+ i 1))))
236        (write-string string stream :start start :end end))))
237  nil)
Note: See TracBrowser for help on using the repository browser.