diff --git a/pcl/boot.lisp b/pcl/boot.lisp index c3518c30c06db5ad0475f624d654304903292fa9..d9ec902eef86b205dd9fe0122db1f38cea1f014a 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.50 2003/05/04 00:37:34 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.51 2003/05/04 13:11:22 gerd Exp $") (in-package :pcl) @@ -554,6 +554,12 @@ work during bootstrapping. (declare (ignore proto-gf proto-method)) (make-method-lambda-internal method-lambda env)) +(defun get-declaration (name declarations &optional default) + (dolist (d declarations default) + (dolist (form (cdr d)) + (when (and (consp form) (eq (car form) name)) + (return-from get-declaration (cdr form)))))) + (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "~@<The ~s argument to ~s, ~s, is not a lambda form.~@:>" @@ -580,7 +586,7 @@ work during bootstrapping. (list `(class ,a ,s)))) parameters specializers))) - (block-name (nth-value 1 (ext:valid-function-name-p + (block-name (nth-value 1 (valid-function-name-p generic-function-name))) (method-lambda ;; Remove the documentation string and insert the @@ -730,7 +736,7 @@ work during bootstrapping. (function #'identity :type function) call-method-args) -(declaim (ext:freeze-type method-call)) +(declaim (freeze-type method-call)) (defmacro invoke-method-call1 (function args cm-args) `(let ((.function. ,function) @@ -753,7 +759,7 @@ work during bootstrapping. next-method-call arg-info) -(declaim (ext:freeze-type fast-method-call)) +(declaim (freeze-type fast-method-call)) (defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) `(function-funcall (fast-method-call-function ,method-call) @@ -764,7 +770,7 @@ work during bootstrapping. (defstruct fast-instance-boundp (index 0 :type fixnum)) -(declaim (ext:freeze-type fast-instance-boundp)) +(declaim (freeze-type fast-instance-boundp)) (defmacro invoke-effective-method-function-fast (emf restp &rest required-args+rest-arg) @@ -1066,7 +1072,7 @@ work during bootstrapping. (info-accessor-p `(setf ,(caadr form)))) (optimize-slot-writer form required-parameters slots env)) ;; - ((and (ext:valid-function-name-p (car form)) + ((and (valid-function-name-p (car form)) (info-gf-name-p (car form))) (optimize-gf-call form required-parameters calls env)) (t @@ -1078,7 +1084,7 @@ work during bootstrapping. (defun generic-function-name-p (name) - (and (ext:valid-function-name-p name) + (and (valid-function-name-p name) (fboundp name) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) @@ -1376,7 +1382,7 @@ work during bootstrapping. (gf-info-c-a-m-emf-std-p t) gf-info-fast-mf-p) -(declaim (ext:freeze-type arg-info)) +(declaim (freeze-type arg-info)) (defun arg-info-valid-p (arg-info) (not (null (arg-info-number-optional arg-info)))) @@ -1536,7 +1542,7 @@ work during bootstrapping. (early-gf-name gf)))) (setf (gf-precompute-dfun-and-emf-p arg-info) (multiple-value-bind (valid sym) - (ext:valid-function-name-p name) + (valid-function-name-p name) (and valid sym (symbolp sym) (let ((pkg (symbol-package sym)) @@ -1600,8 +1606,8 @@ work during bootstrapping. (or function (if (eq spec 'print-object) #'(kernel:instance-lambda (instance stream) - (printing-random-thing (instance stream) - (format stream "std-instance"))) + (print-unreadable-object (instance stream :identity t) + (format stream "std-instance"))) #'(kernel:instance-lambda (&rest args) (declare (ignore args)) (error "~@<The function of the funcallable instance ~S ~ @@ -2167,7 +2173,7 @@ work during bootstrapping. (declare (ignore more-context more-count)) (when morep (error "~@<~s is not allowed in specialized lambda-lists~@:>" :more)) - (ext:collect ((req) (spec)) + (collect ((req) (spec)) (dolist (x required) (req (if (consp x) (car x) x)) (spec (if (consp x) (cadr x) t))) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 64dad49740215058012e888cf7ad75d7b3225a89..9dbd2c07d2daa92de9a517e9ea0538a18fe9b71c 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.34 2003/04/06 09:10:09 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.35 2003/05/04 13:11:22 gerd Exp $") ;;; ;;; Bootstrapping the meta-braid. @@ -89,7 +89,7 @@ (defmacro initial-classes-and-wrappers (&rest classes) `(progn ,@(mapcar (lambda (class) - (let ((wr (symbolicate *the-pcl-package* class '-wrapper))) + (let ((wr (symbolicate* *the-pcl-package* class '-wrapper))) `(setf ,wr ,(if (eq class 'standard-generic-function) '*sgf-wrapper* `(boot-make-wrapper @@ -109,12 +109,12 @@ (null) (kernel::built-in-class (let ((translation (kernel::built-in-class-translation kernel-class))) - (setf (ext:info type translator class) + (setf (info type translator class) (if translation (lambda (spec) (declare (ignore spec)) translation) (lambda (spec) (declare (ignore spec)) kernel-class))))) (kernel::class - (setf (ext:info type translator class) + (setf (info type translator class) (lambda (spec) (declare (ignore spec)) kernel-class)))))) (defun bootstrap-meta-braid () @@ -190,7 +190,7 @@ (boot-make-wrapper (length slots) name)))) (proto nil)) (when (eq name t) (setq *the-wrapper-of-t* wrapper)) - (set (symbolicate *the-pcl-package* '*the-class- name '*) + (set (symbolicate* *the-pcl-package* '*the-class- name '*) class) (dolist (slot slots) (unless (eq (getf slot :allocation :instance) :instance) @@ -630,7 +630,7 @@ (bootstrap-built-in-classes) (/show " class layouts") - (ext:do-hash (name x *find-class*) + (do-hash (name x *find-class*) (let* ((class (find-class-from-cell name x)) (layout (class-wrapper class)) (lclass (kernel:layout-class layout)) diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 074bc437deee49cff303408518968be017cadc79..f1823910763030661bbe7c3547aaacb80c121e06 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.28 2003/04/13 16:39:22 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.29 2003/05/04 13:11:22 gerd Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. @@ -179,11 +179,11 @@ ;; List of entries not fitting in VECTOR. (overflow nil :type list)) -(declaim (ext:freeze-type cache)) +(declaim (freeze-type cache)) (defun print-cache (cache stream depth) (declare (ignore depth)) - (printing-random-thing (cache stream) + (print-unreadable-object (cache stream :identity t) (format stream "cache ~D ~S ~D" (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache)))) @@ -259,7 +259,7 @@ ;; shared with subclasses inheriting a class slot. (class-slots nil :type list)) -(declaim (ext:freeze-type wrapper)) +(declaim (freeze-type wrapper)) (defmacro wrapper-class (wrapper) `(kernel:%class-pcl-class (kernel:layout-class ,wrapper))) @@ -346,7 +346,7 @@ (defun print-wrapper (wrapper stream depth) (declare (ignore depth)) - (printing-random-thing (wrapper stream) + (print-unreadable-object (wrapper stream :identity t) (format stream "Wrapper ~S" (wrapper-class wrapper)))) (defmacro wrapper-class* (wrapper) diff --git a/pcl/cmucl-documentation.lisp b/pcl/cmucl-documentation.lisp index 45e2f404dbe7ac6ef3ce65cfa079293d12236b9a..b13b6ef07d4d90dd0a5724fa4cd54be588f01cf3 100644 --- a/pcl/cmucl-documentation.lisp +++ b/pcl/cmucl-documentation.lisp @@ -3,8 +3,8 @@ ;;; This code was written by Douglas T. Crosher and has been placed in ;;; the public domain, and is provided 'as is'. -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.11 2003/03/22 16:15:18 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.12 2003/05/04 13:11:22 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -24,36 +24,36 @@ (lisp::function-doc x)) (defmethod documentation ((x list) (doc-type (eql 'function))) - (when (ext:valid-function-name-p x) + (when (valid-function-name-p x) (if (eq (car x) 'setf) - (or (values (ext:info setf documentation (cadr x))) + (or (values (info setf documentation (cadr x))) (and (fboundp x) (documentation (fdefinition x) t))) - (or (values (ext:info function documentation x)) + (or (values (info function documentation x)) (and (fboundp x) (documentation (fdefinition x) t)))))) (defmethod documentation ((x symbol) (doc-type (eql 'function))) - (or (values (ext:info function documentation x)) + (or (values (info function documentation x)) ;; Try the pcl function documentation. (and (fboundp x) (documentation (fdefinition x) 't)))) (defmethod documentation ((x symbol) (doc-type (eql 'setf))) - (values (ext:info setf documentation x))) + (values (info setf documentation x))) (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) - (unless (ext:valid-function-name-p x) + (unless (valid-function-name-p x) (error "Invalid function name ~s" x)) (if (eq 'setf (cadr x)) - (setf (ext:info setf documentation (cadr x)) new-value) - (setf (ext:info function documentation x) new-value)) + (setf (info setf documentation (cadr x)) new-value) + (setf (info function documentation x) new-value)) new-value) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function))) - (setf (ext:info function documentation x) new-value)) + (setf (info function documentation x) new-value)) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf))) - (setf (ext:info setf documentation x) new-value)) + (setf (info setf documentation x) new-value)) ;;; Packages. (defmethod documentation ((x package) (doc-type (eql 't))) @@ -64,74 +64,74 @@ ;;; Types, classes, and structure names. (defmethod documentation ((x kernel::structure-class) (doc-type (eql 't))) - (values (ext:info type documentation (kernel:%class-name x)))) + (values (info type documentation (kernel:%class-name x)))) (defmethod documentation ((x structure-class) (doc-type (eql 't))) - (values (ext:info type documentation (class-name x)))) + (values (info type documentation (class-name x)))) (defmethod documentation ((x kernel::standard-class) (doc-type (eql 't))) - (or (values (ext:info type documentation (kernel:%class-name x))) + (or (values (info type documentation (kernel:%class-name x))) (let ((pcl-class (kernel:%class-pcl-class x))) (and pcl-class (plist-value pcl-class 'documentation))))) (defmethod documentation ((x kernel::structure-class) (doc-type (eql 'type))) - (values (ext:info type documentation (kernel:%class-name x)))) + (values (info type documentation (kernel:%class-name x)))) (defmethod documentation ((x structure-class) (doc-type (eql 'type))) - (values (ext:info type documentation (class-name x)))) + (values (info type documentation (class-name x)))) (defmethod documentation ((x kernel::standard-class) (doc-type (eql 'type))) - (or (values (ext:info type documentation (kernel:%class-name x))) + (or (values (info type documentation (kernel:%class-name x))) (let ((pcl-class (kernel:%class-pcl-class x))) (and pcl-class (plist-value pcl-class 'documentation))))) (defmethod documentation ((x symbol) (doc-type (eql 'type))) - (or (values (ext:info type documentation x)) + (or (values (info type documentation x)) (let ((class (find-class x nil))) (when class (plist-value class 'documentation))))) (defmethod documentation ((x symbol) (doc-type (eql 'structure))) - (when (eq (ext:info type kind x) :instance) - (values (ext:info type documentation x)))) + (when (eq (info type kind x) :instance) + (values (info type documentation x)))) (defmethod (setf documentation) (new-value (x kernel::structure-class) (doc-type (eql 't))) - (setf (ext:info type documentation (kernel:%class-name x)) new-value)) + (setf (info type documentation (kernel:%class-name x)) new-value)) (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) - (setf (ext:info type documentation (class-name x)) new-value)) + (setf (info type documentation (class-name x)) new-value)) (defmethod (setf documentation) (new-value (x kernel::structure-class) (doc-type (eql 'type))) - (setf (ext:info type documentation (kernel:%class-name x)) new-value)) + (setf (info type documentation (kernel:%class-name x)) new-value)) (defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type))) - (setf (ext:info type documentation (class-name x)) new-value)) + (setf (info type documentation (class-name x)) new-value)) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) (if (or (structure-type-p x) (condition-type-p x)) - (setf (ext:info type documentation x) new-value) + (setf (info type documentation x) new-value) (let ((class (find-class x nil))) (if class (setf (plist-value class 'documentation) new-value) - (setf (ext:info type documentation x) new-value))))) + (setf (info type documentation x) new-value))))) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'structure))) - (unless (eq (ext:info type kind x) :instance) + (unless (eq (info type kind x) :instance) (error "~@<~S is not the name of a structure type.~@:>" x)) - (setf (ext:info type documentation x) new-value)) + (setf (info type documentation x) new-value)) ;;; Variables. (defmethod documentation ((x symbol) (doc-type (eql 'variable))) - (values (ext:info variable documentation x))) + (values (info variable documentation x))) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'variable))) - (setf (ext:info variable documentation x) new-value)) + (setf (info variable documentation x) new-value)) ;;; CMUCL random documentation. Compiler-macro documentation is stored ;;; as random-documentation and handled here. (defmethod documentation ((x symbol) (doc-type symbol)) (cdr (assoc doc-type - (values (ext:info random-documentation stuff x))))) + (values (info random-documentation stuff x))))) (defmethod (setf documentation) (new-value (x symbol) (doc-type symbol)) (set-random-documentation x doc-type new-value) diff --git a/pcl/combin.lisp b/pcl/combin.lisp index 077432d4f6e742e0223402d66726f8dcaa1d4e20..37f8482c37d116a9714c5e54ec90e0a7673fccd5 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.14 2003/03/22 16:15:17 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.15 2003/05/04 13:11:22 gerd Exp $") (in-package "PCL") diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp index e432e77cff8a6d71b693657bd9d08459ad06ddb2..1f994c003e564c4d538deece2e89df6dca5a92df 100644 --- a/pcl/cpl.lisp +++ b/pcl/cpl.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.12 2003/04/06 09:10:09 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cpl.lisp,v 1.13 2003/05/04 13:11:22 gerd Rel $") ;;; (in-package :pcl) diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp index d3046cec67394c078fdd6200800e7a8f3455e1d7..7c07aae84b4df9bfac91c235ae17938f35606928 100644 --- a/pcl/ctor.lisp +++ b/pcl/ctor.lisp @@ -45,8 +45,8 @@ ;;; for classes whose definitions are known at the time the function ;;; is called. -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.7 2003/05/02 16:25:51 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.8 2003/05/04 13:11:22 gerd Exp $") (in-package "PCL") @@ -109,7 +109,7 @@ unless (constantp value) collect value)) (eval-when (:compile-toplevel :load-toplevel :execute) - (ext:define-function-name-syntax ctor (name) + (define-function-name-syntax ctor (name) (when (symbolp (cadr name)) (values t (cadr name))))) @@ -212,10 +212,10 @@ ;; ;; Prevent compiler warnings for calling the ctor. (c::define-function-name function-name) - (when (eq (ext:info function where-from function-name) :assumed) - (setf (ext:info function where-from function-name) :defined) - (when (ext:info function assumed-type function-name) - (setf (ext:info function assumed-type function-name) nil))) + (when (eq (info function where-from function-name) :assumed) + (setf (info function where-from function-name) :defined) + (when (info function assumed-type function-name) + (setf (info function assumed-type function-name) nil))) ;; ;; Return code constructing a ctor at load time, which, when ;; called, will set its funcallable instance function to an @@ -385,8 +385,7 @@ (flet ((method-calls (methods args) (loop for method in methods as fn = (method-function method) - collect `(funcall (ext:truly-the function ,fn) - ,args ())))) + collect `(funcall (truly-the function ,fn) ,args ())))) (values `(let (,@(when (or ii-before ii-after) `((.ii-args. (list .instance. ,@initargs)))) @@ -559,7 +558,7 @@ (instance-init-forms slot-vector before-method-p)))) (class-init-forms (unless structure-p - (ext:collect ((forms)) + (collect ((forms)) (dolist (init class-inits (forms)) (destructuring-bind (location type value slot-type) init (forms diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index eb2802af7d49410519071bc51e4fedcfdc209a35..fda35f639624a4b6e226bbd495f894d03188173a 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.26 2003/04/06 09:10:09 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.27 2003/05/04 13:11:22 gerd Exp $") ;;; (in-package :pcl) @@ -133,8 +133,8 @@ options)) (defstruct-p (and (eq *boot-state* 'complete) - (not (or (ext:featurep :loadable-pcl) - (ext:featurep :bootable-pcl))) + (not (or (featurep :loadable-pcl) + (featurep :bootable-pcl))) (let ((mclass (find-class metaclass nil))) (and mclass (*subtypep mclass @@ -180,6 +180,10 @@ (inform-type-system-about-std-class name)) defclass-form))))))) +(defun true (&rest ignore) (declare (ignore ignore)) t) +(defun false (&rest ignore) (declare (ignore ignore)) nil) +(defun zero (&rest ignore) (declare (ignore ignore)) 0) + (defun make-initfunction (initform) (declare (special *initfunctions*)) (cond ((or (eq initform t) diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 37de87e57c0c052ef53ad1466490dde5b42235e7..1255c736bb5a3c704b048aa88f90727346045a3d 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.22 2003/03/22 16:15:17 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.23 2003/05/04 13:11:22 gerd Exp $") (in-package :pcl) @@ -121,11 +121,11 @@ (defun set-random-documentation (type doc-type doc) (let ((pair (assoc doc-type - (ext:info random-documentation stuff type)))) + (info random-documentation stuff type)))) (if pair (setf (cdr pair) doc) (push (cons doc-type doc) - (ext:info random-documentation stuff type))))) + (info random-documentation stuff type))))) (defun load-short-defcombin (type operator ioa doc) (let* ((specializers diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 203a39e00342a749064f304263f45219d34e7ab1..a704827b28d727d79cc08ee64bac2834ee03830c 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -266,15 +266,15 @@ (defun get-built-in-class-symbol (class-name) (or (cadr (assq class-name *built-in-class-symbols*)) - (let ((symbol (symbolicate *the-pcl-package* - '*the-class- class-name '*))) + (let ((symbol (symbolicate* *the-pcl-package* + '*the-class- class-name '*))) (push (list class-name symbol) *built-in-class-symbols*) symbol))) (defun get-built-in-wrapper-symbol (class-name) (or (cadr (assq class-name *built-in-wrapper-symbols*)) - (let ((symbol (symbolicate *the-pcl-package* - '*the-wrapper-of- class-name '*))) + (let ((symbol (symbolicate* *the-pcl-package* + '*the-wrapper-of- class-name '*))) (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) @@ -352,15 +352,15 @@ (kernel:%class-layout class)))) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) - (ext:collect ((res)) + (collect ((res)) (let ((subs (kernel:%class-subclasses class))) (when subs - (ext:do-hash (sub v subs) + (do-hash (sub v subs) (declare (ignore v)) (when (member class (direct-supers sub)) (res sub))))) (res)))) - (ext:collect ((res)) + (collect ((res)) (dolist (bic kernel::built-in-classes) (let* ((name (car bic)) (class (kernel::find-class name))) diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index 0e79c07adb4602e5c77c8f40264477ce0f4e5032..beaa4f21229b2514477a75d9d2f1803b468042a3 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.30 2003/03/22 16:15:17 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.31 2003/05/04 13:11:21 gerd 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 @@ -55,8 +55,8 @@ (in-package :user) -(defpackage "WALKER" (:use :common-lisp)) -(defpackage "PCL" (:use :walker :common-lisp)) +(defpackage "WALKER" (:use :common-lisp :ext)) +(defpackage "PCL" (:use :walker :common-lisp :ext)) (in-package "PCL") ;;; @@ -66,7 +66,7 @@ ;;; (defvar *the-pcl-package* (find-package :pcl)) -(defvar *pcl-system-date* "$Date: 2003/03/22 16:15:17 $") +(defvar *pcl-system-date* "$Date: 2003/05/04 13:11:21 $") (setf (getf ext:*herald-items* :pcl) `(" CLOS based on Gerd's PCL " ,(subseq *pcl-system-date* 7 26))) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index ca23a0a44bddb097c274cab6cae6353c093bf4bc..27e1830a2753a64aa5191afd20d2ec75575cc05d 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.25 2003/04/30 18:42:23 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.26 2003/05/04 13:11:21 gerd Exp $") (in-package :pcl) @@ -281,7 +281,7 @@ And so, we are saved. (defun print-dfun-info (dfun-info stream depth) (declare (ignore depth) (stream stream)) - (printing-random-thing (dfun-info stream) + (print-unreadable-object (dfun-info stream :identity t) (format stream "~A" (type-of dfun-info)))) (defstruct (no-methods @@ -376,7 +376,7 @@ And so, we are saved. (lambda (new arg) (accessor-miss gf new arg dfun-info))))) -(declaim (ext:freeze-type dfun-info)) +(declaim (freeze-type dfun-info)) ;;; diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp index ab8e7a5a127053a1e73ea58d06414709b818e43f..a035fce4f6763281a4f2cc5db3668675bd9f2d57 100644 --- a/pcl/dlisp.lisp +++ b/pcl/dlisp.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.11 2003/03/22 16:15:17 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp.lisp,v 1.12 2003/05/04 13:11:21 gerd Rel $") ;;; (in-package :pcl) diff --git a/pcl/dlisp2.lisp b/pcl/dlisp2.lisp index bf0a89f76833e76e2f9598631481aac7920cf0c6..fbe5c8b99c0dd7d20612848fac1892080e42615f 100644 --- a/pcl/dlisp2.lisp +++ b/pcl/dlisp2.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.11 2003/03/22 16:15:17 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp2.lisp,v 1.12 2003/05/04 13:11:21 gerd Rel $") ;;; (in-package :pcl) diff --git a/pcl/dlisp3.lisp b/pcl/dlisp3.lisp index ea93f461aae2b1a8fd95deac3a78a61cb0d89638..ba940ff2275aaa9fb602e991480b85010e093479 100644 --- a/pcl/dlisp3.lisp +++ b/pcl/dlisp3.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp3.lisp,v 1.7 2003/03/22 16:15:17 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dlisp3.lisp,v 1.8 2003/05/04 13:11:21 gerd Rel $") ;;; (in-package :pcl) diff --git a/pcl/env.lisp b/pcl/env.lisp index 22d50fd87f2a0d76f00c8a57c8024ced301ce465..3b678afc76585f6d92ed23f5dd1f919afc8e6911 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.20 2003/03/26 17:15:22 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/env.lisp,v 1.21 2003/05/04 13:11:21 gerd Exp $") ;;; ;;; Basic environmental stuff. ;;; @@ -218,7 +218,7 @@ (map-all-generic-functions (lambda (gf) (multiple-value-bind (valid base) - (ext:valid-function-name-p (generic-function-name gf)) + (valid-function-name-p (generic-function-name gf)) (declare (ignore valid)) (when (and (symbolp base) (eq (symbol-package base) pkg)) diff --git a/pcl/fin.lisp b/pcl/fin.lisp index 2693762c53ca18436d278e3529a53c68ba5da01e..05ce22ce385a13cb193d96fb1e077d4285ff9f16 100644 --- a/pcl/fin.lisp +++ b/pcl/fin.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.20 2003/03/22 16:15:16 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.21 2003/05/04 13:11:21 gerd Exp $") ;;; ;; diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp index a00a49806a82c56d25562a1bd579372e90657609..c8ac3be7cd78eb0c1daaad94130f6253b3fef898 100644 --- a/pcl/fngen.lisp +++ b/pcl/fngen.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.10 2003/03/22 16:15:16 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fngen.lisp,v 1.11 2003/05/04 13:11:21 gerd Exp $") (in-package :pcl) diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp index ff9bb225f80d2f7a18fbfec5b8495e2c382bea4e..c20842111763828630c88a216519d3e649a4d85e 100644 --- a/pcl/fsc.lisp +++ b/pcl/fsc.lisp @@ -24,8 +24,8 @@ ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.12 2003/05/04 00:37:34 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fsc.lisp,v 1.13 2003/05/04 13:11:21 gerd Rel $") ;;; ;;; 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 6f241fecce6f655e695c99c4258078682763dc97..e27f9635ddbb123e2bb4e8ed40c6a4c612140484 100644 --- a/pcl/generic-functions.lisp +++ b/pcl/generic-functions.lisp @@ -1,7 +1,7 @@ ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.24 2003/05/04 00:37:33 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.25 2003/05/04 13:11:21 gerd Exp $") ;;; (in-package :pcl) diff --git a/pcl/gf-call-optimization.lisp b/pcl/gf-call-optimization.lisp index 1062df52606ee7491fa4fbcba0c568f15dd98440..507c4c677737fecd1d9fc7aef062ef0a623b249a 100644 --- a/pcl/gf-call-optimization.lisp +++ b/pcl/gf-call-optimization.lisp @@ -27,7 +27,7 @@ ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gf-call-optimization.lisp,v 1.3 2003/04/13 16:39:22 gerd Exp $") +(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gf-call-optimization.lisp,v 1.4 2003/05/04 13:11:21 gerd Exp $") (in-package "PCL") @@ -158,8 +158,8 @@ ;; ;; Small quirk here: set this flag so that GET-METHOD-FUNCTION ;; won't try to use the PV cache while it's being computed. - (ext:letf (((pv-table-computing-cache-p table) t)) - (ext:collect ((emfs)) + (letf (((pv-table-computing-cache-p table) t)) + (collect ((emfs)) (dolist (call call-list (coerce (emfs) 'simple-vector)) (emfs (compute-call call all-method-wrappers)))))) diff --git a/pcl/gray-streams-class.lisp b/pcl/gray-streams-class.lisp index a5fd6f22139a01dac5b40b05646f2c3b2cb48cfe..219e21b3bdcf950e6bd8798e901a0b93e7094a5a 100644 --- a/pcl/gray-streams-class.lisp +++ b/pcl/gray-streams-class.lisp @@ -4,8 +4,8 @@ ;;; the Public domain, and is provided 'as is'. ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams-class.lisp,v 1.4 2003/03/22 16:15:16 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams-class.lisp,v 1.5 2003/05/04 13:11:21 gerd Rel $") ;;; ;;; ********************************************************************** ;;; diff --git a/pcl/gray-streams.lisp b/pcl/gray-streams.lisp index 1373236e813ddca4526a84d64d3e94a51ad5c89c..a90136b15b68bc426ea6da4c823ea373f531fd16 100644 --- a/pcl/gray-streams.lisp +++ b/pcl/gray-streams.lisp @@ -4,8 +4,8 @@ ;;; the Public domain, and is provided 'as is'. ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams.lisp,v 1.9 2003/03/22 16:15:16 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams.lisp,v 1.10 2003/05/04 13:11:21 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -422,6 +422,6 @@ ;; Announce ourselves to the world (pushnew :gray-streams *features*) -(setf (getf ext:*herald-items* :gray-streams) +(setf (getf *herald-items* :gray-streams) '(" Gray Streams Protocol Support")) diff --git a/pcl/herald.lisp b/pcl/herald.lisp index 369d49989f5a6cc418945e064d62cdb9f370058b..e116029877ebad22f5450aa17ac293440e96753f 100644 --- a/pcl/herald.lisp +++ b/pcl/herald.lisp @@ -2,7 +2,7 @@ #+(or loadable-pcl bootable-pcl) (progn - (defvar *pcl-system-date* "$Date: 2003/03/22 16:15:16 $") - (setf (getf ext:*herald-items* :pcl) + (defvar *pcl-system-date* "$Date: 2003/05/04 13:11:21 $") + (setf (getf *herald-items* :pcl) `(" CLOS based on Gerd's PCL " ,(subseq *pcl-system-date* 7 26)))) diff --git a/pcl/info.lisp b/pcl/info.lisp index 35fc02f4c65a0afc9b981163ef15ecd53cf6d29c..99a60b7f41be57afb1e2399ac553ef092c4475b9 100644 --- a/pcl/info.lisp +++ b/pcl/info.lisp @@ -36,7 +36,7 @@ ;;; GF is actually non-accessor GF. Clean this up. ;;; (setf symbol-value) should be handled like (setf fdefinition) -(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.3 2003/04/06 09:10:09 gerd Exp $") +(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.4 2003/05/04 13:11:21 gerd Exp $") (in-package "PCL") @@ -99,20 +99,20 @@ ;;; ;;; Declare some new INFO type, under class PCL, plus nicer accessors. ;;; -(ext:define-info-class pcl) -(ext:define-info-type pcl class (or null class-info) nil) -(ext:define-info-type pcl gf (or null gf-info) nil) -(ext:define-info-type pcl seal (or null seal-info) nil) +(define-info-class pcl) +(define-info-type pcl class (or null class-info) nil) +(define-info-type pcl gf (or null gf-info) nil) +(define-info-type pcl seal (or null seal-info) nil) (declaim (inline class-info (setf class-info) gf-info (setf gf-info) seal-info (setf seal-info))) (defun class-info (class-name) - (ext:info pcl class class-name)) + (info pcl class class-name)) (defun (setf class-info) (new-value class-name) - (setf (ext:info pcl class class-name) new-value)) + (setf (info pcl class class-name) new-value)) (defun class-info-or-make (class-name) (let ((info (class-info class-name))) @@ -120,10 +120,10 @@ (setf (class-info class-name) (make-class-info))))) (defun gf-info (gf-name) - (ext:info pcl gf gf-name)) + (info pcl gf gf-name)) (defun (setf gf-info) (new-value gf-name) - (setf (ext:info pcl gf gf-name) new-value)) + (setf (info pcl gf gf-name) new-value)) (defun gf-info-or-make (gf-name) (let ((info (gf-info gf-name))) @@ -131,10 +131,10 @@ (setf (gf-info gf-name) (make-gf-info))))) (defun seal-info (name) - (ext:info pcl seal name)) + (info pcl seal name)) (defun (setf seal-info) (new-value name) - (setf (ext:info pcl seal name) new-value)) + (setf (info pcl seal name) new-value)) (defun seal-info-or-make (name) (let ((info (seal-info name))) @@ -360,7 +360,7 @@ ;;; Return true if NAME is the name of a known generic function. ;;; (defun info-gf-name-p (name) - (when (ext:valid-function-name-p name) + (when (valid-function-name-p name) (or (gf-info name) (when (and (fboundp name) (eq *boot-state* 'complete)) @@ -635,7 +635,7 @@ (warn "~@<Invalid auto-compile declaration ~s.~@:>" form))) (gf-name-p (name) - (ext:valid-function-name-p name))) + (valid-function-name-p name))) (if (null (cdr form)) (setq *auto-compile-global-default* compilep) (dolist (specifier (cdr form)) diff --git a/pcl/init.lisp b/pcl/init.lisp index 3f44fed6419c0d70715a18cdd356dee23bf82379..2f3a23d7b0a63fba629e4befeaeeac1176cc986b 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.21 2003/05/04 00:37:33 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.22 2003/05/04 13:11:21 gerd Exp $") ;;; ;;; This file defines the initialization and related protocols. diff --git a/pcl/low.lisp b/pcl/low.lisp index 51f06f5b11888775e04056b5280014eb947a0f54..1f7a36bf22bd7a112726cd53a94a0f9794bca53c 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.23 2003/03/26 17:15:22 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.24 2003/05/04 13:11:21 gerd Exp $") ;;; ;;; This file contains optimized low-level constructs for PCL. @@ -36,7 +36,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *optimize-speed* '(optimize (speed 3) (safety 0) - (ext:inhibit-warnings 3) #+small (debug 0.5)))) + (inhibit-warnings 3) #+small (debug 0.5)))) ;;; Various macros that include necessary declarations for maximum ;;; performance. @@ -51,7 +51,7 @@ (defmacro %set-svref (vector index new-value) ;; Do it this way so that the evaluation of NEW-VALUE doesn't fall ;; under the *OPTIMIZE-SPEED*. - (ext:once-only ((value new-value)) + (once-only ((value new-value)) `(locally (declare #.*optimize-speed* (inline svref)) (setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)))) @@ -104,7 +104,7 @@ (defun set-function-name (function new-name) "Set the name of a compiled function object and return the function." (declare (special *boot-state* *the-class-standard-generic-function*)) - (when (ext:valid-function-name-p function) + (when (valid-function-name-p function) (setq function (fdefinition function))) (when (funcallable-instance-p function) (if (if (eq *boot-state* 'complete) @@ -123,9 +123,9 @@ (setf (fdefinition new-name) function)) function) -(defun symbolicate (pkg &rest things) +(defun symbolicate* (pkg &rest things) (let ((*package* pkg)) - (apply #'ext:symbolicate things))) + (apply #'symbolicate things))) ;;; @@ -235,13 +235,13 @@ the compiler as completely as possible. Currently this means that (defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) (defmacro get-wrapper (inst) - (ext:once-only ((wrapper `(wrapper-of ,inst))) + (once-only ((wrapper `(wrapper-of ,inst))) `(progn (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") ,wrapper))) (defmacro get-instance-wrapper-or-nil (inst) - (ext:once-only ((wrapper `(wrapper-of ,inst))) + (once-only ((wrapper `(wrapper-of ,inst))) `(if (typep ,wrapper 'wrapper) ,wrapper nil))) @@ -257,15 +257,15 @@ the compiler as completely as possible. Currently this means that (t (internal-error "What kind of instance is this?")))) (defmacro get-slots-or-nil (inst) - (ext:once-only ((n-inst inst)) + (once-only ((n-inst inst)) `(when (pcl-instance-p ,n-inst) (if (std-instance-p ,n-inst) (std-instance-slots ,n-inst) (fsc-instance-slots ,n-inst))))) -(defun print-std-instance (instance stream depth) ;A temporary definition used - (declare (ignore depth)) ;for debugging the bootstrap - (printing-random-thing (instance stream) ;code of PCL (See high.lisp). +(defun print-std-instance (instance stream depth) + (declare (ignore depth)) + (print-unreadable-object (instance stream :identity t) (let ((class (class-of instance))) (if (or (eq class (find-class 'standard-class nil)) (eq class (find-class 'funcallable-standard-class nil)) diff --git a/pcl/macros.lisp b/pcl/macros.lisp index d0ee41e26efe53ea224be77bb0d39d9ba54c84e9..fbbc19de62efcd86966ea39401ab13f1caaf3558 100644 --- a/pcl/macros.lisp +++ b/pcl/macros.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.24 2003/04/18 08:54:41 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.25 2003/05/04 13:11:21 gerd Exp $") ;;; ;;; Macros global variable definitions, and other random support stuff used ;;; by the rest of the system. @@ -43,13 +43,13 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;; (CLASS-PREDICATE <CLASS-NAME> - (ext:define-function-name-syntax class-predicate (name) + (define-function-name-syntax class-predicate (name) (when (symbolp (cadr name)) (values t (cadr name)))) ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>) ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc. - (ext:define-function-name-syntax slot-accessor (name) + (define-function-name-syntax slot-accessor (name) (values (and (symbolp (cadr name)) (consp (cddr name)) (symbolp (caddr name)) @@ -58,48 +58,29 @@ (caddr name))) ;; (METHOD NAME QUALIFIERS (SPECIALIZERS)) - (ext:define-function-name-syntax method (name) - (ext:valid-function-name-p (cadr name))) + (define-function-name-syntax method (name) + (valid-function-name-p (cadr name))) ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS)) - (ext:define-function-name-syntax fast-method (name) - (ext:valid-function-name-p (cadr name))) + (define-function-name-syntax fast-method (name) + (valid-function-name-p (cadr name))) ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...) - (ext:define-function-name-syntax effective-method (name) - (ext:valid-function-name-p (cadr name))) + (define-function-name-syntax effective-method (name) + (valid-function-name-p (cadr name)))) - ;; (CALL FUNCTION)? - ) - -;;; -;;; Age old functions which CommonLisp cleaned-up away. They probably exist -;;; in other packages in all CommonLisp implementations, but I will leave it -;;; to the compiler to optimize into calls to them. -;;; -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro memq (item list) `(member ,item ,list :test #'eq)) - (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) - (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq)) - (defmacro delq (item list) `(delete ,item ,list :test #'eq)) - (defmacro posq (item list) `(position ,item ,list :test #'eq)) - (defmacro neq (x y) `(not (eq ,x ,y)))) +(import '(cl::make-keyword)) -(defun true (&rest ignore) (declare (ignore ignore)) t) -(defun false (&rest ignore) (declare (ignore ignore)) nil) -(defun zero (&rest ignore) (declare (ignore ignore)) 0) +(defmacro posq (item list) + `(position ,item ,list :test #'eq)) -(defun get-declaration (name declarations &optional default) - (dolist (d declarations default) - (dolist (form (cdr d)) - (when (and (consp form) (eq (car form) name)) - (return-from get-declaration (cdr form)))))) +(defmacro neq (x y) + `(not (eq ,x ,y)))) - -(defvar *keyword-package* (find-package "KEYWORD")) - -(defun make-keyword (symbol) - (intern (symbol-name symbol) *keyword-package*)) +(declaim (inline car-safe)) +(defun car-safe (obj) + (when (consp obj) + (car obj))) (defmacro doplist ((key val) plist &body body &environment env) (multiple-value-bind (bod decls doc) @@ -114,28 +95,7 @@ (setq ,val (pop .plist-tail.)) (progn ,@bod))))) -(defmacro dolist-carefully ((var list improper-list-handler) &body body) - `(let ((,var nil) - (.dolist-carefully. ,list)) - (loop (when (null .dolist-carefully.) (return nil)) - (if (consp .dolist-carefully.) - (progn - (setq ,var (pop .dolist-carefully.)) - ,@body) - (,improper-list-handler))))) - - ;; -;;;;;; printing-random-thing - ;; -;;; Similar to printing-random-object in the lisp machine but much simpler -;;; and machine independent. -(defmacro printing-random-thing ((thing stream) &body body) - `(print-unreadable-object (,thing ,stream :identity t) ,@body)) - -(defun printing-random-thing-internal (thing stream) - (declare (ignore thing stream)) - nil) - + ;;; ;;; FIND-CLASS ;;; @@ -255,12 +215,6 @@ (defsetf slot-value set-slot-value) -(declaim (inline car-safe)) - -(defun car-safe (obj) - (when (consp obj) - (car obj))) - (defvar *cold-boot-state* nil) #+pcl-debug diff --git a/pcl/method-slot-access-optimization.lisp b/pcl/method-slot-access-optimization.lisp index 9eaccf605a8092bf38fd80fa8242dbe82777da76..a73dac305dd6774c43e0dc54804788f375051cc6 100644 --- a/pcl/method-slot-access-optimization.lisp +++ b/pcl/method-slot-access-optimization.lisp @@ -51,8 +51,8 @@ ;;; - Prevent PV lookup if only inline access is done? ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/method-slot-access-optimization.lisp,v 1.2 2003/03/22 16:15:16 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/method-slot-access-optimization.lisp,v 1.3 2003/05/04 13:11:21 gerd Exp $") (in-package "PCL") @@ -585,7 +585,7 @@ '(consp .location.) slot-type) (values `(%svref ,slots-variable .location.) - '(ext:fixnump .location.) + '(fixnump .location.) slot-type)))) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 56f91cc98f1248399a9bc3b34732e071dd660455..689473f192203bba0083cef8ac8372c007f2dcd0 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.28 2003/05/04 00:37:33 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.29 2003/05/04 13:11:21 gerd Exp $") (in-package :pcl) @@ -36,7 +36,7 @@ (defun named-object-print-function (instance stream &optional (extra nil extra-p)) - (printing-random-thing (instance stream) + (print-unreadable-object (instance stream :identity t) (if extra-p (format stream "~A ~S ~:S" (class-name (class-of instance)) @@ -47,7 +47,7 @@ (slot-value-or-default instance 'name))))) (defmethod print-object (instance stream) - (printing-random-thing (instance stream) + (print-unreadable-object (instance stream :identity t) (let ((name (class-name (class-of instance)))) (if name (format stream "~S" name) @@ -60,14 +60,14 @@ (named-object-print-function slotd stream)) (defmethod print-object ((mc standard-method-combination) stream) - (printing-random-thing (mc stream) + (print-unreadable-object (mc stream :identity t) (format stream "Method-Combination ~S ~S" (slot-value-or-default mc 'type) (slot-value-or-default mc 'options)))) (defmethod print-object ((method standard-method) stream) - (printing-random-thing (method stream) + (print-unreadable-object (method stream :identity t) (if (slot-boundp method 'generic-function) (let ((gf (method-generic-function method)) (class-name (class-name (class-of method)))) @@ -79,7 +79,7 @@ (call-next-method)))) (defmethod print-object ((method standard-accessor-method) stream) - (printing-random-thing (method stream) + (print-unreadable-object (method stream :identity t) (if (slot-boundp method 'generic-function) (let ((gf (method-generic-function method)) (class-name (class-name (class-of method)))) @@ -213,14 +213,11 @@ "is not a function")) (defmethod legal-qualifiers-p ((object standard-method) x) - (flet ((improper-list () - (return-from legal-qualifiers-p "Is not a proper list."))) - (dolist-carefully (q x improper-list) - (let ((ok (legal-qualifier-p object q))) - (unless (eq ok t) - (return-from legal-qualifiers-p - (format nil "Contains ~S which ~A" q ok))))) - t)) + (dolist (q x t) + (let ((ok (legal-qualifier-p object q))) + (unless (eq ok t) + (return-from legal-qualifiers-p + (format nil "Contains ~S which ~A" q ok)))))) (defmethod legal-qualifier-p ((object standard-method) x) (if (and x (atom x)) @@ -235,14 +232,11 @@ (t t))) (defmethod legal-specializers-p ((object standard-method) x) - (flet ((improper-list () - (return-from legal-specializers-p "is not a proper list."))) - (dolist-carefully (s x improper-list) - (let ((ok (legal-specializer-p object s))) - (unless (eq ok t) - (return-from legal-specializers-p - (format nil "Contains ~S which ~A" s ok))))) - t)) + (dolist (s x t) + (let ((ok (legal-specializer-p object s))) + (unless (eq ok t) + (return-from legal-specializers-p + (format nil "Contains ~S which ~A" s ok)))))) (defmethod legal-specializer-p ((object standard-method) x) (if (if *allow-experimental-specializers-p* diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index 5c1e61782aa3382528cb2098d40ea20b7de8b631..f45b6c6ff65ac4cc208aea7038ae9c52502ad9f4 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -26,11 +26,11 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.25 2003/03/26 17:15:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/pkg.lisp,v 1.26 2003/05/04 13:11:21 gerd Exp $") ;;; ;;; CMUCL 18a: Jan-1998 -- Changing to DEFPACKAGE. -(defpackage "WALKER" (:use :common-lisp) +(defpackage "WALKER" (:use :common-lisp :ext) (:export "DEFINE-WALKER-TEMPLATE" "WALK-FORM" "WALK-FORM-EXPAND-MACROS-P" @@ -43,7 +43,7 @@ "MACROEXPAND-ALL")) (defpackage "PCL" - (:use :common-lisp :walker) + (:use :common-lisp :walker :ext) (:import-from :kernel "FUNCALLABLE-INSTANCE-P" "SIMPLE-PROGRAM-ERROR") (:shadow "DOCUMENTATION") (:export "ADD-METHOD" diff --git a/pcl/seal.lisp b/pcl/seal.lisp index c52a2b68fee034889114ccdb4d26c18dbe35bee0..1d367912755e627b56b074fc54c87afb911ed272 100644 --- a/pcl/seal.lisp +++ b/pcl/seal.lisp @@ -27,7 +27,7 @@ ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/seal.lisp,v 1.2 2003/03/22 16:15:15 gerd Exp $") +(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/seal.lisp,v 1.3 2003/05/04 13:11:21 gerd Rel $") (in-package "PCL") diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index f6dedd536d112c22a0f62ee017afb645946db071..2974f64cd9eb84330506e2a076231345d5d5822a 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.20 2003/04/28 15:18:49 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.21 2003/05/04 13:11:21 gerd Exp $") ;;; (in-package :pcl) diff --git a/pcl/slots.lisp b/pcl/slots.lisp index 2fd01dae4b014bd994771064a68927f18c12fc5d..3218a918cc2c3da1f89d651ff8c75ea2e52babaf 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.20 2003/05/04 00:37:33 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.21 2003/05/04 13:11:20 gerd Exp $") ;;; (in-package :pcl) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 75627f7e4371d81d2b10742e43a6ec8fbb45d1b1..ff8e00f5cfc9b71aa47a206cbf2f8444bcc5505d 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.60 2003/05/04 00:37:33 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.61 2003/05/04 13:11:20 gerd Exp $") (in-package :pcl) @@ -157,7 +157,7 @@ (defmethod (setf documentation) (doc (gf generic-function) type) (declare (ignore type)) - (setf (ext:info function documentation (generic-function-name gf)) + (setf (info function documentation (generic-function-name gf)) doc)) @@ -511,7 +511,7 @@ ;; Initialize shared slots. A class may inherit initforms for ;; shared slots from superclasses. Such initializations are ;; done in UPDATE-CLASS-SLOT-VALUES. - (ext:collect ((cells)) + (collect ((cells)) (dolist (dslotd direct-slots) (when (eq (slot-definition-allocation dslotd) :class) (let ((initfn (slot-definition-initfunction dslotd))) @@ -611,7 +611,7 @@ (when defstruct-p (let* ((slot-name (getf pl :name)) (accessor - (symbolicate + (symbolicate* *package* (if (symbol-package name) (package-name (symbol-package name)) @@ -624,18 +624,18 @@ (setq direct-slots (slot-value class 'direct-slots))) (if defstruct-p (let* ((include (car (slot-value class 'direct-superclasses))) - (conc-name (symbolicate *package* - (if (symbol-package name) - (package-name (symbol-package name)) - "") - "::" name " structure class ")) + (conc-name (symbolicate* *package* + (if (symbol-package name) + (package-name (symbol-package name)) + "") + "::" name " structure class ")) ;; ;; It's not possible to use a generalized name for the ;; constructor function. It shouldn't matter though, I think, ;; like for the slot names above, because this stuff is not ;; supposed to be used by users directly. (constructor - (symbolicate *package* conc-name " constructor")) + (symbolicate* *package* conc-name " constructor")) (defstruct `(defstruct (,name ,@(when include `((:include ,(class-name include)))) @@ -857,7 +857,7 @@ (member class2 (class-can-precede-list class1))) (defun update-slots (class eslotds) - (ext:collect ((instance-slots) (class-slots)) + (collect ((instance-slots) (class-slots)) (dolist (eslotd eslotds) (ecase (slot-definition-allocation eslotd) (:instance (instance-slots eslotd)) @@ -969,7 +969,7 @@ ;;; The list is in most-specific-first order. ;;; (defmethod compute-slots ((class std-class)) - (ext:collect ((names/slots) (effective)) + (collect ((names/slots) (effective)) (dolist (c (reverse (class-precedence-list class))) (dolist (slot (class-direct-slots c)) (let* ((name (slot-definition-name slot)) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index 388aa05378fe644f86df9f12ab36b896c3f7576c..b0d3daa9bfa381f17c4a23a30d6cf1d92a0cbb49 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.27 2003/03/22 16:15:15 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.28 2003/05/04 13:11:20 gerd Exp $") (in-package :pcl) @@ -104,7 +104,7 @@ ;; the pv-table cache. (computing-cache-p nil :type boolean)) -(declaim (ext:freeze-type pv-table)) +(declaim (freeze-type pv-table)) ;;; diff --git a/pcl/walk.lisp b/pcl/walk.lisp index 6673aab67d34df34c4baa730c0604964e35c421a..558211e4d43de1c61c20e1c4881c90463c11d7c9 100644 --- a/pcl/walk.lisp +++ b/pcl/walk.lisp @@ -25,8 +25,8 @@ ;;; ************************************************************************* ;;; -(ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.25 2003/03/31 11:13:22 gerd Exp $") +(file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/walk.lisp,v 1.26 2003/05/04 13:11:20 gerd Rel $") ;;; ;;; A simple code walker, based IN PART on: (roll the credits) ;;; Larry Masinter's Masterscope @@ -338,7 +338,7 @@ ;;; (defun variable-globally-special-p (symbol) - (eq (ext:info variable kind symbol) :special)) + (eq (info variable kind symbol) :special)) ;; @@ -424,7 +424,7 @@ (define-walker-template BLOCK (NIL NIL REPEAT (EVAL))) (define-walker-template CATCH (NIL EVAL REPEAT (EVAL))) -(define-walker-template ext:COMPILER-LET walk-compiler-let) +(define-walker-template COMPILER-LET walk-compiler-let) (define-walker-template DECLARE walk-unexpected-declare) (define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL))) (define-walker-template FLET walk-flet) @@ -449,7 +449,7 @@ (define-walker-template SYMBOL-MACROLET walk-symbol-macrolet) (define-walker-template TAGBODY walk-tagbody) (define-walker-template THE (NIL QUOTE EVAL)) -(define-walker-template EXT:TRULY-THE (NIL QUOTE EVAL)) +(define-walker-template TRULY-THE (NIL QUOTE EVAL)) (define-walker-template THROW (NIL EVAL EVAL)) (define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) @@ -630,7 +630,7 @@ (SET (walk-form-internal form :SET env)) ((LAMBDA CALL) - (cond ((ext:valid-function-name-p form) form) + (cond ((valid-function-name-p form) form) (t (walk-form-internal form context env))))) (case (car template) (REPEAT