1
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
3
;;; *************************************************************************
4
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5
;;; All rights reserved.
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.
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
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
20
;;; 3333 Coyote Hill Rd.
21
;;; Palo Alto, CA 94304
22
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
24
;;; Suggestions, comments and requests for improvements are also welcome.
25
;;; *************************************************************************
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.
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.
38
;;; Implementation-specific version of this file already exist for:
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
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.
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.
67
(eval-when (compile load eval)
68
(defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
71
(defmacro %svref (vector index)
72
`(locally (declare #.*optimize-speed*
74
(svref (the simple-vector ,vector) (the fixnum ,index))))
76
(defsetf %svref %set-svref)
78
(defmacro %set-svref (vector index new-value)
79
`(locally (declare #.*optimize-speed*
81
(setf (svref (the simple-vector ,vector) (the fixnum ,index))
86
;;; without-interrupts
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:
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.
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.
103
(defmacro without-interrupts (&body body)
104
`(macrolet ((interrupts-on () ())
105
(interrupts-off () ()))
110
;;; Very Low-Level representation of instances with meta-class standard-class.
115
(defstruct (std-instance (:predicate std-instance-p)
116
(:conc-name %std-instance-)
117
(:constructor %%allocate-instance--class ())
118
(:print-function print-std-instance))
122
(defmacro %instance-ref (slots index)
123
`(%svref ,slots ,index))
125
(defmacro instance-ref (slots index)
126
`(svref ,slots ,index))
131
(defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t
132
:initial-element nil))
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)))
140
(aref *init-vector* (1- (fill-pointer *init-vector*))))
143
(defmacro %std-instance-wrapper (instance)
144
`(structure-def ,instance))
146
(defmacro %std-instance-slots (instance)
149
(defmacro std-instance-p (x)
153
(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x))
154
(defmacro std-instance-slots (x) `(%std-instance-slots ,x))
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?"))))
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))))
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?"))))
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))))
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))))))
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
194
(defvar *slot-unbound* '..slot-unbound..)
196
(defmacro %allocate-static-slot-storage--class (no-of-slots)
197
#+new-kcl-wrapper (declare (ignore no-of-slots))
199
`(make-array ,no-of-slots :initial-element *slot-unbound*)
201
(error "don't call this"))
203
(defmacro std-instance-class (instance)
204
`(wrapper-class* (std-instance-wrapper ,instance)))
208
;;;;;; FUNCTION-ARGLIST
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))
218
(defun function-pretty-arglist (function)
219
(declare (ignore function))
222
(defsetf function-pretty-arglist set-function-pretty-arglist)
224
(defun set-function-pretty-arglist (function new-value)
225
(declare (ignore function))
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
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.
242
;;; In all cases, set-function-name must return the new (or same) function.
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)
250
(defun set-function-name-1 (function new-name uninterned-name)
251
(declare (ignore new-name uninterned-name))
254
(defun intern-function-name (name)
255
(cond ((symbolp name) name)
257
(intern (let ((*package* *the-pcl-package*)
258
(*print-case* :upcase)
261
(format nil "~S" name))
262
*the-pcl-package*))))
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.
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.
278
;;; *COMPILER-PRESENT-P* NIL means the compiler is not loaded
280
;;; *COMPILER-SPEED* one of :FAST :MEDIUM or :SLOW
282
;;; *COMPILER-REENTRANT-P* T ==> OK to call compiler recursively
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.
291
(defvar *compiler-present-p* t)
293
(defvar *compiler-speed*
294
#+(or KCL IBCL GCLisp CMU) :slow
295
#-(or KCL IBCL GCLisp CMU) :fast)
297
(defvar *compiler-reentrant-p*
298
#+(and (not XKCL) (or KCL IBCL)) nil
299
#-(and (not XKCL) (or KCL IBCL)) t)
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)
306
(defvar *compile-lambda-break-p* nil)
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*)
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))
324
(compile-lambda-uncompiled lambda))))
326
(defun compile-lambda-uncompiled (uncompiled)
327
#'(lambda (&rest args) (apply (coerce uncompiled 'function) args)))
329
(defun compile-lambda-deferred (uncompiled)
330
(let ((function (coerce uncompiled 'function))
332
(declare (type (or function null) compiled))
333
#'(lambda (&rest args)
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)))))))
341
(defmacro precompile-random-code-segments (&optional system)
344
(update-dispatch-dfuns)
345
(compile-iis-functions nil))
346
(precompile-function-generators ,system)
347
(precompile-dfun-constructors ,system)
348
(precompile-iis-functions ,system)
350
(compile-iis-functions t))))
354
(defun record-definition (type spec &rest args)
355
(declare (ignore type spec args))
358
(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
362
(defmacro built-in-or-structure-wrapper (x)
364
(if (structure-functions-exist-p) ; otherwise structurep is too slow for this
366
(wrapper-for-structure ,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)))))
375
(defmacro wrapper-of-macro (x)
376
`(cond ((std-instance-p ,x)
377
(std-instance-wrapper ,x))
379
(fsc-instance-wrapper ,x))
381
(#+new-kcl-wrapper built-in-wrapper-of
382
#-new-kcl-wrapper built-in-or-structure-wrapper
386
(defmacro wrapper-of-macro (x)
387
`(kernel:layout-of ,x))
389
;Low level functions for structures
391
;Functions on arbitrary objects
393
(defvar *structure-table* (make-hash-table :test 'eq))
395
(defun declare-structure (name included-name slot-description-list)
396
(setf (gethash name *structure-table*)
397
(cons included-name slot-description-list)))
399
(unless (fboundp 'structure-functions-exist-p)
400
(setf (symbol-function 'structure-functions-exist-p)
403
(defun default-structurep (x)
404
(structure-type-p (type-of x)))
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))))
411
(defun default-structure-type (x)
414
(unless (fboundp 'structurep)
415
(setf (symbol-function 'structurep) #'default-structurep))
417
; excludes std-instance
418
(unless (fboundp 'structure-instance-p)
419
(setf (symbol-function 'structure-instance-p) #'default-structure-instance-p))
422
(unless (fboundp 'structure-type)
423
(setf (symbol-function 'structure-type) #'default-structure-type))
426
;Functions on symbols naming structures
428
; Excludes structures types created with the :type option
429
(defun structure-type-p (symbol)
430
(not (null (gethash symbol *structure-table*))))
432
(defun structure-type-included-type-name (symbol)
433
(car (gethash symbol *structure-table*)))
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*)))
441
;Functions on slot-descriptions (returned by the function above)
444
(defun structure-slotd-name (structure-slot-description)
445
(first structure-slot-description))
448
(defun structure-slotd-accessor-symbol (structure-slot-description)
449
(second structure-slot-description))
451
;returns a symbol or a list or nil
452
(defun structure-slotd-writer-function (structure-slot-description)
453
(third structure-slot-description))
455
(defun structure-slotd-type (structure-slot-description)
456
(fourth structure-slot-description))
458
(defun structure-slotd-init-form (structure-slot-description)
459
(fifth structure-slot-description))
added
removed
pcl/pcl_low.lisp
