1 |
|
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
;;; This file contains portable versions of low-level functions and macros |
28 |
|
;;; which are ripe for implementation specific customization. None of the |
29 |
|
;;; code in this file *has* to be customized for a particular Common Lisp |
30 |
|
;;; implementation. Moreover, in some implementations it may not make any |
31 |
|
;;; sense to customize some of this code. |
32 |
|
;;; |
33 |
|
;;; But, experience suggests that MOST Common Lisp implementors will want |
34 |
|
;;; to customize some of the code in this file to make PCL run better in |
35 |
|
;;; their implementation. The code in this file has been separated and |
36 |
|
;;; heavily commented to make that easier. |
37 |
|
;;; |
38 |
|
;;; Implementation-specific version of this file already exist for: |
39 |
|
;;; |
40 |
|
;;; Symbolics Genera family genera-low.lisp |
41 |
|
;;; Lucid Lisp lucid-low.lisp |
42 |
|
;;; Xerox 1100 family xerox-low.lisp |
43 |
|
;;; ExCL (Franz) excl-low.lisp |
44 |
|
;;; Kyoto Common Lisp kcl-low.lisp |
45 |
|
;;; Vaxlisp vaxl-low.lisp |
46 |
|
;;; CMU Lisp cmu-low.lisp |
47 |
|
;;; H.P. Common Lisp hp-low.lisp |
48 |
|
;;; Golden Common Lisp gold-low.lisp |
49 |
|
;;; Ti Explorer ti-low.lisp |
50 |
|
;;; |
51 |
|
;;; |
52 |
|
;;; These implementation-specific files are loaded after this file. Because |
53 |
|
;;; none of the macros defined by this file are used in functions defined by |
54 |
|
;;; this file the implementation-specific files can just contain the parts of |
55 |
|
;;; this file they want to change. They don't have to copy this whole file |
56 |
|
;;; and then change the parts they want. |
57 |
|
;;; |
58 |
|
;;; If you make changes or improvements to these files, or if you need some |
59 |
|
;;; low-level part of PCL re-modularized to make it more portable to your |
60 |
|
;;; system please send mail to CommonLoops.pa@Xerox.com. |
61 |
|
;;; |
62 |
|
;;; Thanks. |
63 |
|
;;; |
64 |
|
|
65 |
|
(in-package :pcl) |
66 |
|
|
67 |
|
(eval-when (compile load eval) |
68 |
|
(defvar *optimize-speed* '(optimize (speed 3) (safety 0))) |
69 |
|
) |
70 |
|
|
71 |
|
(defmacro %svref (vector index) |
72 |
|
`(locally (declare #.*optimize-speed* |
73 |
|
(inline svref)) |
74 |
|
(svref (the simple-vector ,vector) (the fixnum ,index)))) |
75 |
|
|
76 |
|
(defsetf %svref %set-svref) |
77 |
|
|
78 |
|
(defmacro %set-svref (vector index new-value) |
79 |
|
`(locally (declare #.*optimize-speed* |
80 |
|
(inline svref)) |
81 |
|
(setf (svref (the simple-vector ,vector) (the fixnum ,index)) |
82 |
|
,new-value))) |
83 |
|
|
84 |
|
|
85 |
|
;;; |
86 |
|
;;; without-interrupts |
87 |
|
;;; |
88 |
|
;;; OK, Common Lisp doesn't have this and for good reason. But For all of |
89 |
|
;;; the Common Lisp's that PCL runs on today, there is a meaningful way to |
90 |
|
;;; implement this. WHAT I MEAN IS: |
91 |
|
;;; |
92 |
|
;;; I want the body to be evaluated in such a way that no other code that is |
93 |
|
;;; running PCL can be run during that evaluation. I agree that the body |
94 |
|
;;; won't take *long* to evaluate. That is to say that I will only use |
95 |
|
;;; without interrupts around relatively small computations. |
96 |
|
;;; |
97 |
|
;;; INTERRUPTS-ON should turn interrupts back on if they were on. |
98 |
|
;;; INTERRUPTS-OFF should turn interrupts back off. |
99 |
|
;;; These are only valid inside the body of WITHOUT-INTERRUPTS. |
100 |
|
;;; |
101 |
|
;;; OK? |
102 |
|
;;; |
103 |
|
(defmacro without-interrupts (&body body) |
104 |
|
`(macrolet ((interrupts-on () ()) |
105 |
|
(interrupts-off () ())) |
106 |
|
(progn ,.body))) |
107 |
|
|
108 |
|
|
109 |
|
;;; |
110 |
|
;;; Very Low-Level representation of instances with meta-class standard-class. |
111 |
|
;;; |
112 |
|
#-new-kcl-wrapper |
113 |
|
(progn |
114 |
|
#-cmu17 |
115 |
|
(defstruct (std-instance (:predicate std-instance-p) |
116 |
|
(:conc-name %std-instance-) |
117 |
|
(:constructor %%allocate-instance--class ()) |
118 |
|
(:print-function print-std-instance)) |
119 |
|
(wrapper nil) |
120 |
|
(slots nil)) |
121 |
|
|
122 |
|
(defmacro %instance-ref (slots index) |
123 |
|
`(%svref ,slots ,index)) |
124 |
|
|
125 |
|
(defmacro instance-ref (slots index) |
126 |
|
`(svref ,slots ,index)) |
127 |
|
) |
128 |
|
|
129 |
|
#+new-kcl-wrapper |
130 |
|
(progn |
131 |
|
(defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t |
132 |
|
:initial-element nil)) |
133 |
|
|
134 |
|
(defun get-init-list (i) |
135 |
|
(declare (fixnum i)(special *slot-unbound*)) |
136 |
|
(loop (when (< i (fill-pointer *init-vector*)) |
137 |
|
(return (aref *init-vector* i))) |
138 |
|
(vector-push-extend |
139 |
|
(cons *slot-unbound* |
140 |
|
(aref *init-vector* (1- (fill-pointer *init-vector*)))) |
141 |
|
*init-vector*))) |
142 |
|
|
143 |
|
(defmacro %std-instance-wrapper (instance) |
144 |
|
`(structure-def ,instance)) |
145 |
|
|
146 |
|
(defmacro %std-instance-slots (instance) |
147 |
|
instance) |
148 |
|
|
149 |
|
(defmacro std-instance-p (x) |
150 |
|
`(structurep ,x)) |
151 |
|
) |
152 |
|
|
153 |
|
(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x)) |
154 |
|
(defmacro std-instance-slots (x) `(%std-instance-slots ,x)) |
155 |
|
|
156 |
|
(defmacro get-wrapper (inst) |
157 |
|
`(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) |
158 |
|
((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)) |
159 |
|
(t (error "What kind of instance is this?")))) |
160 |
|
|
161 |
|
(defmacro get-instance-wrapper-or-nil (inst) |
162 |
|
`(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) |
163 |
|
((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)))) |
164 |
|
|
165 |
|
(defmacro get-slots (inst) |
166 |
|
`(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) |
167 |
|
((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) |
168 |
|
(t (error "What kind of instance is this?")))) |
169 |
|
|
170 |
|
(defmacro get-slots-or-nil (inst) |
171 |
|
`(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) |
172 |
|
((fsc-instance-p ,inst) (fsc-instance-slots ,inst)))) |
173 |
|
|
174 |
|
(defun print-std-instance (instance stream depth) ;A temporary definition used |
175 |
|
(declare (ignore depth)) ;for debugging the bootstrap |
176 |
|
(printing-random-thing (instance stream) ;code of PCL (See high.lisp). |
177 |
|
(let ((class (class-of instance))) |
178 |
|
(if (or (eq class (find-class 'standard-class nil)) |
179 |
|
(eq class (find-class 'funcallable-standard-class nil)) |
180 |
|
(eq class (find-class 'built-in-class nil))) |
181 |
|
(format stream "~a ~a" (early-class-name class) |
182 |
|
(early-class-name instance)) |
183 |
|
(format stream "~a" (early-class-name class)))))) |
184 |
|
|
185 |
|
;;; |
186 |
|
;;; This is the value that we stick into a slot to tell us that it is unbound. |
187 |
|
;;; It may seem gross, but for performance reasons, we make this an interned |
188 |
|
;;; symbol. That means that the fast check to see if a slot is unbound is to |
189 |
|
;;; say (EQ <val> '..SLOT-UNBOUND..). That is considerably faster than looking |
190 |
|
;;; at the value of a special variable. Be careful, there are places in the |
191 |
|
;;; code which actually use ..slot-unbound.. rather than this variable. So |
192 |
|
;;; much for modularity |
193 |
|
;;; |
194 |
|
(defvar *slot-unbound* '..slot-unbound..) |
195 |
|
|
196 |
|
(defmacro %allocate-static-slot-storage--class (no-of-slots) |
197 |
|
#+new-kcl-wrapper (declare (ignore no-of-slots)) |
198 |
|
#-new-kcl-wrapper |
199 |
|
`(make-array ,no-of-slots :initial-element *slot-unbound*) |
200 |
|
#+new-kcl-wrapper |
201 |
|
(error "don't call this")) |
202 |
|
|
203 |
|
(defmacro std-instance-class (instance) |
204 |
|
`(wrapper-class* (std-instance-wrapper ,instance))) |
205 |
|
|
206 |
|
|
207 |
|
;; |
208 |
|
;;;;;; FUNCTION-ARGLIST |
209 |
|
;; |
210 |
|
;;; Given something which is functionp, function-arglist should return the |
211 |
|
;;; argument list for it. PCL does not count on having this available, but |
212 |
|
;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of |
213 |
|
;;; function-arglist for each specific port of pcl should be put in the |
214 |
|
;;; appropriate xxx-low file. This is what it should look like: |
215 |
|
;(defun function-arglist (function) |
216 |
|
; (<system-dependent-arglist-function> function)) |
217 |
|
|
218 |
|
(defun function-pretty-arglist (function) |
219 |
|
(declare (ignore function)) |
220 |
|
()) |
221 |
|
|
222 |
|
(defsetf function-pretty-arglist set-function-pretty-arglist) |
223 |
|
|
224 |
|
(defun set-function-pretty-arglist (function new-value) |
225 |
|
(declare (ignore function)) |
226 |
|
new-value) |
227 |
|
|
228 |
|
;;; |
229 |
|
;;; set-function-name |
230 |
|
;;; When given a function should give this function the name <new-name>. |
231 |
|
;;; Note that <new-name> is sometimes a list. Some lisps get the upset |
232 |
|
;;; in the tummy when they start thinking about functions which have |
233 |
|
;;; lists as names. To deal with that there is set-function-name-intern |
234 |
|
;;; which takes a list spec for a function name and turns it into a symbol |
235 |
|
;;; if need be. |
236 |
|
;;; |
237 |
|
;;; When given a funcallable instance, set-function-name MUST side-effect |
238 |
|
;;; that FIN to give it the name. When given any other kind of function |
239 |
|
;;; set-function-name is allowed to return new function which is the 'same' |
240 |
|
;;; except that it has the name. |
241 |
|
;;; |
242 |
|
;;; In all cases, set-function-name must return the new (or same) function. |
243 |
|
;;; |
244 |
|
(defun set-function-name (function new-name) |
245 |
|
(declare (notinline set-function-name-1 intern-function-name)) |
246 |
|
(set-function-name-1 function |
247 |
|
(intern-function-name new-name) |
248 |
|
new-name)) |
249 |
|
|
250 |
|
(defun set-function-name-1 (function new-name uninterned-name) |
251 |
|
(declare (ignore new-name uninterned-name)) |
252 |
|
function) |
253 |
|
|
254 |
|
(defun intern-function-name (name) |
255 |
|
(cond ((symbolp name) name) |
256 |
|
((listp name) |
257 |
|
(intern (let ((*package* *the-pcl-package*) |
258 |
|
(*print-case* :upcase) |
259 |
|
(*print-pretty* nil) |
260 |
|
(*print-gensym* 't)) |
261 |
|
(format nil "~S" name)) |
262 |
|
*the-pcl-package*)))) |
263 |
|
|
264 |
|
|
265 |
|
;;; |
266 |
|
;;; COMPILE-LAMBDA |
267 |
|
;;; |
268 |
|
;;; This is like the Common Lisp function COMPILE. In fact, that is what |
269 |
|
;;; it ends up calling. The difference is that it deals with things like |
270 |
|
;;; watching out for recursive calls to the compiler or not calling the |
271 |
|
;;; compiler in certain cases or allowing the compiler not to be present. |
272 |
|
;;; |
273 |
|
;;; This starts out with several variables and support functions which |
274 |
|
;;; should be conditionalized for any new port of PCL. Note that these |
275 |
|
;;; default to reasonable values, many new ports won't need to look at |
276 |
|
;;; these values at all. |
277 |
|
;;; |
278 |
|
;;; *COMPILER-PRESENT-P* NIL means the compiler is not loaded |
279 |
|
;;; |
280 |
|
;;; *COMPILER-SPEED* one of :FAST :MEDIUM or :SLOW |
281 |
|
;;; |
282 |
|
;;; *COMPILER-REENTRANT-P* T ==> OK to call compiler recursively |
283 |
|
;;; NIL ==> not OK |
284 |
|
;;; |
285 |
|
;;; function IN-THE-COMPILER-P returns T if in the compiler, NIL otherwise |
286 |
|
;;; This is not called if *compiler-reentrant-p* |
287 |
|
;;; is T, so it only needs to be implemented for |
288 |
|
;;; ports which have non-reentrant compilers. |
289 |
|
;;; |
290 |
|
;;; |
291 |
|
(defvar *compiler-present-p* t) |
292 |
|
|
293 |
|
(defvar *compiler-speed* |
294 |
|
#+(or KCL IBCL GCLisp CMU) :slow |
295 |
|
#-(or KCL IBCL GCLisp CMU) :fast) |
296 |
|
|
297 |
|
(defvar *compiler-reentrant-p* |
298 |
|
#+(and (not XKCL) (or KCL IBCL)) nil |
299 |
|
#-(and (not XKCL) (or KCL IBCL)) t) |
300 |
|
|
301 |
|
(defun in-the-compiler-p () |
302 |
|
#+(and (not xkcl) (or KCL IBCL))compiler::*compiler-in-use* |
303 |
|
#+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure) |
304 |
|
) |
305 |
|
|
306 |
|
(defvar *compile-lambda-break-p* nil) |
307 |
|
|
308 |
|
(defun compile-lambda (lambda &optional (desirability :fast)) |
309 |
|
(when *compile-lambda-break-p* (break)) |
310 |
|
(cond ((null *compiler-present-p*) |
311 |
|
(compile-lambda-uncompiled lambda)) |
312 |
|
((and (null *compiler-reentrant-p*) |
313 |
|
(in-the-compiler-p)) |
314 |
|
(compile-lambda-deferred lambda)) |
315 |
|
((eq desirability :fast) |
316 |
|
(compile nil lambda)) |
317 |
|
((and (eq desirability :medium) |
318 |
|
(member *compiler-speed* '(:fast :medium))) |
319 |
|
(compile nil lambda)) |
320 |
|
((and (eq desirability :slow) |
321 |
|
(eq *compiler-speed* ':fast)) |
322 |
|
(compile nil lambda)) |
323 |
|
(t |
324 |
|
(compile-lambda-uncompiled lambda)))) |
325 |
|
|
326 |
|
(defun compile-lambda-uncompiled (uncompiled) |
327 |
|
#'(lambda (&rest args) (apply (coerce uncompiled 'function) args))) |
328 |
|
|
329 |
|
(defun compile-lambda-deferred (uncompiled) |
330 |
|
(let ((function (coerce uncompiled 'function)) |
331 |
|
(compiled nil)) |
332 |
|
(declare (type (or function null) compiled)) |
333 |
|
#'(lambda (&rest args) |
334 |
|
(if compiled |
335 |
|
(apply compiled args) |
336 |
|
(if (in-the-compiler-p) |
337 |
|
(apply function args) |
338 |
|
(progn (setq compiled (compile nil uncompiled)) |
339 |
|
(apply compiled args))))))) |
340 |
|
|
341 |
|
(defmacro precompile-random-code-segments (&optional system) |
342 |
|
`(progn |
343 |
|
(eval-when (compile) |
344 |
|
(update-dispatch-dfuns) |
345 |
|
(compile-iis-functions nil)) |
346 |
|
(precompile-function-generators ,system) |
347 |
|
(precompile-dfun-constructors ,system) |
348 |
|
(precompile-iis-functions ,system) |
349 |
|
(eval-when (load) |
350 |
|
(compile-iis-functions t)))) |
351 |
|
|
352 |
|
|
353 |
|
|
354 |
|
(defun record-definition (type spec &rest args) |
355 |
|
(declare (ignore type spec args)) |
356 |
|
()) |
357 |
|
|
358 |
|
(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) |
359 |
|
|
360 |
|
;; From braid.lisp |
361 |
|
#-new-kcl-wrapper |
362 |
|
(defmacro built-in-or-structure-wrapper (x) |
363 |
|
(once-only (x) |
364 |
|
(if (structure-functions-exist-p) ; otherwise structurep is too slow for this |
365 |
|
`(if (structurep ,x) |
366 |
|
(wrapper-for-structure ,x) |
367 |
|
(if (symbolp ,x) |
368 |
|
(if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) |
369 |
|
(built-in-wrapper-of ,x))) |
370 |
|
`(or (and (symbolp ,x) |
371 |
|
(if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) |
372 |
|
(built-in-or-structure-wrapper1 ,x))))) |
373 |
|
|
374 |
|
#-cmu17 |
375 |
|
(defmacro wrapper-of-macro (x) |
376 |
|
`(cond ((std-instance-p ,x) |
377 |
|
(std-instance-wrapper ,x)) |
378 |
|
((fsc-instance-p ,x) |
379 |
|
(fsc-instance-wrapper ,x)) |
380 |
|
(t |
381 |
|
(#+new-kcl-wrapper built-in-wrapper-of |
382 |
|
#-new-kcl-wrapper built-in-or-structure-wrapper |
383 |
|
,x)))) |
384 |
|
|
385 |
|
#+cmu17 |
386 |
|
(defmacro wrapper-of-macro (x) |
387 |
|
`(kernel:layout-of ,x)) |
388 |
|
|
389 |
|
;Low level functions for structures |
390 |
|
|
391 |
|
;Functions on arbitrary objects |
392 |
|
|
393 |
|
(defvar *structure-table* (make-hash-table :test 'eq)) |
394 |
|
|
395 |
|
(defun declare-structure (name included-name slot-description-list) |
396 |
|
(setf (gethash name *structure-table*) |
397 |
|
(cons included-name slot-description-list))) |
398 |
|
|
399 |
|
(unless (fboundp 'structure-functions-exist-p) |
400 |
|
(setf (symbol-function 'structure-functions-exist-p) |
401 |
|
#'(lambda () nil))) |
402 |
|
|
403 |
|
(defun default-structurep (x) |
404 |
|
(structure-type-p (type-of x))) |
405 |
|
|
406 |
|
(defun default-structure-instance-p (x) |
407 |
|
(let ((type (type-of x))) |
408 |
|
(and (not (eq type 'std-instance)) |
409 |
|
(structure-type-p type)))) |
410 |
|
|
411 |
|
(defun default-structure-type (x) |
412 |
|
(type-of x)) |
413 |
|
|
414 |
|
(unless (fboundp 'structurep) |
415 |
|
(setf (symbol-function 'structurep) #'default-structurep)) |
416 |
|
|
417 |
|
; excludes std-instance |
418 |
|
(unless (fboundp 'structure-instance-p) |
419 |
|
(setf (symbol-function 'structure-instance-p) #'default-structure-instance-p)) |
420 |
|
|
421 |
|
; returns a symbol |
422 |
|
(unless (fboundp 'structure-type) |
423 |
|
(setf (symbol-function 'structure-type) #'default-structure-type)) |
424 |
|
|
425 |
|
|
426 |
|
;Functions on symbols naming structures |
427 |
|
|
428 |
|
; Excludes structures types created with the :type option |
429 |
|
(defun structure-type-p (symbol) |
430 |
|
(not (null (gethash symbol *structure-table*)))) |
431 |
|
|
432 |
|
(defun structure-type-included-type-name (symbol) |
433 |
|
(car (gethash symbol *structure-table*))) |
434 |
|
|
435 |
|
; direct slots only |
436 |
|
; The results of this function are used only by the functions below. |
437 |
|
(defun structure-type-slot-description-list (symbol) |
438 |
|
(cdr (gethash symbol *structure-table*))) |
439 |
|
|
440 |
|
|
441 |
|
;Functions on slot-descriptions (returned by the function above) |
442 |
|
|
443 |
|
;returns a symbol |
444 |
|
(defun structure-slotd-name (structure-slot-description) |
445 |
|
(first structure-slot-description)) |
446 |
|
|
447 |
|
;returns a symbol |
448 |
|
(defun structure-slotd-accessor-symbol (structure-slot-description) |
449 |
|
(second structure-slot-description)) |
450 |
|
|
451 |
|
;returns a symbol or a list or nil |
452 |
|
(defun structure-slotd-writer-function (structure-slot-description) |
453 |
|
(third structure-slot-description)) |
454 |
|
|
455 |
|
(defun structure-slotd-type (structure-slot-description) |
456 |
|
(fourth structure-slot-description)) |
457 |
|
|
458 |
|
(defun structure-slotd-init-form (structure-slot-description) |
459 |
|
(fifth structure-slot-description)) |