source: branches/qres/ccl/level-0/l0-int.lisp @ 14261

Last change on this file since 14261 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.0 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)))))))
Note: See TracBrowser for help on using the repository browser.