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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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