X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffast-init.lisp;h=88219f56714dfc516f60497e180091eb17e97071;hb=85b5d31eda93a427acf97f835f78654a9b5c4f4f;hp=8f21ad64c2176db2a3d7acd7017653640c7a104b;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 8f21ad6..88219f5 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -43,7 +43,7 @@ (defun expand-make-instance-form (form) (let ((class (cadr form)) (initargs (cddr form)) - (keys nil)(allow-other-keys-p nil) key value) + (keys nil) (allow-other-keys-p nil) key value) (when (and (constant-symbol-p class) (let ((initargs-tail initargs)) (loop (when (null initargs-tail) (return t)) @@ -51,7 +51,7 @@ (return nil)) (setq key (eval (pop initargs-tail))) (setq value (pop initargs-tail)) - (when (eq ':allow-other-keys key) + (when (eq :allow-other-keys key) (setq allow-other-keys-p value)) (push key keys)))) (let* ((class (eval class)) @@ -64,7 +64,7 @@ ;; 1. Don't worry, I know what I'm doing. ;; 2. You and what army? ;; 3. If you were as smart as you think you are, you - ;; wouldn't be a copy. + ;; wouldn't be a cop. ;; This is case #1.:-) Even if SYM hasn't been defined yet, ;; it must be an implementation function, or we we wouldn't ;; have expanded into it. So declare SYM as defined, so that @@ -88,7 +88,7 @@ (walk-form form env (lambda (subform context env) (declare (ignore env)) - (or (and (eq context ':eval) + (or (and (eq context :eval) (consp subform) (eq (car subform) 'make-instance) (expand-make-instance-form subform)) @@ -128,8 +128,9 @@ (*print-case* :upcase) (*print-pretty* nil)) (intern (format nil - "MAKE-INSTANCE ~S ~S ~S" - class-name + "MAKE-INSTANCE ~A::~A ~S ~S" + (package-name (symbol-package class-name)) + (symbol-name class-name) keys allow-other-keys-p)))))))) @@ -141,7 +142,7 @@ (cached-name (intern (format nil "~A-CACHED-~A" type name)))) `(defmacro ,reader-name (info) `(let ((value (,',cached-name ,info))) - (if (eq value ':unknown) + (if (eq value :unknown) (progn (,',trap ,info ',',name) (,',cached-name ,info)) @@ -154,8 +155,8 @@ initargs-form-list new-keys default-initargs-function - shared-initialize-t-function - shared-initialize-nil-function + shared-initialize-t-fun + shared-initialize-nil-fun constants combined-initialize-function ; allocate-instance + shared-initialize make-instance-function ; nil means use gf @@ -180,12 +181,12 @@ (defmacro reset-initialize-info-internal (info) `(progn ,@(mapcar (lambda (cname) - `(setf (,cname ,info) ':unknown)) + `(setf (,cname ,info) :unknown)) ',cached-names))) (defun initialize-info-bound-slots (info) (let ((slots nil)) ,@(mapcar (lambda (name cached-name) - `(unless (eq ':unknown (,cached-name info)) + `(unless (eq :unknown (,cached-name info)) (push ',name slots))) *initialize-info-cached-slots* cached-names) slots)) @@ -288,7 +289,7 @@ ((default-initargs-function) (let ((initargs-form-list (initialize-info-initargs-form-list info))) (setf (initialize-info-cached-default-initargs-function info) - (initialize-instance-simple-function + (initialize-instance-simple-fun 'default-initargs-function info class initargs-form-list)))) ((valid-p ri-valid-p) @@ -310,21 +311,21 @@ (compute-valid-p (list (list* 'reinitialize-instance proto nil) (list* 'shared-initialize proto nil nil))))))) - ((shared-initialize-t-function) + ((shared-initialize-t-fun) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys t nil) (declare (ignore ignore)) - (setf (initialize-info-cached-shared-initialize-t-function info) - (initialize-instance-simple-function - 'shared-initialize-t-function info + (setf (initialize-info-cached-shared-initialize-t-fun info) + (initialize-instance-simple-fun + 'shared-initialize-t-fun info class initialize-form-list)))) - ((shared-initialize-nil-function) + ((shared-initialize-nil-fun) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys nil nil) (declare (ignore ignore)) - (setf (initialize-info-cached-shared-initialize-nil-function info) - (initialize-instance-simple-function - 'shared-initialize-nil-function info + (setf (initialize-info-cached-shared-initialize-nil-fun info) + (initialize-instance-simple-fun + 'shared-initialize-nil-fun info class initialize-form-list)))) ((constants combined-initialize-function) (let ((initargs-form-list (initialize-info-initargs-form-list info)) @@ -333,7 +334,7 @@ (make-shared-initialize-form-list class new-keys t t) (setf (initialize-info-cached-constants info) constants) (setf (initialize-info-cached-combined-initialize-function info) - (initialize-instance-simple-function + (initialize-instance-simple-fun 'combined-initialize-function info class (append initargs-form-list initialize-form-list)))))) ((make-instance-function-symbol) @@ -391,8 +392,8 @@ (eq (car (method-specializers meth)) *the-class-slot-object*) (and (null (cdr quals)) - (or (eq (car quals) ':before) - (eq (car quals) ':after))))))) + (or (eq (car quals) :before) + (eq (car quals) :after))))))) (and (every #'check-meth initialize-instance-methods) (every #'check-meth shared-initialize-methods)))) (return-from get-make-instance-function nil)) @@ -431,7 +432,7 @@ (defun complicated-instance-creation-method (m) (let ((qual (method-qualifiers m))) (if qual - (not (and (null (cdr qual)) (eq (car qual) ':after))) + (not (and (null (cdr qual)) (eq (car qual) :after))) (let ((specl (car (method-specializers m)))) (or (not (classp specl)) (not (eq 'slot-object (class-name specl)))))))) @@ -491,7 +492,7 @@ initialize-instance-methods))))) (lambda (class1 initargs) (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) (fn (initialize-info-make-instance-function info))) (declare (type function fn)) (funcall fn class1 initargs)) @@ -534,7 +535,7 @@ (list wrapper *the-wrapper-of-t*)))) (lambda (class1 initargs) (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) (fn (initialize-info-make-instance-function info))) (declare (type function fn)) (funcall fn class1 initargs)) @@ -562,9 +563,9 @@ info))) (if separate-p (values default-initargs-function - (initialize-info-shared-initialize-t-function info)) + (initialize-info-shared-initialize-t-fun info)) (values default-initargs-function - (initialize-info-shared-initialize-t-function + (initialize-info-shared-initialize-t-fun (initialize-info class (initialize-info-new-keys info) nil allow-other-keys-arg)))))) @@ -619,7 +620,7 @@ (wrapper (class-wrapper class)) (constants (when simple-p (make-list (wrapper-no-of-instance-slots wrapper) - ':initial-element +slot-unbound+))) + :initial-element +slot-unbound+))) (slots (class-slots class)) (slot-names (mapcar #'slot-definition-name slots)) (slots-key (mapcar (lambda (slot) @@ -688,21 +689,21 @@ (defvar *initialize-instance-simple-alist* nil) (defvar *note-iis-entry-p* nil) -(defvar *compiled-initialize-instance-simple-functions* +(defvar *compiled-initialize-instance-simple-funs* (make-hash-table :test 'equal)) -(defun initialize-instance-simple-function (use info class form-list) +(defun initialize-instance-simple-fun (use info class form-list) (let* ((pv-cell (get-pv-cell-for-class class)) (key (initialize-info-key info)) (sf-key (list* use (class-name (car key)) (cdr key)))) (if (or *compile-make-instance-functions-p* - (gethash sf-key *compiled-initialize-instance-simple-functions*)) + (gethash sf-key *compiled-initialize-instance-simple-funs*)) (multiple-value-bind (form args) (form-list-to-lisp pv-cell form-list) (let ((entry (assoc form *initialize-instance-simple-alist* :test #'equal))) (setf (gethash sf-key - *compiled-initialize-instance-simple-functions*) + *compiled-initialize-instance-simple-funs*) t) (if entry (setf (cdddr entry) (union (list sf-key) (cdddr entry) @@ -734,7 +735,7 @@ (setf (cadr entry) function) (setf (caddr entry) system) (dolist (use uses) - (setf (gethash use *compiled-initialize-instance-simple-functions*) t)) + (setf (gethash use *compiled-initialize-instance-simple-funs*) t)) (setf (cdddr entry) (union uses (cdddr entry) :test #'equal)))) @@ -856,9 +857,9 @@ `((instance-write-internal pv slots ,(const pv-offset) value ,default ,(typecase location - (fixnum ':instance) - (cons ':class) - (t ':default))))))) + (fixnum :instance) + (cons :class) + (t :default))))))) (skip-when-instance-boundp (let* ((pv-offset (cadr form)) (location (pvref pv pv-offset)) @@ -878,9 +879,9 @@ pv slots ,(const pv-offset) ,default ,(typecase (pvref pv pv-offset) - (fixnum ':instance) - (cons ':class) - (t ':default)))) + (fixnum :instance) + (cons :class) + (t :default)))) ,@(let ((sforms (cons nil nil))) (dotimes-fixnum (i (cadddr form) (car sforms)) (add-forms (first-form-to-lisp forms cvector pv)