1 | ;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | (in-package "CCL") |
---|
18 | |
---|
19 | (eval-when (:compile-toplevel :execute) |
---|
20 | (require "NUMBER-MACROS") |
---|
21 | ) |
---|
22 | |
---|
23 | (defun %parse-number-token (string &optional start end radix) |
---|
24 | (if end (require-type end 'fixnum)(setq end (length string))) |
---|
25 | (if start (require-type start 'fixnum)(setq start 0)) |
---|
26 | (multiple-value-bind (string offset)(array-data-and-offset string) |
---|
27 | (new-numtoken string (+ start offset)(- end start) (%validate-radix (or radix 10))))) |
---|
28 | |
---|
29 | (defun new-numtoken (string start len radix &optional no-rat no-sign) |
---|
30 | (declare (fixnum start len radix)) |
---|
31 | (if (eq 0 len) |
---|
32 | nil |
---|
33 | (let ((c (%scharcode string start)) |
---|
34 | (nstart start) |
---|
35 | (end (+ start len)) |
---|
36 | (hic (if (<= radix 10) |
---|
37 | (+ (char-code #\0) (1- radix)) |
---|
38 | (+ (char-code #\A) (- radix 11)))) |
---|
39 | dot dec dgt) |
---|
40 | (declare (fixnum nstart end hic)) |
---|
41 | (when (or (eq c (char-code #\+))(eq c (char-code #\-))) |
---|
42 | (if no-sign |
---|
43 | (return-from new-numtoken nil) |
---|
44 | (setq nstart (1+ nstart)))) |
---|
45 | (when (eq nstart end)(return-from new-numtoken nil)) ; just a sign |
---|
46 | (do ((i nstart (1+ i))) |
---|
47 | ((eq i end)) |
---|
48 | (let () |
---|
49 | (setq c (%scharcode string i)) |
---|
50 | (cond |
---|
51 | ((eq c (char-code #\.)) |
---|
52 | (when dot (return-from new-numtoken nil)) |
---|
53 | (setq dot t) |
---|
54 | (when dec (return-from new-numtoken nil)) |
---|
55 | (setq hic (char-code #\9))) |
---|
56 | ((< c (char-code #\0)) |
---|
57 | (when (and (eq c (char-code #\/))(not dot)(not no-rat)) |
---|
58 | (let ((top (new-numtoken string start (- i start) radix))) |
---|
59 | (when top |
---|
60 | (let ((bottom (new-numtoken string (+ start i 1) (- len i 1) radix t t))) |
---|
61 | (when bottom |
---|
62 | (return-from new-numtoken (/ top bottom))))))) |
---|
63 | (return-from new-numtoken nil)) |
---|
64 | ((<= c (char-code #\9)) |
---|
65 | (when (> c hic) |
---|
66 | ; seen a decimal digit above base. |
---|
67 | (setq dgt t))) |
---|
68 | (t (when (>= c (char-code #\a))(setq c (- c 32))) |
---|
69 | ;; don't care about *read-base* if float |
---|
70 | (cond ((or (< c (char-code #\A))(> c hic)) |
---|
71 | (when (and (neq i nstart) ; need some digits first |
---|
72 | (memq c '#.(list (char-code #\E)(char-code #\F) |
---|
73 | (char-code #\D)(char-code #\L) |
---|
74 | (char-code #\S)))) |
---|
75 | (return-from new-numtoken (parse-float string len start))) |
---|
76 | (return-from new-numtoken nil)) |
---|
77 | (t ; seen a "digit" in base that ain't decimal |
---|
78 | (setq dec t))))))) |
---|
79 | (when (and dot (or (and (neq nstart start)(eq len 2)) |
---|
80 | (eq len 1))) ;. +. or -. |
---|
81 | (return-from new-numtoken nil)) |
---|
82 | (when dot |
---|
83 | (if (eq c (char-code #\.)) |
---|
84 | (progn (setq len (1- len) end (1- end)) |
---|
85 | (when dec (return-from new-numtoken nil)) |
---|
86 | ; make #o9. work (should it) |
---|
87 | (setq radix 10 dgt nil)) |
---|
88 | (return-from new-numtoken (parse-float string len start)))) |
---|
89 | (when dgt (return-from new-numtoken nil)) ; so why didnt we quit at first sight of it? |
---|
90 | ; and we ought to accumulate as we go until she gets too big - maybe |
---|
91 | (cond (nil ;(or (and (eq radix 10)(< (- end nstart) 9))(and (eq radix 8)(< (- end nstart) 10))) |
---|
92 | (let ((num 0)) |
---|
93 | (declare (fixnum num)) |
---|
94 | (do ((i nstart (1+ i))) |
---|
95 | ((eq i end)) |
---|
96 | (setq num (%i+ (%i* num radix)(%i- (%scharcode string i) (char-code #\0))))) |
---|
97 | (if (eq (%scharcode string start) (char-code #\-)) (setq num (- num))) |
---|
98 | num)) |
---|
99 | (t (token2int string start len radix)))))) |
---|
100 | |
---|
101 | |
---|
102 | ;; Will Clingers number 1.448997445238699 |
---|
103 | ;; Doug Curries numbers 214748.3646, 1073741823/5000 |
---|
104 | ;; My number: 12. |
---|
105 | ;; Your number: |
---|
106 | |
---|
107 | |
---|
108 | |
---|
109 | |
---|
110 | |
---|
111 | (defun logand (&lexpr numbers) |
---|
112 | "Return the bit-wise and of its arguments. Args must be integers." |
---|
113 | (let* ((count (%lexpr-count numbers))) |
---|
114 | (declare (fixnum count)) |
---|
115 | (if (zerop count) |
---|
116 | -1 |
---|
117 | (let* ((n0 (%lisp-word-ref numbers count))) |
---|
118 | (if (= count 1) |
---|
119 | (require-type n0 'integer) |
---|
120 | (do* ((i 1 (1+ i))) |
---|
121 | ((= i count) n0) |
---|
122 | (declare (fixnum i)) |
---|
123 | (declare (optimize (speed 3) (safety 0))) |
---|
124 | (setq n0 (logand (%lexpr-ref numbers count i) n0)))))))) |
---|
125 | |
---|
126 | |
---|
127 | (defun logior (&lexpr numbers) |
---|
128 | "Return the bit-wise or of its arguments. Args must be integers." |
---|
129 | (let* ((count (%lexpr-count numbers))) |
---|
130 | (declare (fixnum count)) |
---|
131 | (if (zerop count) |
---|
132 | 0 |
---|
133 | (let* ((n0 (%lisp-word-ref numbers count))) |
---|
134 | (if (= count 1) |
---|
135 | (require-type n0 'integer) |
---|
136 | (do* ((i 1 (1+ i))) |
---|
137 | ((= i count) n0) |
---|
138 | (declare (fixnum i)) |
---|
139 | (declare (optimize (speed 3) (safety 0))) |
---|
140 | (setq n0 (logior (%lexpr-ref numbers count i) n0)))))))) |
---|
141 | |
---|
142 | (defun logxor (&lexpr numbers) |
---|
143 | "Return the bit-wise exclusive or of its arguments. Args must be integers." |
---|
144 | (let* ((count (%lexpr-count numbers))) |
---|
145 | (declare (fixnum count)) |
---|
146 | (if (zerop count) |
---|
147 | 0 |
---|
148 | (let* ((n0 (%lisp-word-ref numbers count))) |
---|
149 | (if (= count 1) |
---|
150 | (require-type n0 'integer) |
---|
151 | (do* ((i 1 (1+ i))) |
---|
152 | ((= i count) n0) |
---|
153 | (declare (fixnum i)) |
---|
154 | (declare (optimize (speed 3) (safety 0))) |
---|
155 | (setq n0 (logxor (%lexpr-ref numbers count i) n0)))))))) |
---|
156 | |
---|
157 | (defun logeqv (&lexpr numbers) |
---|
158 | "Return the bit-wise equivalence of its arguments. Args must be integers." |
---|
159 | (let* ((count (%lexpr-count numbers)) |
---|
160 | (result (if (zerop count) |
---|
161 | 0 |
---|
162 | (let* ((n0 (%lisp-word-ref numbers count))) |
---|
163 | (if (= count 1) |
---|
164 | (require-type n0 'integer) |
---|
165 | (do* ((i 1 (1+ i))) |
---|
166 | ((= i count) n0) |
---|
167 | (declare (fixnum i)) |
---|
168 | (declare (optimize (speed 3) (safety 0))) |
---|
169 | (setq n0 (logxor (%lexpr-ref numbers count i) n0)))))))) |
---|
170 | (declare (fixnum count)) |
---|
171 | (if (evenp count) |
---|
172 | (lognot result) |
---|
173 | result))) |
---|
174 | |
---|
175 | |
---|
176 | |
---|
177 | |
---|
178 | (defun = (num &lexpr more) |
---|
179 | "Return T if all of its arguments are numerically equal, NIL otherwise." |
---|
180 | (let* ((count (%lexpr-count more))) |
---|
181 | (declare (fixnum count)) |
---|
182 | (if (zerop count) |
---|
183 | (progn |
---|
184 | (require-type num 'number) |
---|
185 | t) |
---|
186 | (dotimes (i count t) |
---|
187 | (unless (=-2 (%lexpr-ref more count i) num) (return)))))) |
---|
188 | |
---|
189 | (defun /= (num &lexpr more) |
---|
190 | "Return T if no two of its arguments are numerically equal, NIL otherwise." |
---|
191 | (let* ((count (%lexpr-count more))) |
---|
192 | (declare (fixnum count)) |
---|
193 | (if (zerop count) |
---|
194 | (progn |
---|
195 | (require-type num 'number) |
---|
196 | t) |
---|
197 | (dotimes (i count t) |
---|
198 | (declare (fixnum i)) |
---|
199 | (do ((j i (1+ j))) |
---|
200 | ((= j count)) |
---|
201 | (declare (fixnum j)) |
---|
202 | (when (=-2 num (%lexpr-ref more count j)) |
---|
203 | (return-from /= nil))) |
---|
204 | (setq num (%lexpr-ref more count i)))))) |
---|
205 | |
---|
206 | (defun - (num &lexpr more) |
---|
207 | "Subtract the second and all subsequent arguments from the first; |
---|
208 | or with one argument, negate the first argument." |
---|
209 | (let* ((count (%lexpr-count more))) |
---|
210 | (declare (fixnum count)) |
---|
211 | (if (zerop count) |
---|
212 | (- num) |
---|
213 | (dotimes (i count num) |
---|
214 | (setq num (--2 num (%lexpr-ref more count i))))))) |
---|
215 | |
---|
216 | (defun / (num &lexpr more) |
---|
217 | "Divide the first argument by each of the following arguments, in turn. |
---|
218 | With one argument, return reciprocal." |
---|
219 | (let* ((count (%lexpr-count more))) |
---|
220 | (declare (fixnum count)) |
---|
221 | (if (zerop count) |
---|
222 | (%quo-1 num) |
---|
223 | (dotimes (i count num) |
---|
224 | (setq num (/-2 num (%lexpr-ref more count i))))))) |
---|
225 | |
---|
226 | (defun + (&lexpr numbers) |
---|
227 | "Return the sum of its arguments. With no args, returns 0." |
---|
228 | (let* ((count (%lexpr-count numbers))) |
---|
229 | (declare (fixnum count)) |
---|
230 | (if (zerop count) |
---|
231 | 0 |
---|
232 | (let* ((n0 (%lisp-word-ref numbers count))) |
---|
233 | (if (= count 1) |
---|
234 | (require-type n0 'number) |
---|
235 | (do* ((i 1 (1+ i))) |
---|
236 | ((= i count) n0) |
---|
237 | (declare (fixnum i)) |
---|
238 | (setq n0 (+-2 (%lexpr-ref numbers count i) n0)))))))) |
---|
239 | |
---|
240 | |
---|
241 | |
---|
242 | (defun * (&lexpr numbers) |
---|
243 | "Return the product of its arguments. With no args, returns 1." |
---|
244 | (let* ((count (%lexpr-count numbers))) |
---|
245 | (declare (fixnum count)) |
---|
246 | (if (zerop count) |
---|
247 | 1 |
---|
248 | (let* ((n0 (%lisp-word-ref numbers count))) |
---|
249 | (if (= count 1) |
---|
250 | (require-type n0 'number) |
---|
251 | (do* ((i 1 (1+ i))) |
---|
252 | ((= i count) n0) |
---|
253 | (declare (fixnum i)) |
---|
254 | (declare (optimize (speed 3) (safety 0))) |
---|
255 | (setq n0 (*-2 (%lexpr-ref numbers count i) n0)))))))) |
---|
256 | |
---|
257 | |
---|
258 | (defun < (num &lexpr more) |
---|
259 | "Return T if its arguments are in strictly increasing order, NIL otherwise." |
---|
260 | (let* ((count (%lexpr-count more))) |
---|
261 | (declare (fixnum count)) |
---|
262 | (if (zerop count) |
---|
263 | (progn |
---|
264 | (require-type num 'real) |
---|
265 | t) |
---|
266 | (dotimes (i count t) |
---|
267 | (declare (optimize (speed 3) (safety 0))) |
---|
268 | (unless (< num (setq num (%lexpr-ref more count i))) |
---|
269 | (return)))))) |
---|
270 | |
---|
271 | (defun <= (num &lexpr more) |
---|
272 | "Return T if arguments are in strictly non-decreasing order, NIL otherwise." |
---|
273 | (let* ((count (%lexpr-count more))) |
---|
274 | (declare (fixnum count)) |
---|
275 | (if (zerop count) |
---|
276 | (progn |
---|
277 | (require-type num 'real) |
---|
278 | t) |
---|
279 | (dotimes (i count t) |
---|
280 | (declare (optimize (speed 3) (safety 0))) |
---|
281 | (unless (<= num (setq num (%lexpr-ref more count i))) |
---|
282 | (return)))))) |
---|
283 | |
---|
284 | |
---|
285 | (defun > (num &lexpr more) |
---|
286 | "Return T if its arguments are in strictly decreasing order, NIL otherwise." |
---|
287 | (let* ((count (%lexpr-count more))) |
---|
288 | (declare (fixnum count)) |
---|
289 | (if (zerop count) |
---|
290 | (progn |
---|
291 | (require-type num 'real) |
---|
292 | t) |
---|
293 | (dotimes (i count t) |
---|
294 | (declare (optimize (speed 3) (safety 0))) |
---|
295 | (unless (> num (setq num (%lexpr-ref more count i))) |
---|
296 | (return)))))) |
---|
297 | |
---|
298 | (defun >= (num &lexpr more) |
---|
299 | "Return T if arguments are in strictly non-increasing order, NIL otherwise." |
---|
300 | (let* ((count (%lexpr-count more))) |
---|
301 | (declare (fixnum count)) |
---|
302 | (if (zerop count) |
---|
303 | (progn |
---|
304 | (require-type num 'real) |
---|
305 | t) |
---|
306 | (dotimes (i count t) |
---|
307 | (declare (optimize (speed 3) (safety 0))) |
---|
308 | (unless (>= num (setq num (%lexpr-ref more count i))) |
---|
309 | (return)))))) |
---|
310 | |
---|
311 | (defun max-2 (n0 n1) |
---|
312 | (if (> n0 n1) n0 n1)) |
---|
313 | |
---|
314 | (defun max (num &lexpr more) |
---|
315 | "Return the greatest of its arguments; among EQUALP greatest, return |
---|
316 | the first." |
---|
317 | (let* ((count (%lexpr-count more))) |
---|
318 | (declare (fixnum count)) |
---|
319 | (if (zerop count) |
---|
320 | (require-type num 'real) |
---|
321 | (dotimes (i count num) |
---|
322 | (declare (optimize (speed 3) (safety 0))) |
---|
323 | (setq num (max-2 (%lexpr-ref more count i) num)))))) |
---|
324 | |
---|
325 | (defun min-2 (n0 n1) |
---|
326 | (if (< n0 n1) n0 n1)) |
---|
327 | |
---|
328 | (defun min (num &lexpr more) |
---|
329 | "Return the least of its arguments; among EQUALP least, return |
---|
330 | the first." |
---|
331 | (let* ((count (%lexpr-count more))) |
---|
332 | (declare (fixnum count)) |
---|
333 | (if (zerop count) |
---|
334 | (require-type num 'real) |
---|
335 | (dotimes (i count num) |
---|
336 | (declare (optimize (speed 3) (safety 0))) |
---|
337 | (setq num (min-2 (%lexpr-ref more count i) num)))))) |
---|
338 | |
---|
339 | |
---|
340 | |
---|
341 | ;Not CL. Used by transforms. |
---|
342 | (defun deposit-byte (value size position integer) |
---|
343 | (let ((mask (byte-mask size))) |
---|
344 | (logior (ash (logand value mask) position) |
---|
345 | (logandc1 (ash mask position) integer)))) |
---|
346 | |
---|
347 | (defun deposit-field (value bytespec integer) |
---|
348 | "Return new integer with newbyte in specified position, newbyte is not right justified." |
---|
349 | (if (> bytespec 0) |
---|
350 | (logior (logandc1 bytespec integer) (logand bytespec value)) |
---|
351 | (progn |
---|
352 | (require-type value 'integer) |
---|
353 | (require-type integer 'integer)))) |
---|
354 | |
---|
355 | ;;;;;;;;;; Byte field functions ;;;;;;;;;;;;;;;; |
---|
356 | |
---|
357 | ;;; Size = 0, position = 0 -> 0 |
---|
358 | ;;; size = 0, position > 0 -> -position |
---|
359 | ;;; else -> (ash (byte-mask size) position) |
---|
360 | (defun byte (size position) |
---|
361 | "Return a byte specifier which may be used by other byte functions |
---|
362 | (e.g. LDB)." |
---|
363 | (unless (and (typep size 'integer) |
---|
364 | (>= size 0)) |
---|
365 | (report-bad-arg size 'unsigned-byte)) |
---|
366 | (unless (and (typep position 'integer) |
---|
367 | (>= position 0)) |
---|
368 | (report-bad-arg position 'unsigned-byte)) |
---|
369 | (if (eql 0 size) |
---|
370 | (if (eql 0 position) |
---|
371 | 0 |
---|
372 | (- position)) |
---|
373 | (ash (byte-mask size) position))) |
---|
374 | |
---|
375 | |
---|
376 | |
---|
377 | (defun byte-size (bytespec) |
---|
378 | "Return the size part of the byte specifier bytespec." |
---|
379 | (if (> bytespec 0) |
---|
380 | (logcount bytespec) |
---|
381 | 0)) |
---|
382 | |
---|
383 | (defun ldb (bytespec integer) |
---|
384 | "Extract the specified byte from integer, and right justify result." |
---|
385 | (if (and (fixnump bytespec) (> (the fixnum bytespec) 0) (fixnump integer)) |
---|
386 | (%ilsr (byte-position bytespec) (%ilogand bytespec integer)) |
---|
387 | (let ((size (byte-size bytespec)) |
---|
388 | (position (byte-position bytespec))) |
---|
389 | (if (eql size 0) |
---|
390 | (progn |
---|
391 | (require-type integer 'integer) |
---|
392 | 0) |
---|
393 | (if (and (bignump integer) |
---|
394 | (<= size (- (1- target::nbits-in-word) target::fixnumshift)) |
---|
395 | (fixnump position)) |
---|
396 | (%ldb-fixnum-from-bignum integer size position) |
---|
397 | (ash (logand bytespec integer) (- position))))))) |
---|
398 | |
---|
399 | (defun mask-field (bytespec integer) |
---|
400 | "Extract the specified byte from integer, but do not right justify result." |
---|
401 | (if (>= bytespec 0) |
---|
402 | (logand bytespec integer) |
---|
403 | (logand integer 0))) |
---|
404 | |
---|
405 | (defun dpb (value bytespec integer) |
---|
406 | "Return new integer with newbyte in specified position, newbyte is right justified." |
---|
407 | (if (and (fixnump value) |
---|
408 | (fixnump bytespec) |
---|
409 | (> (the fixnum bytespec) 0) |
---|
410 | (fixnump integer)) |
---|
411 | (%ilogior (%ilogand bytespec (%ilsl (byte-position bytespec) value)) |
---|
412 | (%ilogand (%ilognot bytespec) integer)) |
---|
413 | (deposit-field (ash value (byte-position bytespec)) bytespec integer))) |
---|
414 | |
---|
415 | (defun ldb-test (bytespec integer) |
---|
416 | "Return T if any of the specified bits in integer are 1's." |
---|
417 | (if (> bytespec 0) |
---|
418 | (logtest bytespec integer) |
---|
419 | (progn |
---|
420 | (require-type integer 'integer) |
---|
421 | nil))) |
---|
422 | |
---|
423 | (defun %cons-random-state (seed-1 seed-2) |
---|
424 | #+32-bit-target |
---|
425 | (%istruct 'random-state seed-1 seed-2) |
---|
426 | #+64-bit-target |
---|
427 | (%istruct 'random-state (the fixnum (+ (the fixnum seed-2) |
---|
428 | (the fixnum (ash (the fixnum seed-1) 16)))))) |
---|
429 | |
---|
430 | ;;; random associated stuff except for the print-object method which |
---|
431 | ;;; is still in "lib;numbers.lisp" |
---|
432 | (defun initialize-random-state (seed-1 seed-2) |
---|
433 | (unless (and (fixnump seed-1) (%i<= 0 seed-1) (%i< seed-1 #x10000)) |
---|
434 | (report-bad-arg seed-1 '(unsigned-byte 16))) |
---|
435 | (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000)) |
---|
436 | (report-bad-arg seed-2 '(unsigned-byte 16))) |
---|
437 | (%cons-random-state seed-1 seed-2)) |
---|
438 | |
---|
439 | (defun make-random-state (&optional state) |
---|
440 | "Make a random state object. If STATE is not supplied, return a copy |
---|
441 | of the default random state. If STATE is a random state, then return a |
---|
442 | copy of it. If STATE is T then return a random state generated from |
---|
443 | the universal time." |
---|
444 | (let* ((seed-1 0) |
---|
445 | (seed-2 0)) |
---|
446 | (if (eq state t) |
---|
447 | (multiple-value-setq (seed-1 seed-2) (init-random-state-seeds)) |
---|
448 | (progn |
---|
449 | (setq state (require-type (or state *random-state*) 'random-state)) |
---|
450 | #+32-bit-target |
---|
451 | (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state)) |
---|
452 | #+64-bit-target |
---|
453 | (let* ((seed (random.seed-1 state))) |
---|
454 | (declare (type (unsigned-byte 32) seed)) |
---|
455 | (setq seed-1 (ldb (byte 16 16) seed) |
---|
456 | seed-2 (ldb (byte 16 0) seed))))) |
---|
457 | (%cons-random-state seed-1 seed-2))) |
---|
458 | |
---|
459 | (defun random-state-p (thing) (istruct-typep thing 'random-state)) |
---|
460 | |
---|
461 | ;;; transcendental stuff. Should go in level-0;l0-float |
---|
462 | ;;; but shleps don't work in level-0. Or do they ? |
---|
463 | ; Destructively set z to x^y and return z. |
---|
464 | (defun %double-float-expt! (b e result) |
---|
465 | (declare (double-float b e result)) |
---|
466 | (with-stack-double-floats ((temp)) |
---|
467 | (%setf-double-float temp (#_pow b e)) |
---|
468 | (%df-check-exception-2 'expt b e (%ffi-exception-status)) |
---|
469 | (%setf-double-float result TEMP))) |
---|
470 | |
---|
471 | #+(and 32-bit-target (not win32-target)) |
---|
472 | (defun %single-float-expt! (b e result) |
---|
473 | (declare (single-float b e result)) |
---|
474 | (target::with-stack-short-floats ((temp)) |
---|
475 | (%setf-short-float temp (#_powf b e)) |
---|
476 | (%sf-check-exception-2 'expt b e (%ffi-exception-status)) |
---|
477 | (%setf-short-float result TEMP))) |
---|
478 | |
---|
479 | #+win32-target |
---|
480 | (defun %single-float-expt! (b e result) |
---|
481 | (declare (single-float b e result)) |
---|
482 | (with-stack-double-floats ((temp) (db b) (de e)) |
---|
483 | (%setf-double-float temp (#_pow db de)) |
---|
484 | (%df-check-exception-2 'expt b e (%ffi-exception-status)) |
---|
485 | (%double-float->short-float temp result))) |
---|
486 | |
---|
487 | #+64-bit-target |
---|
488 | (defun %single-float-expt (b e) |
---|
489 | (declare (single-float b e)) |
---|
490 | (let* ((result (#_powf b e))) |
---|
491 | (%sf-check-exception-2 'expt b e (%ffi-exception-status)) |
---|
492 | result)) |
---|
493 | |
---|
494 | (defun %double-float-sin! (n result) |
---|
495 | (declare (double-float n result)) |
---|
496 | (with-stack-double-floats ((temp)) |
---|
497 | (%setf-double-float TEMP (#_sin n)) |
---|
498 | (%df-check-exception-1 'sin n (%ffi-exception-status)) |
---|
499 | (%setf-double-float result TEMP))) |
---|
500 | |
---|
501 | #+32-bit-target |
---|
502 | (defun %single-float-sin! (n result) |
---|
503 | (declare (single-float n result)) |
---|
504 | (target::with-stack-short-floats ((temp)) |
---|
505 | (%setf-short-float TEMP (#_sinf n)) |
---|
506 | (%sf-check-exception-1 'sin n (%ffi-exception-status)) |
---|
507 | (%setf-short-float result TEMP))) |
---|
508 | |
---|
509 | #+64-bit-target |
---|
510 | (defun %single-float-sin (n) |
---|
511 | (declare (single-float n)) |
---|
512 | (let* ((result (#_sinf n))) |
---|
513 | (%sf-check-exception-1 'sin n (%ffi-exception-status)) |
---|
514 | result)) |
---|
515 | |
---|
516 | (defun %double-float-cos! (n result) |
---|
517 | (declare (double-float n result)) |
---|
518 | (with-stack-double-floats ((temp)) |
---|
519 | (%setf-double-float TEMP (#_cos n)) |
---|
520 | (%df-check-exception-1 'cos n (%ffi-exception-status)) |
---|
521 | (%setf-double-float result TEMP))) |
---|
522 | |
---|
523 | #+32-bit-target |
---|
524 | (defun %single-float-cos! (n result) |
---|
525 | (declare (single-float n result)) |
---|
526 | (target::with-stack-short-floats ((temp)) |
---|
527 | (%setf-short-float TEMP (#_cosf n)) |
---|
528 | (%sf-check-exception-1 'cos n (%ffi-exception-status)) |
---|
529 | (%setf-short-float result TEMP))) |
---|
530 | |
---|
531 | #+64-bit-target |
---|
532 | (defun %single-float-cos (n) |
---|
533 | (declare (single-float n)) |
---|
534 | (let* ((result (#_cosf n))) |
---|
535 | (%sf-check-exception-1 'cos n (%ffi-exception-status)) |
---|
536 | result)) |
---|
537 | |
---|
538 | (defun %double-float-acos! (n result) |
---|
539 | (declare (double-float n result)) |
---|
540 | (with-stack-double-floats ((temp)) |
---|
541 | (%setf-double-float TEMP (#_acos n)) |
---|
542 | (%df-check-exception-1 'acos n (%ffi-exception-status)) |
---|
543 | (%setf-double-float result TEMP))) |
---|
544 | |
---|
545 | #+32-bit-target |
---|
546 | (defun %single-float-acos! (n result) |
---|
547 | (declare (single-float n result)) |
---|
548 | (target::with-stack-short-floats ((temp)) |
---|
549 | (%setf-short-float TEMP (#_acosf n)) |
---|
550 | (%sf-check-exception-1 'acos n (%ffi-exception-status)) |
---|
551 | (%setf-short-float result TEMP))) |
---|
552 | |
---|
553 | #+64-bit-target |
---|
554 | (defun %single-float-acos (n) |
---|
555 | (declare (single-float n)) |
---|
556 | (let* ((result (#_acosf n))) |
---|
557 | (%sf-check-exception-1 'acos n (%ffi-exception-status)) |
---|
558 | result)) |
---|
559 | |
---|
560 | (defun %double-float-asin! (n result) |
---|
561 | (declare (double-float n result)) |
---|
562 | (with-stack-double-floats ((temp)) |
---|
563 | (%setf-double-float TEMP (#_asin n)) |
---|
564 | (%df-check-exception-1 'asin n (%ffi-exception-status)) |
---|
565 | (%setf-double-float result TEMP))) |
---|
566 | |
---|
567 | #+32-bit-target |
---|
568 | (defun %single-float-asin! (n result) |
---|
569 | (declare (single-float n result)) |
---|
570 | (target::with-stack-short-floats ((temp)) |
---|
571 | (%setf-short-float TEMP (#_asinf n)) |
---|
572 | (%sf-check-exception-1 'asin n (%ffi-exception-status)) |
---|
573 | (%setf-short-float result TEMP))) |
---|
574 | |
---|
575 | #+64-bit-target |
---|
576 | (defun %single-float-asin (n) |
---|
577 | (declare (single-float n)) |
---|
578 | (let* ((result (#_asinf n))) |
---|
579 | (%sf-check-exception-1 'asin n (%ffi-exception-status)) |
---|
580 | result)) |
---|
581 | |
---|
582 | (defun %double-float-cosh! (n result) |
---|
583 | (declare (double-float n result)) |
---|
584 | (with-stack-double-floats ((temp)) |
---|
585 | (%setf-double-float TEMP (#_cosh n)) |
---|
586 | (%df-check-exception-1 'cosh n (%ffi-exception-status)) |
---|
587 | (%setf-double-float result TEMP))) |
---|
588 | |
---|
589 | #+32-bit-target |
---|
590 | (defun %single-float-cosh! (n result) |
---|
591 | (declare (single-float n result)) |
---|
592 | (target::with-stack-short-floats ((temp)) |
---|
593 | (%setf-short-float TEMP (external-call "coshf" :single-float n :single-float)) |
---|
594 | (%sf-check-exception-1 'cosh n (%ffi-exception-status)) |
---|
595 | (%setf-short-float result TEMP))) |
---|
596 | |
---|
597 | #+64-bit-target |
---|
598 | (defun %single-float-cosh (n) |
---|
599 | (declare (single-float n)) |
---|
600 | (let* ((result (#_coshf n))) |
---|
601 | (%sf-check-exception-1 'cosh n (%ffi-exception-status)) |
---|
602 | result)) |
---|
603 | |
---|
604 | (defun %double-float-log! (n result) |
---|
605 | (declare (double-float n result)) |
---|
606 | (with-stack-double-floats ((temp)) |
---|
607 | (%setf-double-float TEMP (#_log n)) |
---|
608 | (%df-check-exception-1 'log n (%ffi-exception-status)) |
---|
609 | (%setf-double-float result TEMP))) |
---|
610 | |
---|
611 | #+32-bit-target |
---|
612 | (defun %single-float-log! (n result) |
---|
613 | (declare (single-float n result)) |
---|
614 | (target::with-stack-short-floats ((temp)) |
---|
615 | (%setf-short-float TEMP (#_logf n)) |
---|
616 | (%sf-check-exception-1 'log n (%ffi-exception-status)) |
---|
617 | (%setf-short-float result TEMP))) |
---|
618 | |
---|
619 | #+64-bit-target |
---|
620 | (defun %single-float-log (n) |
---|
621 | (let* ((result (#_logf n))) |
---|
622 | (%sf-check-exception-1 'log n (%ffi-exception-status)) |
---|
623 | result)) |
---|
624 | |
---|
625 | (defun %double-float-tan! (n result) |
---|
626 | (declare (double-float n result)) |
---|
627 | (with-stack-double-floats ((temp)) |
---|
628 | (%setf-double-float TEMP (#_tan n)) |
---|
629 | (%df-check-exception-1 'tan n (%ffi-exception-status)) |
---|
630 | (%setf-double-float result TEMP))) |
---|
631 | |
---|
632 | #+32-bit-target |
---|
633 | (defun %single-float-tan! (n result) |
---|
634 | (declare (single-float n result)) |
---|
635 | (target::with-stack-short-floats ((temp)) |
---|
636 | (%setf-short-float TEMP (#_tanf n)) |
---|
637 | (%sf-check-exception-1 'tan n (%ffi-exception-status)) |
---|
638 | (%setf-short-float result TEMP))) |
---|
639 | |
---|
640 | #+64-bit-target |
---|
641 | (defun %single-float-tan (n) |
---|
642 | (declare (single-float n)) |
---|
643 | (let* ((result (#_tanf n))) |
---|
644 | (%sf-check-exception-1 'tan n (%ffi-exception-status)) |
---|
645 | result)) |
---|
646 | |
---|
647 | (defun %double-float-atan! (n result) |
---|
648 | (declare (double-float n result)) |
---|
649 | (with-stack-double-floats ((temp)) |
---|
650 | (%setf-double-float TEMP (#_atan n)) |
---|
651 | (%df-check-exception-1 'atan n (%ffi-exception-status)) |
---|
652 | (%setf-double-float result TEMP))) |
---|
653 | |
---|
654 | |
---|
655 | #+32-bit-target |
---|
656 | (defun %single-float-atan! (n result) |
---|
657 | (declare (single-float n result)) |
---|
658 | (target::with-stack-short-floats ((temp)) |
---|
659 | (%setf-short-float TEMP (#_atanf n)) |
---|
660 | (%sf-check-exception-1 'atan n (%ffi-exception-status)) |
---|
661 | (%setf-short-float result TEMP))) |
---|
662 | |
---|
663 | #+64-bit-target |
---|
664 | (defun %single-float-atan (n) |
---|
665 | (declare (single-float n)) |
---|
666 | (let* ((temp (#_atanf n))) |
---|
667 | (%sf-check-exception-1 'atan n (%ffi-exception-status)) |
---|
668 | temp)) |
---|
669 | |
---|
670 | (defun %double-float-atan2! (x y result) |
---|
671 | (declare (double-float x y result)) |
---|
672 | (with-stack-double-floats ((temp)) |
---|
673 | (%setf-double-float TEMP (#_atan2 x y)) |
---|
674 | (%df-check-exception-2 'atan2 x y (%ffi-exception-status)) |
---|
675 | (%setf-double-float result TEMP))) |
---|
676 | |
---|
677 | #+32-bit-target |
---|
678 | (defun %single-float-atan2! (x y result) |
---|
679 | (declare (single-float x y result)) |
---|
680 | (target::with-stack-short-floats ((temp)) |
---|
681 | (%setf-short-float TEMP (#_atan2f x y)) |
---|
682 | (%sf-check-exception-2 'atan2 x y (%ffi-exception-status)) |
---|
683 | (%setf-short-float result TEMP))) |
---|
684 | |
---|
685 | #+64-bit-target |
---|
686 | (defun %single-float-atan2 (x y) |
---|
687 | (declare (single-float x y)) |
---|
688 | (let* ((result (#_atan2f x y))) |
---|
689 | (%sf-check-exception-2 'atan2 x y (%ffi-exception-status)) |
---|
690 | result)) |
---|
691 | |
---|
692 | (defun %double-float-exp! (n result) |
---|
693 | (declare (double-float n result)) |
---|
694 | (with-stack-double-floats ((temp)) |
---|
695 | (%setf-double-float TEMP (#_exp n)) |
---|
696 | (%df-check-exception-1 'exp n (%ffi-exception-status)) |
---|
697 | (%setf-double-float result TEMP))) |
---|
698 | |
---|
699 | #+(and 32-bit-target (not windows target)) |
---|
700 | (defun %single-float-exp! (n result) |
---|
701 | (declare (single-float n result)) |
---|
702 | (target::with-stack-short-floats ((temp)) |
---|
703 | (%setf-short-float TEMP (#_expf n)) |
---|
704 | (%sf-check-exception-1 'exp n (%ffi-exception-status)) |
---|
705 | (%setf-short-float result TEMP))) |
---|
706 | |
---|
707 | #+64-bit-target |
---|
708 | (defun %single-float-exp (n) |
---|
709 | (declare (single-float n)) |
---|
710 | (let* ((result (#_expf n))) |
---|
711 | (%sf-check-exception-1 'exp n (%ffi-exception-status)) |
---|
712 | result)) |
---|
713 | |
---|
714 | (defun %double-float-sinh! (n result) |
---|
715 | (declare (double-float n result)) |
---|
716 | (with-stack-double-floats ((temp)) |
---|
717 | (%setf-double-float TEMP (#_sinh n)) |
---|
718 | (%df-check-exception-1 'sinh n (%ffi-exception-status)) |
---|
719 | (%setf-double-float result TEMP))) |
---|
720 | |
---|
721 | #+32-bit-target |
---|
722 | (defun %single-float-sinh! (n result) |
---|
723 | (declare (single-float n result)) |
---|
724 | (target::with-stack-short-floats ((temp)) |
---|
725 | (%setf-short-float TEMP (external-call "sinhf" :single-float n :single-float)) |
---|
726 | (%sf-check-exception-1 'sinh n (%ffi-exception-status)) |
---|
727 | (%setf-short-float result TEMP))) |
---|
728 | |
---|
729 | #+64-bit-target |
---|
730 | (defun %single-float-sinh (n) |
---|
731 | (declare (single-float n)) |
---|
732 | (let* ((result (#_sinhf n))) |
---|
733 | (%sf-check-exception-1 'sinh n (%ffi-exception-status)) |
---|
734 | result)) |
---|
735 | |
---|
736 | (defun %double-float-tanh! (n result) |
---|
737 | (declare (double-float n result)) |
---|
738 | (with-stack-double-floats ((temp)) |
---|
739 | (%setf-double-float TEMP (#_tanh n)) |
---|
740 | (%df-check-exception-1 'tanh n (%ffi-exception-status)) |
---|
741 | (%setf-double-float result TEMP))) |
---|
742 | |
---|
743 | #+32-bit-target |
---|
744 | (defun %single-float-tanh! (n result) |
---|
745 | (declare (single-float n result)) |
---|
746 | (target::with-stack-short-floats ((temp)) |
---|
747 | (%setf-short-float TEMP (external-call "tanhf" :single-float n :single-float)) |
---|
748 | (%sf-check-exception-1 'tanh n (%ffi-exception-status)) |
---|
749 | (%setf-short-float result TEMP))) |
---|
750 | |
---|
751 | #+64-bit-target |
---|
752 | (defun %single-float-tanh (n) |
---|
753 | (declare (single-float n)) |
---|
754 | (let* ((result (#_tanhf n))) |
---|
755 | (%sf-check-exception-1 'tanh n (%ffi-exception-status)) |
---|
756 | result)) |
---|
757 | |
---|
758 | #+windows-target |
---|
759 | (progn |
---|
760 | (defun %double-float-asinh! (n result) |
---|
761 | (%setf-double-float |
---|
762 | result |
---|
763 | (log (+ n (sqrt (1+ (* n n))))))) |
---|
764 | |
---|
765 | #+32-bit-target |
---|
766 | (defun %single-float-asinh! (n result) |
---|
767 | (%setf-short-float |
---|
768 | result |
---|
769 | (log (+ n (sqrt (1+ (* n n))))))) |
---|
770 | |
---|
771 | #+64-bit-target |
---|
772 | (defun %single-float-asinh (n) |
---|
773 | (log (+ n (sqrt (1+ (* n n))))))) |
---|
774 | |
---|
775 | #-windows-target |
---|
776 | (progn |
---|
777 | (defun %double-float-asinh! (n result) |
---|
778 | (declare (double-float n result)) |
---|
779 | (with-stack-double-floats ((temp)) |
---|
780 | (%setf-double-float TEMP (#_asinh n)) |
---|
781 | (%df-check-exception-1 'asinh n (%ffi-exception-status)) |
---|
782 | (%setf-double-float result TEMP))) |
---|
783 | |
---|
784 | |
---|
785 | #+32-bit-target |
---|
786 | (defun %single-float-asinh! (n result) |
---|
787 | (declare (single-float n result)) |
---|
788 | (target::with-stack-short-floats ((temp)) |
---|
789 | (%setf-short-float TEMP (#_asinhf n)) |
---|
790 | (%sf-check-exception-1 'asinh n (%ffi-exception-status)) |
---|
791 | (%setf-short-float result TEMP))) |
---|
792 | |
---|
793 | #+64-bit-target |
---|
794 | (defun %single-float-asinh (n) |
---|
795 | (declare (single-float n)) |
---|
796 | (let* ((result (#_asinhf n))) |
---|
797 | (%sf-check-exception-1 'asinh n (%ffi-exception-status)) |
---|
798 | result)) |
---|
799 | ) |
---|
800 | |
---|
801 | #+windows-target |
---|
802 | (progn |
---|
803 | (defun %double-float-acosh! (n result) |
---|
804 | (%setf-double-float |
---|
805 | result |
---|
806 | (* 2 (log (+ (sqrt (/ (+ n 1) 2)) (sqrt (/ (- n 1) 2))))))) |
---|
807 | |
---|
808 | #+32-bit-target |
---|
809 | (defun %single-float-acosh! (n result) |
---|
810 | (%setf-short-float |
---|
811 | result |
---|
812 | (* 2 (log (+ (sqrt (/ (+ n 1) 2)) (sqrt (/ (- n 1) 2))))))) |
---|
813 | |
---|
814 | #+64-bit-target |
---|
815 | (defun %single-float-acosh (n) |
---|
816 | (* 2 (log (+ (sqrt (/ (+ n 1) 2)) (sqrt (/ (- n 1) 2)))))) |
---|
817 | |
---|
818 | ) |
---|
819 | |
---|
820 | #-windows-target |
---|
821 | (progn |
---|
822 | (defun %double-float-acosh! (n result) |
---|
823 | (declare (double-float n result)) |
---|
824 | (with-stack-double-floats ((temp)) |
---|
825 | (%setf-double-float TEMP (#_acosh n)) |
---|
826 | (%df-check-exception-1 'acosh n (%ffi-exception-status)) |
---|
827 | (%setf-double-float result TEMP))) |
---|
828 | |
---|
829 | #+32-bit-target |
---|
830 | (defun %single-float-acosh! (n result) |
---|
831 | (declare (single-float n result)) |
---|
832 | (target::with-stack-short-floats ((temp)) |
---|
833 | (%setf-short-float TEMP (#_acoshf n)) |
---|
834 | (%sf-check-exception-1 'acosh n (%ffi-exception-status)) |
---|
835 | (%setf-short-float result TEMP))) |
---|
836 | |
---|
837 | #+64-bit-target |
---|
838 | (defun %single-float-acosh (n) |
---|
839 | (declare (single-float n)) |
---|
840 | (let* ((result (#_acoshf n))) |
---|
841 | (%sf-check-exception-1 'acosh n (%ffi-exception-status)) |
---|
842 | result)) |
---|
843 | ) |
---|
844 | |
---|
845 | #+windows-target |
---|
846 | (progn |
---|
847 | (defun %double-float-atanh! (n result) |
---|
848 | (%setf-double-float |
---|
849 | result |
---|
850 | (/ (- (log (1+ n)) |
---|
851 | (log (- 1 n))) |
---|
852 | 2))) |
---|
853 | |
---|
854 | #+32-bit-target |
---|
855 | (defun %single-float-atanh! (n result) |
---|
856 | (%setf-short-float |
---|
857 | result |
---|
858 | (/ (- (log (1+ n)) |
---|
859 | (log (- 1 n))) |
---|
860 | 2))) |
---|
861 | |
---|
862 | #+64-bit-target |
---|
863 | (defun %single-float-atanh (n) |
---|
864 | (/ (- (log (1+ n)) |
---|
865 | (log (- 1 n))) |
---|
866 | 2)) |
---|
867 | |
---|
868 | ) |
---|
869 | |
---|
870 | #-windows-target |
---|
871 | (progn |
---|
872 | (defun %double-float-atanh! (n result) |
---|
873 | (declare (double-float n result)) |
---|
874 | (with-stack-double-floats ((temp)) |
---|
875 | (%setf-double-float TEMP (#_atanh n)) |
---|
876 | (%df-check-exception-1 'atanh n (%ffi-exception-status)) |
---|
877 | (%setf-double-float result TEMP))) |
---|
878 | |
---|
879 | #+32-bit-target |
---|
880 | (defun %single-float-atanh! (n result) |
---|
881 | (declare (single-float n result)) |
---|
882 | (target::with-stack-short-floats ((temp)) |
---|
883 | (%setf-short-float TEMP (#_atanhf n)) |
---|
884 | (%sf-check-exception-1 'atanh n (%ffi-exception-status)) |
---|
885 | (%setf-short-float result TEMP))) |
---|
886 | |
---|
887 | #+64-bit-target |
---|
888 | (defun %single-float-atanh (n) |
---|
889 | (declare (single-float n)) |
---|
890 | (let* ((result (#_atanhf n))) |
---|
891 | (%sf-check-exception-1 'atanh n (%ffi-exception-status)) |
---|
892 | result)) |
---|
893 | ) |
---|