source: trunk/source/level-1/l1-numbers.lisp @ 8535

Last change on this file since 8535 was 8535, checked in by gb, 12 years ago

MAKE-RANDOM-STATE was broken last fall, probably broken on working-0711
branch as well.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 31.7 KB
Line 
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  (gvector :istruct
426           'random-state
427           seed-1
428           seed-2)
429  #+64-bit-target
430  (gvector :istruct
431           'random-state
432           (the fixnum (+ (the fixnum seed-2)
433                          (the fixnum (ash (the fixnum seed-1) 16))))))
434
435;;; random associated stuff except for the print-object method which
436;;; is still in "lib;numbers.lisp"
437(defun initialize-random-state (seed-1 seed-2)
438  (unless (and (fixnump seed-1) (%i<= 0 seed-1) (%i< seed-1 #x10000))
439    (report-bad-arg seed-1 '(unsigned-byte 16)))
440  (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000))
441    (report-bad-arg seed-2 '(unsigned-byte 16)))
442    (%cons-random-state seed-1 seed-2))
443
444(defun make-random-state (&optional state)
445  "Make a random state object. If STATE is not supplied, return a copy
446  of the default random state. If STATE is a random state, then return a
447  copy of it. If STATE is T then return a random state generated from
448  the universal time."
449  (let* ((seed-1 0)
450         (seed-2 0))
451    (if (eq state t)
452      (multiple-value-setq (seed-1 seed-2) (init-random-state-seeds))
453      (progn
454        (setq state (require-type (or state *random-state*) 'random-state))
455        #+32-bit-target
456        (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state))
457        #+64-bit-target
458        (let* ((seed (random.seed-1 state)))
459          (declare (type (unsigned-byte 32) seed))
460          (setq seed-1 (ldb (byte 16 16) seed)
461                seed-2 (ldb (byte 16 0) seed)))))
462    (%cons-random-state seed-1 seed-2)))
463
464(defun random-state-p (thing) (istruct-typep thing 'random-state))
465
466;;; transcendental stuff.  Should go in level-0;l0-float
467;;; but shleps don't work in level-0.  Or do they ?
468; Destructively set z to x^y and return z.
469(defun %double-float-expt! (b e result)
470  (declare (double-float b e result))
471  (with-stack-double-floats ((temp))
472    (%setf-double-float temp (#_pow b e))
473    (%df-check-exception-2 'expt b e (%ffi-exception-status))
474    (%setf-double-float result TEMP)))
475
476#+(and ppc32-target (not darwinppc-target))
477(defun %single-float-expt! (b e result)
478  (declare (single-float b e result))
479  (ppc32::with-stack-short-floats ((temp))
480    (%setf-short-float temp (#_powf b e))
481    (%sf-check-exception-2 'expt b e (%ffi-exception-status))
482    (%setf-short-float result TEMP)))
483
484#+(and ppc32-target darwinppc-target)
485(defun %single-float-expt! (b e result)
486  (declare (single-float b e result))
487  (with-stack-double-floats ((b2 b)
488                             (e2 e)
489                             (result2))
490    (%double-float-expt! b2 e2 result2)
491    (%double-float->short-float result2 result)))
492
493#+64-bit-target
494(defun %single-float-expt (b e)
495  (declare (single-float b e))
496  (let* ((result (#_powf b e)))
497    (%sf-check-exception-2 'expt b e (%ffi-exception-status))
498    result))
499
500(defun %double-float-sin! (n result)
501  (declare (double-float n result))
502  (with-stack-double-floats ((temp))
503    (%setf-double-float TEMP (#_sin n))
504    (%df-check-exception-1 'sin n (%ffi-exception-status))
505    (%setf-double-float result TEMP)))
506
507#+(and ppc32-target (not darwinppc-target))
508(defun %single-float-sin! (n result)
509  (declare (single-float n result))
510  (ppc32::with-stack-short-floats ((temp))
511    (%setf-short-float TEMP (#_sinf n))
512    (%sf-check-exception-1 'sin n (%ffi-exception-status))
513    (%setf-short-float result TEMP)))
514
515#+(and ppc32-target darwinppc-target)
516(defun %single-float-sin! (n result)
517  (declare (single-float n result))
518  (with-stack-double-floats ((n2 n)
519                             (result2))
520    (%double-float-sin! n2 result2)
521    (%double-float->short-float result2 result)))
522
523#+64-bit-target
524(defun %single-float-sin (n)
525  (declare (single-float n))
526  (let* ((result (#_sinf n)))
527    (%sf-check-exception-1 'sin n (%ffi-exception-status))
528    result))
529
530(defun %double-float-cos! (n result)
531  (declare (double-float n result))
532  (with-stack-double-floats ((temp))
533    (%setf-double-float TEMP (#_cos n))
534    (%df-check-exception-1 'cos n (%ffi-exception-status))
535    (%setf-double-float result TEMP)))
536
537#+(and ppc32-target (not darwinppc-target))
538(defun %single-float-cos! (n result)
539  (declare (single-float n result))
540  (ppc32::with-stack-short-floats ((temp))
541    (%setf-short-float TEMP (#_cosf n))
542    (%sf-check-exception-1 'cos n (%ffi-exception-status))
543    (%setf-short-float result TEMP)))
544
545#+(and ppc32-target darwinppc-target)
546(defun %single-float-cos! (n result)
547  (declare (single-float n result))
548  (with-stack-double-floats ((n2 n)
549                             (result2))
550    (%double-float-cos! n2 result2)
551    (%double-float->short-float result2 result)))
552
553#+64-bit-target
554(defun %single-float-cos (n)
555  (declare (single-float n))
556  (let* ((result (#_cosf n)))
557    (%sf-check-exception-1 'cos n (%ffi-exception-status))
558    result))
559
560(defun %double-float-acos! (n result)
561  (declare (double-float n result))
562  (with-stack-double-floats ((temp))
563    (%setf-double-float TEMP (#_acos n))
564    (%df-check-exception-1 'acos n (%ffi-exception-status))
565    (%setf-double-float result TEMP)))
566
567#+(and ppc32-target (not darwinppc-target))
568(defun %single-float-acos! (n result)
569  (declare (single-float n result))
570  (ppc32::with-stack-short-floats ((temp))
571    (%setf-short-float TEMP (#_acosf n))
572    (%sf-check-exception-1 'acos n (%ffi-exception-status))
573    (%setf-short-float result TEMP)))
574
575#+(and ppc32-target darwinppc-target)
576(defun %single-float-acos! (n result)
577  (declare (single-float n result))
578  (with-stack-double-floats ((n2 n)
579                             (result2))
580    (%double-float-acos! n2 result2)
581    (%double-float->short-float result2 result)))
582
583#+64-bit-target
584(defun %single-float-acos (n)
585  (declare (single-float n))
586  (let* ((result (#_acosf n)))
587    (%sf-check-exception-1 'acos n (%ffi-exception-status))
588    result))
589
590(defun %double-float-asin! (n result)
591  (declare (double-float n result))
592  (with-stack-double-floats ((temp))
593    (%setf-double-float TEMP (#_asin n))
594    (%df-check-exception-1 'asin n (%ffi-exception-status))
595    (%setf-double-float result TEMP)))
596
597#+(and ppc32-target (not darwinppc-target))
598(defun %single-float-asin! (n result)
599  (declare (single-float n result))
600  (ppc32::with-stack-short-floats ((temp))
601    (%setf-short-float TEMP (#_asinf n))
602    (%sf-check-exception-1 'asin n (%ffi-exception-status))
603    (%setf-short-float result TEMP)))
604
605#+(and ppc32-target darwinppc-target) 
606(defun %single-float-asin! (n result)
607  (declare (single-float n result))
608  (with-stack-double-floats ((n2 n)
609                             (result2))
610    (%double-float-asin! n2 result2)
611    (%double-float->short-float result2 result)))
612
613#+64-bit-target
614(defun %single-float-asin (n)
615  (declare (single-float n))
616  (let* ((result (#_asinf n)))
617    (%sf-check-exception-1 'asin n (%ffi-exception-status))
618    result))
619
620(defun %double-float-cosh! (n result)
621  (declare (double-float n result))
622  (with-stack-double-floats ((temp))
623    (%setf-double-float TEMP (#_cosh n))
624    (%df-check-exception-1 'cosh n (%ffi-exception-status))
625    (%setf-double-float result TEMP)))
626
627#+(and ppc32-target (not darwinppc-target))
628(defun %single-float-cosh! (n result)
629  (declare (single-float n result))
630  (ppc32::with-stack-short-floats ((temp))
631    (%setf-short-float TEMP (#_coshf n))
632    (%sf-check-exception-1 'cosh n (%ffi-exception-status))
633    (%setf-short-float result TEMP)))
634
635#+(and ppc32-target darwinppc-target)
636(defun %single-float-cosh! (n result)
637  (declare (single-float n result))
638  (with-stack-double-floats ((n2 n)
639                             (result2))
640    (%double-float-cosh! n2 result2)
641    (%double-float->short-float result2 result)))
642
643#+64-bit-target
644(defun %single-float-cosh (n)
645  (declare (single-float n))
646  (let* ((result (#_coshf n)))
647    (%sf-check-exception-1 'cosh n (%ffi-exception-status))
648    result))
649
650
651(defun %double-float-log! (n result)
652  (declare (double-float n result))
653  (with-stack-double-floats ((temp))
654    (%setf-double-float TEMP (#_log n))
655    (%df-check-exception-1 'log n (%ffi-exception-status))
656    (%setf-double-float result TEMP)))
657
658#+ppc32-target
659(progn
660#-darwinppc-target
661(defun %single-float-log! (n result)
662  (declare (single-float n result))
663  (ppc32::with-stack-short-floats ((temp))
664    (%setf-short-float TEMP (#_logf n))
665    (%sf-check-exception-1 'log n (%ffi-exception-status))
666    (%setf-short-float result TEMP)))
667
668#+darwinppc-target
669(defun %single-float-log! (n result)
670  (declare (single-float n result))
671  (with-stack-double-floats ((n2 n)
672                             (result2))
673    (%double-float-log! n2 result2)
674    (%double-float->short-float result2 result)))
675)
676
677#+64-bit-target
678(defun %single-float-log (n)
679  (let* ((result (#_logf n)))
680    (%sf-check-exception-1 'log n (%ffi-exception-status))
681    result))
682
683(defun %double-float-tan! (n result)
684  (declare (double-float n result))
685  (with-stack-double-floats ((temp))
686    (%setf-double-float TEMP (#_tan n))
687    (%df-check-exception-1 'tan n (%ffi-exception-status))
688    (%setf-double-float result TEMP)))
689
690#+(and ppc32-target (not darwinppc-target))
691(defun %single-float-tan! (n result)
692  (declare (single-float n result))
693  (ppc32::with-stack-short-floats ((temp))
694    (%setf-short-float TEMP (#_tanf n))
695    (%sf-check-exception-1 'tan n (%ffi-exception-status))
696    (%setf-short-float result TEMP)))
697
698#+(and ppc32-target darwinppc-target)
699(defun %single-float-tan! (n result)
700  (declare (single-float n result))
701  (with-stack-double-floats ((n2 n)
702                             (result2))
703    (%double-float-tan! n2 result2)
704    (%double-float->short-float result2 result)))
705
706#+64-bit-target
707(defun %single-float-tan (n)
708  (declare (single-float n))
709  (let* ((result (#_tanf n)))
710    (%sf-check-exception-1 'tan n (%ffi-exception-status))
711    result))
712
713(defun %double-float-atan! (n result)
714  (declare (double-float n result))
715  (with-stack-double-floats ((temp))
716    (%setf-double-float TEMP (#_atan n))
717    (%df-check-exception-1 'atan n (%ffi-exception-status))
718    (%setf-double-float result TEMP)))
719
720
721#+(and ppc32-target (not darwinppc-target))
722(defun %single-float-atan! (n result)
723  (declare (single-float n result))
724  (ppc32::with-stack-short-floats ((temp))
725    (%setf-short-float TEMP (#_atanf n))
726    (%sf-check-exception-1 'atan n (%ffi-exception-status))
727    (%setf-short-float result TEMP)))
728
729#+(and ppc32-target darwinppc-target)
730(defun %single-float-atan! (n result)
731  (declare (single-float n result))
732  (with-stack-double-floats ((n2 n)
733                             (result2))
734    (%double-float-atan! n2 result2)
735    (%double-float->short-float result2 result)))
736
737#+64-bit-target
738(defun %single-float-atan (n)
739  (declare (single-float n))
740  (let* ((temp (#_atanf n)))
741    (%sf-check-exception-1 'atan n (%ffi-exception-status))
742    temp))
743
744(defun %double-float-atan2! (x y result)
745  (declare (double-float x y result))
746  (with-stack-double-floats ((temp))
747    (%setf-double-float TEMP (#_atan2 x y))
748    (%df-check-exception-2 'atan2 x y (%ffi-exception-status))
749    (%setf-double-float result TEMP)))
750
751#+(and ppc32-target (not darwinppc-target))
752(defun %single-float-atan2! (x y result)
753  (declare (single-float x y result))
754  (ppc32::with-stack-short-floats ((temp))
755    (%setf-short-float TEMP (#_atan2f x y))
756    (%sf-check-exception-2 'atan2 x y (%ffi-exception-status))
757    (%setf-short-float result TEMP)))
758
759#+(and ppc32-target darwinppc-target)
760(defun %single-float-atan2! (x y result)
761  (declare (single-float x y result))
762  (with-stack-double-floats ((x2 x)
763                             (y2 y)
764                             (result2))
765    (%double-float-atan2! x2 y2 result2)
766    (%double-float->short-float result2 result)))
767
768#+64-bit-target
769(defun %single-float-atan2 (x y)
770  (declare (single-float x y))
771  (let* ((result (#_atan2f x y)))
772    (%sf-check-exception-2 'atan2 x y (%ffi-exception-status))
773    result))
774
775(defun %double-float-exp! (n result)
776  (declare (double-float n result))
777  (with-stack-double-floats ((temp))
778    (%setf-double-float TEMP (#_exp n))
779    (%df-check-exception-1 'exp n (%ffi-exception-status))
780    (%setf-double-float result TEMP)))
781
782#+(and ppc32-target (not darwinppc-target))
783(defun %single-float-exp! (n result)
784  (declare (single-float n result))
785  (ppc32::with-stack-short-floats ((temp))
786    (%setf-short-float TEMP (#_expf n))
787    (%sf-check-exception-1 'exp n (%ffi-exception-status))
788    (%setf-short-float result TEMP)))
789
790#+(and ppc32-target darwinppc-target)
791(defun %single-float-exp! (n result)
792  (declare (single-float n result))
793  (with-stack-double-floats ((n2 n)
794                             (result2))
795    (%double-float-exp! n2 result2)
796    (%double-float->short-float result2 result)))
797
798#+64-bit-target
799(defun %single-float-exp (n)
800  (declare (single-float n))
801  (let* ((result (#_expf n)))
802    (%sf-check-exception-1 'exp n (%ffi-exception-status))
803    result))
804
805(defun %double-float-sinh! (n result)
806  (declare (double-float n result))
807  (with-stack-double-floats ((temp))
808    (%setf-double-float TEMP (#_sinh n))
809    (%df-check-exception-1 'sinh n (%ffi-exception-status))
810    (%setf-double-float result TEMP)))
811
812#+(and ppc32-target (not darwinppc-target))
813(defun %single-float-sinh! (n result)
814  (declare (single-float n result))
815  (ppc32::with-stack-short-floats ((temp))
816    (%setf-short-float TEMP (#_sinhf n))
817    (%sf-check-exception-1 'sinh n (%ffi-exception-status))
818    (%setf-short-float result TEMP)))
819
820#+(and darwinppc-target ppc32-target)
821(defun %single-float-sinh! (n result)
822  (declare (single-float n result))
823  (with-stack-double-floats ((n2 n)
824                             (result2))
825    (%double-float-sinh! n2 result2)
826    (%double-float->short-float result2 result)))
827
828#+64-bit-target
829(defun %single-float-sinh (n)
830  (declare (single-float n))
831  (let* ((result (#_sinhf n)))
832    (%sf-check-exception-1 'sinh n (%ffi-exception-status))
833    result))
834
835
836
837(defun %double-float-tanh! (n result)
838  (declare (double-float n result))
839  (with-stack-double-floats ((temp))
840    (%setf-double-float TEMP (#_tanh n))
841    (%df-check-exception-1 'tanh n (%ffi-exception-status))
842    (%setf-double-float result TEMP)))
843
844
845#+(and ppc32-target (not darwinppc-target))
846(defun %single-float-tanh! (n result)
847  (declare (single-float n result))
848  (ppc32::with-stack-short-floats ((temp))
849    (%setf-short-float TEMP (#_tanhf n))
850    (%sf-check-exception-1 'tanh n (%ffi-exception-status))
851    (%setf-short-float result TEMP)))
852
853#+(and ppc32-target darwinppc-target)
854(defun %single-float-tanh! (n result)
855  (declare (single-float n result))
856  (with-stack-double-floats ((n2 n)
857                             (result2))
858    (%double-float-tanh! n2 result2)
859    (%double-float->short-float result2 result)))
860
861#+64-bit-target
862(defun %single-float-tanh (n)
863  (declare (single-float n))
864  (let* ((result (#_tanhf n)))
865    (%sf-check-exception-1 'tanh n (%ffi-exception-status))
866    result))
867
868(defun %double-float-asinh! (n result)
869  (declare (double-float n result))
870  (with-stack-double-floats ((temp))
871    (%setf-double-float TEMP (#_asinh n))
872    (%df-check-exception-1 'asinh n (%ffi-exception-status))
873    (%setf-double-float result TEMP)))
874
875
876#+(and ppc32-target (not darwinppc-target))
877(defun %single-float-asinh! (n result)
878  (declare (single-float n result))
879  (ppc32::with-stack-short-floats ((temp))
880    (%setf-short-float TEMP (#_asinhf n))
881    (%sf-check-exception-1 'asinh n (%ffi-exception-status))
882    (%setf-short-float result TEMP)))
883
884#+(and ppc32-target darwinppc-target)
885(defun %single-float-asinh! (n result)
886  (declare (single-float n result))
887  (with-stack-double-floats ((n2 n)
888                             (result2))
889    (%double-float-asinh! n2 result2)
890    (%double-float->short-float result2 result)))
891
892#+64-bit-target
893(defun %single-float-asinh (n)
894  (declare (single-float n))
895  (let* ((result (#_asinhf n)))
896    (%sf-check-exception-1 'asinh n (%ffi-exception-status))
897    result))
898
899(defun %double-float-acosh! (n result)
900  (declare (double-float n result))
901  (with-stack-double-floats ((temp))
902    (%setf-double-float TEMP (#_acosh n))
903    (%df-check-exception-1 'acosh n (%ffi-exception-status))
904    (%setf-double-float result TEMP)))
905
906#+(and ppc32-target (not darwinppc-target))
907(defun %single-float-acosh! (n result)
908  (declare (single-float n result))
909  (ppc32::with-stack-short-floats ((temp))
910    (%setf-short-float TEMP (#_acoshf n))
911    (%sf-check-exception-1 'acosh n (%ffi-exception-status))
912    (%setf-short-float result TEMP)))
913
914#+(and ppc32-target darwinppc-target)
915(defun %single-float-acosh! (n result)
916  (declare (single-float n result))
917  (with-stack-double-floats ((n2 n)
918                             (result2))
919    (%double-float-acosh! n2 result2)
920    (%double-float->short-float result2 result)))
921
922#+64-bit-target
923(defun %single-float-acosh (n)
924  (declare (single-float n))
925  (let* ((result (#_acoshf n)))
926    (%sf-check-exception-1 'acosh n (%ffi-exception-status))
927    result))
928
929(defun %double-float-atanh! (n result)
930  (declare (double-float n result))
931  (with-stack-double-floats ((temp))
932    (%setf-double-float TEMP (#_atanh n))
933    (%df-check-exception-1 'atanh n (%ffi-exception-status))
934    (%setf-double-float result TEMP)))
935
936#+(and ppc32-target (not darwinppc-target))
937(defun %single-float-atanh! (n result)
938  (declare (single-float n result)) 
939  (ppc32::with-stack-short-floats ((temp))
940    (%setf-short-float TEMP (#_atanhf n))
941    (%sf-check-exception-1 'atanh n (%ffi-exception-status))
942    (%setf-short-float result TEMP)))
943
944#+(and ppc32-target darwinppc-target)
945(defun %single-float-atanh! (n result)
946  (declare (single-float n result))
947  (with-stack-double-floats ((n2 n)
948                             (result2))
949    (%double-float-atanh! n2 result2)
950    (%double-float->short-float result2 result)))
951
952#+64-bit-target
953(defun %single-float-atanh (n)
954  (declare (single-float n)) 
955  (let* ((result (#_atanhf n)))
956    (%sf-check-exception-1 'atanh n (%ffi-exception-status))
957    result))
958
959
960
961
Note: See TracBrowser for help on using the repository browser.