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

Last change on this file since 13067 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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