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

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

On Windows, use quasi-documented function RtlGenRandom? to initialize
random state object when calling (make-random-state t).

http://msdn.microsoft.com/en-us/library/aa387694(VS.85).aspx
http://blogs.msdn.com/michael_howard/archive/2005/01/14/353379.aspx

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