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

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

New special-purpose code for fast output of unsigned-byte values in
base 16.

  • 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 (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(eval-when (:compile-toplevel :execute)
21  (require "NUMBER-MACROS")
22  (require "NUMBER-CASE-MACRO")
23)
24
25
26(defun lsh (fixnum count)
27  (require-type fixnum 'fixnum)
28  (require-type count 'fixnum)
29  (if (> count 0) 
30    (%ilsl count fixnum)
31    (%ilsr (- count) fixnum)))
32
33; this called with fixnum
34(defun %iabs  (n)
35  (declare (fixnum n))
36  (if (minusp  n) (- n) n))
37
38; called with any integer - is there a cmu version of integer/bignum-abs?
39(defun %integer-abs (n)
40  (number-case n
41    (fixnum
42     (locally
43         (declare (fixnum n))
44       (if (minusp n) (- n) n)))
45    (bignum
46     (if (minusp n) (- n) n))))
47
48
49(eval-when (:compile-toplevel :execute)
50  (assert (< (char-code #\9) (char-code #\A) (char-code #\a))))
51
52(defun token2int (string start len radix)
53  ; simple minded in case you hadn't noticed
54  (let* ((n start)
55         (end (+ start len))
56         (char0 (schar string n))
57         (val 0)
58         minus)
59    (declare (fixnum n end start len radix)) ; as if it mattered
60    (when (or (eq char0 #\+)(eq char0 #\-))
61      (setq n (1+ n))
62      (if (eq char0 #\-)(setq minus t)))
63    (while (< n end)
64      (let ((code (%scharcode string n)))
65        (if (<= code (char-code #\9)) 
66          (setq code (- code (char-code #\0)))
67          (progn
68            (when (>= code (char-code #\a))
69              (setq code (- code (- (char-code #\a) (char-code #\A)))))
70            (setq code (- code (- (char-code #\A) 10)))))
71        (setq val (+ (* val radix) code))
72        (setq n (1+ n))))
73    (if minus (- val) val)))
74 
75
76(defun %integer-to-string (int &optional (radix 10))
77  (%pr-integer int radix nil t))
78
79
80;;; it may be hard to believe, but this is much faster than the lap
81;;; version (3 or 4X) for fixnums that is (stream-write-string vs
82;;; stream-tyo ???)
83
84(defun %pr-integer (int &optional (radix 10) (stream *standard-output*) return-it  negate-it)
85  (declare (fixnum radix)) ; assume caller has checked
86  (if stream 
87    (if (eq stream t) (setq stream *terminal-io*))
88    (setq stream *standard-output*))
89  (let ((digit-string "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))   
90    (cond ((fixnump int)  ; ugh                     
91           (let ((temstring (make-string (- target::nbits-in-word target::fixnumshift) :element-type 'base-char))
92                 (i (- target::nbits-in-word  target::fixnumshift 1))
93                 (neg (< int 0))
94                 (rem 0))
95             (declare (fixnum i rem))
96             (declare (dynamic-extent temstring))
97             (when neg (setq int (- int)))
98             (when (not (fixnump int))
99               (return-from %pr-integer (%pr-integer int radix stream return-it t)))
100             (locally (declare (fixnum int)) 
101               (loop
102                 (multiple-value-setq  (int rem) (%fixnum-truncate int radix))                 
103                 (setf (%schar temstring i)(%schar digit-string rem))
104                 (when (eq 0 int)
105                   (return))
106                 (setq i (1- i)))
107               (when neg 
108                 (setf (%schar temstring (setq i (1- i))) #\-))
109               (if return-it
110                 (%substr temstring i (- target::nbits-in-word
111                                         target::fixnumshift))
112                 (write-string temstring stream :start i :end (- target::nbits-in-word target::fixnumshift))))))         
113          (t (let* ((size-vect #(nil nil 32 21 16 14 13 12 11
114                                 11   10 10  9  9  9  9  8  8
115                                 8     8  8  8  8  8  7  7  7
116                                 7     7  7  7  7  7  7  7  7 7))
117                    ;; overestimate # digits by a little for weird
118                    ;; radix
119                    (bigwords (uvsize int))
120                    (strlen (1+ (* bigwords (svref size-vect radix))))
121                    (temstring (make-string strlen :element-type 'base-char))
122                    (i (1- strlen))
123                    (neg (< int 0))
124                    ; ;(rem 0)
125                    ;; ;better-bignum-print?
126                    )  ; warn
127               (declare (dynamic-extent temstring)
128                        (fixnum i strlen))
129               (flet ((do-it (newbig)
130                        (print-bignum-2 newbig radix temstring digit-string)))
131                 (declare (dynamic-extent #'do-it))
132                 (setq i (with-one-negated-bignum-buffer int do-it)))                           
133               (when (or neg negate-it) 
134                 (setf (%schar temstring (setq i (1- i))) #\-))
135               (if return-it
136                 (%substr temstring i strlen)
137                 (write-string temstring stream :start i :end strlen)))))))
138
139
140
141;;; *BASE-POWER* holds the number that we keep dividing into the bignum for
142;;; each *print-base*.  We want this number as close to *most-positive-fixnum*
143;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)).
144;;;
145(defparameter *base-power* ())
146
147;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that
148;;; fit in the corresponding *base-power*.
149;;;
150(defparameter *fixnum-power--1* ())
151
152(do* ((b (make-array 37 :initial-element nil))
153      (f (make-array 37 :initial-element nil))
154      (base 2 (1+ base)))
155     ((= base 37) (setq *base-power* b *fixnum-power--1* f))
156  (do ((power-1 -1 (1+ power-1))
157       (new-divisor base (* new-divisor base))
158       (divisor 1 new-divisor))
159      ((not (fixnump new-divisor))
160       (setf (aref b base) divisor)
161       (setf (aref f base) power-1))))
162
163
164(defun print-bignum-2 (big radix string digit-string)
165  (declare (optimize (speed 3) (safety 0))
166           (simple-base-string string digit-string))
167  (let* ((divisor (aref *base-power* radix))
168         (power (aref *fixnum-power--1* radix))
169         (index (1- (length string)))
170         (rem 0))
171    (declare (fixnum index divisor power))
172    ;;(print index)
173    (loop
174      (multiple-value-setq (big rem) (truncate big divisor))
175      (let* ((int rem)
176             (rem 0)
177             (final-index (- index power 1)))
178        (loop
179          (multiple-value-setq (int rem) (%fixnum-truncate int radix))
180          (setf (schar string index)(schar digit-string rem))
181          (when (eql 0 int)
182            (return index))
183          (setq index (1- index)))
184        (if (zerop big)
185          (return index)
186          (dotimes (i (- index final-index) index)
187            (declare (fixnum i))
188            (setq index (1- index))
189            (setf (schar string index) #\0)))))))
190
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 n :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.