source: trunk/source/lib/number-macros.lisp @ 14423

Last change on this file since 14423 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: 3.9 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 "LISPEQU")
22  )
23
24(declare-arch-specific-macro %make-sfloat)
25
26(declare-arch-specific-macro %make-dfloat)
27
28(defmacro require-null-or-double-float-sym (sym)
29  (setq sym (require-type sym 'symbol))
30  `(when (and ,sym (not (double-float-p ,sym)))
31     (setq ,sym (require-type ,sym 'double-float))))
32
33
34(declare-arch-specific-macro %numerator)
35
36(declare-arch-specific-macro %denominator)
37
38(declare-arch-specific-macro %realpart)
39
40(declare-arch-specific-macro %imagpart)
41
42
43(defmacro with-stack-double-floats (specs &body body)
44  (collect ((binds)
45            (inits)
46            (names))
47    (dolist (spec specs)
48      (let ((name (first spec)))
49        (binds `(,name (%make-dfloat)))
50        (names name)
51        (let ((init (second spec)))
52          (when init
53            (inits `(%double-float ,init ,name))))))
54    `(let* ,(binds)
55      (declare (dynamic-extent ,@(names))
56               (double-float ,@(names)))
57      ,@(inits)
58      ,@body)))
59
60
61
62
63
64
65 ;;; WITH-BIGNUM-BUFFERS  --  Internal.
66  ;;;
67  ;;; Could do freelisting someday. NAH
68  ;;;
69(defmacro with-bignum-buffers (specs &body body)  ; <<
70  "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*"
71  (collect ((binds)
72            (inits)
73            (names))
74    (dolist (spec specs)
75      (let ((name (first spec))
76            (size (second spec)))
77        (binds `(,name (allocate-typed-vector :bignum ,size)))
78        (names name)         
79        (let ((init (third spec)))
80          (when init
81            (inits `(bignum-replace ,name ,init))))))
82    `(let* ,(binds)
83       (declare (dynamic-extent ,@(names)))
84       ,@(inits)
85       ,@body)))
86
87;;; call fn on possibly stack allocated negative of a and/or b
88;;; args better be vars - we dont bother with once-only
89(defmacro with-negated-bignum-buffers (a b fn)
90  `(let* ((len-a (%bignum-length ,a))
91          (len-b (%bignum-length ,b))
92          (a-plusp (bignum-plusp ,a))
93          (b-plusp (bignum-plusp ,b)))
94     (declare (type bignum-index len-a len-b))
95     (if (and a-plusp b-plusp)
96       (,fn ,a ,b )
97       (if (not a-plusp)
98         (with-bignum-buffers ((a1 (1+ len-a)))
99           (negate-bignum ,a nil a1)
100           (if b-plusp
101             (,fn a1 ,b)
102             (with-bignum-buffers ((b1 (1+ len-b)))
103               (negate-bignum ,b nil b1)
104               (,fn a1 b1))))
105         (with-bignum-buffers ((b1 (1+ len-b)))
106           (negate-bignum ,b nil b1)
107           (,fn ,a b1))))))
108
109(defmacro with-one-negated-bignum-buffer (a fn)
110  `(if (bignum-plusp ,a)
111    (,fn ,a)
112    (with-bignum-buffers ((a1 (1+ (%bignum-length ,a))))
113      (negate-bignum ,a nil a1)
114      (,fn a1))))
115
116
117(defmacro fixnum-to-bignum-set (big fix)
118  `(%fixnum-to-bignum-set ,big ,fix))
119
120(defmacro with-small-bignum-buffers (specs &body body)
121  (collect ((binds)
122            (inits)
123            (names))
124    (dolist (spec specs)
125      (let ((name (first spec)))
126        (binds `(,name (allocate-typed-vector :bignum
127                        ,(target-word-size-case (32 1)
128                                                (64 2)))))
129                       
130        (names name)
131        (let ((init (second spec)))
132          (when init
133            (inits `(fixnum-to-bignum-set ,name ,init))))))
134    `(let* ,(binds)
135      (declare (dynamic-extent ,@(names)))
136      ,@(inits)
137      ,@body)))
138
139(provide "NUMBER-MACROS")
140
141;;; end of number-macros.lisp
Note: See TracBrowser for help on using the repository browser.