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