1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of Clozure CL. |
---|
5 | ;;; |
---|
6 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; Clozure CL 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 | ; L1-utils.lisp |
---|
18 | |
---|
19 | (in-package "CCL") |
---|
20 | |
---|
21 | ;The following forms (up thru defn of %DEFUN) must come before any DEFUN's. |
---|
22 | ;Any (non-kernel) functions must be defined before they're used! |
---|
23 | ;In fact, ALL functions must be defined before they're used! How about that ? |
---|
24 | |
---|
25 | |
---|
26 | |
---|
27 | (setq %lisp-system-fixups% nil) |
---|
28 | |
---|
29 | |
---|
30 | ;;; Kludge for record-source-file bootstrapping |
---|
31 | |
---|
32 | (%fhave 'full-pathname (qlfun bootstrapping-full-pathname (name) name)) |
---|
33 | |
---|
34 | |
---|
35 | ; real one is in setf.lisp |
---|
36 | (%fhave '%setf-method (qlfun bootstripping-setf-fsname (spec) |
---|
37 | spec nil)) |
---|
38 | |
---|
39 | (fset 'physical-pathname-p (lambda (file)(declare (ignore file)) nil)) ; redefined later |
---|
40 | |
---|
41 | (setq *record-source-file* t) |
---|
42 | |
---|
43 | (fset 'level-1-record-source-file |
---|
44 | (qlfun level-1-record-source-file (name def-type &optional (source (or *loading-toplevel-location* |
---|
45 | *loading-file-source-file*))) |
---|
46 | ;; Level-0 puts stuff on plist of name. Once we're in level-1, names can |
---|
47 | ;; be more complicated than just a symbol, so just collect all calls until |
---|
48 | ;; the real record-source-file is loaded. |
---|
49 | (when *record-source-file* |
---|
50 | (unless (listp *record-source-file*) |
---|
51 | (setq *record-source-file* nil)) |
---|
52 | (push (list name def-type source) *record-source-file*)))) |
---|
53 | |
---|
54 | (fset 'record-source-file #'level-1-record-source-file) |
---|
55 | |
---|
56 | (defun inherit-from-p (ob parent) |
---|
57 | (memq (if (symbolp parent) (find-class parent nil) parent) |
---|
58 | (%inited-class-cpl (class-of ob)))) |
---|
59 | |
---|
60 | ;;; returns new plist with value spliced in or key, value consed on. |
---|
61 | (defun setprop (plist key value &aux loc) |
---|
62 | (if (setq loc (pl-search plist key)) |
---|
63 | (progn (%rplaca (%cdr loc) value) plist) |
---|
64 | (cons key (cons value plist)))) |
---|
65 | |
---|
66 | (defun getf-test (place indicator test &optional default) |
---|
67 | (loop |
---|
68 | (when (null place) |
---|
69 | (return default)) |
---|
70 | (when (funcall test indicator (car place)) |
---|
71 | (return (cadr place))) |
---|
72 | (setq place (cddr place)))) |
---|
73 | |
---|
74 | (defun setprop-test (plist indicator test value) |
---|
75 | (let ((tail plist)) |
---|
76 | (loop |
---|
77 | (when (null tail) |
---|
78 | (return (cons indicator (cons value plist)))) |
---|
79 | (when (funcall test indicator (car tail)) |
---|
80 | (setf (cadr tail) value) |
---|
81 | (return plist)) |
---|
82 | (setq tail (cddr tail))))) |
---|
83 | |
---|
84 | (defun plistp (p &aux len) |
---|
85 | (and (listp p) |
---|
86 | (setq len (list-length p)) |
---|
87 | (not (%ilogbitp 0 len)))) ; (evenp p) |
---|
88 | |
---|
89 | (defun %imax (i1 i2) |
---|
90 | (if (%i> i1 i2) i1 i2)) |
---|
91 | |
---|
92 | (defun %imin (i1 i2) |
---|
93 | (if (%i< i1 i2) i1 i2)) |
---|
94 | |
---|
95 | |
---|
96 | |
---|
97 | |
---|
98 | ;|# |
---|
99 | |
---|
100 | |
---|
101 | (eval-when (:compile-toplevel :execute) |
---|
102 | (require "NUMBER-MACROS")) |
---|
103 | |
---|
104 | |
---|
105 | |
---|
106 | |
---|
107 | (defun loading-file-source-file () |
---|
108 | *loading-file-source-file*) |
---|
109 | |
---|
110 | (setq *save-local-symbols* t) |
---|
111 | |
---|
112 | (%fhave 'require-type (nfunction bootstrapping-require-type |
---|
113 | (lambda (thing type) |
---|
114 | (declare (ignore type)) |
---|
115 | thing))) |
---|
116 | (%fhave '%require-type |
---|
117 | (nfunction bootstrapping-%require-type |
---|
118 | (lambda (thing predicate) |
---|
119 | (declare (ignore predicate)) |
---|
120 | thing))) |
---|
121 | |
---|
122 | (setf (type-predicate 'macptr) 'macptrp) |
---|
123 | |
---|
124 | |
---|
125 | |
---|
126 | |
---|
127 | |
---|
128 | |
---|
129 | (defun %pop-required-arg-ptr (ptr) |
---|
130 | (if (atom (destructure-state.current ptr)) |
---|
131 | (signal-program-error "Required arguments in ~s don't match lambda list ~s." |
---|
132 | (destructure-state.whole ptr) (destructure-state.lambda ptr)) |
---|
133 | (pop (destructure-state.current ptr)))) |
---|
134 | |
---|
135 | (defun %default-optional-value (ptr &optional default) |
---|
136 | (let* ((tail (destructure-state.current ptr))) |
---|
137 | (if tail |
---|
138 | (if (atom tail) |
---|
139 | (signal-program-error "Optional arguments in ~s don't match lambda list ~s." |
---|
140 | (destructure-state.whole ptr) (destructure-state.lambda ptr)) |
---|
141 | (pop (destructure-state.current ptr))) |
---|
142 | default))) |
---|
143 | |
---|
144 | (defun %check-extra-arguments (ptr) |
---|
145 | (when (destructure-state.current ptr) |
---|
146 | (signal-program-error "Extra arguments in ~s don't match lambda list ~s." |
---|
147 | (destructure-state.whole ptr) (destructure-state.lambda ptr)))) |
---|
148 | |
---|
149 | (defun %keyword-present-p (keys keyword) |
---|
150 | (let* ((not-there (cons nil nil))) |
---|
151 | (declare (dynamic-extent not-there)) |
---|
152 | (not (eq (getf keys keyword not-there) not-there)))) |
---|
153 | |
---|
154 | (defun check-keywords (keys actual allow-others) |
---|
155 | (let* ((len (ignore-errors (list-length actual)))) |
---|
156 | (if (null len) |
---|
157 | (signal-simple-program-error "Circular or dotted keyword list: ~s" actual) |
---|
158 | (if (oddp len) |
---|
159 | (signal-simple-program-error "Odd length keyword list: ~s" actual)))) |
---|
160 | (setq allow-others (or allow-others (getf actual :allow-other-keys))) |
---|
161 | (do* ((a actual (cddr a)) |
---|
162 | (k (car a) (car a))) |
---|
163 | ((null a)) |
---|
164 | (unless (typep k 'symbol) |
---|
165 | (signal-simple-program-error |
---|
166 | "Invalid keyword argument ~s in ~s. ~&Valid keyword arguments are ~s." k actual keys)) |
---|
167 | (unless (or allow-others |
---|
168 | (eq k :allow-other-keys) |
---|
169 | (member k keys)) |
---|
170 | (signal-simple-program-error "Unknown keyword argument ~s in ~s. ~&Valid keyword arguments are ~s." k actual keys)))) |
---|
171 | |
---|
172 | (%fhave 'set-macro-function #'%macro-have) ; redefined in sysutils. |
---|
173 | |
---|
174 | ;;; Define special forms. |
---|
175 | (dolist (sym '(block catch compiler-let eval-when |
---|
176 | flet function go if labels let let* macrolet |
---|
177 | multiple-value-call multiple-value-prog1 |
---|
178 | progn progv quote return-from setq tagbody |
---|
179 | the throw unwind-protect locally load-time-value |
---|
180 | symbol-macrolet |
---|
181 | ;; These are implementation-specific special forms : |
---|
182 | nfunction |
---|
183 | ppc-lap-function fbind |
---|
184 | with-c-frame with-variable-c-frame)) |
---|
185 | (%macro-have sym sym)) |
---|
186 | |
---|
187 | |
---|
188 | (defun %macro (named-fn &optional doc &aux arglist) |
---|
189 | ;; "doc" is either a string or a list of the form : |
---|
190 | ;; (doc-string-or-nil . (body-pos-or-nil . arglist-or-nil)) |
---|
191 | (if (listp doc) |
---|
192 | (setq arglist (cddr doc) |
---|
193 | doc (car doc))) |
---|
194 | (let* ((name (function-name named-fn))) |
---|
195 | (record-source-file name 'function) |
---|
196 | (set-macro-function name named-fn) |
---|
197 | (when (and doc *save-doc-strings*) |
---|
198 | (set-documentation name 'function doc)) |
---|
199 | (when arglist |
---|
200 | (record-arglist name arglist)) |
---|
201 | (when *fasload-print* (format t "~&~S~%" name)) |
---|
202 | name)) |
---|
203 | |
---|
204 | |
---|
205 | (defun %defvar (var &optional doc) |
---|
206 | "Returns boundp" |
---|
207 | (%proclaim-special var) |
---|
208 | (record-source-file var 'variable) |
---|
209 | (when (and doc *save-doc-strings*) |
---|
210 | (set-documentation var 'variable doc)) |
---|
211 | (cond ((not (boundp var)) |
---|
212 | (when *fasload-print* (format t "~&~S~%" var)) |
---|
213 | nil) |
---|
214 | (t t))) |
---|
215 | |
---|
216 | (defun %defparameter (var value &optional doc) |
---|
217 | (%proclaim-special var) |
---|
218 | (record-source-file var 'variable) |
---|
219 | (when (and doc *save-doc-strings*) |
---|
220 | (set-documentation var 'variable doc)) |
---|
221 | (when *fasload-print* (format t "~&~S~%" var)) |
---|
222 | (set var value) |
---|
223 | var) |
---|
224 | |
---|
225 | |
---|
226 | (defun %defglobal (var value &optional doc) |
---|
227 | (%symbol-bits var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits var)))) |
---|
228 | (%defparameter var value doc)) |
---|
229 | |
---|
230 | ;Needed early for member etc. |
---|
231 | (defun identity (x) |
---|
232 | "This function simply returns what was passed to it." |
---|
233 | x) |
---|
234 | |
---|
235 | (defun coerce-to-function (arg) |
---|
236 | (if (functionp arg) |
---|
237 | arg |
---|
238 | (if (symbolp arg) |
---|
239 | (%function arg) |
---|
240 | (report-bad-arg arg 'function)))) |
---|
241 | |
---|
242 | ;;; takes arguments in arg_x, arg_y, arg_z, returns "multiple values" |
---|
243 | ;;; Test(-not) arguments are NOT validated beyond what is done |
---|
244 | ;;; here. |
---|
245 | ;;; if both :test and :test-not supplied, signal error. |
---|
246 | ;;; if test provided as #'eq or 'eq, return first value 'eq. |
---|
247 | ;;; if test defaulted, provided as 'eql, or provided as #'eql, return |
---|
248 | ;;; first value 'eql. |
---|
249 | ;;; if test-not provided as 'eql or provided as #'eql, return second |
---|
250 | ;;; value 'eql. |
---|
251 | ;;; if key provided as either 'identity or #'identity, return third value nil. |
---|
252 | (defun %key-conflict (test-fn test-not-fn key) |
---|
253 | (let* ((eqfn #'eq) |
---|
254 | (eqlfn #'eql) |
---|
255 | (idfn #'identity)) |
---|
256 | (if (or (eq key 'identity) (eq key idfn)) |
---|
257 | (setq key nil)) |
---|
258 | (if test-fn |
---|
259 | (if test-not-fn |
---|
260 | (%err-disp $xkeyconflict ':test test-fn ':test-not test-not-fn) |
---|
261 | (if (eq test-fn eqfn) |
---|
262 | (values 'eq nil key) |
---|
263 | (if (eq test-fn eqlfn) |
---|
264 | (values 'eql nil key) |
---|
265 | (values test-fn nil key)))) |
---|
266 | (if test-not-fn |
---|
267 | (if (eq test-not-fn eqfn) |
---|
268 | (values nil 'eq key) |
---|
269 | (if (eq test-not-fn eqlfn) |
---|
270 | (values nil 'eql key) |
---|
271 | (values nil test-not-fn key))) |
---|
272 | (values 'eql nil key))))) |
---|
273 | |
---|
274 | |
---|
275 | |
---|
276 | |
---|
277 | ;;; Assoc. |
---|
278 | |
---|
279 | ;;; (asseql item list) <=> (assoc item list :test #'eql :key #'identity) |
---|
280 | |
---|
281 | |
---|
282 | |
---|
283 | ;;; (assoc-test item list test-fn) |
---|
284 | ;;; <=> |
---|
285 | ;;; (assoc item list :test test-fn :key #'identity) |
---|
286 | ;;; test-fn may not be FUNCTIONP, so we coerce it here. |
---|
287 | (defun assoc-test (item list test-fn) |
---|
288 | (dolist (pair list) |
---|
289 | (if pair |
---|
290 | (if (funcall test-fn item (car pair)) |
---|
291 | (return pair))))) |
---|
292 | |
---|
293 | |
---|
294 | |
---|
295 | ; (assoc-test-not item list test-not-fn) |
---|
296 | ; <=> |
---|
297 | ; (assoc item list :test-not test-not-fn :key #'identity) |
---|
298 | ; test-not-fn may not be FUNCTIONP, so we coerce it here. |
---|
299 | (defun assoc-test-not (item list test-not-fn) |
---|
300 | (dolist (pair list) |
---|
301 | (if pair |
---|
302 | (if (not (funcall test-not-fn item (car pair))) |
---|
303 | (return pair))))) |
---|
304 | |
---|
305 | (defun assoc (item list &key test test-not key) |
---|
306 | "Return the cons in ALIST whose car is equal (by a given test or EQL) to |
---|
307 | the ITEM." |
---|
308 | (multiple-value-bind (test test-not key) (%key-conflict test test-not key) |
---|
309 | (if (null key) |
---|
310 | (if (eq test 'eq) |
---|
311 | (assq item list) |
---|
312 | (if (eq test 'eql) |
---|
313 | (asseql item list) |
---|
314 | (if test |
---|
315 | (assoc-test item list test) |
---|
316 | (assoc-test-not item list test-not)))) |
---|
317 | (if test |
---|
318 | (dolist (pair list) |
---|
319 | (if pair |
---|
320 | (if (funcall test item (funcall key (car pair))) |
---|
321 | (return pair)))) |
---|
322 | (dolist (pair list) |
---|
323 | (if pair |
---|
324 | (unless (funcall test-not item (funcall key (car pair))) |
---|
325 | (return pair)))))))) |
---|
326 | |
---|
327 | |
---|
328 | ;;;; Member. |
---|
329 | |
---|
330 | ;;; (member-test-not item list test-not-fn) |
---|
331 | ;;; <=> |
---|
332 | ;;; (member item list :test-not test-not-fn :key #'identity) |
---|
333 | (defun member-test-not (item list test-not-fn) |
---|
334 | (do* ((l list (cdr l))) |
---|
335 | ((endp l)) |
---|
336 | (unless (funcall test-not-fn item (%car l)) (return l)))) |
---|
337 | |
---|
338 | (defun member (item list &key test test-not key) |
---|
339 | "Return the tail of LIST beginning with first element satisfying EQLity, |
---|
340 | :TEST, or :TEST-NOT with the given ITEM." |
---|
341 | (multiple-value-bind (test test-not key) (%key-conflict test test-not key) |
---|
342 | (if (null key) |
---|
343 | (if (eq test 'eq) |
---|
344 | (memq item list) |
---|
345 | (if (eq test 'eql) |
---|
346 | (memeql item list) |
---|
347 | (if test |
---|
348 | (member-test item list test) |
---|
349 | (member-test-not item list test-not)))) |
---|
350 | (if test |
---|
351 | (do* ((l list (cdr l))) |
---|
352 | ((endp l)) |
---|
353 | (if (funcall test item (funcall key (car l))) |
---|
354 | (return l))) |
---|
355 | (do* ((l list (cdr l))) |
---|
356 | ((null l)) |
---|
357 | (unless (funcall test-not item (funcall key (car l))) |
---|
358 | (return l))))))) |
---|
359 | |
---|
360 | |
---|
361 | (defun adjoin (item list &key test test-not key) |
---|
362 | "Add ITEM to LIST unless it is already a member" |
---|
363 | (if (and (not test)(not test-not)(not key)) |
---|
364 | (if (not (memeql item list))(cons item list) list) |
---|
365 | (multiple-value-bind (test test-not key) (%key-conflict test test-not key) |
---|
366 | (if |
---|
367 | (if (null key) |
---|
368 | (if (eq test 'eq) |
---|
369 | (memq item list) |
---|
370 | (if (eq test 'eql) |
---|
371 | (memeql item list) |
---|
372 | (if test |
---|
373 | (member-test item list test) |
---|
374 | (member-test-not item list test-not)))) |
---|
375 | (if test |
---|
376 | (member (funcall key item) list :test test :key key) |
---|
377 | (member (funcall key item) list :test-not test-not :key key))) |
---|
378 | list |
---|
379 | (cons item list))))) |
---|
380 | |
---|
381 | (defun adjoin-eq (elt list) |
---|
382 | (if (memq elt list) |
---|
383 | list |
---|
384 | (cons elt list))) |
---|
385 | |
---|
386 | (defun adjoin-eql (elt list) |
---|
387 | (if (memeql elt list) |
---|
388 | list |
---|
389 | (cons elt list))) |
---|
390 | |
---|
391 | (defun union-eq (list1 list2) |
---|
392 | (let ((res list2)) |
---|
393 | (dolist (elt list1) |
---|
394 | (unless (memq elt res) |
---|
395 | (push elt res))) |
---|
396 | res)) |
---|
397 | |
---|
398 | (defun union-eql (list1 list2) |
---|
399 | (let ((res list2)) |
---|
400 | (dolist (elt list1) |
---|
401 | (unless (memeql elt res) |
---|
402 | (push elt res))) |
---|
403 | res)) |
---|
404 | |
---|
405 | ;;; Fix this someday. Fix EQUALP, while you're at it ... |
---|
406 | (defun similar-as-constants-p (x y) |
---|
407 | (or (eq x y) ; Redefinition of constants to themselves. |
---|
408 | (if (and (stringp x) (stringp y)) ;The most obvious case where equalp & s-a-c-p need to differ... |
---|
409 | (string= x y) |
---|
410 | (equalp x y)))) |
---|
411 | |
---|
412 | (defun undefine-constant (var) |
---|
413 | (%set-sym-global-value var (%unbound-marker-8))) |
---|
414 | |
---|
415 | (defparameter *cerror-on-constant-redefinition* t) |
---|
416 | |
---|
417 | (defun define-constant (var value) |
---|
418 | (block nil |
---|
419 | (if (constant-symbol-p var) |
---|
420 | (let* ((old-value (%sym-global-value var))) |
---|
421 | (unless (eq old-value (%unbound-marker-8)) |
---|
422 | (if (similar-as-constants-p (%sym-global-value var) value) |
---|
423 | (return) |
---|
424 | ;; This should really be a cell error, allow options other than |
---|
425 | ;; redefining (such as don't redefine and continue)... |
---|
426 | (when *cerror-on-constant-redefinition* |
---|
427 | (cerror "Redefine ~S to have new value ~*~s" |
---|
428 | "Constant ~S is already defined with a different value (~s)" |
---|
429 | var old-value value)))))) |
---|
430 | (%symbol-bits var |
---|
431 | (%ilogior (%ilsl $sym_bit_special 1) (%ilsl $sym_bit_const 1) |
---|
432 | (%symbol-bits var))) |
---|
433 | (%set-sym-global-value var value)) |
---|
434 | var) |
---|
435 | |
---|
436 | (defun %defconstant (var value &optional doc) |
---|
437 | (%proclaim-special var) |
---|
438 | (record-source-file var 'constant) |
---|
439 | (define-constant var value) |
---|
440 | (when (and doc *save-doc-strings*) |
---|
441 | (set-documentation var 'variable doc)) |
---|
442 | (when *fasload-print* (format t "~&~S~%" var)) |
---|
443 | var) |
---|
444 | |
---|
445 | (defparameter *nx1-compiler-special-forms* ()) |
---|
446 | (defparameter *nx-proclaimed-types* ()) |
---|
447 | (defparameter *nx-proclaimed-ftypes* nil) |
---|
448 | |
---|
449 | (defun compiler-special-form-p (sym) |
---|
450 | (or (eq sym 'quote) |
---|
451 | (if (memq sym *nx1-compiler-special-forms*) t))) |
---|
452 | |
---|
453 | |
---|
454 | |
---|
455 | (defparameter *nx-known-declarations* ()) |
---|
456 | (defparameter *nx-proclaimed-inline* ()) |
---|
457 | (defparameter *nx-proclaimed-ignore* ()) |
---|
458 | (defparameter *nx-globally-inline* ()) |
---|
459 | |
---|
460 | |
---|
461 | |
---|
462 | (defconstant *cl-types* '( |
---|
463 | array |
---|
464 | atom |
---|
465 | base-char |
---|
466 | bignum |
---|
467 | bit |
---|
468 | bit-vector |
---|
469 | character |
---|
470 | #| |
---|
471 | lisp:common |
---|
472 | |# |
---|
473 | compiled-function |
---|
474 | complex |
---|
475 | cons |
---|
476 | double-float |
---|
477 | extended-char |
---|
478 | fixnum |
---|
479 | float |
---|
480 | function |
---|
481 | hash-table |
---|
482 | integer |
---|
483 | keyword |
---|
484 | list |
---|
485 | long-float |
---|
486 | nil |
---|
487 | null |
---|
488 | number |
---|
489 | package |
---|
490 | pathname |
---|
491 | random-state |
---|
492 | ratio |
---|
493 | rational |
---|
494 | readtable |
---|
495 | real |
---|
496 | sequence |
---|
497 | short-float |
---|
498 | signed-byte |
---|
499 | simple-array |
---|
500 | simple-bit-vector |
---|
501 | simple-string |
---|
502 | simple-base-string |
---|
503 | simple-vector |
---|
504 | single-float |
---|
505 | standard-char |
---|
506 | stream |
---|
507 | string |
---|
508 | #| |
---|
509 | lisp:string-char |
---|
510 | |# |
---|
511 | symbol |
---|
512 | t |
---|
513 | unsigned-byte |
---|
514 | vector |
---|
515 | )) |
---|
516 | |
---|
517 | ;; Redefined in sysutils. |
---|
518 | (%fhave 'specifier-type-if-known |
---|
519 | (qlfun bootstrapping-type-specifier-p (name &optional env &key &allow-other-keys) |
---|
520 | (declare (ignore env)) |
---|
521 | (memq name *cl-types*))) |
---|
522 | |
---|
523 | |
---|
524 | |
---|
525 | (defun proclaim (spec) |
---|
526 | (case (car spec) |
---|
527 | (special (apply #'proclaim-special (%cdr spec))) |
---|
528 | (notspecial (apply #'proclaim-notspecial (%cdr spec))) |
---|
529 | (optimize (%proclaim-optimize (%cdr spec))) |
---|
530 | (inline (apply #'proclaim-inline t (%cdr spec))) |
---|
531 | (notinline (apply #'proclaim-inline nil (%cdr spec))) |
---|
532 | (declaration (apply #'proclaim-declaration (%cdr spec))) |
---|
533 | (ignore (apply #'proclaim-ignore t (%cdr spec))) |
---|
534 | (unignore (apply #'proclaim-ignore nil (%cdr spec))) |
---|
535 | (type (apply #'proclaim-type (%cdr spec))) |
---|
536 | (ftype (apply #'proclaim-ftype (%cdr spec))) |
---|
537 | (function (apply #'proclaim-type spec)) |
---|
538 | (t (unless (memq (%car spec) *nx-known-declarations*) |
---|
539 | ;; Any type name is now (ANSI CL) a valid declaration. |
---|
540 | (if (specifier-type-if-known (%car spec)) |
---|
541 | (apply #'proclaim-type spec) |
---|
542 | (signal-program-error "Unknown declaration specifier ~s in ~S" (%car spec) spec)))))) |
---|
543 | |
---|
544 | (defun bad-proclaim-spec (spec) |
---|
545 | (signal-program-error "Invalid declaration specifier ~s" spec)) |
---|
546 | |
---|
547 | (defun proclaim-type (type &rest vars) |
---|
548 | (declare (dynamic-extent vars)) |
---|
549 | ;; Called too early to use (every #'symbolp vars) |
---|
550 | (unless (loop for v in vars always (symbolp v)) (bad-proclaim-spec `(,type ,@vars))) |
---|
551 | (when *type-system-initialized* |
---|
552 | ;; Check the type. This will signal program-error's in case of invalid types, let it. |
---|
553 | ;; Do not signal anything about unknown types though -- it should be ok to have forward |
---|
554 | ;; references here, before anybody needs the info. |
---|
555 | (specifier-type type)) |
---|
556 | (dolist (var vars) |
---|
557 | (let ((spec (assq var *nx-proclaimed-types*))) |
---|
558 | (if spec |
---|
559 | (rplacd spec type) |
---|
560 | (push (cons var type) *nx-proclaimed-types*))))) |
---|
561 | |
---|
562 | (defun proclaim-ftype (ftype &rest names) |
---|
563 | (declare (dynamic-extent names)) |
---|
564 | (unless (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) names) |
---|
565 | (bad-proclaim-spec `(ftype ,ftype ,@names))) |
---|
566 | (unless *nx-proclaimed-ftypes* |
---|
567 | (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq))) |
---|
568 | ;; Check the type. This will signal program-error's in case of invalid types, let it. |
---|
569 | ;; Do not signal anything about unknown types though -- it should be ok to have forward |
---|
570 | ;; references here, before anybody needs the info. |
---|
571 | (let* ((ctype (specifier-type ftype))) |
---|
572 | ;; If know enough to complain now, do so. |
---|
573 | (when (types-disjoint-p ctype (specifier-type 'function)) |
---|
574 | (bad-proclaim-spec `(ftype ,ftype ,@names)))) |
---|
575 | (dolist (name names) |
---|
576 | (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype))) |
---|
577 | |
---|
578 | |
---|
579 | |
---|
580 | (defun proclaimed-ftype (name) |
---|
581 | (when *nx-proclaimed-ftypes* |
---|
582 | (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*))) |
---|
583 | |
---|
584 | |
---|
585 | (defun proclaim-special (&rest vars) |
---|
586 | (declare (dynamic-extent vars)) |
---|
587 | (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars))) |
---|
588 | (dolist (sym vars) (%proclaim-special sym))) |
---|
589 | |
---|
590 | |
---|
591 | (defun proclaim-notspecial (&rest vars) |
---|
592 | (declare (dynamic-extent vars)) |
---|
593 | (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars))) |
---|
594 | (dolist (sym vars) (%proclaim-notspecial sym))) |
---|
595 | |
---|
596 | (defun proclaim-inline (t-or-nil &rest names) |
---|
597 | (declare (dynamic-extent names)) |
---|
598 | ;;This is just to make it more likely to detect forgetting about the |
---|
599 | ;;first arg... |
---|
600 | (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil))) |
---|
601 | (unless (loop for v in names always (or (symbolp v) (setf-function-name-p v))) |
---|
602 | (bad-proclaim-spec `(,(if t-or-nil 'inline 'notinline) ,@names))) |
---|
603 | (dolist (name names) |
---|
604 | (setq name (maybe-setf-function-name name)) |
---|
605 | (if (listp *nx-proclaimed-inline*) |
---|
606 | (setq *nx-proclaimed-inline* |
---|
607 | (alist-adjoin name |
---|
608 | (or t-or-nil (if (compiler-special-form-p name) t)) |
---|
609 | *nx-proclaimed-inline*)) |
---|
610 | (setf (gethash name *nx-proclaimed-inline*) |
---|
611 | (or t-or-nil (if (compiler-special-form-p name) t)))))) |
---|
612 | |
---|
613 | (defun proclaim-declaration (&rest syms) |
---|
614 | (declare (dynamic-extent syms)) |
---|
615 | (unless (every #'symbolp syms) (bad-proclaim-spec `(declaration ,@syms))) |
---|
616 | (dolist (sym syms) |
---|
617 | (when (type-specifier-p sym) |
---|
618 | (error "Cannot define declaration ~s because it is the name of a type" sym)) |
---|
619 | (setq *nx-known-declarations* |
---|
620 | (adjoin sym *nx-known-declarations* :test 'eq)))) |
---|
621 | |
---|
622 | (defun check-declaration-redefinition (name why) |
---|
623 | (when (memq name *nx-known-declarations*) |
---|
624 | (cerror "Undeclare the declaration ~*~s" |
---|
625 | "Cannot ~a ~s because ~:*~s has been declared as a declaration name" why name) |
---|
626 | (setq *nx-known-declarations* (remove name *nx-known-declarations*)))) |
---|
627 | |
---|
628 | (defun proclaim-ignore (t-or-nil &rest syms) |
---|
629 | (declare (dynamic-extent syms)) |
---|
630 | ;;This is just to make it more likely to detect forgetting about the |
---|
631 | ;;first arg... |
---|
632 | (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil))) |
---|
633 | (unless (every #'symbolp syms) (bad-proclaim-spec `(,(if t-or-nil 'ignore 'unignore) ,@syms))) |
---|
634 | (dolist (sym syms) |
---|
635 | (setq *nx-proclaimed-ignore* |
---|
636 | (alist-adjoin sym t-or-nil *nx-proclaimed-ignore*)))) |
---|
637 | |
---|
638 | |
---|
639 | (queue-fixup |
---|
640 | (when (listp *nx-proclaimed-inline*) |
---|
641 | (let ((table (make-hash-table :size 100 :test #'eq))) |
---|
642 | (dolist (x *nx-proclaimed-inline*) |
---|
643 | (let ((name (car x)) (value (cdr x))) |
---|
644 | (when (symbolp name) |
---|
645 | (setf (gethash name table) value)))) |
---|
646 | (setq *nx-proclaimed-inline* table)))) |
---|
647 | |
---|
648 | (defun proclaimed-special-p (sym) |
---|
649 | (%ilogbitp $sym_vbit_special (%symbol-bits sym))) |
---|
650 | |
---|
651 | (defun proclaimed-inline-p (sym) |
---|
652 | (if (listp *nx-proclaimed-inline*) |
---|
653 | (%cdr (assq sym *nx-proclaimed-inline*)) |
---|
654 | (gethash sym *nx-proclaimed-inline*))) |
---|
655 | |
---|
656 | (defun proclaimed-notinline-p (sym) |
---|
657 | (if (listp *nx-proclaimed-inline*) |
---|
658 | (and (setq sym (assq sym *nx-proclaimed-inline*)) |
---|
659 | (null (%cdr sym))) |
---|
660 | (null (gethash sym *nx-proclaimed-inline* t)))) |
---|
661 | |
---|
662 | |
---|
663 | (defun self-evaluating-p (form) |
---|
664 | (and (atom form) |
---|
665 | (or (not (non-nil-symbol-p form)) |
---|
666 | (eq form t) |
---|
667 | (keywordp form)))) |
---|
668 | |
---|
669 | (defun constantp (form &optional env) |
---|
670 | "True of any Lisp object that has a constant value: types that eval to |
---|
671 | themselves, keywords, constants, and list whose car is QUOTE." |
---|
672 | (or (self-evaluating-p form) |
---|
673 | (quoted-form-p form) |
---|
674 | (constant-symbol-p form) |
---|
675 | (and env |
---|
676 | (symbolp form) |
---|
677 | (eq :constant (variable-information form env))))) |
---|
678 | |
---|
679 | |
---|
680 | (defun eval-constant (form) |
---|
681 | (if (quoted-form-p form) (%cadr form) |
---|
682 | (if (constant-symbol-p form) (symbol-value form) |
---|
683 | (if (self-evaluating-p form) form |
---|
684 | (report-bad-arg form '(satisfies constantp)))))) |
---|
685 | |
---|
686 | (defvar *lfun-names*) |
---|
687 | |
---|
688 | |
---|
689 | (defvar %lambda-lists% (make-hash-table :test #'eq :weak t)) |
---|
690 | (defparameter *save-arglist-info* t) |
---|
691 | |
---|
692 | |
---|
693 | (defun record-arglist (name args) |
---|
694 | "Used by defmacro & defgeneric" |
---|
695 | (when (or *save-arglist-info* *save-local-symbols*) |
---|
696 | (setf (gethash name %lambda-lists%) args))) |
---|
697 | |
---|
698 | |
---|
699 | ;;;Support the simple case of defsetf. |
---|
700 | (%fhave 'store-setf-method |
---|
701 | (qlfun bootstrapping-store-setf-method (name fn &optional doc) |
---|
702 | (declare (ignore doc)) |
---|
703 | (put name 'bootstrapping-setf-method (require-type fn 'symbol)))) |
---|
704 | (%fhave '%setf-method |
---|
705 | (qlfun bootstrapping-%setf-method (name) |
---|
706 | (get name 'bootstrapping-setf-method))) |
---|
707 | |
---|
708 | |
---|
709 | ;;; defmacro uses (setf (assq ...) ...) for &body forms. |
---|
710 | (defun adjoin-assq (indicator alist value) |
---|
711 | (let ((cell (assq indicator alist))) |
---|
712 | (if cell |
---|
713 | (setf (cdr cell) value) |
---|
714 | (push (cons indicator value) alist))) |
---|
715 | alist) |
---|
716 | |
---|
717 | (defmacro setf-assq (indicator place value) |
---|
718 | (let ((res (gensym))) |
---|
719 | `(let (,res) |
---|
720 | (setf ,place (adjoin-assq ,indicator ,place (setq ,res ,value))) |
---|
721 | ,res))) |
---|
722 | |
---|
723 | (defsetf assq setf-assq) |
---|
724 | (defsetf %typed-miscref %typed-miscset) |
---|
725 | |
---|
726 | (defun quoted-form-p (form) |
---|
727 | (and (consp form) |
---|
728 | (eq (%car form) 'quote) |
---|
729 | (consp (%cdr form)) |
---|
730 | (null (%cdr (%cdr form))))) |
---|
731 | |
---|
732 | (defun lambda-expression-p (form) |
---|
733 | (and (consp form) |
---|
734 | (eq (%car form) 'lambda) |
---|
735 | (consp (%cdr form)) |
---|
736 | (listp (%cadr form)))) |
---|
737 | |
---|
738 | ;;;;;FUNCTION BINDING Functions |
---|
739 | |
---|
740 | ;;; A symbol's entrypoint contains: |
---|
741 | ;;; 1) something tagged as $t_lfun if the symbol is |
---|
742 | ;;; not fbound as a macro or special form; |
---|
743 | ;;; 2) a cons, otherwise, where the cdr is a fixnum |
---|
744 | ;;; whose value happens to be the same bit-pattern |
---|
745 | ;;; as a "jsr_subprim $sp-apply-macro" instruction. |
---|
746 | ;;; The car of this cons is either: |
---|
747 | ;;; a) a function -> macro-function; |
---|
748 | ;;; b) a symbol: special form not redefined as a macro. |
---|
749 | ;;; c) a cons whose car is a function -> macro function defined |
---|
750 | ;;; on a special form. |
---|
751 | |
---|
752 | |
---|
753 | |
---|
754 | |
---|
755 | (defun symbol-function (name) |
---|
756 | "Return the definition of NAME, even if it is a macro or a special form. |
---|
757 | Error if NAME doesn't have a definition." |
---|
758 | (or (fboundp name) ;Our fboundp returns the binding |
---|
759 | (prog1 (%err-disp $xfunbnd name)))) |
---|
760 | |
---|
761 | (%fhave 'fdefinition #'symbol-function) |
---|
762 | |
---|
763 | |
---|
764 | (defun kernel-function-p (f) |
---|
765 | (declare (ignore f)) |
---|
766 | nil) |
---|
767 | |
---|
768 | (defun %make-function (name fn env) |
---|
769 | (compile-user-function fn name env)) |
---|
770 | |
---|
771 | ;;;;;;;;; VALUE BINDING Functions |
---|
772 | |
---|
773 | (defun gensym (&optional (string-or-integer nil string-or-integer-p)) |
---|
774 | "Creates a new uninterned symbol whose name is a prefix string (defaults |
---|
775 | to \"G\"), followed by a decimal number. Thing, when supplied, will |
---|
776 | alter the prefix if it is a string, or be used for the decimal number |
---|
777 | if it is a number, of this symbol. The default value of the number is |
---|
778 | the current value of *gensym-counter* which is incremented each time |
---|
779 | it is used." |
---|
780 | (let ((prefix "G") |
---|
781 | (counter nil)) |
---|
782 | (when string-or-integer-p |
---|
783 | (etypecase string-or-integer |
---|
784 | (integer (setq counter string-or-integer)) ; & emit-style-warning |
---|
785 | (string (setq prefix (ensure-simple-string string-or-integer))))) |
---|
786 | (unless counter |
---|
787 | (setq *gensym-counter* (1+ (setq counter *gensym-counter*)))) |
---|
788 | (make-symbol (%str-cat prefix (%integer-to-string counter))))) |
---|
789 | |
---|
790 | (defun make-keyword (name) |
---|
791 | (if (and (symbolp name) (eq (symbol-package name) *keyword-package*)) |
---|
792 | name |
---|
793 | (values (intern (string name) *keyword-package*)))) |
---|
794 | |
---|
795 | |
---|
796 | |
---|
797 | |
---|
798 | ; destructive, removes first match only |
---|
799 | (defun remove-from-alist (thing alist) |
---|
800 | (let ((start alist)) |
---|
801 | (if (eq thing (%caar alist)) |
---|
802 | (%cdr alist) |
---|
803 | (let* ((prev start) |
---|
804 | (this (%cdr prev)) |
---|
805 | (next (%cdr this))) |
---|
806 | (while this |
---|
807 | (if (eq thing (%caar this)) |
---|
808 | (progn |
---|
809 | (%rplacd prev next) |
---|
810 | (return-from remove-from-alist start)) |
---|
811 | (setq prev this |
---|
812 | this next |
---|
813 | next (%cdr next)))) |
---|
814 | start)))) |
---|
815 | |
---|
816 | ;destructive |
---|
817 | (defun add-to-alist (thing val alist &aux (pair (assq thing alist))) |
---|
818 | (if pair |
---|
819 | (progn (%rplacd pair thing) alist) |
---|
820 | (cons (cons thing val) alist))) |
---|
821 | |
---|
822 | ;non-destructive... |
---|
823 | (defun alist-adjoin (thing val alist &aux (pair (assq thing alist))) |
---|
824 | (if (and pair (eq (%cdr pair) val)) |
---|
825 | alist |
---|
826 | (cons (cons thing val) alist))) |
---|
827 | |
---|
828 | (defun %str-assoc (str alist) |
---|
829 | (assoc str alist :test #'string-equal)) |
---|
830 | |
---|
831 | (defstatic *pathname-escape-character* |
---|
832 | #+windows-target #\' |
---|
833 | #-windows-target #\\ |
---|
834 | "Not CL. A Coral addition for compatibility between CL spec and the shell.") |
---|
835 | |
---|
836 | |
---|
837 | (defun caar (x) |
---|
838 | "Return the car of the 1st sublist." |
---|
839 | (car (car x))) |
---|
840 | |
---|
841 | (defun cadr (x) |
---|
842 | "Return the 2nd object in a list." |
---|
843 | (car (cdr x))) |
---|
844 | |
---|
845 | (defun cdar (x) |
---|
846 | "Return the cdr of the 1st sublist." |
---|
847 | (cdr (car x))) |
---|
848 | |
---|
849 | (defun cddr (x) |
---|
850 | "Return all but the 1st two objects of a list." |
---|
851 | |
---|
852 | (cdr (cdr x))) |
---|
853 | |
---|
854 | (defun caaar (x) |
---|
855 | "Return the 1st object in the caar of a list." |
---|
856 | (car (car (car x)))) |
---|
857 | |
---|
858 | (defun caadr (x) |
---|
859 | "Return the 1st object in the cadr of a list." |
---|
860 | (car (car (cdr x)))) |
---|
861 | |
---|
862 | (defun cadar (x) |
---|
863 | "Return the car of the cdar of a list." |
---|
864 | (car (cdr (car x)))) |
---|
865 | |
---|
866 | (defun caddr (x) |
---|
867 | "Return the 1st object in the cddr of a list." |
---|
868 | (car (cdr (cdr x)))) |
---|
869 | |
---|
870 | (defun cdaar (x) |
---|
871 | "Return the cdr of the caar of a list." |
---|
872 | (cdr (car (car x)))) |
---|
873 | |
---|
874 | (defun cdadr (x) |
---|
875 | "Return the cdr of the cadr of a list." |
---|
876 | (cdr (car (cdr x)))) |
---|
877 | |
---|
878 | (defun cddar (x) |
---|
879 | "Return the cdr of the cdar of a list." |
---|
880 | (cdr (cdr (car x)))) |
---|
881 | |
---|
882 | (defun cdddr (x) |
---|
883 | "Return the cdr of the cddr of a list." |
---|
884 | (cdr (cdr (cdr x)))) |
---|
885 | |
---|
886 | (defun cadddr (x) |
---|
887 | "Return the car of the cdddr of a list." |
---|
888 | (car (cdr (cdr (cdr x))))) |
---|
889 | |
---|
890 | (%fhave 'type-of #'%type-of) |
---|
891 | |
---|
892 | |
---|
893 | |
---|
894 | (defun pointerp (thing &optional errorp) |
---|
895 | (if (macptrp thing) |
---|
896 | t |
---|
897 | (if errorp (error "~S is not a pointer" thing) nil))) |
---|
898 | |
---|
899 | |
---|
900 | ;Add an item to a dialog items list handle. HUH ? |
---|
901 | (defun %rsc-string (n) |
---|
902 | (or (cdr (assq n *error-format-strings*)) |
---|
903 | (%str-cat "Error #" (%integer-to-string n)))) |
---|
904 | |
---|
905 | (defun string-arg (arg) |
---|
906 | (or (string-argp arg) (error "~S is not a string" arg))) |
---|
907 | |
---|
908 | (defun string-argp (arg) |
---|
909 | (cond ((symbolp arg) (symbol-name arg)) |
---|
910 | ((typep arg 'character) (string arg)) |
---|
911 | ((stringp arg) (ensure-simple-string arg)) |
---|
912 | (t nil))) |
---|
913 | |
---|
914 | (defun symbol-arg (arg) |
---|
915 | (unless (symbolp arg) |
---|
916 | (report-bad-arg arg 'symbol)) |
---|
917 | arg) |
---|
918 | |
---|
919 | (defun %cstrlen (ptr) |
---|
920 | ;;(#_strlen ptr) |
---|
921 | (do* ((i 0 (1+ i))) |
---|
922 | ((zerop (the fixnum (%get-byte ptr i))) i) |
---|
923 | (declare (fixnum i)))) |
---|
924 | |
---|
925 | |
---|
926 | (defun %set-cstring (ptr string) |
---|
927 | (%cstr-pointer string ptr) |
---|
928 | string) |
---|
929 | |
---|
930 | (defsetf %get-cstring %set-cstring) |
---|
931 | |
---|
932 | ;;; Deprecated, but used by UFFI. |
---|
933 | (defun %put-cstring (ptr str &optional (offset 0)) |
---|
934 | (setf (%get-cstring (%inc-ptr ptr offset)) str) |
---|
935 | ;; 0 is the traditional, not-very-useful return value ... |
---|
936 | 0) |
---|
937 | |
---|
938 | |
---|
939 | |
---|
940 | |
---|
941 | |
---|
942 | |
---|
943 | ;;; Returns a simple string and adjusted start and end, such that |
---|
944 | ;;; 0<= start <= end <= (length simple-string). |
---|
945 | (defun get-sstring (str &optional (start 0) (end (length (require-type str 'string)))) |
---|
946 | (multiple-value-bind (sstr offset) (array-data-and-offset (string str)) |
---|
947 | (setq start (+ start offset) end (+ end offset)) |
---|
948 | (when (< (length sstr) end)(setq end (length sstr))) |
---|
949 | (when (< end start) (setq start end)) |
---|
950 | (values sstr start end))) |
---|
951 | |
---|
952 | ;e.g. (bad-named-arg :key key 'function) |
---|
953 | (defun bad-named-arg (name arg &optional (type nil type-p)) |
---|
954 | (if type-p |
---|
955 | (%err-disp $err-bad-named-arg-2 name arg type) |
---|
956 | (%err-disp $err-bad-named-arg name arg))) |
---|
957 | |
---|
958 | (defun verify-arg-count (call min &optional max) |
---|
959 | "If call contains less than MIN number of args, or more than MAX |
---|
960 | number of args, error. Otherwise, return call. |
---|
961 | If Max is NIL, the maximum args for the fn are infinity." |
---|
962 | (or (verify-call-count (car call) (%cdr call) min max) call)) |
---|
963 | |
---|
964 | (defun verify-call-count (sym args min &optional max &aux argcount) |
---|
965 | (if (%i< (setq argcount (list-length args)) min) |
---|
966 | (%err-disp $xtoofew (cons sym args)) |
---|
967 | (if (if max (%i> argcount max)) |
---|
968 | (%err-disp $xtoomany (cons sym args))))) |
---|
969 | |
---|
970 | (defun getf (place key &optional (default ())) |
---|
971 | "Search the property list stored in Place for an indicator EQ to INDICATOR. |
---|
972 | If one is found, return the corresponding value, else return DEFAULT." |
---|
973 | (let ((p (pl-search place key))) (if p (%cadr p) default))) |
---|
974 | |
---|
975 | (defun remprop (symbol key) |
---|
976 | "Look on property list of SYMBOL for property with specified |
---|
977 | INDICATOR. If found, splice this indicator and its value out of |
---|
978 | the plist, and return the tail of the original list starting with |
---|
979 | INDICATOR. If not found, return () with no side effects. |
---|
980 | |
---|
981 | NOTE: The ANSI specification requires REMPROP to return true (not false) |
---|
982 | or false (the symbol NIL). Portable code should not rely on any other value." |
---|
983 | (do* ((prev nil plist) |
---|
984 | (plist (symbol-plist symbol) tail) |
---|
985 | (tail (cddr plist) (cddr tail))) |
---|
986 | ((null plist)) |
---|
987 | (when (eq (car plist) key) |
---|
988 | (if prev |
---|
989 | (rplacd (cdr prev) tail) |
---|
990 | (setf (symbol-plist symbol) tail)) |
---|
991 | (return t)))) |
---|
992 | |
---|
993 | |
---|
994 | |
---|
995 | ;;; If this returns non-nil, safe to do %rplaca of %cdr to update. |
---|
996 | (defun pl-search (plist key) |
---|
997 | (unless (plistp plist) |
---|
998 | (report-bad-arg plist '(satisfies plistp))) |
---|
999 | (%pl-search plist key)) |
---|
1000 | |
---|
1001 | |
---|
1002 | (defun rassoc (item alist &key (test #'eql test-p) test-not (key #'identity)) |
---|
1003 | (declare (list alist)) |
---|
1004 | "Return the cons in ALIST whose CDR is equal (by a given test or EQL) to |
---|
1005 | the ITEM." |
---|
1006 | (if (or test-p (not test-not)) |
---|
1007 | (progn |
---|
1008 | (if test-not (error "Cannot specify both :TEST and :TEST-NOT.")) |
---|
1009 | (dolist (pair alist) |
---|
1010 | (if (atom pair) |
---|
1011 | (if pair (error "Invalid alist containing ~S: ~S" pair alist)) |
---|
1012 | (when (funcall test item (funcall key (cdr pair))) (return pair))))) |
---|
1013 | (progn |
---|
1014 | (unless test-not (error "Must specify at least one of :TEST or :TEST-NOT")) |
---|
1015 | (dolist (pair alist) |
---|
1016 | (if (atom pair) |
---|
1017 | (if pair (error "Invalid alist containing ~S: ~S" pair alist)) |
---|
1018 | (unless (funcall test-not item (funcall key (cdr pair))) (return pair))))))) |
---|
1019 | |
---|
1020 | (defun *%saved-method-var%* () |
---|
1021 | (declare (special %saved-method-var%)) |
---|
1022 | %saved-method-var%) |
---|
1023 | |
---|
1024 | (defun set-*%saved-method-var%* (new-value) |
---|
1025 | (declare (special %saved-method-var%)) |
---|
1026 | (setq %saved-method-var% new-value)) |
---|
1027 | |
---|
1028 | (defsetf *%saved-method-var%* set-*%saved-method-var%*) |
---|
1029 | |
---|
1030 | |
---|
1031 | |
---|
1032 | |
---|
1033 | |
---|
1034 | |
---|
1035 | (setf (symbol-function 'clear-type-cache) #'false) ; bootstrapping |
---|
1036 | |
---|
1037 | (defun make-array-1 (dims element-type element-type-p |
---|
1038 | displaced-to |
---|
1039 | displaced-index-offset |
---|
1040 | adjustable |
---|
1041 | fill-pointer |
---|
1042 | initial-element initial-element-p |
---|
1043 | initial-contents initial-contents-p |
---|
1044 | size) |
---|
1045 | (let ((subtype (element-type-subtype element-type))) |
---|
1046 | (when (and element-type (null subtype)) |
---|
1047 | (error "Unknown element-type ~S" element-type)) |
---|
1048 | (when (null size) |
---|
1049 | (cond ((listp dims) |
---|
1050 | (setq size 1) |
---|
1051 | (dolist (dim dims) |
---|
1052 | (when (< dim 0) |
---|
1053 | (report-bad-arg dim '(integer 0 *))) |
---|
1054 | (setq size (* size dim)))) |
---|
1055 | (t (setq size dims)))) ; no need to check vs. array-dimension-limit |
---|
1056 | (cond |
---|
1057 | (displaced-to |
---|
1058 | (when (or initial-element-p initial-contents-p) |
---|
1059 | (error "Cannot specify initial values for displaced arrays")) |
---|
1060 | (when (and element-type-p |
---|
1061 | (neq (array-element-subtype displaced-to) subtype)) |
---|
1062 | (error "The ~S array ~S is not of ~S ~S" |
---|
1063 | :displaced-to displaced-to :element-type element-type)) |
---|
1064 | (%make-displaced-array dims displaced-to |
---|
1065 | fill-pointer adjustable displaced-index-offset t)) |
---|
1066 | (t |
---|
1067 | (when displaced-index-offset |
---|
1068 | (error "Cannot specify ~S for non-displaced-array" :displaced-index-offset)) |
---|
1069 | (when (null subtype) |
---|
1070 | (error "Cannot make an array of empty type ~S" element-type)) |
---|
1071 | (make-uarray-1 subtype dims adjustable fill-pointer |
---|
1072 | initial-element initial-element-p |
---|
1073 | initial-contents initial-contents-p |
---|
1074 | nil size))))) |
---|
1075 | |
---|
1076 | (defun %make-simple-array (subtype dims) |
---|
1077 | (let* ((size (if (listp dims) (apply #'* dims) dims)) |
---|
1078 | (vector (%alloc-misc size subtype))) |
---|
1079 | (if (and (listp dims) |
---|
1080 | (not (eql (length dims) 1))) |
---|
1081 | (let* ((array (%make-displaced-array dims vector))) |
---|
1082 | (%set-simple-array-p array) |
---|
1083 | array) |
---|
1084 | vector))) |
---|
1085 | |
---|
1086 | (defun make-uarray-1 (subtype dims adjustable fill-pointer |
---|
1087 | initial-element initial-element-p |
---|
1088 | initial-contents initial-contents-p |
---|
1089 | temporary |
---|
1090 | size) |
---|
1091 | (declare (ignore temporary)) |
---|
1092 | (when (null size)(setq size (if (listp dims)(apply #'* dims) dims))) |
---|
1093 | (let ((vector (%alloc-misc size subtype))) ; may not get here in that case |
---|
1094 | (if initial-element-p |
---|
1095 | (dotimes (i (uvsize vector)) (declare (fixnum i))(uvset vector i initial-element)) |
---|
1096 | (if initial-contents-p |
---|
1097 | (if (null dims) (uvset vector 0 initial-contents) |
---|
1098 | (init-uvector-contents vector 0 dims initial-contents)))) |
---|
1099 | (if (and (null fill-pointer) |
---|
1100 | (not adjustable) |
---|
1101 | dims |
---|
1102 | (or (atom dims) (null (%cdr dims)))) |
---|
1103 | vector |
---|
1104 | (let ((array (%make-displaced-array dims vector |
---|
1105 | fill-pointer adjustable nil))) |
---|
1106 | (when (and (null fill-pointer) (not adjustable)) |
---|
1107 | (%set-simple-array-p array)) |
---|
1108 | array)))) |
---|
1109 | |
---|
1110 | (defun init-uvector-contents (vect offset dims contents |
---|
1111 | &aux (len (length contents))) |
---|
1112 | "Returns final offset. Assumes dims not ()." |
---|
1113 | (unless (eq len (if (atom dims) dims (%car dims))) |
---|
1114 | (error "~S doesn't match array dimensions of ~S ." contents vect)) |
---|
1115 | (cond ((or (atom dims) (null (%cdr dims))) |
---|
1116 | (if (listp contents) |
---|
1117 | (let ((contents-tail contents)) |
---|
1118 | (dotimes (i len) |
---|
1119 | (declare (fixnum i)) |
---|
1120 | (uvset vect offset (pop contents-tail)) |
---|
1121 | (setq offset (%i+ offset 1)))) |
---|
1122 | (dotimes (i len) |
---|
1123 | (declare (fixnum i)) |
---|
1124 | (uvset vect offset (elt contents i)) |
---|
1125 | (setq offset (%i+ offset 1))))) |
---|
1126 | (t (setq dims (%cdr dims)) |
---|
1127 | (if (listp contents) |
---|
1128 | (let ((contents-tail contents)) |
---|
1129 | (dotimes (i len) |
---|
1130 | (declare (fixnum i)) |
---|
1131 | (setq offset |
---|
1132 | (init-uvector-contents vect offset dims (pop contents-tail))))) |
---|
1133 | (dotimes (i len) |
---|
1134 | (declare (fixnum i)) |
---|
1135 | (setq offset |
---|
1136 | (init-uvector-contents vect offset dims (elt contents i))))))) |
---|
1137 | offset) |
---|
1138 | |
---|
1139 | (defun %get-signed-long-long (ptr &optional (offset 0)) |
---|
1140 | (%%get-signed-longlong ptr offset)) |
---|
1141 | |
---|
1142 | (defun %set-signed-long-long (ptr arg1 |
---|
1143 | &optional |
---|
1144 | (arg2 (prog1 arg1 (setq arg1 0)))) |
---|
1145 | (%%set-signed-longlong ptr arg1 arg2)) |
---|
1146 | |
---|
1147 | (defun %get-unsigned-long-long (ptr &optional (offset 0)) |
---|
1148 | (%%get-unsigned-longlong ptr offset)) |
---|
1149 | |
---|
1150 | (defun %set-unsigned-long-long (ptr arg1 |
---|
1151 | &optional |
---|
1152 | (arg2 (prog1 arg1 (setq arg1 0)))) |
---|
1153 | (%%set-unsigned-longlong ptr arg1 arg2)) |
---|
1154 | |
---|
1155 | (defun %composite-pointer-ref (size pointer offset) |
---|
1156 | (declare (ignorable size)) |
---|
1157 | (%inc-ptr pointer offset)) |
---|
1158 | |
---|
1159 | (defun %set-composite-pointer-ref (size pointer offset new) |
---|
1160 | (#_memmove (%inc-ptr pointer offset) |
---|
1161 | new |
---|
1162 | size)) |
---|
1163 | |
---|
1164 | |
---|
1165 | (defsetf %composite-pointer-ref %set-composite-pointer-ref) |
---|
1166 | |
---|
1167 | |
---|
1168 | (defsetf pathname-encoding-name set-pathname-encoding-name) |
---|
1169 | |
---|
1170 | ;end of L1-utils.lisp |
---|
1171 | |
---|