diff --git a/pcl/boot.lisp b/pcl/boot.lisp index 99daa34ef18f215fc01e85fe4e2b7266498713a0..008967825e514bf1aba17600f1c03da1d8addf16 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.19 1999/03/14 01:14:13 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.20 1999/05/30 23:13:51 pw Exp $") (in-package :pcl) @@ -590,7 +590,6 @@ work during bootstrapping. (function #'identity :type function) call-method-args) -#+cmu (declaim (ext:freeze-type method-call)) (defmacro invoke-method-call1 (function args cm-args) @@ -614,7 +613,6 @@ work during bootstrapping. next-method-call arg-info) -#+cmu (declaim (ext:freeze-type fast-method-call)) (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) @@ -629,7 +627,6 @@ work during bootstrapping. (defstruct fast-instance-boundp (index 0 :type fixnum)) -#+cmu (declaim (ext:freeze-type fast-instance-boundp)) (eval-when (compile load eval) @@ -679,9 +676,8 @@ work during bootstrapping. (setq restp (eval restp)) `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (cond (#-(or lucid excl) (typep ,emf 'fast-method-call) - #+(or lucid excl) (fast-method-call-p ,emf) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + (cond ((typep ,emf 'fast-method-call) + (invoke-fast-method-call ,emf ,@required-args+rest-arg)) ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fixnum) (let* ((.slots. (get-slots-or-nil @@ -1200,42 +1196,39 @@ work during bootstrapping. (intern (symbol-name key) (find-package "KEYWORD")) (car key)))) -(defun ftype-declaration-from-lambda-list (lambda-list #+cmu name) +(defun ftype-declaration-from-lambda-list (lambda-list name) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) - (let* (#+cmu (old (c::info function type name)) - #+cmu (old-ftype (if (c::function-type-p old) old nil)) - #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype))) - #+cmu (old-keys (and old-ftype - (mapcar #'c::key-info-name - (c::function-type-keywords old-ftype)))) - #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) - #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) - (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keywords)) - #-cmu (mapcar #'keyword-spec-name keywords))) + (let* ((old (c::info function type name)) + (old-ftype (if (c::function-type-p old) old nil)) + (old-restp (and old-ftype (c::function-type-rest old-ftype))) + (old-keys (and old-ftype + (mapcar #'c::key-info-name + (c::function-type-keywords old-ftype)))) + (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) + (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) + (keywords (union old-keys (mapcar #'keyword-spec-name keywords)))) `(function ,(append (make-list nrequired :initial-element 't) (when (plusp noptional) (append '(&optional) (make-list noptional :initial-element 't))) - (when (or restp #+cmu old-restp) + (when (or restp old-restp) '(&rest t)) - (when (or keysp #+cmu old-keysp) + (when (or keysp old-keysp) (append '(&key) (mapcar #'(lambda (key) `(,key t)) keywords) - (when (or allow-other-keys-p #+cmu old-allowp) + (when (or allow-other-keys-p old-allowp) '(&allow-other-keys))))) *)))) (defun proclaim-defgeneric (spec lambda-list) - #-cmu (declare (ignore lambda-list)) - (let (#+cmu - (decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec) + (let ((decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))) - #+cmu (proclaim decl) + (proclaim decl) )) ;;;; Early generic-function support @@ -1259,7 +1252,6 @@ work during bootstrapping. existing function-specifier all-keys)))) (defun generic-clobbers-function (function-specifier) - #+cmu (error 'kernel:simple-program-error :format-control "~S already names an ordinary function or a macro,~%~ @@ -1267,14 +1259,7 @@ work during bootstrapping. will require that you decide what to do with the existing function~%~ definition.~%~ The PCL-specific function MAKE-SPECIALIZABLE may be useful to you." - :format-arguments (list function-specifier)) - #-(or cmu) - (error "~S already names an ordinary function or a macro,~%~ - you may want to replace it with a generic function, but doing so~%~ - will require that you decide what to do with the existing function~%~ - definition.~%~ - The PCL-specific function MAKE-SPECIALIZABLE may be useful to you." - function-specifier)) + :format-arguments (list function-specifier))) (defvar *sgf-wrapper* (boot-make-wrapper (early-class-size 'standard-generic-function) @@ -1332,7 +1317,6 @@ work during bootstrapping. (gf-info-c-a-m-emf-std-p t) gf-info-fast-mf-p) -#+cmu (declaim (ext:freeze-type arg-info)) (defun arg-info-valid-p (arg-info) @@ -1533,13 +1517,13 @@ work during bootstrapping. fin (or function (if (eq spec 'print-object) - #'(#+cmu kernel:instance-lambda #-cmu lambda (instance stream) + #'(kernel:instance-lambda (instance stream) (printing-random-thing (instance stream) - (format stream "std-instance"))) - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + (format stream "std-instance"))) + #'(kernel:instance-lambda (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S~ - has not been set" fin))))) + has not been set" fin))))) (setf (gdefinition spec) fin) (bootstrap-set-slot 'standard-generic-function fin 'name spec) (bootstrap-set-slot 'standard-generic-function fin 'source (load-truename)) @@ -2072,7 +2056,7 @@ work during bootstrapping. (defmacro with-slots (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) - #+cmu (declare (ignorable ,in)) + (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) (third instance) instance))) @@ -2097,7 +2081,7 @@ work during bootstrapping. (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) - #+cmu (declare (ignorable ,in)) + (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) (third instance) instance))) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 594a24185f91d2283b8d97b6834c3748ae191564..7e8a76dec7345bbfe874fcdfc8ef866201ce7546 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.14 1998/12/20 04:30:16 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.15 1999/05/30 23:13:52 pw Exp $") ;;; ;;; Bootstrapping the meta-braid. ;;; @@ -41,16 +41,9 @@ (in-package :pcl) (defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p)) - #-new-kcl-wrapper (let ((instance (%%allocate-instance--class)) (no-of-slots (wrapper-no-of-instance-slots wrapper))) (setf (std-instance-wrapper instance) wrapper) - #-cmu - (setf (std-instance-slots instance) - (if slots-init-p - (make-array no-of-slots :initial-contents slots-init) - (make-array no-of-slots :initial-element *slot-unbound*))) - #+cmu ; faster version for CMUCL (setf (std-instance-slots instance) (cond (slots-init-p ;; Inline the slots vector allocation and initialisation. @@ -65,37 +58,22 @@ (t (make-array no-of-slots :initial-element pcl::*slot-unbound*)))) - instance) - #+new-kcl-wrapper - (apply #'si:make-structure wrapper - (if slots-init-p - slots-init - (let ((no-of-slots (si::s-data-length wrapper))) - (if (< no-of-slots (fill-pointer *init-vector*)) - (aref *init-vector* no-of-slots) - (get-init-list no-of-slots)))))) + instance)) (defmacro allocate-funcallable-instance-slots (wrapper &optional slots-init-p slots-init) - #-new-kcl-wrapper `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper))) ,(if slots-init-p `(if ,slots-init-p (make-array no-of-slots :initial-contents ,slots-init) (make-array no-of-slots :initial-element *slot-unbound*)) - `(make-array no-of-slots :initial-element *slot-unbound*))) - #+new-kcl-wrapper - (if slots-init-p - `(if ,slots-init-p - (allocate-standard-instance ,wrapper ,slots-init) - (allocate-standard-instance ,wrapper)) - `(allocate-standard-instance ,wrapper))) + `(make-array no-of-slots :initial-element *slot-unbound*)))) (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p)) (let ((fin (allocate-funcallable-instance-1))) (set-funcallable-instance-function fin - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + #'(kernel:instance-lambda (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S has not been set" fin))) @@ -105,7 +83,6 @@ fin)) (defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p)) - #-new-kcl-wrapper (let* ((class (wrapper-class wrapper)) (constructor (class-defstruct-constructor class))) (if constructor @@ -115,11 +92,7 @@ (dolist (slot slots) (setf (slot-value-using-class class instance slot) (pop slots-init)))) instance) - (error "Can't allocate an instance of class ~S" (class-name class)))) - #+new-kcl-wrapper - (if slots-init-p - (allocate-standard-instance wrapper slots-init) - (allocate-standard-instance wrapper))) + (error "Can't allocate an instance of class ~S" (class-name class))))) ;;; ;;; bootstrap-meta-braid @@ -133,9 +106,6 @@ *the-pcl-package*))) `(setf ,wr ,(if (eq class 'standard-generic-function) '*sgf-wrapper* - #-cmu17 - `(make-wrapper (early-class-size ',class)) - #+cmu17 `(boot-make-wrapper (early-class-size ',class) ',class)) @@ -144,8 +114,6 @@ 'funcallable-standard-class-wrapper 'standard-class-wrapper)) (wrapper-class ,wr) ,class - #+new-kcl-wrapper (si::s-data-name ,wr) - #+new-kcl-wrapper ',class (find-class ',class) ,class))) classes))) @@ -227,9 +195,6 @@ ((eq class standard-generic-function) standard-generic-function-wrapper) (t - #-cmu17 - (make-wrapper (length slots) class) - #+cmu17 (boot-make-wrapper (length slots) name)))) (proto nil)) (when (eq name 't) (setq *the-wrapper-of-t* wrapper)) @@ -240,7 +205,7 @@ (unless (eq (getf slot :allocation :instance) :instance) (error "Slot allocation ~S not supported in bootstrap."))) - (when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t + (when (typep wrapper 'wrapper) (setf (wrapper-instance-slots-layout wrapper) (mapcar #'canonical-slot-name slots)) (setf (wrapper-class-slots wrapper) @@ -322,8 +287,6 @@ (set-slot 'direct-subclasses (classes direct-subclasses)) (set-slot 'direct-methods (cons nil nil)) (set-slot 'wrapper wrapper) - #+new-kcl-wrapper - (setf (si::s-data-name wrapper) name) (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) (make-class-predicate-name name))) (set-slot 'plist @@ -494,17 +457,11 @@ (dolist (e *built-in-classes*) (destructuring-bind (name supers subs cpl prototype) e (let* ((class (find-class name)) - #+cmu17 (lclass (lisp:find-class name)) - (wrapper #-cmu17(make-wrapper 0 class) - #+cmu17(kernel:class-layout lclass))) + (wrapper (kernel:class-layout lclass))) (set (get-built-in-class-symbol name) class) (set (get-built-in-wrapper-symbol name) wrapper) - #+cmu17 (setf (kernel:class-pcl-class lclass) class) - #-cmu17 - (setf (wrapper-instance-slots-layout wrapper) () - (wrapper-class-slots wrapper) ()) (bootstrap-initialize-class 'built-in-class class name class-eq-wrapper nil @@ -522,91 +479,17 @@ ;;; ;;; ;;; -#-(or new-kcl-wrapper cmu17) -(progn -(defvar *built-in-or-structure-wrapper-table* - (make-hash-table :test 'eq)) - -(defvar wft-type1 nil) -(defvar wft-wrapper1 nil) -(defvar wft-type2 nil) -(defvar wft-wrapper2 nil) - -(defun wrapper-for-structure (x) - (let ((type (structure-type x))) - (when (symbolp type) - (cond ((eq type 'std-instance) - (return-from wrapper-for-structure (std-instance-wrapper x))) - ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1)) - ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2)) - (t (setq wft-type2 wft-type1 wft-wrapper2 wft-wrapper1)))) - (let* ((cell (find-class-cell type)) - (class (or (find-class-cell-class cell) - (let* (#+lucid - (*structure-type* type) - #+lucid - (*structure-length* (structure-length x type))) - (find-class-from-cell type cell)))) - (wrapper (if class (class-wrapper class) *the-wrapper-of-t*))) - (when (symbolp type) - (setq wft-type1 type wft-wrapper1 wrapper)) - wrapper))) - -(defun built-in-or-structure-wrapper1 (x) - (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*))) - (or (and (eq biw *the-wrapper-of-t*) - (structurep x) - (let* ((type (type-of x)) - #+lucid - (*structure-type* type) - #+lucid - (*structure-length* (structure-length x type)) - (class (find-class type nil))) - (and class (class-wrapper class)))) - biw))) -) - -#|| ; moved to low.lisp -(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))))) -||# - -#-cmu17 -(defmacro wrapper-of-macro (x) - `(cond ((std-instance-p ,x) - (std-instance-wrapper ,x)) - ((fsc-instance-p ,x) - (fsc-instance-wrapper ,x)) - (t - (#+new-kcl-wrapper built-in-wrapper-of - #-new-kcl-wrapper built-in-or-structure-wrapper - ,x)))) - -#+cmu17 + (defmacro wrapper-of-macro (x) `(kernel:layout-of ,x)) (defun class-of (x) (wrapper-class* (wrapper-of-macro x))) -#+cmu17 (declaim (inline wrapper-of)) (defun wrapper-of (x) (wrapper-of-macro x)) -#-cmu17 -(defun structure-wrapper (x) - (class-wrapper (find-class (structure-type x)))) - (defvar find-structure-class nil) (defun eval-form (form) @@ -629,15 +512,13 @@ :metaclass 'structure-class :name symbol :direct-superclasses - (cond #+cmu - ;; Handle the CMUCL structure based conditions. + (cond ;; Handle the CMUCL structure based conditions. ((lisp:subtypep symbol 'condition) (mapcar #'lisp:class-name (kernel:class-direct-superclasses (lisp:find-class symbol)))) ;; Hack to add the stream class as a ;; mixin to the lisp-stream class. - #+cmu ((eq symbol 'sys:lisp-stream) '(structure-object stream)) ((structure-type-included-type-name symbol) @@ -647,55 +528,6 @@ (structure-type-slot-description-list symbol))))) (error "~S is not a legal structure class name." symbol))) -#-cmu17 -(eval-when (compile eval) - -(defun make-built-in-class-subs () - (mapcar #'(lambda (e) - (let ((class (car e)) - (class-subs ())) - (dolist (s *built-in-classes*) - (when (memq class (cadr s)) (pushnew (car s) class-subs))) - (cons class class-subs))) - (cons '(t) *built-in-classes*))) - -(defun make-built-in-class-tree () - (let ((subs (make-built-in-class-subs))) - (labels ((descend (class) - (cons class (mapcar #'descend (cdr (assq class subs)))))) - (descend 't)))) - -(defun make-built-in-wrapper-of-body () - (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) - 'x - #'get-built-in-wrapper-symbol)) - -(defun make-built-in-wrapper-of-body-1 (tree var get-symbol) - (let ((*specials* ())) - (declare (special *specials*)) - (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol))) - `(locally (declare (special .,*specials*)) ,inner)))) - -(defun make-built-in-wrapper-of-body-2 (tree var get-symbol) - (declare (special *specials*)) - (let ((symbol (funcall get-symbol (car tree)))) - (push symbol *specials*) - (let ((sub-tests - (mapcar #'(lambda (x) - (make-built-in-wrapper-of-body-2 x var get-symbol)) - (cdr tree)))) - `(and (typep ,var ',(car tree)) - ,(if sub-tests - `(or ,.sub-tests ,symbol) - symbol))))) -) - -#-cmu17 -(defun built-in-wrapper-of (x) - #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file - (make-built-in-wrapper-of-body))) - - (defun method-function-returning-nil (args next-methods) (declare (ignore args next-methods)) @@ -737,7 +569,6 @@ gf)) -#+cmu17 ;;; Set inherits from CPL and register layout. This actually installs the ;;; class in the lisp type system. ;;; @@ -765,7 +596,6 @@ (bootstrap-class-predicates nil) (bootstrap-built-in-classes) - #+cmu17 (ext:do-hash (name x *find-class*) (let* ((class (find-class-from-cell name x)) (layout (class-wrapper class)) @@ -786,10 +616,6 @@ (setq *boot-state* 'braid) ) -#-cmu17 -(deftype slot-object () - '(or standard-object structure-object)) - (defmethod no-applicable-method (generic-function &rest args) (cerror "Retry call to ~S" "No matching method for the generic-function ~S,~@ diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 9a0751d05320c5d93efc1b1a05d2c6526cf4c169..0e5091ba1c8e325be222770d481cf2397f7624f1 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.12 1999/03/11 16:51:02 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.13 1999/05/30 23:13:53 pw Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. ;;; @@ -94,7 +94,7 @@ ;;; (defmacro cache-vector-ref (cache-vector location) `(svref (the simple-vector ,cache-vector) - (#-cmu the #+cmu ext:truly-the fixnum ,location))) + (ext:truly-the fixnum ,location))) (defmacro cache-vector-size (cache-vector) `(array-dimension (the simple-vector ,cache-vector) 0)) @@ -151,7 +151,6 @@ (vector #() :type simple-vector) (overflow nil :type list)) -#+cmu (declaim (ext:freeze-type cache)) (defun print-cache (cache stream depth) @@ -247,43 +246,6 @@ ;;; forms of this constant which it is more convenient for the runtime code ;;; to use. ;;; -#-cmu17 -(eval-when (compile load eval) - -(defconstant wrapper-cache-number-adds-ok 4) - -;;; Incorrect. This actually allows 15 or 16 adds, depending on whether -;;; most-positive-fixnum is all-ones. -- Ram -;;; -(defconstant wrapper-cache-number-length - (- (integer-length most-positive-fixnum) - wrapper-cache-number-adds-ok)) - -(defconstant wrapper-cache-number-mask - (1- (expt 2 wrapper-cache-number-length))) - - -(defvar *get-wrapper-cache-number* (make-random-state)) - -(defun get-wrapper-cache-number () - (let ((n 0)) - (declare (fixnum n)) - (loop - (setq n - (logand wrapper-cache-number-mask - (random most-positive-fixnum *get-wrapper-cache-number*))) - (unless (zerop n) (return n))))) - - -(unless (> wrapper-cache-number-length 8) - (error "In this implementation of Common Lisp, fixnums are so small that~@ - wrapper cache numbers end up being only ~D bits long. This does~@ - not actually keep PCL from running, but it may degrade cache~@ - performance.~@ - You may want to consider changing the value of the constant~@ - WRAPPER-CACHE-NUMBER-ADDS-OK."))) - -#+cmu17 (progn (defconstant wrapper-cache-number-length (integer-length kernel:layout-hash-max)) @@ -315,181 +277,68 @@ ;;; cache numbers on machines where the addressing modes make that a good ;;; idea. ;;; -#-structure-wrapper -(progn -(eval-when (compile load eval) -(defconstant wrapper-layout - '(number - number - number - number - number - number - number - number - state - instance-slots-layout - class-slots - class - no-of-instance-slots)) -) - -(eval-when (compile load eval) - -(defun wrapper-field (type) - (posq type wrapper-layout)) - -(defun next-wrapper-field (field-number) - (position (nth field-number wrapper-layout) - wrapper-layout - :start (1+ field-number))) - -(defmacro first-wrapper-cache-number-index () - `(wrapper-field 'number)) - -(defmacro next-wrapper-cache-number-index (field-number) - `(next-wrapper-field ,field-number)) - -);eval-when - -(defmacro wrapper-cache-number-vector (wrapper) - wrapper) - -(defmacro cache-number-vector-ref (cnv n) - `(svref ,cnv ,n)) - - -(defmacro wrapper-ref (wrapper n) - `(svref ,wrapper ,n)) - -(defmacro wrapper-state (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'state))) - -(defmacro wrapper-instance-slots-layout (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) - -(defmacro wrapper-class-slots (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) - -(defmacro wrapper-class (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'class))) - -(defmacro wrapper-no-of-instance-slots (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots))) - -(defmacro make-wrapper-internal () - `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) - ,@(gathering1 (collecting) - (iterate ((i (interval :from 0)) - (desc (list-elements wrapper-layout))) - (ecase desc - (number - (gather1 `(setf (wrapper-ref wrapper ,i) - (get-wrapper-cache-number)))) - ((state instance-slots-layout class-slots class no-of-instance-slots))))) - (setf (wrapper-state wrapper) 't) - wrapper)) - -(defun make-wrapper (no-of-instance-slots &optional class) - (let ((wrapper (make-wrapper-internal))) - (setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots) - (setf (wrapper-class wrapper) class) - wrapper)) - -) ; In CMUCL we want to do type checking as early as possible; structures help this. -#+structure-wrapper + (eval-when (compile load eval) (defconstant wrapper-cache-number-vector-length - #+cmu17 kernel:layout-hash-length #-cmu17 8) - -#-cmu17 -(deftype cache-number-vector () - `(simple-array fixnum (,wrapper-cache-number-vector-length))) + kernel:layout-hash-length) (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length :initial-element 'number)) - ) -#+structure-wrapper + (progn -#-(or cmu17) -(defun make-wrapper-cache-number-vector () - (let ((cnv (make-array #.wrapper-cache-number-vector-length - :element-type 'fixnum))) - (dotimes (i #.wrapper-cache-number-vector-length) - (setf (aref cnv i) (get-wrapper-cache-number))) - cnv)) +(unless (boundp '*the-class-t*) (setq *the-class-t* nil)) +;;; Note that for CMU, the WRAPPER of a built-in or structure class will be +;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only +;;; two slots that WRAPPER adds are meaningless in those cases. +;;; -#-cmu17 (defstruct (wrapper - (:print-function print-wrapper) - (:constructor make-wrapper (no-of-instance-slots &optional class))) - (cache-number-vector (make-wrapper-cache-number-vector) - :type cache-number-vector) - (state t :type (or (member t) cons)) - ;; either t or a list (state-sym new-wrapper) - ;; where state-sym is either :flush or :obsolete + (:include kernel:layout) + (:conc-name %wrapper-) + (:print-function print-wrapper) + (:constructor make-wrapper-internal)) (instance-slots-layout nil :type list) - (class-slots nil :type list) - (no-of-instance-slots 0 :type fixnum) - (class *the-class-t* :type class)) + (class-slots nil :type list)) +(declaim (ext:freeze-type wrapper)) +(defmacro wrapper-class (wrapper) + `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) +(defmacro wrapper-no-of-instance-slots (wrapper) + `(kernel:layout-length ,wrapper)) +(declaim (inline wrapper-state (setf wrapper-state))) + +(defun wrapper-state (wrapper) + (let ((invalid (kernel:layout-invalid wrapper))) + (cond ((null invalid) + t) + ((atom invalid) + ;; Some non-pcl object. invalid is probably :INVALID + ;; We should compute the new wrapper here instead + ;; of returning nil, but why bother, since + ;; obsolete-instance-trap can't use it. + '(:obsolete nil)) + (t + invalid)))) + +(defun (setf wrapper-state) (new-value wrapper) + (setf (kernel:layout-invalid wrapper) + (if (eq new-value 't) + nil + new-value))) -(unless (boundp '*the-class-t*) (setq *the-class-t* nil)) +(defmacro wrapper-instance-slots-layout (wrapper) + `(%wrapper-instance-slots-layout ,wrapper)) +(defmacro wrapper-class-slots (wrapper) + `(%wrapper-class-slots ,wrapper)) +(defmacro wrapper-cache-number-vector (x) x)) -;;; Note that for CMU, the WRAPPER of a built-in or structure class will be -;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only -;;; two slots that WRAPPER adds are meaningless in those cases. -;;; -#+cmu17 -(progn - (defstruct (wrapper - (:include kernel:layout) - (:conc-name %wrapper-) - (:print-function print-wrapper) - (:constructor make-wrapper-internal)) - (instance-slots-layout nil :type list) - (class-slots nil :type list)) - (declaim (ext:freeze-type wrapper)) - - (defmacro wrapper-class (wrapper) - `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) - (defmacro wrapper-no-of-instance-slots (wrapper) - `(kernel:layout-length ,wrapper)) - (declaim (inline wrapper-state (setf wrapper-state))) - - (defun wrapper-state (wrapper) - (let ((invalid (kernel:layout-invalid wrapper))) - (cond ((null invalid) - t) - ((atom invalid) - ;; Some non-pcl object. invalid is probably :INVALID - ;; We should compute the new wrapper here instead - ;; of returning nil, but why bother, since - ;; obsolete-instance-trap can't use it. - '(:obsolete nil)) - (t - invalid)))) - - (defun (setf wrapper-state) (new-value wrapper) - (setf (kernel:layout-invalid wrapper) - (if (eq new-value 't) - nil - new-value))) - - (defmacro wrapper-instance-slots-layout (wrapper) - `(%wrapper-instance-slots-layout ,wrapper)) - (defmacro wrapper-class-slots (wrapper) - `(%wrapper-class-slots ,wrapper)) - (defmacro wrapper-cache-number-vector (x) x)) - -#+cmu17 ;;; BOOT-MAKE-WRAPPER -- Interface ;;; ;;; Called in BRAID when we are making wrappers for classes whose slots are @@ -517,10 +366,9 @@ ;;; already been created by the lisp code and which is to be redefined ;;; by PCL. This allows standard-classes to be defined and used for ;;; type testing and dispatch before PCL is loaded. -#+cmu17 + (defvar *pcl-class-boot* nil) -#+cmu17 ;;; MAKE-WRAPPER -- Interface ;;; ;;; In CMU CL, the layouts (a.k.a wrappers) for built-in and structure @@ -572,22 +420,9 @@ `(and (< ,field-number #.(1- wrapper-cache-number-vector-length)) (1+ ,field-number))) -#-cmu17 -(defmacro cache-number-vector-ref (cnv n) - `(svref ,cnv ,n)) - -#+cmu17 (defmacro cache-number-vector-ref (cnv n) `(wrapper-cache-number-vector-ref ,cnv ,n)) -) - -#-cmu17 -(defmacro wrapper-cache-number-vector-ref (wrapper n) - `(the fixnum - (#-structure-wrapper svref #+structure-wrapper aref - (wrapper-cache-number-vector ,wrapper) ,n))) -#+cmu17 (defmacro wrapper-cache-number-vector-ref (wrapper n) `(kernel:layout-hash ,wrapper ,n)) @@ -595,13 +430,10 @@ `(wrapper-no-of-instance-slots (class-wrapper ,class))) (defmacro wrapper-class* (wrapper) - #-(or cmu17) - `(wrapper-class ,wrapper) - #+(or cmu17) `(let ((wrapper ,wrapper)) (or (wrapper-class wrapper) (find-structure-class - #+cmu17 (lisp:class-name (kernel:layout-class wrapper)))))) + (lisp:class-name (kernel:layout-class wrapper)))))) ;;; ;;; The wrapper cache machinery provides general mechanism for trapping on @@ -676,21 +508,6 @@ (error "Wrapper returned from trap invalid."))) nwrapper)))) -#-cmu17 -(defmacro check-wrapper-validity1 (object) - (let ((owrapper (gensym))) - `(let ((,owrapper (cond ((std-instance-p ,object) - (std-instance-wrapper ,object)) - ((fsc-instance-p ,object) - (fsc-instance-wrapper ,object)) - (t (wrapper-of ,object))))) - (if (eq 't (wrapper-state ,owrapper)) - ,owrapper - (check-wrapper-validity ,object))))) - -#+cmu17 -;;; semantically equivalent, but faster. -;;; (defmacro check-wrapper-validity1 (object) (let ((owrapper (gensym))) `(let ((,owrapper (kernel:layout-of object))) diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp index 99de6e97c1f51ad07278f9f67b3e729bbbe78aa9..9ed7b61fd5e14f3294fc909a8049c5f24a03e111 100644 --- a/pcl/cmu-low.lisp +++ b/pcl/cmu-low.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/cmu-low.lisp,v 1.17 1998/12/20 04:30:17 dtc Exp $") + "$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. ;;; @@ -83,31 +83,7 @@ (eval:interpreted-function (setf (eval:interpreted-function-name fcn) new-name)))) fcn) - (t - ;; pw-- This seems wrong and causes trouble. Tests show - ;; that loading CL-HTTP resulted in ~5400 closures being - ;; passed through this code of which ~4000 of them pointed - ;; to but 16 closure-functions, including 1015 each of - ;; DEFUN MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION - ;; DEFUN MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION - ;; DEFUN MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION. - ;; Since the actual functions have been moved by PURIFY - ;; to memory not seen by GC, changing a pointer there - ;; not only clobbers the last change but leaves a dangling - ;; pointer invalid after the next GC. Comments in low.lisp - ;; indicate this code need do nothing. Setting the - ;; function-name to NIL loses some info, and not changing - ;; it loses some info of potential hacking value. So, - ;; lets not do this... - #+nil - (let ((header (kernel:%closure-function fcn))) - #+cmu17 - (setf (c::%function-name header) new-name) - #-cmu17 - (system:%primitive c::set-function-name header new-name)) - - ;; Maybe add better scheme here someday. - fcn))) + (t fcn))) (in-package "C") @@ -202,8 +178,6 @@ ;;;; Structure-instance stuff: -(pushnew :structure-wrapper *features*) - (defun structure-functions-exist-p () t) diff --git a/pcl/combin.lisp b/pcl/combin.lisp index cb76ac83cde3ec9aa6d5f5a94b6e97125f57003e..f432d682a4cb94e1735e5d924edc5cb6eaec7ba6 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.8 1998/12/20 04:30:17 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.9 1999/05/30 23:13:54 pw Exp $") ;;; (in-package :pcl) diff --git a/pcl/construct.lisp b/pcl/construct.lisp index 2925bbdc3284e6540ebc5c07b40087d591515010..78c7756eacaab5ceaaad628849f86e1e604cd1d4 100644 --- a/pcl/construct.lisp +++ b/pcl/construct.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/construct.lisp,v 1.11 1998/12/20 04:30:18 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/construct.lisp,v 1.12 1999/05/30 23:13:54 pw Exp $") ;;; ;;; This file defines the defconstructor and other make-instance optimization ;;; mechanisms. @@ -130,13 +130,7 @@ ;; tell the compile time environment that a function with this ;; name and this argument list has been defined. The portable ;; way to do this is with defun. - #-cmu (proclaim '(notinline ,name)) - #-cmu - (defun ,name ,lambda-list - (declare (ignore ,@(extract-parameters lambda-list))) - (error "Constructor ~S not loaded." ',name)) ;; But the derived result type for the above is wrong under CMUCL. - #+cmu (proclaim '(ftype ,(ftype-declaration-from-lambda-list lambda-list name) ,name)) @@ -302,7 +296,7 @@ (defmethod install-lazy-constructor-installer ((constructor constructor)) (let ((class (constructor-class constructor))) (set-constructor-code constructor - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + #'(kernel:instance-lambda (&rest args) (multiple-value-bind (code type) (compute-constructor-code class constructor) (set-constructor-code constructor code type) @@ -633,7 +627,7 @@ (lambda (&rest ignore) (declare (ignore ignore)) (function - (#+cmu kernel:instance-lambda #-cmu lambda ,arglist + (kernel:instance-lambda ,arglist (make-instance ',(class-name class) ,@(gathering1 (collecting) @@ -675,7 +669,7 @@ (null (non-pcl-or-after-shared-initialize-methods-p shared))) (function - (#+cmu kernel:instance-lambda #-cmu lambda ,arglist + (kernel:instance-lambda ,arglist (declare #.*optimize-speed*) (let* ((.instance. (,raw-allocator .wrapper. .constants.)) (.slots. (,slots-fetcher .instance.)) @@ -835,7 +829,7 @@ (when (and .constants. (null (non-pcl-initialize-instance-methods-p init)) (null (non-pcl-shared-initialize-methods-p shared))) - #'(#+cmu kernel:instance-lambda #-cmu lambda ,arglist + #'(kernel:instance-lambda ,arglist (declare #.*optimize-speed*) (let* ((.instance. (,raw-allocator .wrapper. .constants.)) (.slots. (,slots-fetcher .instance.)) @@ -969,7 +963,7 @@ ',supplied-initargs) (when .constants. (function - (#+cmu kernel:instance-lambda #-cmu lambda ,arglist + (kernel:instance-lambda ,arglist (declare #.*optimize-speed*) (let* ((.instance. (,raw-allocator .wrapper. .constants.)) (.slots. (,slots-fetcher .instance.)) diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp index 0089e6cc0e22f5ca1808cf8ded0c9c0a2e254565..4690d9d5e6065b60f490710d0b3ab130f0a842f0 100644 --- a/pcl/cpl.lisp +++ b/pcl/cpl.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.8 1998/12/20 04:30:18 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.9 1999/05/30 23:13:55 pw Exp $") ;;; (in-package :pcl) diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index bd1ad843b5d13a771e435870a0aba5193612ff3e..c7060a8938ec23822c1c236b526e5956a278e3ec 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.15 1999/03/14 01:14:13 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.16 1999/05/30 23:13:55 pw Exp $") ;;; (in-package :pcl) @@ -54,14 +54,9 @@ (capitalize-words (car name) ()) (cdr name)) (format nil "~S" name)))) (definition-name) - - #+cmu (if (member 'compile times) `(eval-when ,times ,form) - form) - - #-(or cmu) - (make-progn `',name `(eval-when ,times ,form)))) + form))) (defun make-progn (&rest forms) (let ((progn-form nil)) @@ -112,9 +107,6 @@ "The value of the :metaclass option (~S) is not a~%~ legal class name." :format-arguments (list (cadr option)))) - #-cmu17 - (setq metaclass (cadr option)) - #+cmu17 (setq metaclass (case (cadr option) (lisp:standard-class 'standard-class) @@ -146,10 +138,10 @@ `(progn ,@(mapcar #'(lambda (x) `(declaim (ftype (function (t) t) ,x))) - #+cmu *readers* #-cmu nil) + *readers*) ,@(mapcar #'(lambda (x) `(declaim (ftype (function (t t) t) ,x))) - #+cmu *writers* #-cmu nil) + *writers*) (let ,(mapcar #'cdr *initfunctions*) (load-defclass ',name ',metaclass diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index ab09a3cfa81015ef5bd3193e6e34594811e1add6..09e916033cda719f290462f970b814f13441637d 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.9 1998/12/20 04:30:18 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.10 1999/05/30 23:13:55 pw Exp $") ;;; (in-package :pcl) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index bcf7f287446db726fcb498e764dd9c555b60fabf..d2fe7296c50da138df97f7ca9ac37ecc84e1f0f2 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -72,14 +72,9 @@ ;;; the `real' definition without affecting the advise. ;;; (defun (setf gdefinition) (new-definition name) - #+cmu (progn - (c::%%defun name new-definition nil) - (c::note-name-defined name :function) - new-definition) - #-(or cmu) - (setf (symbol-function name) new-definition)) - - + (c::%%defun name new-definition nil) + (c::note-name-defined name :function) + new-definition) (proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* @@ -146,7 +141,6 @@ :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) - #+cmu17 ((and (null args) (typep type 'lisp:class)) (or (kernel:class-pcl-class type) (find-structure-class (lisp:class-name type)))) @@ -242,8 +236,7 @@ ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type)))) ((class class-eq) ; class-eq is impossible to do right - #-cmu17 (class-name (cadr type)) - #+cmu17 (kernel:layout-class (class-wrapper (cadr type)))) + (kernel:layout-class (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) (car type) @@ -281,13 +274,7 @@ (convert-to-system-type type2)))))))) (defun do-satisfies-deftype (name predicate) - #+cmu17 (declare (ignore name predicate)) - #-(or cmu17) - ;; This is the default for ports for which we don't know any - ;; better. Note that for most ports, providing this definition - ;; should just speed up class definition. It shouldn't have an - ;; effect on performance of most user code. - (eval `(deftype ,name () '(satisfies ,predicate)))) + (declare (ignore name predicate))) (defun make-type-predicate-name (name &optional kind) (if (symbol-package name) @@ -423,7 +410,6 @@ list) () (symbol list sequence t) nil))) -#+cmu17 (labels ((direct-supers (class) (if (typep class 'lisp:built-in-class) (kernel:built-in-class-direct-superclasses class) @@ -464,24 +450,22 @@ (defclass t () () (:metaclass built-in-class)) -#+cmu17 -(progn - (defclass kernel:instance (t) () - (:metaclass built-in-class)) - - (defclass function (t) () - (:metaclass built-in-class)) +(defclass kernel:instance (t) () + (:metaclass built-in-class)) - (defclass kernel:funcallable-instance (function) () - (:metaclass built-in-class)) +(defclass function (t) () + (:metaclass built-in-class)) + +(defclass kernel:funcallable-instance (function) () + (:metaclass built-in-class)) - (defclass stream (t) () - (:metaclass built-in-class))) +(defclass stream (t) () + (:metaclass built-in-class)) (defclass slot-object (t) () (:metaclass slot-class)) -(defclass structure-object (slot-object #+cmu17 kernel:instance) () +(defclass structure-object (slot-object kernel:instance) () (:metaclass structure-class)) (defstruct (dead-beef-structure-object @@ -491,10 +475,10 @@ (defclass std-object (slot-object) () (:metaclass std-class)) -(defclass standard-object (std-object #+cmu17 kernel:instance) ()) +(defclass standard-object (std-object kernel:instance) ()) (defclass funcallable-standard-object (std-object - #+cmu17 kernel:funcallable-instance) + kernel:funcallable-instance) () (:metaclass funcallable-standard-class)) diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index acc2c17d8ac0bd98fe06f047de2d40ae0f35c450..8e8f56b6e0f6f631a4592bc9b83d6c6d1f42c0cb 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.20 1999/03/14 01:14:14 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.21 1999/05/30 23:13:56 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 @@ -80,7 +80,6 @@ (defvar *pcl-system-date* "September 16 92 PCL (f)") -#+cmu (setf (getf ext:*herald-items* :pcl) `(" CLOS based on PCL version: " ,*pcl-system-date*)) @@ -144,8 +143,7 @@ and load your system with: ;;; defsys use the value of *port* rather than #+ and #- to conditionalize ;;; the way they work. ;;; -(defvar *port* - '(#+:CMU CMU)) +(defvar *port* '(CMU)) ;;; ;;; When you get a copy of PCL (by tape or by FTP), the sources files will @@ -173,7 +171,7 @@ and load your system with: ;;; "mv *.lisp *.lsp". ;;; (defvar *default-pathname-extensions* - (car '(#+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))))) + (car '(("lisp" . #.(c:backend-fasl-file-type c:*backend*))))) (defvar *pathname-extensions* (let ((proper-extensions *default-pathname-extensions*)) @@ -363,7 +361,6 @@ and load your system with: (declare (ignore ignore)) 't) -#+cmu17 (defparameter *byte-files* '(defclass defcombin iterate env)) (defun operate-on-system (name mode &optional arg print-only) @@ -388,7 +385,7 @@ and load your system with: (make-pathname :defaults (make-binary-pathname name) :version :newest) - #+cmu17 :byte-compile #+cmu17 + :byte-compile (if (and (member name *byte-files*) (member :small *features*)) t @@ -465,14 +462,6 @@ and load your system with: (declare (ignore errorp)) *load-truename*) -#-(or cmu Symbolics) -(defvar *pcl-directory* - (or (load-truename t) - (error "Because load-truename is not implemented in this port~%~ - of PCL, you must manually edit the definition of the~%~ - variable *pcl-directory* in the file defsys.lisp."))) - -#+cmu (defvar *pcl-directory* (pathname "target:pcl/")) (defsystem pcl @@ -592,8 +581,6 @@ and load your system with: (do-symbols (sym pkg) (when (eq pkg (symbol-package sym)) (if (or (constantp sym) - #-cmu (member sym '(wrapper cache arg-info pv-table)) - #+cmu (or (c::info setf inverse sym) (c::info setf expander sym) (c::info type kind sym) @@ -605,6 +592,5 @@ and load your system with: (unless (or (eq sym 'reset-pcl-package) (eq sym 'reset-package)) (fmakunbound sym) - #+cmu (fmakunbound `(setf ,sym))) (setf (symbol-plist sym) nil))))))) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index 89e53ae9ea8e375fa34744757219ad58380f37b5..ffc82cb15eb2d05895448930dbf1e0bda75bbb79 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.9 1998/12/20 04:30:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.10 1999/05/30 23:13:56 pw Exp $") ;;; (in-package :pcl) @@ -330,7 +330,6 @@ And so, we are saved. (declare (pcl-fast-call)) (accessor-miss gf new arg dfun-info))))) -#+cmu (declaim (ext:freeze-type dfun-info)) @@ -656,7 +655,6 @@ And so, we are saved. *secondary-dfun-call-cost* 0)))) -#+cmu (progn (setq *non-built-in-typep-cost* 100) (setq *structure-typep-cost* 15) @@ -742,7 +740,7 @@ And so, we are saved. (defun make-initial-dfun (gf) (let ((initial-dfun - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + #'(kernel:instance-lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) @@ -777,11 +775,11 @@ And so, we are saved. (let* ((methods (early-gf-methods gf)) (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type - (reader #'(#+cmu kernel:instance-lambda #-cmu lambda (instance) + (reader #'(kernel:instance-lambda (instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-get-slot class-name instance slot-name)))) - (writer #'(#+cmu kernel:instance-lambda #-cmu lambda (new-value instance) + (writer #'(kernel:instance-lambda (new-value instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-set-slot class-name instance slot-name new-value))))))) @@ -868,7 +866,7 @@ And so, we are saved. specls all-same-p) (cond ((null methods) (values - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + #'(kernel:instance-lambda (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) @@ -925,11 +923,7 @@ And so, we are saved. (caching)) ((or invalidp (null nindex))) - ((not #-cmu17 - (or (std-instance-p object) - (fsc-instance-p object)) - #+cmu17 - (pcl-instance-p object)) + ((not (pcl-instance-p object)) (caching)) ((or (neq ntype otype) (listp wrappers)) (caching)) @@ -1484,7 +1478,7 @@ And so, we are saved. (if function-p #'(lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + #'(kernel:instance-lambda (&rest args) (apply #'no-applicable-method gf args))) #'(lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) @@ -1555,9 +1549,9 @@ And so, we are saved. (unless (eq 'default-method-only (type-of info)) (setq dfun (doctor-dfun-for-the-debugger generic-function - #+cmu dfun #-cmu (set-function-name dfun gf-name)))) + dfun))) (set-funcallable-instance-function generic-function dfun) - #+cmu (set-function-name generic-function gf-name) + (set-function-name generic-function gf-name) (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp index d355f374e1cf76ffb36d00c718e4b49e89ec368d..c9ecda9e89bc9170816c9831b10f0ada31342b48 100644 --- a/pcl/dlap.lisp +++ b/pcl/dlap.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/dlap.lisp,v 1.7 1998/12/20 04:30:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/dlap.lisp,v 1.8 1999/05/30 23:13:57 pw Exp $") ;;; (in-package :pcl) @@ -64,16 +64,14 @@ (generating-lap closure-variables arglist (with-lap-registers ((inst t) ;reg for the instance - (wrapper #-structure-wrapper vector ;reg for the wrapper - #+structure-wrapper t) - #+structure-wrapper (cnv fixnum-vector) + (wrapper t) + (cnv fixnum-vector) (cache-no index)) ;reg for the cache no (let ((index cache-no) ;This register is used ;for different values at ;different times. (slots (and (null class-slot-p) - (allocate-register #-new-kcl-wrapper 'vector - #+new-kcl-wrapper t))) + (allocate-register 'vector))) (csv (and class-slot-p (allocate-register t)))) (prog1 (flatten-lap @@ -94,11 +92,7 @@ (opcode :move (operand :std-slots inst) slots)) (opcode :label 'have-wrapper) - #-structure-wrapper - (opcode :move (operand :cref wrapper field) cache-no) - #+structure-wrapper (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - #+structure-wrapper (opcode :move (operand :cref cnv field) cache-no) (opcode :izerop cache-no 'trap) ;obsolete wrapper? @@ -129,7 +123,7 @@ (let ((arglist (list (dfun-arg-symbol 0)))) (generating-lap '(field cache-vector mask size index miss-fn) arglist - (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)) + (with-lap-registers ((slots vector)) (emit-dlap arglist '(standard-instance) 'trap @@ -149,7 +143,7 @@ (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) (generating-lap '(field cache-vector mask size index miss-fn) arglist - (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)) + (with-lap-registers ((slots vector)) (emit-dlap arglist '(t standard-instance) 'trap @@ -171,7 +165,7 @@ (let ((arglist (list (dfun-arg-symbol 0)))) (generating-lap '(field cache-vector mask size miss-fn) arglist - (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t) + (with-lap-registers ((slots vector) (index index)) (emit-dlap arglist '(standard-instance) @@ -187,7 +181,7 @@ (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)))) (generating-lap '(field cache-vector mask size miss-fn) arglist - (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t) + (with-lap-registers ((slots vector) (index index)) (flatten-lap (emit-dlap arglist @@ -204,21 +198,15 @@ (defun emit-checking (metatypes applyp) (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) - (generating-lap '(field cache-vector mask size - #-excl-sun4 emf #+excl-sun4 function - miss-fn) + (generating-lap '(field cache-vector mask size emf miss-fn) dlap-lambda-list (emit-dlap (remove '&rest dlap-lambda-list) metatypes 'trap - (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t)) + (with-lap-registers ((emf t)) (flatten-lap - (opcode :move (operand :cvar - #-excl-sun4 'emf #+excl-sun4 'function) - #-excl-sun4 emf - #+excl-sun4 function) - #-excl-sun4 (opcode :emf-call emf) - #+excl-sun4 (opcode :jmp function))) + (opcode :move (operand :cvar 'emf) emf) + (opcode :emf-call emf))) (with-lap-registers ((miss-function t)) (flatten-lap (opcode :label 'trap) @@ -230,19 +218,18 @@ (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) (generating-lap '(field cache-vector mask size miss-fn) dlap-lambda-list - (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t)) + (with-lap-registers ((emf t)) (emit-dlap (remove '&rest dlap-lambda-list) metatypes 'trap (flatten-lap - #-excl-sun4 (opcode :emf-call emf) - #+excl-sun4 (opcode :jmp function)) + (opcode :emf-call emf)) (with-lap-registers ((miss-function t)) (flatten-lap (opcode :label 'trap) (opcode :move (operand :cvar 'miss-fn) miss-function) (opcode :jmp miss-function))) - #-excl-sun4 emf #+excl-sun4 function))))) + emf))))) (defun emit-constant-value (metatypes) (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil))) @@ -264,15 +251,13 @@ (defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label) - (with-lap-registers ((cwrapper #-structure-wrapper vector - #+structure-wrapper t)) + (with-lap-registers ((cwrapper t)) (flatten-lap (opcode :move (operand :cvar cwrapper-0) cwrapper) (opcode :neq wrapper cwrapper miss-label)))) ;wrappers not eq, trap (defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label) - (with-lap-registers ((cwrapper #-structure-wrapper vector - #+structure-wrapper t)) + (with-lap-registers ((cwrapper t)) (flatten-lap (opcode :move (operand :cvar cwrapper-0) cwrapper) ;This is an OR. Isn't (opcode :eq wrapper cwrapper 'hit-internal) ;assembly code fun @@ -320,8 +305,7 @@ (defun dlap-wrappers (metatypes) (mapcar #'(lambda (x) (and (neq x 't) - (allocate-register #-structure-wrapper 'vector - #+structure-wrapper t))) + (allocate-register t))) metatypes)) (defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs) @@ -474,8 +458,7 @@ (defun emit-check-1-wrapper-in-cache (cache-vector location wrapper hit-code) (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache"))) - (with-lap-registers ((cwrapper #-structure-wrapper vector - #+structure-wrapper t)) + (with-lap-registers ((cwrapper t)) (flatten-lap (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache) @@ -483,8 +466,7 @@ (opcode :label exit-emit-check-1-wrapper-in-cache))))) (defun emit-check-cache-entry (cache-vector location wrapper hit-label) - (with-lap-registers ((cwrapper #-structure-wrapper vector - #+structure-wrapper t)) + (with-lap-registers ((cwrapper t)) (flatten-lap (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) (opcode :eq cwrapper wrapper hit-label)))) @@ -494,8 +476,7 @@ (flatten-lap (gathering1 (flattening-lap) (iterate ((wrapper (list-elements wrappers))) - (with-lap-registers ((cwrapper #-structure-wrapper vector - #+structure-wrapper t)) + (with-lap-registers ((cwrapper t)) (gather1 (flatten-lap (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper) @@ -544,16 +525,12 @@ (defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no) (with-lap-registers ((mask index) - #+structure-wrapper (cnv fixnum-vector)) + (cnv fixnum-vector)) (let ((field wrapper-cache-no)) (flatten-lap (opcode :move (operand :cvar 'mask) mask) (opcode :move (operand :cvar 'field) field) - #-structure-wrapper - (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) - #+structure-wrapper (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - #+structure-wrapper (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no) (opcode :move (operand :ilogand wrapper-cache-no mask) primary))))) @@ -567,13 +544,10 @@ (i (interval :from 1))) (gather1 (with-lap-registers ((wrapper-cache-no index) - #+structure-wrapper (cnv fixnum-vector)) + (cnv fixnum-vector)) (flatten-lap - #-structure-wrapper (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) - #+structure-wrapper (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv) - #+structure-wrapper (opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no) (opcode :izerop wrapper-cache-no miss-label) @@ -592,7 +566,7 @@ (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper"))) (with-lap-registers ((arg t)) (ecase metatype - ((standard-instance #+new-kcl-wrapper structure-instance) + ((standard-instance) (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) (flatten-lap @@ -618,10 +592,7 @@ (opcode :move (operand :arg argument) arg) (opcode :std-instance-p arg get-std-inst-wrapper) (opcode :fsc-instance-p arg get-fsc-inst-wrapper) - #-new-kcl-wrapper (opcode :move (operand :built-in-or-structure-wrapper arg) dest) - #+new-kcl-wrapper - (opcode :move (operand :built-in-wrapper arg) dest) (opcode :go exit-emit-fetch-wrapper) (opcode :label get-fsc-inst-wrapper) (opcode :move (operand :fsc-wrapper arg) dest) @@ -629,15 +600,12 @@ (opcode :label get-std-inst-wrapper) (opcode :move (operand :std-wrapper arg) dest) (opcode :label exit-emit-fetch-wrapper)))) - ((built-in-instance #-new-kcl-wrapper structure-instance) + ((built-in-instance structure-instance) (when slot (error "Can't do a slot reg for this metatype.")) (let () (flatten-lap (opcode :move (operand :arg argument) arg) (opcode :std-instance-p arg miss-label) (opcode :fsc-instance-p arg miss-label) - #-new-kcl-wrapper - (opcode :move (operand :built-in-or-structure-wrapper arg) dest) - #+new-kcl-wrapper - (opcode :move (operand :built-in-wrapper arg) dest)))))))) + (opcode :move (operand :built-in-or-structure-wrapper arg) dest)))))))) diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp index b739afa78a4a29c377346e40753abcc6e99a94c5..fd203dabb124904e18e7f5ec17284af1b74b8729 100644 --- a/pcl/dlisp.lisp +++ b/pcl/dlisp.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.6 1999/03/11 16:51:05 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.7 1999/05/30 23:13:58 pw Exp $") ;;; (in-package :pcl) @@ -108,7 +108,7 @@ (lambda `(lambda ,closure-variables ,@(when (member 'miss-fn closure-variables) `((declare (type function miss-fn)))) - #'(#+cmu kernel:instance-lambda #-cmu lambda ,args + #'(kernel:instance-lambda ,args #+copy-&rest-arg ,@(when rest `((setq .lap-rest-arg. diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp index 2e84dc3a6c033814bc5df008f4c6820c05761f21..d2cf9e8faa8b18e77d68a6c2e7735383fcc59dfd 100644 --- a/pcl/dlisp2.lisp +++ b/pcl/dlisp2.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.6 1998/12/20 04:30:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.7 1999/05/30 23:13:58 pw Exp $") ;;; (in-package :pcl) @@ -95,7 +95,7 @@ (if cached-emf-p #'(lambda (cache miss-fn) (declare (type function miss-fn)) - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + #'(kernel:instance-lambda (&rest args) (declare #.*optimize-speed*) #+copy-&rest-arg (setq args (copy-list args)) (with-dfun-wrappers (args metatypes) @@ -111,7 +111,7 @@ (invoke-emf emf args)))))))) #'(lambda (cache emf miss-fn) (declare (type function miss-fn)) - #'(#+cmu kernel:instance-lambda #-cmu lambda (&rest args) + #'(kernel:instance-lambda (&rest args) (declare #.*optimize-speed*) #+copy-&rest-arg (setq args (copy-list args)) (with-dfun-wrappers (args metatypes) diff --git a/pcl/dlisp3.lisp b/pcl/dlisp3.lisp index 9bcd4e631680137eb522aa1415f848df794c75cc..93e4e4cac159c522cfc76fafc603f46a303a4528 100644 --- a/pcl/dlisp3.lisp +++ b/pcl/dlisp3.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp3.lisp,v 1.3 1998/12/20 04:30:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp3.lisp,v 1.4 1999/05/30 23:13:58 pw Exp $") ;;; (in-package :pcl) diff --git a/pcl/env.lisp b/pcl/env.lisp index b88325e66c685a25d929a11670a40c24d6478b6d..b7e12dbcc6bd1171f8fb4a507ba5df5cf382b9d9 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.11 1999/03/11 16:51:05 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.12 1999/05/30 23:13:58 pw Exp $") ;;; ;;; Basic environmental stuff. ;;; @@ -39,18 +39,9 @@ (defgeneric describe-object (object stream)) -#-cmu -(defun pcl-describe (object) - (describe-object object *standard-output*) - (values)) - (defmethod describe-object (object stream) - #+cmu (describe object stream)) -#-cmu -(redefine-function 'describe 'pcl-describe) - (defmethod describe-object ((object slot-object) stream) (let* ((class (class-of object)) (slotds (slots-to-inspect class object)) @@ -151,21 +142,12 @@ (when nick (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%" (butlast nick) (first (last nick))))) - (let* (#+cmu (internal (lisp::package-internal-symbols object)) - (internal-count #+cmu (- (lisp::package-hashtable-size internal) - (lisp::package-hashtable-free internal)) - #-cmu 0) - #+cmu (external (lisp::package-external-symbols object)) - (external-count #+cmu (- (lisp::package-hashtable-size external) - (lisp::package-hashtable-free external)) - #-cmu 0)) - #-cmu (do-external-symbols (sym object) - (declare (ignore sym)) - (incf external-count)) - #-cmu (do-symbols (sym object) - (declare (ignore sym)) - (incf internal-count)) - #-cmu (decf internal-count external-count) + (let* ((internal (lisp::package-internal-symbols object)) + (internal-count (- (lisp::package-hashtable-size internal) + (lisp::package-hashtable-free internal))) + (external (lisp::package-external-symbols object)) + (external-count (- (lisp::package-hashtable-size external) + (lisp::package-hashtable-free external)))) (format stream "It has ~D internal and ~D external symbols (~D total).~%" internal-count external-count (+ internal-count external-count))) (let ((used (package-use-list object))) @@ -177,16 +159,13 @@ (format stream "It is used by the packages ~{~S~^, ~}.~%" (mapcar #'package-name users))))) -#+cmu (defmethod describe-object ((object package) stream) (describe-package object stream)) -#+cmu (defmethod describe-object ((object hash-table) stream) (format stream "~&~S is an ~a hash table." object - #-cmu17 (lisp::hash-table-kind object) - #+cmu17 (lisp::hash-table-test object)) + (lisp::hash-table-test object)) (format stream "~&Its size is ~d buckets." (lisp::hash-table-size object)) (format stream "~&Its rehash-size is ~d." @@ -303,7 +282,6 @@ (pushnew :portable-commonloops *features*) (pushnew :pcl-structures *features*) -#+cmu (when (find-package "OLD-PCL") (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl)) (symbol-function 'pcl::print-object))) @@ -311,52 +289,45 @@ ;;;; MAKE-LOAD-FORM -#+cmu17 (export '(cl::make-load-form cl::make-load-form-saving-slots) "CL") -#+cmu17 -(progn - (defgeneric make-load-form (object &optional environment)) +(defgeneric make-load-form (object &optional environment)) - (defmethod make-load-form ((object structure-object) &optional environment) - (declare (ignore environment)) - (kernel:make-structure-load-form object)) +(defmethod make-load-form ((object structure-object) &optional environment) + (declare (ignore environment)) + (kernel:make-structure-load-form object)) - (defmethod make-load-form ((object wrapper) &optional env) - (declare (ignore env)) - (let ((pname (kernel:class-proper-name (kernel:layout-class object)))) - (unless pname - (error "Can't dump wrapper for anonymous class:~% ~S" - (kernel:layout-class object))) - `(kernel:class-layout (lisp:find-class ',pname)))) +(defmethod make-load-form ((object wrapper) &optional env) + (declare (ignore env)) + (let ((pname (kernel:class-proper-name (kernel:layout-class object)))) + (unless pname + (error "Can't dump wrapper for anonymous class:~% ~S" + (kernel:layout-class object))) + `(kernel:class-layout (lisp:find-class ',pname)))) - (defun make-load-form-saving-slots (object &key slot-names environment) - (declare (ignore environment)) - (when slot-names - (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~ - slots:~% ~S" - object)) - :just-dump-it-normally)) +(defun make-load-form-saving-slots (object &key slot-names environment) + (declare (ignore environment)) + (when slot-names + (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~ + slots:~% ~S" + object)) + :just-dump-it-normally) ;;; The following are hacks to deal with CMU CL having two different CLASS ;;; classes. ;;; -#+cmu17 (defun coerce-to-pcl-class (class) (if (typep class 'lisp:class) (or (kernel:class-pcl-class class) (find-structure-class (lisp:class-name class))) class)) -#+cmu17 -(progn - (defmethod make-instance ((class lisp:class) &rest stuff) - (apply #'make-instance (coerce-to-pcl-class class) stuff)) - (defmethod change-class (instance (class lisp:class)) - (apply #'change-class instance (coerce-to-pcl-class class)))) +(defmethod make-instance ((class lisp:class) &rest stuff) + (apply #'make-instance (coerce-to-pcl-class class) stuff)) +(defmethod change-class (instance (class lisp:class)) + (apply #'change-class instance (coerce-to-pcl-class class))) -#+cmu17 (macrolet ((frob (&rest names) `(progn ,@(mapcar #'(lambda (name) diff --git a/pcl/extensions.lisp b/pcl/extensions.lisp index a76786899731b604bcb58cfc9978eb2c96f5fdf1..f92f46b794638619681715ab1bc264d62aeabb50 100644 --- a/pcl/extensions.lisp +++ b/pcl/extensions.lisp @@ -16,9 +16,9 @@ ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/extensions.lisp,v 1.2 1998/12/20 04:30:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/extensions.lisp,v 1.3 1999/05/30 23:13:58 pw Exp $") ;;; (in-package 'pcl) @@ -491,10 +491,6 @@ variable-accessors)) ,@body)))) - -#-(or KCL IBCL) (export *extensions-exports* *the-pcl-package*) -#+(or KCL IBCL) -(mapc 'export (list *extensions-exports*) (list *the-pcl-package*)) diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp index f062adb213adf8f26dbbe4feab3b3bcb3296bab2..a8084dc6ec08da04258a7609d315bd2ba7deb34e 100644 --- a/pcl/fast-init.lisp +++ b/pcl/fast-init.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/fast-init.lisp,v 1.4 1998/12/20 04:30:20 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/fast-init.lisp,v 1.5 1999/05/30 23:13:59 pw Exp $") ;;; ;;; This file defines the optimized make-instance functions. ;;; @@ -910,12 +910,10 @@ ;This optimization applys only when the first argument and all the even ;numbered arguments are constants evaluating to interned symbols. -#+cmu (declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) ; Use this definition in any CL implementation supporting ; both define-compiler-macro and load-time-value. -#+cmu (define-compiler-macro make-instance (&whole form &rest args) (declare (ignore args)) (let* ((*make-instance-function-keys* nil) diff --git a/pcl/fin.lisp b/pcl/fin.lisp index 6adfef53b5d3eaad0bbac94d0887c39e10b74a8e..6b08189a6ad6a09c32cc65962dd2bff6674b49b2 100644 --- a/pcl/fin.lisp +++ b/pcl/fin.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.12 1999/03/11 16:51:06 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.13 1999/05/30 23:13:59 pw Exp $") ;;; ;; @@ -152,12 +152,10 @@ explicitly marked saying who wrote it. ;; The debug-name for this function. (funcallable-instance-name nil)) -#+CMU ;;; Note: returns true for non-pcl funcallable structures. (import 'kernel:funcallable-instance-p) -#+CMU -(progn + ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION -- Interface ;;; ;;; Set the function that is called when FIN is called. @@ -182,10 +180,6 @@ explicitly marked saying who wrote it. (defmacro pcl-funcallable-instance-wrapper (x) `(kernel:%funcallable-instance-layout ,x)) - -); End of #+cmu progn - - ;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff. diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp index 0e3b1693bb35a9a68e17545b0ebc6f5d03649ae5..4e2357902cf9e2c1fcdc4fab8a13559e20d63041 100644 --- a/pcl/fngen.lisp +++ b/pcl/fngen.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.7 1998/12/20 04:30:20 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.8 1999/05/30 23:14:00 pw Exp $") ;;; (in-package :pcl) diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp index d7b95a0edfb29ffb3e77f22cafb5eb4ec0974966..fdf45d27e78c836689d4c0569624c9c586ca2528 100644 --- a/pcl/fsc.lisp +++ b/pcl/fsc.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.8 1998/12/20 04:30:20 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.9 1999/05/30 23:14:00 pw Exp $") ;;; ;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS ;;; metaclass. Much of the implementation of this metaclass is actually diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp index b7f57f948b2984610be0e68c1c9117daa73c6d2a..6c2d36f4fc8fb020ef971f0df6c2c3e5e407bbb0 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -1,8 +1,8 @@ ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.8 1998/12/20 04:30:20 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.9 1999/05/30 23:14:00 pw Exp $") ;;; (in-package :pcl) diff --git a/pcl/init.lisp b/pcl/init.lisp index 86acfcff9ef2de6acbf64a4784dcaff358561078..8306291acf80b4f188c549e88a74dda3cc45bab6 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.10 1999/03/11 16:51:09 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.11 1999/05/30 23:14:00 pw Exp $") ;;; ;;; This file defines the initialization and related protocols. ;;; @@ -171,11 +171,7 @@ ;; (let* ((class (class-of instance)) (slotds (class-slots class)) - #-new-kcl-wrapper - (std-p #+cmu17 - (pcl-instance-p instance) - #-cmu17 - (or (std-instance-p instance) (fsc-instance-p instance)))) + (std-p (pcl-instance-p instance))) (dolist (slotd slotds) (let ((slot-name (slot-definition-name slotd)) (slot-initargs (slot-definition-initargs slotd))) diff --git a/pcl/iterate.lisp b/pcl/iterate.lisp index 3c9a306be42431e6c7adacda946ee04dda9f3081..0f736bb2ed1dd7a2167fa2e46751028cdc05c98c 100644 --- a/pcl/iterate.lisp +++ b/pcl/iterate.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/iterate.lisp,v 1.6 1998/12/20 04:30:21 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/iterate.lisp,v 1.7 1999/05/30 23:14:01 pw Exp $") ;;; ;;; Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 @@ -298,16 +298,7 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's (generator (second clause))) (setq let-bindings - (list (list gvar - (cond - #-cmu ; Python thinks this is unreachable. - (leftover-body - ; Have to use this up - `(progn ,@(prog1 leftover-body (setq - leftover-body - nil)) - generator)) - (t generator))))) + (list (list gvar generator))) (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form))))) (push (mv-setq (copy-list vars) let-body) diff --git a/pcl/lap.lisp b/pcl/lap.lisp index 7adddc86401be805ea2a6a2ebd61e31f89c5484f..a9f80e503aa1da94585aa10059de012797b8d58f 100644 --- a/pcl/lap.lisp +++ b/pcl/lap.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/lap.lisp,v 1.7 1998/12/20 04:30:21 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/lap.lisp,v 1.8 1999/05/30 23:14:01 pw Exp $") ;;; (in-package 'pcl) @@ -222,7 +222,6 @@ `(progn (eval-when (load eval) (load-defopcode ',name ',fn-name)) (defun ,fn-name ,lambda-list - #+Genera (declare (sys:function-parent ,name defopcode)) (defopcode-1 ',name ',types ,@lambda-list))))) (defmacro defoperand (name types) @@ -232,7 +231,6 @@ `(progn (eval-when (load eval) (load-defoperand ',name ',fn-name)) (defun ,fn-name ,lambda-list - #+Genera (declare (sys:function-parent ,name defoperand)) (defoperand-1 ',name ',types ,@lambda-list))))) (defun load-defopcode (name fn-name) diff --git a/pcl/low.lisp b/pcl/low.lisp index ce57ef71e3e9af99924f2fa94e1978faf62ce977..9460e2e85910ae4631affdea783fba61e9f7660a 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.10 1999/03/11 16:51:10 pw Exp $") + "$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 @@ -113,22 +113,12 @@ ;;; ;;; Very Low-Level representation of instances with meta-class standard-class. ;;; -#-new-kcl-wrapper -(progn -#-cmu17 -(defstruct (std-instance (:predicate std-instance-p) - (:conc-name %std-instance-) - (:constructor %%allocate-instance--class ()) - (:print-function print-std-instance)) - (wrapper nil) - (slots nil)) (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)) @@ -266,13 +256,9 @@ ;;; (defvar *compiler-present-p* t) -(defvar *compiler-speed* - #+(or KCL IBCL GCLisp CMU) :slow - #-(or KCL IBCL GCLisp CMU) :fast) +(defvar *compiler-speed* :slow) -(defvar *compiler-reentrant-p* - #+(and (not XKCL) (or KCL IBCL)) nil - #-(and (not XKCL) (or KCL IBCL)) t) +(defvar *compiler-reentrant-p* t) (defun in-the-compiler-p () ) diff --git a/pcl/macros.lisp b/pcl/macros.lisp index a8a7cf540fcf3ee3a9631627c29476b4a825ef43..63e8f509fcda57536abf070abaf32e478f4d8d0b 100644 --- a/pcl/macros.lisp +++ b/pcl/macros.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.13 1999/04/25 12:46:28 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.14 1999/05/30 23:14:03 pw Exp $") ;;; ;;; Macros global variable definitions, and other random support stuff used ;;; by the rest of the system. @@ -38,15 +38,15 @@ (in-package :pcl) (proclaim '(declaration - #-Genera values ;I use this so that Zwei can remind - ;me what values a function returns. + values ;;I use this so that Zwei can remind + ;;me what values a function returns. - #-Genera arglist ;Tells me what the pretty arglist - ;of something (which probably takes - ;&rest args) is. + arglist ;;Tells me what the pretty arglist + ;;of something (which probably takes + ;;&rest args) is. - #-Genera indentation ;Tells ZWEI how to indent things - ;like defclass. + indentation ;;Tells ZWEI how to indent things + ;;like defclass. class variable-rebinding pcl-fast-call @@ -164,10 +164,6 @@ (return-from get-declaration (cdr form)))))) -#+Lucid -(eval-when (compile load eval) - (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid))))) - (defvar *keyword-package* (find-package 'keyword)) (defun make-keyword (symbol) @@ -260,18 +256,15 @@ ((null pat) ()) (if (symbolp (setq var (car pat))) (progn - #-:coral (unless (memq var '(nil ignore)) - (push var *destructure-vars*)) - #+:coral (push var *destructure-vars*) + (unless (memq var '(nil ignore)) + (push var *destructure-vars*)) (cond ((null (cdr pat)) (push (make-pop var form ()) setqs)) ((symbolp (cdr pat)) (push (make-pop var form (cdr pat)) setqs) (push (cdr pat) *destructure-vars*) (return ())) - #-:coral ((memq var '(nil ignore)) (incf pending-pops)) - #-:coral ((memq (cadr pat) '(nil ignore)) (push (make-pop var form ()) setqs) (incf pending-pops 1)) @@ -335,18 +328,7 @@ ;;; Similar to printing-random-object in the lisp machine but much simpler ;;; and machine independent. (defmacro printing-random-thing ((thing stream) &body body) - #+cmu17 - `(print-unreadable-object (,thing ,stream :identity t) ,@body) - #-cmu17 - (once-only (thing stream) - `(progn - (when *print-readably* - (error "~S cannot be printed readably." thing)) - (format ,stream "#<") - ,@body - (format ,stream " ") - (printing-random-thing-internal ,thing ,stream) - (format ,stream ">")))) + `(print-unreadable-object (,thing ,stream :identity t) ,@body)) (defun printing-random-thing-internal (thing stream) (declare (ignore thing stream)) @@ -376,23 +358,6 @@ (unless dashes-p (setf (elt string i) #\space))) (t (setq flag nil)))))) -#-(or lucid kcl) -(eval-when (compile load eval) -;(warn "****** Things will go faster if you fix define-compiler-macro") -) - -#-cmu -(defmacro define-compiler-macro (name arglist &body body) - #+(or lucid kcl) - `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro - ,name ,arglist - ,@body) - #-(or kcl lucid) - (declare (ignore name arglist body)) - #-(or kcl lucid) - nil) - - ;;; ;;; FIND-CLASS ;;; @@ -463,7 +428,7 @@ ; Use this definition in any CL implementation supporting ; both define-compiler-macro and load-time-value. -#+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class +; Note that in CMU, lisp:find-class /= pcl:find-class (define-compiler-macro find-class (&whole form symbol &optional (errorp t) environment) (declare (ignore environment)) @@ -476,9 +441,6 @@ (class-cell (make-symbol "CLASS-CELL"))) `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) (or (find-class-cell-class ,class-cell) - #-cmu17 - (find-class-from-cell ',symbol ,class-cell ,errorp) - #+cmu17 ,(if errorp `(find-class-from-cell ',symbol ,class-cell t) `(and (kernel:class-cell-class @@ -537,12 +499,10 @@ (setq tail (funcall ,by tail)))))) (defmacro function-funcall (form &rest args) - #-cmu `(funcall ,form ,@args) - #+cmu `(funcall (the function ,form) ,@args)) + `(funcall (the function ,form) ,@args)) (defmacro function-apply (form &rest args) - #-cmu `(apply ,form ,@args) - #+cmu `(apply (the function ,form) ,@args)) + `(apply (the function ,form) ,@args)) (defsetf slot-value set-slot-value) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index df445118419568878b7223b97d981685f74ee3dd..63ca9ebd5a18017bcc8e1fdfe628a234000cc9b1 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.12 1998/12/20 04:30:21 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.13 1999/05/30 23:14:03 pw Exp $") ;;; (in-package :pcl) @@ -1033,7 +1033,7 @@ (mec-all-class-lists (method-specializers method) precompute-p)))) cache))) -#+cmu + (defmacro class-test (arg class) (cond ((eq class *the-class-t*) 't) @@ -1045,9 +1045,6 @@ `(std-instance-p ,arg)) ((eq class *the-class-funcallable-standard-object*) `(fsc-instance-p ,arg)) - #-cmu17 - ((eq class *the-class-structure-object*) - `(memq ',class (class-precedence-list (class-of ,arg)))) ;; TYPEP is now sometimes faster than doing memq of the cpl (t `(typep ,arg ',(class-name class))))) @@ -1186,8 +1183,6 @@ new-type `(and ,new-type ,@so-far))))) -#+lcl3.0 (dont-use-production-compiler) - (defun generate-discrimination-net-internal (gf methods types methods-function test-function type-function) (let* ((arg-info (gf-arg-info gf)) @@ -1246,8 +1241,6 @@ (do-if t) (do-if nil)))))))))) (do-column precedence methods ())))) -#+lcl3.0 (use-previous-compiler) - (defun compute-secondary-dispatch-function (generic-function net &optional method-alist wrappers) (function-funcall (compute-secondary-dispatch-function1 generic-function net) @@ -1390,10 +1383,9 @@ (make-fast-method-call-lambda-list metatypes applyp)))) (multiple-value-bind (cfunction constants) - (get-function1 `(#+cmu ,(if function-p - 'kernel:instance-lambda - 'lambda) - #-cmu lambda + (get-function1 `(,(if function-p + 'kernel:instance-lambda + 'lambda) ,arglist ,@(unless function-p `((declare (ignore .pv-cell. diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index 55f21b5ad7bf116f806511add378b46b574a1e71..5617e083d25695accf3e3a21172ac645647427e0 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.15 1998/12/20 04:30:22 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.16 1999/05/30 23:14:05 pw Exp $") ;;; ;;; CMUCL 18a: Jan-1998 -- Changing to DEFPACKAGE. ;;; Note that at this time CMUCL is not in compliance with ANSI @@ -55,19 +55,12 @@ "*ITERATE-WARNINGS*")) (defpackage "PCL" (:use :common-lisp :walker :iterate) - #+CMU (:shadow "DESTRUCTURING-BIND") - #+cmu17 (:shadow "FIND-CLASS" "CLASS-NAME" "CLASS-OF" "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS" "STANDARD-CLASS") - - #+cmu (:shadow "DOTIMES") - - #+cmu (:import-from :kernel "FUNCALLABLE-INSTANCE-P") - (:shadow "DOCUMENTATION") @@ -115,12 +108,9 @@ "SLOT-UNBOUND" "SLOT-VALUE" "STANDARD" - #-CMU17 "STANDARD-CLASS" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" - #-CMU17 "STRUCTURE-CLASS" - #-CMU17 "SYMBOL-MACROLET" "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WITH-ACCESSORS" @@ -146,9 +136,7 @@ "STANDARD-EFFECTIVE-SLOT-DEFINITION" "SPECIALIZER" "EQL-SPECIALIZER" - #-CMU17 "BUILT-IN-CLASS" "FORWARD-REFERENCED-CLASS" - #-CMU17 "STANDARD-CLASS" "FUNCALLABLE-STANDARD-CLASS" "FUNCALLABLE-STANDARD-OBJECT") diff --git a/pcl/plap.lisp b/pcl/plap.lisp index fd69ba4bf4d2bb4b7c42aae62a6c60d56c26f11b..bddcbd184f60d1f5c76023a3ba5c019153df24d0 100644 --- a/pcl/plap.lisp +++ b/pcl/plap.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/plap.lisp,v 1.8 1998/12/20 04:30:22 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/plap.lisp,v 1.9 1999/05/30 23:14:06 pw Exp $") ;;; (in-package 'pcl) @@ -97,9 +97,6 @@ (*lap-rest-p* (not (null rest)))) `(lambda ,cvars #'(lambda ,args - #-CMU (declare ,*lap-optimize-declaration*) - #-CMU ,(make-lap-prog-internal i-regs v-regs fv-regs t-regs lap) - #+CMU ;; ;; Use LOCALLY instead of a declare on the lambda so that we don't ;; suppress arg count checking... @@ -123,10 +120,8 @@ (append i-regs v-regs fv-regs t-regs)) (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*)) (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)) - (type #+structure-wrapper cache-number-vector - #-structure-wrapper (simple-array fixnum) - ,@(mapcar #'lap-reg *lap-fv-regs*)) - #-cmu ,*lap-optimize-declaration*) + (type cache-number-vector + ,@(mapcar #'lap-reg *lap-fv-regs*))) ,.code))) (defvar *empty-vector* '#()) @@ -189,7 +184,7 @@ (:exit-lap-in-lisp () `(go exit-lap-in-lisp)) (:break () `(break)) - (:beep () #+Genera`(zl:beep)) + (:beep () ) (:print (val) (lap-operands 'print val)) )) @@ -253,12 +248,10 @@ (proclaim '(declaration pcl-fast-call)) (defmacro RUNTIME\ FUNCALL (fn &rest args) - #+CMU `(funcall (the function ,fn) ,.args) - #-CMU `(funcall ,fn ,.args)) + `(funcall (the function ,fn) ,.args)) (defmacro RUNTIME\ APPLY (fn &rest args) - #+CMU `(apply (the function ,fn) ,.args) - #-CMU `(apply ,fn ,.args)) + `(apply (the function ,fn) ,.args)) (defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg) `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg)) @@ -311,30 +304,18 @@ ;;; Some compilers are so stupid... ;;; (defmacro RUNTIME\ IREF (vector index) - #-structure-wrapper - `(svref (the simple-vector ,vector) (the fixnum ,index)) - #+structure-wrapper `(aref ,vector (the fixnum ,index))) (defmacro RUNTIME\ ISET (vector index value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)) (defmacro RUNTIME\ INSTANCE-REF (vector index) - #-new-kcl-wrapper - `(svref (the simple-vector ,vector) (the fixnum ,index)) - #+new-kcl-wrapper - `(%instance-ref ,vector (the fixnum ,index))) + `(svref (the simple-vector ,vector) (the fixnum ,index))) (defmacro RUNTIME\ INSTANCE-SET (vector index value) - #-new-kcl-wrapper - `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value) - #+new-kcl-wrapper - `(setf (%instance-ref ,vector (the fixnum ,index)) ,value)) + `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)) (defmacro RUNTIME\ SVREF (vector fixnum) - #-structure-wrapper - `(svref (the simple-vector ,vector) (the fixnum ,fixnum)) - #+structure-wrapper `(aref ,vector (the fixnum ,fixnum))) (defmacro RUNTIME\ I+ (index1 index2) @@ -347,8 +328,7 @@ `(the fixnum (1+ (the fixnum ,index)))) (defmacro RUNTIME\ ILOGAND (index1 index2) - #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2))) - #+Lucid `(%logand ,index1 ,index2)) + `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2)))) (defmacro RUNTIME\ ILOGXOR (index1 index2) `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2)))) diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index 8213be7dbc1e6bd5d70821049976c39421811363..6352ac7e50dbfbdcc4ca71b3470451c7c0114f9b 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.7 1999/03/11 16:51:16 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.8 1999/05/30 23:14:06 pw Exp $") ;;; (in-package :pcl) @@ -196,7 +196,7 @@ `(boundp ,slot-name))) (defun make-optimized-structure-slot-value-using-class-method-function (function) - #+cmu (declare (type function function)) + (declare (type function function)) #'(lambda (class object slotd) (let ((value (funcall function object))) (if (eq value *slot-unbound*) @@ -204,13 +204,13 @@ value)))) (defun make-optimized-structure-setf-slot-value-using-class-method-function (function) - #+cmu (declare (type function function)) + (declare (type function function)) #'(lambda (nv class object slotd) (declare (ignore class slotd)) (funcall function nv object))) (defun make-optimized-structure-slot-boundp-using-class-method-function (function) - #+cmu (declare (type function function)) + (declare (type function function)) #'(lambda (class object slotd) (declare (ignore class slotd)) (not (eq (funcall function object) *slot-unbound*)))) @@ -237,7 +237,7 @@ #'make-optimized-std-setf-slot-value-using-class-method-function) (boundp #'make-optimized-std-slot-boundp-using-class-method-function)))) - #+cmu (declare (type function function)) + (declare (type function function)) (values (funcall function fsc-p slot-name index) index)))) (defun make-optimized-std-slot-value-using-class-method-function diff --git a/pcl/slots.lisp b/pcl/slots.lisp index 401b906d616bcb35281a0ec6cc37296519f79296..591fbdca771fa85f175ac19dba730a426a0742a0 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.11 1999/03/11 16:51:16 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.12 1999/05/30 23:14:06 pw Exp $") ;;; (in-package :pcl) @@ -309,7 +309,7 @@ (slotd structure-effective-slot-definition)) (let* ((function (slot-definition-internal-reader-function slotd)) (value (funcall function object))) - #+cmu (declare (type function function)) + (declare (type function function)) (if (eq value *slot-unbound*) (slot-unbound class object (slot-definition-name slotd)) value))) @@ -319,7 +319,7 @@ (object structure-object) (slotd structure-effective-slot-definition)) (let ((function (slot-definition-internal-writer-function slotd))) - #+cmu (declare (type function function)) + (declare (type function function)) (funcall function new-value object))) (defmethod slot-boundp-using-class diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 4ef002f23f59fdb0822f3e025f4e84f565353a2f..c9b2fa7dc4679e597e3e2cc7fa7154428bf27180 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.24 1999/03/14 01:14:14 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.25 1999/05/30 23:14:08 pw Exp $") ;;; (in-package :pcl) @@ -330,8 +330,7 @@ ;; have a wrapper. RES is the incomplete PCL class. The Lisp class ;; does not yet exist. Maybe should return NIL in that case as RES ;; is not useful to the user? - #+cmu17 (and (class-wrapper res)(kernel:layout-class (class-wrapper res))) - #-cmu17 res)) + (and (class-wrapper res)(kernel:layout-class (class-wrapper res))))) (setf (gdefinition 'load-defclass) #'real-load-defclass) @@ -567,11 +566,7 @@ (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'slots) (compute-slots class)) - #-(or cmu17) - (unless (slot-value class 'wrapper) - (setf (slot-value class 'wrapper) (make-wrapper 0 class))) - #+cmu17 - (let ((lclass (lisp:find-class (class-name class)))) + (let ((lclass (lisp:find-class (class-name class)))) (setf (kernel:class-pcl-class lclass) class) (setf (slot-value class 'wrapper) (kernel:class-layout lclass))) (update-pv-table-cache-info class) @@ -709,7 +704,6 @@ (class-wrapper class))))) (with-slots (wrapper slots) class - #+cmu17 (update-lisp-class-layout class nwrapper) (setf slots eslotds (wrapper-instance-slots-layout nwrapper) nlayout @@ -1045,7 +1039,6 @@ (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) (without-interrupts - #+cmu17 (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper ':flush nwrapper)))))) @@ -1070,7 +1063,6 @@ (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) (without-interrupts - #+cmu17 (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper ':obsolete nwrapper) @@ -1112,7 +1104,6 @@ (defvar *the-wrapper-of-structure-object* (class-wrapper (find-class 'structure-object))) -#+cmu17 (define-condition obsolete-structure (error) ((datum :reader obsolete-structure-datum :initarg :datum)) (:report @@ -1125,16 +1116,10 @@ (type-of (obsolete-structure-datum condition)))))) (defun obsolete-instance-trap (owrapper nwrapper instance) - (if (not #-(or cmu17) - (or (std-instance-p instance) (fsc-instance-p instance)) - #+cmu17 - (pcl-instance-p instance)) + (if (not (pcl-instance-p instance)) (if *in-obsolete-instance-trap* *the-wrapper-of-structure-object* (let ((*in-obsolete-instance-trap* t)) - #-cmu17 - (error "The structure ~S is obsolete." instance) - #+cmu17 (error 'obsolete-structure :datum instance))) (let* ((class (wrapper-class* nwrapper)) (copy (allocate-instance class)) ;??? allocate-instance ??? @@ -1292,7 +1277,7 @@ (defmethod class-default-initargs ((class built-in-class)) ()) (defmethod validate-superclass ((c class) (s built-in-class)) - (or (eq s *the-class-t*) #+cmu (eq s *the-class-stream*))) + (or (eq s *the-class-t*) (eq s *the-class-stream*))) diff --git a/pcl/structure-class.lisp b/pcl/structure-class.lisp index 46c812953d0e3bd90ff937d7baf40831f691c04f..613e98bbb3d711d64e5dbdc7e58f2dfb9db26a3d 100644 --- a/pcl/structure-class.lisp +++ b/pcl/structure-class.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/structure-class.lisp,v 1.2 1998/12/20 04:30:22 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/structure-class.lisp,v 1.3 1999/05/30 23:14:09 pw Exp $") ;;; (in-package 'pcl) @@ -94,9 +94,7 @@ (conc-name (or (if defstruct-form (defstruct-form-conc-name defstruct-form)) (slot-value class 'defstruct-conc-name) - (format nil #-excl "~s structure class " - #+excl "~s_STRUCTURE.CLASS_" - name))) + (format nil "~s structure class " name))) (defstruct-predicate (if defstruct-form (defstruct-form-predicate-name defstruct-form))) (pred-name ;; Predicate name for class diff --git a/pcl/user-instances.lisp b/pcl/user-instances.lisp index 0038015f2950d6aeb7119748fe71a892ff7a90fe..e961f38df67c433d385cfec59a6759c00a399f32 100644 --- a/pcl/user-instances.lisp +++ b/pcl/user-instances.lisp @@ -18,9 +18,9 @@ ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/user-instances.lisp,v 1.2 1998/12/20 04:30:23 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/user-instances.lisp,v 1.3 1999/05/30 23:14:09 pw Exp $") ;;; (in-package 'pcl) @@ -129,7 +129,7 @@ (defmacro get-user-instance-slots (x) `(user-vector-instance-slots ,x)) -(eval-when (eval #+cmu load) +(eval-when (eval load) (force-compile 'user-instance-p) (force-compile 'user-instance-slots) (force-compile 'user-instance-wrapper) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index a6e115f071b0dc7e0c3fc42b841eb2d985f24f0d..ae65cb487619689b30facbf2eac41be5be785140 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.14 1999/03/14 01:14:14 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.15 1999/05/30 23:14:09 pw Exp $") ;;; ;;; Permutation vectors. ;;; @@ -57,7 +57,6 @@ (slot-name-lists nil :type list) (call-list nil :type list)) -#+cmu (declaim (ext:freeze-type pv-table)) (defvar *initial-pv-table* (make-pv-table-internal nil nil)) @@ -177,8 +176,7 @@ (iterate ((slot-names (list-elements slot-name-lists))) (when slot-names (let* ((wrapper (pop wrappers)) - (std-p #+cmu17 (typep wrapper 'wrapper) - #-cmu17 t) + (std-p (typep wrapper 'wrapper)) (class (wrapper-class* wrapper)) (class-slots (and std-p (wrapper-class-slots wrapper)))) (dolist (slot-name (cdr slot-names)) @@ -281,7 +279,7 @@ (defun update-all-pv-table-caches (class slot-names) (let* ((cwrapper (class-wrapper class)) - (std-p #+cmu17 (typep cwrapper 'wrapper) #-cmu17 t) + (std-p (typep cwrapper 'wrapper)) (class-slots (and std-p (wrapper-class-slots cwrapper))) (class-slot-p-cell (list nil)) (new-values (mapcar #'(lambda (slot-name) @@ -866,7 +864,7 @@ ,@forms)) (defvar *non-variable-declarations* - '(#+cmu values method-name method-lambda-list + '(values method-name method-lambda-list optimize ftype inline notinline)) (defvar *variable-declarations-with-argument* @@ -1038,14 +1036,7 @@ w (w-t pv-wrappers)) (dolist (arg args) (setq w - #+cmu17 (wrapper-of arg) - #-cmu17 - (cond ((std-instance-p arg) - (std-instance-wrapper arg)) - ((fsc-instance-p arg) - (fsc-instance-wrapper arg)) - (t - (built-in-or-structure-wrapper arg)))) + (wrapper-of arg)) (unless (eq 't (wrapper-state w)) (setq w (check-wrapper-validity arg))) (setf (car w-t) w)) diff --git a/pcl/walk.lisp b/pcl/walk.lisp index 4f89b723cb336847bc1534bf607a9ed4804a2ebc..39b662214c6ba33c9d0d85f4acb4eafca7f5b765 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -24,9 +24,9 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; -#+cmu + (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.15 1998/12/20 04:30:23 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.16 1999/05/30 23:14:10 pw Exp $") ;;; ;;; A simple code walker, based IN PART on: (roll the credits) ;;; Larry Masinter's Masterscope @@ -127,718 +127,7 @@ This most likely source of this error is a program which tries to~%~ to use the PCL portable code walker to build its own evaluator.")) - -;;; -;;; In Coral Common Lisp, the macroexpansion environment is just a list -;;; of environment entries. The cadr of each element specifies the type -;;; of the element. The only types that interest us are CCL::MACRO and -;;; FUNCTION. In these cases the element is interpreted as follows. -;;; -;;; (<function-name> CCL::MACRO . macroexpansion-function) -;;; -;;; (<function-name> FUNCTION . <fn>) -;;; -;;; When in the compiler, <fn> is a gensym which will be -;;; a variable which bound at run-time to the function. -;;; When in the interpreter, <fn> is the actual function. -;;; -;;; -#+:Coral -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (dolist (f functions) - (push (list* f 'function (gensym)) env)) - (dolist (m macros) - (push (list* (car m) 'ccl::macro (cadr m)) env)) - env) - -(defun environment-function (env fn) - (let ((entry (assoc fn env :test #'equal))) - (and entry - (eq (cadr entry) 'function) - (cddr entry)))) -(defun environment-macro (env macro) - (let ((entry (assoc macro env :test #'equal))) - (and entry - (eq (cadr entry) 'ccl::macro) - (cddr entry)))) - -);#+:Coral - - -;;; -;;; Franz Common Lisp is a lot like Coral Lisp. The macroexpansion -;;; environment is just a list of entries. The cadr of each element -;;; specifies the type of the element. The types that interest us -;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE. These -;;; are interpreted as follows: -;;; -;;; (<function-name> FUNCTION . <a lexical closure>) -;;; -;;; This happens in the interpreter with lexically -;;; bound functions. -;;; -;;; (<function-name> COMPILER::FUNCTION-VALUE . <gensym>) -;;; -;;; This happens in the compiler. The gensym represents -;;; a variable which will be bound at run time to the -;;; function object. -;;; -;;; (<function-name> EXCL::MACRO . <a lambda>) -;;; -;;; In both interpreter and compiler, this is the -;;; representation used for macro definitions. -;;; -;;; -#+:ExCL -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (let (#+allegro-v4.1 (env-tail (cdr env)) #+allegro-v4.1 (env (car env))) - (dolist (f functions) - (push (list* f 'function #'unbound-lexical-function) env)) - (dolist (m macros) - (push (list* (car m) 'excl::macro (cadr m)) env)) - #-allegro-v4.1 env #+allegro-v4.1 (cons env env-tail))) - -(defun environment-function (env fn) - (let* (#+allegro-v4.1 (env (car env)) - (entry (assoc fn env :test #'equal))) - (and entry - (or (eq (cadr entry) 'function) - (eq (cadr entry) 'compiler::function-value)) - (cddr entry)))) - -(defun environment-macro (env macro) - (let* (#+allegro-v4.1 (env (car env)) - (entry (assoc macro env :test #'equal))) - (and entry - (eq (cadr entry) 'excl::macro) - (cddr entry)))) - -);#+:ExCL - - -#+Lucid -(progn - -(proclaim '(inline - %alphalex-p - add-contour-to-env-shape - make-function-variable - make-sfc-contour - sfc-contour-type - sfc-contour-elements - add-sfc-contour - add-function-contour - add-macrolet-contour - find-variable-in-contour - find-alist-element-in-contour - find-macrolet-in-contour)) - -(defun %alphalex-p (object) - #-Prime - (eq (cadddr (cddddr object)) 'lucid::%alphalex) - #+Prime - (eq (caddr (cddddr object)) 'lucid::%alphalex)) - -#+Prime -(defun lucid::augment-lexenv-fvars-dummy (lexical vars) - (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '())) - -(defconstant function-contour 1) -(defconstant macrolet-contour 5) - -(defstruct lucid::contour - type - elements) - -(defun add-contour-to-env-shape (contour-type elements env-shape) - (cons (make-contour :type contour-type - :elements elements) - env-shape)) - -(defstruct (variable (:constructor make-variable (name source-type))) - name - (identifier nil) - source-type) - -(defconstant function-sfc-contour 1) -(defconstant macrolet-sfc-contour 8) -(defconstant function-variable-type 1) - -(defun make-function-variable (name) - (make-variable name function-variable-type)) - -(defun make-sfc-contour (type elements) - (cons type elements)) - -(defun sfc-contour-type (sfc-contour) - (car sfc-contour)) - -(defun sfc-contour-elements (sfc-contour) - (cdr sfc-contour)) - -(defun add-sfc-contour (element-list environment type) - (cons (make-sfc-contour type element-list) environment)) - -(defun add-function-contour (variable-list environment) - (add-sfc-contour variable-list environment function-sfc-contour)) - -(defun add-macrolet-contour (alist environment) - (add-sfc-contour alist environment macrolet-sfc-contour)) - -(defun find-variable-in-contour (name contour) - (dolist (element (sfc-contour-elements contour) nil) - (when (eq (variable-name element) name) - (return element)))) - -(defun find-alist-element-in-contour (name contour) - (cdr (assoc name (sfc-contour-elements contour)))) - -(defun find-macrolet-in-contour (name contour) - (find-alist-element-in-contour name contour)) - -(defmacro do-sfc-contours ((contour-var environment &optional result) - &body body) - `(dolist (,contour-var ,environment ,result) ,@body)) - - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let* ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -;;; -;;; with-augmented-environment-internal is where the real work of augmenting -;;; the environment happens. -;;; -(defun with-augmented-environment-internal (env functions macros) - (let ((function-names (mapcar #'first functions)) - (macro-names (mapcar #'first macros)) - (macro-functions (mapcar #'second macros))) - (cond ((or (null env) - (contour-p (first env))) - (when function-names - (setq env (add-contour-to-env-shape function-contour - function-names - env))) - (when macro-names - (setq env (add-contour-to-env-shape macrolet-contour - (pairlis macro-names - macro-functions) - env)))) - ((%alphalex-p env) - (when function-names - (setq env (lucid::augment-lexenv-fvars-dummy env function-names))) - (when macro-names - (setq env (lucid::augment-lexenv-mvars env - macro-names - macro-functions)))) - (t - (when function-names - (setq env (add-function-contour - (mapcar #'make-function-variable function-names) - env))) - (when macro-names - (setq env (add-macrolet-contour - (pairlis macro-names macro-functions) - env))))) - env)) - - -(defun environment-function (env fn) - (cond ((null env) nil) - ((contour-p (first env)) - (if (lucid::find-lexical-function fn env) - t - nil)) - ((%alphalex-p env) - (if (lucid::lexenv-fvar fn env) - t - nil)) - (t (do-sfc-contours (contour env nil) - (let ((type (sfc-contour-type contour))) - (cond ((eql type function-sfc-contour) - (when (find-variable-in-contour fn contour) - (return t))) - ((eql type macrolet-sfc-contour) - (when (find-macrolet-in-contour fn contour) - (return nil))))))))) - -(defun environment-macro (env macro) - (cond ((null env) nil) - ((contour-p (first env)) - (lucid::find-lexical-macro macro env)) - ((%alphalex-p env) - (lucid::lexenv-mvar macro env)) - (t (do-sfc-contours (contour env nil) - (let ((type (sfc-contour-type contour))) - (cond ((eql type function-sfc-contour) - (when (find-variable-in-contour macro contour) - (return nil))) - ((eql type macrolet-sfc-contour) - (let ((fn (find-macrolet-in-contour macro contour))) - (when fn - (return fn)))))))))) - - -);#+Lucid - - - -;;; -;;; On the 3600, the documentation for how the environments are represented -;;; is in sys:sys;eval.lisp. That total information is not repeated here. -;;; The important points are that: -;;; si:env-variables returns a list of which each element is: -;;; -;;; (symbol value) -;;; or (symbol . locative) -;;; -;;; The first form is for lexical variables, the second for -;;; special and instance variables. In either case CADR of -;;; the entry is the value and SETF of CADR is used to change -;;; the value. Variables are looked up with ASSQ. -;;; -;;; si:env-functions returns a list of which each element is: -;;; -;;; (symbol definition) -;;; -;;; where definition is anything that could go in a function cell. -;;; This is used for both local functions and local macros. -;;; -;;; The 3600 stack conses its environments (at least in the interpreter). -;;; This means that code written using this walker and running on the 3600 -;;; must not hold on to the environment after the walk-function returns. -;;; No code in this walker or in PCL does that. -;;; -#+Genera -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - (let ((funs (make-symbol "FNS")) - (macs (make-symbol "MACROS")) - (new (make-symbol "NEW"))) - `(let ((,funs ,functions) - (,macs ,macros) - (,new ())) - (dolist (f ,funs) - (push `(,(car f) ,#'unbound-lexical-function) ,new)) - (dolist (m ,macs) - (push `(,(car m) (special ,(cadr m))) ,new)) - (let* ((.old-env. ,old-env) - (.old-vars. (pop .old-env.)) - (.old-funs. (pop .old-env.)) - (.old-blks. (pop .old-env.)) - (.old-tags. (pop .old-env.)) - (.old-dcls. (pop .old-env.))) - (si:with-interpreter-environment (,new-env - .old-env. - .old-vars. - (append ,new .old-funs.) - .old-blks. - .old-tags. - .old-dcls.) - ,@body))))) - - -(defun environment-function (env fn) - (if (null env) - (values nil nil) - (let ((entry (assoc fn (si:env-functions env) :test #'equal))) - (if (and entry - (or (not (listp (cadr entry))) - (not (eq (caadr entry) 'special)))) - (values (cadr entry) t) - (environment-function (si:env-parent env) fn))))) - -(defun environment-macro (env macro) - (if (null env) - (values nil nil) - (let ((entry (assoc macro (si:env-functions env) :test #'equal))) - (if (and entry - (listp (cadr entry)) - (eq (caadr entry) 'special)) - (values (cadadr entry) t) - (environment-macro (si:env-parent env) macro))))) - -);#+Genera - -#+Cloe-Runtime -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - functions - (dolist (m macros) - (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env))) - env) - -(defun environment-function (env fn) - nil) - -(defun environment-macro (env macro) - (let ((entry (getf env macro))) - (if (and (consp entry) - (eq (car entry) 'compiler::macro)) - (values (cdr entry) t) - (values nil nil)))) - -);#+Cloe-Runtime - - -;;; -;;; In Xerox Lisp, the compiler and interpreter use different structures for -;;; the environment. This doesn't cause a serious problem, the parts of the -;;; environments we are concerned with are fairly similar. -;;; -#+:Xerox -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let* ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -;;; -;;; with-augmented-environment-internal is where the real work of augmenting -;;; the environment happens. Before it gets there, env had better not be NIL -;;; anymore because we have to know what kind of environment we are supposed -;;; to be building up. This is probably never a real concern in practice. -;;; It better not be because we don't do anything about it. -;;; -(defun with-augmented-environment-internal (env functions macros) - (cond - ((compiler::env-p env) - (dolist (f functions) - (setq env (compiler::copy-env-with-function - env f :function))) - (dolist (m macros) - (setq env (compiler::copy-env-with-function - env (car m) :macro (cadr m))))) - (t (setq env (if (il:environment-p env) - (il:\\copy-environment env) - (il:\\make-environment))) - ;; The functions field of the environment is a plist of function names - ;; and conses like (:function . fn) or (:macro . expansion-fn). - ;; Note that we can't smash existing entries in this plist since these - ;; are likely shared with older environments. - (dolist (f functions) - (setf (il:environment-functions env) - (list* f (cons :function #'unbound-lexical-function) - (il:environment-functions env)))) - (dolist (m macros) - (setf (il:environment-functions env) - (list* (car m) (cons :macro (cadr m)) - (il:environment-functions env)))))) - env) - -(defun environment-function (env fn) - (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function)) - ((il:environment-p env) (eq (getf (il:environment-functions env) fn) - :function)) - (t nil))) - -(defun environment-macro (env macro) - (cond ((compiler::env-p env) - (multiple-value-bind (type def) - (compiler:env-fboundp env macro) - (when (eq type :macro) def))) - ((il:environment-p env) - (xcl:destructuring-bind (type . def) - (getf (il:environment-functions env) macro) - (when (eq type :macro) def))) - (t nil))) - -);#+:Xerox - - -;;; -;;; In IBUKI Common Lisp, the macroexpansion environment is a three element -;;; list. The second element describes lexical functions and macros. The -;;; function entries in this list have the form -;;; (<name> . (FUNCTION . (<function-value> . nil)) -;;; The macro entries have the form -;;; (<name> . (MACRO . (<macro-value> . nil)). -;;; -;;; -#+(or KCL IBCL) -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (let ((first (first env)) - (lexicals (second env)) - (third (third env))) - (dolist (f functions) - (push `(,(car f) . (function . (,#'unbound-lexical-function . nil))) - lexicals)) - (dolist (m macros) - (push `(,(car m) . (macro . ( ,(cadr m) . nil))) - lexicals)) - (list first lexicals third))) - -(defun environment-function (env fn) - (when env - (let ((entry (assoc fn (second env)))) - (and entry - (eq (cadr entry) 'function) - (caddr entry))))) - -(defun environment-macro (env macro) - (when env - (let ((entry (assoc macro (second env)))) - (and entry - (eq (cadr entry) 'macro) - (caddr entry))))) -);#+(or KCL IBCL) - - -;;; --- TI Explorer -- - -;;; An environment is a two element list, whose car we can ignore and -;;; whose cadr is list of the local-definitions-frames. Each -;;; local-definitions-frame holds either macros or functions, but not -;;; both. Each frame is a plist of <name> <def> <name> <def> ... where -;;; <name> is a locative to the function cell of the symbol that names -;;; the function or macro, and <def> is the new def or NIL if this is function -;;; redefinition or (cons 'ticl:macro <macro-expansion-function>) if this is a macro -;;; redefinition. -;;; -;;; Here's an example. For the form: -;;; (defun foo () -;;; (macrolet ((bar (a b) (list a b)) -;;; (bar2 (a b) (list a b))) -;;; (flet ((some-local-fn (c d) (print (list c d))) -;;; (another (c d) (print (list c d)))) -;;; (bar (some-local-fn 1 2) 3)))) - -;;; the environment arg to macroexpand-1 when called on -;;; (bar (some-local-fn 1 2) 3) -;;;is -;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL -;;; #<DTP-LOCATIVE 4710671> NIL) -;;; (#<DTP-LOCATIVE 7346562> -;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B))) -;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) -;;; (BLOCK BAR ....)) -;;; #<DTP-LOCATIVE 4710664> -;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B))) -;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) -;;; (BLOCK BAR2 ....)))) -#+TI -(progn - -;;; from sys:site;macros.lisp -(eval-when (compile load eval) - -(DEFMACRO MACRO-DEF? (thing) - `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO))) - -;; the following macro generates code to check the 'local' environment -;; for a macro definition for THE SYMBOL <name>. Such a definition would -;; be set up only by a MACROLET. If a macro definition for <name> is -;; found, its expander function is returned. - -(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment) - `(IF ,local-function-environment - (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name)))) - (DOLIST (frame ,local-function-environment) - ;; <value> is nil or a locative - (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame) - vcell))) - (When value (RETURN (CAR value)))))) - nil))) - - -;;;Edited by Reed Hastings 13 Jan 88 16:29 -(defun environment-macro (env macro) - "returns what macro-function would, ie. the expansion function" - ;;some code picked off macroexpand-1 - (let* ((local-definitions (cadr env)) - (local-def (find-local-definition macro local-definitions))) - (if (macro-def? local-def) - (cdr local-def)))) - -;;;Edited by Reed Hastings 13 Jan 88 16:29 -;;;Edited by Reed Hastings 7 Mar 88 19:07 -(defun environment-function (env fn) - (let* ((local-definitions (cadr env))) - (dolist (frame local-definitions) - (let ((val (getf frame - (ticl::locf (symbol-function fn)) - :not-found-marker))) - (cond ((eq val :not-found-marker)) - ((functionp val) (return t)) - ((and (listp val) - (eq (car val) 'ticl::macro)) - (return nil)) - (t - (error "we are confused"))))))) - - -;;;Edited by Reed Hastings 13 Jan 88 16:29 -;;;Edited by Reed Hastings 7 Mar 88 19:07 -(defun with-augmented-environment-internal (env functions macros) - (let ((local-definitions (cadr env)) - (new-local-fns-frame - (mapcan #'(lambda (fn) - (list (ticl:locf (symbol-function (car fn))) - #'unbound-lexical-function)) - functions)) - (new-local-macros-frame - (mapcan #'(lambda (m) - (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m)))) - macros))) - (when new-local-fns-frame - (push new-local-fns-frame local-definitions)) - (when new-local-macros-frame - (push new-local-macros-frame local-definitions)) - `(,(car env) ,local-definitions))) - - -;;;Edited by Reed Hastings 7 Mar 88 19:07 -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -);#+TI - - -#+(and dec vax common) -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - #'(lambda (op &optional (arg nil arg-p)) - (cond ((eq op :macro-function) - (unless arg-p (error "Invalid environment use.")) - (lookup-macro-function arg env functions macros)) - (arg-p - (error "Invalid environment operation: ~S ~S" op arg)) - (t - (lookup-macro-function op env functions macros))))) - -(defun lookup-macro-function (name env fns macros) - (let ((m (assoc name macros))) - (cond (m (cadr m)) - ((assoc name fns) :function) - (env (funcall env name)) - (t nil)))) - -(defun environment-macro (env macro) - (let ((m (and env (funcall env macro)))) - (and (not (eq m :function)) - m))) - -;;; Nobody calls environment-function. What would it return, anyway? -);#+(and dec vax common) - - -;;; -;;; In Golden Common Lisp, the macroexpansion environment is just a list -;;; of environment entries. Unless the car of the list is :compiler-menv -;;; it is an interpreted environment. The cadr of each element specifies -;;; the type of the element. The only types that interest us are GCL:MACRO -;;; and FUNCTION. In these cases the element is interpreted as follows. -;;; -;;; Compiled: -;;; (<function-name> <gensym> macroexpansion-function) -;;; (<function-name> <fn>) -;;; -;;; Interpreted: -;;; (<function-name> GCL:MACRO macroexpansion-function) -;;; (<function-name> <fn>) -;;; -;;; When in the compiler, <fn> is a gensym which will be -;;; a variable which bound at run-time to the function. -;;; When in the interpreter, <fn> is the actual function. -;;; -;;; -#+gclisp -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (let ((new-entries nil)) - (dolist (f functions) - (push (cons (car f) nil) new-entries)) - (dolist (m macros) - (push (cons (car m) - (if (eq :compiler-menv (car env)) - (if (eq (caadr m) 'lisp::lambda) - `(,(gensym) ,(cadr m)) - `(,(gensym) ,@(cadr m))) - `(gclisp:MACRO ,@(cadr m)))) - new-entries)) - (if (eq :compiler-menv (car env)) - `(:compiler-menv ,@new-entries ,@(cdr env)) - (append new-entries env)))) - -(defun environment-function (env fn) - (let ((entry (lisp::lexical-function fn env))) - (and entry - (eq entry 'lisp::lexical-function) - fn))) - -(defun environment-macro (env macro) - (let ((entry (assoc macro (if (eq :compiler-menv (first env)) - (rest env) - env)))) - (and entry - (consp entry) - (symbolp (car entry)) ;name - (symbolp (cadr entry)) ;gcl:macro or gensym - (nthcdr 2 entry)))) - -);#+gclisp ;;;; CMU Common Lisp version of environment frobbing stuff. @@ -850,8 +139,6 @@ ;;; or a list (MACRO . <function>) (a local macro, with the specifier ;;; expander.) Note that Name may be a (SETF <name>) function. -#+:CMU -(progn (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) @@ -893,8 +180,6 @@ (eq (cadr entry) 'c::macro) (function-lambda-expression (cddr entry)))))) -); end of #+:CMU - (defmacro with-new-definition-in-environment @@ -918,20 +203,11 @@ (,new-env ,old-env :functions ,functions :macros ,macros) ,@body)))) -#-Genera (defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) (let ((gensym (make-symbol name))) (eval `(defmacro ,gensym ,llist ,@body)) (macro-function gensym))) -#+Genera -(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) - (si:defmacro-1 - 'sys:named-lambda 'sys:special (make-symbol name) llist body)) - - - - ;;; ;;; Now comes the real walker. @@ -1028,36 +304,9 @@ ;;; Common Lisp nit: ;;; variable-globally-special-p should be defined in Common Lisp. ;;; -#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs - GCLisp TI pyramid) -(defvar *globally-special-variables* ()) (defun variable-globally-special-p (symbol) - #+Genera (si:special-variable-p symbol) - #+Cloe-Runtime (compiler::specialp symbol) - #+Lucid (lucid::proclaimed-special-p symbol) - #+TI (get symbol 'special) - #+Xerox (il:variable-globally-special-p symbol) - #+(and dec vax common) (get symbol 'system::globally-special) - #+(or KCL IBCL) (si:specialp symbol) - #+excl (get symbol 'excl::.globally-special.) - #+:CMU (eq (ext:info variable kind symbol) :special) - #+HP-HPLabs (member (get symbol 'impl:vartype) - '(impl:fluid impl:global) - :test #'eq) - #+:GCLISP (gclisp::special-p symbol) - #+pyramid (or (get symbol 'lisp::globally-special) - (get symbol - 'clc::globally-special-in-compiler)) - #+:CORAL (ccl::proclaimed-special-p symbol) - #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs - GCLisp TI pyramid :CORAL) - (or (not (null (member symbol *globally-special-variables* :test #'eq))) - (when (eval `(flet ((ref () ,symbol)) - (let ((,symbol '#,(list nil))) - (and (boundp ',symbol) (eq ,symbol (ref)))))) - (push symbol *globally-special-variables*) - t))) + (eq (ext:info variable kind symbol) :special)) ;; @@ -1168,7 +417,7 @@ (define-walker-template SYMBOL-MACROLET walk-symbol-macrolet) (define-walker-template TAGBODY walk-tagbody) (define-walker-template THE (NIL QUOTE EVAL)) -#+cmu(define-walker-template EXT:TRULY-THE (NIL QUOTE EVAL)) +(define-walker-template EXT:TRULY-THE (NIL QUOTE EVAL)) (define-walker-template THROW (NIL EVAL EVAL)) (define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) @@ -1184,36 +433,6 @@ (define-walker-template PROG* walk-prog*) (define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL))))) -#+Genera -(progn - (define-walker-template zl::named-lambda walk-named-lambda) - (define-walker-template SCL:LETF walk-let) - (define-walker-template SCL:LETF* walk-let*) - ) - -#+Lucid -(progn - (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda - #-LCL3.0 sys:named-lambda walk-named-lambda) - ) - -#+(or KCL IBCL) -(progn - (define-walker-template lambda-block walk-named-lambda);Not really right, - ;we don't hack block - ;names anyways. - ) - -#+TI -(progn - (define-walker-template TICL::LET-IF walk-let-if) - ) - -#+:Coral -(progn - (define-walker-template ccl:%stack-block walk-let) - ) - (defvar walk-form-expand-macros-p nil) @@ -1356,10 +575,7 @@ newnewnewform))) ((and (symbolp fn) (not (fboundp fn)) - #+cmu17 - (special-operator-p fn) - #-cmu17 - (special-form-p fn)) + (special-operator-p fn)) (error "~S is a special form, not defined in the CommonLisp.~%~ manual This code walker doesn't know how to walk it.~%~ @@ -1386,8 +602,6 @@ (= (length form) 2) (eq (car form) 'setf))) form) - #+Lispm - ((sys:validate-function-spec form) form) (t (walk-form-internal form context env))))) (case (car template) (REPEAT