1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | (in-package "CCL") |
---|
18 | |
---|
19 | (eval-when (:compile-toplevel :execute :load-toplevel) |
---|
20 | |
---|
21 | (defconstant most-positive-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0)) |
---|
22 | (defconstant most-negative-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1)) |
---|
23 | (defconstant most-positive-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0)) |
---|
24 | (defconstant most-negative-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1)) |
---|
25 | |
---|
26 | |
---|
27 | (defconstant least-positive-short-float (make-short-float-from-fixnums 1 0 0)) |
---|
28 | (defconstant least-negative-short-float (make-short-float-from-fixnums 1 0 -1)) |
---|
29 | (defconstant least-positive-single-float (make-short-float-from-fixnums 1 0 0)) |
---|
30 | (defconstant least-negative-single-float (make-short-float-from-fixnums 1 0 -1)) |
---|
31 | |
---|
32 | (defconstant short-float-epsilon (make-short-float-from-fixnums 1 103 0)) |
---|
33 | (defconstant short-float-negative-epsilon (make-short-float-from-fixnums 1 102 0)) |
---|
34 | (defconstant single-float-epsilon (make-short-float-from-fixnums 1 103 0)) |
---|
35 | (defconstant single-float-negative-epsilon (make-short-float-from-fixnums 1 102 0)) |
---|
36 | |
---|
37 | (defconstant least-positive-normalized-short-float (make-short-float-from-fixnums 1 1 0)) |
---|
38 | (defconstant least-negative-normalized-short-float (make-short-float-from-fixnums 1 1 -1)) |
---|
39 | (defconstant least-positive-normalized-single-float (make-short-float-from-fixnums 1 1 0)) |
---|
40 | (defconstant least-negative-normalized-single-float (make-short-float-from-fixnums 1 1 -1)) |
---|
41 | |
---|
42 | (let ((bigfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe 0))) |
---|
43 | ; do it this way if you want to be able to compile before reading floats works |
---|
44 | (defconstant most-positive-double-float bigfloat) |
---|
45 | (defconstant most-positive-long-float bigfloat) |
---|
46 | ) |
---|
47 | |
---|
48 | (let ((littleposfloat (make-float-from-fixnums 0 1 0 0 ))) |
---|
49 | (defconstant least-positive-double-float littleposfloat) |
---|
50 | (defconstant least-positive-long-float littleposfloat) |
---|
51 | ) |
---|
52 | |
---|
53 | (let ((littlenegfloat (make-float-from-fixnums 0 1 0 -1))) |
---|
54 | (defconstant least-negative-double-float littlenegfloat) |
---|
55 | (defconstant least-negative-long-float littlenegfloat) |
---|
56 | ) |
---|
57 | |
---|
58 | (let ((bignegfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe -1))) |
---|
59 | (defconstant most-negative-double-float bignegfloat) |
---|
60 | (defconstant most-negative-long-float bignegfloat) |
---|
61 | ) |
---|
62 | |
---|
63 | (let ((eps (make-float-from-fixnums #x1000000 1 #x3ca 0))) ;was wrong |
---|
64 | (defconstant double-float-epsilon eps) |
---|
65 | (defconstant long-float-epsilon eps) |
---|
66 | ) |
---|
67 | |
---|
68 | (let ((eps- (make-float-from-fixnums #x1000000 1 #x3c9 1))) |
---|
69 | (defconstant double-float-negative-epsilon eps-) |
---|
70 | (defconstant long-float-negative-epsilon eps-) |
---|
71 | ) |
---|
72 | |
---|
73 | (let ((norm (make-float-from-fixnums 0 0 1 0))) |
---|
74 | (defconstant least-positive-normalized-double-float norm) |
---|
75 | (defconstant least-positive-normalized-long-float norm) |
---|
76 | ) |
---|
77 | |
---|
78 | (let ((norm- (make-float-from-fixnums 0 0 1 -1))) |
---|
79 | (defconstant least-negative-normalized-double-float norm-) |
---|
80 | (defconstant least-negative-normalized-long-float norm-) |
---|
81 | ) |
---|
82 | |
---|
83 | (defconstant pi (make-float-from-fixnums #x921fb5 #x4442d18 #x400 0)) |
---|
84 | |
---|
85 | ) |
---|
86 | |
---|
87 | |
---|
88 | |
---|
89 | (defconstant boole-clr 0 |
---|
90 | "Boole function op, makes BOOLE return 0.") |
---|
91 | (defconstant boole-set 1 |
---|
92 | "Boole function op, makes BOOLE return -1.") |
---|
93 | (defconstant boole-1 2 |
---|
94 | "Boole function op, makes BOOLE return integer1.") |
---|
95 | (defconstant boole-2 3 |
---|
96 | "Boole function op, makes BOOLE return integer2.") |
---|
97 | (defconstant boole-c1 4 |
---|
98 | "Boole function op, makes BOOLE return complement of integer1.") |
---|
99 | (defconstant boole-c2 5 |
---|
100 | "Boole function op, makes BOOLE return complement of integer2.") |
---|
101 | (defconstant boole-and 6 |
---|
102 | "Boole function op, makes BOOLE return logand of integer1 and integer2.") |
---|
103 | (defconstant boole-ior 7 |
---|
104 | "Boole function op, makes BOOLE return logior of integer1 and integer2.") |
---|
105 | (defconstant boole-xor 8 |
---|
106 | "Boole function op, makes BOOLE return logxor of integer1 and integer2.") |
---|
107 | (defconstant boole-eqv 9 |
---|
108 | "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") |
---|
109 | (defconstant boole-nand 10 |
---|
110 | "Boole function op, makes BOOLE return log nand of integer1 and integer2.") |
---|
111 | (defconstant boole-nor 11 |
---|
112 | "Boole function op, makes BOOLE return lognor of integer1 and integer2.") |
---|
113 | (defconstant boole-andc1 12 |
---|
114 | "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") |
---|
115 | (defconstant boole-andc2 13 |
---|
116 | "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") |
---|
117 | (defconstant boole-orc1 14 |
---|
118 | "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") |
---|
119 | (defconstant boole-orc2 15 |
---|
120 | "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") |
---|
121 | |
---|
122 | |
---|
123 | |
---|
124 | (defconstant internal-time-units-per-second #+64-bit-target 1000000 #-64-bit-target 1000 |
---|
125 | "The number of internal time units that fit into a second. See |
---|
126 | GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") |
---|
127 | |
---|
128 | (defconstant char-code-limit #.(arch::target-char-code-limit |
---|
129 | (backend-target-arch *target-backend*)) |
---|
130 | "the upper exclusive bound on values produced by CHAR-CODE") |
---|
131 | |
---|
132 | (defconstant array-rank-limit (floor #x8000 target::node-size) |
---|
133 | "the exclusive upper bound on the rank of an array") |
---|
134 | (defconstant multiple-values-limit 200 |
---|
135 | "The exclusive upper bound on the number of multiple VALUES that you can |
---|
136 | return.") |
---|
137 | (defconstant lambda-parameters-limit (floor #x8000 target::node-size) |
---|
138 | "The exclusive upper bound on the number of parameters which may be specifed |
---|
139 | in a given lambda list. This is actually the limit on required and &OPTIONAL |
---|
140 | parameters. With &KEY and &AUX you can get more.") |
---|
141 | (defconstant call-arguments-limit (floor #x8000 target::node-size) |
---|
142 | "The exclusive upper bound on the number of arguments which may be passed |
---|
143 | to a function, including &REST args." |
---|
144 | ) |
---|
145 | |
---|
146 | ; Currently, vectors can be at most (expt 2 22) bytes, and |
---|
147 | ; the largest element (double-float or long-float) is 8 bytes: |
---|
148 | #| to get largest element size... |
---|
149 | (apply #'max (mapcar #'(lambda (type) |
---|
150 | (%vect-byte-size (make-array 1 :element-type type))) |
---|
151 | *cl-types*)) |
---|
152 | |# |
---|
153 | |
---|
154 | (defconstant array-dimension-limit array-total-size-limit |
---|
155 | "the exclusive upper bound on any given dimension of an array") |
---|
156 | |
---|
157 | (defconstant most-positive-fixnum target::target-most-positive-fixnum |
---|
158 | "the fixnum closest in value to positive infinity") |
---|
159 | (defconstant most-negative-fixnum target::target-most-negative-fixnum |
---|
160 | "the fixnum closest in value to negative infinity") |
---|
161 | |
---|
162 | |
---|
163 | (defconstant lambda-list-keywords |
---|
164 | '(&OPTIONAL &REST &AUX &KEY &ALLOW-OTHER-KEYS &BODY &ENVIRONMENT &WHOLE) |
---|
165 | "symbols which are magical in a lambda list") |
---|
166 | |
---|
167 | |
---|
168 | (defparameter %toplevel-catch% ':toplevel) |
---|
169 | |
---|
170 | (defvar *read-default-float-format* 'single-float) |
---|
171 | |
---|
172 | (defvar *read-suppress* nil |
---|
173 | "Suppress most interpreting in the reader when T.") |
---|
174 | |
---|
175 | (defvar *read-base* 10. |
---|
176 | "the radix that Lisp reads numbers in") |
---|
177 | |
---|
178 | |
---|
179 | (defparameter *warn-if-redefine-kernel* nil |
---|
180 | "When true, attempts to redefine (via DEFUN or DEFMETHOD) functions and |
---|
181 | methods that are marked as being predefined signal continuable errors.") |
---|
182 | |
---|
183 | (defvar *next-screen-context-lines* 2 "Number of lines to show of old screen |
---|
184 | after a scroll-up or scroll-down.") |
---|
185 | |
---|
186 | (defparameter *compiling-file* nil |
---|
187 | "Name of outermost file being compiled or NIL if not compiling a file.") |
---|
188 | |
---|
189 | (defvar *eval-fn-name* nil) |
---|
190 | |
---|
191 | |
---|
192 | (defvar *compile-definitions* t |
---|
193 | "When non-NIL and the evaluator's lexical environment contains no |
---|
194 | lexical entities, causes FUNCTION and NFUNCTION forms to be compiled.") |
---|
195 | #| |
---|
196 | (defvar *fast-eval* () |
---|
197 | "If non-nil, compile-and-call any forms which would be expensive to evaluate.") |
---|
198 | |# |
---|
199 | (defvar *declaration-handlers* ()) |
---|
200 | |
---|
201 | |
---|
202 | (defvar *lisp-system-pointer-functions* nil) |
---|
203 | (defvar *lisp-user-pointer-functions* nil) |
---|
204 | (defvar *lisp-cleanup-functions* nil) ; list of (0-arg) functions to call before quitting Lisp |
---|
205 | (defvar *lisp-startup-functions* nil) ; list of funs to call after startup. |
---|
206 | (defvar %lisp-system-fixups% nil) |
---|
207 | |
---|
208 | |
---|
209 | (setf (*%saved-method-var%*) nil) |
---|
210 | |
---|
211 | ; The GC expects these to be NIL or a function of no args |
---|
212 | (defvar *pre-gc-hook* nil) |
---|
213 | (defvar *post-gc-hook* nil) |
---|
214 | |
---|
215 | ; These are used by add-gc-hook, delete-gc-hook |
---|
216 | (defvar *pre-gc-hook-list* nil) |
---|
217 | (defvar *post-gc-hook-list* nil) |
---|
218 | |
---|
219 | (defvar *backtrace-dialogs* nil) |
---|
220 | ;(defvar *stepper-running* nil) |
---|
221 | (defparameter *last-mouse-down-time* 0) |
---|
222 | (defparameter *last-mouse-down-position* 0) |
---|
223 | |
---|
224 | (defvar %handlers% ()) |
---|
225 | |
---|
226 | |
---|
227 | #| |
---|
228 | (defvar %restarts% (list (list (%cons-restart 'abort |
---|
229 | #'(lambda (&rest ignore) |
---|
230 | (declare (ignore ignore)) |
---|
231 | (throw :toplevel nil)) |
---|
232 | "Restart the toplevel loop." |
---|
233 | nil |
---|
234 | nil)))) |
---|
235 | |# |
---|
236 | |
---|
237 | (defvar %restarts% nil) |
---|
238 | |
---|
239 | (defvar ccl::*kernel-restarts* nil) |
---|
240 | (defvar *condition-restarts* nil "explicit mapping between c & r") |
---|
241 | (declaim (type list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*)) |
---|
242 | |
---|
243 | |
---|
244 | |
---|
245 | |
---|
246 | (defparameter *%periodic-tasks%* nil) |
---|
247 | (defparameter *dribble-stream* nil) |
---|
248 | |
---|
249 | (defconstant *keyword-package* *keyword-package*) |
---|
250 | (defconstant *common-lisp-package* *common-lisp-package*) |
---|
251 | (defconstant *ccl-package* *ccl-package*) |
---|
252 | |
---|
253 | (defparameter *load-print* nil "the default for the :PRINT argument to LOAD") |
---|
254 | (defparameter *loading-files* nil) |
---|
255 | (defparameter *break-level* 0) |
---|
256 | (defparameter *last-break-level* 0) |
---|
257 | (defvar *record-source-file* nil) ; set in l1-utils. |
---|
258 | (defvar *warn-if-redefine* nil) ; set in l1-utils. |
---|
259 | (defparameter *level-1-loaded* nil) ; set t by l1-boot |
---|
260 | (defparameter *save-definitions* nil) |
---|
261 | (defparameter *save-local-symbols* t) |
---|
262 | |
---|
263 | (defvar *modules* nil |
---|
264 | "This is a list of module names that have been loaded into Lisp so far. |
---|
265 | The names are case sensitive strings. It is used by PROVIDE and REQUIRE.") |
---|
266 | |
---|
267 | |
---|
268 | |
---|
269 | |
---|
270 | |
---|
271 | (defparameter *eof-value* (cons nil nil)) |
---|
272 | |
---|
273 | (defvar *gc-event-status-bits*) ; also initialized by kernel |
---|
274 | |
---|
275 | (defparameter *top-listener* nil) |
---|
276 | |
---|
277 | |
---|
278 | |
---|
279 | |
---|
280 | |
---|
281 | |
---|
282 | |
---|
283 | (defvar *listener-indent* nil) |
---|
284 | |
---|
285 | (defparameter *autoload-lisp-package* nil) ; Make 'em suffer |
---|
286 | (defparameter *apropos-case-sensitive-p* nil) |
---|
287 | |
---|
288 | (defloadvar *total-gc-microseconds* (let* ((timeval-size |
---|
289 | #.(%foreign-type-or-record-size |
---|
290 | :timeval :bytes)) |
---|
291 | (p (malloc (* 5 timeval-size)))) |
---|
292 | (#_bzero p (* 5 timeval-size)) |
---|
293 | p)) |
---|
294 | |
---|
295 | |
---|
296 | (defloadvar *total-bytes-freed* (let* ((p (malloc 8))) |
---|
297 | (setf (%get-long p 0) 0 |
---|
298 | (%get-long p 4) 0) |
---|
299 | p)) |
---|
300 | |
---|
301 | |
---|
302 | |
---|
303 | (defvar *terminal-character-encoding-name* nil |
---|
304 | "NIL (implying :ISO-8859-1), or a keyword which names a defined |
---|
305 | character encoding to be used for *TERMINAL-IO* and other predefined |
---|
306 | initial streams. The value of *TERMINAL-CHARACTER-ENCODING-NAME* |
---|
307 | persists across calls to SAVE-APPLICATION; it can be specified via |
---|
308 | the command-line argument --terminal-encoding (-K)") |
---|
309 | |
---|
310 | |
---|
311 | (defconstant +null-ptr+ (%null-ptr)) |
---|
312 | |
---|
313 | ;;; end of L1-init.lisp |
---|
314 | |
---|