/[gcl]/gcl/pcl/gcl_pcl_low.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_low.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
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))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26