From 1149d475d1d4966fde9c204c0cb795c4693d9b30 Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Tue, 10 Apr 2001 22:37:23 +0000 Subject: [PATCH] From Pierre Mai: o All the stuff from cmu-low.lisp has been merged into low.lisp. o Therefore cmu-low.lisp has been removed completely. o All the stuff in low.lisp which either wasn't used in current PCL or was unnecessary in CMU CL, or which was implemented as no-ops for CMU CL has been removed. o Calls in other files to functions which were dropped have been removed. o Source order reorganised a bit and added several comments and doc-strings. o Made `*optimize-speed*' consistent for small and non-small cores, and fixed ordering problem. o Added `*compile-lambda-silent-p*' which when true (the default) will cause compile-lambda to be silent when compiling PCL-generated code. --- pcl/boot.lisp | 3 +- pcl/cmu-low.lisp | 232 --------------------- pcl/defsys.lisp | 4 +- pcl/dfun.lisp | 13 +- pcl/low.lisp | 497 +++++++++++++++++++++------------------------ pcl/std-class.lisp | 5 +- 6 files changed, 245 insertions(+), 509 deletions(-) delete mode 100644 pcl/cmu-low.lisp diff --git a/pcl/boot.lisp b/pcl/boot.lisp index 32f46480f..4ce5f1739 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.24 2001/03/13 15:49:46 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.25 2001/04/10 22:37:21 pw Exp $") (in-package :pcl) @@ -1087,7 +1087,6 @@ work during bootstrapping. (let ((method-spec (or (getf initargs ':method-spec) (make-method-spec name quals specls)))) (setf (getf initargs ':method-spec) method-spec) - (record-definition 'method method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) (defun load-defmethod-internal diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp deleted file mode 100644 index 9ed7b61fd..000000000 --- a/pcl/cmu-low.lisp +++ /dev/null @@ -1,232 +0,0 @@ -;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;; All rights reserved. -;;; -;;; Use and copying of this software and preparation of derivative works -;;; based upon this software are permitted. Any distribution of this -;;; software or derivative works must comply with all applicable United -;;; States export control laws. -;;; -;;; This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any -;;; specification. -;;; -;;; Any person obtaining a copy of this software is requested to send their -;;; name and post office or electronic mail address to: -;;; CommonLoops Coordinator -;;; Xerox PARC -;;; 3333 Coyote Hill Rd. -;;; Palo Alto, CA 94304 -;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) -;;; -;;; Suggestions, comments and requests for improvements are also welcome. -;;; ************************************************************************* -;;; - -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/cmu-low.lisp,v 1.18 1999/05/30 23:13:53 pw Exp $") -;;; -;;; This is the CMU Lisp version of the file low. -;;; - -(in-package :pcl) - -#+small -(setq *optimize-speed* - '(optimize (speed 3) (safety 0) (debug 0.5) (ext:inhibit-warnings 3))) - -(defmacro dotimes ((var count &optional (result nil)) &body body) - `(lisp:dotimes (,var (the fixnum ,count) ,result) - (declare (fixnum ,var)) - ,@body)) - -;;; Just use our without-interrupts. We don't have the INTERRUPTS-ON/OFF local -;;; macros spec'ed in low.lisp, but they aren't used. -;;; -(defmacro without-interrupts (&rest stuff) - `(sys:without-interrupts ,@stuff)) - -(defun function-arglist (fcn) - "Returns the argument list of a compiled function, if possible." - (cond ((symbolp fcn) - (when (fboundp fcn) - (function-arglist (symbol-function fcn)))) - ((eval:interpreted-function-p fcn) - (eval:interpreted-function-arglist fcn)) - ((functionp fcn) - (let ((lambda-expr (function-lambda-expression fcn))) - (if lambda-expr - (cadr lambda-expr) - (let* ((function (kernel:%closure-function fcn)) - (arglist-string (kernel:%function-arglist function))) - (when arglist-string - (values (read-from-string arglist-string))))))))) - -;;; And returns the function, not the *name*. -(defun set-function-name (fcn new-name) - "Set the name of a compiled function object." - (declare (special *boot-state* *the-class-standard-generic-function*)) - (cond ((symbolp fcn) - (set-function-name (symbol-function fcn) new-name)) - ((funcallable-instance-p fcn) - (if (if (eq *boot-state* 'complete) - (typep fcn 'generic-function) - (eq (class-of fcn) *the-class-standard-generic-function*)) - (setf (kernel:%funcallable-instance-info fcn 1) new-name) - (typecase fcn - (kernel:byte-closure - (set-function-name (kernel:byte-closure-function fcn) new-name)) - (kernel:byte-function - (setf (kernel:byte-function-name fcn) new-name)) - (eval:interpreted-function - (setf (eval:interpreted-function-name fcn) new-name)))) - fcn) - (t fcn))) - -(in-package "C") - -(def-source-context pcl:defmethod (name &rest stuff) - (let ((arg-pos (position-if #'listp stuff))) - (if arg-pos - `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos) - ,(nth-value 2 (pcl::parse-specialized-lambda-list - (elt stuff arg-pos)))) - `(pcl:defmethod ,name "<illegal syntax>")))) - - -(in-package "PCL") - -;;;; STD-INSTANCE - -;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate -;;; between functions (including FINs) and normal instances, so we can return -;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p) -;;; are changed to pcl-instance-p. -;;; -(defmacro std-instance-p (x) - `(kernel:%instancep ,x)) - -;;; PCL-INSTANCE-P is implemented via a compiler transform so that the -;;; test can be optimised away when the result is known, such as is -;;; typically the case during slot access within methods, see -;;; get-slots-or-nil below. - -(in-package "C") - -(defknown pcl::pcl-instance-p (t) boolean - (movable foldable flushable explicit-check)) - -(deftransform pcl::pcl-instance-p ((object)) - (let* ((otype (continuation-type object)) - (std-obj (specifier-type 'pcl::std-object))) - (cond - ;; Flush tests whose result is known at compile time. - ((csubtypep otype std-obj) 't) - ((not (types-intersect otype std-obj)) 'nil) - (t - `(typep (kernel:layout-of object) 'pcl::wrapper))))) - -(in-package "PCL") - -;;; Definition for interpreted code. -(defun pcl-instance-p (x) - (typep (kernel:layout-of x) 'wrapper)) - - -;;; We define this as STANDARD-INSTANCE, since we're going to clobber the -;;; layout with some standard-instance layout as soon as we make it, and we -;;; want the accesor to still be type-correct. -;;; -(defstruct (standard-instance - (:predicate nil) - (:constructor %%allocate-instance--class ()) - (:alternate-metaclass kernel:instance lisp:standard-class - kernel:make-standard-class)) - (slots nil)) - -;;; Both of these operations "work" on structures, which allows the above -;;; weakening of std-instance-p. -;;; -(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1)) -(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) - -(defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) - -(defmacro get-wrapper (inst) - (ext:once-only ((wrapper `(wrapper-of ,inst))) - `(progn - (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") - ,wrapper))) - -(defmacro get-instance-wrapper-or-nil (inst) - (ext:once-only ((wrapper `(wrapper-of ,inst))) - `(if (typep ,wrapper 'wrapper) - ,wrapper - nil))) - -;;; get-slots harmless - -(defmacro get-slots-or-nil (inst) - (ext:once-only ((n-inst inst)) - `(when (pcl-instance-p ,n-inst) - (if (std-instance-p ,n-inst) - (std-instance-slots ,n-inst) - (fsc-instance-slots ,n-inst))))) - - -;;;; Structure-instance stuff: - -(defun structure-functions-exist-p () - t) - -(defun structure-instance-p (x) - (typep x 'lisp:structure-object)) - -(defun structurep (x) - (typep x 'lisp:structure-object)) - -(defun structure-type (x) - (lisp:class-name (kernel:layout-class (kernel:%instance-layout x)))) - - -(defun structure-type-p (type) - (and (symbolp type) - (let ((class (lisp:find-class type nil))) - (and class - (typep (kernel:layout-info (kernel:class-layout class)) - 'kernel:defstruct-description))))) - -(defun get-structure-dd (type) - (kernel:layout-info (kernel:class-layout (lisp:find-class type)))) - -(defun structure-type-included-type-name (type) - (let ((include (kernel::dd-include (get-structure-dd type)))) - (if (consp include) - (car include) - include))) - -(defun structure-type-slot-description-list (type) - (nthcdr (length (let ((include (structure-type-included-type-name type))) - (and include (kernel:dd-slots (get-structure-dd include))))) - (kernel:dd-slots (get-structure-dd type)))) - -(defun structure-slotd-name (slotd) - (kernel:dsd-name slotd)) - -(defun structure-slotd-accessor-symbol (slotd) - (kernel:dsd-accessor slotd)) - -(defun structure-slotd-reader-function (slotd) - (fdefinition (kernel:dsd-accessor slotd))) - -(defun structure-slotd-writer-function (slotd) - (unless (kernel:dsd-read-only slotd) - (fdefinition `(setf ,(kernel:dsd-accessor slotd))))) - -(defun structure-slotd-type (slotd) - (kernel:dsd-type slotd)) - -(defun structure-slotd-init-form (slotd) - (kernel::dsd-default slotd)) diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index 28def384a..44343e2c4 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.23 2000/06/14 06:22:25 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.24 2001/04/10 22:37:21 pw Exp $") ;;; ;;; Some support stuff for compiling and loading PCL. It would be nice if ;;; there was some portable make-system we could all agree to share for a @@ -479,8 +479,6 @@ and load your system with: (macros t t ()) (low (pkg macros) t (macros)) - (cmu-low (low) (low) (low) CMU) - (fin t t (low)) (defclass t t (low)) (defs t t (defclass macros iterate)) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index ffc82cb15..86b10b519 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.10 1999/05/30 23:13:56 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.11 2001/04/10 22:37:22 pw Exp $") ;;; (in-package :pcl) @@ -1542,14 +1542,9 @@ And so, we are saved. (generic-function-name generic-function))) (ocache (gf-dfun-cache generic-function))) (set-dfun generic-function dfun cache info) - (let* ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function))) - (info (gf-dfun-info generic-function))) - (unless (eq 'default-method-only (type-of info)) - (setq dfun (doctor-dfun-for-the-debugger - generic-function - dfun))) + (let ((dfun (if early-p + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) (set-funcallable-instance-function generic-function dfun) (set-function-name generic-function gf-name) (when (and ocache (not (eq ocache cache))) (free-cache ocache)) diff --git a/pcl/low.lisp b/pcl/low.lisp index 9460e2e85..f0250529a 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -26,51 +26,23 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.11 1999/05/30 23:14:03 pw Exp $") -;;; -;;; This file contains portable versions of low-level functions and macros -;;; which are ripe for implementation specific customization. None of the -;;; code in this file *has* to be customized for a particular Common Lisp -;;; implementation. Moreover, in some implementations it may not make any -;;; sense to customize some of this code. -;;; -;;; But, experience suggests that MOST Common Lisp implementors will want -;;; to customize some of the code in this file to make PCL run better in -;;; their implementation. The code in this file has been separated and -;;; heavily commented to make that easier. -;;; -;;; Implementation-specific version of this file already exist for: -;;; -;;; Symbolics Genera family genera-low.lisp -;;; Lucid Lisp lucid-low.lisp -;;; Xerox 1100 family xerox-low.lisp -;;; ExCL (Franz) excl-low.lisp -;;; Kyoto Common Lisp kcl-low.lisp -;;; Vaxlisp vaxl-low.lisp -;;; CMU Lisp cmu-low.lisp -;;; H.P. Common Lisp hp-low.lisp -;;; Golden Common Lisp gold-low.lisp -;;; Ti Explorer ti-low.lisp -;;; -;;; -;;; These implementation-specific files are loaded after this file. Because -;;; none of the macros defined by this file are used in functions defined by -;;; this file the implementation-specific files can just contain the parts of -;;; this file they want to change. They don't have to copy this whole file -;;; and then change the parts they want. -;;; -;;; If you make changes or improvements to these files, or if you need some -;;; low-level part of PCL re-modularized to make it more portable to your -;;; system please send mail to CommonLoops.pa@Xerox.com. -;;; -;;; Thanks. -;;; + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.12 2001/04/10 22:37:23 pw Exp $") (in-package :pcl) (eval-when (compile load eval) -(defvar *optimize-speed* '(optimize (speed 3) (safety 0))) -) +(defvar *optimize-speed* + '(optimize (speed 3) (safety 0) (ext:inhibit-warnings 3) #+small (debug 0.5)) + "This variable is used in various places in PCL as an optimization +declaration.")) + +;;; Various macros that include necessary declarations for maximum +;;; performance. + +(defmacro dotimes ((var count &optional (result nil)) &body body) + `(lisp:dotimes (,var (the fixnum ,count) ,result) + (declare (fixnum ,var)) + ,@body)) (defmacro %svref (vector index) `(locally (declare #.*optimize-speed* @@ -85,7 +57,6 @@ (setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value))) - ;;; ;;; without-interrupts ;;; @@ -104,99 +75,42 @@ ;;; ;;; OK? ;;; +;;; For CMU CL we just use our without-interrupts. We don't have the +;;; INTERRUPTS-ON/OFF local macros spec'ed, but they aren't used. +;;; (defmacro without-interrupts (&body body) - `(macrolet ((interrupts-on () ()) - (interrupts-off () ())) - (progn ,.body))) + `(sys:without-interrupts ,@body)) ;;; -;;; Very Low-Level representation of instances with meta-class standard-class. -;;; - -(defmacro %instance-ref (slots index) - `(%svref ,slots ,index)) - -(defmacro instance-ref (slots index) - `(svref ,slots ,index)) - -(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x)) -(defmacro std-instance-slots (x) `(%std-instance-slots ,x)) - -(defmacro get-wrapper (inst) - `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) - ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)) - (t (error "What kind of instance is this?")))) - -(defmacro get-instance-wrapper-or-nil (inst) - `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst)) - ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst)))) - -(defmacro get-slots (inst) - `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) - ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) - (t (error "What kind of instance is this?")))) - -(defmacro get-slots-or-nil (inst) - `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) - ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)))) - -(defun print-std-instance (instance stream depth) ;A temporary definition used - (declare (ignore depth)) ;for debugging the bootstrap - (printing-random-thing (instance stream) ;code of PCL (See high.lisp). - (let ((class (class-of instance))) - (if (or (eq class (find-class 'standard-class nil)) - (eq class (find-class 'funcallable-standard-class nil)) - (eq class (find-class 'built-in-class nil))) - (format stream "~a ~a" (early-class-name class) - (early-class-name instance)) - (format stream "~a" (early-class-name class)))))) - +;;; FUNCTION-ARGLIST ;;; -;;; This is the value that we stick into a slot to tell us that it is unbound. -;;; It may seem gross, but for performance reasons, we make this an interned -;;; symbol. That means that the fast check to see if a slot is unbound is to -;;; say (EQ <val> '..SLOT-UNBOUND..). That is considerably faster than looking -;;; at the value of a special variable. Be careful, there are places in the -;;; code which actually use ..slot-unbound.. rather than this variable. So -;;; much for modularity -;;; -(defconstant *slot-unbound* '..slot-unbound..) - -(defmacro %allocate-static-slot-storage--class (no-of-slots) - `(make-array ,no-of-slots :initial-element *slot-unbound*)) - -(defmacro std-instance-class (instance) - `(wrapper-class* (std-instance-wrapper ,instance))) - - - ;; -;;;;;; FUNCTION-ARGLIST - ;; ;;; Given something which is functionp, function-arglist should return the ;;; argument list for it. PCL does not count on having this available, but -;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of -;;; function-arglist for each specific port of pcl should be put in the -;;; appropriate xxx-low file. This is what it should look like: -;(defun function-arglist (function) -; (<system-dependent-arglist-function> function)) - -(defun function-pretty-arglist (function) - (declare (ignore function)) - ()) - -(defsetf function-pretty-arglist set-function-pretty-arglist) - -(defun set-function-pretty-arglist (function new-value) - (declare (ignore function)) - new-value) +;;; MAKE-SPECIALIZABLE works much better if it is available. + +(defun function-arglist (fcn) + "Returns the argument list of a compiled function, if possible." + (cond ((symbolp fcn) + (when (fboundp fcn) + (function-arglist (symbol-function fcn)))) + ((eval:interpreted-function-p fcn) + (eval:interpreted-function-arglist fcn)) + ((functionp fcn) + (let ((lambda-expr (function-lambda-expression fcn))) + (if lambda-expr + (cadr lambda-expr) + (let* ((function (kernel:%closure-function fcn)) + (arglist-string (kernel:%function-arglist function))) + (when arglist-string + (values (read-from-string arglist-string))))))))) ;;; ;;; set-function-name ;;; When given a function should give this function the name <new-name>. ;;; Note that <new-name> is sometimes a list. Some lisps get the upset ;;; in the tummy when they start thinking about functions which have -;;; lists as names. To deal with that there is set-function-name-intern +;;; lists as names. To deal with that there is intern-function-name ;;; which takes a list spec for a function name and turns it into a symbol ;;; if need be. ;;; @@ -207,16 +121,31 @@ ;;; ;;; In all cases, set-function-name must return the new (or same) function. ;;; -(defun set-function-name (function new-name) - (declare (notinline set-function-name-1 intern-function-name)) - (set-function-name-1 function - (intern-function-name new-name) - new-name)) - -(defun set-function-name-1 (function new-name uninterned-name) - (declare (ignore new-name uninterned-name)) - function) +(defun set-function-name (fcn new-name) + "Set the name of a compiled function object and return the function." + (declare (special *boot-state* *the-class-standard-generic-function*)) + (cond ((symbolp fcn) + (set-function-name (symbol-function fcn) new-name)) + ((funcallable-instance-p fcn) + (if (if (eq *boot-state* 'complete) + (typep fcn 'generic-function) + (eq (class-of fcn) *the-class-standard-generic-function*)) + (setf (kernel:%funcallable-instance-info fcn 1) new-name) + (typecase fcn + (kernel:byte-closure + (set-function-name (kernel:byte-closure-function fcn) + new-name)) + (kernel:byte-function + (setf (kernel:byte-function-name fcn) new-name)) + (eval:interpreted-function + (setf (eval:interpreted-function-name fcn) new-name)))) + fcn) + (t fcn))) +;;; +;;; Note: While we don't need intern-function-name for +;;; set-function-name, this is used in boot.lisp. +;;; (defun intern-function-name (name) (cond ((symbolp name) name) ((listp name) @@ -231,174 +160,222 @@ ;;; ;;; COMPILE-LAMBDA ;;; -;;; This is like the Common Lisp function COMPILE. In fact, that is what -;;; it ends up calling. The difference is that it deals with things like -;;; watching out for recursive calls to the compiler or not calling the -;;; compiler in certain cases or allowing the compiler not to be present. -;;; -;;; This starts out with several variables and support functions which -;;; should be conditionalized for any new port of PCL. Note that these -;;; default to reasonable values, many new ports won't need to look at -;;; these values at all. -;;; -;;; *COMPILER-PRESENT-P* NIL means the compiler is not loaded -;;; -;;; *COMPILER-SPEED* one of :FAST :MEDIUM or :SLOW +;;; This is called by PCL to compile generated code (i.e. lambda +;;; forms). ;;; -;;; *COMPILER-REENTRANT-P* T ==> OK to call compiler recursively -;;; NIL ==> not OK -;;; -;;; function IN-THE-COMPILER-P returns T if in the compiler, NIL otherwise -;;; This is not called if *compiler-reentrant-p* -;;; is T, so it only needs to be implemented for -;;; ports which have non-reentrant compilers. -;;; -;;; -(defvar *compiler-present-p* t) - -(defvar *compiler-speed* :slow) +(defvar *compile-lambda-break-p* nil + "PCL debugging aid that breaks into the debugger each time +`compile-lambda' is invoked.") -(defvar *compiler-reentrant-p* t) +(defvar *compile-lambda-silent-p* t + "If true (the default), then `compile-lambda' will try to silence +the compiler as completely as possible. Currently this means that +`*compile-print*' will be bound to nil during compilation.") -(defun in-the-compiler-p () - ) - -(defvar *compile-lambda-break-p* nil) - -(defun compile-lambda (lambda &optional (desirability :fast)) +(defun compile-lambda (lambda-form) (when *compile-lambda-break-p* (break)) - (cond ((null *compiler-present-p*) - (compile-lambda-uncompiled lambda)) - ((and (null *compiler-reentrant-p*) - (in-the-compiler-p)) - (compile-lambda-deferred lambda)) - ((eq desirability :fast) - (compile nil lambda)) - ((and (eq desirability :medium) - (member *compiler-speed* '(:fast :medium))) - (compile nil lambda)) - ((and (eq desirability :slow) - (eq *compiler-speed* ':fast)) - (compile nil lambda)) - (t - (compile-lambda-uncompiled lambda)))) - -(defun compile-lambda-uncompiled (uncompiled) - #'(lambda (&rest args) (apply (coerce uncompiled 'function) args))) - -(defun compile-lambda-deferred (uncompiled) - (let ((function (coerce uncompiled 'function)) - (compiled nil)) - (declare (type (or function null) compiled)) - #'(lambda (&rest args) - (if compiled - (apply compiled args) - (if (in-the-compiler-p) - (apply function args) - (progn (setq compiled (compile nil uncompiled)) - (apply compiled args))))))) + (let ((*compile-print* (if *compile-lambda-silent-p* nil *compile-print*))) + (compile nil lambda-form))) + +;;; +;;; This macro will precompile various PCL-generated code fragments, +;;; so that those won't have to be compiled lazily at run-time. For +;;; correct usage the invokation of `precompile-random-code-segments' +;;; needs to be put in a file, which is compiled via `compile-file', +;;; and then loaded. +;;; (defmacro precompile-random-code-segments (&optional system) `(progn - (eval-when (compile) + (eval-when (:compile-toplevel) (update-dispatch-dfuns) (compile-iis-functions nil)) (precompile-function-generators ,system) (precompile-dfun-constructors ,system) (precompile-iis-functions ,system) - (eval-when (load) + (eval-when (:load-toplevel) (compile-iis-functions t)))) +;;;; STD-INSTANCE -(defun record-definition (type spec &rest args) - (declare (ignore type spec args)) - ()) +;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate +;;; between functions (including FINs) and normal instances, so we can return +;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p) +;;; are changed to pcl-instance-p. +;;; +(defmacro std-instance-p (x) + `(kernel:%instancep ,x)) -(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) +;;; PCL-INSTANCE-P is implemented via a compiler transform so that the +;;; test can be optimised away when the result is known, such as is +;;; typically the case during slot access within methods, see +;;; get-slots-or-nil below. -;; From braid.lisp +(in-package "C") -(defmacro built-in-or-structure-wrapper (x) - (once-only (x) - (if (structure-functions-exist-p) ; otherwise structurep is too slow for this - `(if (structurep ,x) - (wrapper-for-structure ,x) - (if (symbolp ,x) - (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*) - (built-in-wrapper-of ,x))) - `(or (and (symbolp ,x) - (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) - (built-in-or-structure-wrapper1 ,x))))) +(defknown pcl::pcl-instance-p (t) boolean + (movable foldable flushable explicit-check)) -;Low level functions for structures +(deftransform pcl::pcl-instance-p ((object)) + (let* ((otype (continuation-type object)) + (std-obj (specifier-type 'pcl::std-object))) + (cond + ;; Flush tests whose result is known at compile time. + ((csubtypep otype std-obj) 't) + ((not (types-intersect otype std-obj)) 'nil) + (t + `(typep (kernel:layout-of object) 'pcl::wrapper))))) -;Functions on arbitrary objects +(in-package "PCL") -(defvar *structure-table* (make-hash-table :test 'eq)) +;;; Definition for interpreted code. +(defun pcl-instance-p (x) + (typep (kernel:layout-of x) 'wrapper)) -(defun declare-structure (name included-name slot-description-list) - (setf (gethash name *structure-table*) - (cons included-name slot-description-list))) -(unless (fboundp 'structure-functions-exist-p) - (setf (symbol-function 'structure-functions-exist-p) - #'(lambda () nil))) +;;; We define this as STANDARD-INSTANCE, since we're going to clobber the +;;; layout with some standard-instance layout as soon as we make it, and we +;;; want the accesor to still be type-correct. +;;; +(defstruct (standard-instance + (:predicate nil) + (:constructor %%allocate-instance--class ()) + (:alternate-metaclass kernel:instance lisp:standard-class + kernel:make-standard-class)) + (slots nil)) + +;;; Both of these operations "work" on structures, which allows the above +;;; weakening of std-instance-p. +;;; +(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1)) +(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) -(defun default-structurep (x) - (structure-type-p (type-of x))) +(defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) -(defun default-structure-instance-p (x) - (let ((type (type-of x))) - (and (not (eq type 'std-instance)) - (structure-type-p type)))) +(defmacro get-wrapper (inst) + (ext:once-only ((wrapper `(wrapper-of ,inst))) + `(progn + (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") + ,wrapper))) -(defun default-structure-type (x) - (type-of x)) +(defmacro get-instance-wrapper-or-nil (inst) + (ext:once-only ((wrapper `(wrapper-of ,inst))) + `(if (typep ,wrapper 'wrapper) + ,wrapper + nil))) -(unless (fboundp 'structurep) - (setf (symbol-function 'structurep) #'default-structurep)) +(defmacro get-slots (inst) + `(cond ((std-instance-p ,inst) (std-instance-slots ,inst)) + ((fsc-instance-p ,inst) (fsc-instance-slots ,inst)) + (t (error "What kind of instance is this?")))) -; excludes std-instance -(unless (fboundp 'structure-instance-p) - (setf (symbol-function 'structure-instance-p) #'default-structure-instance-p)) +(defmacro get-slots-or-nil (inst) + (ext:once-only ((n-inst inst)) + `(when (pcl-instance-p ,n-inst) + (if (std-instance-p ,n-inst) + (std-instance-slots ,n-inst) + (fsc-instance-slots ,n-inst))))) -; returns a symbol -(unless (fboundp 'structure-type) - (setf (symbol-function 'structure-type) #'default-structure-type)) +(defun print-std-instance (instance stream depth) ;A temporary definition used + (declare (ignore depth)) ;for debugging the bootstrap + (printing-random-thing (instance stream) ;code of PCL (See high.lisp). + (let ((class (class-of instance))) + (if (or (eq class (find-class 'standard-class nil)) + (eq class (find-class 'funcallable-standard-class nil)) + (eq class (find-class 'built-in-class nil))) + (format stream "~a ~a" (early-class-name class) + (early-class-name instance)) + (format stream "~a" (early-class-name class)))))) + +;;; Slot access itself + +(defmacro %instance-ref (slots index) + `(%svref ,slots ,index)) + +(defmacro instance-ref (slots index) + `(svref ,slots ,index)) + +;;; +;;; This is the value that we stick into a slot to tell us that it is unbound. +;;; It may seem gross, but for performance reasons, we make this an interned +;;; symbol. That means that the fast check to see if a slot is unbound is to +;;; say (EQ <val> '..SLOT-UNBOUND..). That is considerably faster than looking +;;; at the value of a special variable. Be careful, there are places in the +;;; code which actually use ..slot-unbound.. rather than this variable. So +;;; much for modularity. +;;; +;;; Actually at the current point in time it seems that all code now +;;; uses *slot-unbound* instead of ..slot-unbound.. itself. +;;; +(defconstant *slot-unbound* '..slot-unbound..) + + +;;;; Structure-instance stuff: + +(defun structure-instance-p (x) + (typep x 'lisp:structure-object)) +(defun structurep (x) + (typep x 'lisp:structure-object)) -;Functions on symbols naming structures +(defun structure-type (x) + (lisp:class-name (kernel:layout-class (kernel:%instance-layout x)))) -; Excludes structures types created with the :type option -(defun structure-type-p (symbol) - (not (null (gethash symbol *structure-table*)))) -(defun structure-type-included-type-name (symbol) - (car (gethash symbol *structure-table*))) +(defun structure-type-p (type) + (and (symbolp type) + (let ((class (lisp:find-class type nil))) + (and class + (typep (kernel:layout-info (kernel:class-layout class)) + 'kernel:defstruct-description))))) -; direct slots only -; The results of this function are used only by the functions below. -(defun structure-type-slot-description-list (symbol) - (cdr (gethash symbol *structure-table*))) +(defun get-structure-dd (type) + (kernel:layout-info (kernel:class-layout (lisp:find-class type)))) +(defun structure-type-included-type-name (type) + (let ((include (kernel::dd-include (get-structure-dd type)))) + (if (consp include) + (car include) + include))) -;Functions on slot-descriptions (returned by the function above) +(defun structure-type-slot-description-list (type) + (nthcdr (length (let ((include (structure-type-included-type-name type))) + (and include (kernel:dd-slots (get-structure-dd include))))) + (kernel:dd-slots (get-structure-dd type)))) -;returns a symbol -(defun structure-slotd-name (structure-slot-description) - (first structure-slot-description)) +(defun structure-slotd-name (slotd) + (kernel:dsd-name slotd)) -;returns a symbol -(defun structure-slotd-accessor-symbol (structure-slot-description) - (second structure-slot-description)) +(defun structure-slotd-accessor-symbol (slotd) + (kernel:dsd-accessor slotd)) -;returns a symbol or a list or nil -(defun structure-slotd-writer-function (structure-slot-description) - (third structure-slot-description)) +(defun structure-slotd-reader-function (slotd) + (fdefinition (kernel:dsd-accessor slotd))) + +(defun structure-slotd-writer-function (slotd) + (unless (kernel:dsd-read-only slotd) + (fdefinition `(setf ,(kernel:dsd-accessor slotd))))) + +(defun structure-slotd-type (slotd) + (kernel:dsd-type slotd)) + +(defun structure-slotd-init-form (slotd) + (kernel::dsd-default slotd)) + + +;;; +;;; Extractor for source context information, which is used by the +;;; compiler to indicate progress and context information for error +;;; reporting. +;;; -(defun structure-slotd-type (structure-slot-description) - (fourth structure-slot-description)) +(in-package "C") -(defun structure-slotd-init-form (structure-slot-description) - (fifth structure-slot-description)) +(def-source-context pcl:defmethod (name &rest stuff) + (let ((arg-pos (position-if #'listp stuff))) + (if arg-pos + `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos) + ,(nth-value 2 (pcl::parse-specialized-lambda-list + (elt stuff arg-pos)))) + `(pcl:defmethod ,name "<illegal syntax>")))) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index c68996944..78df6671b 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.26 2000/08/03 16:58:56 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.27 2001/04/10 22:37:23 pw Exp $") ;;; (in-package :pcl) @@ -550,8 +550,7 @@ (defstruct-form `(progn ,defstruct - ,@readers-init ,@writers-init - (declare-structure ',name nil nil)))) + ,@readers-init ,@writers-init))) (unless (structure-type-p name) (eval defstruct-form)) (mapc #'(lambda (dslotd reader-name writer-name) (let* ((reader (gdefinition reader-name)) -- GitLab