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 | |
---|
18 | ;; sysutils.lisp - things which have outgrown l1-utils |
---|
19 | |
---|
20 | (in-package "CCL") |
---|
21 | |
---|
22 | (eval-when (:execute :compile-toplevel) |
---|
23 | (require 'level-2) |
---|
24 | (require 'optimizers) |
---|
25 | (require 'backquote) |
---|
26 | (require 'defstruct-macros) |
---|
27 | ) |
---|
28 | |
---|
29 | ;;; things might be clearer if this stuff were in l1-typesys? |
---|
30 | ;;; Translation from type keywords to specific predicates. |
---|
31 | (eval-when (:execute :compile-toplevel) |
---|
32 | |
---|
33 | (defconstant type-pred-pairs |
---|
34 | '((array . arrayp) |
---|
35 | (atom . atom) |
---|
36 | (base-string . base-string-p) |
---|
37 | (bignum . bignump) |
---|
38 | (bit . bitp) |
---|
39 | (bit-vector . bit-vector-p) |
---|
40 | (character . characterp) |
---|
41 | (compiled-function . compiled-function-p) |
---|
42 | (complex . complexp) |
---|
43 | (cons . consp) |
---|
44 | (double-float . double-float-p) |
---|
45 | (fixnum . fixnump) ;not cl |
---|
46 | (float . floatp) |
---|
47 | (function . functionp) |
---|
48 | (hash-table . hash-table-p) |
---|
49 | (integer . integerp) |
---|
50 | (real . realp) |
---|
51 | (keyword . keywordp) |
---|
52 | (list . listp) |
---|
53 | (long-float . double-float-p) |
---|
54 | (nil . false) |
---|
55 | (null . null) |
---|
56 | (number . numberp) |
---|
57 | (package . packagep) |
---|
58 | (pathname . pathnamep) |
---|
59 | (logical-pathname . logical-pathname-p) |
---|
60 | (random-state . random-state-p) |
---|
61 | (ratio . ratiop) |
---|
62 | (rational . rationalp) |
---|
63 | (readtable . readtablep) |
---|
64 | (sequence . sequencep) |
---|
65 | (short-float . short-float-p) |
---|
66 | (signed-byte . integerp) |
---|
67 | (simple-array . simple-array-p) |
---|
68 | (simple-base-string . simple-base-string-p) |
---|
69 | (simple-extended-string . simple-extended-string-p) |
---|
70 | (simple-bit-vector . simple-bit-vector-p) |
---|
71 | (simple-string . simple-string-p) |
---|
72 | (simple-vector . simple-vector-p) |
---|
73 | (single-float . short-float-p) |
---|
74 | (stream . streamp) |
---|
75 | (string . stringp) |
---|
76 | (extended-string . extended-string-p) |
---|
77 | (base-char . base-char-p) |
---|
78 | (extended-char . extended-char-p) |
---|
79 | (structure-object . structurep) |
---|
80 | (symbol . symbolp) |
---|
81 | (t . true) |
---|
82 | (unsigned-byte . unsigned-byte-p) |
---|
83 | (vector . vectorp) |
---|
84 | )) |
---|
85 | |
---|
86 | (defmacro init-type-predicates () |
---|
87 | `(dolist (pair ',type-pred-pairs) |
---|
88 | (setf (type-predicate (car pair)) (cdr pair)) |
---|
89 | (let ((ctype (info-type-builtin (car pair)))) |
---|
90 | (if (typep ctype 'numeric-ctype) |
---|
91 | (setf (numeric-ctype-predicate ctype) (cdr pair)))))) |
---|
92 | |
---|
93 | ) |
---|
94 | |
---|
95 | (init-type-predicates) |
---|
96 | |
---|
97 | (defun unsigned-byte-8-p (n) |
---|
98 | (and (fixnump n) |
---|
99 | (locally (declare (fixnum n)) |
---|
100 | (and |
---|
101 | (>= n 0) |
---|
102 | (< n #x100))))) |
---|
103 | |
---|
104 | (defun signed-byte-8-p (n) |
---|
105 | (and (fixnump n) |
---|
106 | (locally (declare (fixnum n)) |
---|
107 | (and |
---|
108 | (>= n -128) |
---|
109 | (<= n 127))))) |
---|
110 | |
---|
111 | (defun unsigned-byte-16-p (n) |
---|
112 | (and (fixnump n) |
---|
113 | (locally (declare (fixnum n)) |
---|
114 | (and |
---|
115 | (>= n 0) |
---|
116 | (< n #x10000))))) |
---|
117 | |
---|
118 | (defun signed-byte-16-p (n) |
---|
119 | (and (fixnump n) |
---|
120 | (locally (declare (fixnum n)) |
---|
121 | (and |
---|
122 | (>= n -32768) |
---|
123 | (<= n 32767))))) |
---|
124 | |
---|
125 | (defun unsigned-byte-32-p (n) |
---|
126 | (and (integerp n) |
---|
127 | (>= n 0) |
---|
128 | (<= n #xffffffff))) |
---|
129 | |
---|
130 | (defun signed-byte-32-p (n) |
---|
131 | (and (integerp n) |
---|
132 | (>= n -2147483648) |
---|
133 | (<= n 2147483647))) |
---|
134 | |
---|
135 | (eval-when (:load-toplevel :execute) |
---|
136 | (let ((more-pairs |
---|
137 | '(((unsigned-byte 8) . unsigned-byte-8-p) |
---|
138 | ((signed-byte 8) . signed-byte-8-p) |
---|
139 | ((unsigned-byte 16) . unsigned-byte-16-p) |
---|
140 | ((signed-byte 16) . signed-byte-16-p) |
---|
141 | ((unsigned-byte 32) . unsigned-byte-32-p) |
---|
142 | ((signed-byte 32) . signed-byte-32-p)))) |
---|
143 | (dolist (pair more-pairs) |
---|
144 | (let ((ctype (info-type-builtin (car pair)))) |
---|
145 | (if (typep ctype 'numeric-ctype) (setf (numeric-ctype-predicate ctype) (cdr pair)))))) |
---|
146 | ) |
---|
147 | |
---|
148 | |
---|
149 | (defun specifier-type-known (type) |
---|
150 | (let ((ctype (specifier-type type))) |
---|
151 | (if (typep ctype 'unknown-ctype) |
---|
152 | (error "Unknown type specifier ~s." type) |
---|
153 | (if (and (typep ctype 'numeric-ctype) ; complexp?? |
---|
154 | (eq 'integer (numeric-ctype-class ctype)) |
---|
155 | (not (numeric-ctype-predicate ctype))) |
---|
156 | (setf (numeric-ctype-predicate ctype)(make-numeric-ctype-predicate ctype)))) |
---|
157 | ctype)) |
---|
158 | |
---|
159 | |
---|
160 | (defun find-builtin-cell (type &optional (create t)) |
---|
161 | (let ((cell (gethash type %builtin-type-cells%))) |
---|
162 | (or cell |
---|
163 | (when create |
---|
164 | (setf (gethash type %builtin-type-cells%) |
---|
165 | (cons type (or (info-type-builtin type)(specifier-type-known type)))))))) |
---|
166 | |
---|
167 | |
---|
168 | ; for now only called for builtin types or car = unsigned-byte, signed-byte, mod or integer |
---|
169 | |
---|
170 | (defun builtin-typep (form cell) |
---|
171 | (unless (listp cell) |
---|
172 | (setq cell (require-type cell 'list))) |
---|
173 | (locally (declare (type list cell)) |
---|
174 | (let ((ctype (cdr cell)) |
---|
175 | (name (car cell))) |
---|
176 | (when (not ctype) |
---|
177 | (setq ctype (or (info-type-builtin name)(specifier-type-known name))) |
---|
178 | (when ctype (setf (gethash (car cell) %builtin-type-cells%) cell)) |
---|
179 | (rplacd cell ctype)) |
---|
180 | (if ctype |
---|
181 | (if (and (typep ctype 'numeric-ctype) |
---|
182 | (numeric-ctype-predicate ctype)) |
---|
183 | ; doing this inline is a winner - at least if true |
---|
184 | (funcall (numeric-ctype-predicate ctype) form) |
---|
185 | (%%typep form ctype)) |
---|
186 | (typep form name))))) |
---|
187 | |
---|
188 | #| |
---|
189 | (defvar %find-classes% (make-hash-table :test 'eq)) |
---|
190 | |
---|
191 | (defun find-class-cell (name create?) |
---|
192 | (let ((cell (gethash name %find-classes%))) |
---|
193 | (or cell |
---|
194 | (and create? |
---|
195 | (setf (gethash name %find-classes%) (cons name nil)))))) |
---|
196 | |# |
---|
197 | |
---|
198 | ;(setq *type-system-initialized* t) |
---|
199 | |
---|
200 | |
---|
201 | ;; Type-of, typep, and a bunch of other predicates. |
---|
202 | |
---|
203 | ;;; Data type predicates. |
---|
204 | |
---|
205 | ;;; things might be clearer if this stuff were in l1-typesys? |
---|
206 | ;;; Translation from type keywords to specific predicates. |
---|
207 | |
---|
208 | |
---|
209 | |
---|
210 | |
---|
211 | ;necessary since standard-char-p, by definition, errors if not passed a char. |
---|
212 | (setf (type-predicate 'standard-char) |
---|
213 | #'(lambda (form) (and (characterp form) (standard-char-p form)))) |
---|
214 | |
---|
215 | (defun type-of (form) |
---|
216 | "Return the type of OBJECT." |
---|
217 | (case form |
---|
218 | ((t) 'boolean) |
---|
219 | ((0 1) 'bit) |
---|
220 | (t |
---|
221 | (typecase form |
---|
222 | (standard-char 'standard-char) |
---|
223 | (keyword 'keyword) |
---|
224 | ;; Partition integers so that the negative cases |
---|
225 | ;; are SIGNED-BYTE and the positive are UNSIGNED-BYTE |
---|
226 | (fixnum |
---|
227 | (if (< (the fixnum form) 0) |
---|
228 | 'fixnum |
---|
229 | '(integer 0 #.target::target-most-positive-fixnum))) |
---|
230 | (bignum |
---|
231 | (if (< form 0) |
---|
232 | 'bignum |
---|
233 | '(integer #.(1+ target::target-most-positive-fixnum)))) |
---|
234 | ((or array complex) (type-specifier (ctype-of form))) |
---|
235 | (single-float 'single-float) |
---|
236 | (double-float 'double-float) |
---|
237 | (t |
---|
238 | (if (eql (typecode form) target::subtag-istruct) |
---|
239 | (istruct-type-name form) |
---|
240 | (let* ((class (class-of form))) |
---|
241 | (or (%class-proper-name class) |
---|
242 | class)))))))) |
---|
243 | |
---|
244 | ;;; Create the list-style description of an array. |
---|
245 | |
---|
246 | ;made more specific by fry. slisp used (mod 2) , etc. |
---|
247 | ;Oh. |
---|
248 | ; As much fun as this has been, I think it'd be really neat if |
---|
249 | ; it returned a type specifier. |
---|
250 | |
---|
251 | (defun describe-array (array) |
---|
252 | (if (arrayp array) |
---|
253 | (type-specifier |
---|
254 | (specifier-type |
---|
255 | `(,(if (simple-array-p array) 'simple-array 'array) |
---|
256 | ,(array-element-type array) |
---|
257 | ,(array-dimensions array)))) |
---|
258 | (report-bad-arg array 'array))) |
---|
259 | |
---|
260 | |
---|
261 | ;;;; TYPEP and auxiliary functions. |
---|
262 | |
---|
263 | |
---|
264 | |
---|
265 | (defun type-specifier-p (form &aux sym) |
---|
266 | (cond ((symbolp form) |
---|
267 | (or (type-predicate form) |
---|
268 | (structure-class-p form) |
---|
269 | (%deftype-expander form) |
---|
270 | (find-class form nil) |
---|
271 | )) |
---|
272 | ((consp form) |
---|
273 | (setq sym (%car form)) |
---|
274 | (or (type-specifier-p sym) |
---|
275 | (memq sym '(member satisfies mod)) |
---|
276 | (and (memq sym '(and or not)) |
---|
277 | (dolist (spec (%cdr form) t) |
---|
278 | (unless (type-specifier-p spec) (return nil)))))) |
---|
279 | (t (typep form 'class)))) |
---|
280 | |
---|
281 | (defun built-in-type-p (type) |
---|
282 | (if (symbolp type) |
---|
283 | (or (type-predicate type) |
---|
284 | (let ((class (find-class type nil))) |
---|
285 | (and class (typep class 'built-in-class)))) |
---|
286 | (and (consp type) |
---|
287 | (or (and (memq (%car type) '(and or not)) |
---|
288 | (every #'built-in-type-p (%cdr type))) |
---|
289 | (memq (%car type) '(array simple-array vector simple-vector |
---|
290 | string simple-string bit-vector simple-bit-vector |
---|
291 | complex integer mod signed-byte unsigned-byte |
---|
292 | rational float short-float single-float |
---|
293 | double-float long-float real member)))))) |
---|
294 | |
---|
295 | (defun typep (object type &optional env) |
---|
296 | "Is OBJECT of type TYPE?" |
---|
297 | (let* ((pred (if (symbolp type) (type-predicate type)))) |
---|
298 | (if pred |
---|
299 | (funcall pred object) |
---|
300 | (values (%typep object (if env (specifier-type type env) type)))))) |
---|
301 | |
---|
302 | |
---|
303 | |
---|
304 | ;;; This is like check-type, except it returns the value rather than setf'ing |
---|
305 | ;;; anything, and so can be done entirely out-of-line. |
---|
306 | (defun require-type (arg type) |
---|
307 | (multiple-value-bind (win sure) |
---|
308 | (ctypep arg (specifier-type type)) |
---|
309 | (if (or win (not sure)) |
---|
310 | arg |
---|
311 | (%kernel-restart $xwrongtype arg type)))) |
---|
312 | |
---|
313 | ;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named) |
---|
314 | (defun %require-type (arg predsym) |
---|
315 | (if (funcall predsym arg) |
---|
316 | arg |
---|
317 | (%kernel-restart $xwrongtype arg (type-for-predicate predsym)))) |
---|
318 | |
---|
319 | (defun %require-type-builtin (arg type-cell) |
---|
320 | (if (builtin-typep arg type-cell) |
---|
321 | arg |
---|
322 | (%kernel-restart $xwrongtype arg (car type-cell)))) |
---|
323 | |
---|
324 | |
---|
325 | |
---|
326 | ;;; In lieu of an inverted mapping, at least try to find cases involving |
---|
327 | ;;; builtin numeric types and predicates associated with them. |
---|
328 | (defun type-for-predicate (pred) |
---|
329 | (or (block find |
---|
330 | (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype) |
---|
331 | (eq (numeric-ctype-predicate ctype) |
---|
332 | pred)) |
---|
333 | (return-from find type))) |
---|
334 | *builtin-type-info*)) |
---|
335 | `(satisfies ,pred))) |
---|
336 | |
---|
337 | |
---|
338 | |
---|
339 | ; Subtypep. |
---|
340 | |
---|
341 | (defun subtypep (type1 type2 &optional env) |
---|
342 | "Return two values indicating the relationship between type1 and type2. |
---|
343 | If values are T and T, type1 definitely is a subtype of type2. |
---|
344 | If values are NIL and T, type1 definitely is not a subtype of type2. |
---|
345 | If values are NIL and NIL, it couldn't be determined." |
---|
346 | (csubtypep (specifier-type type1 env) (specifier-type type2 env))) |
---|
347 | |
---|
348 | |
---|
349 | |
---|
350 | |
---|
351 | (defun preload-all-functions () |
---|
352 | nil) |
---|
353 | |
---|
354 | |
---|
355 | ; used by arglist |
---|
356 | (defun temp-cons (a b) |
---|
357 | (cons a b)) |
---|
358 | |
---|
359 | |
---|
360 | |
---|
361 | |
---|
362 | (defun copy-into-float (src dest) |
---|
363 | (%copy-double-float src dest)) |
---|
364 | |
---|
365 | (queue-fixup |
---|
366 | (defun fmakunbound (name) |
---|
367 | "Make NAME have no global function definition." |
---|
368 | (let* ((fname (validate-function-name name))) |
---|
369 | (remhash fname %structure-refs%) |
---|
370 | (%unfhave fname)) |
---|
371 | name)) |
---|
372 | |
---|
373 | (defun frozen-definition-p (name) |
---|
374 | (if (symbolp name) |
---|
375 | (%ilogbitp $sym_fbit_frozen (%symbol-bits name)))) |
---|
376 | |
---|
377 | (defun redefine-kernel-function (name) |
---|
378 | (when (and *warn-if-redefine-kernel* |
---|
379 | (frozen-definition-p name) |
---|
380 | (or (lfunp (fboundp name)) |
---|
381 | (and (not (consp name)) (macro-function name))) |
---|
382 | (or (and (consp name) (neq (car name) 'setf)) |
---|
383 | (let ((pkg (symbol-package (if (consp name) (cadr name) name)))) |
---|
384 | (or (eq *common-lisp-package* pkg) (eq *ccl-package* pkg))))) |
---|
385 | (cerror "Replace the definition of ~S." |
---|
386 | "The function ~S is predefined in Clozure CL." name) |
---|
387 | (unless (consp name) |
---|
388 | (proclaim-inline nil name)))) |
---|
389 | |
---|
390 | (defun fset (name function) |
---|
391 | (setq function (require-type function 'function)) |
---|
392 | (when (symbolp name) |
---|
393 | (when (special-operator-p name) |
---|
394 | (error "Can not redefine a special-form: ~S ." name)) |
---|
395 | (when (macro-function name) |
---|
396 | (cerror "Redefine the macro ~S as a function" |
---|
397 | "The macro ~S is being redefined as a function." name))) |
---|
398 | ; This lets us redefine %FHAVE. Big fun. |
---|
399 | (let ((fhave #'%fhave)) |
---|
400 | (redefine-kernel-function name) |
---|
401 | (fmakunbound name) |
---|
402 | (funcall fhave name function) |
---|
403 | function)) |
---|
404 | |
---|
405 | (defsetf symbol-function fset) |
---|
406 | (defsetf fdefinition fset) |
---|
407 | |
---|
408 | (defun (setf macro-function) (macro-fun name &optional env) |
---|
409 | (declare (ignore env)) |
---|
410 | (unless (typep macro-fun 'function) |
---|
411 | (report-bad-arg macro-fun 'function)) |
---|
412 | (if (special-operator-p name) |
---|
413 | (error "Can not redefine a special-form: ~S ." name)) |
---|
414 | (when (and (fboundp name) (not (macro-function name))) |
---|
415 | (warn "The function ~S is being redefined as a macro." name)) |
---|
416 | (redefine-kernel-function name) |
---|
417 | (fmakunbound name) |
---|
418 | (%macro-have name macro-fun) |
---|
419 | macro-fun) |
---|
420 | |
---|
421 | (defun set-macro-function (name def) |
---|
422 | (setf (macro-function name) def)) |
---|
423 | |
---|
424 | |
---|
425 | |
---|
426 | |
---|
427 | ;;; Arrays and vectors, including make-array. |
---|
428 | |
---|
429 | |
---|
430 | |
---|
431 | |
---|
432 | |
---|
433 | |
---|
434 | |
---|
435 | (defun char (string index) |
---|
436 | "Given a string and a non-negative integer index less than the length of |
---|
437 | the string, returns the character object representing the character at |
---|
438 | that position in the string." |
---|
439 | (if (typep string 'simple-string) |
---|
440 | (schar (the simple-string string) index) |
---|
441 | (if (stringp string) |
---|
442 | (multiple-value-bind (data offset) (array-data-and-offset string) |
---|
443 | (schar (the simple-string data) (+ index offset))) |
---|
444 | (report-bad-arg string 'string)))) |
---|
445 | |
---|
446 | (defun set-char (string index new-el) |
---|
447 | (if (typep string 'simple-string) |
---|
448 | (setf (schar string index) new-el) |
---|
449 | (if (stringp string) |
---|
450 | (multiple-value-bind (data offset) (array-data-and-offset string) |
---|
451 | (setf (schar (the simple-string data) (+ index offset)) new-el)) |
---|
452 | (report-bad-arg string 'string)))) |
---|
453 | |
---|
454 | (defun equalp (x y) |
---|
455 | "Just like EQUAL, but more liberal in several respects. |
---|
456 | Numbers may be of different types, as long as the values are identical |
---|
457 | after coercion. Characters may differ in alphabetic case. Vectors and |
---|
458 | arrays must have identical dimensions and EQUALP elements, but may differ |
---|
459 | in their type restriction. |
---|
460 | If one of x or y is a pathname and one is a string with the name of the |
---|
461 | pathname then this will return T." |
---|
462 | (cond ((eql x y) t) |
---|
463 | ((characterp x) (and (characterp y) (eq (char-upcase x) (char-upcase y)))) |
---|
464 | ((numberp x) (and (numberp y) (= x y))) |
---|
465 | ((consp x) |
---|
466 | (and (consp y) |
---|
467 | (equalp (car x) (car y)) |
---|
468 | (equalp (cdr x) (cdr y)))) |
---|
469 | ((pathnamep x) (equal x y)) |
---|
470 | ((vectorp x) |
---|
471 | (and (vectorp y) |
---|
472 | (let ((length (length x))) |
---|
473 | (when (eq length (length y)) |
---|
474 | (dotimes (i length t) |
---|
475 | (declare (fixnum i)) |
---|
476 | (let ((x-el (aref x i)) |
---|
477 | (y-el (aref y i))) |
---|
478 | (unless (or (eq x-el y-el) (equalp x-el y-el)) |
---|
479 | (return nil)))))))) |
---|
480 | ((arrayp x) |
---|
481 | (and (arrayp y) |
---|
482 | (let ((rank (array-rank x)) x-el y-el) |
---|
483 | (and (eq (array-rank y) rank) |
---|
484 | (if (%izerop rank) (equalp (aref x) (aref y)) |
---|
485 | (and |
---|
486 | (dotimes (i rank t) |
---|
487 | (declare (fixnum i)) |
---|
488 | (unless (eq (array-dimension x i) |
---|
489 | (array-dimension y i)) |
---|
490 | (return nil))) |
---|
491 | (multiple-value-bind (x0 i) (array-data-and-offset x) |
---|
492 | (multiple-value-bind (y0 j) (array-data-and-offset y) |
---|
493 | (dotimes (count (array-total-size x) t) |
---|
494 | (declare (fixnum count)) |
---|
495 | (setq x-el (uvref x0 i) y-el (uvref y0 j)) |
---|
496 | (unless (or (eq x-el y-el) (equalp x-el y-el)) |
---|
497 | (return nil)) |
---|
498 | (setq i (%i+ i 1) j (%i+ j 1))))))))))) |
---|
499 | ((and (structurep x) (structurep y)) |
---|
500 | (let ((size (uvsize x))) |
---|
501 | (and (eq size (uvsize y)) |
---|
502 | (dotimes (i size t) |
---|
503 | (declare (fixnum i)) |
---|
504 | (unless (equalp (uvref x i) (uvref y i)) |
---|
505 | (return nil)))))) |
---|
506 | ((and (hash-table-p x) (hash-table-p y)) |
---|
507 | (%hash-table-equalp x y)) |
---|
508 | (t nil))) |
---|
509 | |
---|
510 | |
---|
511 | ; The compiler (or some transforms) might want to do something more interesting |
---|
512 | ; with these, but they have to exist as functions anyhow. |
---|
513 | |
---|
514 | |
---|
515 | |
---|
516 | (defun complement (function) |
---|
517 | "Return a new function that returns T whenever FUNCTION returns NIL and |
---|
518 | NIL whenever FUNCTION returns non-NIL." |
---|
519 | (let ((f (coerce-to-function function))) ; keep poor compiler from consing value cell |
---|
520 | #'(lambda (&rest args) |
---|
521 | (declare (dynamic-extent args)) ; not tail-recursive anyway |
---|
522 | (not (apply f args))))) |
---|
523 | |
---|
524 | ; Special variables are evil, but I can't think of a better way to do this. |
---|
525 | |
---|
526 | (defparameter *outstanding-deferred-warnings* nil) |
---|
527 | |
---|
528 | |
---|
529 | (defun %defer-warnings (override &optional flags) |
---|
530 | (%istruct 'deferred-warnings (unless override *outstanding-deferred-warnings*) nil nil flags)) |
---|
531 | |
---|
532 | (defun report-deferred-warnings () |
---|
533 | (let* ((current *outstanding-deferred-warnings*) |
---|
534 | (parent (deferred-warnings.parent current)) |
---|
535 | (defs (deferred-warnings.defs current)) |
---|
536 | (warnings (deferred-warnings.warnings current)) |
---|
537 | (any nil) |
---|
538 | (harsh nil)) |
---|
539 | (if parent |
---|
540 | (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent)) |
---|
541 | (deferred-warnings.defs parent) (append defs (deferred-warnings.defs parent)) |
---|
542 | parent t) |
---|
543 | (let* ((file nil) |
---|
544 | (init t)) |
---|
545 | (flet ((signal-warning (w) |
---|
546 | (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any)) |
---|
547 | (setq init nil))) |
---|
548 | (dolist (w warnings) |
---|
549 | (let* ((args (compiler-warning-args w)) |
---|
550 | (wfname (car args)) |
---|
551 | (def nil)) |
---|
552 | (when (if (typep w 'undefined-function-reference) |
---|
553 | (not (setq def (or (assq wfname defs) |
---|
554 | (let* ((global (fboundp wfname))) |
---|
555 | (if (typep global 'function) |
---|
556 | global)))))) |
---|
557 | (signal-warning w)) |
---|
558 | ;; Check args in call to forward-referenced function. |
---|
559 | (if (or (typep def 'function) |
---|
560 | (and (consp def) |
---|
561 | (consp (cdr def)) |
---|
562 | (consp (cadr def)) |
---|
563 | (caadr def))) |
---|
564 | (when (cdr args) |
---|
565 | (destructuring-bind (arglist spread-p) |
---|
566 | (cdr args) |
---|
567 | (multiple-value-bind (deftype reason) |
---|
568 | (nx1-check-call-args def arglist spread-p) |
---|
569 | (when deftype |
---|
570 | (let* ((w2 (make-condition |
---|
571 | 'invalid-arguments |
---|
572 | :file-name (compiler-warning-file-name w) |
---|
573 | :function-name (compiler-warning-function-name w) |
---|
574 | :warning-type deftype |
---|
575 | :args (list (car args) reason arglist spread-p)))) |
---|
576 | (setf (compiler-warning-stream-position w2) |
---|
577 | (compiler-warning-stream-position w)) |
---|
578 | (signal-warning w2)))))) |
---|
579 | (if (or (and (consp def) |
---|
580 | (consp (cdr def)) |
---|
581 | (consp (cadr def)) |
---|
582 | (eq (cdadr def) 'macro)) |
---|
583 | (typep def 'simple-vector)) |
---|
584 | (let* ((w2 (make-condition |
---|
585 | 'macro-used-before-definition |
---|
586 | :file-name (compiler-warning-file-name w) |
---|
587 | :function-name (compiler-warning-function-name w) |
---|
588 | :warning-type :macro-used-before-definition |
---|
589 | :args (list (car args))))) |
---|
590 | (setf (compiler-warning-stream-position w2) |
---|
591 | (compiler-warning-stream-position w)) |
---|
592 | (signal-warning w2))))))))) |
---|
593 | (values any harsh parent))) |
---|
594 | |
---|
595 | (defun print-nested-name (name-list stream) |
---|
596 | (if (null name-list) |
---|
597 | (princ "a toplevel form" stream) |
---|
598 | (progn |
---|
599 | (if (car name-list) |
---|
600 | (prin1 (%car name-list) stream) |
---|
601 | (princ "an anonymous lambda form" stream)) |
---|
602 | (when (%cdr name-list) |
---|
603 | (princ " inside " stream) |
---|
604 | (print-nested-name (%cdr name-list) stream))))) |
---|
605 | |
---|
606 | (defparameter *suppress-compiler-warnings* nil) |
---|
607 | |
---|
608 | (defun signal-compiler-warning (w init-p last-w-file harsh-p any-p &optional eval-p) |
---|
609 | (let ((muffled *suppress-compiler-warnings*) |
---|
610 | (w-file (compiler-warning-file-name w)) |
---|
611 | (s *error-output*)) |
---|
612 | (unless muffled |
---|
613 | (restart-case (signal w) |
---|
614 | (muffle-warning () (setq muffled t)))) |
---|
615 | (unless muffled |
---|
616 | (setq any-p t) |
---|
617 | (unless (typep w 'style-warning) |
---|
618 | (unless (eq harsh-p :very) |
---|
619 | (setq harsh-p t) |
---|
620 | (when (and (typep w 'compiler-warning) |
---|
621 | (eq (compiler-warning-warning-type w) :program-error) |
---|
622 | (typep (car (compiler-warning-args w)) 'error)) |
---|
623 | (setq harsh-p :very)))) |
---|
624 | (when (or init-p (not (equalp w-file last-w-file))) |
---|
625 | (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter")) |
---|
626 | (if w-file (format s "for ~S :" w-file) (princ ":" s))) |
---|
627 | (let* ((indenting-stream (make-indenting-string-output-stream #\; 4))) |
---|
628 | (format indenting-stream "~%~a" w) |
---|
629 | (format s "~a" (get-output-stream-string indenting-stream)))) |
---|
630 | (values harsh-p any-p w-file))) |
---|
631 | |
---|
632 | ;;;; Assorted mumble-P type predicates. |
---|
633 | ;;;; No functions have been in the kernel for the last year or so. |
---|
634 | ;;;; (Just thought you'd like to know.) |
---|
635 | |
---|
636 | (defun sequencep (form) |
---|
637 | "Not CL. SLISP Returns T if form is a sequence, NIL otherwise." |
---|
638 | (or (listp form) (vectorp form))) |
---|
639 | |
---|
640 | ;;; The following are not defined at user level, but are necessary for |
---|
641 | ;;; internal use by TYPEP. |
---|
642 | |
---|
643 | (defun bitp (form) |
---|
644 | "Not CL. SLISP" |
---|
645 | (or (eq form 0) (eq form 1))) |
---|
646 | |
---|
647 | (defun unsigned-byte-p (form) |
---|
648 | (and (integerp form) (not (< form 0)))) |
---|
649 | |
---|
650 | ;This is false for internal structures. |
---|
651 | ;;; ---- look at defenv.structures, not defenv.structrefs |
---|
652 | |
---|
653 | (defun structure-class-p (form &optional env) |
---|
654 | (and (symbolp form) |
---|
655 | (let ((sd (or (and env |
---|
656 | (let ((defenv (definition-environment env))) |
---|
657 | (and defenv |
---|
658 | (%cdr (assq form (defenv.structures defenv)))))) |
---|
659 | (gethash form %defstructs%)))) |
---|
660 | (and sd |
---|
661 | (null (sd-type sd)) |
---|
662 | sd)))) |
---|
663 | |
---|
664 | |
---|
665 | |
---|
666 | |
---|
667 | |
---|
668 | (defun type-keyword-code (type-keyword &optional target) |
---|
669 | (let* ((backend (if target (find-backend target) *target-backend*)) |
---|
670 | (alist (arch::target-uvector-subtags (backend-target-arch backend))) |
---|
671 | (entry (assq type-keyword alist))) |
---|
672 | (if entry |
---|
673 | (let* ((code (cdr entry))) |
---|
674 | (or code (error "Vector type ~s invalid," type-keyword))) |
---|
675 | (error "Unknown type-keyword ~s. " type-keyword)))) |
---|
676 | |
---|
677 | |
---|
678 | (defstruct id-map |
---|
679 | (vector (make-array 1 :initial-element nil)) |
---|
680 | (free 0) |
---|
681 | (lock (make-lock))) |
---|
682 | |
---|
683 | ;;; Caller owns the lock on the id-map. |
---|
684 | (defun id-map-grow (id-map) |
---|
685 | (without-interrupts |
---|
686 | (let* ((old-vector (id-map-vector id-map)) |
---|
687 | (old-size (length old-vector)) |
---|
688 | (new-size (+ old-size old-size)) |
---|
689 | (new-vector (make-array new-size))) |
---|
690 | (declare (fixnum old-size new-size)) |
---|
691 | (dotimes (i old-size) |
---|
692 | (setf (svref new-vector i) (svref old-vector i))) |
---|
693 | (let* ((limit (1- new-size))) |
---|
694 | (declare (fixnum limit)) |
---|
695 | (do* ((i old-size (1+ i))) |
---|
696 | ((= i limit) (setf (svref new-vector i) nil)) |
---|
697 | (declare (fixnum i)) |
---|
698 | (setf (svref new-vector i) (the fixnum (1+ i))))) |
---|
699 | (setf (id-map-vector id-map) new-vector |
---|
700 | (id-map-free id-map) old-size)))) |
---|
701 | |
---|
702 | ;;; Map an object to a small fixnum ID in id-map. |
---|
703 | ;;; Object can't be NIL or a fixnum itself. |
---|
704 | (defun assign-id-map-id (id-map object) |
---|
705 | (if (or (null object) (typep object 'fixnum)) |
---|
706 | (setq object (require-type object '(not (or null fixnum))))) |
---|
707 | (with-lock-grabbed ((id-map-lock id-map)) |
---|
708 | (let* ((free (or (id-map-free id-map) (id-map-grow id-map))) |
---|
709 | (vector (id-map-vector id-map)) |
---|
710 | (newfree (svref vector free))) |
---|
711 | (setf (id-map-free id-map) newfree |
---|
712 | (svref vector free) object) |
---|
713 | free))) |
---|
714 | |
---|
715 | ;;; Referemce the object with id ID in ID-MAP. Leave the object in |
---|
716 | ;;; the map. |
---|
717 | (defun id-map-object (id-map id) |
---|
718 | (let* ((object (with-lock-grabbed ((id-map-lock id-map)) |
---|
719 | (svref (id-map-vector id-map) id)))) |
---|
720 | (if (or (null object) (typep object 'fixnum)) |
---|
721 | (error "invalid index ~d for ~s" id id-map) |
---|
722 | object))) |
---|
723 | |
---|
724 | ;;; Referemce the object with id ID in ID-MAP. Remove the object from |
---|
725 | ;;; the map. |
---|
726 | (defun id-map-free-object (id-map id) |
---|
727 | (with-lock-grabbed ((id-map-lock id-map)) |
---|
728 | (let* ((vector (id-map-vector id-map)) |
---|
729 | (object (svref vector id))) |
---|
730 | (if (or (null object) (typep object 'fixnum)) |
---|
731 | (error "invalid index ~d for ~s" id id-map)) |
---|
732 | (setf (svref vector id) (id-map-free id-map) |
---|
733 | (id-map-free id-map) id) |
---|
734 | object))) |
---|
735 | |
---|
736 | (defun id-map-modify-object (id-map id old-value new-value) |
---|
737 | (with-lock-grabbed ((id-map-lock id-map)) |
---|
738 | (let* ((vector (id-map-vector id-map)) |
---|
739 | (object (svref vector id))) |
---|
740 | (if (or (null object) (typep object 'fixnum)) |
---|
741 | (error "invalid index ~d for ~s" id id-map)) |
---|
742 | (if (eq object old-value) |
---|
743 | (setf (svref vector id) new-value))))) |
---|
744 | |
---|
745 | |
---|
746 | |
---|
747 | |
---|
748 | (setq *type-system-initialized* t) |
---|
749 | |
---|
750 | ;;; Try to map from a CTYPE describing some array/stream |
---|
751 | ;;; element-type to a target-specific typecode, catching |
---|
752 | ;;; cases that CTYPE-SUBTYPE missed. |
---|
753 | |
---|
754 | (defun harder-ctype-subtype (ctype) |
---|
755 | (cond ((csubtypep ctype (load-time-value (specifier-type 'bit))) |
---|
756 | target::subtag-bit-vector) |
---|
757 | ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 8)))) |
---|
758 | target::subtag-u8-vector) |
---|
759 | ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 16)))) |
---|
760 | target::subtag-u16-vector) |
---|
761 | ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 32)))) |
---|
762 | target::subtag-u32-vector) |
---|
763 | #+64-bit-target |
---|
764 | ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 64)))) |
---|
765 | target::subtag-u64-vector) |
---|
766 | ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 8)))) |
---|
767 | target::subtag-s8-vector) |
---|
768 | ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 16)))) |
---|
769 | target::subtag-s16-vector) |
---|
770 | #+32-bit-target |
---|
771 | ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum)))) |
---|
772 | target::subtag-fixnum-vector) |
---|
773 | ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 32)))) |
---|
774 | target::subtag-s32-vector) |
---|
775 | #+64-bit-target |
---|
776 | ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum)))) |
---|
777 | target::subtag-fixnum-vector) |
---|
778 | #+64-bit-target |
---|
779 | ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 64)))) |
---|
780 | target::subtag-s64-vector) |
---|
781 | (t target::subtag-simple-vector))) |
---|
782 | |
---|
783 | |
---|
784 | #+count-gf-calls |
---|
785 | (progn |
---|
786 | ;;; Call-counting for generic functions. We overload the |
---|
787 | ;;; (previously unused |
---|
788 | (defmethod generic-function-call-count ((gf generic-function)) |
---|
789 | (gf.hash gf)) |
---|
790 | |
---|
791 | |
---|
792 | (defun (setf generic-function-call-count) (count gf) |
---|
793 | (setf (gf.hash gf) (require-type count 'fixnum))) |
---|
794 | |
---|
795 | (defun clear-all-generic-function-call-counts () |
---|
796 | (dolist (gf (population.data %all-gfs%)) |
---|
797 | (setf (gf.hash gf) 0))) |
---|
798 | );#+count-gf-calls |
---|
799 | |
---|
800 | |
---|