From: William Harold Newman Date: Thu, 14 Jul 2005 19:28:16 +0000 (+0000) Subject: 0.9.2.49: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git 0.9.2.49: another slice of whitespace canonicalization (Anyone who ends up here with "cvs annotate" probably wants to look at the "tabby" tagged version.) --- diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 87c30fe..4114110 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -69,17 +69,17 @@ bootstrapping. |# (declaim (notinline make-a-method - add-named-method - ensure-generic-function-using-class - add-method - remove-method)) + add-named-method + ensure-generic-function-using-class + add-method + remove-method)) (defvar *!early-functions* - '((make-a-method early-make-a-method - real-make-a-method) - (add-named-method early-add-named-method - real-add-named-method) - )) + '((make-a-method early-make-a-method + real-make-a-method) + (add-named-method early-add-named-method + real-add-named-method) + )) ;;; For each of the early functions, arrange to have it point to its ;;; early definition. Do this in a way that makes sure that if we @@ -87,11 +87,11 @@ bootstrapping. ;;; effect. This makes development easier. (dolist (fns *!early-functions*) (let ((name (car fns)) - (early-name (cadr fns))) + (early-name (cadr fns))) (setf (gdefinition name) (set-fun-name (lambda (&rest args) - (apply (fdefinition early-name) args)) + (apply (fdefinition early-name) args)) name)))) ;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS @@ -99,9 +99,9 @@ bootstrapping. ;;; to be generic functions but can't be early on. (defvar *!generic-function-fixups* '((add-method - ((generic-function method) ;lambda-list + ((generic-function method) ;lambda-list (standard-generic-function method) ;specializers - real-add-method)) ;method-function + real-add-method)) ;method-function (remove-method ((generic-function method) (standard-generic-function method) @@ -112,13 +112,13 @@ bootstrapping. real-get-method)) (ensure-generic-function-using-class ((generic-function fun-name - &key generic-function-class environment - &allow-other-keys) + &key generic-function-class environment + &allow-other-keys) (generic-function t) real-ensure-gf-using-class--generic-function) ((generic-function fun-name - &key generic-function-class environment - &allow-other-keys) + &key generic-function-class environment + &allow-other-keys) (null t) real-ensure-gf-using-class--null)) (make-method-lambda @@ -127,8 +127,8 @@ bootstrapping. real-make-method-lambda)) (make-method-initargs-form ((proto-generic-function proto-method - lambda-expression - lambda-list environment) + lambda-expression + lambda-list environment) (standard-generic-function standard-method t t t) real-make-method-initargs-form)) (compute-effective-method @@ -140,93 +140,93 @@ bootstrapping. (declare (type list lambda-list)) (unless (legal-fun-name-p fun-name) (error 'simple-program-error - :format-control "illegal generic function name ~S" - :format-arguments (list fun-name))) + :format-control "illegal generic function name ~S" + :format-arguments (list fun-name))) (check-gf-lambda-list lambda-list) (let ((initargs ()) - (methods ())) + (methods ())) (flet ((duplicate-option (name) - (error 'simple-program-error - :format-control "The option ~S appears more than once." - :format-arguments (list name))) - (expand-method-definition (qab) ; QAB = qualifiers, arglist, body - (let* ((arglist-pos (position-if #'listp qab)) - (arglist (elt qab arglist-pos)) - (qualifiers (subseq qab 0 arglist-pos)) - (body (nthcdr (1+ arglist-pos) qab))) - `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) + (error 'simple-program-error + :format-control "The option ~S appears more than once." + :format-arguments (list name))) + (expand-method-definition (qab) ; QAB = qualifiers, arglist, body + (let* ((arglist-pos (position-if #'listp qab)) + (arglist (elt qab arglist-pos)) + (qualifiers (subseq qab 0 arglist-pos)) + (body (nthcdr (1+ arglist-pos) qab))) + `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) (generic-function-initial-methods (fdefinition ',fun-name)))))) (macrolet ((initarg (key) `(getf initargs ,key))) - (dolist (option options) - (let ((car-option (car option))) - (case car-option - (declare - (when (and - (consp (cadr option)) - (member (first (cadr option)) - ;; FIXME: this list is slightly weird. - ;; ANSI (on the DEFGENERIC page) in one - ;; place allows only OPTIMIZE; in - ;; another place gives this list of - ;; disallowed declaration specifiers. - ;; This seems to be the only place where - ;; the FUNCTION declaration is - ;; mentioned; TYPE seems to be missing. - ;; Very strange. -- CSR, 2002-10-21 - '(declaration ftype function - inline notinline special))) - (error 'simple-program-error - :format-control "The declaration specifier ~S ~ + (dolist (option options) + (let ((car-option (car option))) + (case car-option + (declare + (when (and + (consp (cadr option)) + (member (first (cadr option)) + ;; FIXME: this list is slightly weird. + ;; ANSI (on the DEFGENERIC page) in one + ;; place allows only OPTIMIZE; in + ;; another place gives this list of + ;; disallowed declaration specifiers. + ;; This seems to be the only place where + ;; the FUNCTION declaration is + ;; mentioned; TYPE seems to be missing. + ;; Very strange. -- CSR, 2002-10-21 + '(declaration ftype function + inline notinline special))) + (error 'simple-program-error + :format-control "The declaration specifier ~S ~ is not allowed inside DEFGENERIC." - :format-arguments (list (cadr option)))) - (push (cadr option) (initarg :declarations))) - (:method-combination - (when (initarg car-option) - (duplicate-option car-option)) - (unless (symbolp (cadr option)) - (error 'simple-program-error - :format-control "METHOD-COMBINATION name not a ~ + :format-arguments (list (cadr option)))) + (push (cadr option) (initarg :declarations))) + (:method-combination + (when (initarg car-option) + (duplicate-option car-option)) + (unless (symbolp (cadr option)) + (error 'simple-program-error + :format-control "METHOD-COMBINATION name not a ~ symbol: ~S" - :format-arguments (list (cadr option)))) - (setf (initarg car-option) - `',(cdr option))) - (:argument-precedence-order - (let* ((required (parse-lambda-list lambda-list)) - (supplied (cdr option))) - (unless (= (length required) (length supplied)) - (error 'simple-program-error - :format-control "argument count discrepancy in ~ + :format-arguments (list (cadr option)))) + (setf (initarg car-option) + `',(cdr option))) + (:argument-precedence-order + (let* ((required (parse-lambda-list lambda-list)) + (supplied (cdr option))) + (unless (= (length required) (length supplied)) + (error 'simple-program-error + :format-control "argument count discrepancy in ~ :ARGUMENT-PRECEDENCE-ORDER clause." - :format-arguments nil)) - (when (set-difference required supplied) - (error 'simple-program-error - :format-control "unequal sets for ~ + :format-arguments nil)) + (when (set-difference required supplied) + (error 'simple-program-error + :format-control "unequal sets for ~ :ARGUMENT-PRECEDENCE-ORDER clause: ~ ~S and ~S" - :format-arguments (list required supplied))) - (setf (initarg car-option) - `',(cdr option)))) - ((:documentation :generic-function-class :method-class) - (unless (proper-list-of-length-p option 2) - (error "bad list length for ~S" option)) - (if (initarg car-option) - (duplicate-option car-option) - (setf (initarg car-option) `',(cadr option)))) - (:method - (push (cdr option) methods)) - (t - ;; ANSI requires that unsupported things must get a - ;; PROGRAM-ERROR. - (error 'simple-program-error - :format-control "unsupported option ~S" - :format-arguments (list option)))))) - - (when (initarg :declarations) - (setf (initarg :declarations) - `',(initarg :declarations)))) + :format-arguments (list required supplied))) + (setf (initarg car-option) + `',(cdr option)))) + ((:documentation :generic-function-class :method-class) + (unless (proper-list-of-length-p option 2) + (error "bad list length for ~S" option)) + (if (initarg car-option) + (duplicate-option car-option) + (setf (initarg car-option) `',(cadr option)))) + (:method + (push (cdr option) methods)) + (t + ;; ANSI requires that unsupported things must get a + ;; PROGRAM-ERROR. + (error 'simple-program-error + :format-control "unsupported option ~S" + :format-arguments (list option)))))) + + (when (initarg :declarations) + (setf (initarg :declarations) + `',(initarg :declarations)))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (compile-or-load-defgeneric ',fun-name)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (compile-or-load-defgeneric ',fun-name)) (load-defgeneric ',fun-name ',lambda-list ,@initargs) ,@(mapcar #'expand-method-definition methods) (fdefinition ',fun-name))))) @@ -237,7 +237,7 @@ bootstrapping. (unless (eq (info :function :where-from fun-name) :declared) (setf (info :function :where-from fun-name) :defined) (setf (info :function :type fun-name) - (specifier-type 'function)))) + (specifier-type 'function)))) (defun load-defgeneric (fun-name lambda-list &rest initargs) (when (fboundp fun-name) @@ -261,13 +261,13 @@ bootstrapping. (defun check-gf-lambda-list (lambda-list) (flet ((ensure (arg ok) (unless ok - (error 'generic-function-lambda-list-error - :format-control - "~@" - :format-arguments (list arg lambda-list))))) + (error 'generic-function-lambda-list-error + :format-control + "~@" + :format-arguments (list arg lambda-list))))) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) - (parse-lambda-list lambda-list) + (parse-lambda-list lambda-list) (declare (ignore required)) ; since they're no different in a gf ll (declare (ignore restp rest)) ; since they're no different in a gf ll (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way @@ -275,23 +275,23 @@ bootstrapping. (declare (ignore more-context more-count)) ; safely ignored unless MOREP ;; no defaults allowed for &OPTIONAL arguments (dolist (i optional) - (ensure i (or (symbolp i) - (and (consp i) (symbolp (car i)) (null (cdr i)))))) + (ensure i (or (symbolp i) + (and (consp i) (symbolp (car i)) (null (cdr i)))))) ;; no defaults allowed for &KEY arguments (when keyp - (dolist (i keys) - (ensure i (or (symbolp i) - (and (consp i) - (or (symbolp (car i)) - (and (consp (car i)) - (symbolp (caar i)) - (symbolp (cadar i)) - (null (cddar i)))) - (null (cdr i))))))) + (dolist (i keys) + (ensure i (or (symbolp i) + (and (consp i) + (or (symbolp (car i)) + (and (consp (car i)) + (symbolp (caar i)) + (symbolp (cadar i)) + (null (cddar i)))) + (null (cdr i))))))) ;; no &AUX allowed (when auxp - (error "&AUX is not allowed in a generic function lambda list: ~S" - lambda-list)) + (error "&AUX is not allowed in a generic function lambda list: ~S" + lambda-list)) ;; Oh, *puhlease*... not specifically as per section 3.4.2 of ;; the ANSI spec, but the CMU CL &MORE extension does not ;; belong here! @@ -301,27 +301,27 @@ bootstrapping. (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) (multiple-value-bind (proto-gf proto-method) - (prototypes-for-make-method-lambda name) + (prototypes-for-make-method-lambda name) (expand-defmethod name - proto-gf - proto-method - qualifiers - lambda-list - body - env)))) + proto-gf + proto-method + qualifiers + lambda-list + body + env)))) (defun prototypes-for-make-method-lambda (name) (if (not (eq *boot-state* 'complete)) (values nil nil) (let ((gf? (and (gboundp name) - (gdefinition name)))) - (if (or (null gf?) - (not (generic-function-p gf?))) - (values (class-prototype (find-class 'standard-generic-function)) - (class-prototype (find-class 'standard-method))) - (values gf? - (class-prototype (or (generic-function-method-class gf?) - (find-class 'standard-method)))))))) + (gdefinition name)))) + (if (or (null gf?) + (not (generic-function-p gf?))) + (values (class-prototype (find-class 'standard-generic-function)) + (class-prototype (find-class 'standard-method))) + (values gf? + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method)))))))) ;;; Take a name which is either a generic function name or a list specifying ;;; a SETF generic function (like: (SETF )). Return @@ -336,119 +336,119 @@ bootstrapping. ;;; Note: During bootstrapping, this function is allowed to return NIL. (defun method-prototype-for-gf (name) (let ((gf? (and (gboundp name) - (gdefinition name)))) + (gdefinition name)))) (cond ((neq *boot-state* 'complete) nil) - ((or (null gf?) - (not (generic-function-p gf?))) ; Someone else MIGHT - ; error at load time. - (class-prototype (find-class 'standard-method))) - (t - (class-prototype (or (generic-function-method-class gf?) - (find-class 'standard-method))))))) + ((or (null gf?) + (not (generic-function-p gf?))) ; Someone else MIGHT + ; error at load time. + (class-prototype (find-class 'standard-method))) + (t + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method))))))) (defun expand-defmethod (name - proto-gf - proto-method - qualifiers - lambda-list - body - env) + proto-gf + proto-method + qualifiers + lambda-list + body + env) (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) (add-method-declarations name qualifiers lambda-list body env) (multiple-value-bind (method-function-lambda initargs) - (make-method-lambda proto-gf proto-method method-lambda env) + (make-method-lambda proto-gf proto-method method-lambda env) (let ((initargs-form (make-method-initargs-form proto-gf - proto-method - method-function-lambda - initargs - env))) - `(progn - ;; Note: We could DECLAIM the ftype of the generic function - ;; here, since ANSI specifies that we create it if it does - ;; not exist. However, I chose not to, because I think it's - ;; more useful to support a style of programming where every - ;; generic function has an explicit DEFGENERIC and any typos - ;; in DEFMETHODs are warned about. Otherwise - ;; - ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) - ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) - ;; - ;; compiles without raising an error and runs without - ;; raising an error (since SIMPLE-VECTOR cases fall through - ;; to VECTOR) but still doesn't do what was intended. I hate - ;; that kind of bug (code which silently gives the wrong - ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 - ,(make-defmethod-form name qualifiers specializers - unspecialized-lambda-list - (if proto-method - (class-name (class-of proto-method)) - 'standard-method) - initargs-form - (getf (getf initargs :plist) - :pv-table-symbol))))))) + proto-method + method-function-lambda + initargs + env))) + `(progn + ;; Note: We could DECLAIM the ftype of the generic function + ;; here, since ANSI specifies that we create it if it does + ;; not exist. However, I chose not to, because I think it's + ;; more useful to support a style of programming where every + ;; generic function has an explicit DEFGENERIC and any typos + ;; in DEFMETHODs are warned about. Otherwise + ;; + ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) + ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) + ;; + ;; compiles without raising an error and runs without + ;; raising an error (since SIMPLE-VECTOR cases fall through + ;; to VECTOR) but still doesn't do what was intended. I hate + ;; that kind of bug (code which silently gives the wrong + ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 + ,(make-defmethod-form name qualifiers specializers + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form + (getf (getf initargs :plist) + :pv-table-symbol))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) (defun make-defmethod-form (name qualifiers specializers - unspecialized-lambda-list method-class-name - initargs-form &optional pv-table-symbol) + unspecialized-lambda-list method-class-name + initargs-form &optional pv-table-symbol) (let (fn - fn-lambda) + fn-lambda) (if (and (interned-symbol-p (fun-name-block-name name)) - (every #'interned-symbol-p qualifiers) - (every (lambda (s) - (if (consp s) - (and (eq (car s) 'eql) - (constantp (cadr s)) - (let ((sv (eval (cadr s)))) - (or (interned-symbol-p sv) - (integerp sv) - (and (characterp sv) - (standard-char-p sv))))) - (interned-symbol-p s))) - specializers) - (consp initargs-form) - (eq (car initargs-form) 'list*) - (memq (cadr initargs-form) '(:function :fast-function)) - (consp (setq fn (caddr initargs-form))) - (eq (car fn) 'function) - (consp (setq fn-lambda (cadr fn))) - (eq (car fn-lambda) 'lambda)) - (let* ((specls (mapcar (lambda (specl) - (if (consp specl) - `(,(car specl) ,(eval (cadr specl))) - specl)) - specializers)) - (mname `(,(if (eq (cadr initargs-form) :function) - 'slow-method 'fast-method) - ,name ,@qualifiers ,specls))) - `(progn - (defun ,mname ,(cadr fn-lambda) - ,@(cddr fn-lambda)) - ,(make-defmethod-form-internal - name qualifiers `',specls - unspecialized-lambda-list method-class-name - `(list* ,(cadr initargs-form) - #',mname - ,@(cdddr initargs-form)) - pv-table-symbol))) - (make-defmethod-form-internal - name qualifiers - `(list ,@(mapcar (lambda (specializer) - (if (consp specializer) - ``(,',(car specializer) - ,,(cadr specializer)) - `',specializer)) - specializers)) - unspecialized-lambda-list - method-class-name - initargs-form - pv-table-symbol)))) + (every #'interned-symbol-p qualifiers) + (every (lambda (s) + (if (consp s) + (and (eq (car s) 'eql) + (constantp (cadr s)) + (let ((sv (eval (cadr s)))) + (or (interned-symbol-p sv) + (integerp sv) + (and (characterp sv) + (standard-char-p sv))))) + (interned-symbol-p s))) + specializers) + (consp initargs-form) + (eq (car initargs-form) 'list*) + (memq (cadr initargs-form) '(:function :fast-function)) + (consp (setq fn (caddr initargs-form))) + (eq (car fn) 'function) + (consp (setq fn-lambda (cadr fn))) + (eq (car fn-lambda) 'lambda)) + (let* ((specls (mapcar (lambda (specl) + (if (consp specl) + `(,(car specl) ,(eval (cadr specl))) + specl)) + specializers)) + (mname `(,(if (eq (cadr initargs-form) :function) + 'slow-method 'fast-method) + ,name ,@qualifiers ,specls))) + `(progn + (defun ,mname ,(cadr fn-lambda) + ,@(cddr fn-lambda)) + ,(make-defmethod-form-internal + name qualifiers `',specls + unspecialized-lambda-list method-class-name + `(list* ,(cadr initargs-form) + #',mname + ,@(cdddr initargs-form)) + pv-table-symbol))) + (make-defmethod-form-internal + name qualifiers + `(list ,@(mapcar (lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) + ,,(cadr specializer)) + `',specializer)) + specializers)) + unspecialized-lambda-list + method-class-name + initargs-form + pv-table-symbol)))) (defun make-defmethod-form-internal (name qualifiers specializers-form unspecialized-lambda-list @@ -473,64 +473,64 @@ bootstrapping. (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda nil) (multiple-value-bind (method-function-lambda initargs) - (make-method-lambda proto-gf proto-method method-lambda env) + (make-method-lambda proto-gf proto-method method-lambda env) (make-method-initargs-form proto-gf - proto-method - method-function-lambda - initargs - env)))) + proto-method + method-function-lambda + initargs + env)))) (defun add-method-declarations (name qualifiers lambda-list body env) (declare (ignore env)) (multiple-value-bind (parameters unspecialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list) (multiple-value-bind (real-body declarations documentation) - (parse-body body) + (parse-body body) (values `(lambda ,unspecialized-lambda-list - ,@(when documentation `(,documentation)) - ;; (Old PCL code used a somewhat different style of - ;; list for %METHOD-NAME values. Our names use - ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the - ;; method names look more like what you see in a - ;; DEFMETHOD form.) - ;; - ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at - ;; least the code to set up named BLOCKs around the - ;; bodies of methods, depends on the function's base - ;; name being the first element of the %METHOD-NAME - ;; list. It would be good to remove this dependency, - ;; perhaps by building the BLOCK here, or by using - ;; another declaration (e.g. %BLOCK-NAME), so that - ;; our method debug names are free to have any format, - ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). - ;; - ;; Further, as of sbcl-0.7.9.10, the code to - ;; implement NO-NEXT-METHOD is coupled to the form of - ;; this declaration; see the definition of - ;; CALL-NO-NEXT-METHOD (and the passing of - ;; METHOD-NAME-DECLARATION arguments around the - ;; various CALL-NEXT-METHOD logic). - (declare (%method-name (,name - ,@qualifiers - ,specializers))) - (declare (%method-lambda-list ,@lambda-list)) - ,@declarations - ,@real-body) - unspecialized-lambda-list specializers)))) + ,@(when documentation `(,documentation)) + ;; (Old PCL code used a somewhat different style of + ;; list for %METHOD-NAME values. Our names use + ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the + ;; method names look more like what you see in a + ;; DEFMETHOD form.) + ;; + ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at + ;; least the code to set up named BLOCKs around the + ;; bodies of methods, depends on the function's base + ;; name being the first element of the %METHOD-NAME + ;; list. It would be good to remove this dependency, + ;; perhaps by building the BLOCK here, or by using + ;; another declaration (e.g. %BLOCK-NAME), so that + ;; our method debug names are free to have any format, + ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). + ;; + ;; Further, as of sbcl-0.7.9.10, the code to + ;; implement NO-NEXT-METHOD is coupled to the form of + ;; this declaration; see the definition of + ;; CALL-NO-NEXT-METHOD (and the passing of + ;; METHOD-NAME-DECLARATION arguments around the + ;; various CALL-NEXT-METHOD logic). + (declare (%method-name (,name + ,@qualifiers + ,specializers))) + (declare (%method-lambda-list ,@lambda-list)) + ,@declarations + ,@real-body) + unspecialized-lambda-list specializers)))) (defun real-make-method-initargs-form (proto-gf proto-method - method-lambda initargs env) + method-lambda initargs env) (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) - (eq (car method-lambda) 'lambda)) + (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~ - is not a lambda form." - method-lambda)) + is not a lambda form." + method-lambda)) (make-method-initargs-form-internal method-lambda initargs env)) (unless (fboundp 'make-method-initargs-form) (setf (gdefinition 'make-method-initargs-form) - (symbol-function 'real-make-method-initargs-form))) + (symbol-function 'real-make-method-initargs-form))) (defun real-make-method-lambda (proto-gf proto-method method-lambda env) (declare (ignore proto-gf proto-method)) @@ -540,73 +540,73 @@ bootstrapping. ;;; in DEFMETHOD forms (defun parameter-specializer-declaration-in-defmethod (parameter specializer) (cond ((and (consp specializer) - (eq (car specializer) 'eql)) - ;; KLUDGE: ANSI, in its wisdom, says that - ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at - ;; DEFMETHOD expansion time. Thus, although one might think - ;; that in - ;; (DEFMETHOD FOO ((X PACKAGE) - ;; (Y (EQL 12)) - ;; ..)) - ;; the PACKAGE and (EQL 12) forms are both parallel type - ;; names, they're not, as is made clear when you do - ;; (DEFMETHOD FOO ((X PACKAGE) - ;; (Y (EQL 'BAR))) - ;; ..) - ;; where Y needs to be a symbol named "BAR", not some cons - ;; made by (CONS 'QUOTE 'BAR). I.e. when the - ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument - ;; to be of type (EQL X). It'd be easy to transform one to - ;; the other, but it'd be somewhat messier to do so while - ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd - ;; once. (The new code wouldn't be messy, but it'd require a - ;; big transformation of the old code.) So instead we punt. - ;; -- WHN 20000610 - '(ignorable)) - ((member specializer - ;; KLUDGE: For some low-level implementation - ;; classes, perhaps because of some problems related - ;; to the incomplete integration of PCL into SBCL's - ;; type system, some specializer classes can't be - ;; declared as argument types. E.g. - ;; (DEFMETHOD FOO ((X SLOT-OBJECT)) - ;; (DECLARE (TYPE SLOT-OBJECT X)) - ;; ..) - ;; loses when - ;; (DEFSTRUCT BAR A B) - ;; (FOO (MAKE-BAR)) - ;; perhaps because of the way that STRUCTURE-OBJECT - ;; inherits both from SLOT-OBJECT and from - ;; SB-KERNEL:INSTANCE. In an effort to sweep such - ;; problems under the rug, we exclude these problem - ;; cases by blacklisting them here. -- WHN 2001-01-19 - '(slot-object)) - '(ignorable)) - ((not (eq *boot-state* 'complete)) - ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with - ;; types which don't match their specializers. (Specifically, - ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL - ;; second argument.) Hopefully it only does this kind of - ;; weirdness when bootstrapping.. -- WHN 20000610 - '(ignorable)) - ((var-globally-special-p parameter) - ;; KLUDGE: Don't declare types for global special variables - ;; -- our rebinding magic for SETQ cases don't work right - ;; there. - ;; - ;; FIXME: It would be better to detect the SETQ earlier and - ;; skip declarations for specials only when needed, not - ;; always. - ;; - ;; --NS 2004-10-14 - '(ignorable)) - (t - ;; Otherwise, we can usually make Python very happy. - (let ((kind (info :type :kind specializer))) - (ecase kind - ((:primitive) `(type ,specializer ,parameter)) - ((:defined) - (let ((class (find-class specializer nil))) + (eq (car specializer) 'eql)) + ;; KLUDGE: ANSI, in its wisdom, says that + ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at + ;; DEFMETHOD expansion time. Thus, although one might think + ;; that in + ;; (DEFMETHOD FOO ((X PACKAGE) + ;; (Y (EQL 12)) + ;; ..)) + ;; the PACKAGE and (EQL 12) forms are both parallel type + ;; names, they're not, as is made clear when you do + ;; (DEFMETHOD FOO ((X PACKAGE) + ;; (Y (EQL 'BAR))) + ;; ..) + ;; where Y needs to be a symbol named "BAR", not some cons + ;; made by (CONS 'QUOTE 'BAR). I.e. when the + ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument + ;; to be of type (EQL X). It'd be easy to transform one to + ;; the other, but it'd be somewhat messier to do so while + ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd + ;; once. (The new code wouldn't be messy, but it'd require a + ;; big transformation of the old code.) So instead we punt. + ;; -- WHN 20000610 + '(ignorable)) + ((member specializer + ;; KLUDGE: For some low-level implementation + ;; classes, perhaps because of some problems related + ;; to the incomplete integration of PCL into SBCL's + ;; type system, some specializer classes can't be + ;; declared as argument types. E.g. + ;; (DEFMETHOD FOO ((X SLOT-OBJECT)) + ;; (DECLARE (TYPE SLOT-OBJECT X)) + ;; ..) + ;; loses when + ;; (DEFSTRUCT BAR A B) + ;; (FOO (MAKE-BAR)) + ;; perhaps because of the way that STRUCTURE-OBJECT + ;; inherits both from SLOT-OBJECT and from + ;; SB-KERNEL:INSTANCE. In an effort to sweep such + ;; problems under the rug, we exclude these problem + ;; cases by blacklisting them here. -- WHN 2001-01-19 + '(slot-object)) + '(ignorable)) + ((not (eq *boot-state* 'complete)) + ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with + ;; types which don't match their specializers. (Specifically, + ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL + ;; second argument.) Hopefully it only does this kind of + ;; weirdness when bootstrapping.. -- WHN 20000610 + '(ignorable)) + ((var-globally-special-p parameter) + ;; KLUDGE: Don't declare types for global special variables + ;; -- our rebinding magic for SETQ cases don't work right + ;; there. + ;; + ;; FIXME: It would be better to detect the SETQ earlier and + ;; skip declarations for specials only when needed, not + ;; always. + ;; + ;; --NS 2004-10-14 + '(ignorable)) + (t + ;; Otherwise, we can usually make Python very happy. + (let ((kind (info :type :kind specializer))) + (ecase kind + ((:primitive) `(type ,specializer ,parameter)) + ((:defined) + (let ((class (find-class specializer nil))) ;; CLASS can be null here if the user has erroneously ;; tried to use a defined type as a specializer; it ;; can be a non-BUILT-IN-CLASS if the user defines a @@ -614,225 +614,225 @@ bootstrapping. ;; way. (when (and class (typep class 'built-in-class)) `(type ,specializer ,parameter)))) - ((:instance nil) - (let ((class (find-class specializer nil))) - (cond - (class - (if (typep class '(or built-in-class structure-class)) - `(type ,specializer ,parameter) - ;; don't declare CLOS classes as parameters; - ;; it's too expensive. - '(ignorable))) - (t - ;; we can get here, and still not have a failure - ;; case, by doing MOP programming like (PROGN - ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) - ;; ...)). Best to let the user know we haven't - ;; been able to extract enough information: - (style-warn - "~@" - specializer - 'parameter-specializer-declaration-in-defmethod) - '(ignorable))))) - ((:forthcoming-defclass-type) '(ignorable))))))) + ((:instance nil) + (let ((class (find-class specializer nil))) + (cond + (class + (if (typep class '(or built-in-class structure-class)) + `(type ,specializer ,parameter) + ;; don't declare CLOS classes as parameters; + ;; it's too expensive. + '(ignorable))) + (t + ;; we can get here, and still not have a failure + ;; case, by doing MOP programming like (PROGN + ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) + ;; ...)). Best to let the user know we haven't + ;; been able to extract enough information: + (style-warn + "~@" + specializer + 'parameter-specializer-declaration-in-defmethod) + '(ignorable))))) + ((:forthcoming-defclass-type) '(ignorable))))))) (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ - is not a lambda form." - method-lambda)) + is not a lambda form." + method-lambda)) (multiple-value-bind (real-body declarations documentation) (parse-body (cddr method-lambda)) (let* ((name-decl (get-declaration '%method-name declarations)) - (sll-decl (get-declaration '%method-lambda-list declarations)) - (method-name (when (consp name-decl) (car name-decl))) - (generic-function-name (when method-name (car method-name))) - (specialized-lambda-list (or sll-decl (cadr method-lambda)))) + (sll-decl (get-declaration '%method-lambda-list declarations)) + (method-name (when (consp name-decl) (car name-decl))) + (generic-function-name (when method-name (car method-name))) + (specialized-lambda-list (or sll-decl (cadr method-lambda)))) (multiple-value-bind (parameters lambda-list specializers) - (parse-specialized-lambda-list specialized-lambda-list) - (let* ((required-parameters - (mapcar (lambda (r s) (declare (ignore s)) r) - parameters - specializers)) - (slots (mapcar #'list required-parameters)) - (calls (list nil)) - (class-declarations - `(declare - ;; These declarations seem to be used by PCL to pass - ;; information to itself; when I tried to delete 'em - ;; ca. 0.6.10 it didn't work. I'm not sure how - ;; they work, but note the (VAR-DECLARATION '%CLASS ..) - ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 - ,@(remove nil - (mapcar (lambda (a s) (and (symbolp s) - (neq s t) - `(%class ,a ,s))) - parameters - specializers)) - ;; These TYPE declarations weren't in the original - ;; PCL code, but the Python compiler likes them a - ;; lot. (We're telling the compiler about our - ;; knowledge of specialized argument types so that - ;; it can avoid run-time type dispatch overhead, - ;; which can be a huge win for Python.) - ;; - ;; KLUDGE: when I tried moving these to - ;; ADD-METHOD-DECLARATIONS, things broke. No idea - ;; why. -- CSR, 2004-06-16 - ,@(mapcar #'parameter-specializer-declaration-in-defmethod - parameters - specializers))) - (method-lambda - ;; Remove the documentation string and insert the - ;; appropriate class declarations. The documentation - ;; string is removed to make it easy for us to insert - ;; new declarations later, they will just go after the - ;; CADR of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's - ;; arguments to the code walk. - `(lambda ,lambda-list - ;; The default ignorability of method parameters - ;; doesn't seem to be specified by ANSI. PCL had - ;; them basically ignorable but was a little - ;; inconsistent. E.g. even though the two - ;; method definitions - ;; (DEFMETHOD FOO ((X T) (Y T)) "Z") - ;; (DEFMETHOD FOO ((X T) Y) "Z") - ;; are otherwise equivalent, PCL treated Y as - ;; ignorable in the first definition but not in the - ;; second definition. We make all required - ;; parameters ignorable as a way of systematizing - ;; the old PCL behavior. -- WHN 2000-11-24 - (declare (ignorable ,@required-parameters)) - ,class-declarations - ,@declarations - (block ,(fun-name-block-name generic-function-name) - ,@real-body))) - (constant-value-p (and (null (cdr real-body)) - (constantp (car real-body)))) - (constant-value (and constant-value-p - (eval (car real-body)))) - (plist (and constant-value-p + (parse-specialized-lambda-list specialized-lambda-list) + (let* ((required-parameters + (mapcar (lambda (r s) (declare (ignore s)) r) + parameters + specializers)) + (slots (mapcar #'list required-parameters)) + (calls (list nil)) + (class-declarations + `(declare + ;; These declarations seem to be used by PCL to pass + ;; information to itself; when I tried to delete 'em + ;; ca. 0.6.10 it didn't work. I'm not sure how + ;; they work, but note the (VAR-DECLARATION '%CLASS ..) + ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 + ,@(remove nil + (mapcar (lambda (a s) (and (symbolp s) + (neq s t) + `(%class ,a ,s))) + parameters + specializers)) + ;; These TYPE declarations weren't in the original + ;; PCL code, but the Python compiler likes them a + ;; lot. (We're telling the compiler about our + ;; knowledge of specialized argument types so that + ;; it can avoid run-time type dispatch overhead, + ;; which can be a huge win for Python.) + ;; + ;; KLUDGE: when I tried moving these to + ;; ADD-METHOD-DECLARATIONS, things broke. No idea + ;; why. -- CSR, 2004-06-16 + ,@(mapcar #'parameter-specializer-declaration-in-defmethod + parameters + specializers))) + (method-lambda + ;; Remove the documentation string and insert the + ;; appropriate class declarations. The documentation + ;; string is removed to make it easy for us to insert + ;; new declarations later, they will just go after the + ;; CADR of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's + ;; arguments to the code walk. + `(lambda ,lambda-list + ;; The default ignorability of method parameters + ;; doesn't seem to be specified by ANSI. PCL had + ;; them basically ignorable but was a little + ;; inconsistent. E.g. even though the two + ;; method definitions + ;; (DEFMETHOD FOO ((X T) (Y T)) "Z") + ;; (DEFMETHOD FOO ((X T) Y) "Z") + ;; are otherwise equivalent, PCL treated Y as + ;; ignorable in the first definition but not in the + ;; second definition. We make all required + ;; parameters ignorable as a way of systematizing + ;; the old PCL behavior. -- WHN 2000-11-24 + (declare (ignorable ,@required-parameters)) + ,class-declarations + ,@declarations + (block ,(fun-name-block-name generic-function-name) + ,@real-body))) + (constant-value-p (and (null (cdr real-body)) + (constantp (car real-body)))) + (constant-value (and constant-value-p + (eval (car real-body)))) + (plist (and constant-value-p (or (typep constant-value '(or number character)) (and (symbolp constant-value) (symbol-package constant-value))) (list :constant-value constant-value))) - (applyp (dolist (p lambda-list nil) - (cond ((memq p '(&optional &rest &key)) - (return t)) - ((eq p '&aux) - (return nil)))))) - (multiple-value-bind - (walked-lambda call-next-method-p closurep - next-method-p-p setq-p) - (walk-method-lambda method-lambda - required-parameters - env - slots - calls) - (multiple-value-bind (walked-lambda-body - walked-declarations - walked-documentation) - (parse-body (cddr walked-lambda)) - (declare (ignore walked-documentation)) - (when (or next-method-p-p call-next-method-p) - (setq plist (list* :needs-next-methods-p t plist))) - (when (some #'cdr slots) - (multiple-value-bind (slot-name-lists call-list) - (slot-name-lists-from-slots slots calls) - (let ((pv-table-symbol (make-symbol "pv-table"))) - (setq plist - `(,@(when slot-name-lists - `(:slot-name-lists ,slot-name-lists)) - ,@(when call-list - `(:call-list ,call-list)) - :pv-table-symbol ,pv-table-symbol - ,@plist)) - (setq walked-lambda-body - `((pv-binding (,required-parameters - ,slot-name-lists - ,pv-table-symbol) - ,@walked-lambda-body)))))) - (when (and (memq '&key lambda-list) - (not (memq '&allow-other-keys lambda-list))) - (let ((aux (memq '&aux lambda-list))) - (setq lambda-list (nconc (ldiff lambda-list aux) - (list '&allow-other-keys) - aux)))) - (values `(lambda (.method-args. .next-methods.) - (simple-lexical-method-functions - (,lambda-list .method-args. .next-methods. - :call-next-method-p - ,call-next-method-p - :next-method-p-p ,next-method-p-p - :setq-p ,setq-p - ;; we need to pass this along - ;; so that NO-NEXT-METHOD can - ;; be given a suitable METHOD - ;; argument; we need the - ;; QUALIFIERS and SPECIALIZERS - ;; inside the declaration to - ;; give to FIND-METHOD. - :method-name-declaration ,name-decl - :closurep ,closurep - :applyp ,applyp) - ,@walked-declarations - ,@walked-lambda-body)) - `(,@(when plist - `(:plist ,plist)) - ,@(when documentation - `(:documentation ,documentation))))))))))) + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind + (walked-lambda call-next-method-p closurep + next-method-p-p setq-p) + (walk-method-lambda method-lambda + required-parameters + env + slots + calls) + (multiple-value-bind (walked-lambda-body + walked-declarations + walked-documentation) + (parse-body (cddr walked-lambda)) + (declare (ignore walked-documentation)) + (when (or next-method-p-p call-next-method-p) + (setq plist (list* :needs-next-methods-p t plist))) + (when (some #'cdr slots) + (multiple-value-bind (slot-name-lists call-list) + (slot-name-lists-from-slots slots calls) + (let ((pv-table-symbol (make-symbol "pv-table"))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@(when call-list + `(:call-list ,call-list)) + :pv-table-symbol ,pv-table-symbol + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters + ,slot-name-lists + ,pv-table-symbol) + ,@walked-lambda-body)))))) + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let ((aux (memq '&aux lambda-list))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) + (values `(lambda (.method-args. .next-methods.) + (simple-lexical-method-functions + (,lambda-list .method-args. .next-methods. + :call-next-method-p + ,call-next-method-p + :next-method-p-p ,next-method-p-p + :setq-p ,setq-p + ;; we need to pass this along + ;; so that NO-NEXT-METHOD can + ;; be given a suitable METHOD + ;; argument; we need the + ;; QUALIFIERS and SPECIALIZERS + ;; inside the declaration to + ;; give to FIND-METHOD. + :method-name-declaration ,name-decl + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + ,@walked-lambda-body)) + `(,@(when plist + `(:plist ,plist)) + ,@(when documentation + `(:documentation ,documentation))))))))))) (unless (fboundp 'make-method-lambda) (setf (gdefinition 'make-method-lambda) - (symbol-function 'real-make-method-lambda))) + (symbol-function 'real-make-method-lambda))) (defmacro simple-lexical-method-functions ((lambda-list - method-args - next-methods - &rest lmf-options) - &body body) + method-args + next-methods + &rest lmf-options) + &body body) `(progn ,method-args ,next-methods (bind-simple-lexical-method-macros (,method-args ,next-methods) (bind-lexical-method-functions (,@lmf-options) - (bind-args (,lambda-list ,method-args) - ,@body))))) + (bind-args (,lambda-list ,method-args) + ,@body))))) (defmacro fast-lexical-method-functions ((lambda-list - next-method-call - args - rest-arg - &rest lmf-options) - &body body) + next-method-call + args + rest-arg + &rest lmf-options) + &body body) `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) (bind-lexical-method-functions (,@lmf-options) (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) - ,@body)))) + ,@body)))) (defmacro bind-simple-lexical-method-macros ((method-args next-methods) - &body body) + &body body) `(macrolet ((call-next-method-bind (&body body) - `(let ((.next-method. (car ,',next-methods)) - (,',next-methods (cdr ,',next-methods))) - .next-method. ,',next-methods - ,@body)) - (call-next-method-body (method-name-declaration cnm-args) - `(if .next-method. - (funcall (if (std-instance-p .next-method.) - (method-function .next-method.) - .next-method.) ; for early methods - (or ,cnm-args ,',method-args) - ,',next-methods) - (apply #'call-no-next-method ',method-name-declaration - (or ,cnm-args ,',method-args)))) - (next-method-p-body () - `(not (null .next-method.))) - (with-rebound-original-args ((call-next-method-p setq-p) - &body body) - (declare (ignore call-next-method-p setq-p)) - `(let () ,@body))) + `(let ((.next-method. (car ,',next-methods)) + (,',next-methods (cdr ,',next-methods))) + .next-method. ,',next-methods + ,@body)) + (call-next-method-body (method-name-declaration cnm-args) + `(if .next-method. + (funcall (if (std-instance-p .next-method.) + (method-function .next-method.) + .next-method.) ; for early methods + (or ,cnm-args ,',method-args) + ,',next-methods) + (apply #'call-no-next-method ',method-name-declaration + (or ,cnm-args ,',method-args)))) + (next-method-p-body () + `(not (null .next-method.))) + (with-rebound-original-args ((call-next-method-p setq-p) + &body body) + (declare (ignore call-next-method-p setq-p)) + `(let () ,@body))) ,@body)) (defun call-no-next-method (method-name-declaration &rest args) @@ -841,12 +841,12 @@ bootstrapping. ;; KLUDGE: inefficient traversal, but hey. This should only ;; happen on the slow error path anyway. (let* ((qualifiers (butlast qualifiers-and-specializers)) - (specializers (car (last qualifiers-and-specializers))) - (method (find-method (gdefinition name) qualifiers specializers))) - (apply #'no-next-method - (method-generic-function method) - method - args))))) + (specializers (car (last qualifiers-and-specializers))) + (method (find-method (gdefinition name) qualifiers specializers))) + (apply #'no-next-method + (method-generic-function method) + method + args))))) (defstruct (method-call (:copier nil)) (function #'identity :type function) @@ -856,18 +856,18 @@ bootstrapping. (defmacro invoke-method-call1 (function args cm-args) `(let ((.function. ,function) - (.args. ,args) - (.cm-args. ,cm-args)) + (.args. ,args) + (.cm-args. ,cm-args)) (if (and .cm-args. (null (cdr .cm-args.))) - (funcall .function. .args. (car .cm-args.)) - (apply .function. .args. .cm-args.)))) + (funcall .function. .args. (car .cm-args.)) + (apply .function. .args. .cm-args.)))) (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg) `(invoke-method-call1 (method-call-function ,method-call) - ,(if restp - `(list* ,@required-args+rest-arg) - `(list ,@required-args+rest-arg)) - (method-call-call-method-args ,method-call))) + ,(if restp + `(list* ,@required-args+rest-arg) + `(list ,@required-args+rest-arg)) + (method-call-call-method-args ,method-call))) (defstruct (fast-method-call (:copier nil)) (function #'identity :type function) @@ -882,9 +882,9 @@ bootstrapping. (defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) `(fmc-funcall (fast-method-call-function ,method-call) - (fast-method-call-pv-cell ,method-call) - (fast-method-call-next-method-call ,method-call) - ,@required-args+rest-arg)) + (fast-method-call-pv-cell ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args+rest-arg)) (defstruct (fast-instance-boundp (:copier nil)) (index 0 :type fixnum)) @@ -910,20 +910,20 @@ bootstrapping. (defun show-emf-call-trace () (when *emf-call-trace* (let ((j *emf-call-trace-index*) - (*enable-emf-call-tracing-p* nil)) + (*enable-emf-call-tracing-p* nil)) (format t "~&(The oldest entries are printed first)~%") (dotimes-fixnum (i *emf-call-trace-size*) - (let ((ct (aref *emf-call-trace* j))) - (when ct (print ct))) - (incf j) - (when (= j *emf-call-trace-size*) - (setq j 0)))))) + (let ((ct (aref *emf-call-trace* j))) + (when ct (print ct))) + (incf j) + (when (= j *emf-call-trace-size*) + (setq j 0)))))) (defun trace-emf-call-internal (emf format args) (unless *emf-call-trace* (setq *emf-call-trace* (make-array *emf-call-trace-size*))) (setf (aref *emf-call-trace* *emf-call-trace-index*) - (list* emf format args)) + (list* emf format args)) (incf *emf-call-trace-index*) (when (= *emf-call-trace-index* *emf-call-trace-size*) (setq *emf-call-trace-index* 0))) @@ -940,7 +940,7 @@ bootstrapping. (invoke-fast-method-call ,emf ,@required-args+rest-arg))) (defmacro invoke-effective-method-function (emf restp - &rest required-args+rest-arg) + &rest required-args+rest-arg) (unless (constantp restp) (error "The RESTP argument is not constant.")) ;; FIXME: The RESTP handling here is confusing and maybe slightly @@ -951,381 +951,381 @@ bootstrapping. `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond ((typep ,emf 'fast-method-call) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) - ;; "What," you may wonder, "do these next two clauses do?" - ;; In that case, you are not a PCL implementor, for they - ;; considered this to be self-documenting.:-| Or CSR, for - ;; that matter, since he can also figure it out by looking - ;; at it without breaking stride. For the rest of us, - ;; though: From what the code is doing with .SLOTS. and - ;; whatnot, evidently it's implementing SLOT-VALUEish and - ;; GET-SLOT-VALUEish things. Then we can reason backwards - ;; and conclude that setting EMF to a FIXNUM is an - ;; optimized way to represent these slot access operations. - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let* ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg))) - (value (when .slots. (clos-slots-ref .slots. ,emf)))) - (if (eq value +slot-unbound+) - (slot-unbound-internal ,(car required-args+rest-arg) - ,emf) - value))))) - ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let ((.new-value. ,(car required-args+rest-arg)) - (.slots. (get-slots-or-nil - ,(cadr required-args+rest-arg)))) - (when .slots. - (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) - ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN - ;; ...) clause here to handle SLOT-BOUNDish stuff. Since - ;; there was no explanation and presumably the code is 10+ - ;; years stale, I simply deleted it. -- WHN) - (t - (etypecase ,emf - (method-call - (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) - (function - ,(if restp - `(apply (the function ,emf) ,@required-args+rest-arg) - `(funcall (the function ,emf) - ,@required-args+rest-arg)))))))) + (invoke-fast-method-call ,emf ,@required-args+rest-arg)) + ;; "What," you may wonder, "do these next two clauses do?" + ;; In that case, you are not a PCL implementor, for they + ;; considered this to be self-documenting.:-| Or CSR, for + ;; that matter, since he can also figure it out by looking + ;; at it without breaking stride. For the rest of us, + ;; though: From what the code is doing with .SLOTS. and + ;; whatnot, evidently it's implementing SLOT-VALUEish and + ;; GET-SLOT-VALUEish things. Then we can reason backwards + ;; and conclude that setting EMF to a FIXNUM is an + ;; optimized way to represent these slot access operations. + ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) + `(((typep ,emf 'fixnum) + (let* ((.slots. (get-slots-or-nil + ,(car required-args+rest-arg))) + (value (when .slots. (clos-slots-ref .slots. ,emf)))) + (if (eq value +slot-unbound+) + (slot-unbound-internal ,(car required-args+rest-arg) + ,emf) + value))))) + ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) + `(((typep ,emf 'fixnum) + (let ((.new-value. ,(car required-args+rest-arg)) + (.slots. (get-slots-or-nil + ,(cadr required-args+rest-arg)))) + (when .slots. + (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) + ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN + ;; ...) clause here to handle SLOT-BOUNDish stuff. Since + ;; there was no explanation and presumably the code is 10+ + ;; years stale, I simply deleted it. -- WHN) + (t + (etypecase ,emf + (method-call + (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) + (function + ,(if restp + `(apply (the function ,emf) ,@required-args+rest-arg) + `(funcall (the function ,emf) + ,@required-args+rest-arg)))))))) (defun invoke-emf (emf args) (trace-emf-call emf t args) (etypecase emf (fast-method-call (let* ((arg-info (fast-method-call-arg-info emf)) - (restp (cdr arg-info)) - (nreq (car arg-info))) + (restp (cdr arg-info)) + (nreq (car arg-info))) (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args rest-args))) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (nconc req-args (list rest-args)))) - (cond ((null args) - (if (eql nreq 0) - (invoke-fast-method-call emf) - (error 'simple-program-error - :format-control "invalid number of arguments: 0" - :format-arguments nil))) - ((null (cdr args)) - (if (eql nreq 1) - (invoke-fast-method-call emf (car args)) - (error 'simple-program-error - :format-control "invalid number of arguments: 1" - :format-arguments nil))) - ((null (cddr args)) - (if (eql nreq 2) - (invoke-fast-method-call emf (car args) (cadr args)) - (error 'simple-program-error - :format-control "invalid number of arguments: 2" - :format-arguments nil))) - (t - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - args)))))) + (let* ((rest-args (nthcdr nreq args)) + (req-args (ldiff args rest-args))) + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + (nconc req-args (list rest-args)))) + (cond ((null args) + (if (eql nreq 0) + (invoke-fast-method-call emf) + (error 'simple-program-error + :format-control "invalid number of arguments: 0" + :format-arguments nil))) + ((null (cdr args)) + (if (eql nreq 1) + (invoke-fast-method-call emf (car args)) + (error 'simple-program-error + :format-control "invalid number of arguments: 1" + :format-arguments nil))) + ((null (cddr args)) + (if (eql nreq 2) + (invoke-fast-method-call emf (car args) (cadr args)) + (error 'simple-program-error + :format-control "invalid number of arguments: 2" + :format-arguments nil))) + (t + (apply (fast-method-call-function emf) + (fast-method-call-pv-cell emf) + (fast-method-call-next-method-call emf) + args)))))) (method-call (apply (method-call-function emf) - args - (method-call-call-method-args emf))) + args + (method-call-call-method-args emf))) (fixnum (cond ((null args) - (error 'simple-program-error - :format-control "invalid number of arguments: 0" - :format-arguments nil)) - ((null (cdr args)) - (let* ((slots (get-slots (car args))) + (error 'simple-program-error + :format-control "invalid number of arguments: 0" + :format-arguments nil)) + ((null (cdr args)) + (let* ((slots (get-slots (car args))) (value (clos-slots-ref slots emf))) - (if (eq value +slot-unbound+) - (slot-unbound-internal (car args) emf) - value))) - ((null (cddr args)) - (setf (clos-slots-ref (get-slots (cadr args)) emf) - (car args))) - (t (error 'simple-program-error - :format-control "invalid number of arguments" - :format-arguments nil)))) + (if (eq value +slot-unbound+) + (slot-unbound-internal (car args) emf) + value))) + ((null (cddr args)) + (setf (clos-slots-ref (get-slots (cadr args)) emf) + (car args))) + (t (error 'simple-program-error + :format-control "invalid number of arguments" + :format-arguments nil)))) (fast-instance-boundp (if (or (null args) (cdr args)) - (error 'simple-program-error - :format-control "invalid number of arguments" - :format-arguments nil) - (let ((slots (get-slots (car args)))) - (not (eq (clos-slots-ref slots (fast-instance-boundp-index emf)) - +slot-unbound+))))) + (error 'simple-program-error + :format-control "invalid number of arguments" + :format-arguments nil) + (let ((slots (get-slots (car args)))) + (not (eq (clos-slots-ref slots (fast-instance-boundp-index emf)) + +slot-unbound+))))) (function (apply emf args)))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) - &body body) + &body body) (let* ((all-params (append args (when rest-arg (list rest-arg)))) - (rebindings (mapcar (lambda (x) (list x x)) all-params))) + (rebindings (mapcar (lambda (x) (list x x)) all-params))) `(macrolet ((narrowed-emf (emf) - ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to - ;; dispatch on the possibility that EMF might be of - ;; type FIXNUM (as an optimized representation of a - ;; slot accessor). But as far as I (WHN 2002-06-11) - ;; can tell, it's impossible for such a representation - ;; to end up as .NEXT-METHOD-CALL. By reassuring - ;; INVOKE-E-M-F that when called from this context - ;; it needn't worry about the FIXNUM case, we can - ;; keep those cases from being compiled, which is - ;; good both because it saves bytes and because it - ;; avoids annoying type mismatch compiler warnings. - ;; - ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type - ;; system isn't smart enough about NOT and - ;; intersection types to benefit from a (NOT FIXNUM) - ;; declaration here. -- WHN 2002-06-12 (FIXME: maybe - ;; it is now... -- CSR, 2003-06-07) - ;; - ;; FIXME: Might the FUNCTION type be omittable here, - ;; leaving only METHOD-CALLs? Failing that, could this - ;; be documented somehow? (It'd be nice if the types - ;; involved could be understood without solving the - ;; halting problem.) - `(the (or function method-call fast-method-call) - ,emf)) - (call-next-method-bind (&body body) - `(let () ,@body)) - (call-next-method-body (method-name-declaration cnm-args) - `(if ,',next-method-call - ,(locally - ;; This declaration suppresses a "deleting - ;; unreachable code" note for the following IF - ;; when REST-ARG is NIL. It is not nice for - ;; debugging SBCL itself, but at least it - ;; keeps us from annoying users. - (declare (optimize (inhibit-warnings 3))) - (if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(invoke-effective-method-function - (narrowed-emf ,',next-method-call) - nil - ,@(cdr cnm-args)) - (let ((call `(invoke-effective-method-function - (narrowed-emf ,',next-method-call) - ,',(not (null rest-arg)) - ,@',args - ,@',(when rest-arg `(,rest-arg))))) - `(if ,cnm-args - (bind-args ((,@',args - ,@',(when rest-arg - `(&rest ,rest-arg))) - ,cnm-args) - ,call) - ,call)))) - ,(locally - ;; As above, this declaration suppresses code - ;; deletion notes. - (declare (optimize (inhibit-warnings 3))) - (if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(call-no-next-method ',method-name-declaration - ,@(cdr cnm-args)) - `(call-no-next-method ',method-name-declaration - ,@',args - ,@',(when rest-arg - `(,rest-arg))))))) - (next-method-p-body () - `(not (null ,',next-method-call))) - (with-rebound-original-args ((cnm-p setq-p) &body body) - (if (or cnm-p setq-p) - `(let ,',rebindings - (declare (ignorable ,@',all-params)) - ,@body) - `(let () ,@body)))) + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to + ;; dispatch on the possibility that EMF might be of + ;; type FIXNUM (as an optimized representation of a + ;; slot accessor). But as far as I (WHN 2002-06-11) + ;; can tell, it's impossible for such a representation + ;; to end up as .NEXT-METHOD-CALL. By reassuring + ;; INVOKE-E-M-F that when called from this context + ;; it needn't worry about the FIXNUM case, we can + ;; keep those cases from being compiled, which is + ;; good both because it saves bytes and because it + ;; avoids annoying type mismatch compiler warnings. + ;; + ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type + ;; system isn't smart enough about NOT and + ;; intersection types to benefit from a (NOT FIXNUM) + ;; declaration here. -- WHN 2002-06-12 (FIXME: maybe + ;; it is now... -- CSR, 2003-06-07) + ;; + ;; FIXME: Might the FUNCTION type be omittable here, + ;; leaving only METHOD-CALLs? Failing that, could this + ;; be documented somehow? (It'd be nice if the types + ;; involved could be understood without solving the + ;; halting problem.) + `(the (or function method-call fast-method-call) + ,emf)) + (call-next-method-bind (&body body) + `(let () ,@body)) + (call-next-method-body (method-name-declaration cnm-args) + `(if ,',next-method-call + ,(locally + ;; This declaration suppresses a "deleting + ;; unreachable code" note for the following IF + ;; when REST-ARG is NIL. It is not nice for + ;; debugging SBCL itself, but at least it + ;; keeps us from annoying users. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(invoke-effective-method-function + (narrowed-emf ,',next-method-call) + nil + ,@(cdr cnm-args)) + (let ((call `(invoke-effective-method-function + (narrowed-emf ,',next-method-call) + ,',(not (null rest-arg)) + ,@',args + ,@',(when rest-arg `(,rest-arg))))) + `(if ,cnm-args + (bind-args ((,@',args + ,@',(when rest-arg + `(&rest ,rest-arg))) + ,cnm-args) + ,call) + ,call)))) + ,(locally + ;; As above, this declaration suppresses code + ;; deletion notes. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(call-no-next-method ',method-name-declaration + ,@(cdr cnm-args)) + `(call-no-next-method ',method-name-declaration + ,@',args + ,@',(when rest-arg + `(,rest-arg))))))) + (next-method-p-body () + `(not (null ,',next-method-call))) + (with-rebound-original-args ((cnm-p setq-p) &body body) + (if (or cnm-p setq-p) + `(let ,',rebindings + (declare (ignorable ,@',all-params)) + ,@body) + `(let () ,@body)))) ,@body))) (defmacro bind-lexical-method-functions ((&key call-next-method-p next-method-p-p setq-p - closurep applyp method-name-declaration) + closurep applyp method-name-declaration) &body body) (cond ((and (null call-next-method-p) (null next-method-p-p) - (null closurep) (null applyp) (null setq-p)) - `(let () ,@body)) - (t - `(call-next-method-bind - (flet (,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (call-next-method-body - ,method-name-declaration - cnm-args)))) - ,@(and next-method-p-p - '((next-method-p () - (next-method-p-body))))) - (with-rebound-original-args (,call-next-method-p ,setq-p) - ,@body)))))) + (null closurep) (null applyp) (null setq-p)) + `(let () ,@body)) + (t + `(call-next-method-bind + (flet (,@(and call-next-method-p + `((call-next-method (&rest cnm-args) + (call-next-method-body + ,method-name-declaration + cnm-args)))) + ,@(and next-method-p-p + '((next-method-p () + (next-method-p-body))))) + (with-rebound-original-args (,call-next-method-p ,setq-p) + ,@body)))))) (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) - (key '.key.) - (state 'required)) + (key '.key.) + (state 'required)) (flet ((process-var (var) - (if (memq var lambda-list-keywords) - (progn - (case var - (&optional (setq state 'optional)) - (&key (setq state 'key)) - (&allow-other-keys) - (&rest (setq state 'rest)) - (&aux (setq state 'aux)) - (otherwise - (error - "encountered the non-standard lambda list keyword ~S" - var))) - nil) - (case state - (required `((,var (pop ,args-tail)))) - (optional (cond ((not (consp var)) - `((,var (when ,args-tail - (pop ,args-tail))))) - ((null (cddr var)) - `((,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))) - (t - `((,(caddr var) ,args-tail) - (,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))))) - (rest `((,var ,args-tail))) - (key (cond ((not (consp var)) - `((,var (car - (get-key-arg-tail ,(keywordicate var) - ,args-tail))))) - ((null (cddr var)) - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) - (cadar var)) - (values (keywordicate (car var)) - (car var))) - `((,key (get-key-arg-tail ',keyword - ,args-tail)) - (,variable (if ,key - (car ,key) - ,(cadr var)))))) - (t - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) - (cadar var)) - (values (keywordicate (car var)) - (car var))) - `((,key (get-key-arg-tail ',keyword - ,args-tail)) - (,(caddr var) ,key) - (,variable (if ,key - (car ,key) - ,(cadr var)))))))) - (aux `(,var)))))) + (if (memq var lambda-list-keywords) + (progn + (case var + (&optional (setq state 'optional)) + (&key (setq state 'key)) + (&allow-other-keys) + (&rest (setq state 'rest)) + (&aux (setq state 'aux)) + (otherwise + (error + "encountered the non-standard lambda list keyword ~S" + var))) + nil) + (case state + (required `((,var (pop ,args-tail)))) + (optional (cond ((not (consp var)) + `((,var (when ,args-tail + (pop ,args-tail))))) + ((null (cddr var)) + `((,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))) + (t + `((,(caddr var) ,args-tail) + (,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))))) + (rest `((,var ,args-tail))) + (key (cond ((not (consp var)) + `((,var (car + (get-key-arg-tail ,(keywordicate var) + ,args-tail))))) + ((null (cddr var)) + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) + (cadar var)) + (values (keywordicate (car var)) + (car var))) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) + (,variable (if ,key + (car ,key) + ,(cadr var)))))) + (t + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) + (cadar var)) + (values (keywordicate (car var)) + (car var))) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) + (,(caddr var) ,key) + (,variable (if ,key + (car ,key) + ,(cadr var)))))))) + (aux `(,var)))))) (let ((bindings (mapcan #'process-var lambda-list))) - `(let* ((,args-tail ,args) - ,@bindings - (.dummy0. - ,@(when (eq state 'optional) - `((unless (null ,args-tail) - (error 'simple-program-error - :format-control "surplus arguments: ~S" - :format-arguments (list ,args-tail))))))) - (declare (ignorable ,args-tail .dummy0.)) - ,@body))))) + `(let* ((,args-tail ,args) + ,@bindings + (.dummy0. + ,@(when (eq state 'optional) + `((unless (null ,args-tail) + (error 'simple-program-error + :format-control "surplus arguments: ~S" + :format-arguments (list ,args-tail))))))) + (declare (ignorable ,args-tail .dummy0.)) + ,@body))))) (defun get-key-arg-tail (keyword list) (loop for (key . tail) on list by #'cddr - when (null tail) do - ;; FIXME: Do we want to export this symbol? Or maybe use an - ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form? - (sb-c::%odd-key-args-error) - when (eq key keyword) - return tail)) + when (null tail) do + ;; FIXME: Do we want to export this symbol? Or maybe use an + ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form? + (sb-c::%odd-key-args-error) + when (eq key keyword) + return tail)) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD - ; should be in the method definition - (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD - ; was seen in the body of a method - (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P - ; should be in the method definition - (setq-p nil)) + ; should be in the method definition + (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD + ; was seen in the body of a method + (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P + ; should be in the method definition + (setq-p nil)) (flet ((walk-function (form context env) - (cond ((not (eq context :eval)) form) - ;; FIXME: Jumping to a conclusion from the way it's used - ;; above, perhaps CONTEXT should be called SITUATION - ;; (after the term used in the ANSI specification of - ;; EVAL-WHEN) and given modern ANSI keyword values - ;; like :LOAD-TOPLEVEL. - ((not (listp form)) form) - ((eq (car form) 'call-next-method) - (setq call-next-method-p t) - form) - ((eq (car form) 'next-method-p) - (setq next-method-p-p t) - form) - ((memq (car form) '(setq multiple-value-setq)) - ;; FIXME: this is possibly a little strong as - ;; conditions go. Ideally we would want to detect - ;; which, if any, of the method parameters are - ;; being set, and communicate that information to - ;; e.g. SPLIT-DECLARATIONS. However, the brute - ;; force method doesn't really cost much; a little - ;; loss of discrimination over IGNORED variables - ;; should be all. -- CSR, 2004-07-01 - (setq setq-p t) - form) - ((and (eq (car form) 'function) - (cond ((eq (cadr form) 'call-next-method) - (setq call-next-method-p t) - (setq closurep t) - form) - ((eq (cadr form) 'next-method-p) - (setq next-method-p-p t) - (setq closurep t) - form) - (t nil)))) - ((and (memq (car form) + (cond ((not (eq context :eval)) form) + ;; FIXME: Jumping to a conclusion from the way it's used + ;; above, perhaps CONTEXT should be called SITUATION + ;; (after the term used in the ANSI specification of + ;; EVAL-WHEN) and given modern ANSI keyword values + ;; like :LOAD-TOPLEVEL. + ((not (listp form)) form) + ((eq (car form) 'call-next-method) + (setq call-next-method-p t) + form) + ((eq (car form) 'next-method-p) + (setq next-method-p-p t) + form) + ((memq (car form) '(setq multiple-value-setq)) + ;; FIXME: this is possibly a little strong as + ;; conditions go. Ideally we would want to detect + ;; which, if any, of the method parameters are + ;; being set, and communicate that information to + ;; e.g. SPLIT-DECLARATIONS. However, the brute + ;; force method doesn't really cost much; a little + ;; loss of discrimination over IGNORED variables + ;; should be all. -- CSR, 2004-07-01 + (setq setq-p t) + form) + ((and (eq (car form) 'function) + (cond ((eq (cadr form) 'call-next-method) + (setq call-next-method-p t) + (setq closurep t) + form) + ((eq (cadr form) 'next-method-p) + (setq next-method-p-p t) + (setq closurep t) + form) + (t nil)))) + ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) - (constantp (caddr form))) + (constantp (caddr form))) (let ((parameter (can-optimize-access form - required-parameters - env))) + required-parameters + env))) (let ((fun (ecase (car form) (slot-value #'optimize-slot-value) (set-slot-value #'optimize-set-slot-value) (slot-boundp #'optimize-slot-boundp)))) (funcall fun slots parameter form)))) - ((and (eq (car form) 'apply) - (consp (cadr form)) - (eq (car (cadr form)) 'function) - (generic-function-name-p (cadr (cadr form)))) - (optimize-generic-function-call - form required-parameters env slots calls)) - ((generic-function-name-p (car form)) - (optimize-generic-function-call - form required-parameters env slots calls)) - (t form)))) + ((and (eq (car form) 'apply) + (consp (cadr form)) + (eq (car (cadr form)) 'function) + (generic-function-name-p (cadr (cadr form)))) + (optimize-generic-function-call + form required-parameters env slots calls)) + ((generic-function-name-p (car form)) + (optimize-generic-function-call + form required-parameters env slots calls)) + (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) - (values walked-lambda - call-next-method-p - closurep - next-method-p-p - setq-p))))) + (values walked-lambda + call-next-method-p + closurep + next-method-p-p + setq-p))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) (gboundp name) (if (eq *boot-state* 'complete) - (standard-generic-function-p (gdefinition name)) - (funcallable-instance-p (gdefinition name))))) + (standard-generic-function-p (gdefinition name)) + (funcallable-instance-p (gdefinition name))))) (defvar *method-function-plist* (make-hash-table :test 'eq)) (defvar *mf1* nil) @@ -1344,8 +1344,8 @@ bootstrapping. (setf (gethash *mf1* *method-function-plist*) *mf1p*)) (unless (eq method-function *mf1*) (setf *mf1* method-function - *mf1cp* nil - *mf1p* (gethash method-function *method-function-plist*))) + *mf1cp* nil + *mf1p* (gethash method-function *method-function-plist*))) *mf1p*) (defun (setf method-function-plist) @@ -1357,8 +1357,8 @@ bootstrapping. (unless (or (eq method-function *mf1*) (null *mf1cp*)) (setf (gethash *mf1* *method-function-plist*) *mf1p*)) (setf *mf1* method-function - *mf1cp* t - *mf1p* val)) + *mf1cp* t + *mf1p* val)) (defun method-function-get (method-function key &optional default) (getf (method-function-plist method-function) key default)) @@ -1383,47 +1383,47 @@ bootstrapping. (class name quals specls ll initargs &optional pv-table-symbol) (setq initargs (copy-tree initargs)) (let ((method-spec (or (getf initargs :method-spec) - (make-method-spec name quals specls)))) + (make-method-spec name quals specls)))) (setf (getf initargs :method-spec) method-spec) (load-defmethod-internal class name quals specls - ll initargs pv-table-symbol))) + ll initargs pv-table-symbol))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list - initargs pv-table-symbol) + initargs pv-table-symbol) (when pv-table-symbol (setf (getf (getf initargs :plist) :pv-table-symbol) - pv-table-symbol)) + pv-table-symbol)) (when (and (eq *boot-state* 'complete) - (fboundp gf-spec)) + (fboundp gf-spec)) (let* ((gf (fdefinition gf-spec)) - (method (and (generic-function-p gf) + (method (and (generic-function-p gf) (generic-function-methods gf) - (find-method gf - qualifiers + (find-method gf + qualifiers (parse-specializers specializers) - nil)))) + nil)))) (when method - (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" - gf-spec qualifiers specializers)))) + (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" + gf-spec qualifiers specializers)))) (let ((method (apply #'add-named-method - gf-spec qualifiers specializers lambda-list - :definition-source `((defmethod ,gf-spec - ,@qualifiers - ,specializers) - ,*load-pathname*) - initargs))) + gf-spec qualifiers specializers lambda-list + :definition-source `((defmethod ,gf-spec + ,@qualifiers + ,specializers) + ,*load-pathname*) + initargs))) (unless (or (eq method-class 'standard-method) - (eq (find-class method-class nil) (class-of method))) + (eq (find-class method-class nil) (class-of method))) ;; FIXME: should be STYLE-WARNING? (format *error-output* - "~&At the time the method with qualifiers ~:S and~%~ - specializers ~:S on the generic function ~S~%~ - was compiled, the method-class for that generic function was~%~ - ~S. But, the method class is now ~S, this~%~ - may mean that this method was compiled improperly.~%" - qualifiers specializers gf-spec - method-class (class-name (class-of method)))) + "~&At the time the method with qualifiers ~:S and~%~ + specializers ~:S on the generic function ~S~%~ + was compiled, the method-class for that generic function was~%~ + ~S. But, the method class is now ~S, this~%~ + may mean that this method was compiled improperly.~%" + qualifiers specializers gf-spec + method-class (class-name (class-of method)))) method)) (defun make-method-spec (gf-spec qualifiers unparsed-specializers) @@ -1431,119 +1431,119 @@ bootstrapping. (defun initialize-method-function (initargs &optional return-function-p method) (let* ((mf (getf initargs :function)) - (method-spec (getf initargs :method-spec)) - (plist (getf initargs :plist)) - (pv-table-symbol (getf plist :pv-table-symbol)) - (pv-table nil) - (mff (getf initargs :fast-function))) + (method-spec (getf initargs :method-spec)) + (plist (getf initargs :plist)) + (pv-table-symbol (getf plist :pv-table-symbol)) + (pv-table nil) + (mff (getf initargs :fast-function))) (flet ((set-mf-property (p v) - (when mf - (setf (method-function-get mf p) v)) - (when mff - (setf (method-function-get mff p) v)))) + (when mf + (setf (method-function-get mf p) v)) + (when mff + (setf (method-function-get mff p) v)))) (when method-spec - (when mf - (setq mf (set-fun-name mf method-spec))) - (when mff - (let ((name `(fast-method ,@(cdr method-spec)))) - (set-fun-name mff name) - (unless mf - (set-mf-property :name name))))) + (when mf + (setq mf (set-fun-name mf method-spec))) + (when mff + (let ((name `(fast-method ,@(cdr method-spec)))) + (set-fun-name mff name) + (unless mf + (set-mf-property :name name))))) (when plist - (let ((snl (getf plist :slot-name-lists)) - (cl (getf plist :call-list))) - (when (or snl cl) - (setq pv-table (intern-pv-table :slot-name-lists snl - :call-list cl)) - (when pv-table (set pv-table-symbol pv-table)) - (set-mf-property :pv-table pv-table))) - (loop (when (null plist) (return nil)) - (set-mf-property (pop plist) (pop plist))) - (when method - (set-mf-property :method method)) - (when return-function-p - (or mf (method-function-from-fast-function mff))))))) + (let ((snl (getf plist :slot-name-lists)) + (cl (getf plist :call-list))) + (when (or snl cl) + (setq pv-table (intern-pv-table :slot-name-lists snl + :call-list cl)) + (when pv-table (set pv-table-symbol pv-table)) + (set-mf-property :pv-table pv-table))) + (loop (when (null plist) (return nil)) + (set-mf-property (pop plist) (pop plist))) + (when method + (set-mf-property :method method)) + (when return-function-p + (or mf (method-function-from-fast-function mff))))))) (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? - (parse-key-arg (arg) - (if (listp arg) - (if (listp (car arg)) - (caar arg) - (keywordicate (car arg))) - (keywordicate arg)))) + (parse-key-arg (arg) + (if (listp arg) + (if (listp (car arg)) + (caar arg) + (keywordicate (car arg))) + (keywordicate arg)))) (let ((nrequired 0) - (noptional 0) - (keysp nil) - (restp nil) + (noptional 0) + (keysp nil) + (restp nil) (nrest 0) - (allow-other-keys-p nil) - (keywords ()) - (keyword-parameters ()) - (state 'required)) + (allow-other-keys-p nil) + (keywords ()) + (keyword-parameters ()) + (state 'required)) (dolist (x lambda-list) - (if (memq x lambda-list-keywords) - (case x - (&optional (setq state 'optional)) - (&key (setq keysp t - state 'key)) - (&allow-other-keys (setq allow-other-keys-p t)) - (&rest (setq restp t - state 'rest)) - (&aux (return t)) - (otherwise - (error "encountered the non-standard lambda list keyword ~S" - x))) - (ecase state - (required (incf nrequired)) - (optional (incf noptional)) - (key (push (parse-key-arg x) keywords) - (push x keyword-parameters)) - (rest (incf nrest))))) + (if (memq x lambda-list-keywords) + (case x + (&optional (setq state 'optional)) + (&key (setq keysp t + state 'key)) + (&allow-other-keys (setq allow-other-keys-p t)) + (&rest (setq restp t + state 'rest)) + (&aux (return t)) + (otherwise + (error "encountered the non-standard lambda list keyword ~S" + x))) + (ecase state + (required (incf nrequired)) + (optional (incf noptional)) + (key (push (parse-key-arg x) keywords) + (push x keyword-parameters)) + (rest (incf nrest))))) (when (and restp (zerop nrest)) (error "Error in lambda-list:~%~ After &REST, a DEFGENERIC lambda-list ~ must be followed by at least one variable.")) (values nrequired noptional keysp restp allow-other-keys-p - (reverse keywords) - (reverse keyword-parameters))))) + (reverse keywords) + (reverse keyword-parameters))))) (defun keyword-spec-name (x) (let ((key (if (atom x) x (car x)))) (if (atom key) - (keywordicate key) - (car key)))) + (keywordicate key) + (car key)))) (defun ftype-declaration-from-lambda-list (lambda-list name) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p - keywords keyword-parameters) + keywords keyword-parameters) (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead? - (old-ftype (if (fun-type-p old) old nil)) - (old-restp (and old-ftype (fun-type-rest old-ftype))) - (old-keys (and old-ftype - (mapcar #'key-info-name - (fun-type-keywords - old-ftype)))) - (old-keysp (and old-ftype (fun-type-keyp old-ftype))) - (old-allowp (and old-ftype - (fun-type-allowp old-ftype))) - (keywords (union old-keys (mapcar #'keyword-spec-name keywords)))) + (old-ftype (if (fun-type-p old) old nil)) + (old-restp (and old-ftype (fun-type-rest old-ftype))) + (old-keys (and old-ftype + (mapcar #'key-info-name + (fun-type-keywords + old-ftype)))) + (old-keysp (and old-ftype (fun-type-keyp old-ftype))) + (old-allowp (and old-ftype + (fun-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 old-restp) - '(&rest t)) - (when (or keysp old-keysp) - (append '(&key) - (mapcar (lambda (key) - `(,key t)) - keywords) - (when (or allow-other-keys-p old-allowp) - '(&allow-other-keys))))) - *)))) + (when (plusp noptional) + (append '(&optional) + (make-list noptional :initial-element t))) + (when (or restp old-restp) + '(&rest t)) + (when (or keysp old-keysp) + (append '(&key) + (mapcar (lambda (key) + `(,key t)) + keywords) + (when (or allow-other-keys-p old-allowp) + '(&allow-other-keys))))) + *)))) (defun defgeneric-declaration (spec lambda-list) `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec)) @@ -1553,37 +1553,37 @@ bootstrapping. (defvar *!early-generic-functions* ()) (defun ensure-generic-function (fun-name - &rest all-keys - &key environment - &allow-other-keys) + &rest all-keys + &key environment + &allow-other-keys) (declare (ignore environment)) (let ((existing (and (gboundp fun-name) - (gdefinition fun-name)))) + (gdefinition fun-name)))) (if (and existing - (eq *boot-state* 'complete) - (null (generic-function-p existing))) - (generic-clobbers-function fun-name) - (apply #'ensure-generic-function-using-class - existing fun-name all-keys)))) + (eq *boot-state* 'complete) + (null (generic-function-p existing))) + (generic-clobbers-function fun-name) + (apply #'ensure-generic-function-using-class + existing fun-name all-keys)))) (defun generic-clobbers-function (fun-name) (error 'simple-program-error - :format-control "~S already names an ordinary function or a macro." - :format-arguments (list fun-name))) + :format-control "~S already names an ordinary function or a macro." + :format-arguments (list fun-name))) (defvar *sgf-wrapper* (boot-make-wrapper (early-class-size 'standard-generic-function) - 'standard-generic-function)) + 'standard-generic-function)) (defvar *sgf-slots-init* (mapcar (lambda (canonical-slot) - (if (memq (getf canonical-slot :name) '(arg-info source)) - +slot-unbound+ - (let ((initfunction (getf canonical-slot :initfunction))) - (if initfunction - (funcall initfunction) - +slot-unbound+)))) - (early-collect-inheritance 'standard-generic-function))) + (if (memq (getf canonical-slot :name) '(arg-info source)) + +slot-unbound+ + (let ((initfunction (getf canonical-slot :initfunction))) + (if initfunction + (funcall initfunction) + +slot-unbound+)))) + (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* (!bootstrap-slot-index 'standard-generic-function 'method-class)) @@ -1591,7 +1591,7 @@ bootstrapping. (defun early-gf-p (x) (and (fsc-instance-p x) (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*) - +slot-unbound+))) + +slot-unbound+))) (defvar *sgf-methods-index* (!bootstrap-slot-index 'standard-generic-function 'methods)) @@ -1609,17 +1609,17 @@ bootstrapping. (!bootstrap-slot-index 'standard-generic-function 'dfun-state)) (defstruct (arg-info - (:conc-name nil) - (:constructor make-arg-info ()) - (:copier nil)) + (:conc-name nil) + (:constructor make-arg-info ()) + (:copier nil)) (arg-info-lambda-list :no-lambda-list) arg-info-precedence arg-info-metatypes arg-info-number-optional arg-info-key/rest-p arg-info-keys ;nil no &KEY or &REST allowed - ;(k1 k2 ..) Each method must accept these &KEY arguments. - ;T must have &KEY or &REST + ;(k1 k2 ..) Each method must accept these &KEY arguments. + ;T must have &KEY or &REST gf-info-simple-accessor-type ; nil, reader, writer, boundp (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info @@ -1650,47 +1650,47 @@ bootstrapping. if (eq x '&key) do (loop-finish))) (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) - argument-precedence-order) + argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) - (gf-arg-info gf) - (early-gf-arg-info gf))) - (methods (if (eq *boot-state* 'complete) - (generic-function-methods gf) - (early-gf-methods gf))) - (was-valid-p (integerp (arg-info-number-optional arg-info))) - (first-p (and new-method (null (cdr methods))))) + (gf-arg-info gf) + (early-gf-arg-info gf))) + (methods (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf))) + (was-valid-p (integerp (arg-info-number-optional arg-info))) + (first-p (and new-method (null (cdr methods))))) (when (and (not lambda-list-p) methods) (setq lambda-list (gf-lambda-list gf))) (when (or lambda-list-p - (and first-p - (eq (arg-info-lambda-list arg-info) :no-lambda-list))) + (and first-p + (eq (arg-info-lambda-list arg-info) :no-lambda-list))) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list lambda-list) - (when (and methods (not first-p)) - (let ((gf-nreq (arg-info-number-required arg-info)) - (gf-nopt (arg-info-number-optional arg-info)) - (gf-key/rest-p (arg-info-key/rest-p arg-info))) - (unless (and (= nreq gf-nreq) - (= nopt gf-nopt) - (eq (or keysp restp) gf-key/rest-p)) - (error "The lambda-list ~S is incompatible with ~ - existing methods of ~S." - lambda-list gf)))) + (analyze-lambda-list lambda-list) + (when (and methods (not first-p)) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info))) + (unless (and (= nreq gf-nreq) + (= nopt gf-nopt) + (eq (or keysp restp) gf-key/rest-p)) + (error "The lambda-list ~S is incompatible with ~ + existing methods of ~S." + lambda-list gf)))) (setf (arg-info-lambda-list arg-info) - (if lambda-list-p - lambda-list + (if lambda-list-p + lambda-list (create-gf-lambda-list lambda-list))) - (when (or lambda-list-p argument-precedence-order - (null (arg-info-precedence arg-info))) - (setf (arg-info-precedence arg-info) - (compute-precedence lambda-list nreq argument-precedence-order))) - (setf (arg-info-metatypes arg-info) (make-list nreq)) - (setf (arg-info-number-optional arg-info) nopt) - (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) - (setf (arg-info-keys arg-info) - (if lambda-list-p - (if allow-other-keys-p t keywords) - (arg-info-key/rest-p arg-info))))) + (when (or lambda-list-p argument-precedence-order + (null (arg-info-precedence arg-info))) + (setf (arg-info-precedence arg-info) + (compute-precedence lambda-list nreq argument-precedence-order))) + (setf (arg-info-metatypes arg-info) (make-list nreq)) + (setf (arg-info-number-optional arg-info) nopt) + (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) + (setf (arg-info-keys arg-info) + (if lambda-list-p + (if allow-other-keys-p t keywords) + (arg-info-key/rest-p arg-info))))) (when new-method (check-method-arg-info gf arg-info new-method)) (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) @@ -1699,118 +1699,118 @@ bootstrapping. (defun check-method-arg-info (gf arg-info method) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) + (early-method-lambda-list method) + (method-lambda-list method))) (flet ((lose (string &rest args) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list method gf string args))) - (comparison-description (x y) - (if (> x y) "more" "fewer"))) + :format-arguments (list method gf string args))) + (comparison-description (x y) + (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) - (gf-nopt (arg-info-number-optional arg-info)) - (gf-key/rest-p (arg-info-key/rest-p arg-info)) - (gf-keywords (arg-info-keys arg-info))) - (unless (= nreq gf-nreq) - (lose - "the method has ~A required arguments than the generic function." - (comparison-description nreq gf-nreq))) - (unless (= nopt gf-nopt) - (lose - "the method has ~A optional arguments than the generic function." - (comparison-description nopt gf-nopt))) - (unless (eq (or keysp restp) gf-key/rest-p) - (lose - "the method and generic function differ in whether they accept~_~ - &REST or &KEY arguments.")) - (when (consp gf-keywords) - (unless (or (and restp (not keysp)) - allow-other-keys-p - (every (lambda (k) (memq k keywords)) gf-keywords)) - (lose "the method does not accept each of the &KEY arguments~2I~_~ - ~S." - gf-keywords))))))) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info)) + (gf-keywords (arg-info-keys arg-info))) + (unless (= nreq gf-nreq) + (lose + "the method has ~A required arguments than the generic function." + (comparison-description nreq gf-nreq))) + (unless (= nopt gf-nopt) + (lose + "the method has ~A optional arguments than the generic function." + (comparison-description nopt gf-nopt))) + (unless (eq (or keysp restp) gf-key/rest-p) + (lose + "the method and generic function differ in whether they accept~_~ + &REST or &KEY arguments.")) + (when (consp gf-keywords) + (unless (or (and restp (not keysp)) + allow-other-keys-p + (every (lambda (k) (memq k keywords)) gf-keywords)) + (lose "the method does not accept each of the &KEY arguments~2I~_~ + ~S." + gf-keywords))))))) (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) (let* ((existing-p (and methods (cdr methods) new-method)) - (nreq (length (arg-info-metatypes arg-info))) - (metatypes (if existing-p - (arg-info-metatypes arg-info) - (make-list nreq))) - (type (if existing-p - (gf-info-simple-accessor-type arg-info) - nil))) + (nreq (length (arg-info-metatypes arg-info))) + (metatypes (if existing-p + (arg-info-metatypes arg-info) + (make-list nreq))) + (type (if existing-p + (gf-info-simple-accessor-type arg-info) + nil))) (when (arg-info-valid-p arg-info) (dolist (method (if new-method (list new-method) methods)) - (let* ((specializers (if (or (eq *boot-state* 'complete) - (not (consp method))) - (method-specializers method) - (early-method-specializers method t))) - (class (if (or (eq *boot-state* 'complete) (not (consp method))) - (class-of method) - (early-method-class method))) - (new-type (when (and class - (or (not (eq *boot-state* 'complete)) - (eq (generic-function-method-combination gf) - *standard-method-combination*))) - (cond ((eq class *the-class-standard-reader-method*) - 'reader) - ((eq class *the-class-standard-writer-method*) - 'writer) - ((eq class *the-class-standard-boundp-method*) - 'boundp))))) - (setq metatypes (mapcar #'raise-metatype metatypes specializers)) - (setq type (cond ((null type) new-type) - ((eq type new-type) type) - (t nil))))) + (let* ((specializers (if (or (eq *boot-state* 'complete) + (not (consp method))) + (method-specializers method) + (early-method-specializers method t))) + (class (if (or (eq *boot-state* 'complete) (not (consp method))) + (class-of method) + (early-method-class method))) + (new-type (when (and class + (or (not (eq *boot-state* 'complete)) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + (cond ((eq class *the-class-standard-reader-method*) + 'reader) + ((eq class *the-class-standard-writer-method*) + 'writer) + ((eq class *the-class-standard-boundp-method*) + 'boundp))))) + (setq metatypes (mapcar #'raise-metatype metatypes specializers)) + (setq type (cond ((null type) new-type) + ((eq type new-type) type) + (t nil))))) (setf (arg-info-metatypes arg-info) metatypes) (setf (gf-info-simple-accessor-type arg-info) type))) (when (or (not was-valid-p) first-p) (multiple-value-bind (c-a-m-emf std-p) - (if (early-gf-p gf) - (values t t) - (compute-applicable-methods-emf gf)) + (if (early-gf-p gf) + (values t t) + (compute-applicable-methods-emf gf)) (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) (setf (gf-info-c-a-m-emf-std-p arg-info) std-p) (unless (gf-info-c-a-m-emf-std-p arg-info) - (setf (gf-info-simple-accessor-type arg-info) t)))) + (setf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p (let ((name (if (eq *boot-state* 'complete) - (generic-function-name gf) - (!early-gf-name gf)))) + (generic-function-name gf) + (!early-gf-name gf)))) (setf (gf-precompute-dfun-and-emf-p arg-info) - (cond - ((and (consp name) - (member (car name) - *internal-pcl-generalized-fun-name-symbols*)) - nil) - (t (let* ((symbol (fun-name-block-name name)) - (package (symbol-package symbol))) - (and (or (eq package *pcl-package*) - (memq package (package-use-list *pcl-package*))) - ;; FIXME: this test will eventually be - ;; superseded by the *internal-pcl...* test, - ;; above. While we are in a process of - ;; transition, however, it should probably - ;; remain. - (not (find #\Space (symbol-name symbol)))))))))) + (cond + ((and (consp name) + (member (car name) + *internal-pcl-generalized-fun-name-symbols*)) + nil) + (t (let* ((symbol (fun-name-block-name name)) + (package (symbol-package symbol))) + (and (or (eq package *pcl-package*) + (memq package (package-use-list *pcl-package*))) + ;; FIXME: this test will eventually be + ;; superseded by the *internal-pcl...* test, + ;; above. While we are in a process of + ;; transition, however, it should probably + ;; remain. + (not (find #\Space (symbol-name symbol)))))))))) (setf (gf-info-fast-mf-p arg-info) - (or (not (eq *boot-state* 'complete)) - (let* ((method-class (generic-function-method-class gf)) - (methods (compute-applicable-methods - #'make-method-lambda - (list gf (class-prototype method-class) - '(lambda) nil)))) - (and methods (null (cdr methods)) - (let ((specls (method-specializers (car methods)))) - (and (classp (car specls)) - (eq 'standard-generic-function - (class-name (car specls))) - (classp (cadr specls)) - (eq 'standard-method - (class-name (cadr specls))))))))) + (or (not (eq *boot-state* 'complete)) + (let* ((method-class (generic-function-method-class gf)) + (methods (compute-applicable-methods + #'make-method-lambda + (list gf (class-prototype method-class) + '(lambda) nil)))) + (and methods (null (cdr methods)) + (let ((specls (method-specializers (car methods)))) + (and (classp (car specls)) + (eq 'standard-generic-function + (class-name (car specls))) + (classp (cadr specls)) + (eq 'standard-method + (class-name (cadr specls))))))))) arg-info) ;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS. @@ -1822,85 +1822,85 @@ bootstrapping. ;;; CAR - a list of the early methods on this early gf ;;; CADR - the early discriminator code for this method (defun ensure-generic-function-using-class (existing spec &rest keys - &key (lambda-list nil - lambda-list-p) - argument-precedence-order - &allow-other-keys) + &key (lambda-list nil + lambda-list-p) + argument-precedence-order + &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) - (when lambda-list-p - (set-arg-info existing :lambda-list lambda-list)) - existing) - ((assoc spec *!generic-function-fixups* :test #'equal) - (if existing - (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order) - (error "The function ~S is not already defined." spec))) - (existing - (error "~S should be on the list ~S." - spec - '*!generic-function-fixups*)) - (t - (pushnew spec *!early-generic-functions* :test #'equal) - (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order)))) + (when lambda-list-p + (set-arg-info existing :lambda-list lambda-list)) + existing) + ((assoc spec *!generic-function-fixups* :test #'equal) + (if existing + (make-early-gf spec lambda-list lambda-list-p existing + argument-precedence-order) + (error "The function ~S is not already defined." spec))) + (existing + (error "~S should be on the list ~S." + spec + '*!generic-function-fixups*)) + (t + (pushnew spec *!early-generic-functions* :test #'equal) + (make-early-gf spec lambda-list lambda-list-p nil + argument-precedence-order)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p - function argument-precedence-order) + function argument-precedence-order) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin (or function - (if (eq spec 'print-object) - #'(instance-lambda (instance stream) - (print-unreadable-object (instance stream :identity t) - (format stream "std-instance"))) - #'(instance-lambda (&rest args) - (declare (ignore args)) - (error "The function of the funcallable-instance ~S~ - has not been set." fin))))) + (if (eq spec 'print-object) + #'(instance-lambda (instance stream) + (print-unreadable-object (instance stream :identity t) + (format stream "std-instance"))) + #'(instance-lambda (&rest args) + (declare (ignore args)) + (error "The function of the funcallable-instance ~S~ + 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-pathname*) + fin + 'source + *load-pathname*) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p - (proclaim (defgeneric-declaration spec lambda-list)) - (if argument-precedence-order - (set-arg-info fin - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order) - (set-arg-info fin :lambda-list lambda-list)))) + (proclaim (defgeneric-declaration spec lambda-list)) + (if argument-precedence-order + (set-arg-info fin + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info fin :lambda-list lambda-list)))) fin)) (defun set-dfun (gf &optional dfun cache info) (when cache (setf (cache-owner cache) gf)) (let ((new-state (if (and dfun (or cache info)) - (list* dfun cache info) - dfun))) + (list* dfun cache info) + dfun))) (if (eq *boot-state* 'complete) - (setf (gf-dfun-state gf) new-state) - (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) - new-state))) + (setf (gf-dfun-state gf) new-state) + (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) + new-state))) dfun) (defun gf-dfun-cache (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (gf-dfun-state gf) + (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cadr state))))) (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (gf-dfun-state gf) + (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cddr state))))) @@ -1913,55 +1913,55 @@ bootstrapping. (defun gf-lambda-list (gf) (let ((arg-info (if (eq *boot-state* 'complete) - (gf-arg-info gf) - (early-gf-arg-info gf)))) + (gf-arg-info gf) + (early-gf-arg-info gf)))) (if (eq :no-lambda-list (arg-info-lambda-list arg-info)) - (let ((methods (if (eq *boot-state* 'complete) - (generic-function-methods gf) - (early-gf-methods gf)))) - (if (null methods) - (progn - (warn "no way to determine the lambda list for ~S" gf) - nil) - (let* ((method (car (last methods))) - (ll (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method)))) + (let ((methods (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf)))) + (if (null methods) + (progn + (warn "no way to determine the lambda list for ~S" gf) + nil) + (let* ((method (car (last methods))) + (ll (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method)))) (create-gf-lambda-list ll)))) - (arg-info-lambda-list arg-info)))) + (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) `(progn (cond ((symbolp ,gf-class) - (setq ,gf-class (find-class ,gf-class t ,env))) - ((classp ,gf-class)) - (t - (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ - class nor a symbol that names a class." - ,gf-class))) + (setq ,gf-class (find-class ,gf-class t ,env))) + ((classp ,gf-class)) + (t + (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ + class nor a symbol that names a class." + ,gf-class))) (remf ,all-keys :generic-function-class) (remf ,all-keys :environment) (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) (unless (eq combin '.shes-not-there.) - (setf (getf ,all-keys :method-combination) - (find-method-combination (class-prototype ,gf-class) - (car combin) - (cdr combin))))) + (setf (getf ,all-keys :method-combination) + (find-method-combination (class-prototype ,gf-class) + (car combin) + (cdr combin))))) (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) - (find-class method-class t ,env)))))) + (find-class method-class t ,env)))))) (defun real-ensure-gf-using-class--generic-function (existing - fun-name - &rest all-keys - &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function gf-class-p) - &allow-other-keys) + fun-name + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function gf-class-p) + &allow-other-keys) (real-ensure-gf-internal generic-function-class all-keys environment) (unless (or (null gf-class-p) - (eq (class-of existing) generic-function-class)) + (eq (class-of existing) generic-function-class)) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) @@ -1970,17 +1970,17 @@ bootstrapping. (defun real-ensure-gf-using-class--null (existing - fun-name - &rest all-keys - &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function) - &allow-other-keys) + fun-name + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function) + &allow-other-keys) (declare (ignore existing)) (real-ensure-gf-internal generic-function-class all-keys environment) (prog1 (setf (gdefinition fun-name) - (apply #'make-instance generic-function-class - :name fun-name all-keys)) + (apply #'make-instance generic-function-class + :name fun-name all-keys)) (when lambda-list-p (proclaim (defgeneric-declaration fun-name lambda-list))))) @@ -1988,21 +1988,21 @@ bootstrapping. ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (metatypes (arg-info-metatypes arg-info))) - (values (arg-info-applyp arg-info) - metatypes - arg-info)) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (metatypes (arg-info-metatypes arg-info))) + (values (arg-info-applyp arg-info) + metatypes + arg-info)) (values (length metatypes) applyp metatypes - (count-if (lambda (x) (neq x t)) metatypes) - arg-info))) + (count-if (lambda (x) (neq x t)) metatypes) + arg-info))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc - &optional slot-name) + &optional slot-name) (initialize-method-function initargs) (let ((parsed ()) - (unparsed ())) + (unparsed ())) ;; Figure out whether we got class objects or class names as the ;; specializers and set parsed and unparsed appropriately. If we ;; got class objects, then we can compute unparsed, but if we got @@ -2012,43 +2012,43 @@ bootstrapping. ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. (if (every (lambda (s) (not (symbolp s))) specializers) - (setq parsed specializers - unparsed (mapcar (lambda (s) - (if (eq s t) t (class-name s))) - specializers)) - (setq unparsed specializers - parsed ())) - (list :early-method ;This is an early method dammit! - - (getf initargs :function) - (getf initargs :fast-function) - - parsed ;The parsed specializers. This is used - ;by early-method-specializers to cache - ;the parse. Note that this only comes - ;into play when there is more than one - ;early method on an early gf. - - (list class ;A list to which real-make-a-method - qualifiers ;can be applied to make a real method - arglist ;corresponding to this early one. - unparsed - initargs - doc - slot-name)))) + (setq parsed specializers + unparsed (mapcar (lambda (s) + (if (eq s t) t (class-name s))) + specializers)) + (setq unparsed specializers + parsed ())) + (list :early-method ;This is an early method dammit! + + (getf initargs :function) + (getf initargs :fast-function) + + parsed ;The parsed specializers. This is used + ;by early-method-specializers to cache + ;the parse. Note that this only comes + ;into play when there is more than one + ;early method on an early gf. + + (list class ;A list to which real-make-a-method + qualifiers ;can be applied to make a real method + arglist ;corresponding to this early one. + unparsed + initargs + doc + slot-name)))) (defun real-make-a-method (class qualifiers lambda-list specializers initargs doc - &optional slot-name) + &optional slot-name) (setq specializers (parse-specializers specializers)) (apply #'make-instance class - :qualifiers qualifiers - :lambda-list lambda-list - :specializers specializers - :documentation doc - :slot-name slot-name - :allow-other-keys t - initargs)) + :qualifiers qualifiers + :lambda-list lambda-list + :specializers specializers + :documentation doc + :slot-name slot-name + :allow-other-keys t + initargs)) (defun early-method-function (early-method) (values (cadr early-method) (caddr early-method))) @@ -2059,8 +2059,8 @@ bootstrapping. (defun early-method-standard-accessor-p (early-method) (let ((class (first (fifth early-method)))) (or (eq class 'standard-reader-method) - (eq class 'standard-writer-method) - (eq class 'standard-boundp-method)))) + (eq class 'standard-writer-method) + (eq class 'standard-boundp-method)))) (defun early-method-standard-accessor-slot-name (early-method) (seventh (fifth early-method))) @@ -2081,13 +2081,13 @@ bootstrapping. ;;; method on any generic function up until the time classes exist. (defun early-method-specializers (early-method &optional objectsp) (if (and (listp early-method) - (eq (car early-method) :early-method)) + (eq (car early-method) :early-method)) (cond ((eq objectsp t) - (or (fourth early-method) - (setf (fourth early-method) - (mapcar #'find-class (cadddr (fifth early-method)))))) - (t - (cadddr (fifth early-method)))) + (or (fourth early-method) + (setf (fourth early-method) + (mapcar #'find-class (cadddr (fifth early-method)))))) + (t + (cadddr (fifth early-method)))) (error "~S is not an early-method." early-method))) (defun early-method-qualifiers (early-method) @@ -2097,22 +2097,22 @@ bootstrapping. (caddr (fifth early-method))) (defun early-add-named-method (generic-function-name - qualifiers - specializers - arglist - &rest initargs) + qualifiers + specializers + arglist + &rest initargs) (let* ((gf (ensure-generic-function generic-function-name)) - (existing - (dolist (m (early-gf-methods gf)) - (when (and (equal (early-method-specializers m) specializers) - (equal (early-method-qualifiers m) qualifiers)) - (return m)))) - (new (make-a-method 'standard-method - qualifiers - arglist - specializers - initargs - ()))) + (existing + (dolist (m (early-gf-methods gf)) + (when (and (equal (early-method-specializers m) specializers) + (equal (early-method-qualifiers m) qualifiers)) + (return m)))) + (new (make-a-method 'standard-method + qualifiers + arglist + specializers + initargs + ()))) (when existing (remove-method gf existing)) (add-method gf new))) @@ -2127,8 +2127,8 @@ bootstrapping. (push method (early-gf-methods generic-function)) (set-arg-info generic-function :new-method method) (unless (assoc (!early-gf-name generic-function) - *!generic-function-fixups* - :test #'equal) + *!generic-function-fixups* + :test #'equal) (update-dfun generic-function))) ;;; This is the early version of REMOVE-METHOD. See comments on @@ -2139,28 +2139,28 @@ bootstrapping. (when (not (and (listp method) (eq (car method) :early-method))) (error "An early remove-method didn't get an early method.")) (setf (early-gf-methods generic-function) - (remove method (early-gf-methods generic-function))) + (remove method (early-gf-methods generic-function))) (set-arg-info generic-function) (unless (assoc (!early-gf-name generic-function) - *!generic-function-fixups* - :test #'equal) + *!generic-function-fixups* + :test #'equal) (update-dfun generic-function))) ;;; This is the early version of GET-METHOD. See comments on the early ;;; version of ADD-METHOD. (defun get-method (generic-function qualifiers specializers - &optional (errorp t)) + &optional (errorp t)) (if (early-gf-p generic-function) (or (dolist (m (early-gf-methods generic-function)) - (when (and (or (equal (early-method-specializers m nil) - specializers) - (equal (early-method-specializers m t) - specializers)) - (equal (early-method-qualifiers m) qualifiers)) - (return m))) - (if errorp - (error "can't get early method") - nil)) + (when (and (or (equal (early-method-specializers m nil) + specializers) + (equal (early-method-specializers m t) + specializers)) + (equal (early-method-qualifiers m) qualifiers)) + (return m))) + (if errorp + (error "can't get early method") + nil)) (real-get-method generic-function qualifiers specializers errorp))) (defun !fix-early-generic-functions () @@ -2169,47 +2169,47 @@ bootstrapping. ;; FIX-EARLY-GENERIC-FUNCTIONS. (dolist (early-gf-spec *!early-generic-functions*) (when (every #'early-method-standard-accessor-p - (early-gf-methods (gdefinition early-gf-spec))) - (push early-gf-spec accessors))) + (early-gf-methods (gdefinition early-gf-spec))) + (push early-gf-spec accessors))) (dolist (spec (nconc accessors - '(accessor-method-slot-name - generic-function-methods - method-specializers - specializerp - specializer-type - specializer-class - slot-definition-location - slot-definition-name - class-slots - gf-arg-info - class-precedence-list - slot-boundp-using-class - (setf slot-value-using-class) - slot-value-using-class - structure-class-p - standard-class-p - funcallable-standard-class-p - specializerp))) + '(accessor-method-slot-name + generic-function-methods + method-specializers + specializerp + specializer-type + specializer-class + slot-definition-location + slot-definition-name + class-slots + gf-arg-info + class-precedence-list + slot-boundp-using-class + (setf slot-value-using-class) + slot-value-using-class + structure-class-p + standard-class-p + funcallable-standard-class-p + specializerp))) (/show spec) (setq *!early-generic-functions* - (cons spec - (delete spec *!early-generic-functions* :test #'equal)))) + (cons spec + (delete spec *!early-generic-functions* :test #'equal)))) (dolist (early-gf-spec *!early-generic-functions*) (/show early-gf-spec) (let* ((gf (gdefinition early-gf-spec)) - (methods (mapcar (lambda (early-method) - (let ((args (copy-list (fifth - early-method)))) - (setf (fourth args) - (early-method-specializers - early-method t)) - (apply #'real-make-a-method args))) - (early-gf-methods gf)))) - (setf (generic-function-method-class gf) *the-class-standard-method*) - (setf (generic-function-method-combination gf) - *standard-method-combination*) - (set-methods gf methods))) + (methods (mapcar (lambda (early-method) + (let ((args (copy-list (fifth + early-method)))) + (setf (fourth args) + (early-method-specializers + early-method t)) + (apply #'real-make-a-method args))) + (early-gf-methods gf)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) + *standard-method-combination*) + (set-methods gf methods))) (dolist (fn *!early-functions*) (/show fn) @@ -2218,33 +2218,33 @@ bootstrapping. (dolist (fixup *!generic-function-fixups*) (/show fixup) (let* ((fspec (car fixup)) - (gf (gdefinition fspec)) - (methods (mapcar (lambda (method) - (let* ((lambda-list (first method)) - (specializers (second method)) - (method-fn-name (third method)) - (fn-name (or method-fn-name fspec)) - (fn (fdefinition fn-name)) - (initargs - (list :function - (set-fun-name - (lambda (args next-methods) - (declare (ignore - next-methods)) - (apply fn args)) - `(call ,fn-name))))) - (declare (type function fn)) - (make-a-method 'standard-method - () - lambda-list - specializers - initargs - nil))) - (cdr fixup)))) - (setf (generic-function-method-class gf) *the-class-standard-method*) - (setf (generic-function-method-combination gf) - *standard-method-combination*) - (set-methods gf methods)))) + (gf (gdefinition fspec)) + (methods (mapcar (lambda (method) + (let* ((lambda-list (first method)) + (specializers (second method)) + (method-fn-name (third method)) + (fn-name (or method-fn-name fspec)) + (fn (fdefinition fn-name)) + (initargs + (list :function + (set-fun-name + (lambda (args next-methods) + (declare (ignore + next-methods)) + (apply fn args)) + `(call ,fn-name))))) + (declare (type function fn)) + (make-a-method 'standard-method + () + lambda-list + specializers + initargs + nil))) + (cdr fixup)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) + *standard-method-combination*) + (set-methods gf methods)))) (/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS")) ;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument @@ -2253,68 +2253,68 @@ bootstrapping. (defun parse-defmethod (cdr-of-form) (declare (list cdr-of-form)) (let ((name (pop cdr-of-form)) - (qualifiers ()) - (spec-ll ())) + (qualifiers ()) + (spec-ll ())) (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) - (push (pop cdr-of-form) qualifiers) - (return (setq qualifiers (nreverse qualifiers))))) + (push (pop cdr-of-form) qualifiers) + (return (setq qualifiers (nreverse qualifiers))))) (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) (defun parse-specializers (specializers) (declare (list specializers)) (flet ((parse (spec) - (let ((result (specializer-from-type spec))) - (if (specializerp result) - result - (if (symbolp spec) - (error "~S was used as a specializer,~%~ - but is not the name of a class." - spec) - (error "~S is not a legal specializer." spec)))))) + (let ((result (specializer-from-type spec))) + (if (specializerp result) + result + (if (symbolp spec) + (error "~S was used as a specializer,~%~ + but is not the name of a class." + spec) + (error "~S is not a legal specializer." spec)))))) (mapcar #'parse specializers))) (defun unparse-specializers (specializers-or-method) (if (listp specializers-or-method) (flet ((unparse (spec) - (if (specializerp spec) - (let ((type (specializer-type spec))) - (if (and (consp type) - (eq (car type) 'class)) - (let* ((class (cadr type)) - (class-name (class-name class))) - (if (eq class (find-class class-name nil)) - class-name - type)) - type)) - (error "~S is not a legal specializer." spec)))) - (mapcar #'unparse specializers-or-method)) + (if (specializerp spec) + (let ((type (specializer-type spec))) + (if (and (consp type) + (eq (car type) 'class)) + (let* ((class (cadr type)) + (class-name (class-name class))) + (if (eq class (find-class class-name nil)) + class-name + type)) + type)) + (error "~S is not a legal specializer." spec)))) + (mapcar #'unparse specializers-or-method)) (unparse-specializers (method-specializers specializers-or-method)))) (defun parse-method-or-spec (spec &optional (errorp t)) (let (gf method name temp) - (if (method-p spec) - (setq method spec - gf (method-generic-function method) - temp (and gf (generic-function-name gf)) - name (if temp + (if (method-p spec) + (setq method spec + gf (method-generic-function method) + temp (and gf (generic-function-name gf)) + name (if temp (make-method-spec temp (method-qualifiers method) (unparse-specializers (method-specializers method))) - (make-symbol (format nil "~S" method)))) - (multiple-value-bind (gf-spec quals specls) - (parse-defmethod spec) - (and (setq gf (and (or errorp (gboundp gf-spec)) - (gdefinition gf-spec))) - (let ((nreq (compute-discriminating-function-arglist-info gf))) - (setq specls (append (parse-specializers specls) - (make-list (- nreq (length specls)) - :initial-element - *the-class-t*))) - (and - (setq method (get-method gf quals specls errorp)) - (setq name + (make-symbol (format nil "~S" method)))) + (multiple-value-bind (gf-spec quals specls) + (parse-defmethod spec) + (and (setq gf (and (or errorp (gboundp gf-spec)) + (gdefinition gf-spec))) + (let ((nreq (compute-discriminating-function-arglist-info gf))) + (setq specls (append (parse-specializers specls) + (make-list (- nreq (length specls)) + :initial-element + *the-class-t*))) + (and + (setq method (get-method gf quals specls errorp)) + (setq name (make-method-spec gf-spec quals (unparse-specializers specls)))))))) (values gf method name))) @@ -2352,75 +2352,75 @@ bootstrapping. (arglist &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux)) &aux (specialized-lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux))) + '(&optional &rest &key &allow-other-keys &aux))) (let ((arg (car arglist))) (cond ((null arglist) (values nil nil nil nil)) - ((eq arg '&aux) - (values nil arglist nil nil)) - ((memq arg lambda-list-keywords) - ;; non-standard lambda-list-keywords are errors. - (unless (memq arg specialized-lambda-list-keywords) - (error 'specialized-lambda-list-error - :format-control "unknown specialized-lambda-list ~ + ((eq arg '&aux) + (values nil arglist nil nil)) + ((memq arg lambda-list-keywords) + ;; non-standard lambda-list-keywords are errors. + (unless (memq arg specialized-lambda-list-keywords) + (error 'specialized-lambda-list-error + :format-control "unknown specialized-lambda-list ~ keyword ~S~%" - :format-arguments (list arg))) - ;; no multiple &rest x &rest bla specifying - (when (memq arg supplied-keywords) - (error 'specialized-lambda-list-error - :format-control "multiple occurrence of ~ + :format-arguments (list arg))) + ;; no multiple &rest x &rest bla specifying + (when (memq arg supplied-keywords) + (error 'specialized-lambda-list-error + :format-control "multiple occurrence of ~ specialized-lambda-list keyword ~S~%" - :format-arguments (list arg))) - ;; And no placing &key in front of &optional, either. - (unless (memq arg allowed-keywords) - (error 'specialized-lambda-list-error - :format-control "misplaced specialized-lambda-list ~ + :format-arguments (list arg))) + ;; And no placing &key in front of &optional, either. + (unless (memq arg allowed-keywords) + (error 'specialized-lambda-list-error + :format-control "misplaced specialized-lambda-list ~ keyword ~S~%" - :format-arguments (list arg))) - ;; When we are at a lambda-list keyword, the parameters - ;; don't include the lambda-list keyword; the lambda-list - ;; does include the lambda-list keyword; and no - ;; specializers are allowed to follow the lambda-list - ;; keywords (at least for now). - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) - (cons arg supplied-keywords) - (if (eq arg '&key) - (cons '&allow-other-keys - (cdr (member arg allowed-keywords))) - (cdr (member arg allowed-keywords)))) - (when (and (eq arg '&rest) - (or (null lambda-list) - (memq (car lambda-list) - specialized-lambda-list-keywords) - (not (or (null (cadr lambda-list)) - (memq (cadr lambda-list) - specialized-lambda-list-keywords))))) - (error 'specialized-lambda-list-error - :format-control - "in a specialized-lambda-list, excactly one ~ + :format-arguments (list arg))) + ;; When we are at a lambda-list keyword, the parameters + ;; don't include the lambda-list keyword; the lambda-list + ;; does include the lambda-list keyword; and no + ;; specializers are allowed to follow the lambda-list + ;; keywords (at least for now). + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) + (cons arg supplied-keywords) + (if (eq arg '&key) + (cons '&allow-other-keys + (cdr (member arg allowed-keywords))) + (cdr (member arg allowed-keywords)))) + (when (and (eq arg '&rest) + (or (null lambda-list) + (memq (car lambda-list) + specialized-lambda-list-keywords) + (not (or (null (cadr lambda-list)) + (memq (cadr lambda-list) + specialized-lambda-list-keywords))))) + (error 'specialized-lambda-list-error + :format-control + "in a specialized-lambda-list, excactly one ~ variable must follow &REST.~%" - :format-arguments nil)) - (values parameters - (cons arg lambda-list) - () - ()))) - (supplied-keywords - ;; After a lambda-list keyword there can be no specializers. - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) - supplied-keywords - allowed-keywords) - (values (cons (if (listp arg) (car arg) arg) parameters) - (cons arg lambda-list) - () - ()))) - (t - (multiple-value-bind (parameters lambda-list specializers required) - (parse-specialized-lambda-list (cdr arglist)) - (values (cons (if (listp arg) (car arg) arg) parameters) - (cons (if (listp arg) (car arg) arg) lambda-list) - (cons (if (listp arg) (cadr arg) t) specializers) - (cons (if (listp arg) (car arg) arg) required))))))) + :format-arguments nil)) + (values parameters + (cons arg lambda-list) + () + ()))) + (supplied-keywords + ;; After a lambda-list keyword there can be no specializers. + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) + supplied-keywords + allowed-keywords) + (values (cons (if (listp arg) (car arg) arg) parameters) + (cons arg lambda-list) + () + ()))) + (t + (multiple-value-bind (parameters lambda-list specializers required) + (parse-specialized-lambda-list (cdr arglist)) + (values (cons (if (listp arg) (car arg) arg) parameters) + (cons (if (listp arg) (car arg) arg) lambda-list) + (cons (if (listp arg) (cadr arg) t) specializers) + (cons (if (listp arg) (car arg) arg) required))))))) (setq *boot-state* 'early) @@ -2434,38 +2434,38 @@ bootstrapping. `(let ((,in ,instance)) (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) - (and (symbolp instance) - `((declare (%variable-rebinding ,in ,instance))))) + (third instance) + instance))) + (and (symbolp instance) + `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) - (let ((var-name - (if (symbolp slot-entry) - slot-entry - (car slot-entry))) - (slot-name - (if (symbolp slot-entry) - slot-entry - (cadr slot-entry)))) - `(,var-name - (slot-value ,in ',slot-name)))) - slots) - ,@body)))) + (let ((var-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,var-name + (slot-value ,in ',slot-name)))) + slots) + ,@body)))) (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) - (and (symbolp instance) - `((declare (%variable-rebinding ,in ,instance))))) + (third instance) + instance))) + (and (symbolp instance) + `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) - (let ((var-name (car slot-entry)) - (accessor-name (cadr slot-entry))) - `(,var-name (,accessor-name ,in)))) - slots) - ,@body)))) + (let ((var-name (car slot-entry)) + (accessor-name (cadr slot-entry))) + `(,var-name (,accessor-name ,in)))) + slots) + ,@body)))) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index ed76500..a3cabbb 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -32,63 +32,63 @@ (in-package "SB-PCL") (defun allocate-standard-instance (wrapper - &optional (slots-init nil slots-init-p)) + &optional (slots-init nil slots-init-p)) (let ((instance (%make-standard-instance nil (get-instance-hash-code))) - (no-of-slots (wrapper-no-of-instance-slots wrapper))) + (no-of-slots (wrapper-no-of-instance-slots wrapper))) (setf (std-instance-wrapper instance) wrapper) (setf (std-instance-slots instance) - (cond (slots-init-p - ;; Inline the slots vector allocation and initialization. - (let ((slots (make-array no-of-slots :initial-element 0))) - (do ((rem-slots slots-init (rest rem-slots)) - (i 0 (1+ i))) - ((>= i no-of-slots)) ;endp rem-slots)) - (declare (list rem-slots) - (type index i)) - (setf (aref slots i) (first rem-slots))) - slots)) - (t - (make-array no-of-slots - :initial-element +slot-unbound+)))) + (cond (slots-init-p + ;; Inline the slots vector allocation and initialization. + (let ((slots (make-array no-of-slots :initial-element 0))) + (do ((rem-slots slots-init (rest rem-slots)) + (i 0 (1+ i))) + ((>= i no-of-slots)) ;endp rem-slots)) + (declare (list rem-slots) + (type index i)) + (setf (aref slots i) (first rem-slots))) + slots)) + (t + (make-array no-of-slots + :initial-element +slot-unbound+)))) instance)) (defmacro allocate-funcallable-instance-slots (wrapper &optional - slots-init-p slots-init) + slots-init-p slots-init) `(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+)))) + `(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+)))) (defun allocate-funcallable-instance (wrapper &optional - (slots-init nil slots-init-p)) + (slots-init nil slots-init-p)) (let ((fin (%make-pcl-funcallable-instance nil nil - (get-instance-hash-code)))) + (get-instance-hash-code)))) (set-funcallable-instance-function fin #'(instance-lambda (&rest args) - (declare (ignore args)) - (error "The function of the funcallable-instance ~S has not been set." - fin))) + (declare (ignore args)) + (error "The function of the funcallable-instance ~S has not been set." + fin))) (setf (fsc-instance-wrapper fin) wrapper - (fsc-instance-slots fin) (allocate-funcallable-instance-slots - wrapper slots-init-p slots-init)) + (fsc-instance-slots fin) (allocate-funcallable-instance-slots + wrapper slots-init-p slots-init)) fin)) (defun allocate-structure-instance (wrapper &optional - (slots-init nil slots-init-p)) + (slots-init nil slots-init-p)) (let* ((class (wrapper-class wrapper)) - (constructor (class-defstruct-constructor class))) + (constructor (class-defstruct-constructor class))) (if constructor - (let ((instance (funcall constructor)) - (slots (class-slots class))) - (when slots-init-p - (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))))) + (let ((instance (funcall constructor)) + (slots (class-slots class))) + (when slots-init-p + (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))))) ;;;; BOOTSTRAP-META-BRAID ;;;; @@ -97,35 +97,35 @@ (defmacro !initial-classes-and-wrappers (&rest classes) `(progn ,@(mapcar (lambda (class) - (let ((wr (format-symbol *pcl-package* "~A-WRAPPER" class))) - `(setf ,wr ,(if (eq class 'standard-generic-function) - '*sgf-wrapper* - `(boot-make-wrapper - (early-class-size ',class) - ',class)) - ,class (allocate-standard-instance - ,(if (eq class 'standard-generic-function) - 'funcallable-standard-class-wrapper - 'standard-class-wrapper)) - (wrapper-class ,wr) ,class - (find-class ',class) ,class))) - classes))) + (let ((wr (format-symbol *pcl-package* "~A-WRAPPER" class))) + `(setf ,wr ,(if (eq class 'standard-generic-function) + '*sgf-wrapper* + `(boot-make-wrapper + (early-class-size ',class) + ',class)) + ,class (allocate-standard-instance + ,(if (eq class 'standard-generic-function) + 'funcallable-standard-class-wrapper + 'standard-class-wrapper)) + (wrapper-class ,wr) ,class + (find-class ',class) ,class))) + classes))) (defun !bootstrap-meta-braid () (let* ((*create-classes-from-internal-structure-definitions-p* nil) - std-class-wrapper std-class - standard-class-wrapper standard-class - funcallable-standard-class-wrapper funcallable-standard-class - slot-class-wrapper slot-class - built-in-class-wrapper built-in-class - structure-class-wrapper structure-class - condition-class-wrapper condition-class - standard-direct-slot-definition-wrapper - standard-direct-slot-definition - standard-effective-slot-definition-wrapper - standard-effective-slot-definition - class-eq-specializer-wrapper class-eq-specializer - standard-generic-function-wrapper standard-generic-function) + std-class-wrapper std-class + standard-class-wrapper standard-class + funcallable-standard-class-wrapper funcallable-standard-class + slot-class-wrapper slot-class + built-in-class-wrapper built-in-class + structure-class-wrapper structure-class + condition-class-wrapper condition-class + standard-direct-slot-definition-wrapper + standard-direct-slot-definition + standard-effective-slot-definition-wrapper + standard-effective-slot-definition + class-eq-specializer-wrapper class-eq-specializer + standard-generic-function-wrapper standard-generic-function) (!initial-classes-and-wrappers standard-class funcallable-standard-class slot-class built-in-class structure-class condition-class std-class @@ -136,154 +136,154 @@ ;; the wrapper is always that of STANDARD-CLASS. (dolist (definition *early-class-definitions*) (let* ((name (ecd-class-name definition)) - (meta (ecd-metaclass definition)) - (wrapper (ecase meta - (slot-class slot-class-wrapper) - (std-class std-class-wrapper) - (standard-class standard-class-wrapper) - (funcallable-standard-class - funcallable-standard-class-wrapper) - (built-in-class built-in-class-wrapper) - (structure-class structure-class-wrapper) - (condition-class condition-class-wrapper))) - (class (or (find-class name nil) - (allocate-standard-instance wrapper)))) - (setf (find-class name) class))) + (meta (ecd-metaclass definition)) + (wrapper (ecase meta + (slot-class slot-class-wrapper) + (std-class std-class-wrapper) + (standard-class standard-class-wrapper) + (funcallable-standard-class + funcallable-standard-class-wrapper) + (built-in-class built-in-class-wrapper) + (structure-class structure-class-wrapper) + (condition-class condition-class-wrapper))) + (class (or (find-class name nil) + (allocate-standard-instance wrapper)))) + (setf (find-class name) class))) (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) - (meta (ecd-metaclass definition)) - (source (ecd-source definition)) - (direct-supers (ecd-superclass-names definition)) - (direct-slots (ecd-canonical-slots definition)) - (other-initargs (ecd-other-initargs definition))) - (let ((direct-default-initargs - (getf other-initargs :direct-default-initargs))) - (multiple-value-bind (slots cpl default-initargs direct-subclasses) - (early-collect-inheritance name) - (let* ((class (find-class name)) - (wrapper (cond ((eq class slot-class) - slot-class-wrapper) - ((eq class std-class) - std-class-wrapper) - ((eq class standard-class) - standard-class-wrapper) - ((eq class funcallable-standard-class) - funcallable-standard-class-wrapper) - ((eq class standard-direct-slot-definition) - standard-direct-slot-definition-wrapper) - ((eq class - standard-effective-slot-definition) - standard-effective-slot-definition-wrapper) - ((eq class built-in-class) - built-in-class-wrapper) - ((eq class structure-class) - structure-class-wrapper) - ((eq class condition-class) - condition-class-wrapper) - ((eq class class-eq-specializer) - class-eq-specializer-wrapper) - ((eq class standard-generic-function) - standard-generic-function-wrapper) - (t - (boot-make-wrapper (length slots) name)))) - (proto nil)) - (when (eq name t) (setq *the-wrapper-of-t* wrapper)) - (set (make-class-symbol name) class) - (dolist (slot slots) - (unless (eq (getf slot :allocation :instance) :instance) - (error "Slot allocation ~S is not supported in bootstrap." - (getf slot :allocation)))) - - (when (typep wrapper 'wrapper) - (setf (wrapper-instance-slots-layout wrapper) - (mapcar #'canonical-slot-name slots)) - (setf (wrapper-class-slots wrapper) - ())) - - (setq proto (if (eq meta 'funcallable-standard-class) - (allocate-funcallable-instance wrapper) - (allocate-standard-instance wrapper))) - - (setq direct-slots - (!bootstrap-make-slot-definitions - name class direct-slots - standard-direct-slot-definition-wrapper nil)) - (setq slots - (!bootstrap-make-slot-definitions - name class slots - standard-effective-slot-definition-wrapper t)) - - (case meta - ((std-class standard-class funcallable-standard-class) - (!bootstrap-initialize-class - meta - class name class-eq-specializer-wrapper source - direct-supers direct-subclasses cpl wrapper proto - direct-slots slots direct-default-initargs default-initargs)) - (built-in-class ; *the-class-t* - (!bootstrap-initialize-class - meta - class name class-eq-specializer-wrapper source - direct-supers direct-subclasses cpl wrapper proto)) - (slot-class ; *the-class-slot-object* - (!bootstrap-initialize-class - meta - class name class-eq-specializer-wrapper source - direct-supers direct-subclasses cpl wrapper proto)) - (structure-class ; *the-class-structure-object* - (!bootstrap-initialize-class - meta - class name class-eq-specializer-wrapper source - direct-supers direct-subclasses cpl wrapper)) - (condition-class - (!bootstrap-initialize-class - meta - class name class-eq-specializer-wrapper source - direct-supers direct-subclasses cpl wrapper)))))))) + (meta (ecd-metaclass definition)) + (source (ecd-source definition)) + (direct-supers (ecd-superclass-names definition)) + (direct-slots (ecd-canonical-slots definition)) + (other-initargs (ecd-other-initargs definition))) + (let ((direct-default-initargs + (getf other-initargs :direct-default-initargs))) + (multiple-value-bind (slots cpl default-initargs direct-subclasses) + (early-collect-inheritance name) + (let* ((class (find-class name)) + (wrapper (cond ((eq class slot-class) + slot-class-wrapper) + ((eq class std-class) + std-class-wrapper) + ((eq class standard-class) + standard-class-wrapper) + ((eq class funcallable-standard-class) + funcallable-standard-class-wrapper) + ((eq class standard-direct-slot-definition) + standard-direct-slot-definition-wrapper) + ((eq class + standard-effective-slot-definition) + standard-effective-slot-definition-wrapper) + ((eq class built-in-class) + built-in-class-wrapper) + ((eq class structure-class) + structure-class-wrapper) + ((eq class condition-class) + condition-class-wrapper) + ((eq class class-eq-specializer) + class-eq-specializer-wrapper) + ((eq class standard-generic-function) + standard-generic-function-wrapper) + (t + (boot-make-wrapper (length slots) name)))) + (proto nil)) + (when (eq name t) (setq *the-wrapper-of-t* wrapper)) + (set (make-class-symbol name) class) + (dolist (slot slots) + (unless (eq (getf slot :allocation :instance) :instance) + (error "Slot allocation ~S is not supported in bootstrap." + (getf slot :allocation)))) + + (when (typep wrapper 'wrapper) + (setf (wrapper-instance-slots-layout wrapper) + (mapcar #'canonical-slot-name slots)) + (setf (wrapper-class-slots wrapper) + ())) + + (setq proto (if (eq meta 'funcallable-standard-class) + (allocate-funcallable-instance wrapper) + (allocate-standard-instance wrapper))) + + (setq direct-slots + (!bootstrap-make-slot-definitions + name class direct-slots + standard-direct-slot-definition-wrapper nil)) + (setq slots + (!bootstrap-make-slot-definitions + name class slots + standard-effective-slot-definition-wrapper t)) + + (case meta + ((std-class standard-class funcallable-standard-class) + (!bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto + direct-slots slots direct-default-initargs default-initargs)) + (built-in-class ; *the-class-t* + (!bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto)) + (slot-class ; *the-class-slot-object* + (!bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper proto)) + (structure-class ; *the-class-structure-object* + (!bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper)) + (condition-class + (!bootstrap-initialize-class + meta + class name class-eq-specializer-wrapper source + direct-supers direct-subclasses cpl wrapper)))))))) (let* ((smc-class (find-class 'standard-method-combination)) - (smc-wrapper (!bootstrap-get-slot 'standard-class - smc-class - 'wrapper)) - (smc (allocate-standard-instance smc-wrapper))) + (smc-wrapper (!bootstrap-get-slot 'standard-class + smc-class + 'wrapper)) + (smc (allocate-standard-instance smc-wrapper))) (flet ((set-slot (name value) - (!bootstrap-set-slot 'standard-method-combination - smc - name - value))) - (set-slot 'source *load-pathname*) - (set-slot 'type 'standard) - (set-slot 'documentation "The standard method combination.") - (set-slot 'options ())) + (!bootstrap-set-slot 'standard-method-combination + smc + name + value))) + (set-slot 'source *load-pathname*) + (set-slot 'type 'standard) + (set-slot 'documentation "The standard method combination.") + (set-slot 'options ())) (setq *standard-method-combination* smc)))) ;;; Initialize a class metaobject. (defun !bootstrap-initialize-class (metaclass-name class name - class-eq-wrapper source direct-supers direct-subclasses cpl wrapper - &optional - (proto nil proto-p) - direct-slots slots direct-default-initargs default-initargs) + class-eq-wrapper source direct-supers direct-subclasses cpl wrapper + &optional + (proto nil proto-p) + direct-slots slots direct-default-initargs default-initargs) (flet ((classes (names) (mapcar #'find-class names)) - (set-slot (slot-name value) - (!bootstrap-set-slot metaclass-name class slot-name value))) + (set-slot (slot-name value) + (!bootstrap-set-slot metaclass-name class slot-name value))) (set-slot 'name name) (set-slot 'finalized-p t) (set-slot 'source source) (set-slot 'type (if (eq class (find-class t)) - t - ;; FIXME: Could this just be CLASS instead - ;; of `(CLASS ,CLASS)? If not, why not? - ;; (See also similar expression in - ;; SHARED-INITIALIZE :BEFORE (CLASS).) - `(class ,class))) + t + ;; FIXME: Could this just be CLASS instead + ;; of `(CLASS ,CLASS)? If not, why not? + ;; (See also similar expression in + ;; SHARED-INITIALIZE :BEFORE (CLASS).) + `(class ,class))) (set-slot 'class-eq-specializer - (let ((spec (allocate-standard-instance class-eq-wrapper))) - (!bootstrap-set-slot 'class-eq-specializer spec 'type - `(class-eq ,class)) - (!bootstrap-set-slot 'class-eq-specializer spec 'object - class) - spec)) + (let ((spec (allocate-standard-instance class-eq-wrapper))) + (!bootstrap-set-slot 'class-eq-specializer spec 'type + `(class-eq ,class)) + (!bootstrap-set-slot 'class-eq-specializer spec 'object + class) + spec)) (set-slot 'class-precedence-list (classes cpl)) (set-slot 'cpl-available-p t) (set-slot 'can-precede-list (classes (cdr cpl))) @@ -293,16 +293,16 @@ (set-slot 'direct-methods (cons nil nil)) (set-slot 'wrapper wrapper) (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*)) - (make-class-predicate-name name))) + (make-class-predicate-name name))) (set-slot 'documentation nil) (set-slot 'plist - `(,@(and direct-default-initargs - `(direct-default-initargs ,direct-default-initargs)) - ,@(and default-initargs - `(default-initargs ,default-initargs)))) + `(,@(and direct-default-initargs + `(direct-default-initargs ,direct-default-initargs)) + ,@(and default-initargs + `(default-initargs ,default-initargs)))) (when (memq metaclass-name '(standard-class funcallable-standard-class - structure-class condition-class - slot-class std-class)) + structure-class condition-class + slot-class std-class)) (set-slot 'direct-slots direct-slots) (set-slot 'slots slots)) @@ -312,165 +312,165 @@ ;; inherits the slot from class CLASS. (dolist (super direct-supers) (let* ((super (find-class super)) - (subclasses (!bootstrap-get-slot metaclass-name super - 'direct-subclasses))) - (cond ((eq +slot-unbound+ subclasses) - (!bootstrap-set-slot metaclass-name super 'direct-subclasses - (list class))) - ((not (memq class subclasses)) - (!bootstrap-set-slot metaclass-name super 'direct-subclasses - (cons class subclasses)))))) + (subclasses (!bootstrap-get-slot metaclass-name super + 'direct-subclasses))) + (cond ((eq +slot-unbound+ subclasses) + (!bootstrap-set-slot metaclass-name super 'direct-subclasses + (list class))) + ((not (memq class subclasses)) + (!bootstrap-set-slot metaclass-name super 'direct-subclasses + (cons class subclasses)))))) (case metaclass-name (structure-class (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) - (set-slot 'predicate-name (or (cadr (assoc name - *early-class-predicates*)) - (make-class-predicate-name name))) - (set-slot 'defstruct-form - `(defstruct (structure-object (:constructor - ,constructor-sym) - (:copier nil)))) - (set-slot 'defstruct-constructor constructor-sym) - (set-slot 'from-defclass-p t) - (set-slot 'plist nil) - (set-slot 'prototype (funcall constructor-sym)))) + (set-slot 'predicate-name (or (cadr (assoc name + *early-class-predicates*)) + (make-class-predicate-name name))) + (set-slot 'defstruct-form + `(defstruct (structure-object (:constructor + ,constructor-sym) + (:copier nil)))) + (set-slot 'defstruct-constructor constructor-sym) + (set-slot 'from-defclass-p t) + (set-slot 'plist nil) + (set-slot 'prototype (funcall constructor-sym)))) (condition-class (set-slot 'prototype (make-condition name))) (t (set-slot 'prototype - (if proto-p proto (allocate-standard-instance wrapper))))) + (if proto-p proto (allocate-standard-instance wrapper))))) class)) (defun !bootstrap-make-slot-definitions (name class slots wrapper effective-p) (let ((index -1)) (mapcar (lambda (slot) - (incf index) - (!bootstrap-make-slot-definition - name class slot wrapper effective-p index)) - slots))) + (incf index) + (!bootstrap-make-slot-definition + name class slot wrapper effective-p index)) + slots))) (defun !bootstrap-make-slot-definition (name class slot wrapper effective-p index) (let* ((slotd-class-name (if effective-p - 'standard-effective-slot-definition - 'standard-direct-slot-definition)) - (slotd (allocate-standard-instance wrapper)) - (slot-name (getf slot :name))) + 'standard-effective-slot-definition + 'standard-direct-slot-definition)) + (slotd (allocate-standard-instance wrapper)) + (slot-name (getf slot :name))) (flet ((get-val (name) (getf slot name)) - (set-val (name val) - (!bootstrap-set-slot slotd-class-name slotd name val))) - (set-val 'name slot-name) + (set-val (name val) + (!bootstrap-set-slot slotd-class-name slotd name val))) + (set-val 'name slot-name) (set-val 'initform (get-val :initform)) (set-val 'initfunction (get-val :initfunction)) (set-val 'initargs (get-val :initargs)) (set-val 'readers (get-val :readers)) (set-val 'writers (get-val :writers)) (set-val 'allocation :instance) - (set-val 'type (or (get-val :type) t)) + (set-val 'type (or (get-val :type) t)) (set-val 'documentation (or (get-val :documentation) "")) - (set-val 'class class) + (set-val 'class class) (when effective-p - (set-val 'location index) - (let ((fsc-p nil)) - (set-val 'reader-function (make-optimized-std-reader-method-function - fsc-p nil slot-name index)) - (set-val 'writer-function (make-optimized-std-writer-method-function - fsc-p nil slot-name index)) - (set-val 'boundp-function (make-optimized-std-boundp-method-function - fsc-p nil slot-name index))) - (set-val 'accessor-flags 7) - (let ((table (or (gethash slot-name *name->class->slotd-table*) - (setf (gethash slot-name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (setf (gethash class table) slotd))) + (set-val 'location index) + (let ((fsc-p nil)) + (set-val 'reader-function (make-optimized-std-reader-method-function + fsc-p nil slot-name index)) + (set-val 'writer-function (make-optimized-std-writer-method-function + fsc-p nil slot-name index)) + (set-val 'boundp-function (make-optimized-std-boundp-method-function + fsc-p nil slot-name index))) + (set-val 'accessor-flags 7) + (let ((table (or (gethash slot-name *name->class->slotd-table*) + (setf (gethash slot-name *name->class->slotd-table*) + (make-hash-table :test 'eq :size 5))))) + (setf (gethash class table) slotd))) (when (and (eq name 'standard-class) - (eq slot-name 'slots) effective-p) - (setq *the-eslotd-standard-class-slots* slotd)) + (eq slot-name 'slots) effective-p) + (setq *the-eslotd-standard-class-slots* slotd)) (when (and (eq name 'funcallable-standard-class) - (eq slot-name 'slots) effective-p) - (setq *the-eslotd-funcallable-standard-class-slots* slotd)) + (eq slot-name 'slots) effective-p) + (setq *the-eslotd-funcallable-standard-class-slots* slotd)) slotd))) (defun !bootstrap-accessor-definitions (early-p) (let ((*early-p* early-p)) (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) - (meta (ecd-metaclass definition))) - (unless (eq meta 'built-in-class) - (let ((direct-slots (ecd-canonical-slots definition))) - (dolist (slotd direct-slots) - (let ((slot-name (getf slotd :name)) - (readers (getf slotd :readers)) - (writers (getf slotd :writers))) - (!bootstrap-accessor-definitions1 - name - slot-name - readers - writers - nil) - (!bootstrap-accessor-definitions1 - 'slot-object - slot-name - (list (slot-reader-name slot-name)) - (list (slot-writer-name slot-name)) - (list (slot-boundp-name slot-name))))))))))) + (meta (ecd-metaclass definition))) + (unless (eq meta 'built-in-class) + (let ((direct-slots (ecd-canonical-slots definition))) + (dolist (slotd direct-slots) + (let ((slot-name (getf slotd :name)) + (readers (getf slotd :readers)) + (writers (getf slotd :writers))) + (!bootstrap-accessor-definitions1 + name + slot-name + readers + writers + nil) + (!bootstrap-accessor-definitions1 + 'slot-object + slot-name + (list (slot-reader-name slot-name)) + (list (slot-writer-name slot-name)) + (list (slot-boundp-name slot-name))))))))))) (defun !bootstrap-accessor-definition (class-name accessor-name slot-name type) (multiple-value-bind (accessor-class make-method-function arglist specls doc) (ecase type - (reader (values 'standard-reader-method - #'make-std-reader-method-function - (list class-name) - (list class-name) - "automatically generated reader method")) - (writer (values 'standard-writer-method - #'make-std-writer-method-function - (list 'new-value class-name) - (list t class-name) - "automatically generated writer method")) - (boundp (values 'standard-boundp-method - #'make-std-boundp-method-function - (list class-name) - (list class-name) - "automatically generated boundp method"))) + (reader (values 'standard-reader-method + #'make-std-reader-method-function + (list class-name) + (list class-name) + "automatically generated reader method")) + (writer (values 'standard-writer-method + #'make-std-writer-method-function + (list 'new-value class-name) + (list t class-name) + "automatically generated writer method")) + (boundp (values 'standard-boundp-method + #'make-std-boundp-method-function + (list class-name) + (list class-name) + "automatically generated boundp method"))) (let ((gf (ensure-generic-function accessor-name - :lambda-list arglist))) + :lambda-list arglist))) (if (find specls (early-gf-methods gf) - :key #'early-method-specializers - :test 'equal) - (unless (assoc accessor-name *!generic-function-fixups* - :test #'equal) - (update-dfun gf)) - (add-method gf - (make-a-method accessor-class - () - arglist specls - (funcall make-method-function - class-name slot-name) - doc - slot-name)))))) + :key #'early-method-specializers + :test 'equal) + (unless (assoc accessor-name *!generic-function-fixups* + :test #'equal) + (update-dfun gf)) + (add-method gf + (make-a-method accessor-class + () + arglist specls + (funcall make-method-function + class-name slot-name) + doc + slot-name)))))) (defun !bootstrap-accessor-definitions1 (class-name - slot-name - readers - writers - boundps) + slot-name + readers + writers + boundps) (flet ((do-reader-definition (reader) - (!bootstrap-accessor-definition class-name - reader - slot-name - 'reader)) - (do-writer-definition (writer) - (!bootstrap-accessor-definition class-name - writer - slot-name - 'writer)) - (do-boundp-definition (boundp) - (!bootstrap-accessor-definition class-name - boundp - slot-name - 'boundp))) + (!bootstrap-accessor-definition class-name + reader + slot-name + 'reader)) + (do-writer-definition (writer) + (!bootstrap-accessor-definition class-name + writer + slot-name + 'writer)) + (do-boundp-definition (boundp) + (!bootstrap-accessor-definition class-name + boundp + slot-name + 'boundp))) (dolist (reader readers) (do-reader-definition reader)) (dolist (writer writers) (do-writer-definition writer)) (dolist (boundp boundps) (do-boundp-definition boundp)))) @@ -479,9 +479,9 @@ (let ((*early-p* early-p)) (dolist (definition *early-class-definitions*) (let* ((name (ecd-class-name definition)) - (class (find-class name))) - (setf (find-class-predicate name) - (make-class-predicate class (class-predicate-name class))))))) + (class (find-class name))) + (setf (find-class-predicate name) + (make-class-predicate class (class-predicate-name class))))))) (defun !bootstrap-built-in-classes () @@ -492,41 +492,41 @@ (dolist (e *built-in-classes*) (dolist (super (cadr e)) (unless (or (eq super t) - (assq super *built-in-classes*)) - (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~ - but ~S is not itself a class in *BUILT-IN-CLASSES*." - (car e) super super)))) + (assq super *built-in-classes*)) + (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~ + but ~S is not itself a class in *BUILT-IN-CLASSES*." + (car e) super super)))) ;; In the first pass, we create a skeletal object to be bound to the ;; class name. (let* ((built-in-class (find-class 'built-in-class)) - (built-in-class-wrapper (class-wrapper built-in-class))) + (built-in-class-wrapper (class-wrapper built-in-class))) (dolist (e *built-in-classes*) (let ((class (allocate-standard-instance built-in-class-wrapper))) - (setf (find-class (car e)) class)))) + (setf (find-class (car e)) class)))) ;; In the second pass, we initialize the class objects. (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer)))) (dolist (e *built-in-classes*) (destructuring-bind (name supers subs cpl prototype) e - (let* ((class (find-class name)) - (lclass (find-classoid name)) - (wrapper (classoid-layout lclass))) - (set (get-built-in-class-symbol name) class) - (set (get-built-in-wrapper-symbol name) wrapper) - (setf (classoid-pcl-class lclass) class) - - (!bootstrap-initialize-class 'built-in-class class - name class-eq-wrapper nil - supers subs - (cons name cpl) - wrapper prototype))))) + (let* ((class (find-class name)) + (lclass (find-classoid name)) + (wrapper (classoid-layout lclass))) + (set (get-built-in-class-symbol name) class) + (set (get-built-in-wrapper-symbol name) wrapper) + (setf (classoid-pcl-class lclass) class) + + (!bootstrap-initialize-class 'built-in-class class + name class-eq-wrapper nil + supers subs + (cons name cpl) + wrapper prototype))))) (dolist (e *built-in-classes*) (let* ((name (car e)) - (class (find-class name))) + (class (find-class name))) (setf (find-class-predicate name) - (make-class-predicate class (class-predicate-name class)))))) + (make-class-predicate class (class-predicate-name class)))))) (defmacro wrapper-of-macro (x) `(layout-of ,x)) @@ -545,93 +545,93 @@ (defun ensure-non-standard-class (name &optional existing-class) (flet ((ensure (metaclass &optional (slots nil slotsp)) - (let ((supers - (mapcar #'classoid-name (classoid-direct-superclasses - (find-classoid name))))) - (if slotsp - (ensure-class-using-class existing-class name - :metaclass metaclass :name name - :direct-superclasses supers - :direct-slots slots) - (ensure-class-using-class existing-class name - :metaclass metaclass :name name - :direct-superclasses supers)))) + (let ((supers + (mapcar #'classoid-name (classoid-direct-superclasses + (find-classoid name))))) + (if slotsp + (ensure-class-using-class existing-class name + :metaclass metaclass :name name + :direct-superclasses supers + :direct-slots slots) + (ensure-class-using-class existing-class name + :metaclass metaclass :name name + :direct-superclasses supers)))) (slot-initargs-from-structure-slotd (slotd) - (let ((accessor (structure-slotd-accessor-symbol slotd))) - `(:name ,(structure-slotd-name slotd) - :defstruct-accessor-symbol ,accessor - ,@(when (fboundp accessor) - `(:internal-reader-function - ,(structure-slotd-reader-function slotd) - :internal-writer-function - ,(structure-slotd-writer-function name slotd))) - :type ,(or (structure-slotd-type slotd) t) - :initform ,(structure-slotd-init-form slotd) - :initfunction ,(eval-form (structure-slotd-init-form slotd))))) + (let ((accessor (structure-slotd-accessor-symbol slotd))) + `(:name ,(structure-slotd-name slotd) + :defstruct-accessor-symbol ,accessor + ,@(when (fboundp accessor) + `(:internal-reader-function + ,(structure-slotd-reader-function slotd) + :internal-writer-function + ,(structure-slotd-writer-function name slotd))) + :type ,(or (structure-slotd-type slotd) t) + :initform ,(structure-slotd-init-form slotd) + :initfunction ,(eval-form (structure-slotd-init-form slotd))))) (slot-initargs-from-condition-slot (slot) - `(:name ,(condition-slot-name slot) - :initargs ,(condition-slot-initargs slot) - :readers ,(condition-slot-readers slot) - :writers ,(condition-slot-writers slot) - ,@(when (condition-slot-initform-p slot) - (let ((form-or-fun (condition-slot-initform slot))) - (if (functionp form-or-fun) - `(:initfunction ,form-or-fun) - `(:initform ,form-or-fun - :initfunction ,(lambda () form-or-fun))))) - :allocation ,(condition-slot-allocation slot) - :documentation ,(condition-slot-documentation slot)))) + `(:name ,(condition-slot-name slot) + :initargs ,(condition-slot-initargs slot) + :readers ,(condition-slot-readers slot) + :writers ,(condition-slot-writers slot) + ,@(when (condition-slot-initform-p slot) + (let ((form-or-fun (condition-slot-initform slot))) + (if (functionp form-or-fun) + `(:initfunction ,form-or-fun) + `(:initform ,form-or-fun + :initfunction ,(lambda () form-or-fun))))) + :allocation ,(condition-slot-allocation slot) + :documentation ,(condition-slot-documentation slot)))) (cond ((structure-type-p name) - (ensure 'structure-class - (mapcar #'slot-initargs-from-structure-slotd - (structure-type-slot-description-list name)))) - ((condition-type-p name) - (ensure 'condition-class - (mapcar #'slot-initargs-from-condition-slot - (condition-classoid-slots (find-classoid name))))) - (t - (error "~@<~S is not the name of a class.~@:>" name))))) + (ensure 'structure-class + (mapcar #'slot-initargs-from-structure-slotd + (structure-type-slot-description-list name)))) + ((condition-type-p name) + (ensure 'condition-class + (mapcar #'slot-initargs-from-condition-slot + (condition-classoid-slots (find-classoid name))))) + (t + (error "~@<~S is not the name of a class.~@:>" name))))) (defun ensure-defstruct-class (classoid) (let ((class (classoid-pcl-class classoid))) (cond (class (ensure-non-standard-class (class-name class) class)) - ((eq 'complete *boot-state*) + ((eq 'complete *boot-state*) (ensure-non-standard-class (classoid-name classoid)))))) (pushnew 'ensure-defstruct-class sb-kernel::*defstruct-hooks*) (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name :lambda-list '(object))) - (mlist (if (eq *boot-state* 'complete) - (generic-function-methods gf) - (early-gf-methods gf)))) + (mlist (if (eq *boot-state* 'complete) + (generic-function-methods gf) + (early-gf-methods gf)))) (unless mlist (unless (eq class *the-class-t*) - (let* ((default-method-function #'constantly-nil) - (default-method-initargs (list :function - default-method-function)) - (default-method (make-a-method - 'standard-method - () - (list 'object) - (list *the-class-t*) - default-method-initargs - "class predicate default method"))) - (setf (method-function-get default-method-function :constant-value) - nil) - (add-method gf default-method))) + (let* ((default-method-function #'constantly-nil) + (default-method-initargs (list :function + default-method-function)) + (default-method (make-a-method + 'standard-method + () + (list 'object) + (list *the-class-t*) + default-method-initargs + "class predicate default method"))) + (setf (method-function-get default-method-function :constant-value) + nil) + (add-method gf default-method))) (let* ((class-method-function #'constantly-t) - (class-method-initargs (list :function - class-method-function)) - (class-method (make-a-method 'standard-method - () - (list 'object) - (list class) - class-method-initargs - "class predicate class method"))) - (setf (method-function-get class-method-function :constant-value) t) - (add-method gf class-method))) + (class-method-initargs (list :function + class-method-function)) + (class-method (make-a-method 'standard-method + () + (list 'object) + (list class) + class-method-initargs + "class predicate class method"))) + (setf (method-function-get class-method-function :constant-value) t) + (add-method gf class-method))) gf)) ;;; Set the inherits from CPL, and register the layout. This actually @@ -649,8 +649,8 @@ ;; unknown to CL:FIND-CLASS and also anonymous. This ;; functionality moved here from (SETF FIND-CLASS). (let ((name (class-name class))) - (setf (find-classoid name) lclass - (classoid-name lclass) name))))) + (setf (find-classoid name) lclass + (classoid-name lclass) name))))) (defun set-class-type-translation (class name) (let ((classoid (find-classoid name nil))) @@ -658,17 +658,17 @@ (null) (built-in-classoid (let ((translation (built-in-classoid-translation classoid))) - (cond - (translation - (aver (ctype-p translation)) - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) translation))) - (t - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) + (cond + (translation + (aver (ctype-p translation)) + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) translation))) + (t + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid)))))) (classoid (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) + (lambda (spec) (declare (ignore spec)) classoid)))))) (clrhash *find-class*) (!bootstrap-meta-braid) @@ -679,39 +679,39 @@ (!bootstrap-built-in-classes) (dohash (name x *find-class*) - (let* ((class (find-class-from-cell name x)) - (layout (class-wrapper class)) - (lclass (layout-classoid layout)) - (lclass-pcl-class (classoid-pcl-class lclass)) - (olclass (find-classoid name nil))) - (if lclass-pcl-class - (aver (eq class lclass-pcl-class)) - (setf (classoid-pcl-class lclass) class)) + (let* ((class (find-class-from-cell name x)) + (layout (class-wrapper class)) + (lclass (layout-classoid layout)) + (lclass-pcl-class (classoid-pcl-class lclass)) + (olclass (find-classoid name nil))) + (if lclass-pcl-class + (aver (eq class lclass-pcl-class)) + (setf (classoid-pcl-class lclass) class)) - (update-lisp-class-layout class layout) + (update-lisp-class-layout class layout) - (cond (olclass - (aver (eq lclass olclass))) - (t - (setf (find-classoid name) lclass))) + (cond (olclass + (aver (eq lclass olclass))) + (t + (setf (find-classoid name) lclass))) - (set-class-type-translation class name))) + (set-class-type-translation class name))) (setq *boot-state* 'braid) (defmethod no-applicable-method (generic-function &rest args) (error "~@" - generic-function - args)) + ~I~_when called with arguments ~2I~_~S.~:>" + generic-function + args)) (defmethod no-next-method ((generic-function standard-generic-function) - (method standard-method) &rest args) + (method standard-method) &rest args) (error "~@" - generic-function - method - args)) + ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>" + generic-function + method + args)) ;;; An extension to the ANSI standard: in the presence of e.g. a ;;; :BEFORE method, it would seem that going through @@ -719,19 +719,19 @@ ;;; applicable method. -- CSR, 2002-11-15 (defmethod no-primary-method (generic-function &rest args) (error "~@" - generic-function - args)) + ~I~_when called with arguments ~2I~_~S.~:>" + generic-function + args)) (defmethod invalid-qualifiers ((gf generic-function) - combin - method) + combin + method) (let ((qualifiers (method-qualifiers method))) (let ((why (cond - ((cdr qualifiers) "has too many qualifiers") - (t (aver (not (member (car qualifiers) - '(:around :before :after)))) - "has an invalid qualifier")))) + ((cdr qualifiers) "has too many qualifiers") + (t (aver (not (member (car qualifiers) + '(:around :before :after)))) + "has an invalid qualifier")))) (invalid-method-error method "The method ~S on ~S ~A.~%~ diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 7536f2a..5b19884 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -84,7 +84,7 @@ ;;; assembler. (defmacro cache-vector-ref (cache-vector location) `(svref (the simple-vector ,cache-vector) - (sb-ext:truly-the fixnum ,location))) + (sb-ext:truly-the fixnum ,location))) (defmacro cache-vector-size (cache-vector) `(array-dimension (the simple-vector ,cache-vector) 0)) @@ -106,10 +106,10 @@ (multiple-value-prog1 (progn ,@body) (let ((old-count (cache-vector-lock-count ,cache-vector))) - (declare (fixnum old-count)) - (setf (cache-vector-lock-count ,cache-vector) - (if (= old-count most-positive-fixnum) - 1 (the fixnum (1+ old-count)))))))) + (declare (fixnum old-count)) + (setf (cache-vector-lock-count ,cache-vector) + (if (= old-count most-positive-fixnum) + 1 (the fixnum (1+ old-count)))))))) (deftype field-type () '(mod #.layout-clos-hash-length)) @@ -124,7 +124,7 @@ (defconstant +nkeys-limit+ 256) (defstruct (cache (:constructor make-cache ()) - (:copier copy-cache-internal)) + (:copier copy-cache-internal)) (owner nil) (nkeys 1 :type (integer 1 #.+nkeys-limit+)) (valuep nil :type (member nil t)) @@ -148,7 +148,7 @@ ;;; ever return a larger cache. (defun get-cache-vector (size) (flush-cache-vector-internal (make-array size))) - + ;;;; wrapper cache numbers @@ -219,16 +219,16 @@ (cond (found (unless (classoid-pcl-class found) - (setf (classoid-pcl-class found) class)) + (setf (classoid-pcl-class found) class)) (aver (eq (classoid-pcl-class found) class)) (let ((layout (classoid-layout found))) - (aver layout) - layout)) + (aver layout) + layout)) (t (make-wrapper-internal :length length :classoid (make-standard-classoid - :name name :pcl-class class)))))) + :name name :pcl-class class)))))) ;;; The following variable may be set to a STANDARD-CLASS that has ;;; already been created by the lisp code and which is to be redefined @@ -243,32 +243,32 @@ (defun make-wrapper (length class) (cond ((or (typep class 'std-class) - (typep class 'forward-referenced-class)) + (typep class 'forward-referenced-class)) (make-wrapper-internal :length length :classoid (let ((owrap (class-wrapper class))) - (cond (owrap - (layout-classoid owrap)) - ((or (*subtypep (class-of class) *the-class-standard-class*) - (typep class 'forward-referenced-class)) - (cond ((and *pcl-class-boot* - (eq (slot-value class 'name) *pcl-class-boot*)) - (let ((found (find-classoid - (slot-value class 'name)))) - (unless (classoid-pcl-class found) - (setf (classoid-pcl-class found) class)) - (aver (eq (classoid-pcl-class found) class)) - found)) - (t - (make-standard-classoid :pcl-class class)))) - (t - (make-random-pcl-classoid :pcl-class class)))))) + (cond (owrap + (layout-classoid owrap)) + ((or (*subtypep (class-of class) *the-class-standard-class*) + (typep class 'forward-referenced-class)) + (cond ((and *pcl-class-boot* + (eq (slot-value class 'name) *pcl-class-boot*)) + (let ((found (find-classoid + (slot-value class 'name)))) + (unless (classoid-pcl-class found) + (setf (classoid-pcl-class found) class)) + (aver (eq (classoid-pcl-class found) class)) + found)) + (t + (make-standard-classoid :pcl-class class)))) + (t + (make-random-pcl-classoid :pcl-class class)))))) (t (let* ((found (find-classoid (slot-value class 'name))) - (layout (classoid-layout found))) + (layout (classoid-layout found))) (unless (classoid-pcl-class found) - (setf (classoid-pcl-class found) class)) + (setf (classoid-pcl-class found) class)) (aver (eq (classoid-pcl-class found) class)) (aver layout) layout)))) @@ -337,23 +337,23 @@ ;; corresponds to a kind of transitivity of wrapper updates. (dolist (previous (gethash owrapper *previous-nwrappers*)) (when (eq state :obsolete) - (setf (car previous) :obsolete)) + (setf (car previous) :obsolete)) (setf (cadr previous) nwrapper) (push previous new-previous)) (let ((ocnv (wrapper-cache-number-vector owrapper))) (dotimes (i layout-clos-hash-length) - (setf (cache-number-vector-ref ocnv i) 0))) + (setf (cache-number-vector-ref ocnv i) 0))) (push (setf (layout-invalid owrapper) (list state nwrapper)) - new-previous) + new-previous) (setf (gethash owrapper *previous-nwrappers*) () - (gethash nwrapper *previous-nwrappers*) new-previous))) + (gethash nwrapper *previous-nwrappers*) new-previous))) (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) - (state (layout-invalid owrapper))) + (state (layout-invalid owrapper))) (aver (not (eq state :uninitialized))) (etypecase state (null owrapper) @@ -372,10 +372,10 @@ (check-wrapper-validity instance)) (cons (ecase (car state) - (:flush - (flush-cache-trap owrapper (cadr state) instance)) - (:obsolete - (obsolete-instance-trap owrapper (cadr state) instance))))))) + (:flush + (flush-cache-trap owrapper (cadr state) instance)) + (:obsolete + (obsolete-instance-trap owrapper (cadr state) instance))))))) (declaim (inline check-obsolete-instance)) (defun check-obsolete-instance (instance) @@ -387,56 +387,56 @@ (let ((cache (make-cache))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) - (compute-cache-parameters nkeys valuep nlines) + (compute-cache-parameters nkeys valuep nlines) (setf (cache-nkeys cache) nkeys - (cache-valuep cache) valuep - (cache-nlines cache) nlines - (cache-field cache) +first-wrapper-cache-number-index+ - (cache-limit-fn cache) limit-fn - (cache-mask cache) cache-mask - (cache-size cache) actual-size - (cache-line-size cache) line-size - (cache-max-location cache) (let ((line (1- nlines))) - (if (= nkeys 1) - (* line line-size) - (1+ (* line line-size)))) - (cache-vector cache) (get-cache-vector actual-size) - (cache-overflow cache) nil) + (cache-valuep cache) valuep + (cache-nlines cache) nlines + (cache-field cache) +first-wrapper-cache-number-index+ + (cache-limit-fn cache) limit-fn + (cache-mask cache) cache-mask + (cache-size cache) actual-size + (cache-line-size cache) line-size + (cache-max-location cache) (let ((line (1- nlines))) + (if (= nkeys 1) + (* line line-size) + (1+ (* line line-size)))) + (cache-vector cache) (get-cache-vector actual-size) + (cache-overflow cache) nil) cache))) (defun get-cache-from-cache (old-cache new-nlines - &optional (new-field +first-wrapper-cache-number-index+)) + &optional (new-field +first-wrapper-cache-number-index+)) (let ((nkeys (cache-nkeys old-cache)) - (valuep (cache-valuep old-cache)) - (cache (make-cache))) + (valuep (cache-valuep old-cache)) + (cache (make-cache))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) - (if (= new-nlines (cache-nlines old-cache)) - (values (cache-mask old-cache) (cache-size old-cache) - (cache-line-size old-cache) (cache-nlines old-cache)) - (compute-cache-parameters nkeys valuep new-nlines)) + (if (= new-nlines (cache-nlines old-cache)) + (values (cache-mask old-cache) (cache-size old-cache) + (cache-line-size old-cache) (cache-nlines old-cache)) + (compute-cache-parameters nkeys valuep new-nlines)) (setf (cache-owner cache) (cache-owner old-cache) - (cache-nkeys cache) nkeys - (cache-valuep cache) valuep - (cache-nlines cache) nlines - (cache-field cache) new-field - (cache-limit-fn cache) (cache-limit-fn old-cache) - (cache-mask cache) cache-mask - (cache-size cache) actual-size - (cache-line-size cache) line-size - (cache-max-location cache) (let ((line (1- nlines))) - (if (= nkeys 1) - (* line line-size) - (1+ (* line line-size)))) - (cache-vector cache) (get-cache-vector actual-size) - (cache-overflow cache) nil) + (cache-nkeys cache) nkeys + (cache-valuep cache) valuep + (cache-nlines cache) nlines + (cache-field cache) new-field + (cache-limit-fn cache) (cache-limit-fn old-cache) + (cache-mask cache) cache-mask + (cache-size cache) actual-size + (cache-line-size cache) line-size + (cache-max-location cache) (let ((line (1- nlines))) + (if (= nkeys 1) + (* line line-size) + (1+ (* line line-size)))) + (cache-vector cache) (get-cache-vector actual-size) + (cache-overflow cache) nil) cache))) (defun copy-cache (old-cache) (let* ((new-cache (copy-cache-internal old-cache)) - (size (cache-size old-cache)) - (old-vector (cache-vector old-cache)) - (new-vector (get-cache-vector size))) + (size (cache-size old-cache)) + (old-vector (cache-vector old-cache)) + (new-vector (get-cache-vector size))) (declare (simple-vector old-vector new-vector)) (dotimes-fixnum (i size) (setf (svref new-vector i) (svref old-vector i))) @@ -451,31 +451,31 @@ (declare (fixnum nkeys)) (if (= nkeys 1) (let* ((line-size (if valuep 2 1)) - (cache-size (if (typep nlines-or-cache-vector 'fixnum) - (the fixnum - (* line-size - (the fixnum - (power-of-two-ceiling - nlines-or-cache-vector)))) - (cache-vector-size nlines-or-cache-vector)))) - (declare (fixnum line-size cache-size)) - (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) - cache-size - line-size - (the (values fixnum t) (floor cache-size line-size)))) + (cache-size (if (typep nlines-or-cache-vector 'fixnum) + (the fixnum + (* line-size + (the fixnum + (power-of-two-ceiling + nlines-or-cache-vector)))) + (cache-vector-size nlines-or-cache-vector)))) + (declare (fixnum line-size cache-size)) + (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) + cache-size + line-size + (the (values fixnum t) (floor cache-size line-size)))) (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) - (cache-size (if (typep nlines-or-cache-vector 'fixnum) - (the fixnum - (* line-size - (the fixnum - (power-of-two-ceiling - nlines-or-cache-vector)))) - (1- (cache-vector-size nlines-or-cache-vector))))) - (declare (fixnum line-size cache-size)) - (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) - (the fixnum (1+ cache-size)) - line-size - (the (values fixnum t) (floor cache-size line-size)))))) + (cache-size (if (typep nlines-or-cache-vector 'fixnum) + (the fixnum + (* line-size + (the fixnum + (power-of-two-ceiling + nlines-or-cache-vector)))) + (1- (cache-vector-size nlines-or-cache-vector))))) + (declare (fixnum line-size cache-size)) + (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) + (the fixnum (1+ cache-size)) + line-size + (the (values fixnum t) (floor cache-size line-size)))))) ;;; the various implementations of computing a primary cache location from ;;; wrappers. Because some implementations of this must run fast there are @@ -494,26 +494,26 @@ (declare (type field-type field) (fixnum mask)) (if (not (listp wrappers)) (logand mask - (the fixnum (wrapper-cache-number-vector-ref wrappers field))) + (the fixnum (wrapper-cache-number-vector-ref wrappers field))) (let ((location 0) (i 0)) - (declare (fixnum location i)) - (dolist (wrapper wrappers) - ;; First add the cache number of this wrapper to location. - (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper - field))) - (declare (fixnum wrapper-cache-number)) - (if (zerop wrapper-cache-number) - (return-from compute-primary-cache-location 0) - (setq location - (the fixnum (+ location wrapper-cache-number))))) - ;; Then, if we are working with lots of wrappers, deal with - ;; the wrapper-cache-number-mask stuff. - (when (and (not (zerop i)) - (zerop (mod i wrapper-cache-number-adds-ok))) - (setq location - (logand location wrapper-cache-number-mask))) - (incf i)) - (the fixnum (1+ (logand mask location)))))) + (declare (fixnum location i)) + (dolist (wrapper wrappers) + ;; First add the cache number of this wrapper to location. + (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper + field))) + (declare (fixnum wrapper-cache-number)) + (if (zerop wrapper-cache-number) + (return-from compute-primary-cache-location 0) + (setq location + (the fixnum (+ location wrapper-cache-number))))) + ;; Then, if we are working with lots of wrappers, deal with + ;; the wrapper-cache-number-mask stuff. + (when (and (not (zerop i)) + (zerop (mod i wrapper-cache-number-adds-ok))) + (setq location + (logand location wrapper-cache-number-mask))) + (incf i)) + (the fixnum (1+ (logand mask location)))))) ;;; This version is called on a cache line. It fetches the wrappers ;;; from the cache line and determines the primary location. Various @@ -524,123 +524,123 @@ ;;; symbol invalid to suggest to its caller that it would be provident ;;; to blow away the cache line in question. (defun compute-primary-cache-location-from-location (to-cache - from-location - &optional - (from-cache to-cache)) + from-location + &optional + (from-cache to-cache)) (declare (type cache to-cache from-cache) (fixnum from-location)) (let ((result 0) - (cache-vector (cache-vector from-cache)) - (field (cache-field to-cache)) - (mask (cache-mask to-cache)) - (nkeys (cache-nkeys to-cache))) + (cache-vector (cache-vector from-cache)) + (field (cache-field to-cache)) + (mask (cache-mask to-cache)) + (nkeys (cache-nkeys to-cache))) (declare (type field-type field) (fixnum result mask nkeys) - (simple-vector cache-vector)) + (simple-vector cache-vector)) (dotimes-fixnum (i nkeys) (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) - (wcn (wrapper-cache-number-vector-ref wrapper field))) - (declare (fixnum wcn)) - (setq result (+ result wcn))) + (wcn (wrapper-cache-number-vector-ref wrapper field))) + (declare (fixnum wcn)) + (setq result (+ result wcn))) (when (and (not (zerop i)) - (zerop (mod i wrapper-cache-number-adds-ok))) - (setq result (logand result wrapper-cache-number-mask)))) + (zerop (mod i wrapper-cache-number-adds-ok))) + (setq result (logand result wrapper-cache-number-mask)))) (if (= nkeys 1) - (logand mask result) - (the fixnum (1+ (logand mask result)))))) + (logand mask result) + (the fixnum (1+ (logand mask result)))))) -;;; NIL means nothing so far, no actual arg info has NILs -;;; in the metatype -;;; CLASS seen all sorts of metaclasses -;;; (specifically, more than one of the next 4 values) -;;; T means everything so far is the class T +;;; NIL means nothing so far, no actual arg info has NILs +;;; in the metatype +;;; CLASS seen all sorts of metaclasses +;;; (specifically, more than one of the next 4 values) +;;; T means everything so far is the class T ;;; STANDARD-CLASS seen only standard classes ;;; BUILT-IN-CLASS seen only built in classes ;;; STRUCTURE-CLASS seen only structure classes (defun raise-metatype (metatype new-specializer) (let ((slot (find-class 'slot-class)) - (std (find-class 'std-class)) - (standard (find-class 'standard-class)) - (fsc (find-class 'funcallable-standard-class)) - (condition (find-class 'condition-class)) - (structure (find-class 'structure-class)) - (built-in (find-class 'built-in-class))) + (std (find-class 'std-class)) + (standard (find-class 'standard-class)) + (fsc (find-class 'funcallable-standard-class)) + (condition (find-class 'condition-class)) + (structure (find-class 'structure-class)) + (built-in (find-class 'built-in-class))) (flet ((specializer->metatype (x) - (let ((meta-specializer - (if (eq *boot-state* 'complete) - (class-of (specializer-class x)) - (class-of x)))) - (cond - ((eq x *the-class-t*) t) - ((*subtypep meta-specializer std) 'standard-instance) - ((*subtypep meta-specializer standard) 'standard-instance) - ((*subtypep meta-specializer fsc) 'standard-instance) - ((*subtypep meta-specializer condition) 'condition-instance) - ((*subtypep meta-specializer structure) 'structure-instance) - ((*subtypep meta-specializer built-in) 'built-in-instance) - ((*subtypep meta-specializer slot) 'slot-instance) - (t (error "~@" - new-specializer - meta-specializer)))))) + new-specializer + meta-specializer)))))) ;; We implement the following table. The notation is ;; that X and Y are distinct meta specializer names. ;; ;; NIL ===> - ;; X X ===> X - ;; X Y ===> CLASS + ;; X X ===> X + ;; X Y ===> CLASS (let ((new-metatype (specializer->metatype new-specializer))) - (cond ((eq new-metatype 'slot-instance) 'class) - ((null metatype) new-metatype) - ((eq metatype new-metatype) new-metatype) - (t 'class)))))) + (cond ((eq new-metatype 'slot-instance) 'class) + ((null metatype) new-metatype) + ((eq metatype new-metatype) new-metatype) + (t 'class)))))) (defmacro with-dfun-wrappers ((args metatypes) - (dfun-wrappers invalid-wrapper-p - &optional wrappers classes types) - invalid-arguments-form - &body body) + (dfun-wrappers invalid-wrapper-p + &optional wrappers classes types) + invalid-arguments-form + &body body) `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil) - (,dfun-wrappers nil) (dfun-wrappers-tail nil) - ,@(when wrappers - `((wrappers-rev nil) (types-rev nil) (classes-rev nil)))) + (,dfun-wrappers nil) (dfun-wrappers-tail nil) + ,@(when wrappers + `((wrappers-rev nil) (types-rev nil) (classes-rev nil)))) (dolist (mt ,metatypes) (unless args-tail - (setq invalid-arguments-p t) - (return nil)) + (setq invalid-arguments-p t) + (return nil)) (let* ((arg (pop args-tail)) - (wrapper nil) - ,@(when wrappers - `((class *the-class-t*) - (type t)))) - (unless (eq mt t) - (setq wrapper (wrapper-of arg)) - (when (invalid-wrapper-p wrapper) - (setq ,invalid-wrapper-p t) - (setq wrapper (check-wrapper-validity arg))) - (cond ((null ,dfun-wrappers) - (setq ,dfun-wrappers wrapper)) - ((not (consp ,dfun-wrappers)) - (setq dfun-wrappers-tail (list wrapper)) - (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail))) - (t - (let ((new-dfun-wrappers-tail (list wrapper))) - (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) - (setf dfun-wrappers-tail new-dfun-wrappers-tail)))) - ,@(when wrappers - `((setq class (wrapper-class* wrapper)) - (setq type `(class-eq ,class))))) - ,@(when wrappers - `((push wrapper wrappers-rev) - (push class classes-rev) - (push type types-rev))))) + (wrapper nil) + ,@(when wrappers + `((class *the-class-t*) + (type t)))) + (unless (eq mt t) + (setq wrapper (wrapper-of arg)) + (when (invalid-wrapper-p wrapper) + (setq ,invalid-wrapper-p t) + (setq wrapper (check-wrapper-validity arg))) + (cond ((null ,dfun-wrappers) + (setq ,dfun-wrappers wrapper)) + ((not (consp ,dfun-wrappers)) + (setq dfun-wrappers-tail (list wrapper)) + (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail))) + (t + (let ((new-dfun-wrappers-tail (list wrapper))) + (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) + (setf dfun-wrappers-tail new-dfun-wrappers-tail)))) + ,@(when wrappers + `((setq class (wrapper-class* wrapper)) + (setq type `(class-eq ,class))))) + ,@(when wrappers + `((push wrapper wrappers-rev) + (push class classes-rev) + (push type types-rev))))) (if invalid-arguments-p - ,invalid-arguments-form - (let* (,@(when wrappers - `((,wrappers (nreverse wrappers-rev)) - (,classes (nreverse classes-rev)) - (,types (mapcar (lambda (class) - `(class-eq ,class)) - ,classes))))) - ,@body)))) + ,invalid-arguments-form + (let* (,@(when wrappers + `((,wrappers (nreverse wrappers-rev)) + (,classes (nreverse classes-rev)) + (,types (mapcar (lambda (class) + `(class-eq ,class)) + ,classes))))) + ,@body)))) ;;;; some support stuff for getting a hold of symbols that we need when ;;;; building the discriminator codes. It's OK for these to be interned @@ -703,8 +703,8 @@ (push (dfun-arg-symbol i) required)) (nreverse required)))) `(,(if (eq emf-type 'fast-method-call) - 'invoke-effective-method-function-fast - 'invoke-effective-method-function) + 'invoke-effective-method-function-fast + 'invoke-effective-method-function) ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) (defun make-fast-method-call-lambda-list (metatypes applyp) @@ -721,202 +721,202 @@ `(let ((.cache. ,cache)) (declare (type cache .cache.)) (labels ((cache () .cache.) - (nkeys () (cache-nkeys .cache.)) - (line-size () (cache-line-size .cache.)) - (vector () (cache-vector .cache.)) - (valuep () (cache-valuep .cache.)) - (nlines () (cache-nlines .cache.)) - (max-location () (cache-max-location .cache.)) - (limit-fn () (cache-limit-fn .cache.)) - (size () (cache-size .cache.)) - (mask () (cache-mask .cache.)) - (field () (cache-field .cache.)) - (overflow () (cache-overflow .cache.)) - ;; - ;; Return T IFF this cache location is reserved. The - ;; only time this is true is for line number 0 of an - ;; nkeys=1 cache. - ;; - (line-reserved-p (line) - (declare (fixnum line)) - (and (= (nkeys) 1) - (= line 0))) - ;; - (location-reserved-p (location) - (declare (fixnum location)) - (and (= (nkeys) 1) - (= location 0))) - ;; - ;; Given a line number, return the cache location. - ;; This is the value that is the second argument to - ;; cache-vector-ref. Basically, this deals with the - ;; offset of nkeys>1 caches and multiplies by line - ;; size. - ;; - (line-location (line) - (declare (fixnum line)) - (when (line-reserved-p line) - (error "line is reserved")) - (if (= (nkeys) 1) - (the fixnum (* line (line-size))) - (the fixnum (1+ (the fixnum (* line (line-size))))))) - ;; - ;; Given a cache location, return the line. This is - ;; the inverse of LINE-LOCATION. - ;; - (location-line (location) - (declare (fixnum location)) - (if (= (nkeys) 1) - (floor location (line-size)) - (floor (the fixnum (1- location)) (line-size)))) - ;; - ;; Given a line number, return the wrappers stored at - ;; that line. As usual, if nkeys=1, this returns a - ;; single value. Only when nkeys>1 does it return a - ;; list. An error is signalled if the line is - ;; reserved. - ;; - (line-wrappers (line) - (declare (fixnum line)) - (when (line-reserved-p line) (error "Line is reserved.")) - (location-wrappers (line-location line))) - ;; - (location-wrappers (location) ; avoid multiplies caused by line-location - (declare (fixnum location)) - (if (= (nkeys) 1) - (cache-vector-ref (vector) location) - (let ((list (make-list (nkeys))) - (vector (vector))) - (declare (simple-vector vector)) - (dotimes (i (nkeys) list) - (declare (fixnum i)) - (setf (nth i list) - (cache-vector-ref vector (+ location i))))))) - ;; - ;; Given a line number, return true IFF the line's - ;; wrappers are the same as wrappers. - ;; - (line-matches-wrappers-p (line wrappers) - (declare (fixnum line)) - (and (not (line-reserved-p line)) - (location-matches-wrappers-p (line-location line) - wrappers))) - ;; - (location-matches-wrappers-p (loc wrappers) ; must not be reserved - (declare (fixnum loc)) - (let ((cache-vector (vector))) - (declare (simple-vector cache-vector)) - (if (= (nkeys) 1) - (eq wrappers (cache-vector-ref cache-vector loc)) - (dotimes (i (nkeys) t) - (declare (fixnum i)) - (unless (eq (pop wrappers) - (cache-vector-ref cache-vector (+ loc i))) - (return nil)))))) - ;; - ;; Given a line number, return the value stored at that line. - ;; If valuep is NIL, this returns NIL. As with line-wrappers, - ;; an error is signalled if the line is reserved. - ;; - (line-value (line) - (declare (fixnum line)) - (when (line-reserved-p line) (error "Line is reserved.")) - (location-value (line-location line))) - ;; - (location-value (loc) - (declare (fixnum loc)) - (and (valuep) - (cache-vector-ref (vector) (+ loc (nkeys))))) - ;; - ;; Given a line number, return true IFF that line has data in - ;; it. The state of the wrappers stored in the line is not - ;; checked. An error is signalled if line is reserved. - (line-full-p (line) - (when (line-reserved-p line) (error "Line is reserved.")) - (not (null (cache-vector-ref (vector) (line-location line))))) - ;; - ;; Given a line number, return true IFF the line is full and - ;; there are no invalid wrappers in the line, and the line's - ;; wrappers are different from wrappers. - ;; An error is signalled if the line is reserved. - ;; - (line-valid-p (line wrappers) - (declare (fixnum line)) - (when (line-reserved-p line) (error "Line is reserved.")) - (location-valid-p (line-location line) wrappers)) - ;; - (location-valid-p (loc wrappers) - (declare (fixnum loc)) - (let ((cache-vector (vector)) - (wrappers-mismatch-p (null wrappers))) - (declare (simple-vector cache-vector)) - (dotimes (i (nkeys) wrappers-mismatch-p) - (declare (fixnum i)) - (let ((wrapper (cache-vector-ref cache-vector (+ loc i)))) - (when (or (null wrapper) - (invalid-wrapper-p wrapper)) - (return nil)) - (unless (and wrappers - (eq wrapper - (if (consp wrappers) - (pop wrappers) - wrappers))) - (setq wrappers-mismatch-p t)))))) - ;; - ;; How many unreserved lines separate line-1 and line-2. - ;; - (line-separation (line-1 line-2) - (declare (fixnum line-1 line-2)) - (let ((diff (the fixnum (- line-2 line-1)))) - (declare (fixnum diff)) - (when (minusp diff) - (setq diff (+ diff (nlines))) - (when (line-reserved-p 0) - (setq diff (1- diff)))) - diff)) - ;; - ;; Given a cache line, get the next cache line. This will not - ;; return a reserved line. - ;; - (next-line (line) - (declare (fixnum line)) - (if (= line (the fixnum (1- (nlines)))) - (if (line-reserved-p 0) 1 0) - (the fixnum (1+ line)))) - ;; - (next-location (loc) - (declare (fixnum loc)) - (if (= loc (max-location)) - (if (= (nkeys) 1) - (line-size) - 1) - (the fixnum (+ loc (line-size))))) - ;; - ;; Given a line which has a valid entry in it, this - ;; will return the primary cache line of the wrappers - ;; in that line. We just call - ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this - ;; is an easier packaging up of the call to it. - ;; - (line-primary (line) - (declare (fixnum line)) - (location-line (line-primary-location line))) - ;; - (line-primary-location (line) - (declare (fixnum line)) - (compute-primary-cache-location-from-location - (cache) (line-location line)))) + (nkeys () (cache-nkeys .cache.)) + (line-size () (cache-line-size .cache.)) + (vector () (cache-vector .cache.)) + (valuep () (cache-valuep .cache.)) + (nlines () (cache-nlines .cache.)) + (max-location () (cache-max-location .cache.)) + (limit-fn () (cache-limit-fn .cache.)) + (size () (cache-size .cache.)) + (mask () (cache-mask .cache.)) + (field () (cache-field .cache.)) + (overflow () (cache-overflow .cache.)) + ;; + ;; Return T IFF this cache location is reserved. The + ;; only time this is true is for line number 0 of an + ;; nkeys=1 cache. + ;; + (line-reserved-p (line) + (declare (fixnum line)) + (and (= (nkeys) 1) + (= line 0))) + ;; + (location-reserved-p (location) + (declare (fixnum location)) + (and (= (nkeys) 1) + (= location 0))) + ;; + ;; Given a line number, return the cache location. + ;; This is the value that is the second argument to + ;; cache-vector-ref. Basically, this deals with the + ;; offset of nkeys>1 caches and multiplies by line + ;; size. + ;; + (line-location (line) + (declare (fixnum line)) + (when (line-reserved-p line) + (error "line is reserved")) + (if (= (nkeys) 1) + (the fixnum (* line (line-size))) + (the fixnum (1+ (the fixnum (* line (line-size))))))) + ;; + ;; Given a cache location, return the line. This is + ;; the inverse of LINE-LOCATION. + ;; + (location-line (location) + (declare (fixnum location)) + (if (= (nkeys) 1) + (floor location (line-size)) + (floor (the fixnum (1- location)) (line-size)))) + ;; + ;; Given a line number, return the wrappers stored at + ;; that line. As usual, if nkeys=1, this returns a + ;; single value. Only when nkeys>1 does it return a + ;; list. An error is signalled if the line is + ;; reserved. + ;; + (line-wrappers (line) + (declare (fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-wrappers (line-location line))) + ;; + (location-wrappers (location) ; avoid multiplies caused by line-location + (declare (fixnum location)) + (if (= (nkeys) 1) + (cache-vector-ref (vector) location) + (let ((list (make-list (nkeys))) + (vector (vector))) + (declare (simple-vector vector)) + (dotimes (i (nkeys) list) + (declare (fixnum i)) + (setf (nth i list) + (cache-vector-ref vector (+ location i))))))) + ;; + ;; Given a line number, return true IFF the line's + ;; wrappers are the same as wrappers. + ;; + (line-matches-wrappers-p (line wrappers) + (declare (fixnum line)) + (and (not (line-reserved-p line)) + (location-matches-wrappers-p (line-location line) + wrappers))) + ;; + (location-matches-wrappers-p (loc wrappers) ; must not be reserved + (declare (fixnum loc)) + (let ((cache-vector (vector))) + (declare (simple-vector cache-vector)) + (if (= (nkeys) 1) + (eq wrappers (cache-vector-ref cache-vector loc)) + (dotimes (i (nkeys) t) + (declare (fixnum i)) + (unless (eq (pop wrappers) + (cache-vector-ref cache-vector (+ loc i))) + (return nil)))))) + ;; + ;; Given a line number, return the value stored at that line. + ;; If valuep is NIL, this returns NIL. As with line-wrappers, + ;; an error is signalled if the line is reserved. + ;; + (line-value (line) + (declare (fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-value (line-location line))) + ;; + (location-value (loc) + (declare (fixnum loc)) + (and (valuep) + (cache-vector-ref (vector) (+ loc (nkeys))))) + ;; + ;; Given a line number, return true IFF that line has data in + ;; it. The state of the wrappers stored in the line is not + ;; checked. An error is signalled if line is reserved. + (line-full-p (line) + (when (line-reserved-p line) (error "Line is reserved.")) + (not (null (cache-vector-ref (vector) (line-location line))))) + ;; + ;; Given a line number, return true IFF the line is full and + ;; there are no invalid wrappers in the line, and the line's + ;; wrappers are different from wrappers. + ;; An error is signalled if the line is reserved. + ;; + (line-valid-p (line wrappers) + (declare (fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-valid-p (line-location line) wrappers)) + ;; + (location-valid-p (loc wrappers) + (declare (fixnum loc)) + (let ((cache-vector (vector)) + (wrappers-mismatch-p (null wrappers))) + (declare (simple-vector cache-vector)) + (dotimes (i (nkeys) wrappers-mismatch-p) + (declare (fixnum i)) + (let ((wrapper (cache-vector-ref cache-vector (+ loc i)))) + (when (or (null wrapper) + (invalid-wrapper-p wrapper)) + (return nil)) + (unless (and wrappers + (eq wrapper + (if (consp wrappers) + (pop wrappers) + wrappers))) + (setq wrappers-mismatch-p t)))))) + ;; + ;; How many unreserved lines separate line-1 and line-2. + ;; + (line-separation (line-1 line-2) + (declare (fixnum line-1 line-2)) + (let ((diff (the fixnum (- line-2 line-1)))) + (declare (fixnum diff)) + (when (minusp diff) + (setq diff (+ diff (nlines))) + (when (line-reserved-p 0) + (setq diff (1- diff)))) + diff)) + ;; + ;; Given a cache line, get the next cache line. This will not + ;; return a reserved line. + ;; + (next-line (line) + (declare (fixnum line)) + (if (= line (the fixnum (1- (nlines)))) + (if (line-reserved-p 0) 1 0) + (the fixnum (1+ line)))) + ;; + (next-location (loc) + (declare (fixnum loc)) + (if (= loc (max-location)) + (if (= (nkeys) 1) + (line-size) + 1) + (the fixnum (+ loc (line-size))))) + ;; + ;; Given a line which has a valid entry in it, this + ;; will return the primary cache line of the wrappers + ;; in that line. We just call + ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this + ;; is an easier packaging up of the call to it. + ;; + (line-primary (line) + (declare (fixnum line)) + (location-line (line-primary-location line))) + ;; + (line-primary-location (line) + (declare (fixnum line)) + (compute-primary-cache-location-from-location + (cache) (line-location line)))) (declare (ignorable #'cache #'nkeys #'line-size #'vector #'valuep - #'nlines #'max-location #'limit-fn #'size - #'mask #'field #'overflow #'line-reserved-p - #'location-reserved-p #'line-location - #'location-line #'line-wrappers #'location-wrappers - #'line-matches-wrappers-p - #'location-matches-wrappers-p - #'line-value #'location-value #'line-full-p - #'line-valid-p #'location-valid-p - #'line-separation #'next-line #'next-location - #'line-primary #'line-primary-location)) + #'nlines #'max-location #'limit-fn #'size + #'mask #'field #'overflow #'line-reserved-p + #'location-reserved-p #'line-location + #'location-line #'line-wrappers #'location-wrappers + #'line-matches-wrappers-p + #'location-matches-wrappers-p + #'line-value #'location-value #'line-full-p + #'line-valid-p #'location-valid-p + #'line-separation #'next-line #'next-location + #'line-primary #'line-primary-location)) ,@body))) ;;; Here is where we actually fill, recache and expand caches. @@ -942,10 +942,10 @@ (or (fill-cache-p nil cache wrappers value) (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*)) - (if (= (cache-nkeys cache) 1) - (1- (cache-nlines cache)) - (cache-nlines cache))) - (adjust-cache cache wrappers value)) + (if (= (cache-nkeys cache) 1) + (1- (cache-nlines cache)) + (cache-nlines cache))) + (adjust-cache cache wrappers value)) (expand-cache cache wrappers value))) (defvar *check-cache-p* nil) @@ -959,21 +959,21 @@ (defun check-cache (cache) (with-local-cache-functions (cache) (let ((location (if (= (nkeys) 1) 0 1)) - (limit (funcall (limit-fn) (nlines)))) + (limit (funcall (limit-fn) (nlines)))) (dotimes-fixnum (i (nlines) cache) - (when (and (not (location-reserved-p location)) - (line-full-p i)) - (let* ((home-loc (compute-primary-cache-location-from-location - cache location)) - (home (location-line (if (location-reserved-p home-loc) - (next-location home-loc) - home-loc))) - (sep (when home (line-separation home i)))) - (when (and sep (> sep limit)) - (error "bad cache ~S ~@ - value at location ~W: ~W lines from its home. The limit is ~W." - cache location sep limit)))) - (setq location (next-location location)))))) + (when (and (not (location-reserved-p location)) + (line-full-p i)) + (let* ((home-loc (compute-primary-cache-location-from-location + cache location)) + (home (location-line (if (location-reserved-p home-loc) + (next-location home-loc) + home-loc))) + (sep (when home (line-separation home i)))) + (when (and sep (> sep limit)) + (error "bad cache ~S ~@ + value at location ~W: ~W lines from its home. The limit is ~W." + cache location sep limit)))) + (setq location (next-location location)))))) (defun probe-cache (cache wrappers &optional default limit-fn) ;;(declare (values value)) @@ -983,34 +983,34 @@ (error "WRAPPERS arg is NIL!")) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) - (limit (funcall (or limit-fn (limit-fn)) (nlines)))) + (limit (funcall (or limit-fn (limit-fn)) (nlines)))) (declare (fixnum location limit)) (when (location-reserved-p location) - (setq location (next-location location))) + (setq location (next-location location))) (dotimes-fixnum (i (1+ limit)) - (when (location-matches-wrappers-p location wrappers) - (return-from probe-cache (or (not (valuep)) - (location-value location)))) - (setq location (next-location location))) + (when (location-matches-wrappers-p location wrappers) + (return-from probe-cache (or (not (valuep)) + (location-value location)))) + (setq location (next-location location))) (dolist (entry (overflow)) - (when (equal (car entry) wrappers) - (return-from probe-cache (or (not (valuep)) - (cdr entry))))) + (when (equal (car entry) wrappers) + (return-from probe-cache (or (not (valuep)) + (cdr entry))))) default))) (defun map-cache (function cache &optional set-p) (with-local-cache-functions (cache) (let ((set-p (and set-p (valuep)))) (dotimes-fixnum (i (nlines) cache) - (unless (or (line-reserved-p i) (not (line-valid-p i nil))) - (let ((value (funcall function (line-wrappers i) (line-value i)))) - (when set-p - (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys))) - value))))) + (unless (or (line-reserved-p i) (not (line-valid-p i nil))) + (let ((value (funcall function (line-wrappers i) (line-value i)))) + (when set-p + (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys))) + value))))) (dolist (entry (overflow)) - (let ((value (funcall function (car entry) (cdr entry)))) - (when set-p - (setf (cdr entry) value)))))) + (let ((value (funcall function (car entry) (cdr entry)))) + (when set-p + (setf (cdr entry) value)))))) cache) (defun cache-count (cache) @@ -1018,83 +1018,83 @@ (let ((count 0)) (declare (fixnum count)) (dotimes-fixnum (i (nlines) count) - (unless (line-reserved-p i) - (when (line-full-p i) - (incf count))))))) + (unless (line-reserved-p i) + (when (line-full-p i) + (incf count))))))) (defun entry-in-cache-p (cache wrappers value) (declare (ignore value)) (with-local-cache-functions (cache) (dotimes-fixnum (i (nlines)) (unless (line-reserved-p i) - (when (equal (line-wrappers i) wrappers) - (return t)))))) + (when (equal (line-wrappers i) wrappers) + (return t)))))) ;;; returns T or NIL (defun fill-cache-p (forcep cache wrappers value) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) - (primary (location-line location))) + (primary (location-line location))) (declare (fixnum location primary)) (multiple-value-bind (free emptyp) - (find-free-cache-line primary cache wrappers) - (when (or forcep emptyp) - (when (not emptyp) - (push (cons (line-wrappers free) (line-value free)) - (cache-overflow cache))) - ;;(fill-line free wrappers value) - (let ((line free)) - (declare (fixnum line)) - (when (line-reserved-p line) - (error "attempt to fill a reserved line")) - (let ((loc (line-location line)) - (cache-vector (vector))) - (declare (fixnum loc) (simple-vector cache-vector)) - (cond ((= (nkeys) 1) - (setf (cache-vector-ref cache-vector loc) wrappers) - (when (valuep) - (setf (cache-vector-ref cache-vector (1+ loc)) value))) - (t - (let ((i 0)) - (declare (fixnum i)) - (dolist (w wrappers) - (setf (cache-vector-ref cache-vector (+ loc i)) w) - (setq i (the fixnum (1+ i))))) - (when (valuep) - (setf (cache-vector-ref cache-vector (+ loc (nkeys))) - value)))) - (maybe-check-cache cache)))))))) + (find-free-cache-line primary cache wrappers) + (when (or forcep emptyp) + (when (not emptyp) + (push (cons (line-wrappers free) (line-value free)) + (cache-overflow cache))) + ;;(fill-line free wrappers value) + (let ((line free)) + (declare (fixnum line)) + (when (line-reserved-p line) + (error "attempt to fill a reserved line")) + (let ((loc (line-location line)) + (cache-vector (vector))) + (declare (fixnum loc) (simple-vector cache-vector)) + (cond ((= (nkeys) 1) + (setf (cache-vector-ref cache-vector loc) wrappers) + (when (valuep) + (setf (cache-vector-ref cache-vector (1+ loc)) value))) + (t + (let ((i 0)) + (declare (fixnum i)) + (dolist (w wrappers) + (setf (cache-vector-ref cache-vector (+ loc i)) w) + (setq i (the fixnum (1+ i))))) + (when (valuep) + (setf (cache-vector-ref cache-vector (+ loc (nkeys))) + value)))) + (maybe-check-cache cache)))))))) (defun fill-cache-from-cache-p (forcep cache from-cache from-line) (declare (fixnum from-line)) (with-local-cache-functions (cache) (let ((primary (location-line - (compute-primary-cache-location-from-location - cache (line-location from-line) from-cache)))) + (compute-primary-cache-location-from-location + cache (line-location from-line) from-cache)))) (declare (fixnum primary)) (multiple-value-bind (free emptyp) - (find-free-cache-line primary cache) - (when (or forcep emptyp) - (when (not emptyp) - (push (cons (line-wrappers free) (line-value free)) - (cache-overflow cache))) - ;;(transfer-line from-cache-vector from-line cache-vector free) - (let ((from-cache-vector (cache-vector from-cache)) - (to-cache-vector (vector)) - (to-line free)) - (declare (fixnum to-line)) - (if (line-reserved-p to-line) - (error "transferring something into a reserved cache line") - (let ((from-loc (line-location from-line)) - (to-loc (line-location to-line))) - (declare (fixnum from-loc to-loc)) - (modify-cache to-cache-vector - (dotimes-fixnum (i (line-size)) - (setf (cache-vector-ref to-cache-vector - (+ to-loc i)) - (cache-vector-ref from-cache-vector - (+ from-loc i))))))) - (maybe-check-cache cache))))))) + (find-free-cache-line primary cache) + (when (or forcep emptyp) + (when (not emptyp) + (push (cons (line-wrappers free) (line-value free)) + (cache-overflow cache))) + ;;(transfer-line from-cache-vector from-line cache-vector free) + (let ((from-cache-vector (cache-vector from-cache)) + (to-cache-vector (vector)) + (to-line free)) + (declare (fixnum to-line)) + (if (line-reserved-p to-line) + (error "transferring something into a reserved cache line") + (let ((from-loc (line-location from-line)) + (to-loc (line-location to-line))) + (declare (fixnum from-loc to-loc)) + (modify-cache to-cache-vector + (dotimes-fixnum (i (line-size)) + (setf (cache-vector-ref to-cache-vector + (+ to-loc i)) + (cache-vector-ref from-cache-vector + (+ from-loc i))))))) + (maybe-check-cache cache))))))) ;;; Returns NIL or (values ) ;;; @@ -1109,23 +1109,23 @@ (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (nlines) (field)))) (do ((nfield (cache-field ncache) - (next-wrapper-cache-number-index nfield))) - ((null nfield) nil) - (setf (cache-field ncache) nfield) - (labels ((try-one-fill-from-line (line) - (fill-cache-from-cache-p nil ncache cache line)) - (try-one-fill (wrappers value) - (fill-cache-p nil ncache wrappers value))) - (if (and (dotimes-fixnum (i (nlines) t) - (when (and (null (line-reserved-p i)) - (line-valid-p i wrappers)) - (unless (try-one-fill-from-line i) (return nil)))) - (dolist (wrappers+value (cache-overflow cache) t) - (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) - (return nil))) - (try-one-fill wrappers value)) - (return (maybe-check-cache ncache)) - (flush-cache-vector-internal (cache-vector ncache)))))))) + (next-wrapper-cache-number-index nfield))) + ((null nfield) nil) + (setf (cache-field ncache) nfield) + (labels ((try-one-fill-from-line (line) + (fill-cache-from-cache-p nil ncache cache line)) + (try-one-fill (wrappers value) + (fill-cache-p nil ncache wrappers value))) + (if (and (dotimes-fixnum (i (nlines) t) + (when (and (null (line-reserved-p i)) + (line-valid-p i wrappers)) + (unless (try-one-fill-from-line i) (return nil)))) + (dolist (wrappers+value (cache-overflow cache) t) + (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) + (return nil))) + (try-one-fill wrappers value)) + (return (maybe-check-cache ncache)) + (flush-cache-vector-internal (cache-vector ncache)))))))) ;;; returns: (values ) (defun expand-cache (cache wrappers value) @@ -1133,23 +1133,23 @@ (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (* (nlines) 2)))) (labels ((do-one-fill-from-line (line) - (unless (fill-cache-from-cache-p nil ncache cache line) - (do-one-fill (line-wrappers line) (line-value line)))) - (do-one-fill (wrappers value) - (setq ncache (or (adjust-cache ncache wrappers value) - (fill-cache-p t ncache wrappers value)))) - (try-one-fill (wrappers value) - (fill-cache-p nil ncache wrappers value))) - (dotimes-fixnum (i (nlines)) - (when (and (null (line-reserved-p i)) - (line-valid-p i wrappers)) - (do-one-fill-from-line i))) - (dolist (wrappers+value (cache-overflow cache)) - (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) - (do-one-fill (car wrappers+value) (cdr wrappers+value)))) - (unless (try-one-fill wrappers value) - (do-one-fill wrappers value)) - (maybe-check-cache ncache))))) + (unless (fill-cache-from-cache-p nil ncache cache line) + (do-one-fill (line-wrappers line) (line-value line)))) + (do-one-fill (wrappers value) + (setq ncache (or (adjust-cache ncache wrappers value) + (fill-cache-p t ncache wrappers value)))) + (try-one-fill (wrappers value) + (fill-cache-p nil ncache wrappers value))) + (dotimes-fixnum (i (nlines)) + (when (and (null (line-reserved-p i)) + (line-valid-p i wrappers)) + (do-one-fill-from-line i))) + (dolist (wrappers+value (cache-overflow cache)) + (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) + (do-one-fill (car wrappers+value) (cdr wrappers+value)))) + (unless (try-one-fill wrappers value) + (do-one-fill wrappers value)) + (maybe-check-cache ncache))))) ;;; This is the heart of the cache filling mechanism. It implements ;;; the decisions about where entries are placed. @@ -1157,67 +1157,67 @@ ;;; Find a line in the cache at which a new entry can be inserted. ;;; ;;; -;;; is in fact empty? +;;; is in fact empty? (defun find-free-cache-line (primary cache &optional wrappers) ;;(declare (values line empty?)) (declare (fixnum primary)) (with-local-cache-functions (cache) (when (line-reserved-p primary) (setq primary (next-line primary))) (let ((limit (funcall (limit-fn) (nlines))) - (wrappedp nil) - (lines nil) - (p primary) (s primary)) + (wrappedp nil) + (lines nil) + (p primary) (s primary)) (declare (fixnum p s limit)) (block find-free - (loop - ;; Try to find a free line starting at .

is the - ;; primary line of the entry we are finding a free - ;; line for, it is used to compute the separations. - (do* ((line s (next-line line)) - (nsep (line-separation p s) (1+ nsep))) - (()) - (declare (fixnum line nsep)) - (when (null (line-valid-p line wrappers)) ;If this line is empty or - (push line lines) ;invalid, just use it. - (return-from find-free)) - (when (and wrappedp (>= line primary)) - ;; have gone all the way around the cache, time to quit - (return-from find-free-cache-line (values primary nil))) - (let ((osep (line-separation (line-primary line) line))) - (when (>= osep limit) - (return-from find-free-cache-line (values primary nil))) - (when (cond ((= nsep limit) t) - ((= nsep osep) (zerop (random 2))) - ((> nsep osep) t) - (t nil)) - ;; See whether we can displace what is in this line so that we - ;; can use the line. - (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)) - (setq p (line-primary line)) - (setq s (next-line line)) - (push line lines) - (return nil))) - (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))))) + (loop + ;; Try to find a free line starting at .

is the + ;; primary line of the entry we are finding a free + ;; line for, it is used to compute the separations. + (do* ((line s (next-line line)) + (nsep (line-separation p s) (1+ nsep))) + (()) + (declare (fixnum line nsep)) + (when (null (line-valid-p line wrappers)) ;If this line is empty or + (push line lines) ;invalid, just use it. + (return-from find-free)) + (when (and wrappedp (>= line primary)) + ;; have gone all the way around the cache, time to quit + (return-from find-free-cache-line (values primary nil))) + (let ((osep (line-separation (line-primary line) line))) + (when (>= osep limit) + (return-from find-free-cache-line (values primary nil))) + (when (cond ((= nsep limit) t) + ((= nsep osep) (zerop (random 2))) + ((> nsep osep) t) + (t nil)) + ;; See whether we can displace what is in this line so that we + ;; can use the line. + (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)) + (setq p (line-primary line)) + (setq s (next-line line)) + (push line lines) + (return nil))) + (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))))) ;; Do all the displacing. (loop (when (null (cdr lines)) (return nil)) (let ((dline (pop lines)) - (line (car lines))) - (declare (fixnum dline line)) - ;;Copy from line to dline (dline is known to be free). - (let ((from-loc (line-location line)) - (to-loc (line-location dline)) - (cache-vector (vector))) - (declare (fixnum from-loc to-loc) (simple-vector cache-vector)) - (modify-cache cache-vector - (dotimes-fixnum (i (line-size)) - (setf (cache-vector-ref cache-vector - (+ to-loc i)) - (cache-vector-ref cache-vector - (+ from-loc i))) - (setf (cache-vector-ref cache-vector - (+ from-loc i)) - nil)))))) + (line (car lines))) + (declare (fixnum dline line)) + ;;Copy from line to dline (dline is known to be free). + (let ((from-loc (line-location line)) + (to-loc (line-location dline)) + (cache-vector (vector))) + (declare (fixnum from-loc to-loc) (simple-vector cache-vector)) + (modify-cache cache-vector + (dotimes-fixnum (i (line-size)) + (setf (cache-vector-ref cache-vector + (+ to-loc i)) + (cache-vector-ref cache-vector + (+ from-loc i))) + (setf (cache-vector-ref cache-vector + (+ from-loc i)) + nil)))))) (values (car lines) t)))) (defun default-limit-fn (nlines) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 28b5618..6c43380 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -26,71 +26,71 @@ (defun get-method-function (method &optional method-alist wrappers) (let ((fn (cadr (assoc method method-alist)))) (if fn - (values fn nil nil nil) - (multiple-value-bind (mf fmf) - (if (listp method) - (early-method-function method) - (values nil (method-fast-function method))) - (let* ((pv-table (and fmf (method-function-pv-table fmf)))) - (if (and fmf (or (null pv-table) wrappers)) - (let* ((pv-wrappers (when pv-table - (pv-wrappers-from-all-wrappers - pv-table wrappers))) - (pv-cell (when (and pv-table pv-wrappers) - (pv-table-lookup pv-table pv-wrappers)))) - (values mf t fmf pv-cell)) - (values - (or mf (if (listp method) - (setf (cadr method) - (method-function-from-fast-function fmf)) - (method-function method))) - t nil nil))))))) + (values fn nil nil nil) + (multiple-value-bind (mf fmf) + (if (listp method) + (early-method-function method) + (values nil (method-fast-function method))) + (let* ((pv-table (and fmf (method-function-pv-table fmf)))) + (if (and fmf (or (null pv-table) wrappers)) + (let* ((pv-wrappers (when pv-table + (pv-wrappers-from-all-wrappers + pv-table wrappers))) + (pv-cell (when (and pv-table pv-wrappers) + (pv-table-lookup pv-table pv-wrappers)))) + (values mf t fmf pv-cell)) + (values + (or mf (if (listp method) + (setf (cadr method) + (method-function-from-fast-function fmf)) + (method-function method))) + t nil nil))))))) (defun make-effective-method-function (generic-function form &optional - method-alist wrappers) + method-alist wrappers) (funcall (make-effective-method-function1 generic-function form - (not (null method-alist)) - (not (null wrappers))) - method-alist wrappers)) + (not (null method-alist)) + (not (null wrappers))) + method-alist wrappers)) (defun make-effective-method-function1 (generic-function form - method-alist-p wrappers-p) + method-alist-p wrappers-p) (if (and (listp form) - (eq (car form) 'call-method)) + (eq (car form) 'call-method)) (make-effective-method-function-simple generic-function form) ;; We have some sort of `real' effective method. Go off and get a ;; compiled function for it. Most of the real hair here is done by ;; the GET-FUN mechanism. (make-effective-method-function-internal generic-function form - method-alist-p wrappers-p))) + method-alist-p wrappers-p))) (defun make-effective-method-fun-type (generic-function - form - method-alist-p - wrappers-p) + form + method-alist-p + wrappers-p) (if (and (listp form) - (eq (car form) 'call-method)) + (eq (car form) 'call-method)) (let* ((cm-args (cdr form)) - (method (car cm-args))) - (when method - (if (if (listp method) - (eq (car method) :early-method) - (method-p method)) - (if method-alist-p - t - (multiple-value-bind (mf fmf) - (if (listp method) - (early-method-function method) - (values nil (method-fast-function method))) - (declare (ignore mf)) - (let* ((pv-table (and fmf (method-function-pv-table fmf)))) - (if (and fmf (or (null pv-table) wrappers-p)) - 'fast-method-call - 'method-call)))) - (if (and (consp method) (eq (car method) 'make-method)) - (make-effective-method-fun-type - generic-function (cadr method) method-alist-p wrappers-p) - (type-of method))))) + (method (car cm-args))) + (when method + (if (if (listp method) + (eq (car method) :early-method) + (method-p method)) + (if method-alist-p + t + (multiple-value-bind (mf fmf) + (if (listp method) + (early-method-function method) + (values nil (method-fast-function method))) + (declare (ignore mf)) + (let* ((pv-table (and fmf (method-function-pv-table fmf)))) + (if (and fmf (or (null pv-table) wrappers-p)) + 'fast-method-call + 'method-call)))) + (if (and (consp method) (eq (car method) 'make-method)) + (make-effective-method-fun-type + generic-function (cadr method) method-alist-p wrappers-p) + (type-of method))))) 'fast-method-call)) (defun make-effective-method-function-simple @@ -105,52 +105,52 @@ ;; asks about them. If it does, we must tell it whether there are ;; or aren't to prevent the leaky next methods bug. (let* ((cm-args (cdr form)) - (fmf-p (and (null no-fmf-p) - (or (not (eq *boot-state* 'complete)) - (gf-fast-method-function-p generic-function)) - (null (cddr cm-args)))) - (method (car cm-args)) - (cm-args1 (cdr cm-args))) + (fmf-p (and (null no-fmf-p) + (or (not (eq *boot-state* 'complete)) + (gf-fast-method-function-p generic-function)) + (null (cddr cm-args)))) + (method (car cm-args)) + (cm-args1 (cdr cm-args))) (lambda (method-alist wrappers) (make-effective-method-function-simple1 generic-function - method - cm-args1 - fmf-p - method-alist - wrappers)))) + method + cm-args1 + fmf-p + method-alist + wrappers)))) (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers) (multiple-value-bind (mf real-mf-p fmf pv-cell) (get-method-function method method-alist wrappers) (if fmf - (let* ((next-methods (car cm-args)) - (next (make-effective-method-function-simple1 - gf (car next-methods) - (list* (cdr next-methods) (cdr cm-args)) - fmf-p method-alist wrappers)) - (arg-info (method-function-get fmf :arg-info))) - (make-fast-method-call :function fmf - :pv-cell pv-cell - :next-method-call next - :arg-info arg-info)) - (if real-mf-p - (make-method-call :function mf - :call-method-args cm-args) - mf)))) + (let* ((next-methods (car cm-args)) + (next (make-effective-method-function-simple1 + gf (car next-methods) + (list* (cdr next-methods) (cdr cm-args)) + fmf-p method-alist wrappers)) + (arg-info (method-function-get fmf :arg-info))) + (make-fast-method-call :function fmf + :pv-cell pv-cell + :next-method-call next + :arg-info arg-info)) + (if real-mf-p + (make-method-call :function mf + :call-method-args cm-args) + mf)))) (defun make-effective-method-function-simple1 (gf method cm-args fmf-p &optional method-alist wrappers) (when method (if (if (listp method) - (eq (car method) :early-method) - (method-p method)) - (make-emf-from-method method cm-args gf fmf-p method-alist wrappers) - (if (and (consp method) (eq (car method) 'make-method)) - (make-effective-method-function gf - (cadr method) - method-alist wrappers) - method)))) + (eq (car method) :early-method) + (method-p method)) + (make-emf-from-method method cm-args gf fmf-p method-alist wrappers) + (if (and (consp method) (eq (car method) 'make-method)) + (make-effective-method-function gf + (cadr method) + method-alist wrappers) + method)))) (defvar *global-effective-method-gensyms* ()) (defvar *rebound-effective-method-gensyms*) @@ -158,11 +158,11 @@ (defun get-effective-method-gensym () (or (pop *rebound-effective-method-gensyms*) (let ((new (format-symbol *pcl-package* - "EFFECTIVE-METHOD-GENSYM-~D" - (length *global-effective-method-gensyms*)))) - (setq *global-effective-method-gensyms* - (append *global-effective-method-gensyms* (list new))) - new))) + "EFFECTIVE-METHOD-GENSYM-~D" + (length *global-effective-method-gensyms*)))) + (setq *global-effective-method-gensyms* + (append *global-effective-method-gensyms* (list new))) + new))) (let ((*rebound-effective-method-gensyms* ())) (dotimes-fixnum (i 10) (get-effective-method-gensym))) @@ -173,48 +173,48 @@ (get-generic-fun-info gf) (declare (ignore nreq nkeys arg-info)) (let ((ll (make-fast-method-call-lambda-list metatypes applyp)) - (check-applicable-keywords - (when (and applyp (gf-requires-emf-keyword-checks gf)) - '((check-applicable-keywords)))) - (error-p (or (eq (first effective-method) '%no-primary-method) - (eq (first effective-method) '%invalid-qualifiers))) - (mc-args-p - (when (eq *boot-state* 'complete) - ;; Otherwise the METHOD-COMBINATION slot is not bound. - (let ((combin (generic-function-method-combination gf))) - (and (long-method-combination-p combin) - (long-method-combination-args-lambda-list combin)))))) + (check-applicable-keywords + (when (and applyp (gf-requires-emf-keyword-checks gf)) + '((check-applicable-keywords)))) + (error-p (or (eq (first effective-method) '%no-primary-method) + (eq (first effective-method) '%invalid-qualifiers))) + (mc-args-p + (when (eq *boot-state* 'complete) + ;; Otherwise the METHOD-COMBINATION slot is not bound. + (let ((combin (generic-function-method-combination gf))) + (and (long-method-combination-p combin) + (long-method-combination-args-lambda-list combin)))))) (cond - (error-p - `(lambda (.pv-cell. .next-method-call. &rest .args.) - (declare (ignore .pv-cell. .next-method-call.)) - (declare (ignorable .args.)) - (flet ((%no-primary-method (gf args) - (apply #'no-primary-method gf args)) - (%invalid-qualifiers (gf combin method) - (invalid-qualifiers gf combin method))) - (declare (ignorable #'%no-primary-method #'%invalid-qualifiers)) - ,effective-method))) - (mc-args-p - (let* ((required - ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp - (let (req) - (dotimes (i (length metatypes) (nreverse req)) - (push (dfun-arg-symbol i) req)))) - (gf-args (if applyp - `(list* ,@required .dfun-rest-arg.) - `(list ,@required)))) - `(lambda ,ll - (declare (ignore .pv-cell. .next-method-call.)) - (let ((.gf-args. ,gf-args)) - (declare (ignorable .gf-args.)) - ,@check-applicable-keywords - ,effective-method)))) - (t - `(lambda ,ll - (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.)))) - ,@check-applicable-keywords - ,effective-method)))))) + (error-p + `(lambda (.pv-cell. .next-method-call. &rest .args.) + (declare (ignore .pv-cell. .next-method-call.)) + (declare (ignorable .args.)) + (flet ((%no-primary-method (gf args) + (apply #'no-primary-method gf args)) + (%invalid-qualifiers (gf combin method) + (invalid-qualifiers gf combin method))) + (declare (ignorable #'%no-primary-method #'%invalid-qualifiers)) + ,effective-method))) + (mc-args-p + (let* ((required + ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp + (let (req) + (dotimes (i (length metatypes) (nreverse req)) + (push (dfun-arg-symbol i) req)))) + (gf-args (if applyp + `(list* ,@required .dfun-rest-arg.) + `(list ,@required)))) + `(lambda ,ll + (declare (ignore .pv-cell. .next-method-call.)) + (let ((.gf-args. ,gf-args)) + (declare (ignorable .gf-args.)) + ,@check-applicable-keywords + ,effective-method)))) + (t + `(lambda ,ll + (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.)))) + ,@check-applicable-keywords + ,effective-method)))))) (defun expand-emf-call-method (gf form metatypes applyp env) (declare (ignore gf metatypes applyp env)) @@ -229,10 +229,10 @@ (defun make-effective-method-list-fun-type (generic-function form method-alist-p wrappers-p) (if (every (lambda (form) - (eq 'fast-method-call - (make-effective-method-fun-type - generic-function form method-alist-p wrappers-p))) - (cdr form)) + (eq 'fast-method-call + (make-effective-method-fun-type + generic-function form method-alist-p wrappers-p))) + (cdr form)) 'fast-method-call t)) @@ -240,12 +240,12 @@ (case (and (consp form) (car form)) (call-method (case (make-effective-method-fun-type - generic-function form method-alist-p wrappers-p) + generic-function form method-alist-p wrappers-p) (fast-method-call '.fast-call-method.) (t '.call-method.))) (call-method-list (case (make-effective-method-list-fun-type - generic-function form method-alist-p wrappers-p) + generic-function form method-alist-p wrappers-p) (fast-method-call '.fast-call-method-list.) (t '.call-method-list.))) (check-applicable-keywords 'check-applicable-keywords) @@ -263,22 +263,22 @@ (call-method (let ((gensym (get-effective-method-gensym))) (values (make-emf-call - metatypes applyp gensym - (make-effective-method-fun-type - generic-function form method-alist-p wrappers-p)) - (list gensym)))) + metatypes applyp gensym + (make-effective-method-fun-type + generic-function form method-alist-p wrappers-p)) + (list gensym)))) (call-method-list (let ((gensym (get-effective-method-gensym)) - (type (make-effective-method-list-fun-type - generic-function form method-alist-p wrappers-p))) + (type (make-effective-method-list-fun-type + generic-function form method-alist-p wrappers-p))) (values `(dolist (emf ,gensym nil) - ,(make-emf-call metatypes applyp 'emf type)) - (list gensym)))) + ,(make-emf-call metatypes applyp 'emf type)) + (list gensym)))) (check-applicable-keywords (values `(check-applicable-keywords - .dfun-rest-arg. .keyargs-start. .valid-keys.) - '(.keyargs-start. .valid-keys.))) - + .dfun-rest-arg. .keyargs-start. .valid-keys.) + '(.keyargs-start. .valid-keys.))) + (t (default-code-converter form)))) @@ -286,14 +286,14 @@ (case (and (consp form) (car form)) (call-method (list (cons '.meth. - (make-effective-method-function-simple - generic-function form)))) + (make-effective-method-function-simple + generic-function form)))) (call-method-list (list (cons '.meth-list. - (mapcar (lambda (form) - (make-effective-method-function-simple - generic-function form)) - (cdr form))))) + (mapcar (lambda (form) + (make-effective-method-function-simple + generic-function form)) + (cdr form))))) (check-applicable-keywords '(.keyargs-start. .valid-keys.)) (t @@ -306,48 +306,48 @@ (get-generic-fun-info generic-function) (declare (ignore nkeys arg-info)) (let* ((*rebound-effective-method-gensyms* - *global-effective-method-gensyms*) - (name (if (early-gf-p generic-function) - (!early-gf-name generic-function) - (generic-function-name generic-function))) - (arg-info (cons nreq applyp)) - (effective-method-lambda (expand-effective-method-function - generic-function effective-method))) + *global-effective-method-gensyms*) + (name (if (early-gf-p generic-function) + (!early-gf-name generic-function) + (generic-function-name generic-function))) + (arg-info (cons nreq applyp)) + (effective-method-lambda (expand-effective-method-function + generic-function effective-method))) (multiple-value-bind (cfunction constants) - (get-fun1 effective-method-lambda - (lambda (form) - (memf-test-converter form generic-function - method-alist-p wrappers-p)) - (lambda (form) - (memf-code-converter form generic-function - metatypes applyp - method-alist-p wrappers-p)) - (lambda (form) - (memf-constant-converter form generic-function))) - (lambda (method-alist wrappers) - (multiple-value-bind (valid-keys keyargs-start) - (when (memq '.valid-keys. constants) - (compute-applicable-keywords - generic-function *applicable-methods*)) - (flet ((compute-constant (constant) - (if (consp constant) - (case (car constant) - (.meth. - (funcall (cdr constant) method-alist wrappers)) - (.meth-list. - (mapcar (lambda (fn) - (funcall fn method-alist wrappers)) - (cdr constant))) - (t constant)) - (case constant - (.keyargs-start. keyargs-start) - (.valid-keys. valid-keys) - (t constant))))) - (let ((fun (apply cfunction - (mapcar #'compute-constant constants)))) - (set-fun-name fun `(combined-method ,name)) - (make-fast-method-call :function fun - :arg-info arg-info))))))))) + (get-fun1 effective-method-lambda + (lambda (form) + (memf-test-converter form generic-function + method-alist-p wrappers-p)) + (lambda (form) + (memf-code-converter form generic-function + metatypes applyp + method-alist-p wrappers-p)) + (lambda (form) + (memf-constant-converter form generic-function))) + (lambda (method-alist wrappers) + (multiple-value-bind (valid-keys keyargs-start) + (when (memq '.valid-keys. constants) + (compute-applicable-keywords + generic-function *applicable-methods*)) + (flet ((compute-constant (constant) + (if (consp constant) + (case (car constant) + (.meth. + (funcall (cdr constant) method-alist wrappers)) + (.meth-list. + (mapcar (lambda (fn) + (funcall fn method-alist wrappers)) + (cdr constant))) + (t constant)) + (case constant + (.keyargs-start. keyargs-start) + (.valid-keys. valid-keys) + (t constant))))) + (let ((fun (apply cfunction + (mapcar #'compute-constant constants)))) + (set-fun-name fun `(combined-method ,name)) + (make-fast-method-call :function fun + :arg-info arg-info))))))))) (defmacro call-method-list (&rest calls) `(progn ,@calls)) @@ -365,109 +365,109 @@ (generic-function combin applicable-methods) (collect ((before) (primary) (after) (around)) (flet ((invalid (gf combin m) - (if *in-precompute-effective-methods-p* - (return-from standard-compute-effective-method - `(%invalid-qualifiers ',gf ',combin ',m)) - (invalid-qualifiers gf combin m)))) + (if *in-precompute-effective-methods-p* + (return-from standard-compute-effective-method + `(%invalid-qualifiers ',gf ',combin ',m)) + (invalid-qualifiers gf combin m)))) (dolist (m applicable-methods) - (let ((qualifiers (if (listp m) - (early-method-qualifiers m) - (method-qualifiers m)))) - (cond - ((null qualifiers) (primary m)) - ((cdr qualifiers) (invalid generic-function combin m)) - ((eq (car qualifiers) :around) (around m)) - ((eq (car qualifiers) :before) (before m)) - ((eq (car qualifiers) :after) (after m)) - (t (invalid generic-function combin m)))))) + (let ((qualifiers (if (listp m) + (early-method-qualifiers m) + (method-qualifiers m)))) + (cond + ((null qualifiers) (primary m)) + ((cdr qualifiers) (invalid generic-function combin m)) + ((eq (car qualifiers) :around) (around m)) + ((eq (car qualifiers) :before) (before m)) + ((eq (car qualifiers) :after) (after m)) + (t (invalid generic-function combin m)))))) (cond ((null (primary)) - `(%no-primary-method ',generic-function .args.)) - ((and (null (before)) (null (after)) (null (around))) - ;; By returning a single call-method `form' here we enable - ;; an important implementation-specific optimization; that - ;; is, we can use the fast method function directly as the - ;; effective method function. - ;; - ;; However, the requirement by ANSI (CLHS 7.6.5) on generic - ;; function argument checking inhibits this, as we don't - ;; perform this checking in fast-method-functions given - ;; that they are not solely used for effective method - ;; functions, but also in combination, when they should not - ;; perform argument checks. - (let ((call-method - `(call-method ,(first (primary)) ,(rest (primary))))) - (if (gf-requires-emf-keyword-checks generic-function) - ;; the PROGN inhibits the above optimization - `(progn ,call-method) - call-method))) - (t - (let ((main-effective-method - (if (or (before) (after)) - `(multiple-value-prog1 - (progn - ,(make-call-methods (before)) - (call-method ,(first (primary)) - ,(rest (primary)))) - ,(make-call-methods (reverse (after)))) - `(call-method ,(first (primary)) ,(rest (primary)))))) - (if (around) - `(call-method ,(first (around)) - (,@(rest (around)) - (make-method ,main-effective-method))) - main-effective-method)))))) + `(%no-primary-method ',generic-function .args.)) + ((and (null (before)) (null (after)) (null (around))) + ;; By returning a single call-method `form' here we enable + ;; an important implementation-specific optimization; that + ;; is, we can use the fast method function directly as the + ;; effective method function. + ;; + ;; However, the requirement by ANSI (CLHS 7.6.5) on generic + ;; function argument checking inhibits this, as we don't + ;; perform this checking in fast-method-functions given + ;; that they are not solely used for effective method + ;; functions, but also in combination, when they should not + ;; perform argument checks. + (let ((call-method + `(call-method ,(first (primary)) ,(rest (primary))))) + (if (gf-requires-emf-keyword-checks generic-function) + ;; the PROGN inhibits the above optimization + `(progn ,call-method) + call-method))) + (t + (let ((main-effective-method + (if (or (before) (after)) + `(multiple-value-prog1 + (progn + ,(make-call-methods (before)) + (call-method ,(first (primary)) + ,(rest (primary)))) + ,(make-call-methods (reverse (after)))) + `(call-method ,(first (primary)) ,(rest (primary)))))) + (if (around) + `(call-method ,(first (around)) + (,@(rest (around)) + (make-method ,main-effective-method))) + main-effective-method)))))) ;;; helper code for checking keywords in generic function calls. (defun compute-applicable-keywords (gf methods) (let ((any-keyp nil)) (flet ((analyze (lambda-list) - (multiple-value-bind (nreq nopt keyp restp allowp keys) - (analyze-lambda-list lambda-list) - (declare (ignore nreq restp)) - (when keyp - (setq any-keyp t)) - (values nopt allowp keys)))) + (multiple-value-bind (nreq nopt keyp restp allowp keys) + (analyze-lambda-list lambda-list) + (declare (ignore nreq restp)) + (when keyp + (setq any-keyp t)) + (values nopt allowp keys)))) (multiple-value-bind (nopt allowp keys) - (analyze (generic-function-lambda-list gf)) - (dolist (method methods) - (let ((ll (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method)))) - (multiple-value-bind (n allowp method-keys) - (analyze ll) - (declare (ignore n)) - (when allowp - (return-from compute-applicable-keywords (values t nopt))) - (setq keys (union method-keys keys))))) - (aver any-keyp) - (values (if allowp t keys) nopt))))) + (analyze (generic-function-lambda-list gf)) + (dolist (method methods) + (let ((ll (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method)))) + (multiple-value-bind (n allowp method-keys) + (analyze ll) + (declare (ignore n)) + (when allowp + (return-from compute-applicable-keywords (values t nopt))) + (setq keys (union method-keys keys))))) + (aver any-keyp) + (values (if allowp t keys) nopt))))) (defun check-applicable-keywords (args start valid-keys) (let ((allow-other-keys-seen nil) - (allow-other-keys nil) - (args (nthcdr start args))) + (allow-other-keys nil) + (args (nthcdr start args))) (collect ((invalid)) (loop (when (null args) - (when (and (invalid) (not allow-other-keys)) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list (length (invalid)) (invalid) valid-keys))) - (return)) + :format-arguments (list (length (invalid)) (invalid) valid-keys))) + (return)) (let ((key (pop args))) - (cond - ((not (symbolp key)) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list key))) - ((null args) (sb-c::%odd-key-args-error)) - ((eq key :allow-other-keys) - ;; only the leftmost :ALLOW-OTHER-KEYS has any effect - (unless allow-other-keys-seen - (setq allow-other-keys-seen t - allow-other-keys (car args)))) - ((eq t valid-keys)) - ((not (memq key valid-keys)) (invalid key)))) + (cond + ((not (symbolp key)) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list key))) + ((null args) (sb-c::%odd-key-args-error)) + ((eq key :allow-other-keys) + ;; only the leftmost :ALLOW-OTHER-KEYS has any effect + (unless allow-other-keys-seen + (setq allow-other-keys-seen t + allow-other-keys (car args)))) + ((eq t valid-keys)) + ((not (memq key valid-keys)) (invalid key)))) (pop args))))) ;;;; the STANDARD method combination type. This is coded by hand @@ -484,18 +484,18 @@ (defun compute-effective-method (generic-function combin applicable-methods) (standard-compute-effective-method generic-function - combin - applicable-methods)) + combin + applicable-methods)) (defun invalid-method-error (method format-control &rest format-arguments) (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) (error "~@" - method - format-control - format-arguments))) + method + format-control + format-arguments))) (defun method-combination-error (format-control &rest format-arguments) (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) (error "~@" - format-control - format-arguments))) + format-control + format-arguments))) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index 937da71..f475943 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -39,7 +39,7 @@ (deftransform sb-pcl::pcl-instance-p ((object)) (let* ((otype (lvar-type object)) - (std-obj (specifier-type 'sb-pcl::std-object))) + (std-obj (specifier-type 'sb-pcl::std-object))) (cond ;; Flush tests whose result is known at compile time. ((csubtypep otype std-obj) t) @@ -50,12 +50,12 @@ (define-source-context defmethod (name &rest stuff) (let ((arg-pos (position-if #'listp stuff))) (if arg-pos - `(defmethod ,name ,@(subseq stuff 0 arg-pos) - ,(handler-case - (nth-value 2 (sb-pcl::parse-specialized-lambda-list - (elt stuff arg-pos))) - (error () ""))) - `(defmethod ,name "")))) + `(defmethod ,name ,@(subseq stuff 0 arg-pos) + ,(handler-case + (nth-value 2 (sb-pcl::parse-specialized-lambda-list + (elt stuff arg-pos))) + (error () ""))) + `(defmethod ,name "")))) (defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil) @@ -68,16 +68,16 @@ (when (cdr list) (destructuring-bind (name &rest rest) (cdr list) (when (and (symbolp name) - (null rest)) - (values t name))))) + (null rest)) + (values t name))))) (define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list) (when (= (length list) 4) (destructuring-bind (class slot rwb) (cdr list) (when (and (member rwb '(sb-pcl::reader sb-pcl::writer sb-pcl::boundp)) - (symbolp slot) - (symbolp class)) - (values t slot))))) + (symbolp slot) + (symbolp class)) + (values t slot))))) (define-internal-pcl-function-name-syntax sb-pcl::fast-method (list) (valid-function-name-p (cadr list))) @@ -94,9 +94,9 @@ (defun sb-pcl::set-random-documentation (name type new-value) (let ((pair (assoc type (info :random-documentation :stuff name)))) (if pair - (setf (cdr pair) new-value) - (push (cons type new-value) - (info :random-documentation :stuff name)))) + (setf (cdr pair) new-value) + (push (cons type new-value) + (info :random-documentation :stuff name)))) new-value) (defsetf sb-pcl::random-documentation sb-pcl::set-random-documentation) diff --git a/src/pcl/cpl.lisp b/src/pcl/cpl.lisp index fd09bfd..e1ac1aa 100644 --- a/src/pcl/cpl.lisp +++ b/src/pcl/cpl.lisp @@ -78,12 +78,12 @@ (compute-std-cpl root (class-direct-superclasses root))) (defstruct (class-precedence-description - (:conc-name nil) - (:print-object (lambda (obj str) - (print-unreadable-object (obj str :type t) - (format str "~D" (cpd-count obj))))) - (:constructor make-cpd ()) - (:copier nil)) + (:conc-name nil) + (:print-object (lambda (obj str) + (print-unreadable-object (obj str :type t) + (format str "~D" (cpd-count obj))))) + (:constructor make-cpd ()) + (:copier nil)) (cpd-class nil) (cpd-supers ()) (cpd-after ()) @@ -94,17 +94,17 @@ ;; the first two branches of this COND are implementing an ;; optimization for single inheritance. ((and (null supers) - (not (forward-referenced-class-p class))) + (not (forward-referenced-class-p class))) (list class)) ((and (car supers) - (null (cdr supers)) - (not (forward-referenced-class-p (car supers)))) + (null (cdr supers)) + (not (forward-referenced-class-p (car supers)))) (cons class - (compute-std-cpl (car supers) - (class-direct-superclasses (car supers))))) + (compute-std-cpl (car supers) + (class-direct-superclasses (car supers))))) (t (multiple-value-bind (all-cpds nclasses) - (compute-std-cpl-phase-1 class supers) + (compute-std-cpl-phase-1 class supers) (compute-std-cpl-phase-2 all-cpds) (compute-std-cpl-phase-3 class all-cpds nclasses))))) @@ -112,27 +112,27 @@ (defun compute-std-cpl-phase-1 (class supers) (let ((nclasses 0) - (all-cpds ()) - (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* - :test #'eq))) + (all-cpds ()) + (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* + :test #'eq))) (declare (fixnum nclasses)) (labels ((get-cpd (c) - (or (gethash c table) - (setf (gethash c table) (make-cpd)))) - (walk (c supers) - (declare (special *allow-forward-referenced-classes-in-cpl-p*)) - (if (and (forward-referenced-class-p c) - (not *allow-forward-referenced-classes-in-cpl-p*)) - (cpl-forward-referenced-class-error class c) - (let ((cpd (get-cpd c))) - (unless (cpd-class cpd) ;If we have already done this - ;class before, we can quit. - (setf (cpd-class cpd) c) - (incf nclasses) - (push cpd all-cpds) - (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) - (dolist (super supers) - (walk super (class-direct-superclasses super)))))))) + (or (gethash c table) + (setf (gethash c table) (make-cpd)))) + (walk (c supers) + (declare (special *allow-forward-referenced-classes-in-cpl-p*)) + (if (and (forward-referenced-class-p c) + (not *allow-forward-referenced-classes-in-cpl-p*)) + (cpl-forward-referenced-class-error class c) + (let ((cpd (get-cpd c))) + (unless (cpd-class cpd) ;If we have already done this + ;class before, we can quit. + (setf (cpd-class cpd) c) + (incf nclasses) + (push cpd all-cpds) + (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) + (dolist (super supers) + (walk super (class-direct-superclasses super)))))))) (walk class supers) (values all-cpds nclasses)))) @@ -140,18 +140,18 @@ (dolist (cpd all-cpds) (let ((supers (cpd-supers cpd))) (when supers - (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) - (incf (cpd-count (car supers)) 1) - (do* ((t1 supers t2) - (t2 (cdr t1) (cdr t1))) - ((null t2)) - (incf (cpd-count (car t2)) 2) - (push (car t2) (cpd-after (car t1)))))))) + (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) + (incf (cpd-count (car supers)) 1) + (do* ((t1 supers t2) + (t2 (cdr t1) (cdr t1))) + ((null t2)) + (incf (cpd-count (car t2)) 2) + (push (car t2) (cpd-after (car t1)))))))) (defun compute-std-cpl-phase-3 (class all-cpds nclasses) (let ((candidates ()) - (next-cpd nil) - (rcpl ())) + (next-cpd nil) + (rcpl ())) ;; We have to bootstrap the collection of those CPD's that ;; have a zero count. Once we get going, we will maintain @@ -162,12 +162,12 @@ (loop (when (null candidates) - ;; If there are no candidates, and enough classes have been put - ;; into the precedence list, then we are all done. Otherwise - ;; it means there is a consistency problem. - (if (zerop nclasses) - (return (reverse rcpl)) - (cpl-inconsistent-error class all-cpds))) + ;; If there are no candidates, and enough classes have been put + ;; into the precedence list, then we are all done. Otherwise + ;; it means there is a consistency problem. + (if (zerop nclasses) + (return (reverse rcpl)) + (cpl-inconsistent-error class all-cpds))) ;; Try to find the next class to put in from among the candidates. ;; If there is only one, its easy, otherwise we have to use the @@ -175,71 +175,71 @@ ;; having to call DELETE on the list of candidates. I dunno if ;; its worth it but what the hell. (setq next-cpd - (if (null (cdr candidates)) - (prog1 (car candidates) - (setq candidates ())) - (block tie-breaker - (dolist (c rcpl) - (let ((supers (class-direct-superclasses c))) - (if (memq (cpd-class (car candidates)) supers) - (return-from tie-breaker (pop candidates)) - (do ((loc candidates (cdr loc))) - ((null (cdr loc))) - (let ((cpd (cadr loc))) - (when (memq (cpd-class cpd) supers) - (setf (cdr loc) (cddr loc)) - (return-from tie-breaker cpd)))))))))) + (if (null (cdr candidates)) + (prog1 (car candidates) + (setq candidates ())) + (block tie-breaker + (dolist (c rcpl) + (let ((supers (class-direct-superclasses c))) + (if (memq (cpd-class (car candidates)) supers) + (return-from tie-breaker (pop candidates)) + (do ((loc candidates (cdr loc))) + ((null (cdr loc))) + (let ((cpd (cadr loc))) + (when (memq (cpd-class cpd) supers) + (setf (cdr loc) (cddr loc)) + (return-from tie-breaker cpd)))))))))) (decf nclasses) (push (cpd-class next-cpd) rcpl) (dolist (after (cpd-after next-cpd)) - (when (zerop (decf (cpd-count after))) - (push after candidates)))))) + (when (zerop (decf (cpd-count after))) + (push after candidates)))))) ;;;; support code for signalling nice error messages (defun cpl-error (class format-string &rest format-args) (error "While computing the class precedence list of the class ~A.~%~A" - (if (class-name class) - (format nil "named ~S" (class-name class)) - class) - (apply #'format nil format-string format-args))) + (if (class-name class) + (format nil "named ~S" (class-name class)) + class) + (apply #'format nil format-string format-args))) (defun cpl-forward-referenced-class-error (class forward-class) (flet ((class-or-name (class) - (if (class-name class) - (format nil "named ~S" (class-name class)) - class))) + (if (class-name class) + (format nil "named ~S" (class-name class)) + class))) (if (eq class forward-class) - (cpl-error class - "The class ~A is a forward referenced class." - (class-or-name class)) - (let ((names (mapcar #'class-or-name - (cdr (find-superclass-chain class forward-class))))) - (cpl-error class - "The class ~A is a forward referenced class.~@ + (cpl-error class + "The class ~A is a forward referenced class." + (class-or-name class)) + (let ((names (mapcar #'class-or-name + (cdr (find-superclass-chain class forward-class))))) + (cpl-error class + "The class ~A is a forward referenced class.~@ The class ~A is ~A." - (class-or-name forward-class) - (class-or-name forward-class) - (if (null (cdr names)) - (format nil - "a direct superclass of the class ~A" - (class-or-name class)) - (format nil - "reached from the class ~A by following~@ - the direct superclass chain through: ~A~ - ~% ending at the class ~A" - (class-or-name class) - (format nil - "~{~% the class ~A,~}" - (butlast names)) - (car (last names))))))))) + (class-or-name forward-class) + (class-or-name forward-class) + (if (null (cdr names)) + (format nil + "a direct superclass of the class ~A" + (class-or-name class)) + (format nil + "reached from the class ~A by following~@ + the direct superclass chain through: ~A~ + ~% ending at the class ~A" + (class-or-name class) + (format nil + "~{~% the class ~A,~}" + (butlast names)) + (car (last names))))))))) (defun find-superclass-chain (bottom top) (labels ((walk (c chain) - (if (eq c top) - (return-from find-superclass-chain (nreverse chain)) - (dolist (super (class-direct-superclasses c)) - (walk super (cons super chain)))))) + (if (eq c top) + (return-from find-superclass-chain (nreverse chain)) + (dolist (super (class-direct-superclasses c)) + (walk super (cons super chain)))))) (walk bottom (list bottom)))) (defun cpl-inconsistent-error (class all-cpds) @@ -254,57 +254,57 @@ (defun format-cycle-reasons (reasons) (flet ((class-or-name (cpd) - (let ((class (cpd-class cpd))) - (if (class-name class) - (format nil "named ~S" (class-name class)) - class)))) + (let ((class (cpd-class cpd))) + (if (class-name class) + (format nil "named ~S" (class-name class)) + class)))) (mapcar (lambda (reason) - (ecase (caddr reason) - (:super - (format - nil - "The class ~A appears in the supers of the class ~A." - (class-or-name (cadr reason)) - (class-or-name (car reason)))) - (:in-supers - (format - nil - "The class ~A follows the class ~A in the supers of the class ~A." - (class-or-name (cadr reason)) - (class-or-name (car reason)) - (class-or-name (cadddr reason)))))) + (ecase (caddr reason) + (:super + (format + nil + "The class ~A appears in the supers of the class ~A." + (class-or-name (cadr reason)) + (class-or-name (car reason)))) + (:in-supers + (format + nil + "The class ~A follows the class ~A in the supers of the class ~A." + (class-or-name (cadr reason)) + (class-or-name (car reason)) + (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) - (let ((been-here ()) ; list of classes we have visited - (cycle-reasons ())) + (let ((been-here ()) ; list of classes we have visited + (cycle-reasons ())) (labels ((chase (path) - (if (memq (car path) (cdr path)) - (record-cycle (memq (car path) (nreverse path))) - (unless (memq (car path) been-here) - (push (car path) been-here) - (dolist (after (cpd-after (car path))) - (chase (cons after path)))))) - (record-cycle (cycle) - (let ((reasons ())) - (do* ((t1 cycle t2) - (t2 (cdr t1) (cdr t1))) - ((null t2)) - (let ((c1 (car t1)) - (c2 (car t2))) - (if (memq c2 (cpd-supers c1)) - (push (list c1 c2 :super) reasons) - (dolist (cpd all-cpds) - (when (memq c2 (memq c1 (cpd-supers cpd))) - (return - (push (list c1 c2 :in-supers cpd) reasons))))))) - (push (nreverse reasons) cycle-reasons)))) + (if (memq (car path) (cdr path)) + (record-cycle (memq (car path) (nreverse path))) + (unless (memq (car path) been-here) + (push (car path) been-here) + (dolist (after (cpd-after (car path))) + (chase (cons after path)))))) + (record-cycle (cycle) + (let ((reasons ())) + (do* ((t1 cycle t2) + (t2 (cdr t1) (cdr t1))) + ((null t2)) + (let ((c1 (car t1)) + (c2 (car t2))) + (if (memq c2 (cpd-supers c1)) + (push (list c1 c2 :super) reasons) + (dolist (cpd all-cpds) + (when (memq c2 (memq c1 (cpd-supers cpd))) + (return + (push (list c1 c2 :in-supers cpd) reasons))))))) + (push (nreverse reasons) cycle-reasons)))) (dolist (cpd all-cpds) - (unless (zerop (cpd-count cpd)) - (chase (list cpd)))) + (unless (zerop (cpd-count cpd)) + (chase (list cpd)))) cycle-reasons))) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 3bb6af4..92965bf 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -64,31 +64,31 @@ (defun quote-plist-keys (plist) (loop for (key . more) on plist by #'cddr - if (null more) do - (error "Not a property list: ~S" plist) - else - collect `(quote ,key) - and collect (car more))) + if (null more) do + (error "Not a property list: ~S" plist) + else + collect `(quote ,key) + and collect (car more))) (defun plist-keys (plist &key test) (loop for (key . more) on plist by #'cddr - if (null more) do - (error "Not a property list: ~S" plist) - else if (or (null test) (funcall test key)) - collect key)) + if (null more) do + (error "Not a property list: ~S" plist) + else if (or (null test) (funcall test key)) + collect key)) (defun plist-values (plist &key test) (loop for (key . more) on plist by #'cddr - if (null more) do - (error "Not a property list: ~S" plist) - else if (or (null test) (funcall test (car more))) - collect (car more))) + if (null more) do + (error "Not a property list: ~S" plist) + else if (or (null test) (funcall test (car more))) + collect (car more))) (defun constant-symbol-p (form) (and (constantp form) (let ((constant (eval form))) - (and (symbolp constant) - (not (null (symbol-package constant))))))) + (and (symbolp constant) + (not (null (symbol-package constant))))))) ;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just ;;; collecting the defaulted initargs for the call. @@ -128,11 +128,11 @@ (when (or force-p (ctor-class ctor)) (setf (ctor-class ctor) nil) (setf (funcallable-instance-fun ctor) - #'(instance-lambda (&rest args) - (install-optimized-constructor ctor) - (apply ctor args))) + #'(instance-lambda (&rest args) + (install-optimized-constructor ctor) + (apply ctor args))) (setf (%funcallable-instance-info ctor 1) - (ctor-function-name ctor)))) + (ctor-function-name ctor)))) (defun make-ctor-function-name (class-name initargs) (list* 'ctor class-name initargs)) @@ -165,66 +165,66 @@ (destructuring-bind (fn class-name &rest args) form (declare (ignore fn)) (flet (;; - ;; Return the name of parameter number I of a constructor - ;; function. - (parameter-name (i) - (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) - (if (array-in-bounds-p ps i) - (aref ps i) - (format-symbol *pcl-package* ".P~D." i)))) - ;; Check if CLASS-NAME is a constant symbol. Give up if - ;; not. - (check-class () - (unless (and class-name (constant-symbol-p class-name)) - (return-from make-instance->constructor-call nil))) - ;; Check if ARGS are suitable for an optimized constructor. - ;; Return NIL from the outer function if not. - (check-args () - (loop for (key . more) on args by #'cddr do - (when (or (null more) - (not (constant-symbol-p key)) - (eq :allow-other-keys (eval key))) - (return-from make-instance->constructor-call nil))))) + ;; Return the name of parameter number I of a constructor + ;; function. + (parameter-name (i) + (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) + (if (array-in-bounds-p ps i) + (aref ps i) + (format-symbol *pcl-package* ".P~D." i)))) + ;; Check if CLASS-NAME is a constant symbol. Give up if + ;; not. + (check-class () + (unless (and class-name (constant-symbol-p class-name)) + (return-from make-instance->constructor-call nil))) + ;; Check if ARGS are suitable for an optimized constructor. + ;; Return NIL from the outer function if not. + (check-args () + (loop for (key . more) on args by #'cddr do + (when (or (null more) + (not (constant-symbol-p key)) + (eq :allow-other-keys (eval key))) + (return-from make-instance->constructor-call nil))))) (check-class) (check-args) ;; Collect a plist of initargs and constant values/parameter names ;; in INITARGS. Collect non-constant initialization forms in ;; VALUE-FORMS. (multiple-value-bind (initargs value-forms) - (loop for (key value) on args by #'cddr and i from 0 - collect (eval key) into initargs - if (constantp value) - collect value into initargs - else - collect (parameter-name i) into initargs - and collect value into value-forms - finally - (return (values initargs value-forms))) - (let* ((class-name (eval class-name)) - (function-name (make-ctor-function-name class-name initargs))) - ;; Prevent compiler warnings for calling the ctor. - (proclaim-as-fun-name function-name) - (note-name-defined function-name :function) - (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 - ;; optimized constructor function. - `(locally - (declare (disable-package-locks ,function-name)) - (let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs)))) - (declare (ignore .x.)) - ;; ??? check if this is worth it. - (declare - (ftype (or (function ,(make-list (length value-forms) - :initial-element t) - t) - (function (&rest t) t)) - ,function-name)) - (funcall (function ,function-name) ,@value-forms)))))))) + (loop for (key value) on args by #'cddr and i from 0 + collect (eval key) into initargs + if (constantp value) + collect value into initargs + else + collect (parameter-name i) into initargs + and collect value into value-forms + finally + (return (values initargs value-forms))) + (let* ((class-name (eval class-name)) + (function-name (make-ctor-function-name class-name initargs))) + ;; Prevent compiler warnings for calling the ctor. + (proclaim-as-fun-name function-name) + (note-name-defined function-name :function) + (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 + ;; optimized constructor function. + `(locally + (declare (disable-package-locks ,function-name)) + (let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-name ',initargs)))) + (declare (ignore .x.)) + ;; ??? check if this is worth it. + (declare + (ftype (or (function ,(make-list (length value-forms) + :initial-element t) + t) + (function (&rest t) t)) + ,function-name)) + (funcall (function ,function-name) ,@value-forms)))))))) ;;; ************************************************** @@ -245,109 +245,109 @@ (setf (ctor-class ctor) class) (pushnew ctor (plist-value class 'ctors)) (setf (funcallable-instance-fun ctor) - ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL - ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't - ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA - ;; expressions. The below should be equivalent, since we - ;; have a compiler-only implementation. - ;; - ;; (except maybe for optimization qualities? -- CSR, - ;; 2004-07-12) - (eval `(function ,(constructor-function-form ctor)))))) - + ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL + ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't + ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA + ;; expressions. The below should be equivalent, since we + ;; have a compiler-only implementation. + ;; + ;; (except maybe for optimization qualities? -- CSR, + ;; 2004-07-12) + (eval `(function ,(constructor-function-form ctor)))))) + (defun constructor-function-form (ctor) (let* ((class (ctor-class ctor)) - (proto (class-prototype class)) + (proto (class-prototype class)) (make-instance-methods - (compute-applicable-methods #'make-instance (list class))) + (compute-applicable-methods #'make-instance (list class))) (allocate-instance-methods - (compute-applicable-methods #'allocate-instance (list class))) - ;; I stared at this in confusion for a while, thinking - ;; carefully about the possibility of the class prototype not - ;; being of sufficient discrimiating power, given the - ;; possibility of EQL-specialized methods on - ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given - ;; that this is a constructor optimization, the user doesn't - ;; yet have the instance to create a method with such an EQL - ;; specializer. - ;; - ;; There remains the (theoretical) possibility of someone - ;; coming along with code of the form - ;; - ;; (defmethod initialize-instance :before ((o foo) ...) - ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...))) - ;; - ;; but probably we can afford not to worry about this too - ;; much for now. -- CSR, 2004-07-12 + (compute-applicable-methods #'allocate-instance (list class))) + ;; I stared at this in confusion for a while, thinking + ;; carefully about the possibility of the class prototype not + ;; being of sufficient discrimiating power, given the + ;; possibility of EQL-specialized methods on + ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given + ;; that this is a constructor optimization, the user doesn't + ;; yet have the instance to create a method with such an EQL + ;; specializer. + ;; + ;; There remains the (theoretical) possibility of someone + ;; coming along with code of the form + ;; + ;; (defmethod initialize-instance :before ((o foo) ...) + ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...))) + ;; + ;; but probably we can afford not to worry about this too + ;; much for now. -- CSR, 2004-07-12 (ii-methods - (compute-applicable-methods #'initialize-instance (list proto))) + (compute-applicable-methods #'initialize-instance (list proto))) (si-methods - (compute-applicable-methods #'shared-initialize (list proto t))) - (setf-svuc-slots-methods - (loop for slot in (class-slots class) - collect (compute-applicable-methods - #'(setf slot-value-using-class) - (list nil class proto slot)))) - (sbuc-slots-methods - (loop for slot in (class-slots class) - collect (compute-applicable-methods - #'slot-boundp-using-class - (list class proto slot))))) + (compute-applicable-methods #'shared-initialize (list proto t))) + (setf-svuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'(setf slot-value-using-class) + (list nil class proto slot)))) + (sbuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'slot-boundp-using-class + (list class proto slot))))) ;; Cannot initialize these variables earlier because the generic ;; functions don't exist when PCL is built. (when (null *the-system-si-method*) (setq *the-system-si-method* - (find-method #'shared-initialize - () (list *the-class-slot-object* *the-class-t*))) + (find-method #'shared-initialize + () (list *the-class-slot-object* *the-class-t*))) (setq *the-system-ii-method* - (find-method #'initialize-instance - () (list *the-class-slot-object*)))) + (find-method #'initialize-instance + () (list *the-class-slot-object*)))) ;; Note that when there are user-defined applicable methods on ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up ;; together with the system-defined ones in what ;; COMPUTE-APPLICABLE-METHODS returns. (or (and (not (structure-class-p class)) - (not (condition-class-p class)) - (null (cdr make-instance-methods)) - (null (cdr allocate-instance-methods)) - (every (lambda (x) - (member (slot-definition-allocation x) - '(:instance :class))) - (class-slots class)) - (null (check-initargs-1 + (not (condition-class-p class)) + (null (cdr make-instance-methods)) + (null (cdr allocate-instance-methods)) + (every (lambda (x) + (member (slot-definition-allocation x) + '(:instance :class))) + (class-slots class)) + (null (check-initargs-1 class (append (ctor-default-initkeys (ctor-initargs ctor) (class-default-initargs class)) (plist-keys (ctor-initargs ctor))) (append ii-methods si-methods) nil nil)) - (not (around-or-nonstandard-primary-method-p - ii-methods *the-system-ii-method*)) - (not (around-or-nonstandard-primary-method-p - si-methods *the-system-si-method*)) - ;; the instance structure protocol goes through - ;; slot-value(-using-class) and friends (actually just - ;; (SETF SLOT-VALUE-USING-CLASS) and - ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard - ;; applicable methods we can't shortcircuit them. - (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) - (every (lambda (x) (= (length x) 1)) sbuc-slots-methods) - (optimizing-generator ctor ii-methods si-methods)) - (fallback-generator ctor ii-methods si-methods)))) + (not (around-or-nonstandard-primary-method-p + ii-methods *the-system-ii-method*)) + (not (around-or-nonstandard-primary-method-p + si-methods *the-system-si-method*)) + ;; the instance structure protocol goes through + ;; slot-value(-using-class) and friends (actually just + ;; (SETF SLOT-VALUE-USING-CLASS) and + ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard + ;; applicable methods we can't shortcircuit them. + (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) + (every (lambda (x) (= (length x) 1)) sbuc-slots-methods) + (optimizing-generator ctor ii-methods si-methods)) + (fallback-generator ctor ii-methods si-methods)))) (defun around-or-nonstandard-primary-method-p (methods &optional standard-method) (loop with primary-checked-p = nil - for method in methods - as qualifiers = (method-qualifiers method) - when (or (eq :around (car qualifiers)) - (and (null qualifiers) - (not primary-checked-p) - (not (null standard-method)) - (not (eq standard-method method)))) - return t - when (null qualifiers) do - (setq primary-checked-p t))) + for method in methods + as qualifiers = (method-qualifiers method) + when (or (eq :around (car qualifiers)) + (and (null qualifiers) + (not primary-checked-p) + (not (null standard-method)) + (not (eq standard-method method)))) + return t + when (null qualifiers) do + (setq primary-checked-p t))) (defun fallback-generator (ctor ii-methods si-methods) (declare (ignore ii-methods si-methods)) @@ -374,24 +374,24 @@ ;;; vector around BODY. (defun wrap-in-allocate-forms (ctor body before-method-p) (let* ((class (ctor-class ctor)) - (wrapper (class-wrapper class)) - (allocation-function (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class))) + (wrapper (class-wrapper class)) + (allocation-function (raw-instance-allocator class)) + (slots-fetcher (slots-fetcher class))) (if (eq allocation-function 'allocate-standard-instance) - `(let ((.instance. (%make-standard-instance nil - (get-instance-hash-code))) - (.slots. (make-array - ,(layout-length wrapper) - ,@(when before-method-p - '(:initial-element +slot-unbound+))))) - (setf (std-instance-wrapper .instance.) ,wrapper) - (setf (std-instance-slots .instance.) .slots.) - ,body - .instance.) - `(let* ((.instance. (,allocation-function ,wrapper)) - (.slots. (,slots-fetcher .instance.))) - ,body - .instance.)))) + `(let ((.instance. (%make-standard-instance nil + (get-instance-hash-code))) + (.slots. (make-array + ,(layout-length wrapper) + ,@(when before-method-p + '(:initial-element +slot-unbound+))))) + (setf (std-instance-wrapper .instance.) ,wrapper) + (setf (std-instance-slots .instance.) .slots.) + ,body + .instance.) + `(let* ((.instance. (,allocation-function ,wrapper)) + (.slots. (,slots-fetcher .instance.))) + ,body + .instance.)))) ;;; Return a form for invoking METHOD with arguments from ARGS. As ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method @@ -409,31 +409,31 @@ (standard-sort-methods ii-methods) (declare (ignore ii-primary)) (multiple-value-bind (si-around si-before si-primary si-after) - (standard-sort-methods si-methods) + (standard-sort-methods si-methods) (declare (ignore si-primary)) (aver (and (null ii-around) (null si-around))) (let ((initargs (ctor-initargs ctor))) (multiple-value-bind (bindings vars defaulting-initargs body) - (slot-init-forms ctor (or ii-before si-before)) - (values + (slot-init-forms ctor (or ii-before si-before)) + (values `(let ,bindings (declare (ignorable ,@vars)) (let (,@(when (or ii-before ii-after) `((.ii-args. (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs)))) ,@(when (or si-before si-after) - `((.si-args. + `((.si-args. (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs))))) - ,@(loop for method in ii-before - collect `(invoke-method ,method .ii-args.)) - ,@(loop for method in si-before - collect `(invoke-method ,method .si-args.)) - ,@body - ,@(loop for method in si-after - collect `(invoke-method ,method .si-args.)) - ,@(loop for method in ii-after - collect `(invoke-method ,method .ii-args.)))) - (or ii-before si-before))))))) + ,@(loop for method in ii-before + collect `(invoke-method ,method .ii-args.)) + ,@(loop for method in si-before + collect `(invoke-method ,method .si-args.)) + ,@body + ,@(loop for method in si-after + collect `(invoke-method ,method .si-args.)) + ,@(loop for method in ii-after + collect `(invoke-method ,method .ii-args.)))) + (or ii-before si-before))))))) ;;; Return four values from APPLICABLE-METHODS: around methods, before ;;; methods, the applicable primary method, and applicable after @@ -441,17 +441,17 @@ ;;; must be called. (defun standard-sort-methods (applicable-methods) (loop for method in applicable-methods - as qualifiers = (method-qualifiers method) - if (null qualifiers) - collect method into primary - else if (eq :around (car qualifiers)) - collect method into around - else if (eq :after (car qualifiers)) - collect method into after - else if (eq :before (car qualifiers)) - collect method into before - finally - (return (values around before (first primary) (reverse after))))) + as qualifiers = (method-qualifiers method) + if (null qualifiers) + collect method into primary + else if (eq :around (car qualifiers)) + collect method into around + else if (eq :after (car qualifiers)) + collect method into after + else if (eq :before (car qualifiers)) + collect method into before + finally + (return (values around before (first primary) (reverse after))))) ;;; Return as multiple values bindings for default initialization ;;; arguments, variable names, defaulting initargs and a body for @@ -463,53 +463,53 @@ ;;; that we have to check if these before-methods have set slots. (defun slot-init-forms (ctor before-method-p) (let* ((class (ctor-class ctor)) - (initargs (ctor-initargs ctor)) - (initkeys (plist-keys initargs)) - (slot-vector - (make-array (layout-length (class-wrapper class)) - :initial-element nil)) - (class-inits ()) - (default-inits ()) + (initargs (ctor-initargs ctor)) + (initkeys (plist-keys initargs)) + (slot-vector + (make-array (layout-length (class-wrapper class)) + :initial-element nil)) + (class-inits ()) + (default-inits ()) (defaulting-initargs ()) - (default-initargs (class-default-initargs class)) - (initarg-locations - (compute-initarg-locations - class (append initkeys (mapcar #'car default-initargs))))) + (default-initargs (class-default-initargs class)) + (initarg-locations + (compute-initarg-locations + class (append initkeys (mapcar #'car default-initargs))))) (labels ((initarg-locations (initarg) - (cdr (assoc initarg initarg-locations :test #'eq))) - (initializedp (location) - (cond - ((consp location) - (assoc location class-inits :test #'eq)) - ((integerp location) - (not (null (aref slot-vector location)))) - (t (bug "Weird location in ~S" 'slot-init-forms)))) - (class-init (location type val) - (aver (consp location)) - (unless (initializedp location) - (push (list location type val) class-inits))) - (instance-init (location type val) - (aver (integerp location)) - (unless (initializedp location) - (setf (aref slot-vector location) (list type val)))) - (default-init-var-name (i) - (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) - (if (array-in-bounds-p ps i) - (aref ps i) - (format-symbol *pcl-package* ".D~D." i))))) + (cdr (assoc initarg initarg-locations :test #'eq))) + (initializedp (location) + (cond + ((consp location) + (assoc location class-inits :test #'eq)) + ((integerp location) + (not (null (aref slot-vector location)))) + (t (bug "Weird location in ~S" 'slot-init-forms)))) + (class-init (location type val) + (aver (consp location)) + (unless (initializedp location) + (push (list location type val) class-inits))) + (instance-init (location type val) + (aver (integerp location)) + (unless (initializedp location) + (setf (aref slot-vector location) (list type val)))) + (default-init-var-name (i) + (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) + (if (array-in-bounds-p ps i) + (aref ps i) + (format-symbol *pcl-package* ".D~D." i))))) ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr - as locations = (initarg-locations key) do - (if (constantp value) - (dolist (location locations) - (if (consp location) - (class-init location 'constant value) - (instance-init location 'constant value))) - (dolist (location locations) - (if (consp location) - (class-init location 'param value) - (instance-init location 'param value))))) + as locations = (initarg-locations key) do + (if (constantp value) + (dolist (location locations) + (if (consp location) + (class-init location 'constant value) + (instance-init location 'constant value))) + (dolist (location locations) + (if (consp location) + (class-init location 'param value) + (instance-init location 'param value))))) ;; Loop over default initargs of the class, recording ;; initializations of slots that have not been initialized ;; above. Default initargs which are not in the supplied @@ -517,9 +517,9 @@ ;; initargs, that is, their values must be evaluated even ;; if not actually used for initializing a slot. (loop for (key initform initfn) in default-initargs and i from 0 - unless (member key initkeys :test #'eq) do - (let* ((type (if (constantp initform) 'constant 'var)) - (init (if (eq type 'var) initfn initform))) + unless (member key initkeys :test #'eq) do + (let* ((type (if (constantp initform) 'constant 'var)) + (init (if (eq type 'var) initfn initform))) (ecase type (constant (push key defaulting-initargs) @@ -527,69 +527,69 @@ (var (push key defaulting-initargs) (push (default-init-var-name i) defaulting-initargs))) - (when (eq type 'var) - (let ((init-var (default-init-var-name i))) - (setq init init-var) - (push (cons init-var initfn) default-inits))) - (dolist (location (initarg-locations key)) - (if (consp location) - (class-init location type init) - (instance-init location type init))))) + (when (eq type 'var) + (let ((init-var (default-init-var-name i))) + (setq init init-var) + (push (cons init-var initfn) default-inits))) + (dolist (location (initarg-locations key)) + (if (consp location) + (class-init location type init) + (instance-init location type init))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) - as location = (slot-definition-location slotd) - as allocation = (slot-definition-allocation slotd) - as initfn = (slot-definition-initfunction slotd) - as initform = (slot-definition-initform slotd) do - (unless (or (eq allocation :class) - (null initfn) - (initializedp location)) - (if (constantp initform) - (instance-init location 'initform initform) - (instance-init location 'initform/initfn initfn)))) + as location = (slot-definition-location slotd) + as allocation = (slot-definition-allocation slotd) + as initfn = (slot-definition-initfunction slotd) + as initform = (slot-definition-initform slotd) do + (unless (or (eq allocation :class) + (null initfn) + (initializedp location)) + (if (constantp initform) + (instance-init location 'initform initform) + (instance-init location 'initform/initfn initfn)))) ;; Generate the forms for initializing instance and class slots. (let ((instance-init-forms - (loop for slot-entry across slot-vector and i from 0 - as (type value) = slot-entry collect - (ecase type - ((nil) - (unless before-method-p - `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) - ((param var) - `(setf (clos-slots-ref .slots. ,i) ,value)) - (initfn - `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) - (initform/initfn - (if before-method-p - `(when (eq (clos-slots-ref .slots. ,i) - +slot-unbound+) - (setf (clos-slots-ref .slots. ,i) - (funcall ,value))) - `(setf (clos-slots-ref .slots. ,i) - (funcall ,value)))) - (initform - (if before-method-p - `(when (eq (clos-slots-ref .slots. ,i) - +slot-unbound+) - (setf (clos-slots-ref .slots. ,i) - ',(eval value))) - `(setf (clos-slots-ref .slots. ,i) - ',(eval value)))) - (constant - `(setf (clos-slots-ref .slots. ,i) ',(eval value)))))) - (class-init-forms - (loop for (location type value) in class-inits collect - `(setf (cdr ',location) - ,(ecase type - (constant `',(eval value)) - ((param var) `,value) - (initfn `(funcall ,value))))))) - (multiple-value-bind (vars bindings) - (loop for (var . initfn) in (nreverse default-inits) - collect var into vars - collect `(,var (funcall ,initfn)) into bindings - finally (return (values vars bindings))) + (loop for slot-entry across slot-vector and i from 0 + as (type value) = slot-entry collect + (ecase type + ((nil) + (unless before-method-p + `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) + ((param var) + `(setf (clos-slots-ref .slots. ,i) ,value)) + (initfn + `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) + (initform/initfn + (if before-method-p + `(when (eq (clos-slots-ref .slots. ,i) + +slot-unbound+) + (setf (clos-slots-ref .slots. ,i) + (funcall ,value))) + `(setf (clos-slots-ref .slots. ,i) + (funcall ,value)))) + (initform + (if before-method-p + `(when (eq (clos-slots-ref .slots. ,i) + +slot-unbound+) + (setf (clos-slots-ref .slots. ,i) + ',(eval value))) + `(setf (clos-slots-ref .slots. ,i) + ',(eval value)))) + (constant + `(setf (clos-slots-ref .slots. ,i) ',(eval value)))))) + (class-init-forms + (loop for (location type value) in class-inits collect + `(setf (cdr ',location) + ,(ecase type + (constant `',(eval value)) + ((param var) `,value) + (initfn `(funcall ,value))))))) + (multiple-value-bind (vars bindings) + (loop for (var . initfn) in (nreverse default-inits) + collect var into vars + collect `(,var (funcall ,initfn)) into bindings + finally (return (values vars bindings))) (values bindings vars (nreverse defaulting-initargs) `(,@(delete nil instance-init-forms) ,@class-init-forms))))))) @@ -599,15 +599,15 @@ ;;; CLASS is the class of the instance being initialized. (defun compute-initarg-locations (class initkeys) (loop with slots = (class-slots class) - for key in initkeys collect - (loop for slot in slots - if (memq key (slot-definition-initargs slot)) - collect (slot-definition-location slot) into locations - else - collect slot into remaining-slots - finally - (setq slots remaining-slots) - (return (cons key locations))))) + for key in initkeys collect + (loop for slot in slots + if (memq key (slot-definition-initargs slot)) + collect (slot-definition-location slot) into locations + else + collect slot into remaining-slots + finally + (setq slots remaining-slots) + (return (cons key locations))))) ;;; ******************************* @@ -616,13 +616,13 @@ (defun update-ctors (reason &key class name generic-function method) (labels ((reset (class &optional ri-cache-p (ctorsp t)) - (when ctorsp - (dolist (ctor (plist-value class 'ctors)) - (install-initial-constructor ctor))) - (when ri-cache-p - (setf (plist-value class 'ri-initargs) ())) - (dolist (subclass (class-direct-subclasses class)) - (reset subclass ri-cache-p ctorsp)))) + (when ctorsp + (dolist (ctor (plist-value class 'ctors)) + (install-initial-constructor ctor))) + (when ri-cache-p + (setf (plist-value class 'ri-initargs) ())) + (dolist (subclass (class-direct-subclasses class)) + (reset subclass ri-cache-p ctorsp)))) (ecase reason ;; CLASS must have been specified. (finalize-inheritance @@ -630,56 +630,56 @@ ;; NAME must have been specified. (setf-find-class (loop for ctor in *all-ctors* - when (eq (ctor-class-name ctor) name) do - (when (ctor-class ctor) - (reset (ctor-class ctor))) - (loop-finish))) + when (eq (ctor-class-name ctor) name) do + (when (ctor-class ctor) + (reset (ctor-class ctor))) + (loop-finish))) ;; GENERIC-FUNCTION and METHOD must have been specified. ((add-method remove-method) (flet ((class-of-1st-method-param (method) - (type-class (first (method-specializers method))))) - (case (generic-function-name generic-function) - ((make-instance allocate-instance - initialize-instance shared-initialize) - (reset (class-of-1st-method-param method) t t)) - ((reinitialize-instance) - (reset (class-of-1st-method-param method) t nil)) - (t (when (or (eq (generic-function-name generic-function) - 'slot-boundp-using-class) - (equal (generic-function-name generic-function) - '(setf slot-value-using-class))) - ;; this looks awfully expensive, but given that one - ;; can specialize on the SLOTD argument, nothing is - ;; safe. -- CSR, 2004-07-12 - (reset (find-class 'standard-object)))))))))) + (type-class (first (method-specializers method))))) + (case (generic-function-name generic-function) + ((make-instance allocate-instance + initialize-instance shared-initialize) + (reset (class-of-1st-method-param method) t t)) + ((reinitialize-instance) + (reset (class-of-1st-method-param method) t nil)) + (t (when (or (eq (generic-function-name generic-function) + 'slot-boundp-using-class) + (equal (generic-function-name generic-function) + '(setf slot-value-using-class))) + ;; this looks awfully expensive, but given that one + ;; can specialize on the SLOTD argument, nothing is + ;; safe. -- CSR, 2004-07-12 + (reset (find-class 'standard-object)))))))))) (defun precompile-ctors () (dolist (ctor *all-ctors*) (when (null (ctor-class ctor)) (let ((class (find-class (ctor-class-name ctor) nil))) - (when (and class (class-finalized-p class)) - (install-optimized-constructor ctor)))))) + (when (and class (class-finalized-p class)) + (install-optimized-constructor ctor)))))) (defun check-ri-initargs (instance initargs) (let* ((class (class-of instance)) - (keys (plist-keys initargs)) - (cached (assoc keys (plist-value class 'ri-initargs) - :test #'equal)) - (invalid-keys - (if (consp cached) - (cdr cached) - (let ((invalid - ;; FIXME: give CHECK-INITARGS-1 and friends a - ;; more mnemonic name and (possibly) a nicer, - ;; more orthogonal interface. - (check-initargs-1 - class initargs - (list (list* 'reinitialize-instance instance initargs) - (list* 'shared-initialize instance nil initargs)) - t nil))) - (setf (plist-value class 'ri-initargs) - (acons keys invalid cached)) - invalid)))) + (keys (plist-keys initargs)) + (cached (assoc keys (plist-value class 'ri-initargs) + :test #'equal)) + (invalid-keys + (if (consp cached) + (cdr cached) + (let ((invalid + ;; FIXME: give CHECK-INITARGS-1 and friends a + ;; more mnemonic name and (possibly) a nicer, + ;; more orthogonal interface. + (check-initargs-1 + class initargs + (list (list* 'reinitialize-instance instance initargs) + (list* 'shared-initialize instance nil initargs)) + t nil))) + (setf (plist-value class 'ri-initargs) + (acons keys invalid cached)) + invalid)))) (when invalid-keys (error 'initarg-error :class class :initargs invalid-keys)))) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index e4277f9..c07a4ee 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -109,7 +109,7 @@ ;; full-blown class, so the "a class of this name is ;; coming" note we write here would be irrelevant. (eval-when (:compile-toplevel) - (%compiler-defclass ',name + (%compiler-defclass ',name ',*readers-for-this-defclass* ',*writers-for-this-defclass* ',*slot-names-for-this-defclass*)) @@ -120,10 +120,10 @@ (maplist (lambda (sublist) (let ((option-name (first (pop sublist)))) (when (member option-name sublist :key #'first) - (error "Multiple ~S options in DEFCLASS ~S." + (error "Multiple ~S options in DEFCLASS ~S." option-name class-name)))) options) - (let (metaclass + (let (metaclass default-initargs documentation canonized-options) @@ -131,7 +131,7 @@ (unless (listp option) (error "~S is not a legal defclass option." option)) (case (first option) - (:metaclass + (:metaclass (let ((maybe-metaclass (second option))) (unless (and maybe-metaclass (legal-class-name-p maybe-metaclass)) (error "~@" + DEFCLASS ~S.~:>" :format-arguments (list key class-name))) (push key arg-names) (push ``(,',key ,',val ,,(make-initfunction val)) initargs)) (setf default-initargs t) - (push `(:direct-default-initargs (list ,@(nreverse initargs))) + (push `(:direct-default-initargs (list ,@(nreverse initargs))) canonized-options))) (:documentation (unless (stringp (second option)) @@ -185,9 +185,9 @@ (push name *slot-names-for-this-defclass*) (flet ((note-reader (x) (unless (symbolp x) - (error 'simple-program-error + (error 'simple-program-error :format-control "Slot reader name ~S for slot ~S in ~ - DEFCLASS ~S is not a symbol." + DEFCLASS ~S is not a symbol." :format-arguments (list x name class-name))) (push x readers) (push x *readers-for-this-defclass*)) @@ -201,7 +201,7 @@ (:writer (note-writer val)) (:initarg (unless (symbolp val) - (error 'simple-program-error + (error 'simple-program-error :format-control "Slot initarg name ~S for slot ~S in ~ DEFCLASS ~S is not a symbol." :format-arguments (list val name class-name))) @@ -211,9 +211,9 @@ (when (eq key :initform) (setf initform val)) (when (get-properties others (list key)) - (error 'simple-program-error + (error 'simple-program-error :format-control "Duplicate slot option ~S for slot ~ - ~S in DEFCLASS ~S." + ~S in DEFCLASS ~S." :format-arguments (list key name class-name)))) ;; For non-standard options multiple entries go in a list (push val (getf others key)))))) @@ -246,29 +246,29 @@ ((constantp name env) (slot-name-illegal "a constant")) ((member name *slot-names-for-this-defclass*) - (error 'simple-program-error + (error 'simple-program-error :format-control "Multiple slots named ~S in DEFCLASS ~S." :format-arguments (list name class-name)))))) (defun make-initfunction (initform) (cond ((or (eq initform t) - (equal initform ''t)) - '(function constantly-t)) - ((or (eq initform nil) - (equal initform ''nil)) - '(function constantly-nil)) - ((or (eql initform 0) - (equal initform ''0)) - '(function constantly-0)) - (t - (let ((entry (assoc initform *initfunctions-for-this-defclass* - :test #'equal))) - (unless entry - (setq entry (list initform - (gensym) - `(function (lambda () ,initform)))) - (push entry *initfunctions-for-this-defclass*)) - (cadr entry))))) + (equal initform ''t)) + '(function constantly-t)) + ((or (eq initform nil) + (equal initform ''nil)) + '(function constantly-nil)) + ((or (eql initform 0) + (equal initform ''0)) + '(function constantly-0)) + (t + (let ((entry (assoc initform *initfunctions-for-this-defclass* + :test #'equal))) + (unless entry + (setq entry (list initform + (gensym) + `(function (lambda () ,initform)))) + (push entry *initfunctions-for-this-defclass*)) + (cadr entry))))) (defun %compiler-defclass (name readers writers slots) ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it @@ -328,10 +328,10 @@ (defun make-early-class-definition (name source metaclass - superclass-names canonical-slots other-initargs) + superclass-names canonical-slots other-initargs) (list 'early-class-definition - name source metaclass - superclass-names canonical-slots other-initargs)) + name source metaclass + superclass-names canonical-slots other-initargs)) (defun ecd-class-name (ecd) (nth 1 ecd)) (defun ecd-source (ecd) (nth 2 ecd)) @@ -347,11 +347,11 @@ (defun early-class-slots (class-name) (cdr (or (assoc class-name *early-class-slots*) - (let ((a (cons class-name - (mapcar #'canonical-slot-name - (early-collect-inheritance class-name))))) - (push a *early-class-slots*) - a)))) + (let ((a (cons class-name + (mapcar #'canonical-slot-name + (early-collect-inheritance class-name))))) + (push a *early-class-slots*) + a)))) (defun early-class-size (class-name) (length (early-class-slots class-name))) @@ -360,50 +360,50 @@ ;;(declare (values slots cpl default-initargs direct-subclasses)) (let ((cpl (early-collect-cpl class-name))) (values (early-collect-slots cpl) - cpl - (early-collect-default-initargs cpl) - (let (collect) - (dolist (definition *early-class-definitions*) - (when (memq class-name (ecd-superclass-names definition)) - (push (ecd-class-name definition) collect))) + cpl + (early-collect-default-initargs cpl) + (let (collect) + (dolist (definition *early-class-definitions*) + (when (memq class-name (ecd-superclass-names definition)) + (push (ecd-class-name definition) collect))) (nreverse collect))))) (defun early-collect-slots (cpl) (let* ((definitions (mapcar #'early-class-definition cpl)) - (super-slots (mapcar #'ecd-canonical-slots definitions)) - (slots (apply #'append (reverse super-slots)))) + (super-slots (mapcar #'ecd-canonical-slots definitions)) + (slots (apply #'append (reverse super-slots)))) (dolist (s1 slots) (let ((name1 (canonical-slot-name s1))) - (dolist (s2 (cdr (memq s1 slots))) - (when (eq name1 (canonical-slot-name s2)) - (error "More than one early class defines a slot with the~%~ - name ~S. This can't work because the bootstrap~%~ - object system doesn't know how to compute effective~%~ - slots." - name1))))) + (dolist (s2 (cdr (memq s1 slots))) + (when (eq name1 (canonical-slot-name s2)) + (error "More than one early class defines a slot with the~%~ + name ~S. This can't work because the bootstrap~%~ + object system doesn't know how to compute effective~%~ + slots." + name1))))) slots)) (defun early-collect-cpl (class-name) (labels ((walk (c) - (let* ((definition (early-class-definition c)) - (supers (ecd-superclass-names definition))) - (cons c - (apply #'append (mapcar #'early-collect-cpl supers)))))) + (let* ((definition (early-class-definition c)) + (supers (ecd-superclass-names definition))) + (cons c + (apply #'append (mapcar #'early-collect-cpl supers)))))) (remove-duplicates (walk class-name) :from-end nil :test #'eq))) (defun early-collect-default-initargs (cpl) (let ((default-initargs ())) (dolist (class-name cpl) (let* ((definition (early-class-definition class-name)) - (others (ecd-other-initargs definition))) - (loop (when (null others) (return nil)) - (let ((initarg (pop others))) - (unless (eq initarg :direct-default-initargs) - (error "~@" - initarg))) - (setq default-initargs - (nconc default-initargs (reverse (pop others))))))) + (others (ecd-other-initargs definition))) + (loop (when (null others) (return nil)) + (let ((initarg (pop others))) + (unless (eq initarg :direct-default-initargs) + (error "~@" + initarg))) + (setq default-initargs + (nconc default-initargs (reverse (pop others))))))) (reverse default-initargs))) (defun !bootstrap-slot-index (class-name slot-name) @@ -427,7 +427,7 @@ ;;; by the full object system later. (defmacro !bootstrap-get-slot (type object slot-name) `(clos-slots-ref (get-slots ,object) - (!bootstrap-slot-index ,type ,slot-name))) + (!bootstrap-slot-index ,type ,slot-name))) (defun !bootstrap-set-slot (type object slot-name new-value) (setf (!bootstrap-get-slot type object slot-name) new-value)) @@ -454,7 +454,7 @@ (unless (fboundp 'class-name-of) (setf (symbol-function 'class-name-of) - (symbol-function 'early-class-name-of))) + (symbol-function 'early-class-name-of))) (unintern 'early-class-name-of) (defun early-class-direct-subclasses (class) @@ -465,17 +465,17 @@ readers writers slot-names) (%compiler-defclass name readers writers slot-names) (setq supers (copy-tree supers) - canonical-slots (copy-tree canonical-slots) - canonical-options (copy-tree canonical-options)) + canonical-slots (copy-tree canonical-slots) + canonical-options (copy-tree canonical-options)) (let ((ecd - (make-early-class-definition name - *load-pathname* - metaclass - supers - canonical-slots - canonical-options)) - (existing - (find name *early-class-definitions* :key #'ecd-class-name))) + (make-early-class-definition name + *load-pathname* + metaclass + supers + canonical-slots + canonical-options)) + (existing + (find name *early-class-definitions* :key #'ecd-class-name))) (setq *early-class-definitions* - (cons ecd (remove existing *early-class-definitions*))) + (cons ecd (remove existing *early-class-definitions*))) ecd)) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index ecda4e6..46f0677 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -27,11 +27,11 @@ (declare (ignore args)) `(progn (with-single-package-locked-error - (:symbol ',(second form) "defining ~A as a method combination")) + (:symbol ',(second form) "defining ~A as a method combination")) ,(if (and (cddr form) - (listp (caddr form))) - (expand-long-defcombin form) - (expand-short-defcombin form)))) + (listp (caddr form))) + (expand-long-defcombin form) + (expand-short-defcombin form)))) ;;;; standard method combination @@ -42,8 +42,8 @@ ;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping ;;; reasons. (defmethod find-method-combination ((generic-function generic-function) - (type (eql 'standard)) - options) + (type (eql 'standard)) + options) (when options (method-combination-error "The method combination type STANDARD accepts no options.")) @@ -67,38 +67,38 @@ (defun expand-short-defcombin (whole) (let* ((type (cadr whole)) - (documentation - (getf (cddr whole) :documentation "")) - (identity-with-one-arg - (getf (cddr whole) :identity-with-one-argument nil)) - (operator - (getf (cddr whole) :operator type))) + (documentation + (getf (cddr whole) :documentation "")) + (identity-with-one-arg + (getf (cddr whole) :identity-with-one-argument nil)) + (operator + (getf (cddr whole) :operator type))) `(load-short-defcombin ',type ',operator ',identity-with-one-arg ',documentation))) (defun load-short-defcombin (type operator ioa doc) (let* ((pathname *load-pathname*) - (specializers - (list (find-class 'generic-function) - (intern-eql-specializer type) - *the-class-t*)) - (old-method - (get-method #'find-method-combination () specializers nil)) - (new-method nil)) + (specializers + (list (find-class 'generic-function) + (intern-eql-specializer type) + *the-class-t*)) + (old-method + (get-method #'find-method-combination () specializers nil)) + (new-method nil)) (setq new-method - (make-instance 'standard-method - :qualifiers () - :specializers specializers - :lambda-list '(generic-function type options) - :function (lambda (args nms &rest cm-args) - (declare (ignore nms cm-args)) - (apply - (lambda (gf type options) - (declare (ignore gf)) - (short-combine-methods - type options operator ioa new-method doc)) - args)) - :definition-source `((define-method-combination ,type) ,pathname))) + (make-instance 'standard-method + :qualifiers () + :specializers specializers + :lambda-list '(generic-function type options) + :function (lambda (args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + (lambda (gf type options) + (declare (ignore gf)) + (short-combine-methods + type options operator ioa new-method doc)) + args)) + :definition-source `((define-method-combination ,type) ,pathname))) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) @@ -107,154 +107,154 @@ (defun short-combine-methods (type options operator ioa method doc) (cond ((null options) (setq options '(:most-specific-first))) - ((equal options '(:most-specific-first))) - ((equal options '(:most-specific-last))) - (t - (method-combination-error - "Illegal options to a short method combination type.~%~ - The method combination type ~S accepts one option which~%~ - must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." - type))) + ((equal options '(:most-specific-first))) + ((equal options '(:most-specific-last))) + (t + (method-combination-error + "Illegal options to a short method combination type.~%~ + The method combination type ~S accepts one option which~%~ + must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." + type))) (make-instance 'short-method-combination - :type type - :options options - :operator operator - :identity-with-one-argument ioa - :definition-source method - :documentation doc)) + :type type + :options options + :operator operator + :identity-with-one-argument ioa + :definition-source method + :documentation doc)) (defmethod compute-effective-method ((generic-function generic-function) - (combin short-method-combination) - applicable-methods) + (combin short-method-combination) + applicable-methods) (let ((type (method-combination-type combin)) - (operator (short-combination-operator combin)) - (ioa (short-combination-identity-with-one-argument combin)) - (order (car (method-combination-options combin))) - (around ()) - (primary ())) + (operator (short-combination-operator combin)) + (ioa (short-combination-identity-with-one-argument combin)) + (order (car (method-combination-options combin))) + (around ()) + (primary ())) (flet ((invalid (gf combin m) - (return-from compute-effective-method - `(%invalid-qualifiers ',gf ',combin ',m)))) + (return-from compute-effective-method + `(%invalid-qualifiers ',gf ',combin ',m)))) (dolist (m applicable-methods) - (let ((qualifiers (method-qualifiers m))) - (cond ((null qualifiers) (invalid generic-function combin m)) - ((cdr qualifiers) (invalid generic-function combin m)) - ((eq (car qualifiers) :around) - (push m around)) - ((eq (car qualifiers) type) - (push m primary)) - (t (invalid generic-function combin m)))))) + (let ((qualifiers (method-qualifiers m))) + (cond ((null qualifiers) (invalid generic-function combin m)) + ((cdr qualifiers) (invalid generic-function combin m)) + ((eq (car qualifiers) :around) + (push m around)) + ((eq (car qualifiers) type) + (push m primary)) + (t (invalid generic-function combin m)))))) (setq around (nreverse around)) (ecase order (:most-specific-last) ; nothing to be done, already in correct order (:most-specific-first (setq primary (nreverse primary)))) (let ((main-method - (if (and (null (cdr primary)) - (not (null ioa))) - `(call-method ,(car primary) ()) - `(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) - primary))))) + (if (and (null (cdr primary)) + (not (null ioa))) + `(call-method ,(car primary) ()) + `(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) + primary))))) (cond ((null primary) - ;; As of sbcl-0.8.0.80 we don't seem to need to need - ;; to do anything messy like - ;; `(APPLY (FUNCTION (IF AROUND - ;; 'NO-PRIMARY-METHOD - ;; 'NO-APPLICABLE-METHOD) - ;; ',GENERIC-FUNCTION - ;; .ARGS.) - ;; here because (for reasons I don't understand at the - ;; moment -- WHN) control will never reach here if there - ;; are no applicable methods, but instead end up - ;; in NO-APPLICABLE-METHODS first. - ;; - ;; FIXME: The way that we arrange for .ARGS. to be bound - ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION - ;; recognizing any form whose operator is %NO-PRIMARY-METHOD - ;; as magical, and carefully surrounding it with a - ;; LAMBDA form which binds .ARGS. But... - ;; 1. That seems fragile, because the magicalness of - ;; %NO-PRIMARY-METHOD forms is scattered around - ;; the system. So it could easily be broken by - ;; locally-plausible maintenance changes like, - ;; e.g., using the APPLY expression above. - ;; 2. That seems buggy w.r.t. to MOPpish tricks in - ;; user code, e.g. - ;; (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...) - ;; `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*))) + ;; As of sbcl-0.8.0.80 we don't seem to need to need + ;; to do anything messy like + ;; `(APPLY (FUNCTION (IF AROUND + ;; 'NO-PRIMARY-METHOD + ;; 'NO-APPLICABLE-METHOD) + ;; ',GENERIC-FUNCTION + ;; .ARGS.) + ;; here because (for reasons I don't understand at the + ;; moment -- WHN) control will never reach here if there + ;; are no applicable methods, but instead end up + ;; in NO-APPLICABLE-METHODS first. + ;; + ;; FIXME: The way that we arrange for .ARGS. to be bound + ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION + ;; recognizing any form whose operator is %NO-PRIMARY-METHOD + ;; as magical, and carefully surrounding it with a + ;; LAMBDA form which binds .ARGS. But... + ;; 1. That seems fragile, because the magicalness of + ;; %NO-PRIMARY-METHOD forms is scattered around + ;; the system. So it could easily be broken by + ;; locally-plausible maintenance changes like, + ;; e.g., using the APPLY expression above. + ;; 2. That seems buggy w.r.t. to MOPpish tricks in + ;; user code, e.g. + ;; (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...) + ;; `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*))) `(%no-primary-method ',generic-function .args.)) - ((null around) main-method) - (t - `(call-method ,(car around) - (,@(cdr around) (make-method ,main-method)))))))) + ((null around) main-method) + (t + `(call-method ,(car around) + (,@(cdr around) (make-method ,main-method)))))))) (defmethod invalid-qualifiers ((gf generic-function) - (combin short-method-combination) - method) + (combin short-method-combination) + method) (let ((qualifiers (method-qualifiers method)) - (type (method-combination-type combin))) + (type (method-combination-type combin))) (let ((why (cond - ((null qualifiers) "has no qualifiers") - ((cdr qualifiers) "has too many qualifiers") - (t (aver (and (neq (car qualifiers) type) - (neq (car qualifiers) :around))) - "has an invalid qualifier")))) + ((null qualifiers) "has no qualifiers") + ((cdr qualifiers) "has too many qualifiers") + (t (aver (and (neq (car qualifiers) type) + (neq (car qualifiers) :around))) + "has an invalid qualifier")))) (invalid-method-error method "The method ~S on ~S ~A.~%~ - The method combination type ~S was defined with the~%~ - short form of DEFINE-METHOD-COMBINATION and so requires~%~ - all methods have either the single qualifier ~S or the~%~ - single qualifier :AROUND." + The method combination type ~S was defined with the~%~ + short form of DEFINE-METHOD-COMBINATION and so requires~%~ + all methods have either the single qualifier ~S or the~%~ + single qualifier :AROUND." method gf why type type)))) ;;;; long method combinations (defun expand-long-defcombin (form) (let ((type (cadr form)) - (lambda-list (caddr form)) - (method-group-specifiers (cadddr form)) - (body (cddddr form)) - (args-option ()) - (gf-var nil)) + (lambda-list (caddr form)) + (method-group-specifiers (cadddr form)) + (body (cddddr form)) + (args-option ()) + (gf-var nil)) (when (and (consp (car body)) (eq (caar body) :arguments)) (setq args-option (cdr (pop body)))) (when (and (consp (car body)) (eq (caar body) :generic-function)) (setq gf-var (cadr (pop body)))) (multiple-value-bind (documentation function) - (make-long-method-combination-function - type lambda-list method-group-specifiers args-option gf-var - body) + (make-long-method-combination-function + type lambda-list method-group-specifiers args-option gf-var + body) `(load-long-defcombin ',type ',documentation #',function - ',args-option)))) + ',args-option)))) (defvar *long-method-combination-functions* (make-hash-table :test 'eq)) (defun load-long-defcombin (type doc function args-lambda-list) (let* ((specializers - (list (find-class 'generic-function) - (intern-eql-specializer type) - *the-class-t*)) - (old-method - (get-method #'find-method-combination () specializers nil)) - (new-method - (make-instance 'standard-method - :qualifiers () - :specializers specializers - :lambda-list '(generic-function type options) - :function (lambda (args nms &rest cm-args) - (declare (ignore nms cm-args)) - (apply - (lambda (generic-function type options) - (declare (ignore generic-function)) - (make-instance 'long-method-combination - :type type - :options options - :args-lambda-list args-lambda-list - :documentation doc)) - args)) - :definition-source `((define-method-combination ,type) - ,*load-pathname*)))) + (list (find-class 'generic-function) + (intern-eql-specializer type) + *the-class-t*)) + (old-method + (get-method #'find-method-combination () specializers nil)) + (new-method + (make-instance 'standard-method + :qualifiers () + :specializers specializers + :lambda-list '(generic-function type options) + :function (lambda (args nms &rest cm-args) + (declare (ignore nms cm-args)) + (apply + (lambda (generic-function type options) + (declare (ignore generic-function)) + (make-instance 'long-method-combination + :type type + :options options + :args-lambda-list args-lambda-list + :documentation doc)) + args)) + :definition-source `((define-method-combination ,type) + ,*load-pathname*)))) (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) @@ -262,13 +262,13 @@ type)) (defmethod compute-effective-method ((generic-function generic-function) - (combin long-method-combination) - applicable-methods) + (combin long-method-combination) + applicable-methods) (funcall (gethash (method-combination-type combin) - *long-method-combination-functions*) - generic-function - combin - applicable-methods)) + *long-method-combination-functions*) + generic-function + combin + applicable-methods)) (defun make-long-method-combination-function (type ll method-group-specifiers args-option gf-var body) @@ -276,31 +276,31 @@ (multiple-value-bind (real-body declarations documentation) (parse-body body) (let ((wrapped-body - (wrap-method-group-specifier-bindings method-group-specifiers - declarations - real-body))) + (wrap-method-group-specifier-bindings method-group-specifiers + declarations + real-body))) (when gf-var - (push `(,gf-var .generic-function.) (cadr wrapped-body))) + (push `(,gf-var .generic-function.) (cadr wrapped-body))) (when args-option - (setq wrapped-body (deal-with-args-option wrapped-body args-option))) + (setq wrapped-body (deal-with-args-option wrapped-body args-option))) (when ll - (setq wrapped-body - `(apply #'(lambda ,ll ,wrapped-body) - (method-combination-options .method-combination.)))) + (setq wrapped-body + `(apply #'(lambda ,ll ,wrapped-body) + (method-combination-options .method-combination.)))) (values - documentation - `(lambda (.generic-function. .method-combination. .applicable-methods.) - (declare (ignorable .generic-function. - .method-combination. .applicable-methods.)) - (block .long-method-combination-function. ,wrapped-body)))))) + documentation + `(lambda (.generic-function. .method-combination. .applicable-methods.) + (declare (ignorable .generic-function. + .method-combination. .applicable-methods.)) + (block .long-method-combination-function. ,wrapped-body)))))) -(define-condition long-method-combination-error +(define-condition long-method-combination-error (reference-condition simple-error) () - (:default-initargs + (:default-initargs :references (list '(:ansi-cl :macro define-method-combination)))) ;;; NOTE: @@ -315,15 +315,15 @@ (defun group-cond-clause (name tests specializer-cache star-only) (let ((maybe-error-clause - (if star-only - `(setq ,specializer-cache .specializers.) - `(if (and (equal ,specializer-cache .specializers.) + (if star-only + `(setq ,specializer-cache .specializers.) + `(if (and (equal ,specializer-cache .specializers.) (not (null .specializers.))) (return-from .long-method-combination-function. '(error 'long-method-combination-error - :format-control "More than one method of type ~S ~ - with the same specializers." - :format-arguments (list ',name))) + :format-control "More than one method of type ~S ~ + with the same specializers." + :format-arguments (list ',name))) (setq ,specializer-cache .specializers.))))) `((or ,@tests) ,maybe-error-clause @@ -348,7 +348,7 @@ (push `(when (null ,name) (return-from .long-method-combination-function. '(error 'long-method-combination-error - :format-control "No ~S methods." + :format-control "No ~S methods." :format-arguments (list ',name)))) required-checks)) (loop (unless (and (constantp order) @@ -377,53 +377,53 @@ (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) (let* ((name (pop method-group-specifier)) - (patterns ()) - (tests - (let (collect) - (block collect-tests - (loop - (if (or (null method-group-specifier) - (memq (car method-group-specifier) - '(:description :order :required))) - (return-from collect-tests t) - (let ((pattern (pop method-group-specifier))) - (push pattern patterns) - (push (parse-qualifier-pattern name pattern) + (patterns ()) + (tests + (let (collect) + (block collect-tests + (loop + (if (or (null method-group-specifier) + (memq (car method-group-specifier) + '(:description :order :required))) + (return-from collect-tests t) + (let ((pattern (pop method-group-specifier))) + (push pattern patterns) + (push (parse-qualifier-pattern name pattern) collect))))) (nreverse collect)))) (values name - tests - (getf method-group-specifier :description - (make-default-method-group-description patterns)) - (getf method-group-specifier :order :most-specific-first) - (getf method-group-specifier :required nil)))) + tests + (getf method-group-specifier :description + (make-default-method-group-description patterns)) + (getf method-group-specifier :order :most-specific-first) + (getf method-group-specifier :required nil)))) (defun parse-qualifier-pattern (name pattern) (cond ((eq pattern '()) `(null .qualifiers.)) - ((eq pattern '*) t) - ((symbolp pattern) `(,pattern .qualifiers.)) - ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) - (t (error "In the method group specifier ~S,~%~ - ~S isn't a valid qualifier pattern." - name pattern)))) + ((eq pattern '*) t) + ((symbolp pattern) `(,pattern .qualifiers.)) + ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) + (t (error "In the method group specifier ~S,~%~ + ~S isn't a valid qualifier pattern." + name pattern)))) (defun qualifier-check-runtime (pattern qualifiers) (loop (cond ((and (null pattern) (null qualifiers)) - (return t)) - ((eq pattern '*) (return t)) - ((and pattern qualifiers (eq (car pattern) (car qualifiers))) - (pop pattern) - (pop qualifiers)) - (t (return nil))))) + (return t)) + ((eq pattern '*) (return t)) + ((and pattern qualifiers (eq (car pattern) (car qualifiers))) + (pop pattern) + (pop qualifiers)) + (t (return nil))))) (defun make-default-method-group-description (patterns) (if (cdr patterns) (format nil - "methods matching one of the patterns: ~{~S, ~} ~S" - (butlast patterns) (car (last patterns))) + "methods matching one of the patterns: ~{~S, ~} ~S" + (butlast patterns) (car (last patterns))) (format nil - "methods matching the pattern: ~S" - (car patterns)))) + "methods matching the pattern: ~S" + (car patterns)))) ;;; This baby is a complete mess. I can't believe we put it in this ;;; way. No doubt this is a large part of what drives MLY crazy. @@ -438,53 +438,53 @@ ;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST. (defun deal-with-args-option (wrapped-body args-lambda-list) (let ((intercept-rebindings - (let (rebindings) - (dolist (arg args-lambda-list (nreverse rebindings)) - (unless (member arg lambda-list-keywords) - (typecase arg - (symbol (push `(,arg ',arg) rebindings)) - (cons - (unless (symbolp (car arg)) - (error "invalid lambda-list specifier: ~S." arg)) - (push `(,(car arg) ',(car arg)) rebindings)) - (t (error "invalid lambda-list-specifier: ~S." arg))))))) - (nreq 0) - (nopt 0) - (whole nil)) + (let (rebindings) + (dolist (arg args-lambda-list (nreverse rebindings)) + (unless (member arg lambda-list-keywords) + (typecase arg + (symbol (push `(,arg ',arg) rebindings)) + (cons + (unless (symbolp (car arg)) + (error "invalid lambda-list specifier: ~S." arg)) + (push `(,(car arg) ',(car arg)) rebindings)) + (t (error "invalid lambda-list-specifier: ~S." arg))))))) + (nreq 0) + (nopt 0) + (whole nil)) ;; Count the number of required and optional parameters in ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the ;; name of a &WHOLE parameter, if any. (when (member '&whole (rest args-lambda-list)) (error 'simple-program-error - :format-control "~@" - :format-arguments (list args-lambda-list))) + :format-arguments (list args-lambda-list))) (loop with state = 'required - for arg in args-lambda-list do - (if (memq arg lambda-list-keywords) - (setq state arg) - (case state - (required (incf nreq)) - (&optional (incf nopt)) - (&whole (setq whole arg state 'required))))) + for arg in args-lambda-list do + (if (memq arg lambda-list-keywords) + (setq state arg) + (case state + (required (incf nreq)) + (&optional (incf nopt)) + (&whole (setq whole arg state 'required))))) ;; This assumes that the head of WRAPPED-BODY is a let, and it ;; injects let-bindings of the form (ARG 'SYM) for all variables ;; of the argument-lambda-list; SYM is a gensym. (aver (memq (first wrapped-body) '(let let*))) (setf (second wrapped-body) - (append intercept-rebindings (second wrapped-body))) + (append intercept-rebindings (second wrapped-body))) ;; Be sure to fill out the args lambda list so that it can be too ;; short if it wants to. (unless (or (memq '&rest args-lambda-list) - (memq '&allow-other-keys args-lambda-list)) + (memq '&allow-other-keys args-lambda-list)) (let ((aux (memq '&aux args-lambda-list))) - (setq args-lambda-list - (append (ldiff args-lambda-list aux) - (if (memq '&key args-lambda-list) - '(&allow-other-keys) - '(&rest .ignore.)) - aux)))) + (setq args-lambda-list + (append (ldiff args-lambda-list aux) + (if (memq '&key args-lambda-list) + '(&allow-other-keys) + '(&rest .ignore.)) + aux)))) ;; .GENERIC-FUNCTION. is bound to the generic function in the ;; method combination function, and .GF-ARGS* is bound to the ;; generic function arguments in effective method functions @@ -503,19 +503,19 @@ ;; produces the value of actual argument that is bound to the ;; symbol. `(let ((inner-result. ,wrapped-body) - (gf-lambda-list (generic-function-lambda-list .generic-function.))) + (gf-lambda-list (generic-function-lambda-list .generic-function.))) `(destructuring-bind ,',args-lambda-list - (frob-combined-method-args - .gf-args. ',gf-lambda-list - ,',nreq ,',nopt) - ,,(when (memq '.ignore. args-lambda-list) - ''(declare (ignore .ignore.))) - ;; If there is a &WHOLE in the args-lambda-list, let - ;; it result in the actual arguments of the generic-function - ;; not the frobbed list. - ,,(when whole - ``(setq ,',whole .gf-args.)) - ,inner-result.)))) + (frob-combined-method-args + .gf-args. ',gf-lambda-list + ,',nreq ,',nopt) + ,,(when (memq '.ignore. args-lambda-list) + ''(declare (ignore .ignore.))) + ;; If there is a &WHOLE in the args-lambda-list, let + ;; it result in the actual arguments of the generic-function + ;; not the frobbed list. + ,,(when whole + ``(setq ,',whole .gf-args.)) + ,inner-result.)))) ;;; Partition VALUES into three sections: required, optional, and the ;;; rest, according to required, optional, and other parameters in @@ -525,23 +525,23 @@ ;;; is left as rest from VALUES. (defun frob-combined-method-args (values lambda-list nreq nopt) (loop with section = 'required - for arg in lambda-list - if (memq arg lambda-list-keywords) do - (setq section arg) - (unless (eq section '&optional) - (loop-finish)) - else if (eq section 'required) - count t into nr - and collect (pop values) into required - else if (eq section '&optional) - count t into no - and collect (pop values) into optional - finally - (flet ((frob (list n m) - (cond ((> n m) (butlast list (- n m))) - ((< n m) (nconc list (make-list (- m n)))) - (t list)))) - (return (nconc (frob required nr nreq) - (frob optional no nopt) - values))))) + for arg in lambda-list + if (memq arg lambda-list-keywords) do + (setq section arg) + (unless (eq section '&optional) + (loop-finish)) + else if (eq section 'required) + count t into nr + and collect (pop values) into required + else if (eq section '&optional) + count t into no + and collect (pop values) into optional + finally + (flet ((frob (list n m) + (cond ((> n m) (butlast list (- n m))) + ((< n m) (nconc list (make-list (- m n)))) + (t list)))) + (return (nconc (frob required nr nreq) + (frob optional no nopt) + values))))) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 77d79c9..ce413de 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -30,13 +30,13 @@ ;;; so we've left 'em in.) (when (eq *boot-state* 'complete) (error "Trying to load (or compile) PCL in an environment in which it~%~ - has already been loaded. This doesn't work, you will have to~%~ - get a fresh lisp (reboot) and then load PCL.")) + has already been loaded. This doesn't work, you will have to~%~ + get a fresh lisp (reboot) and then load PCL.")) (when *boot-state* (cerror "Try loading (or compiling) PCL anyways." - "Trying to load (or compile) PCL in an environment in which it~%~ - has already been partially loaded. This may not work, you may~%~ - need to get a fresh lisp (reboot) and then load PCL.")) + "Trying to load (or compile) PCL in an environment in which it~%~ + has already been partially loaded. This may not work, you may~%~ + need to get a fresh lisp (reboot) and then load PCL.")) ;;; comments from CMU CL version of PCL: ;;; This is like fdefinition on the Lispm. If Common Lisp had @@ -50,7 +50,7 @@ ;;; which has a 'real' function spec mechanism can use that instead ;;; and in that way get rid of setf generic function names. (defmacro parse-gspec (spec - (non-setf-var . non-setf-case)) + (non-setf-var . non-setf-case)) `(let ((,non-setf-var ,spec)) ,@non-setf-case)) ;;; If symbol names a function which is traced, return the untraced @@ -89,7 +89,7 @@ (defun coerce-to-class (class &optional make-forward-referenced-class-p) (if (symbolp class) (or (find-class class (not make-forward-referenced-class-p)) - (ensure-class class)) + (ensure-class class)) class)) ;;; interface @@ -97,49 +97,49 @@ (when (consp type) (setq args (cdr type) type (car type))) (cond ((symbolp type) - (or (and (null args) (find-class type)) - (ecase type - (class (coerce-to-class (car args))) - (prototype (make-instance 'class-prototype-specializer - :object (coerce-to-class (car args)))) - (class-eq (class-eq-specializer (coerce-to-class (car args)))) - (eql (intern-eql-specializer (car args)))))) - ;; FIXME: do we still need this? - ((and (null args) (typep type 'classoid)) - (or (classoid-pcl-class type) - (ensure-non-standard-class (classoid-name type)))) - ((specializerp type) type))) + (or (and (null args) (find-class type)) + (ecase type + (class (coerce-to-class (car args))) + (prototype (make-instance 'class-prototype-specializer + :object (coerce-to-class (car args)))) + (class-eq (class-eq-specializer (coerce-to-class (car args)))) + (eql (intern-eql-specializer (car args)))))) + ;; FIXME: do we still need this? + ((and (null args) (typep type 'classoid)) + (or (classoid-pcl-class type) + (ensure-non-standard-class (classoid-name type)))) + ((specializerp type) type))) ;;; interface (defun type-from-specializer (specl) (cond ((eq specl t) - t) - ((consp specl) - (unless (member (car specl) '(class prototype class-eq eql)) - (error "~S is not a legal specializer type." specl)) - specl) - ((progn - (when (symbolp specl) - ;;maybe (or (find-class specl nil) (ensure-class specl)) instead? - (setq specl (find-class specl))) - (or (not (eq *boot-state* 'complete)) - (specializerp specl))) - (specializer-type specl)) - (t - (error "~S is neither a type nor a specializer." specl)))) + t) + ((consp specl) + (unless (member (car specl) '(class prototype class-eq eql)) + (error "~S is not a legal specializer type." specl)) + specl) + ((progn + (when (symbolp specl) + ;;maybe (or (find-class specl nil) (ensure-class specl)) instead? + (setq specl (find-class specl))) + (or (not (eq *boot-state* 'complete)) + (specializerp specl))) + (specializer-type specl)) + (t + (error "~S is neither a type nor a specializer." specl)))) (defun type-class (type) (declare (special *the-class-t*)) (setq type (type-from-specializer type)) (if (atom type) (if (eq type t) - *the-class-t* - (error "bad argument to TYPE-CLASS")) + *the-class-t* + (error "bad argument to TYPE-CLASS")) (case (car type) - (eql (class-of (cadr type))) - (prototype (class-of (cadr type))) ;? - (class-eq (cadr type)) - (class (cadr type))))) + (eql (class-of (cadr type))) + (prototype (class-of (cadr type))) ;? + (class-eq (cadr type)) + (class (cadr type))))) (defun class-eq-type (class) (specializer-type (class-eq-specializer class))) @@ -150,34 +150,34 @@ ;;; class objects or types where they should. (defun *normalize-type (type) (cond ((consp type) - (if (member (car type) '(not and or)) - `(,(car type) ,@(mapcar #'*normalize-type (cdr type))) - (if (null (cdr type)) - (*normalize-type (car type)) - type))) - ((symbolp type) - (let ((class (find-class type nil))) - (if class - (let ((type (specializer-type class))) - (if (listp type) type `(,type))) - `(,type)))) - ((or (not (eq *boot-state* 'complete)) - (specializerp type)) - (specializer-type type)) - (t - (error "~S is not a type." type)))) + (if (member (car type) '(not and or)) + `(,(car type) ,@(mapcar #'*normalize-type (cdr type))) + (if (null (cdr type)) + (*normalize-type (car type)) + type))) + ((symbolp type) + (let ((class (find-class type nil))) + (if class + (let ((type (specializer-type class))) + (if (listp type) type `(,type))) + `(,type)))) + ((or (not (eq *boot-state* 'complete)) + (specializerp type)) + (specializer-type type)) + (t + (error "~S is not a type." type)))) ;;; internal to this file... (defun convert-to-system-type (type) (case (car type) ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type - (cdr type)))) + (cdr type)))) ((class class-eq) ; class-eq is impossible to do right (layout-classoid (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) - (car type) - type)))) + (car type) + type)))) ;;; Writing the missing NOT and AND clauses will improve the quality ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling @@ -185,31 +185,31 @@ ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast. ;;; ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use -;;; in the compiler. Could we share some of it here? +;;; in the compiler. Could we share some of it here? (defun *subtypep (type1 type2) (if (equal type1 type2) (values t t) (if (eq *boot-state* 'early) - (values (eq type1 type2) t) - (let ((*in-precompute-effective-methods-p* t)) - (declare (special *in-precompute-effective-methods-p*)) - ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a - ;; good name. It changes the way - ;; CLASS-APPLICABLE-USING-CLASS-P works. - (setq type1 (*normalize-type type1)) - (setq type2 (*normalize-type type2)) - (case (car type2) - (not - (values nil nil)) ; XXX We should improve this. - (and - (values nil nil)) ; XXX We should improve this. - ((eql wrapper-eq class-eq class) - (multiple-value-bind (app-p maybe-app-p) - (specializer-applicable-using-type-p type2 type1) - (values app-p (or app-p (not maybe-app-p))))) - (t - (subtypep (convert-to-system-type type1) - (convert-to-system-type type2)))))))) + (values (eq type1 type2) t) + (let ((*in-precompute-effective-methods-p* t)) + (declare (special *in-precompute-effective-methods-p*)) + ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a + ;; good name. It changes the way + ;; CLASS-APPLICABLE-USING-CLASS-P works. + (setq type1 (*normalize-type type1)) + (setq type2 (*normalize-type type2)) + (case (car type2) + (not + (values nil nil)) ; XXX We should improve this. + (and + (values nil nil)) ; XXX We should improve this. + ((eql wrapper-eq class-eq class) + (multiple-value-bind (app-p maybe-app-p) + (specializer-applicable-using-type-p type2 type1) + (values app-p (or app-p (not maybe-app-p))))) + (t + (subtypep (convert-to-system-type type1) + (convert-to-system-type type2)))))))) (defvar *built-in-class-symbols* ()) (defvar *built-in-wrapper-symbols* ()) @@ -217,14 +217,14 @@ (defun get-built-in-class-symbol (class-name) (or (cadr (assq class-name *built-in-class-symbols*)) (let ((symbol (make-class-symbol class-name))) - (push (list class-name symbol) *built-in-class-symbols*) - symbol))) + (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 (make-wrapper-symbol class-name))) - (push (list class-name symbol) *built-in-wrapper-symbols*) - symbol))) + (push (list class-name symbol) *built-in-wrapper-symbols*) + symbol))) (pushnew '%class *var-declarations*) (pushnew '%variable-rebinding *var-declarations*) @@ -238,7 +238,7 @@ (defun make-class-predicate-name (name) (list 'class-predicate name)) - + (defun plist-value (object name) (getf (object-plist object) name)) @@ -246,8 +246,8 @@ (if new-value (setf (getf (object-plist object) name) new-value) (progn - (remf (object-plist object) name) - nil))) + (remf (object-plist object) name) + nil))) ;;;; built-in classes @@ -256,59 +256,59 @@ (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*") (defvar *built-in-classes* (labels ((direct-supers (class) - (/noshow "entering DIRECT-SUPERS" (classoid-name class)) - (if (typep class 'built-in-classoid) - (built-in-classoid-direct-superclasses class) - (let ((inherits (layout-inherits - (classoid-layout class)))) - (/noshow inherits) - (list (svref inherits (1- (length inherits))))))) - (direct-subs (class) - (/noshow "entering DIRECT-SUBS" (classoid-name class)) - (collect ((res)) - (let ((subs (classoid-subclasses class))) - (/noshow subs) - (when subs - (dohash (sub v subs) - (declare (ignore v)) - (/noshow sub) - (when (member class (direct-supers sub)) - (res sub))))) - (res)))) + (/noshow "entering DIRECT-SUPERS" (classoid-name class)) + (if (typep class 'built-in-classoid) + (built-in-classoid-direct-superclasses class) + (let ((inherits (layout-inherits + (classoid-layout class)))) + (/noshow inherits) + (list (svref inherits (1- (length inherits))))))) + (direct-subs (class) + (/noshow "entering DIRECT-SUBS" (classoid-name class)) + (collect ((res)) + (let ((subs (classoid-subclasses class))) + (/noshow subs) + (when subs + (dohash (sub v subs) + (declare (ignore v)) + (/noshow sub) + (when (member class (direct-supers sub)) + (res sub))))) + (res)))) (mapcar (lambda (kernel-bic-entry) - (/noshow "setting up" kernel-bic-entry) - (let* ((name (car kernel-bic-entry)) - (class (find-classoid name)) - (prototype-form - (getf (cdr kernel-bic-entry) :prototype-form))) - (/noshow name class) - `(,name - ,(mapcar #'classoid-name (direct-supers class)) - ,(mapcar #'classoid-name (direct-subs class)) - ,(map 'list - (lambda (x) - (classoid-name - (layout-classoid x))) - (reverse - (layout-inherits - (classoid-layout class)))) - ,(if prototype-form - (eval prototype-form) - ;; This is the default prototype value which - ;; was used, without explanation, by the CMU CL - ;; code we're derived from. Evidently it's safe - ;; in all relevant cases. - 42)))) - (remove-if (lambda (kernel-bic-entry) - (member (first kernel-bic-entry) - ;; I'm not sure why these are removed from - ;; the list, but that's what the original - ;; CMU CL code did. -- WHN 20000715 - '(t instance - funcallable-instance - function stream - file-stream string-stream))) - sb-kernel::*built-in-classes*)))) + (/noshow "setting up" kernel-bic-entry) + (let* ((name (car kernel-bic-entry)) + (class (find-classoid name)) + (prototype-form + (getf (cdr kernel-bic-entry) :prototype-form))) + (/noshow name class) + `(,name + ,(mapcar #'classoid-name (direct-supers class)) + ,(mapcar #'classoid-name (direct-subs class)) + ,(map 'list + (lambda (x) + (classoid-name + (layout-classoid x))) + (reverse + (layout-inherits + (classoid-layout class)))) + ,(if prototype-form + (eval prototype-form) + ;; This is the default prototype value which + ;; was used, without explanation, by the CMU CL + ;; code we're derived from. Evidently it's safe + ;; in all relevant cases. + 42)))) + (remove-if (lambda (kernel-bic-entry) + (member (first kernel-bic-entry) + ;; I'm not sure why these are removed from + ;; the list, but that's what the original + ;; CMU CL code did. -- WHN 20000715 + '(t instance + funcallable-instance + function stream + file-stream string-stream))) + sb-kernel::*built-in-classes*)))) (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") ;;;; the classes that define the kernel of the metabraid @@ -344,8 +344,8 @@ (:metaclass structure-class)) (defstruct (dead-beef-structure-object - (:constructor |STRUCTURE-OBJECT class constructor|) - (:copier nil))) + (:constructor |STRUCTURE-OBJECT class constructor|) + (:copier nil))) (defclass std-object (slot-object) () (:metaclass std-class)) @@ -382,8 +382,8 @@ ;;; superclass of any kind of class. That is, any class that can be a ;;; metaclass must have the class CLASS in its class precedence list. (defclass class (dependent-update-mixin - definition-source-mixin - specializer) + definition-source-mixin + specializer) ((name :initform nil :initarg :name @@ -419,7 +419,7 @@ (let ((name (class-name class))) (unless (and name (eq (find-class name nil) class)) (error "~@" - class)) + class)) `(find-class ',name))) ;;; The class PCL-CLASS is an implementation-specific common @@ -486,26 +486,26 @@ (defclass exact-class-specializer (specializer) ()) (defclass class-eq-specializer (exact-class-specializer - specializer-with-object) + specializer-with-object) ((object :initarg :class - :reader specializer-class - :reader specializer-object))) + :reader specializer-class + :reader specializer-object))) (defclass class-prototype-specializer (specializer-with-object) ((object :initarg :class - :reader specializer-class - :reader specializer-object))) + :reader specializer-class + :reader specializer-object))) (defclass eql-specializer (exact-class-specializer specializer-with-object) ((object :initarg :object :reader specializer-object - :reader eql-specializer-object))) + :reader eql-specializer-object))) (defvar *eql-specializer-table* (make-hash-table :test 'eql)) (defun intern-eql-specializer (object) (or (gethash object *eql-specializer-table*) (setf (gethash object *eql-specializer-table*) - (make-instance 'eql-specializer :object object)))) + (make-instance 'eql-specializer :object object)))) ;;;; slot definitions @@ -594,41 +594,41 @@ :initform 0))) (defclass standard-direct-slot-definition (standard-slot-definition - direct-slot-definition) + direct-slot-definition) ()) (defclass standard-effective-slot-definition (standard-slot-definition - effective-slot-definition) + effective-slot-definition) ((location ; nil, a fixnum, a cons: (slot-name . value) :initform nil :accessor slot-definition-location))) (defclass condition-direct-slot-definition (condition-slot-definition - direct-slot-definition) + direct-slot-definition) ()) (defclass condition-effective-slot-definition (condition-slot-definition - effective-slot-definition) + effective-slot-definition) ()) (defclass structure-direct-slot-definition (structure-slot-definition - direct-slot-definition) + direct-slot-definition) ()) (defclass structure-effective-slot-definition (structure-slot-definition - effective-slot-definition) + effective-slot-definition) ()) (defclass method (standard-object) ()) (defclass standard-method (definition-source-mixin plist-mixin method) ((generic-function - :initform nil + :initform nil :accessor method-generic-function) ;;; (qualifiers -;;; :initform () -;;; :initarg :qualifiers -;;; :reader method-qualifiers) +;;; :initform () +;;; :initarg :qualifiers +;;; :reader method-qualifiers) (specializers :initform () :initarg :specializers @@ -639,10 +639,10 @@ :reader method-lambda-list) (function :initform nil - :initarg :function) ;no writer + :initarg :function) ;no writer (fast-function :initform nil - :initarg :fast-function ;no writer + :initarg :fast-function ;no writer :reader method-fast-function) (documentation :initform nil @@ -650,11 +650,11 @@ (defclass standard-accessor-method (standard-method) ((slot-name :initform nil - :initarg :slot-name - :reader accessor-method-slot-name) + :initarg :slot-name + :reader accessor-method-slot-name) (slot-definition :initform nil - :initarg :slot-definition - :reader accessor-method-slot-definition))) + :initarg :slot-definition + :reader accessor-method-slot-definition))) (defclass standard-reader-method (standard-accessor-method) ()) @@ -663,8 +663,8 @@ (defclass standard-boundp-method (standard-accessor-method) ()) (defclass generic-function (dependent-update-mixin - definition-source-mixin - funcallable-standard-object) + definition-source-mixin + funcallable-standard-object) ((documentation :initform nil :initarg :documentation) @@ -715,7 +715,7 @@ :accessor gf-dfun-state)) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* - :method-combination *standard-method-combination*)) + :method-combination *standard-method-combination*)) (defclass method-combination (standard-object) ((documentation @@ -724,7 +724,7 @@ :initarg :documentation))) (defclass standard-method-combination (definition-source-mixin - method-combination) + method-combination) ((type :reader method-combination-type :initarg :type) diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index 4fd565a..acd6eec 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -32,60 +32,60 @@ (defmethod describe-object ((object slot-object) stream) (fresh-line stream) - + (let* ((class (class-of object)) - (slotds (slots-to-inspect class object)) - (max-slot-name-length 0) - (instance-slotds ()) - (class-slotds ()) - (other-slotds ())) + (slotds (slots-to-inspect class object)) + (max-slot-name-length 0) + (instance-slotds ()) + (class-slotds ()) + (other-slotds ())) (format stream "~&~@<~S ~_is an instance of class ~S.~:>" object class) ;; Figure out a good width for the slot-name column. (flet ((adjust-slot-name-length (name) - (setq max-slot-name-length - (max max-slot-name-length - (length (the string (symbol-name name))))))) + (setq max-slot-name-length + (max max-slot-name-length + (length (the string (symbol-name name))))))) (dolist (slotd slotds) - (adjust-slot-name-length (slot-definition-name slotd)) - (case (slot-definition-allocation slotd) - (:instance (push slotd instance-slotds)) - (:class (push slotd class-slotds)) - (otherwise (push slotd other-slotds)))) + (adjust-slot-name-length (slot-definition-name slotd)) + (case (slot-definition-allocation slotd) + (:instance (push slotd instance-slotds)) + (:class (push slotd class-slotds)) + (otherwise (push slotd other-slotds)))) (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))) ;; Now that we know the width, we can print. (flet ((describe-slot (name value &optional (allocation () alloc-p)) - (if alloc-p - (format stream - "~& ~A ~S ~VT ~S" - name allocation (+ max-slot-name-length 7) value) - (format stream - "~& ~A~VT ~S" - name max-slot-name-length value)))) + (if alloc-p + (format stream + "~& ~A ~S ~VT ~S" + name allocation (+ max-slot-name-length 7) value) + (format stream + "~& ~A~VT ~S" + name max-slot-name-length value)))) (when instance-slotds - (format stream "~&The following slots have :INSTANCE allocation:") - (dolist (slotd (nreverse instance-slotds)) - (describe-slot - (slot-definition-name slotd) - (slot-value-or-default object - (slot-definition-name slotd))))) + (format stream "~&The following slots have :INSTANCE allocation:") + (dolist (slotd (nreverse instance-slotds)) + (describe-slot + (slot-definition-name slotd) + (slot-value-or-default object + (slot-definition-name slotd))))) (when class-slotds - (format stream "~&The following slots have :CLASS allocation:") - (dolist (slotd (nreverse class-slotds)) - (describe-slot - (slot-definition-name slotd) - (slot-value-or-default object - (slot-definition-name slotd))))) + (format stream "~&The following slots have :CLASS allocation:") + (dolist (slotd (nreverse class-slotds)) + (describe-slot + (slot-definition-name slotd) + (slot-value-or-default object + (slot-definition-name slotd))))) (when other-slotds - (format stream "~&The following slots have allocation as shown:") - (dolist (slotd (nreverse other-slotds)) - (describe-slot - (slot-definition-name slotd) - (slot-value-or-default object - (slot-definition-name slotd)) - (slot-definition-allocation slotd)))))) + (format stream "~&The following slots have allocation as shown:") + (dolist (slotd (nreverse other-slotds)) + (describe-slot + (slot-definition-name slotd) + (slot-value-or-default object + (slot-definition-name slotd)) + (slot-definition-allocation slotd)))))) (terpri stream)) @@ -94,68 +94,68 @@ (when (documentation fun t) (format stream "~&Its documentation is: ~A" (documentation fun t))) (format stream "~&Its lambda-list is:~& ~S" - (generic-function-pretty-arglist fun)) + (generic-function-pretty-arglist fun)) (format stream "~&Its method-combination is:~& ~S" - (generic-function-method-combination fun)) + (generic-function-method-combination fun)) (let ((methods (generic-function-methods fun))) (if (null methods) - (format stream "~&It has no methods.~%") - (let ((gf-name (generic-function-name fun))) - (format stream "~&Its methods are:") - (dolist (method methods) - (format stream "~& (~A ~{~S ~}~:S)~%" - gf-name - (method-qualifiers method) - (unparse-specializers method)) - (when (documentation method t) - (format stream "~& Method documentation: ~A" - (documentation method t)))))))) + (format stream "~&It has no methods.~%") + (let ((gf-name (generic-function-name fun))) + (format stream "~&Its methods are:") + (dolist (method methods) + (format stream "~& (~A ~{~S ~}~:S)~%" + gf-name + (method-qualifiers method) + (unparse-specializers method)) + (when (documentation method t) + (format stream "~& Method documentation: ~A" + (documentation method t)))))))) (defmethod describe-object ((class class) stream) (flet ((pretty-class (c) (or (class-name c) c))) (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) (ft "~&~@<~S is a class. It is an instance of ~S.~:@>" - class (pretty-class (class-of class))) + class (pretty-class (class-of class))) (let ((name (class-name class))) - (if name - (if (eq class (find-class name nil)) - (ft "~&~@" name) - (ft "~&~@" - name)) - (ft "~&~@"))) + (if name + (if (eq class (find-class name nil)) + (ft "~&~@" name) + (ft "~&~@" + name)) + (ft "~&~@"))) (ft "~&~@~%" - (mapcar #'pretty-class (class-direct-superclasses class)) - (mapcar #'pretty-class (class-direct-subclasses class)) - (class-finalized-p class) - (mapcar #'pretty-class (cpl-or-nil class)) - (length (specializer-direct-methods class)))))) + (mapcar #'pretty-class (class-direct-superclasses class)) + (mapcar #'pretty-class (class-direct-subclasses class)) + (class-finalized-p class) + (mapcar #'pretty-class (cpl-or-nil class)) + (length (specializer-direct-methods class)))))) (defmethod describe-object ((package package) stream) (format stream "~&~S is a ~S." package (type-of package)) (format stream - "~@[~&~@~]" - (package-nicknames package)) + "~@[~&~@~]" + (package-nicknames package)) (let* ((internal (package-internal-symbols package)) - (internal-count (- (package-hashtable-size internal) - (package-hashtable-free internal))) - (external (package-external-symbols package)) - (external-count (- (package-hashtable-size external) - (package-hashtable-free external)))) + (internal-count (- (package-hashtable-size internal) + (package-hashtable-free internal))) + (external (package-external-symbols package)) + (external-count (- (package-hashtable-size external) + (package-hashtable-free external)))) (format stream - "~&It has ~S internal and ~S external symbols." - internal-count external-count)) + "~&It has ~S internal and ~S external symbols." + internal-count external-count)) (flet (;; Turn a list of packages into something a human likes - ;; to read. - (humanize (package-list) - (sort (mapcar #'package-name package-list) #'string<))) + ;; to read. + (humanize (package-list) + (sort (mapcar #'package-name package-list) #'string<))) (format stream - "~@[~&~@~]" - (humanize (package-use-list package))) + "~@[~&~@~]" + (humanize (package-use-list package))) (format stream - "~@[~&~@~]" - (humanize (package-used-by-list package)))) + "~@[~&~@~]" + (humanize (package-used-by-list package)))) (terpri stream)) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 2b84a18..a10c91f 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -83,88 +83,88 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; ( . ( ...)). ;;; Each subentry is of the form ;;; ( ). -(defvar *dfun-constructors* ()) +(defvar *dfun-constructors* ()) ;;; If this is NIL, then the whole mechanism for caching dfun constructors is ;;; turned off. The only time that makes sense is when debugging LAP code. -(defvar *enable-dfun-constructor-caching* t) +(defvar *enable-dfun-constructor-caching* t) (defun show-dfun-constructors () (format t "~&DFUN constructor caching is ~A." - (if *enable-dfun-constructor-caching* - "enabled" "disabled")) + (if *enable-dfun-constructor-caching* + "enabled" "disabled")) (dolist (generator-entry *dfun-constructors*) (dolist (args-entry (cdr generator-entry)) (format t "~&~S ~S" - (cons (car generator-entry) (caar args-entry)) - (caddr args-entry))))) + (cons (car generator-entry) (caar args-entry)) + (caddr args-entry))))) (defvar *raise-metatypes-to-class-p* t) (defun get-dfun-constructor (generator &rest args) (when (and *raise-metatypes-to-class-p* - (member generator '(emit-checking emit-caching - emit-in-checking-cache-p emit-constant-value))) + (member generator '(emit-checking emit-caching + emit-in-checking-cache-p emit-constant-value))) (setq args (cons (mapcar (lambda (mt) - (if (eq mt t) - mt - 'class)) - (car args)) - (cdr args)))) + (if (eq mt t) + mt + 'class)) + (car args)) + (cdr args)))) (let* ((generator-entry (assq generator *dfun-constructors*)) - (args-entry (assoc args (cdr generator-entry) :test #'equal))) + (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if (null *enable-dfun-constructor-caching*) - (apply (fdefinition generator) args) - (or (cadr args-entry) - (multiple-value-bind (new not-best-p) - (apply (symbol-function generator) args) - (let ((entry (list (copy-list args) new (unless not-best-p 'pcl) - not-best-p))) - (if generator-entry - (push entry (cdr generator-entry)) - (push (list generator entry) - *dfun-constructors*))) - (values new not-best-p)))))) + (apply (fdefinition generator) args) + (or (cadr args-entry) + (multiple-value-bind (new not-best-p) + (apply (symbol-function generator) args) + (let ((entry (list (copy-list args) new (unless not-best-p 'pcl) + not-best-p))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) + *dfun-constructors*))) + (values new not-best-p)))))) (defun load-precompiled-dfun-constructor (generator args system constructor) (let* ((generator-entry (assq generator *dfun-constructors*)) - (args-entry (assoc args (cdr generator-entry) :test #'equal))) + (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if args-entry - (when (fourth args-entry) - (let* ((dfun-type (case generator - (emit-checking 'checking) - (emit-caching 'caching) - (emit-constant-value 'constant-value) - (emit-default-only 'default-method-only))) - (metatypes (car args)) - (gfs (when dfun-type (gfs-of-type dfun-type)))) - (dolist (gf gfs) - (when (and (equal metatypes - (arg-info-metatypes (gf-arg-info gf))) - (let ((gf-name (generic-function-name gf))) - (and (not (eq gf-name 'slot-value-using-class)) - (not (equal gf-name - '(setf slot-value-using-class))) - (not (eq gf-name 'slot-boundp-using-class))))) - (update-dfun gf))) - (setf (second args-entry) constructor) - (setf (third args-entry) system) - (setf (fourth args-entry) nil))) - (let ((entry (list args constructor system nil))) - (if generator-entry - (push entry (cdr generator-entry)) - (push (list generator entry) *dfun-constructors*)))))) + (when (fourth args-entry) + (let* ((dfun-type (case generator + (emit-checking 'checking) + (emit-caching 'caching) + (emit-constant-value 'constant-value) + (emit-default-only 'default-method-only))) + (metatypes (car args)) + (gfs (when dfun-type (gfs-of-type dfun-type)))) + (dolist (gf gfs) + (when (and (equal metatypes + (arg-info-metatypes (gf-arg-info gf))) + (let ((gf-name (generic-function-name gf))) + (and (not (eq gf-name 'slot-value-using-class)) + (not (equal gf-name + '(setf slot-value-using-class))) + (not (eq gf-name 'slot-boundp-using-class))))) + (update-dfun gf))) + (setf (second args-entry) constructor) + (setf (third args-entry) system) + (setf (fourth args-entry) nil))) + (let ((entry (list args constructor system nil))) + (if generator-entry + (push entry (cdr generator-entry)) + (push (list generator entry) *dfun-constructors*)))))) (defmacro precompile-dfun-constructors (&optional system) (let ((*precompiling-lap* t)) `(progn ,@(let (collect) - (dolist (generator-entry *dfun-constructors*) - (dolist (args-entry (cdr generator-entry)) - (when (or (null (caddr args-entry)) - (eq (caddr args-entry) system)) - (when system (setf (caddr args-entry) system)) - (push `(load-precompiled-dfun-constructor + (dolist (generator-entry *dfun-constructors*) + (dolist (args-entry (cdr generator-entry)) + (when (or (null (caddr args-entry)) + (eq (caddr args-entry) system)) + (when system (setf (caddr args-entry) system)) + (push `(load-precompiled-dfun-constructor ',(car generator-entry) ',(car args-entry) ',system @@ -191,30 +191,30 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (class-name *standard-classes*) (let ((class (find-class class-name))) (dolist (slot (class-slots class)) - (setf (gethash (cons class (slot-definition-name slot)) - *standard-slot-locations*) - (slot-definition-location slot)))))) + (setf (gethash (cons class (slot-definition-name slot)) + *standard-slot-locations*) + (slot-definition-location slot)))))) ;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS ;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS. (defun maybe-update-standard-class-locations (class) (when (and (eq *boot-state* 'complete) - (memq (class-name class) *standard-classes*)) + (memq (class-name class) *standard-classes*)) (compute-standard-slot-locations))) (defun standard-slot-value (object slot-name class) (let ((location (gethash (cons class slot-name) *standard-slot-locations*))) (if location - (let ((value (if (funcallable-instance-p object) - (funcallable-standard-instance-access object location) - (standard-instance-access object location)))) - (when (eq +slot-unbound+ value) - (error "~@" - slot-name class object)) - value) - (error "~@" + slot-name class object)) + value) + (error "~@" - slot-name class object)))) + slot-name class object)))) (defun standard-slot-value/gf (gf slot-name) (standard-slot-value gf slot-name *the-class-standard-generic-function*)) @@ -224,7 +224,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun standard-slot-value/eslotd (slotd slot-name) (standard-slot-value slotd slot-name - *the-class-standard-effective-slot-definition*)) + *the-class-standard-effective-slot-definition*)) (defun standard-slot-value/class (class slot-name) (standard-slot-value class slot-name *the-class-standard-class*)) @@ -263,28 +263,28 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; and corresponding slot indexes. Because each cache line is ;;; more than one element long, a cache lock count is used. (defstruct (dfun-info (:constructor nil) - (:copier nil)) + (:copier nil)) (cache nil)) (defstruct (no-methods (:constructor no-methods-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (initial (:constructor initial-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (dispatch (:constructor dispatch-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (default-method-only (:constructor default-method-only-dfun-info ()) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) ;without caching: ; dispatch one-class two-class default-method-only @@ -295,63 +295,63 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;accessor: ; one-class two-class one-index n-n (defstruct (accessor-dfun-info (:constructor nil) - (:include dfun-info) - (:copier nil)) + (:include dfun-info) + (:copier nil)) accessor-type) ; (member reader writer) (defmacro dfun-info-accessor-type (di) `(accessor-dfun-info-accessor-type ,di)) (defstruct (one-index-dfun-info (:constructor nil) - (:include accessor-dfun-info) - (:copier nil)) + (:include accessor-dfun-info) + (:copier nil)) index) (defmacro dfun-info-index (di) `(one-index-dfun-info-index ,di)) (defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache)) - (:include accessor-dfun-info) - (:copier nil))) + (:include accessor-dfun-info) + (:copier nil))) (defstruct (one-class (:constructor one-class-dfun-info - (accessor-type index wrapper0)) - (:include one-index-dfun-info) - (:copier nil)) + (accessor-type index wrapper0)) + (:include one-index-dfun-info) + (:copier nil)) wrapper0) (defmacro dfun-info-wrapper0 (di) `(one-class-wrapper0 ,di)) (defstruct (two-class (:constructor two-class-dfun-info - (accessor-type index wrapper0 wrapper1)) - (:include one-class) - (:copier nil)) + (accessor-type index wrapper0 wrapper1)) + (:include one-class) + (:copier nil)) wrapper1) (defmacro dfun-info-wrapper1 (di) `(two-class-wrapper1 ,di)) (defstruct (one-index (:constructor one-index-dfun-info - (accessor-type index cache)) - (:include one-index-dfun-info) - (:copier nil))) + (accessor-type index cache)) + (:include one-index-dfun-info) + (:copier nil))) (defstruct (checking (:constructor checking-dfun-info (function cache)) - (:include dfun-info) - (:copier nil)) + (:include dfun-info) + (:copier nil)) function) (defmacro dfun-info-function (di) `(checking-function ,di)) (defstruct (caching (:constructor caching-dfun-info (cache)) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defstruct (constant-value (:constructor constant-value-dfun-info (cache)) - (:include dfun-info) - (:copier nil))) + (:include dfun-info) + (:copier nil))) (defmacro dfun-update (generic-function function &rest args) `(multiple-value-bind (dfun cache info) @@ -371,44 +371,44 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun make-one-class-accessor-dfun (gf type wrapper index) (let ((emit (ecase type - (reader 'emit-one-class-reader) - (boundp 'emit-one-class-boundp) - (writer 'emit-one-class-writer))) - (dfun-info (one-class-dfun-info type index wrapper))) + (reader 'emit-one-class-reader) + (boundp 'emit-one-class-boundp) + (writer 'emit-one-class-writer))) + (dfun-info (one-class-dfun-info type index wrapper))) (values (funcall (get-dfun-constructor emit (consp index)) - wrapper index - (accessor-miss-function gf dfun-info)) + wrapper index + (accessor-miss-function gf dfun-info)) nil dfun-info))) (defun make-two-class-accessor-dfun (gf type w0 w1 index) (let ((emit (ecase type - (reader 'emit-two-class-reader) - (boundp 'emit-two-class-boundp) - (writer 'emit-two-class-writer))) - (dfun-info (two-class-dfun-info type index w0 w1))) + (reader 'emit-two-class-reader) + (boundp 'emit-two-class-boundp) + (writer 'emit-two-class-writer))) + (dfun-info (two-class-dfun-info type index w0 w1))) (values (funcall (get-dfun-constructor emit (consp index)) - w0 w1 index - (accessor-miss-function gf dfun-info)) + w0 w1 index + (accessor-miss-function gf dfun-info)) nil dfun-info))) ;;; std accessors same index dfun (defun make-one-index-accessor-dfun (gf type index &optional cache) (let* ((emit (ecase type - (reader 'emit-one-index-readers) - (boundp 'emit-one-index-boundps) - (writer 'emit-one-index-writers))) - (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) - (dfun-info (one-index-dfun-info type index cache))) + (reader 'emit-one-index-readers) + (boundp 'emit-one-index-boundps) + (writer 'emit-one-index-writers))) + (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) + (dfun-info (one-index-dfun-info type index cache))) (declare (type cache cache)) (values (funcall (get-dfun-constructor emit (consp index)) - cache - index - (accessor-miss-function gf dfun-info)) + cache + index + (accessor-miss-function gf dfun-info)) cache dfun-info))) @@ -421,16 +421,16 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun make-n-n-accessor-dfun (gf type &optional cache) (let* ((emit (ecase type - (reader 'emit-n-n-readers) - (boundp 'emit-n-n-boundps) - (writer 'emit-n-n-writers))) - (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) - (dfun-info (n-n-dfun-info type cache))) + (reader 'emit-n-n-readers) + (boundp 'emit-n-n-boundps) + (writer 'emit-n-n-writers))) + (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) + (dfun-info (n-n-dfun-info type cache))) (declare (type cache cache)) (values (funcall (get-dfun-constructor emit) - cache - (accessor-miss-function gf dfun-info)) + cache + (accessor-miss-function gf dfun-info)) cache dfun-info))) @@ -451,34 +451,34 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-generic-fun-info generic-function) (declare (ignore nreq)) (if (every (lambda (mt) (eq mt t)) metatypes) - (let ((dfun-info (default-method-only-dfun-info))) - (values - (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) - function) - nil - dfun-info)) - (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) - (dfun-info (checking-dfun-info function cache))) - (values - (funcall (get-dfun-constructor 'emit-checking metatypes applyp) - cache - function - (lambda (&rest args) - (checking-miss generic-function args dfun-info))) - cache - dfun-info))))) + (let ((dfun-info (default-method-only-dfun-info))) + (values + (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) + function) + nil + dfun-info)) + (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) + (dfun-info (checking-dfun-info function cache))) + (values + (funcall (get-dfun-constructor 'emit-checking metatypes applyp) + cache + function + (lambda (&rest args) + (checking-miss generic-function args dfun-info))) + cache + dfun-info))))) (defun make-final-checking-dfun (generic-function function - classes-list new-class) + classes-list new-class) (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) (if (every (lambda (mt) (eq mt t)) metatypes) - (values (lambda (&rest args) - (invoke-emf function args)) - nil (default-method-only-dfun-info)) - (let ((cache (make-final-ordinary-dfun-internal - generic-function nil #'checking-limit-fn - classes-list new-class))) - (make-checking-dfun generic-function function cache))))) + (values (lambda (&rest args) + (invoke-emf function args)) + nil (default-method-only-dfun-info)) + (let ((cache (make-final-ordinary-dfun-internal + generic-function nil #'checking-limit-fn + classes-list new-class))) + (make-checking-dfun generic-function function cache))))) (defun use-default-method-only-dfun-p (generic-function) (multiple-value-bind (nreq applyp metatypes nkeys) @@ -488,20 +488,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun use-caching-dfun-p (generic-function) (some (lambda (method) - (let ((fmf (if (listp method) - (third method) - (method-fast-function method)))) - (method-function-get fmf :slot-name-lists))) - ;; KLUDGE: As of sbcl-0.6.4, it's very important for - ;; efficiency to know the type of the sequence argument to - ;; quantifiers (SOME/NOTANY/etc.) at compile time, but - ;; the compiler isn't smart enough to understand the :TYPE - ;; slot option for DEFCLASS, so we just tell - ;; it the type by hand here. - (the list - (if (early-gf-p generic-function) - (early-gf-methods generic-function) - (generic-function-methods generic-function))))) + (let ((fmf (if (listp method) + (third method) + (method-fast-function method)))) + (method-function-get fmf :slot-name-lists))) + ;; KLUDGE: As of sbcl-0.6.4, it's very important for + ;; efficiency to know the type of the sequence argument to + ;; quantifiers (SOME/NOTANY/etc.) at compile time, but + ;; the compiler isn't smart enough to understand the :TYPE + ;; slot option for DEFCLASS, so we just tell + ;; it the type by hand here. + (the list + (if (early-gf-p generic-function) + (early-gf-methods generic-function) + (generic-function-methods generic-function))))) (defun checking-limit-fn (nlines) (default-limit-fn nlines)) @@ -510,27 +510,27 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (unless cache (when (use-constant-value-dfun-p generic-function) (return-from make-caching-dfun - (make-constant-value-dfun generic-function))) + (make-constant-value-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-caching-dfun - (make-dispatch-dfun generic-function)))) + (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (caching-dfun-info cache))) + (dfun-info (caching-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) - cache - (lambda (&rest args) - (caching-miss generic-function args dfun-info))) + cache + (lambda (&rest args) + (caching-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal - generic-function t #'caching-limit-fn - classes-list new-class))) + generic-function t #'caching-limit-fn + classes-list new-class))) (make-caching-dfun generic-function cache))) (defun caching-limit-fn (nlines) @@ -541,9 +541,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-generic-fun-info gf) (declare (ignore nreq nkeys)) (when (and metatypes - (not (null (car metatypes))) - (dolist (mt metatypes nil) - (unless (eq mt t) (return t)))) + (not (null (car metatypes))) + (dolist (mt metatypes nil) + (unless (eq mt t) (return t)))) (get-dfun-constructor 'emit-caching metatypes applyp)))) (defun use-constant-value-dfun-p (gf &optional boolean-values-p) @@ -551,66 +551,66 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-generic-fun-info gf) (declare (ignore nreq metatypes nkeys)) (let* ((early-p (early-gf-p gf)) - (methods (if early-p - (early-gf-methods gf) - (generic-function-methods gf))) - (default '(unknown))) + (methods (if early-p + (early-gf-methods gf) + (generic-function-methods gf))) + (default '(unknown))) (and (null applyp) - (or (not (eq *boot-state* 'complete)) - ;; If COMPUTE-APPLICABLE-METHODS is specialized, we - ;; can't use this, of course, because we can't tell - ;; which methods will be considered applicable. - ;; - ;; Also, don't use this dfun method if the generic - ;; function has a non-standard method combination, - ;; because if it has, it's not sure that method - ;; functions are used directly as effective methods, - ;; which CONSTANT-VALUE-MISS depends on. The - ;; pre-defined method combinations like LIST are - ;; examples of that. - (and (compute-applicable-methods-emf-std-p gf) - (eq (generic-function-method-combination gf) - *standard-method-combination*))) - ;; Check that no method is eql-specialized, and that all - ;; methods return a constant value. If BOOLEAN-VALUES-P, - ;; check that all return T or NIL. Also, check that no - ;; method has qualifiers, to make sure that emfs are really - ;; method functions; see above. - (dolist (method methods t) - (when (eq *boot-state* 'complete) - (when (or (some #'eql-specializer-p - (method-specializers method)) - (method-qualifiers method)) - (return nil))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) - :constant-value default))) - (when (or (eq value default) - (and boolean-values-p - (not (member value '(t nil))))) - (return nil)))))))) + (or (not (eq *boot-state* 'complete)) + ;; If COMPUTE-APPLICABLE-METHODS is specialized, we + ;; can't use this, of course, because we can't tell + ;; which methods will be considered applicable. + ;; + ;; Also, don't use this dfun method if the generic + ;; function has a non-standard method combination, + ;; because if it has, it's not sure that method + ;; functions are used directly as effective methods, + ;; which CONSTANT-VALUE-MISS depends on. The + ;; pre-defined method combinations like LIST are + ;; examples of that. + (and (compute-applicable-methods-emf-std-p gf) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + ;; Check that no method is eql-specialized, and that all + ;; methods return a constant value. If BOOLEAN-VALUES-P, + ;; check that all return T or NIL. Also, check that no + ;; method has qualifiers, to make sure that emfs are really + ;; method functions; see above. + (dolist (method methods t) + (when (eq *boot-state* 'complete) + (when (or (some #'eql-specializer-p + (method-specializers method)) + (method-qualifiers method)) + (return nil))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (when (or (eq value default) + (and boolean-values-p + (not (member value '(t nil))))) + (return nil)))))))) (defun make-constant-value-dfun (generic-function &optional cache) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) - (dfun-info (constant-value-dfun-info cache))) + (dfun-info (constant-value-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) - cache - (lambda (&rest args) - (constant-value-miss generic-function args dfun-info))) + cache + (lambda (&rest args) + (constant-value-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal - generic-function :constant-value #'caching-limit-fn - classes-list new-class))) + generic-function :constant-value #'caching-limit-fn + classes-list new-class))) (make-constant-value-dfun generic-function cache))) (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) @@ -628,7 +628,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ||# ;; This uses improved dispatch-dfun-cost below (let ((cdc (caching-dfun-cost gf))) ; fast - (> cdc (dispatch-dfun-cost gf cdc)))))) + (> cdc (dispatch-dfun-cost gf cdc)))))) (defparameter *non-built-in-typep-cost* 1) (defparameter *structure-typep-cost* 1) @@ -646,20 +646,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (lambda (position type true-value false-value) (declare (ignore position)) (let* ((type-test-cost - (if (eq 'class (car type)) - (let* ((metaclass (class-of (cadr type))) - (mcpl (class-precedence-list metaclass))) - (cond ((memq *the-class-built-in-class* mcpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* mcpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0)) - (max-cost-so-far - (+ (max true-value false-value) type-test-cost))) + (if (eq 'class (car type)) + (let* ((metaclass (class-of (cadr type))) + (mcpl (class-precedence-list metaclass))) + (cond ((memq *the-class-built-in-class* mcpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* mcpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0)) + (max-cost-so-far + (+ (max true-value false-value) type-test-cost))) (when (and limit (<= limit max-cost-so-far)) - (return-from dispatch-dfun-cost max-cost-so-far)) + (return-from dispatch-dfun-cost max-cost-so-far)) max-cost-so-far)) #'identity)) @@ -669,13 +669,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun caching-dfun-cost (gf) (let* ((arg-info (gf-arg-info gf)) - (nreq (length (arg-info-metatypes arg-info)))) + (nreq (length (arg-info-metatypes arg-info)))) (+ *cache-lookup-cost* (* *wrapper-of-cost* nreq) (if (methods-contain-eql-specializer-p - (generic-function-methods gf)) - *secondary-dfun-call-cost* - 0)))) + (generic-function-methods gf)) + *secondary-dfun-call-cost* + 0)))) (setq *non-built-in-typep-cost* 100) (setq *structure-typep-cost* 15) @@ -687,7 +687,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (declaim (inline make-callable)) (defun make-callable (gf methods generator method-alist wrappers) (let* ((*applicable-methods* methods) - (callable (function-funcall generator method-alist wrappers))) + (callable (function-funcall generator method-alist wrappers))) callable)) (defun make-dispatch-dfun (gf) @@ -695,8 +695,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun get-dispatch-function (gf) (let* ((methods (generic-function-methods gf)) - (generator (get-secondary-dispatch-function1 - gf methods nil nil nil nil nil t))) + (generator (get-secondary-dispatch-function1 + gf methods nil nil nil nil nil t))) (make-callable gf methods generator nil nil))) (defun make-final-dispatch-dfun (gf) @@ -708,53 +708,53 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) (let ((cache (or cache (get-cache nkeys valuep limit-fn - (+ (hash-table-count table) 3))))) + (+ (hash-table-count table) 3))))) (maphash (lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value))) - table) + (setq cache (fill-cache cache + (class-wrapper classes) + value))) + table) cache)) (defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn - classes-list new-class) + classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) - (nkeys (arg-info-nkeys arg-info)) - (new-class (and new-class - (equal (type-of (gf-dfun-info generic-function)) - (cond ((eq valuep t) 'caching) - ((eq valuep :constant-value) 'constant-value) - ((null valuep) 'checking))) - new-class)) - (cache (if new-class - (copy-cache (gf-dfun-cache generic-function)) - (get-cache nkeys (not (null valuep)) limit-fn 4)))) + (nkeys (arg-info-nkeys arg-info)) + (new-class (and new-class + (equal (type-of (gf-dfun-info generic-function)) + (cond ((eq valuep t) 'caching) + ((eq valuep :constant-value) 'constant-value) + ((null valuep) 'checking))) + new-class)) + (cache (if new-class + (copy-cache (gf-dfun-cache generic-function)) + (get-cache nkeys (not (null valuep)) limit-fn 4)))) (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) (defmacro dfun-miss ((gf args wrappers invalidp nemf - &optional type index caching-p applicable) - &body body) + &optional type index caching-p applicable) + &body body) (unless applicable (setq applicable (gensym))) `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp - ,@(when type `(,type ,index))) + ,@(when type `(,type ,index))) (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) - (type 'accessor) - (t 'checking))) + (type 'accessor) + (t 'checking))) (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) - ,@body)) + ,@body)) ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is, ;; does not signal a SLOT-UNBOUND error for a boundp test. ,@(if type - ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated - ;; slots?) - `((if (and (eq ,type 'boundp) (integerp ,nemf)) - (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args) - (invoke-emf ,nemf ,args))) - `((invoke-emf ,nemf ,args))))) + ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated + ;; slots?) + `((if (and (eq ,type 'boundp) (integerp ,nemf)) + (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args) + (invoke-emf ,nemf ,args))) + `((invoke-emf ,nemf ,args))))) ;;; The dynamically adaptive method lookup algorithm is implemented is ;;; implemented as a kind of state machine. The kinds of @@ -776,91 +776,91 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun finalize-specializers (gf) (let ((methods (generic-function-methods gf))) (when (or (null *max-emf-precomputation-methods*) - (<= (length methods) *max-emf-precomputation-methods*)) + (<= (length methods) *max-emf-precomputation-methods*)) (let ((all-finalized t)) - (dolist (method methods all-finalized) - (dolist (specializer (method-specializers method)) - (when (and (classp specializer) - (not (class-finalized-p specializer))) - (if (class-has-a-forward-referenced-superclass-p specializer) - (setq all-finalized nil) - (finalize-inheritance specializer))))))))) + (dolist (method methods all-finalized) + (dolist (specializer (method-specializers method)) + (when (and (classp specializer) + (not (class-finalized-p specializer))) + (if (class-has-a-forward-referenced-superclass-p specializer) + (setq all-finalized nil) + (finalize-inheritance specializer))))))))) (defun make-initial-dfun (gf) (let ((initial-dfun - #'(instance-lambda (&rest args) - (initial-dfun gf args)))) + #'(instance-lambda (&rest args) + (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) - (cond - ((and (eq *boot-state* 'complete) - (not (finalize-specializers gf))) - (values initial-dfun nil (initial-dfun-info))) - ((and (eq *boot-state* 'complete) - (compute-applicable-methods-emf-std-p gf)) - (let* ((caching-p (use-caching-dfun-p gf)) - ;; KLUDGE: the only effect of this (when - ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) - ;; is to signal an error when we try to add methods - ;; with the wrong qualifiers to a generic function. - (classes-list (precompute-effective-methods - gf caching-p - (not *lazy-dfun-compute-p*)))) - (if *lazy-dfun-compute-p* - (cond ((use-dispatch-dfun-p gf caching-p) - (values initial-dfun - nil - (initial-dispatch-dfun-info))) - (caching-p - (insure-caching-dfun gf) - (values initial-dfun nil (initial-dfun-info))) - (t - (values initial-dfun nil (initial-dfun-info)))) - (make-final-dfun-internal gf classes-list)))) - (t - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (type nil)) - (if (and (gf-precompute-dfun-and-emf-p arg-info) - (setq type (final-accessor-dfun-type gf))) - (if *early-p* - (values (make-early-accessor gf type) nil nil) - (make-final-accessor-dfun gf type)) - (values initial-dfun nil (initial-dfun-info)))))) + (cond + ((and (eq *boot-state* 'complete) + (not (finalize-specializers gf))) + (values initial-dfun nil (initial-dfun-info))) + ((and (eq *boot-state* 'complete) + (compute-applicable-methods-emf-std-p gf)) + (let* ((caching-p (use-caching-dfun-p gf)) + ;; KLUDGE: the only effect of this (when + ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) + ;; is to signal an error when we try to add methods + ;; with the wrong qualifiers to a generic function. + (classes-list (precompute-effective-methods + gf caching-p + (not *lazy-dfun-compute-p*)))) + (if *lazy-dfun-compute-p* + (cond ((use-dispatch-dfun-p gf caching-p) + (values initial-dfun + nil + (initial-dispatch-dfun-info))) + (caching-p + (insure-caching-dfun gf) + (values initial-dfun nil (initial-dfun-info))) + (t + (values initial-dfun nil (initial-dfun-info)))) + (make-final-dfun-internal gf classes-list)))) + (t + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (initial-dfun-info)))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) (let* ((methods (early-gf-methods gf)) - (slot-name (early-method-standard-accessor-slot-name (car methods)))) + (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type (reader #'(instance-lambda (instance) - (let* ((class (class-of instance)) - (class-name (!bootstrap-get-slot 'class class 'name))) - (!bootstrap-get-slot class-name instance slot-name)))) + (let* ((class (class-of instance)) + (class-name (!bootstrap-get-slot 'class class 'name))) + (!bootstrap-get-slot class-name instance slot-name)))) (boundp #'(instance-lambda (instance) - (let* ((class (class-of instance)) - (class-name (!bootstrap-get-slot 'class class 'name))) - (not (eq +slot-unbound+ - (!bootstrap-get-slot class-name - instance slot-name)))))) + (let* ((class (class-of instance)) + (class-name (!bootstrap-get-slot 'class class 'name))) + (not (eq +slot-unbound+ + (!bootstrap-get-slot class-name + instance slot-name)))))) (writer #'(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))))))) + (let* ((class (class-of instance)) + (class-name (!bootstrap-get-slot 'class class 'name))) + (!bootstrap-set-slot class-name instance slot-name new-value))))))) (defun initial-dfun (gf args) (dfun-miss (gf args wrappers invalidp nemf ntype nindex) (cond (invalidp) - ((and ntype nindex) - (dfun-update - gf #'make-one-class-accessor-dfun ntype wrappers nindex)) - ((use-caching-dfun-p gf) - (dfun-update gf #'make-caching-dfun)) - (t - (dfun-update - gf #'make-checking-dfun - ;; nemf is suitable only for caching, have to do this: - (cache-miss-values gf args 'checking)))))) + ((and ntype nindex) + (dfun-update + gf #'make-one-class-accessor-dfun ntype wrappers nindex)) + ((use-caching-dfun-p gf) + (dfun-update gf #'make-caching-dfun)) + (t + (dfun-update + gf #'make-checking-dfun + ;; nemf is suitable only for caching, have to do this: + (cache-miss-values gf args 'checking)))))) (defun make-final-dfun (gf &optional classes-list) (multiple-value-bind (dfun cache info) @@ -873,11 +873,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defmacro with-hash-table ((table test) &body forms) `(let* ((.free. (assoc ',test *free-hash-tables*)) - (,table (if (cdr .free.) - (pop (cdr .free.)) - (make-hash-table :test ',test)))) + (,table (if (cdr .free.) + (pop (cdr .free.)) + (make-hash-table :test ',test)))) (multiple-value-prog1 - (progn ,@forms) + (progn ,@forms) (clrhash ,table) (push ,table (cdr .free.))))) @@ -886,91 +886,91 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun final-accessor-dfun-type (gf) (let ((methods (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf)))) + (early-gf-methods gf) + (generic-function-methods gf)))) (cond ((every (lambda (method) - (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) - methods) - 'reader) - ((every (lambda (method) - (if (consp method) - (eq *the-class-standard-boundp-method* - (early-method-class method)) - (standard-boundp-method-p method))) - methods) - 'boundp) - ((every (lambda (method) - (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) - methods) - 'writer)))) + (if (consp method) + (eq *the-class-standard-reader-method* + (early-method-class method)) + (standard-reader-method-p method))) + methods) + 'reader) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-boundp-method* + (early-method-class method)) + (standard-boundp-method-p method))) + methods) + 'boundp) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-writer-method* + (early-method-class method)) + (standard-writer-method-p method))) + methods) + 'writer)))) (defun make-final-accessor-dfun (gf type &optional classes-list new-class) (with-eq-hash-table (table) (multiple-value-bind (table all-index first second size no-class-slots-p) - (make-accessor-table gf type table) + (make-accessor-table gf type table) (if table - (cond ((= size 1) - (let ((w (class-wrapper first))) - (make-one-class-accessor-dfun gf type w all-index))) - ((and (= size 2) (or (integerp all-index) (consp all-index))) - (let ((w0 (class-wrapper first)) - (w1 (class-wrapper second))) - (make-two-class-accessor-dfun gf type w0 w1 all-index))) - ((or (integerp all-index) (consp all-index)) - (make-final-one-index-accessor-dfun - gf type all-index table)) - (no-class-slots-p - (make-final-n-n-accessor-dfun gf type table)) - (t - (make-final-caching-dfun gf classes-list new-class))) - (make-final-caching-dfun gf classes-list new-class))))) + (cond ((= size 1) + (let ((w (class-wrapper first))) + (make-one-class-accessor-dfun gf type w all-index))) + ((and (= size 2) (or (integerp all-index) (consp all-index))) + (let ((w0 (class-wrapper first)) + (w1 (class-wrapper second))) + (make-two-class-accessor-dfun gf type w0 w1 all-index))) + ((or (integerp all-index) (consp all-index)) + (make-final-one-index-accessor-dfun + gf type all-index table)) + (no-class-slots-p + (make-final-n-n-accessor-dfun gf type table)) + (t + (make-final-caching-dfun gf classes-list new-class))) + (make-final-caching-dfun gf classes-list new-class))))) (defun make-final-dfun-internal (gf &optional classes-list) (let ((methods (generic-function-methods gf)) type - (new-class *new-class*) (*new-class* nil) - specls all-same-p) + (new-class *new-class*) (*new-class* nil) + specls all-same-p) (cond ((null methods) - (values - #'(instance-lambda (&rest args) - (apply #'no-applicable-method gf args)) - nil - (no-methods-dfun-info))) - ((setq type (final-accessor-dfun-type gf)) - (make-final-accessor-dfun gf type classes-list new-class)) - ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) - (setq specls - (method-specializers (car methods)))) - (setq all-same-p - (every (lambda (method) - (and (equal specls - (method-specializers - method)))) - methods)))) - (use-constant-value-dfun-p gf)) - (make-final-constant-value-dfun gf classes-list new-class)) - ((use-dispatch-dfun-p gf) - (make-final-dispatch-dfun gf)) - ((and all-same-p (not (use-caching-dfun-p gf))) - (let ((emf (get-secondary-dispatch-function gf methods nil))) - (make-final-checking-dfun gf emf classes-list new-class))) - (t - (make-final-caching-dfun gf classes-list new-class))))) + (values + #'(instance-lambda (&rest args) + (apply #'no-applicable-method gf args)) + nil + (no-methods-dfun-info))) + ((setq type (final-accessor-dfun-type gf)) + (make-final-accessor-dfun gf type classes-list new-class)) + ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) + (setq specls + (method-specializers (car methods)))) + (setq all-same-p + (every (lambda (method) + (and (equal specls + (method-specializers + method)))) + methods)))) + (use-constant-value-dfun-p gf)) + (make-final-constant-value-dfun gf classes-list new-class)) + ((use-dispatch-dfun-p gf) + (make-final-dispatch-dfun gf)) + ((and all-same-p (not (use-caching-dfun-p gf))) + (let ((emf (get-secondary-dispatch-function gf methods nil))) + (make-final-checking-dfun gf emf classes-list new-class))) + (t + (make-final-caching-dfun gf classes-list new-class))))) (defun accessor-miss (gf new object dfun-info) (let* ((ostate (type-of dfun-info)) - (otype (dfun-info-accessor-type dfun-info)) - oindex ow0 ow1 cache - (args (ecase otype - ;; The congruence rules ensure that this is safe - ;; despite not knowing the new type yet. - ((reader boundp) (list object)) - (writer (list new object))))) + (otype (dfun-info-accessor-type dfun-info)) + oindex ow0 ow1 cache + (args (ecase otype + ;; The congruence rules ensure that this is safe + ;; despite not knowing the new type yet. + ((reader boundp) (list object)) + (writer (list new object))))) (dfun-miss (gf args wrappers invalidp nemf ntype nindex) ;; The following lexical functions change the state of the @@ -978,139 +978,139 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; which are the parameters of the new state, and get other ;; information from the lexical variables bound above. (flet ((two-class (index w0 w1) - (when (zerop (random 2)) (psetf w0 w1 w1 w0)) - (dfun-update gf - #'make-two-class-accessor-dfun - ntype - w0 - w1 - index)) - (one-index (index &optional cache) - (dfun-update gf - #'make-one-index-accessor-dfun - ntype - index - cache)) - (n-n (&optional cache) - (if (consp nindex) - (dfun-update gf #'make-checking-dfun nemf) - (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) - (caching () ; because cached accessor emfs are much faster - ; for accessors - (dfun-update gf #'make-caching-dfun)) - (do-fill (update-fn) - (let ((ncache (fill-cache cache wrappers nindex))) - (unless (eq ncache cache) - (funcall update-fn ncache))))) - - (cond ((null ntype) - (caching)) - ((or invalidp - (null nindex))) - ((not (pcl-instance-p object)) - (caching)) - ((or (neq ntype otype) (listp wrappers)) - (caching)) - (t - (ecase ostate - (one-class - (setq oindex (dfun-info-index dfun-info)) - (setq ow0 (dfun-info-wrapper0 dfun-info)) - (unless (eq ow0 wrappers) - (if (eql nindex oindex) - (two-class nindex ow0 wrappers) - (n-n)))) - (two-class - (setq oindex (dfun-info-index dfun-info)) - (setq ow0 (dfun-info-wrapper0 dfun-info)) - (setq ow1 (dfun-info-wrapper1 dfun-info)) - (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) - (if (eql nindex oindex) - (one-index nindex) - (n-n)))) - (one-index - (setq oindex (dfun-info-index dfun-info)) - (setq cache (dfun-info-cache dfun-info)) - (if (eql nindex oindex) - (do-fill (lambda (ncache) - (one-index nindex ncache))) - (n-n))) - (n-n - (setq cache (dfun-info-cache dfun-info)) - (if (consp nindex) - (caching) - (do-fill #'n-n)))))))))) + (when (zerop (random 2)) (psetf w0 w1 w1 w0)) + (dfun-update gf + #'make-two-class-accessor-dfun + ntype + w0 + w1 + index)) + (one-index (index &optional cache) + (dfun-update gf + #'make-one-index-accessor-dfun + ntype + index + cache)) + (n-n (&optional cache) + (if (consp nindex) + (dfun-update gf #'make-checking-dfun nemf) + (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) + (caching () ; because cached accessor emfs are much faster + ; for accessors + (dfun-update gf #'make-caching-dfun)) + (do-fill (update-fn) + (let ((ncache (fill-cache cache wrappers nindex))) + (unless (eq ncache cache) + (funcall update-fn ncache))))) + + (cond ((null ntype) + (caching)) + ((or invalidp + (null nindex))) + ((not (pcl-instance-p object)) + (caching)) + ((or (neq ntype otype) (listp wrappers)) + (caching)) + (t + (ecase ostate + (one-class + (setq oindex (dfun-info-index dfun-info)) + (setq ow0 (dfun-info-wrapper0 dfun-info)) + (unless (eq ow0 wrappers) + (if (eql nindex oindex) + (two-class nindex ow0 wrappers) + (n-n)))) + (two-class + (setq oindex (dfun-info-index dfun-info)) + (setq ow0 (dfun-info-wrapper0 dfun-info)) + (setq ow1 (dfun-info-wrapper1 dfun-info)) + (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) + (if (eql nindex oindex) + (one-index nindex) + (n-n)))) + (one-index + (setq oindex (dfun-info-index dfun-info)) + (setq cache (dfun-info-cache dfun-info)) + (if (eql nindex oindex) + (do-fill (lambda (ncache) + (one-index nindex ncache))) + (n-n))) + (n-n + (setq cache (dfun-info-cache dfun-info)) + (if (consp nindex) + (caching) + (do-fill #'n-n)))))))))) (defun checking-miss (generic-function args dfun-info) (let ((oemf (dfun-info-function dfun-info)) - (cache (dfun-info-cache dfun-info))) + (cache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) - ((eq oemf nemf) - (let ((ncache (fill-cache cache wrappers nil))) - (unless (eq ncache cache) - (dfun-update generic-function #'make-checking-dfun - nemf ncache)))) - (t - (dfun-update generic-function #'make-caching-dfun)))))) + ((eq oemf nemf) + (let ((ncache (fill-cache cache wrappers nil))) + (unless (eq ncache cache) + (dfun-update generic-function #'make-checking-dfun + nemf ncache)))) + (t + (dfun-update generic-function #'make-caching-dfun)))))) (defun caching-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) - (t - (let ((ncache (fill-cache ocache wrappers emf))) - (unless (eq ncache ocache) - (dfun-update generic-function - #'make-caching-dfun ncache)))))))) + (t + (let ((ncache (fill-cache ocache wrappers emf))) + (unless (eq ncache ocache) + (dfun-update generic-function + #'make-caching-dfun ncache)))))))) (defun constant-value-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (unless invalidp - (let* ((function - (typecase emf - (fast-method-call (fast-method-call-function emf)) - (method-call (method-call-function emf)))) - (value (let ((val (method-function-get - function :constant-value '.not-found.))) - (aver (not (eq val '.not-found.))) - val)) - (ncache (fill-cache ocache wrappers value))) - (unless (eq ncache ocache) - (dfun-update generic-function - #'make-constant-value-dfun ncache))))))) + (let* ((function + (typecase emf + (fast-method-call (fast-method-call-function emf)) + (method-call (method-call-function emf)))) + (value (let ((val (method-function-get + function :constant-value '.not-found.))) + (aver (not (eq val '.not-found.))) + val)) + (ncache (fill-cache ocache wrappers value))) + (unless (eq ncache ocache) + (dfun-update generic-function + #'make-constant-value-dfun ncache))))))) ;;; Given a generic function and a set of arguments to that generic ;;; function, return a mess of values. ;;; ;;; The compiled effective method function for this set of -;;; arguments. +;;; arguments. ;;; ;;; Sorted list of applicable methods. ;;; ;;; Is a single wrapper if the generic function has only -;;; one key, that is arg-info-nkeys of the arg-info is 1. -;;; Otherwise a list of the wrappers of the specialized -;;; arguments to the generic function. +;;; one key, that is arg-info-nkeys of the arg-info is 1. +;;; Otherwise a list of the wrappers of the specialized +;;; arguments to the generic function. ;;; -;;; Note that all these wrappers are valid. This function -;;; does invalid wrapper traps when it finds an invalid -;;; wrapper and then returns the new, valid wrapper. +;;; Note that all these wrappers are valid. This function +;;; does invalid wrapper traps when it finds an invalid +;;; wrapper and then returns the new, valid wrapper. ;;; ;;; True if any of the specialized arguments had an invalid -;;; wrapper, false otherwise. +;;; wrapper, false otherwise. ;;; ;;; READER or WRITER when the only method that would be run -;;; is a standard reader or writer method. To be specific, -;;; the value is READER when the method combination is eq to -;;; *standard-method-combination*; there are no applicable -;;; :before, :after or :around methods; and the most specific -;;; primary method is a standard reader method. +;;; is a standard reader or writer method. To be specific, +;;; the value is READER when the method combination is eq to +;;; *standard-method-combination*; there are no applicable +;;; :before, :after or :around methods; and the most specific +;;; primary method is a standard reader method. ;;; ;;; If is READER or WRITER, and the slot accessed is -;;; an :instance slot, this is the index number of that slot -;;; in the object argument. +;;; an :instance slot, this is the index number of that slot +;;; in the object argument. (defvar *cache-miss-values-stack* ()) (defun cache-miss-values (gf args state) @@ -1132,29 +1132,29 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (and classes (equal classes (cdr (assq gf *cache-miss-values-stack*)))) (break-vicious-metacircle gf classes arg-info) (let ((*cache-miss-values-stack* - (acons gf classes *cache-miss-values-stack*)) - (cam-std-p (or (null arg-info) - (gf-info-c-a-m-emf-std-p arg-info)))) - (multiple-value-bind (methods all-applicable-and-sorted-p) - (if cam-std-p - (compute-applicable-methods-using-types gf types) - (compute-applicable-methods-using-classes gf classes)) - + (acons gf classes *cache-miss-values-stack*)) + (cam-std-p (or (null arg-info) + (gf-info-c-a-m-emf-std-p arg-info)))) + (multiple-value-bind (methods all-applicable-and-sorted-p) + (if cam-std-p + (compute-applicable-methods-using-types gf types) + (compute-applicable-methods-using-classes gf classes)) + (let* ((for-accessor-p (eq state 'accessor)) - (for-cache-p (or (eq state 'caching) (eq state 'accessor))) - (emf (if (or cam-std-p all-applicable-and-sorted-p) - (let ((generator - (get-secondary-dispatch-function1 - gf methods types nil (and for-cache-p wrappers) - all-applicable-and-sorted-p))) - (make-callable gf methods generator - nil (and for-cache-p wrappers))) - (default-secondary-dispatch-function gf)))) + (for-cache-p (or (eq state 'caching) (eq state 'accessor))) + (emf (if (or cam-std-p all-applicable-and-sorted-p) + (let ((generator + (get-secondary-dispatch-function1 + gf methods types nil (and for-cache-p wrappers) + all-applicable-and-sorted-p))) + (make-callable gf methods generator + nil (and for-cache-p wrappers))) + (default-secondary-dispatch-function gf)))) (multiple-value-bind (index accessor-type) - (and for-accessor-p all-applicable-and-sorted-p methods - (accessor-values gf arg-info classes methods)) + (and for-accessor-p all-applicable-and-sorted-p methods + (accessor-values gf arg-info classes methods)) (values (if (integerp index) index emf) - methods accessor-type index))))))) + methods accessor-type index))))))) ;;; Try to break a vicious circle while computing a cache miss. ;;; GF is the generic function, CLASSES are the classes of actual @@ -1169,23 +1169,23 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun break-vicious-metacircle (gf classes arg-info) (when (typep gf 'standard-generic-function) (multiple-value-bind (class slotd accessor-type) - (accesses-standard-class-slot-p gf) + (accesses-standard-class-slot-p gf) (when class - (let ((method (find-standard-class-accessor-method - gf class accessor-type)) - (index (standard-slot-value/eslotd slotd 'location)) - (type (gf-info-simple-accessor-type arg-info))) - (when (and method - (subtypep (ecase accessor-type - ((reader) (car classes)) - ((writer) (cadr classes))) - class)) - (return-from break-vicious-metacircle - (values index (list method) type index))))))) + (let ((method (find-standard-class-accessor-method + gf class accessor-type)) + (index (standard-slot-value/eslotd slotd 'location)) + (type (gf-info-simple-accessor-type arg-info))) + (when (and method + (subtypep (ecase accessor-type + ((reader) (car classes)) + ((writer) (cadr classes))) + class)) + (return-from break-vicious-metacircle + (values index (list method) type index))))))) (error "~@" - gf classes)) + effective method of ~s for arguments of types ~s uses ~ + the effective method being computed.~@:>" + gf classes)) ;;; Return (CLASS SLOTD ACCESSOR-TYPE) if some method of generic ;;; function GF accesses a slot of some class in *STANDARD-CLASSES*. @@ -1194,297 +1194,297 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; READER or WRITER describing the slot access. (defun accesses-standard-class-slot-p (gf) (flet ((standard-class-slot-access (gf class) - (loop with gf-name = (standard-slot-value/gf gf 'name) - for slotd in (standard-slot-value/class class 'slots) - ;; FIXME: where does BOUNDP fit in here? Is it - ;; relevant? - as readers = (standard-slot-value/eslotd slotd 'readers) - as writers = (standard-slot-value/eslotd slotd 'writers) - if (member gf-name readers :test #'equal) - return (values slotd 'reader) - else if (member gf-name writers :test #'equal) - return (values slotd 'writer)))) + (loop with gf-name = (standard-slot-value/gf gf 'name) + for slotd in (standard-slot-value/class class 'slots) + ;; FIXME: where does BOUNDP fit in here? Is it + ;; relevant? + as readers = (standard-slot-value/eslotd slotd 'readers) + as writers = (standard-slot-value/eslotd slotd 'writers) + if (member gf-name readers :test #'equal) + return (values slotd 'reader) + else if (member gf-name writers :test #'equal) + return (values slotd 'writer)))) (dolist (class-name *standard-classes*) (let ((class (find-class class-name))) - (multiple-value-bind (slotd accessor-type) - (standard-class-slot-access gf class) - (when slotd - (return (values class slotd accessor-type)))))))) + (multiple-value-bind (slotd accessor-type) + (standard-class-slot-access gf class) + (when slotd + (return (values class slotd accessor-type)))))))) ;;; Find a slot reader/writer method among the methods of generic ;;; function GF which reads/writes instances of class CLASS. ;;; TYPE is one of the symbols READER or WRITER. (defun find-standard-class-accessor-method (gf class type) (let ((cpl (standard-slot-value/class class 'class-precedence-list)) - (found-specializer *the-class-t*) - (found-method nil)) + (found-specializer *the-class-t*) + (found-method nil)) (dolist (method (standard-slot-value/gf gf 'methods) found-method) (let ((specializers (standard-slot-value/method method 'specializers)) - (qualifiers (plist-value method 'qualifiers))) - (when (and (null qualifiers) - (let ((subcpl (member (ecase type - (reader (car specializers)) - (writer (cadr specializers))) - cpl))) - (and subcpl (member found-specializer subcpl)))) - (setf found-specializer (ecase type - (reader (car specializers)) - (writer (cadr specializers)))) - (setf found-method method)))))) + (qualifiers (plist-value method 'qualifiers))) + (when (and (null qualifiers) + (let ((subcpl (member (ecase type + (reader (car specializers)) + (writer (cadr specializers))) + cpl))) + (and subcpl (member found-specializer subcpl)))) + (setf found-specializer (ecase type + (reader (car specializers)) + (writer (cadr specializers)))) + (setf found-method method)))))) (defun accessor-values (gf arg-info classes methods) (declare (ignore gf)) (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) - (accessor-class (case accessor-type - ((reader boundp) (car classes)) - (writer (cadr classes))))) + (accessor-class (case accessor-type + ((reader boundp) (car classes)) + (writer (cadr classes))))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values1 (gf accessor-type accessor-class) (let* ((type `(class-eq ,accessor-class)) - (types (ecase accessor-type - ((reader boundp) `(,type)) - (writer `(t ,type)))) - (methods (compute-applicable-methods-using-types gf types))) + (types (ecase accessor-type + ((reader boundp) `(,type)) + (writer `(t ,type)))) + (methods (compute-applicable-methods-using-types gf types))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values-internal (accessor-type accessor-class methods) (dolist (meth methods) (when (if (consp meth) - (early-method-qualifiers meth) - (method-qualifiers meth)) + (early-method-qualifiers meth) + (method-qualifiers meth)) (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) - (early-p (not (eq *boot-state* 'complete))) - (slot-name (when accessor-class - (if (consp meth) - (and (early-method-standard-accessor-p meth) - (early-method-standard-accessor-slot-name meth)) - (and (member *the-class-std-object* - (if early-p - (early-class-precedence-list - accessor-class) - (class-precedence-list - accessor-class))) - (if early-p - (not (eq *the-class-standard-method* - (early-method-class meth))) - (standard-accessor-method-p meth)) - (if early-p - (early-accessor-method-slot-name meth) - (accessor-method-slot-name meth)))))) - (slotd (and accessor-class - (if early-p - (dolist (slot (early-class-slotds accessor-class) nil) - (when (eql slot-name - (early-slot-definition-name slot)) - (return slot))) - (find-slot-definition accessor-class slot-name))))) + (early-p (not (eq *boot-state* 'complete))) + (slot-name (when accessor-class + (if (consp meth) + (and (early-method-standard-accessor-p meth) + (early-method-standard-accessor-slot-name meth)) + (and (member *the-class-std-object* + (if early-p + (early-class-precedence-list + accessor-class) + (class-precedence-list + accessor-class))) + (if early-p + (not (eq *the-class-standard-method* + (early-method-class meth))) + (standard-accessor-method-p meth)) + (if early-p + (early-accessor-method-slot-name meth) + (accessor-method-slot-name meth)))))) + (slotd (and accessor-class + (if early-p + (dolist (slot (early-class-slotds accessor-class) nil) + (when (eql slot-name + (early-slot-definition-name slot)) + (return slot))) + (find-slot-definition accessor-class slot-name))))) (when (and slotd - (or early-p - (slot-accessor-std-p slotd accessor-type))) + (or early-p + (slot-accessor-std-p slotd accessor-type))) (values (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)) - accessor-type)))) + (early-slot-definition-location slotd) + (slot-definition-location slotd)) + accessor-type)))) (defun make-accessor-table (gf type &optional table) (unless table (setq table (make-hash-table :test 'eq))) (let ((methods (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf))) - (all-index nil) - (no-class-slots-p t) - (early-p (not (eq *boot-state* 'complete))) - first second (size 0)) + (early-gf-methods gf) + (generic-function-methods gf))) + (all-index nil) + (no-class-slots-p t) + (early-p (not (eq *boot-state* 'complete))) + first second (size 0)) (declare (fixnum size)) ;; class -> {(specl slotd)} (dolist (method methods) (let* ((specializers (if (consp method) - (early-method-specializers method t) - (method-specializers method))) - (specl (ecase type - ((reader boundp) (car specializers)) - (writer (cadr specializers)))) - (specl-cpl (if early-p - (early-class-precedence-list specl) - (and (class-finalized-p specl) - (class-precedence-list specl)))) - (so-p (member *the-class-std-object* specl-cpl)) - (slot-name (if (consp method) - (and (early-method-standard-accessor-p method) - (early-method-standard-accessor-slot-name - method)) - (accessor-method-slot-name method)))) - (when (or (null specl-cpl) - (member *the-class-structure-object* specl-cpl)) - (return-from make-accessor-table nil)) - (maphash (lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-std-object* cpl)) - (or early-p - (slot-accessor-std-p slotd type))) - (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) - (gethash slot-name *name->class->slotd-table*)))) + (early-method-specializers method t) + (method-specializers method))) + (specl (ecase type + ((reader boundp) (car specializers)) + (writer (cadr specializers)))) + (specl-cpl (if early-p + (early-class-precedence-list specl) + (and (class-finalized-p specl) + (class-precedence-list specl)))) + (so-p (member *the-class-std-object* specl-cpl)) + (slot-name (if (consp method) + (and (early-method-standard-accessor-p method) + (early-method-standard-accessor-slot-name + method)) + (accessor-method-slot-name method)))) + (when (or (null specl-cpl) + (member *the-class-structure-object* specl-cpl)) + (return-from make-accessor-table nil)) + (maphash (lambda (class slotd) + (let ((cpl (if early-p + (early-class-precedence-list class) + (class-precedence-list class)))) + (when (memq specl cpl) + (unless (and (or so-p + (member *the-class-std-object* cpl)) + (or early-p + (slot-accessor-std-p slotd type))) + (return-from make-accessor-table nil)) + (push (cons specl slotd) (gethash class table))))) + (gethash slot-name *name->class->slotd-table*)))) (maphash (lambda (class specl+slotd-list) - (dolist (sclass (if early-p - (early-class-precedence-list class) - (class-precedence-list class)) - (error "This can't happen.")) - (let ((a (assq sclass specl+slotd-list))) - (when a - (let* ((slotd (cdr a)) - (index (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)))) - (unless index (return-from make-accessor-table nil)) - (setf (gethash class table) index) - (when (consp index) (setq no-class-slots-p nil)) - (setq all-index (if (or (null all-index) - (eql all-index index)) - index t)) - (incf size) - (cond ((= size 1) (setq first class)) - ((= size 2) (setq second class))) - (return nil)))))) - table) + (dolist (sclass (if early-p + (early-class-precedence-list class) + (class-precedence-list class)) + (error "This can't happen.")) + (let ((a (assq sclass specl+slotd-list))) + (when a + (let* ((slotd (cdr a)) + (index (if early-p + (early-slot-definition-location slotd) + (slot-definition-location slotd)))) + (unless index (return-from make-accessor-table nil)) + (setf (gethash class table) index) + (when (consp index) (setq no-class-slots-p nil)) + (setq all-index (if (or (null all-index) + (eql all-index index)) + index t)) + (incf size) + (cond ((= size 1) (setq first class)) + ((= size 2) (setq second class))) + (return nil)))))) + table) (values table all-index first second size no-class-slots-p))) (defun compute-applicable-methods-using-types (generic-function types) (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) - (early-gf-methods generic-function) - (generic-function-methods generic-function))) + (early-gf-methods generic-function) + (generic-function-methods generic-function))) (let ((specls (if (consp method) - (early-method-specializers method t) - (method-specializers method))) - (types types) - (possibly-applicable-p t) (applicable-p t)) - (dolist (specl specls) - (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) - (specializer-applicable-using-type-p specl (pop types)) - (unless specl-applicable-p - (setq applicable-p nil)) - (unless specl-possibly-applicable-p - (setq possibly-applicable-p nil) - (return nil)))) - (when possibly-applicable-p - (unless applicable-p (setq definite-p nil)) - (push method possibly-applicable-methods)))) + (early-method-specializers method t) + (method-specializers method))) + (types types) + (possibly-applicable-p t) (applicable-p t)) + (dolist (specl specls) + (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) + (specializer-applicable-using-type-p specl (pop types)) + (unless specl-applicable-p + (setq applicable-p nil)) + (unless specl-possibly-applicable-p + (setq possibly-applicable-p nil) + (return nil)))) + (when possibly-applicable-p + (unless applicable-p (setq definite-p nil)) + (push method possibly-applicable-methods)))) (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info - generic-function) - (gf-arg-info - generic-function))))) + (early-gf-arg-info + generic-function) + (gf-arg-info + generic-function))))) (values (sort-applicable-methods precedence - (nreverse possibly-applicable-methods) - types) - definite-p)))) + (nreverse possibly-applicable-methods) + types) + definite-p)))) (defun sort-applicable-methods (precedence methods types) (sort-methods methods - precedence - (lambda (class1 class2 index) - (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list class)))) - (if (memq class2 (memq class1 cpl)) - class1 class2))))) + precedence + (lambda (class1 class2 index) + (let* ((class (type-class (nth index types))) + (cpl (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class)))) + (if (memq class2 (memq class1 cpl)) + class1 class2))))) (defun sort-methods (methods precedence compare-classes-function) (flet ((sorter (method1 method2) - (dolist (index precedence) - (let* ((specl1 (nth index (if (listp method1) - (early-method-specializers method1 - t) - (method-specializers method1)))) - (specl2 (nth index (if (listp method2) - (early-method-specializers method2 - t) - (method-specializers method2)))) - (order (order-specializers - specl1 specl2 index compare-classes-function))) - (when order - (return-from sorter (eq order specl1))))))) + (dolist (index precedence) + (let* ((specl1 (nth index (if (listp method1) + (early-method-specializers method1 + t) + (method-specializers method1)))) + (specl2 (nth index (if (listp method2) + (early-method-specializers method2 + t) + (method-specializers method2)))) + (order (order-specializers + specl1 specl2 index compare-classes-function))) + (when order + (return-from sorter (eq order specl1))))))) (stable-sort methods #'sorter))) (defun order-specializers (specl1 specl2 index compare-classes-function) (let ((type1 (if (eq *boot-state* 'complete) - (specializer-type specl1) - (!bootstrap-get-slot 'specializer specl1 'type))) - (type2 (if (eq *boot-state* 'complete) - (specializer-type specl2) - (!bootstrap-get-slot 'specializer specl2 'type)))) + (specializer-type specl1) + (!bootstrap-get-slot 'specializer specl1 'type))) + (type2 (if (eq *boot-state* 'complete) + (specializer-type specl2) + (!bootstrap-get-slot 'specializer specl2 'type)))) (cond ((eq specl1 specl2) - nil) - ((atom type1) - specl2) - ((atom type2) - specl1) - (t - (case (car type1) - (class (case (car type2) - (class (funcall compare-classes-function - specl1 specl2 index)) - (t specl2))) - (prototype (case (car type2) - (class (funcall compare-classes-function - specl1 specl2 index)) - (t specl2))) - (class-eq (case (car type2) - (eql specl2) - (class-eq nil) - (class type1))) - (eql (case (car type2) - (eql nil) - (t specl1)))))))) + nil) + ((atom type1) + specl2) + ((atom type2) + specl1) + (t + (case (car type1) + (class (case (car type2) + (class (funcall compare-classes-function + specl1 specl2 index)) + (t specl2))) + (prototype (case (car type2) + (class (funcall compare-classes-function + specl1 specl2 index)) + (t specl2))) + (class-eq (case (car type2) + (eql specl2) + (class-eq nil) + (class type1))) + (eql (case (car type2) + (eql nil) + (t specl1)))))))) (defun map-all-orders (methods precedence function) (let ((choices nil)) (flet ((compare-classes-function (class1 class2 index) - (declare (ignore index)) - (let ((choice nil)) - (dolist (c choices nil) - (when (or (and (eq (first c) class1) - (eq (second c) class2)) - (and (eq (first c) class2) - (eq (second c) class1))) - (return (setq choice c)))) - (unless choice - (setq choice - (if (class-might-precede-p class1 class2) - (if (class-might-precede-p class2 class1) - (list class1 class2 nil t) - (list class1 class2 t)) - (if (class-might-precede-p class2 class1) - (list class2 class1 t) - (let ((name1 (class-name class1)) - (name2 (class-name class2))) - (if (and name1 - name2 - (symbolp name1) - (symbolp name2) - (string< (symbol-name name1) - (symbol-name name2))) - (list class1 class2 t) - (list class2 class1 t)))))) - (push choice choices)) - (car choice)))) + (declare (ignore index)) + (let ((choice nil)) + (dolist (c choices nil) + (when (or (and (eq (first c) class1) + (eq (second c) class2)) + (and (eq (first c) class2) + (eq (second c) class1))) + (return (setq choice c)))) + (unless choice + (setq choice + (if (class-might-precede-p class1 class2) + (if (class-might-precede-p class2 class1) + (list class1 class2 nil t) + (list class1 class2 t)) + (if (class-might-precede-p class2 class1) + (list class2 class1 t) + (let ((name1 (class-name class1)) + (name2 (class-name class2))) + (if (and name1 + name2 + (symbolp name1) + (symbolp name2) + (string< (symbol-name name1) + (symbol-name name2))) + (list class1 class2 t) + (list class2 class1 t)))))) + (push choice choices)) + (car choice)))) (loop (funcall function - (sort-methods methods - precedence - #'compare-classes-function)) - (unless (dolist (c choices nil) - (unless (third c) - (rotatef (car c) (cadr c)) - (return (setf (third c) t)))) - (return nil)))))) + (sort-methods methods + precedence + #'compare-classes-function)) + (unless (dolist (c choices nil) + (unless (third c) + (rotatef (car c) (cadr c)) + (return (setf (third c) t)))) + (return nil)))))) ;;; CMUCL comment: used only in map-all-orders (defun class-might-precede-p (class1 class2) @@ -1495,9 +1495,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) (let ((list nil)) - (dotimes-fixnum (i nreq list) (push (- (1- nreq) i) list))) + (dotimes-fixnum (i nreq list) (push (- (1- nreq) i) list))) (mapcar (lambda (x) (position x lambda-list)) - argument-precedence-order))) + argument-precedence-order))) (defun cpl-or-nil (class) (if (eq *boot-state* 'complete) @@ -1520,43 +1520,43 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun saut-and (specl type) (let ((applicable nil) - (possibly-applicable t)) + (possibly-applicable t)) (dolist (type (cdr type)) (multiple-value-bind (appl poss-appl) - (specializer-applicable-using-type-p specl type) - (when appl (return (setq applicable t))) - (unless poss-appl (return (setq possibly-applicable nil))))) + (specializer-applicable-using-type-p specl type) + (when appl (return (setq applicable t))) + (unless poss-appl (return (setq possibly-applicable nil))))) (values applicable possibly-applicable))) (defun saut-not (specl type) (let ((ntype (cadr type))) (values nil - (case (car ntype) - (class (saut-not-class specl ntype)) - (class-eq (saut-not-class-eq specl ntype)) - (prototype (saut-not-prototype specl ntype)) - (eql (saut-not-eql specl ntype)) - (t (error "~S cannot handle the second argument ~S" - 'specializer-applicable-using-type-p type)))))) + (case (car ntype) + (class (saut-not-class specl ntype)) + (class-eq (saut-not-class-eq specl ntype)) + (prototype (saut-not-prototype specl ntype)) + (eql (saut-not-eql specl ntype)) + (t (error "~S cannot handle the second argument ~S" + 'specializer-applicable-using-type-p type)))))) (defun saut-not-class (specl ntype) (let* ((class (type-class specl)) - (cpl (cpl-or-nil class))) + (cpl (cpl-or-nil class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-prototype (specl ntype) (let* ((class (case (car specl) - (eql (class-of (cadr specl))) - (class-eq (cadr specl)) - (prototype (cadr specl)) - (class (cadr specl)))) - (cpl (cpl-or-nil class))) + (eql (class-of (cadr specl))) + (class-eq (cadr specl)) + (prototype (cadr specl)) + (class (cadr specl)))) + (cpl (cpl-or-nil class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-class-eq (specl ntype) (let ((class (case (car specl) - (eql (class-of (cadr specl))) - (class-eq (cadr specl))))) + (eql (class-of (cadr specl))) + (class-eq (cadr specl))))) (not (eq class (cadr ntype))))) (defun saut-not-eql (specl ntype) @@ -1567,38 +1567,38 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun class-applicable-using-class-p (specl type) (let ((pred (memq specl (cpl-or-nil type)))) (values pred - (or pred - (if (not *in-precompute-effective-methods-p*) - ;; classes might get common subclass - (superclasses-compatible-p specl type) - ;; worry only about existing classes - (classes-have-common-subclass-p specl type)))))) + (or pred + (if (not *in-precompute-effective-methods-p*) + ;; classes might get common subclass + (superclasses-compatible-p specl type) + ;; worry only about existing classes + (classes-have-common-subclass-p specl type)))))) (defun classes-have-common-subclass-p (class1 class2) (or (eq class1 class2) (let ((class1-subs (class-direct-subclasses class1))) - (or (memq class2 class1-subs) - (dolist (class1-sub class1-subs nil) - (when (classes-have-common-subclass-p class1-sub class2) - (return t))))))) + (or (memq class2 class1-subs) + (dolist (class1-sub class1-subs nil) + (when (classes-have-common-subclass-p class1-sub class2) + (return t))))))) (defun saut-class (specl type) (case (car specl) (class (class-applicable-using-class-p (cadr specl) (cadr type))) (t (values nil (let ((class (type-class specl))) - (memq (cadr type) - (cpl-or-nil class))))))) + (memq (cadr type) + (cpl-or-nil class))))))) (defun saut-class-eq (specl type) (if (eq (car specl) 'eql) (values nil (eq (class-of (cadr specl)) (cadr type))) (let ((pred (case (car specl) - (class-eq - (eq (cadr specl) (cadr type))) - (class - (or (eq (cadr specl) (cadr type)) - (memq (cadr specl) (cpl-or-nil (cadr type)))))))) - (values pred pred)))) + (class-eq + (eq (cadr specl) (cadr type))) + (class + (or (eq (cadr specl) (cadr type)) + (memq (cadr specl) (cpl-or-nil (cadr type)))))))) + (values pred pred)))) (defun saut-prototype (specl type) (declare (ignore specl type)) @@ -1606,11 +1606,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun saut-eql (specl type) (let ((pred (case (car specl) - (eql (eql (cadr specl) (cadr type))) - (class-eq (eq (cadr specl) (class-of (cadr type)))) - (class (memq (cadr specl) - (let ((class (class-of (cadr type)))) - (cpl-or-nil class))))))) + (eql (eql (cadr specl) (cadr type))) + (class-eq (eq (cadr specl) (class-of (cadr type)))) + (class (memq (cadr specl) + (let ((class (class-of (cadr type)))) + (cpl-or-nil class))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) @@ -1622,28 +1622,28 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (or (atom type) (eq (car type) t)) (values nil t) (case (car type) - (and (saut-and specl type)) - (not (saut-not specl type)) - (class (saut-class specl type)) - (prototype (saut-prototype specl type)) - (class-eq (saut-class-eq specl type)) - (eql (saut-eql specl type)) - (t (error "~S cannot handle the second argument ~S." - 'specializer-applicable-using-type-p - type))))) + (and (saut-and specl type)) + (not (saut-not specl type)) + (class (saut-class specl type)) + (prototype (saut-prototype specl type)) + (class-eq (saut-class-eq specl type)) + (eql (saut-eql specl type)) + (t (error "~S cannot handle the second argument ~S." + 'specializer-applicable-using-type-p + type))))) (defun map-all-classes (function &optional (root t)) (let ((braid-p (or (eq *boot-state* 'braid) - (eq *boot-state* 'complete)))) + (eq *boot-state* 'complete)))) (labels ((do-class (class) - (mapc #'do-class - (if braid-p - (class-direct-subclasses class) - (early-class-direct-subclasses class))) - (funcall function class))) + (mapc #'do-class + (if braid-p + (class-direct-subclasses class) + (early-class-direct-subclasses class))) + (funcall function class))) (do-class (if (symbolp root) - (find-class root) - root))))) + (find-class root) + root))))) (defvar *effective-method-cache* (make-hash-table :test 'eq)) @@ -1652,71 +1652,71 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (remhash method *effective-method-cache*))) (defun get-secondary-dispatch-function (gf methods types - &optional method-alist wrappers) + &optional method-alist wrappers) (let ((generator - (get-secondary-dispatch-function1 - gf methods types (not (null method-alist)) (not (null wrappers)) - (not (methods-contain-eql-specializer-p methods))))) + (get-secondary-dispatch-function1 + gf methods types (not (null method-alist)) (not (null wrappers)) + (not (methods-contain-eql-specializer-p methods))))) (make-callable gf methods generator method-alist wrappers))) (defun get-secondary-dispatch-function1 (gf methods types method-alist-p - wrappers-p - &optional - all-applicable-p - (all-sorted-p t) - function-p) + wrappers-p + &optional + all-applicable-p + (all-sorted-p t) + function-p) (if (null methods) (if function-p - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(instance-lambda (&rest args) - (apply #'no-applicable-method gf args))) - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - (lambda (&rest args) - (apply #'no-applicable-method gf args)))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(instance-lambda (&rest args) + (apply #'no-applicable-method gf args))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) - (ht-value (or (gethash key *effective-method-cache*) - (setf (gethash key *effective-method-cache*) - (cons nil nil))))) - (if (and (null (cdr methods)) all-applicable-p ; the most common case - (null method-alist-p) wrappers-p (not function-p)) - (or (car ht-value) - (setf (car ht-value) - (get-secondary-dispatch-function2 - gf methods types method-alist-p wrappers-p - all-applicable-p all-sorted-p function-p))) - (let ((akey (list methods - (if all-applicable-p 'all-applicable types) - method-alist-p wrappers-p function-p))) - (or (cdr (assoc akey (cdr ht-value) :test #'equal)) - (let ((value (get-secondary-dispatch-function2 - gf methods types method-alist-p wrappers-p - all-applicable-p all-sorted-p function-p))) - (push (cons akey value) (cdr ht-value)) - value))))))) + (ht-value (or (gethash key *effective-method-cache*) + (setf (gethash key *effective-method-cache*) + (cons nil nil))))) + (if (and (null (cdr methods)) all-applicable-p ; the most common case + (null method-alist-p) wrappers-p (not function-p)) + (or (car ht-value) + (setf (car ht-value) + (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (let ((akey (list methods + (if all-applicable-p 'all-applicable types) + method-alist-p wrappers-p function-p))) + (or (cdr (assoc akey (cdr ht-value) :test #'equal)) + (let ((value (get-secondary-dispatch-function2 + gf methods types method-alist-p wrappers-p + all-applicable-p all-sorted-p function-p))) + (push (cons akey value) (cdr ht-value)) + value))))))) (defun get-secondary-dispatch-function2 (gf methods types method-alist-p - wrappers-p all-applicable-p - all-sorted-p function-p) + wrappers-p all-applicable-p + all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) (if (eq *boot-state* 'complete) - (let* ((combin (generic-function-method-combination gf)) - (effective (compute-effective-method gf combin methods))) - (make-effective-method-function1 gf effective method-alist-p - wrappers-p)) - (let ((effective (standard-compute-effective-method gf nil methods))) - (make-effective-method-function1 gf effective method-alist-p - wrappers-p))) + (let* ((combin (generic-function-method-combination gf)) + (effective (compute-effective-method gf combin methods))) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p)) + (let ((effective (standard-compute-effective-method gf nil methods))) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p))) (let ((net (generate-discrimination-net - gf methods types all-sorted-p))) - (compute-secondary-dispatch-function1 gf net function-p)))) + gf methods types all-sorted-p))) + (compute-secondary-dispatch-function1 gf net function-p)))) (defun get-effective-method-function (gf methods - &optional method-alist wrappers) + &optional method-alist wrappers) (let ((generator - (get-secondary-dispatch-function1 - gf methods nil (not (null method-alist)) (not (null wrappers)) t))) + (get-secondary-dispatch-function1 + gf methods nil (not (null method-alist)) (not (null wrappers)) t))) (make-callable gf methods generator method-alist wrappers))) (defun get-effective-method-function1 (gf methods &optional (sorted-p t)) @@ -1725,19 +1725,19 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun methods-contain-eql-specializer-p (methods) (and (eq *boot-state* 'complete) (dolist (method methods nil) - (when (dolist (spec (method-specializers method) nil) - (when (eql-specializer-p spec) (return t))) - (return t))))) + (when (dolist (spec (method-specializers method) nil) + (when (eql-specializer-p spec) (return t))) + (return t))))) (defun update-dfun (generic-function &optional dfun cache info) (let* ((early-p (early-gf-p generic-function)) - (gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name generic-function)))) + (gf-name (if early-p + (!early-gf-name generic-function) + (generic-function-name generic-function)))) (set-dfun generic-function dfun cache info) (let ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function)))) + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) (set-funcallable-instance-function generic-function dfun) (set-fun-name generic-function gf-name) dfun))) @@ -1753,7 +1753,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 #| (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) - (a (assq sym *dfun-list*))) + (a (assq sym *dfun-list*))) (unless a (push (setq a (list sym)) *dfun-list*)) (push (generic-function-name gf) (cdr a)))) @@ -1765,16 +1765,16 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun list-large-cache (gf) (let* ((sym (type-of (gf-dfun-info gf))) - (cache (gf-dfun-cache gf))) + (cache (gf-dfun-cache gf))) (when cache (let ((size (cache-size cache))) - (when (>= size *minimum-cache-size-to-list*) - (let ((a (assoc size *dfun-list*))) - (unless a - (push (setq a (list size)) *dfun-list*)) - (push (let ((name (generic-function-name gf))) - (if (eq sym 'caching) name (list name sym))) - (cdr a)))))))) + (when (>= size *minimum-cache-size-to-list*) + (let ((a (assoc size *dfun-list*))) + (unless a + (push (setq a (list size)) *dfun-list*)) + (push (let ((name (generic-function-name gf))) + (if (eq sym 'caching) name (list name sym))) + (cdr a)))))))) (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) (setq *dfun-list* nil) @@ -1785,33 +1785,33 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun count-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) - (cache (gf-dfun-cache gf)) - (a (assq sym *dfun-count*))) + (cache (gf-dfun-cache gf)) + (a (assq sym *dfun-count*))) (unless a (push (setq a (list sym 0 nil)) *dfun-count*)) (incf (cadr a)) (when cache (let* ((size (cache-size cache)) - (b (assoc size (third a)))) - (unless b - (push (setq b (cons size 0)) (third a))) - (incf (cdr b)))))) + (b (assoc size (third a)))) + (unless b + (push (setq b (cons size 0)) (third a))) + (incf (cdr b)))))) (defun count-all-dfuns () (setq *dfun-count* (mapcar (lambda (type) (list type 0 nil)) - '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY - ONE-INDEX N-N CHECKING CACHING - DISPATCH))) + '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY + ONE-INDEX N-N CHECKING CACHING + DISPATCH))) (map-all-generic-functions #'count-dfun) (mapc (lambda (type+count+sizes) - (setf (third type+count+sizes) - (sort (third type+count+sizes) #'< :key #'car))) - *dfun-count*) + (setf (third type+count+sizes) + (sort (third type+count+sizes) #'< :key #'car))) + *dfun-count*) (mapc (lambda (type+count+sizes) - (format t "~&There are ~W dfuns of type ~S." - (cadr type+count+sizes) (car type+count+sizes)) - (format t "~% ~S~%" (caddr type+count+sizes))) - *dfun-count*) + (format t "~&There are ~W dfuns of type ~S." + (cadr type+count+sizes) (car type+count+sizes)) + (format t "~% ~S~%" (caddr type+count+sizes))) + *dfun-count*) (values)) |# @@ -1819,7 +1819,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (unless (consp type) (setq type (list type))) (let ((gf-list nil)) (map-all-generic-functions (lambda (gf) - (when (memq (type-of (gf-dfun-info gf)) - type) - (push gf gf-list)))) + (when (memq (type-of (gf-dfun-info gf)) + type) + (push gf gf-list)))) gf-list)) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 6b388e4..99bb789 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -103,34 +103,34 @@ (unless *optimize-cache-functions-p* (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-default-only - (emit-default-only-function metatypes applyp)))) + (emit-default-only-function metatypes applyp)))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) - (args (remove '&rest dlap-lambda-list)) - (restl (when applyp '(.lap-rest-arg.)))) + (args (remove '&rest dlap-lambda-list)) + (restl (when applyp '(.lap-rest-arg.)))) (generating-lisp '(emf) - dlap-lambda-list - `(invoke-effective-method-function emf - ,applyp - ,@args - ,@restl)))) + dlap-lambda-list + `(invoke-effective-method-function emf + ,applyp + ,@args + ,@restl)))) ;;; -------------------------------- (defun generating-lisp (closure-variables args form) (let* ((rest (memq '&rest args)) - (ldiff (and rest (ldiff args rest))) - (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args)) - (lambda `(lambda ,closure-variables - ,@(when (member 'miss-fn closure-variables) - `((declare (type function miss-fn)))) - #'(instance-lambda ,args - (let () - (declare #.*optimize-speed*) - ,form))))) + (ldiff (and rest (ldiff args rest))) + (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args)) + (lambda `(lambda ,closure-variables + ,@(when (member 'miss-fn closure-variables) + `((declare (type function miss-fn)))) + #'(instance-lambda ,args + (let () + (declare #.*optimize-speed*) + ,form))))) (values (if *precompiling-lap* - `#',lambda - (compile nil lambda)) - nil))) + `#',lambda + (compile nil lambda)) + nil))) ;;; note on implementation for CMU 17 and later (including SBCL): ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL @@ -143,20 +143,20 @@ (unless *optimize-cache-functions-p* (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-reader/writer - (emit-reader/writer-function - reader/writer 1-or-2-class class-slot-p)))) + (emit-reader/writer-function + reader/writer 1-or-2-class class-slot-p)))) (let ((instance nil) - (arglist ()) - (closure-variables ()) - (field +first-wrapper-cache-number-index+) - (read-form (emit-slot-read-form class-slot-p 'index 'slots))) + (arglist ()) + (closure-variables ()) + (field +first-wrapper-cache-number-index+) + (read-form (emit-slot-read-form class-slot-p 'index 'slots))) ;;we need some field to do the fast obsolete check (ecase reader/writer ((:reader :boundp) (setq instance (dfun-arg-symbol 0) - arglist (list instance))) + arglist (list instance))) (:writer (setq instance (dfun-arg-symbol 1) - arglist (list (dfun-arg-symbol 0) instance)))) + arglist (list (dfun-arg-symbol 0) instance)))) (ecase 1-or-2-class (1 (setq closure-variables '(wrapper-0 index miss-fn))) (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) @@ -164,34 +164,34 @@ closure-variables arglist `(let* (,@(unless class-slot-p `((slots nil))) - (wrapper (cond ((std-instance-p ,instance) - ,@(unless class-slot-p - `((setq slots - (std-instance-slots ,instance)))) - (std-instance-wrapper ,instance)) - ((fsc-instance-p ,instance) - ,@(unless class-slot-p - `((setq slots - (fsc-instance-slots ,instance)))) - (fsc-instance-wrapper ,instance))))) - (block access - (when (and wrapper - (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) - ,@(if (eql 1 1-or-2-class) - `((eq wrapper wrapper-0)) - `((or (eq wrapper wrapper-0) - (eq wrapper wrapper-1))))) - ,@(ecase reader/writer - (:reader - `((let ((value ,read-form)) - (unless (eq value +slot-unbound+) - (return-from access value))))) - (:boundp - `((let ((value ,read-form)) + (wrapper (cond ((std-instance-p ,instance) + ,@(unless class-slot-p + `((setq slots + (std-instance-slots ,instance)))) + (std-instance-wrapper ,instance)) + ((fsc-instance-p ,instance) + ,@(unless class-slot-p + `((setq slots + (fsc-instance-slots ,instance)))) + (fsc-instance-wrapper ,instance))))) + (block access + (when (and wrapper + (/= (wrapper-cache-number-vector-ref wrapper ,field) 0) + ,@(if (eql 1 1-or-2-class) + `((eq wrapper wrapper-0)) + `((or (eq wrapper wrapper-0) + (eq wrapper wrapper-1))))) + ,@(ecase reader/writer + (:reader + `((let ((value ,read-form)) + (unless (eq value +slot-unbound+) + (return-from access value))))) + (:boundp + `((let ((value ,read-form)) (return-from access (not (eq value +slot-unbound+)))))) - (:writer - `((return-from access (setf ,read-form ,(car arglist))))))) - (funcall miss-fn ,@arglist)))))) + (:writer + `((return-from access (setf ,read-form ,(car arglist))))))) + (funcall miss-fn ,@arglist)))))) (defun emit-slot-read-form (class-slot-p index slots) (if class-slot-p @@ -201,11 +201,11 @@ (defun emit-boundp-check (value-form miss-fn arglist) `(let ((value ,value-form)) (if (eq value +slot-unbound+) - (funcall ,miss-fn ,@arglist) - value))) + (funcall ,miss-fn ,@arglist) + value))) (defun emit-slot-access (reader/writer class-slot-p slots - index miss-fn arglist) + index miss-fn arglist) (let ((read-form (emit-slot-read-form class-slot-p index slots))) (ecase reader/writer (:reader (emit-boundp-check read-form miss-fn arglist)) @@ -214,132 +214,132 @@ (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) (let ((*emit-function-p* nil) - (*precompiling-lap* t)) + (*precompiling-lap* t)) (values (emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) (defun emit-one-or-n-index-reader/writer (reader/writer - cached-index-p - class-slot-p) + cached-index-p + class-slot-p) (unless *optimize-cache-functions-p* (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-one-or-n-index-reader/writer - (emit-one-or-n-index-reader/writer-function - reader/writer cached-index-p class-slot-p)))) + (emit-one-or-n-index-reader/writer-function + reader/writer cached-index-p class-slot-p)))) (multiple-value-bind (arglist metatypes) (ecase reader/writer - ((:reader :boundp) - (values (list (dfun-arg-symbol 0)) - '(standard-instance))) - (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) - '(t standard-instance)))) + ((:reader :boundp) + (values (list (dfun-arg-symbol 0)) + '(standard-instance))) + (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) + '(t standard-instance)))) (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) arglist `(let (,@(unless class-slot-p '(slots)) - ,@(when cached-index-p '(index))) - ,(emit-dlap arglist metatypes - (emit-slot-access reader/writer class-slot-p - 'slots 'index 'miss-fn arglist) - `(funcall miss-fn ,@arglist) - (when cached-index-p 'index) - (unless class-slot-p '(slots))))))) + ,@(when cached-index-p '(index))) + ,(emit-dlap arglist metatypes + (emit-slot-access reader/writer class-slot-p + 'slots 'index 'miss-fn arglist) + `(funcall miss-fn ,@arglist) + (when cached-index-p 'index) + (unless class-slot-p '(slots))))))) (defmacro emit-one-or-n-index-reader/writer-macro (reader/writer cached-index-p class-slot-p) (let ((*emit-function-p* nil) - (*precompiling-lap* t)) + (*precompiling-lap* t)) (values (emit-one-or-n-index-reader/writer reader/writer - cached-index-p - class-slot-p)))) + cached-index-p + class-slot-p)))) (defun emit-miss (miss-fn args &optional applyp) (let ((restl (when applyp '(.lap-rest-arg.)))) (if restl - `(apply ,miss-fn ,@args ,@restl) - `(funcall ,miss-fn ,@args ,@restl)))) + `(apply ,miss-fn ,@args ,@restl) + `(funcall ,miss-fn ,@args ,@restl)))) (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) (unless *optimize-cache-functions-p* (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-checking-or-caching - (emit-checking-or-caching-function - cached-emf-p return-value-p metatypes applyp)))) + (emit-checking-or-caching-function + cached-emf-p return-value-p metatypes applyp)))) (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) - (args (remove '&rest dlap-lambda-list)) - (restl (when applyp '(.lap-rest-arg.)))) + (args (remove '&rest dlap-lambda-list)) + (restl (when applyp '(.lap-rest-arg.)))) (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) dlap-lambda-list `(let (,@(when cached-emf-p '(emf))) - ,(emit-dlap args - metatypes - (if return-value-p - (if cached-emf-p 'emf t) - `(invoke-effective-method-function - emf ,applyp ,@args ,@restl)) - (emit-miss 'miss-fn args applyp) - (when cached-emf-p 'emf)))))) + ,(emit-dlap args + metatypes + (if return-value-p + (if cached-emf-p 'emf t) + `(invoke-effective-method-function + emf ,applyp ,@args ,@restl)) + (emit-miss 'miss-fn args applyp) + (when cached-emf-p 'emf)))))) (defmacro emit-checking-or-caching-macro (cached-emf-p - return-value-p - metatypes - applyp) + return-value-p + metatypes + applyp) (let ((*emit-function-p* nil) - (*precompiling-lap* t)) + (*precompiling-lap* t)) (values (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) (let* ((index -1) - (wrapper-bindings (mapcan (lambda (arg mt) - (unless (eq mt t) - (incf index) - `((,(format-symbol *pcl-package* - "WRAPPER-~D" - index) - ,(emit-fetch-wrapper - mt arg 'miss (pop slot-regs)))))) - args metatypes)) - (wrappers (mapcar #'car wrapper-bindings))) + (wrapper-bindings (mapcan (lambda (arg mt) + (unless (eq mt t) + (incf index) + `((,(format-symbol *pcl-package* + "WRAPPER-~D" + index) + ,(emit-fetch-wrapper + mt arg 'miss (pop slot-regs)))))) + args metatypes)) + (wrappers (mapcar #'car wrapper-bindings))) (declare (fixnum index)) (unless wrappers (error "Every metatype is T.")) `(block dfun (tagbody - (let ((field (cache-field cache)) - (cache-vector (cache-vector cache)) - (mask (cache-mask cache)) - (size (cache-size cache)) - (overflow (cache-overflow cache)) - ,@wrapper-bindings) - (declare (fixnum size field mask)) - ,(cond ((cdr wrappers) - (emit-greater-than-1-dlap wrappers 'miss value-reg)) - (value-reg - (emit-1-t-dlap (car wrappers) 'miss value-reg)) - (t - (emit-1-nil-dlap (car wrappers) 'miss))) - (return-from dfun ,hit)) - miss - (return-from dfun ,miss))))) + (let ((field (cache-field cache)) + (cache-vector (cache-vector cache)) + (mask (cache-mask cache)) + (size (cache-size cache)) + (overflow (cache-overflow cache)) + ,@wrapper-bindings) + (declare (fixnum size field mask)) + ,(cond ((cdr wrappers) + (emit-greater-than-1-dlap wrappers 'miss value-reg)) + (value-reg + (emit-1-t-dlap (car wrappers) 'miss value-reg)) + (t + (emit-1-nil-dlap (car wrappers) 'miss))) + (return-from dfun ,hit)) + miss + (return-from dfun ,miss))))) (defun emit-1-nil-dlap (wrapper miss-label) `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper - miss-label)) - (location primary)) + miss-label)) + (location primary)) (declare (fixnum primary location)) (block search (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) - (return-from search nil)) - (setq location (the fixnum (+ location 1))) - (when (= location size) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (when (eq (car entry) ,wrapper) - (return-from search nil))) - (go ,miss-label)))))) + (return-from search nil)) + (setq location (the fixnum (+ location 1))) + (when (= location size) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (when (eq (car entry) ,wrapper) + (return-from search nil))) + (go ,miss-label)))))) (defmacro get-cache-vector-lock-count (cache-vector) `(let ((lock-count (cache-vector-lock-count ,cache-vector))) @@ -349,103 +349,103 @@ (defun emit-1-t-dlap (wrapper miss-label value) `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper - miss-label)) - (initial-lock-count (get-cache-vector-lock-count cache-vector))) + miss-label)) + (initial-lock-count (get-cache-vector-lock-count cache-vector))) (declare (fixnum primary initial-lock-count)) (let ((location primary)) (declare (fixnum location)) (block search - (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) - (setq ,value (cache-vector-ref cache-vector (1+ location))) - (return-from search nil)) - (setq location (the fixnum (+ location 2))) - (when (= location size) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (when (eq (car entry) ,wrapper) - (setq ,value (cdr entry)) - (return-from search nil))) - (go ,miss-label)))) + (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) + (setq ,value (cache-vector-ref cache-vector (1+ location))) + (return-from search nil)) + (setq location (the fixnum (+ location 2))) + (when (= location size) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (when (eq (car entry) ,wrapper) + (setq ,value (cdr entry)) + (return-from search nil))) + (go ,miss-label)))) (unless (= initial-lock-count - (get-cache-vector-lock-count cache-vector)) - (go ,miss-label))))) + (get-cache-vector-lock-count cache-vector)) + (go ,miss-label))))) (defun emit-greater-than-1-dlap (wrappers miss-label value) (declare (type list wrappers)) (let ((cache-line-size (compute-line-size (+ (length wrappers) - (if value 1 0))))) + (if value 1 0))))) `(let ((primary 0) - (size-1 (the fixnum (- size 1)))) + (size-1 (the fixnum (- size 1)))) (declare (fixnum primary size-1)) ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) - (declare (fixnum initial-lock-count)) - (let ((location primary) - (next-location 0)) - (declare (fixnum location next-location)) - (block search - (loop (setq next-location - (the fixnum (+ location ,cache-line-size))) - (when (and ,@(mapcar - (lambda (wrapper) - `(eq ,wrapper - (cache-vector-ref - cache-vector - (setq location - (the fixnum (+ location 1)))))) - wrappers)) - ,@(when value - `((setq location (the fixnum (+ location 1))) - (setq ,value (cache-vector-ref cache-vector - location)))) - (return-from search nil)) - (setq location next-location) - (when (= location size-1) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (let ((entry-wrappers (car entry))) - (when (and ,@(mapcar (lambda (wrapper) - `(eq ,wrapper - (pop entry-wrappers))) - wrappers)) - ,@(when value - `((setq ,value (cdr entry)))) - (return-from search nil)))) - (go ,miss-label)))) - (unless (= initial-lock-count - (get-cache-vector-lock-count cache-vector)) - (go ,miss-label))))))) + (declare (fixnum initial-lock-count)) + (let ((location primary) + (next-location 0)) + (declare (fixnum location next-location)) + (block search + (loop (setq next-location + (the fixnum (+ location ,cache-line-size))) + (when (and ,@(mapcar + (lambda (wrapper) + `(eq ,wrapper + (cache-vector-ref + cache-vector + (setq location + (the fixnum (+ location 1)))))) + wrappers)) + ,@(when value + `((setq location (the fixnum (+ location 1))) + (setq ,value (cache-vector-ref cache-vector + location)))) + (return-from search nil)) + (setq location next-location) + (when (= location size-1) + (setq location 0)) + (when (= location primary) + (dolist (entry overflow) + (let ((entry-wrappers (car entry))) + (when (and ,@(mapcar (lambda (wrapper) + `(eq ,wrapper + (pop entry-wrappers))) + wrappers)) + ,@(when value + `((setq ,value (cdr entry)))) + (return-from search nil)))) + (go ,miss-label)))) + (unless (= initial-lock-count + (get-cache-vector-lock-count cache-vector)) + (go ,miss-label))))))) (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) (declare (fixnum wrapper-cache-no)) (when (zerop wrapper-cache-no) (go ,miss-label)) ,(let ((form `(logand mask wrapper-cache-no))) - `(the fixnum ,form)))) + `(the fixnum ,form)))) (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) (declare (type list wrappers)) ;; This returns 1 less that the actual location. `(progn ,@(let ((adds 0) (len (length wrappers))) - (declare (fixnum adds len)) - (mapcar (lambda (wrapper) - `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref - ,wrapper field))) - (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - (setq primary (the fixnum (+ primary wrapper-cache-no))) - ,@(progn - (incf adds) - (when (or (zerop (mod adds - wrapper-cache-number-adds-ok)) - (eql adds len)) - `((setq primary - ,(let ((form `(logand primary mask))) - `(the fixnum ,form)))))))) - wrappers)))) + (declare (fixnum adds len)) + (mapcar (lambda (wrapper) + `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref + ,wrapper field))) + (declare (fixnum wrapper-cache-no)) + (when (zerop wrapper-cache-no) (go ,miss-label)) + (setq primary (the fixnum (+ primary wrapper-cache-no))) + ,@(progn + (incf adds) + (when (or (zerop (mod adds + wrapper-cache-number-adds-ok)) + (eql adds len)) + `((setq primary + ,(let ((form `(logand primary mask))) + `(the fixnum ,form)))))))) + wrappers)))) ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the ;;; CMU/SBCL approach of using funcallable instances, that branch may @@ -456,15 +456,15 @@ ;;; as well as PCL fins. (defun emit-fetch-wrapper (metatype argument miss-label &optional slot) (ecase metatype - ((standard-instance) + ((standard-instance) `(cond ((std-instance-p ,argument) - ,@(when slot `((setq ,slot (std-instance-slots ,argument)))) - (std-instance-wrapper ,argument)) - ((fsc-instance-p ,argument) - ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) - (fsc-instance-wrapper ,argument)) - (t - (go ,miss-label)))) + ,@(when slot `((setq ,slot (std-instance-slots ,argument)))) + (std-instance-wrapper ,argument)) + ((fsc-instance-p ,argument) + ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) + (fsc-instance-wrapper ,argument)) + (t + (go ,miss-label)))) (class (when slot (error "can't do a slot reg for this metatype")) `(wrapper-of-macro ,argument)) diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp index 433832b..cfe0489 100644 --- a/src/pcl/dlisp2.lisp +++ b/src/pcl/dlisp2.lisp @@ -27,19 +27,19 @@ (values (ecase reader/writer (:reader (ecase 1-or-2-class - (1 (if class-slot-p - (emit-reader/writer-macro :reader 1 t) - (emit-reader/writer-macro :reader 1 nil))) - (2 (if class-slot-p - (emit-reader/writer-macro :reader 2 t) - (emit-reader/writer-macro :reader 2 nil))))) + (1 (if class-slot-p + (emit-reader/writer-macro :reader 1 t) + (emit-reader/writer-macro :reader 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :reader 2 t) + (emit-reader/writer-macro :reader 2 nil))))) (:writer (ecase 1-or-2-class - (1 (if class-slot-p - (emit-reader/writer-macro :writer 1 t) - (emit-reader/writer-macro :writer 1 nil))) - (2 (if class-slot-p - (emit-reader/writer-macro :writer 2 t) - (emit-reader/writer-macro :writer 2 nil))))) + (1 (if class-slot-p + (emit-reader/writer-macro :writer 1 t) + (emit-reader/writer-macro :writer 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :writer 2 t) + (emit-reader/writer-macro :writer 2 nil))))) (:boundp (ecase 1-or-2-class (1 (if class-slot-p (emit-reader/writer-macro :boundp 1 t) @@ -54,32 +54,32 @@ (values (ecase reader/writer (:reader (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader t t) - (emit-one-or-n-index-reader/writer-macro :reader t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader nil t) - (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader t t) + (emit-one-or-n-index-reader/writer-macro :reader t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader nil t) + (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) (:writer (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer t t) - (emit-one-or-n-index-reader/writer-macro :writer t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer nil t) - (emit-one-or-n-index-reader/writer-macro :writer nil nil)))) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer t t) + (emit-one-or-n-index-reader/writer-macro :writer t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer nil t) + (emit-one-or-n-index-reader/writer-macro :writer nil nil)))) (:boundp (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :boundp t t) - (emit-one-or-n-index-reader/writer-macro :boundp t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :boundp nil t) - (emit-one-or-n-index-reader/writer-macro :boundp nil nil))))) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :boundp t t) + (emit-one-or-n-index-reader/writer-macro :boundp t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :boundp nil t) + (emit-one-or-n-index-reader/writer-macro :boundp nil nil))))) nil)) (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) (values (emit-checking-or-caching-function-preliminary - cached-emf-p return-value-p metatypes applyp) - t)) + cached-emf-p return-value-p metatypes applyp) + t)) (defvar *not-in-cache* (make-symbol "not in cache")) @@ -88,41 +88,41 @@ (declare (ignore applyp)) (if cached-emf-p (lambda (cache miss-fn) - (declare (type function miss-fn)) - #'(instance-lambda (&rest args) + (declare (type function miss-fn)) + #'(instance-lambda (&rest args) (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*))) - (if (eq emf *not-in-cache*) - (apply miss-fn args) - (if return-value-p - emf - (invoke-emf emf args)))))))) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*))) + (if (eq emf *not-in-cache*) + (apply miss-fn args) + (if return-value-p + emf + (invoke-emf emf args)))))))) (lambda (cache emf miss-fn) - (declare (type function miss-fn)) - #'(instance-lambda (&rest args) - (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((found-p (not (eq *not-in-cache* - (probe-cache cache dfun-wrappers - *not-in-cache*))))) - (if found-p - (invoke-emf emf args) - (if return-value-p - t - (apply miss-fn args)))))))))) + (declare (type function miss-fn)) + #'(instance-lambda (&rest args) + (declare #.*optimize-speed*) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((found-p (not (eq *not-in-cache* + (probe-cache cache dfun-wrappers + *not-in-cache*))))) + (if found-p + (invoke-emf emf args) + (if return-value-p + t + (apply miss-fn args)))))))))) (defun emit-default-only-function (metatypes applyp) (declare (ignore metatypes applyp)) (values (lambda (emf) - (lambda (&rest args) - (invoke-emf emf args))) - t)) + (lambda (&rest args) + (invoke-emf emf args))) + t)) diff --git a/src/pcl/dlisp3.lisp b/src/pcl/dlisp3.lisp index 0cef2d6..c935ec2 100644 --- a/src/pcl/dlisp3.lisp +++ b/src/pcl/dlisp3.lisp @@ -65,11 +65,11 @@ (dolist (key *checking-or-caching-list*) (destructuring-bind (cached-emf-p return-value-p metatypes applyp) key (multiple-value-bind (args generator) - (if cached-emf-p - (if return-value-p - (values (list metatypes) 'emit-constant-value) - (values (list metatypes applyp) 'emit-caching)) - (if return-value-p - (values (list metatypes) 'emit-in-checking-p) - (values (list metatypes applyp) 'emit-checking))) + (if cached-emf-p + (if return-value-p + (values (list metatypes) 'emit-constant-value) + (values (list metatypes applyp) 'emit-caching)) + (if return-value-p + (values (list metatypes) 'emit-in-checking-p) + (values (list metatypes applyp) 'emit-checking))) (apply #'get-dfun-constructor generator args)))) diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index f1ab48b..cd8e592 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -45,8 +45,8 @@ (if (typep x 'generic-function) (setf (slot-value x 'documentation) new-value) (let ((name (%fun-name x))) - (when (and name (typep name '(or symbol cons))) - (setf (info :function :documentation name) new-value)))) + (when (and name (typep name '(or symbol cons))) + (setf (info :function :documentation name) new-value)))) new-value) (defmethod (setf documentation) @@ -54,8 +54,8 @@ (if (typep x 'generic-function) (setf (slot-value x 'documentation) new-value) (let ((name (%fun-name x))) - (when (and name (typep name '(or symbol cons))) - (setf (info :function :documentation name) new-value)))) + (when (and name (typep name '(or symbol cons))) + (setf (info :function :documentation name) new-value)))) new-value) (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) @@ -66,8 +66,8 @@ (setf (random-documentation x 'compiler-macro) new-value)) (defmethod (setf documentation) (new-value - (x symbol) - (doc-type (eql 'function))) + (x symbol) + (doc-type (eql 'function))) (setf (info :function :documentation x) new-value)) (defmethod (setf documentation) @@ -140,70 +140,70 @@ (defmethod documentation ((x symbol) (doc-type (eql 'type))) (or (values (info :type :documentation x)) (let ((class (find-class x nil))) - (when class - (slot-value class 'documentation))))) + (when class + (slot-value class 'documentation))))) (defmethod documentation ((x symbol) (doc-type (eql 'structure))) (cond ((eq (info :type :kind x) :instance) - (values (info :type :documentation x))) - ((info :typed-structure :info x) - (values (info :typed-structure :documentation x))) - (t - (error "~S is not the name of a structure type." x)))) + (values (info :type :documentation x))) + ((info :typed-structure :info x) + (values (info :typed-structure :documentation x))) + (t + (error "~S is not the name of a structure type." x)))) (defmethod (setf documentation) (new-value - (x structure-class) - (doc-type (eql 't))) + (x structure-class) + (doc-type (eql 't))) (setf (info :type :documentation (class-name x)) new-value)) (defmethod (setf documentation) (new-value - (x structure-class) - (doc-type (eql 'type))) + (x structure-class) + (doc-type (eql 'type))) (setf (info :type :documentation (class-name x)) new-value)) (defmethod (setf documentation) (new-value - (x standard-class) - (doc-type (eql 't))) + (x standard-class) + (doc-type (eql 't))) (setf (slot-value x 'documentation) new-value)) (defmethod (setf documentation) (new-value - (x standard-class) - (doc-type (eql 'type))) + (x standard-class) + (doc-type (eql 'type))) (setf (slot-value x 'documentation) new-value)) (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) (if (or (structure-type-p x) (condition-type-p x)) (setf (info :type :documentation x) new-value) (let ((class (find-class x nil))) - (if class - (setf (slot-value class 'documentation) new-value) - (setf (info :type :documentation x) new-value))))) + (if class + (setf (slot-value class 'documentation) new-value) + (setf (info :type :documentation x) new-value))))) (defmethod (setf documentation) (new-value - (x symbol) - (doc-type (eql 'structure))) + (x symbol) + (doc-type (eql 'structure))) (cond ((eq (info :type :kind x) :instance) - (setf (info :type :documentation x) new-value)) - ((info :typed-structure :info x) - (setf (info :typed-structure :documentation x) new-value)) - (t - (error "~S is not the name of a structure type." x)))) - + (setf (info :type :documentation x) new-value)) + ((info :typed-structure :info x) + (setf (info :typed-structure :documentation x) new-value)) + (t + (error "~S is not the name of a structure type." x)))) + ;;; variables (defmethod documentation ((x symbol) (doc-type (eql 'variable))) (values (info :variable :documentation x))) (defmethod (setf documentation) (new-value - (x symbol) - (doc-type (eql 'variable))) + (x symbol) + (doc-type (eql 'variable))) (setf (info :variable :documentation x) new-value)) ;;; default if DOC-TYPE doesn't match one of the specified types (defmethod documentation (object doc-type) (warn "unsupported DOCUMENTATION: type ~S for object ~S" - doc-type - (type-of object)) + doc-type + (type-of object)) nil) ;;; default if DOC-TYPE doesn't match one of the specified types @@ -212,8 +212,8 @@ ;; doc types an implementation is permitted to discard docs at any time ;; for any reason, this feels to me more like a warning. -- WHN 19991214 (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S" - doc-type - (type-of object)) + doc-type + (type-of object)) new-value) ;;; extra-standard methods, for getting at slot documentation diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index 046f3cf..d762907 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -42,7 +42,7 @@ ;;; #-SB-FLUID (FIND-PACKAGE NAME) ;;; #+SB-FLUID `(FIND-PACKAGE ,NAME)) ;;; and use that to replace all three variables.) -(defvar *pcl-package* (find-package "SB-PCL")) +(defvar *pcl-package* (find-package "SB-PCL")) ;;; This excludes structure types created with the :TYPE option to ;;; DEFSTRUCT. It also doesn't try to deal with types created by @@ -55,10 +55,10 @@ (and (symbolp type) (not (condition-type-p type)) (let ((classoid (find-classoid type nil))) - (and classoid - (typep (layout-info - (classoid-layout classoid)) - 'defstruct-description))))) + (and classoid + (typep (layout-info + (classoid-layout classoid)) + 'defstruct-description))))) ;;; Symbol contruction utilities (defun format-symbol (package format-string &rest format-arguments) @@ -76,49 +76,49 @@ (condition-classoid-p (find-classoid type nil)))) (declaim (special *the-class-t* - *the-class-vector* *the-class-symbol* - *the-class-string* *the-class-sequence* - *the-class-rational* *the-class-ratio* - *the-class-number* *the-class-null* *the-class-list* - *the-class-integer* *the-class-float* *the-class-cons* - *the-class-complex* *the-class-character* - *the-class-bit-vector* *the-class-array* - *the-class-stream* *the-class-file-stream* - *the-class-string-stream* + *the-class-vector* *the-class-symbol* + *the-class-string* *the-class-sequence* + *the-class-rational* *the-class-ratio* + *the-class-number* *the-class-null* *the-class-list* + *the-class-integer* *the-class-float* *the-class-cons* + *the-class-complex* *the-class-character* + *the-class-bit-vector* *the-class-array* + *the-class-stream* *the-class-file-stream* + *the-class-string-stream* - *the-class-slot-object* - *the-class-structure-object* - *the-class-std-object* - *the-class-standard-object* - *the-class-funcallable-standard-object* - *the-class-class* - *the-class-generic-function* - *the-class-built-in-class* - *the-class-slot-class* - *the-class-condition-class* - *the-class-structure-class* - *the-class-std-class* - *the-class-standard-class* - *the-class-funcallable-standard-class* - *the-class-method* - *the-class-standard-method* - *the-class-standard-reader-method* - *the-class-standard-writer-method* - *the-class-standard-boundp-method* - *the-class-standard-generic-function* - *the-class-standard-effective-slot-definition* + *the-class-slot-object* + *the-class-structure-object* + *the-class-std-object* + *the-class-standard-object* + *the-class-funcallable-standard-object* + *the-class-class* + *the-class-generic-function* + *the-class-built-in-class* + *the-class-slot-class* + *the-class-condition-class* + *the-class-structure-class* + *the-class-std-class* + *the-class-standard-class* + *the-class-funcallable-standard-class* + *the-class-method* + *the-class-standard-method* + *the-class-standard-reader-method* + *the-class-standard-writer-method* + *the-class-standard-boundp-method* + *the-class-standard-generic-function* + *the-class-standard-effective-slot-definition* - *the-eslotd-standard-class-slots* - *the-eslotd-funcallable-standard-class-slots*)) + *the-eslotd-standard-class-slots* + *the-eslotd-funcallable-standard-class-slots*)) (declaim (special *the-wrapper-of-t* - *the-wrapper-of-vector* *the-wrapper-of-symbol* - *the-wrapper-of-string* *the-wrapper-of-sequence* - *the-wrapper-of-rational* *the-wrapper-of-ratio* - *the-wrapper-of-number* *the-wrapper-of-null* - *the-wrapper-of-list* *the-wrapper-of-integer* - *the-wrapper-of-float* *the-wrapper-of-cons* - *the-wrapper-of-complex* *the-wrapper-of-character* - *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) + *the-wrapper-of-vector* *the-wrapper-of-symbol* + *the-wrapper-of-string* *the-wrapper-of-sequence* + *the-wrapper-of-rational* *the-wrapper-of-ratio* + *the-wrapper-of-number* *the-wrapper-of-null* + *the-wrapper-of-list* *the-wrapper-of-integer* + *the-wrapper-of-float* *the-wrapper-of-cons* + *the-wrapper-of-complex* *the-wrapper-of-character* + *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) (/show "finished with early-low.lisp") diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index fadcb93..be5e677 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -53,9 +53,9 @@ (defclass traced-method (method) ((method :initarg :method) (function :initarg :function - :reader method-function) + :reader method-function) (generic-function :initform nil - :accessor method-generic-function))) + :accessor method-generic-function))) (defmethod method-lambda-list ((m traced-method)) (with-slots (method) m (method-lambda-list method))) @@ -75,11 +75,11 @@ (multiple-value-bind (gf omethod name) (parse-method-or-spec spec) (let* ((tfunction (trace-method-internal (method-function omethod) - name - options)) - (tmethod (make-instance 'traced-method - :method omethod - :function tfunction))) + name + options)) + (tmethod (make-instance 'traced-method + :method omethod + :function tfunction))) (remove-method gf omethod) (add-method gf tmethod) (pushnew tmethod *traced-methods*) @@ -87,19 +87,19 @@ (defun untrace-method (&optional spec) (flet ((untrace-1 (m) - (let ((gf (method-generic-function m))) - (when gf - (remove-method gf m) - (add-method gf (slot-value m 'method)) - (setq *traced-methods* (remove m *traced-methods*)))))) + (let ((gf (method-generic-function m))) + (when gf + (remove-method gf m) + (add-method gf (slot-value m 'method)) + (setq *traced-methods* (remove m *traced-methods*)))))) (if (not (null spec)) - (multiple-value-bind (gf method) - (parse-method-or-spec spec) - (declare (ignore gf)) - (if (memq method *traced-methods*) - (untrace-1 method) - (error "~S is not a traced method?" method))) - (dolist (m *traced-methods*) (untrace-1 m))))) + (multiple-value-bind (gf method) + (parse-method-or-spec spec) + (declare (ignore gf)) + (if (memq method *traced-methods*) + (untrace-1 method) + (error "~S is not a traced method?" method))) + (dolist (m *traced-methods*) (untrace-1 m))))) (defun trace-method-internal (ofunction name options) (eval `(untrace ,name)) @@ -128,7 +128,7 @@ ;; Link bootstrap-time how-to-dump-it information into the shiny new ;; CLOS system. (defmethod make-load-form ((obj sb-sys:structure!object) - &optional (env nil env-p)) + &optional (env nil env-p)) (if env-p (sb-sys:structure!object-make-load-form obj env) (sb-sys:structure!object-make-load-form obj))) @@ -136,26 +136,26 @@ (defmethod make-load-form ((object wrapper) &optional env) (declare (ignore env)) (let ((pname (classoid-proper-name - (layout-classoid object)))) + (layout-classoid object)))) (unless pname (error "can't dump wrapper for anonymous class:~% ~S" - (layout-classoid object))) + (layout-classoid object))) `(classoid-layout (find-classoid ',pname)))) (defmethod make-load-form ((object structure-object) &optional env) (declare (ignore env)) (error "~@" - object 'make-load-form)) + object 'make-load-form)) (defmethod make-load-form ((object standard-object) &optional env) (declare (ignore env)) (error "~@" - object 'make-load-form)) + object 'make-load-form)) (defmethod make-load-form ((object condition) &optional env) (declare (ignore env)) (error "~@" - object 'make-load-form)) + object 'make-load-form)) (defun make-load-form-saving-slots (object &key slot-names environment) (declare (ignore environment)) @@ -168,14 +168,14 @@ (eq :instance (slot-definition-allocation slot)))) (if (slot-boundp-using-class class object slot) (let ((value (slot-value-using-class class object slot))) - (if (typep object 'structure-object) - ;; low-level but less noisy initializer form - (let* ((dd (get-structure-dd (class-name class))) - (dsd (find slot-name (dd-slots dd) - :key #'dsd-name))) - (inits `(,(slot-setter-lambda-form dd dsd) - ',value ,object))) - (inits `(setf (slot-value ,object ',slot-name) ',value)))) + (if (typep object 'structure-object) + ;; low-level but less noisy initializer form + (let* ((dd (get-structure-dd (class-name class))) + (dsd (find slot-name (dd-slots dd) + :key #'dsd-name))) + (inits `(,(slot-setter-lambda-form dd dsd) + ',value ,object))) + (inits `(setf (slot-value ,object ',slot-name) ',value)))) (inits `(slot-makunbound ,object ',slot-name)))))) (values `(allocate-instance (find-class ',(class-name class))) `(progn ,@(inits)))))) diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index e4c6697..0017ce0 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -40,24 +40,24 @@ ;;; to GET-FUN: ;;; COMPUTE-TEST converts the lambda into a key to be used for lookup, ;;; COMPUTE-CODE is used by GET-NEW-FUN-GENERATOR-INTERNAL to -;;; generate the actual lambda to be compiled, and +;;; generate the actual lambda to be compiled, and ;;; COMPUTE-CONSTANTS is used to generate the argument list that is -;;; to be passed to the compiled function. +;;; to be passed to the compiled function. ;;; (defun get-fun (lambda &optional - (test-converter #'default-test-converter) - (code-converter #'default-code-converter) - (constant-converter #'default-constant-converter)) + (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) (function-apply (get-fun-generator lambda test-converter code-converter) - (compute-constants lambda constant-converter))) + (compute-constants lambda constant-converter))) (defun get-fun1 (lambda &optional - (test-converter #'default-test-converter) - (code-converter #'default-code-converter) - (constant-converter #'default-constant-converter)) + (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) (values (the function - (get-fun-generator lambda test-converter code-converter)) - (compute-constants lambda constant-converter))) + (get-fun-generator lambda test-converter code-converter)) + (compute-constants lambda constant-converter))) (defun default-constantp (form) (and (constantp form) @@ -86,10 +86,10 @@ (defun store-fgen (fgen) (let ((old (lookup-fgen (fgen-test fgen)))) (if old - (setf (svref old 2) (fgen-generator fgen) - (svref old 4) (or (svref old 4) - (fgen-system fgen))) - (setq *fgens* (nconc *fgens* (list fgen)))))) + (setf (svref old 2) (fgen-generator fgen) + (svref old 4) (or (svref old 4) + (fgen-system fgen))) + (setq *fgens* (nconc *fgens* (list fgen)))))) (defun lookup-fgen (test) (find test (the list *fgens*) :key #'fgen-test :test #'equal)) @@ -97,30 +97,30 @@ (defun make-fgen (test gensyms generator generator-lambda system) (let ((new (make-array 6))) (setf (svref new 0) test - (svref new 1) gensyms - (svref new 2) generator - (svref new 3) generator-lambda - (svref new 4) system) + (svref new 1) gensyms + (svref new 2) generator + (svref new 3) generator-lambda + (svref new 4) system) new)) -(defun fgen-test (fgen) (svref fgen 0)) -(defun fgen-gensyms (fgen) (svref fgen 1)) -(defun fgen-generator (fgen) (svref fgen 2)) +(defun fgen-test (fgen) (svref fgen 0)) +(defun fgen-gensyms (fgen) (svref fgen 1)) +(defun fgen-generator (fgen) (svref fgen 2)) (defun fgen-generator-lambda (fgen) (svref fgen 3)) -(defun fgen-system (fgen) (svref fgen 4)) +(defun fgen-system (fgen) (svref fgen 4)) (defun get-fun-generator (lambda test-converter code-converter) (let* ((test (compute-test lambda test-converter)) - (fgen (lookup-fgen test))) + (fgen (lookup-fgen test))) (if fgen - (fgen-generator fgen) - (get-new-fun-generator lambda test code-converter)))) + (fgen-generator fgen) + (get-new-fun-generator lambda test code-converter)))) (defun get-new-fun-generator (lambda test code-converter) (multiple-value-bind (gensyms generator-lambda) (get-new-fun-generator-internal lambda code-converter) (let* ((generator (compile nil generator-lambda)) - (fgen (make-fgen test gensyms generator generator-lambda nil))) + (fgen (make-fgen test gensyms generator generator-lambda nil))) (store-fgen fgen) generator))) @@ -132,28 +132,28 @@ (defun compute-test (lambda test-converter) (let ((*walk-form-expand-macros-p* t)) (walk-form lambda - nil - (lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((converted (funcall test-converter f))) - (values converted (neq converted f)))))))) + nil + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((converted (funcall test-converter f))) + (values converted (neq converted f)))))))) (defun compute-code (lambda code-converter) (let ((*walk-form-expand-macros-p* t) - (gensyms ())) + (gensyms ())) (values (walk-form lambda - nil - (lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (multiple-value-bind (converted gens) - (funcall code-converter f) - (when gens (setq gensyms (append gensyms gens))) - (values converted (neq converted f)))))) - gensyms))) + nil + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (multiple-value-bind (converted gens) + (funcall code-converter f) + (when gens (setq gensyms (append gensyms gens))) + (values converted (neq converted f)))))) + gensyms))) (defun compute-constants (lambda constant-converter) (let ((*walk-form-expand-macros-p* t) ; doesn't matter here. @@ -161,15 +161,15 @@ (walk-form lambda nil (lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((consts (funcall constant-converter f))) - (if consts - (progn - (setq collect (append collect consts)) - (values f t)) - f))))) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((consts (funcall constant-converter f))) + (if consts + (progn + (setq collect (append collect consts)) + (values f t)) + f))))) collect)) (defmacro precompile-function-generators (&optional system) diff --git a/src/pcl/fsc.lisp b/src/pcl/fsc.lisp index 3fb228f..cb3a834 100644 --- a/src/pcl/fsc.lisp +++ b/src/pcl/fsc.lisp @@ -43,23 +43,23 @@ 'allocate-funcallable-instance) (defmethod validate-superclass ((fsc funcallable-standard-class) - (new-super std-class)) + (new-super std-class)) (let ((new-super-meta-class (class-of new-super))) (or (eq new-super-meta-class *the-class-std-class*) - (eq (class-of fsc) new-super-meta-class)))) + (eq (class-of fsc) new-super-meta-class)))) (defmethod allocate-instance - ((class funcallable-standard-class) &rest initargs) + ((class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-funcallable-instance (class-wrapper class))) (defmethod make-reader-method-function ((class funcallable-standard-class) - slot-name) + slot-name) (make-std-reader-method-function (class-name class) slot-name)) (defmethod make-writer-method-function ((class funcallable-standard-class) - slot-name) + slot-name) (make-std-writer-method-function (class-name class) slot-name)) ;;;; See the comment about reader-function--std and writer-function--sdt. @@ -68,17 +68,17 @@ ; `(function ; (lambda (instance) ; (slot-value-using-class (wrapper-class (get-wrapper instance)) -; instance -; slot-name)))) +; instance +; slot-name)))) ; ;(define-function-template writer-function--fsc () '(slot-name) ; `(function ; (lambda (nv instance) ; (setf -; (slot-value-using-class (wrapper-class (get-wrapper instance)) -; instance -; slot-name) -; nv)))) +; (slot-value-using-class (wrapper-class (get-wrapper instance)) +; instance +; slot-name) +; nv)))) ; ;(eval-when (:load-toplevel) ; (pre-make-templated-function-constructor reader-function--fsc) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 910e21b..e92cc55 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -171,16 +171,16 @@ (defgeneric (setf class-slots) (new-value slot-class)) (defgeneric (setf generic-function-method-class) (new-value - standard-generic-function)) + standard-generic-function)) (defgeneric (setf generic-function-method-combination) (new-value standard-generic-function)) (defgeneric (setf generic-function-declarations) (new-value - standard-generic-function)) + standard-generic-function)) (defgeneric (setf generic-function-methods) (new-value - standard-generic-function)) + standard-generic-function)) (defgeneric (setf generic-function-name) (new-value standard-generic-function)) @@ -194,7 +194,7 @@ (defgeneric (setf object-plist) (new-value plist-mixin)) (defgeneric (setf slot-definition-allocation) (new-value - standard-slot-definition)) + standard-slot-definition)) (defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition)) @@ -222,7 +222,7 @@ (defgeneric (setf slot-definition-name) (new-value slot-definition)) (defgeneric (setf slot-definition-reader-function) (new-value - effective-slot-definition)) + effective-slot-definition)) (defgeneric (setf slot-definition-readers) (new-value slot-definition)) @@ -410,8 +410,8 @@ ;;; COMPUTE-EFFECTIVE-METHOD returns one value as do Allegro and ;;; Lispworks. (defgeneric compute-effective-method (generic-function - combin - applicable-methods)) + combin + applicable-methods)) (defgeneric compute-effective-slot-definition (class name dslotds)) @@ -438,50 +438,50 @@ ;;;; 4 arguments (defgeneric make-method-lambda (proto-generic-function - proto-method - lambda-expression - environment)) + proto-method + lambda-expression + environment)) (defgeneric (setf slot-value-using-class) (new-value class object slotd)) ;;;; 5 arguments (defgeneric make-method-initargs-form (proto-generic-function - proto-method - lambda-expression - lambda-list - environment)) + proto-method + lambda-expression + lambda-list + environment)) ;;;; optional arguments (defgeneric get-method (generic-function - qualifiers - specializers - &optional errorp)) + qualifiers + specializers + &optional errorp)) (defgeneric find-method (generic-function - qualifiers - specializers - &optional errorp)) + qualifiers + specializers + &optional errorp)) (defgeneric slot-missing (class - instance - slot-name - operation - &optional new-value)) + instance + slot-name + operation + &optional new-value)) ;;;; &KEY arguments (defgeneric allocate-instance (class &rest initargs)) (defgeneric ensure-class-using-class (class - name - &rest args - &key &allow-other-keys)) + name + &rest args + &key &allow-other-keys)) (defgeneric ensure-generic-function-using-class (generic-function - fun-name - &key &allow-other-keys)) + fun-name + &key &allow-other-keys)) (defgeneric initialize-instance (gf &key &allow-other-keys)) @@ -500,19 +500,19 @@ (defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys)) (defgeneric shared-initialize (generic-function - slot-names - &key &allow-other-keys)) + slot-names + &key &allow-other-keys)) (defgeneric update-dependent (metaobject dependent &rest initargs)) (defgeneric update-instance-for-different-class (previous - current - &rest initargs)) + current + &rest initargs)) (defgeneric update-instance-for-redefined-class (instance - added-slots - discarded-slots - property-list - &rest initargs)) + added-slots + discarded-slots + property-list + &rest initargs)) (defgeneric writer-method-class (class direct-slot &rest initargs)) diff --git a/src/pcl/gray-streams-class.lisp b/src/pcl/gray-streams-class.lisp index a999b41..4721893 100644 --- a/src/pcl/gray-streams-class.lisp +++ b/src/pcl/gray-streams-class.lisp @@ -46,9 +46,9 @@ #| (defclass character-output-stream (fundamental-character-output-stream) ((lisp-stream :initarg :lisp-stream - :accessor character-output-stream-lisp-stream))) + :accessor character-output-stream-lisp-stream))) (defclass character-input-stream (fundamental-character-input-stream) ((lisp-stream :initarg :lisp-stream - :accessor character-input-stream-lisp-stream))) + :accessor character-input-stream-lisp-stream))) |# diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp index a293e9d..873bf38 100644 --- a/src/pcl/gray-streams.lisp +++ b/src/pcl/gray-streams.lisp @@ -96,7 +96,7 @@ (defgeneric input-stream-p (stream) #+sb-doc (:documentation "Can STREAM perform input operations?")) - + (defmethod input-stream-p ((stream ansi-stream)) (ansi-stream-input-stream-p stream)) @@ -108,7 +108,7 @@ (defmethod input-stream-p ((stream stream)) (bug-or-error stream 'input-stream-p)) - + (defmethod input-stream-p ((non-stream t)) (error 'type-error :datum non-stream :expected-type 'stream))) @@ -118,7 +118,7 @@ (defgeneric interactive-stream-p (stream) #+sb-doc (:documentation "Is STREAM an interactive stream?")) - + (defmethod interactive-stream-p ((stream ansi-stream)) (funcall (ansi-stream-misc stream) stream :interactive-p)) @@ -127,7 +127,7 @@ (defmethod interactive-stream-p ((stream stream)) (bug-or-error stream 'interactive-stream-p)) - + (defmethod interactive-stream-p ((non-stream t)) (error 'type-error :datum non-stream :expected-type 'stream))) @@ -143,7 +143,7 @@ (defmethod output-stream-p ((stream fundamental-stream)) nil) - + (defmethod output-stream-p ((stream fundamental-output-stream)) t) @@ -224,22 +224,22 @@ (defmethod stream-read-line ((stream fundamental-character-input-stream)) (let ((res (make-string 80)) - (len 80) - (index 0)) + (len 80) + (index 0)) (loop (let ((ch (stream-read-char stream))) (cond ((eq ch :eof) - (return (values (shrink-vector res index) t))) - (t - (when (char= ch #\newline) - (return (values (shrink-vector res index) nil))) - (when (= index len) - (setq len (* len 2)) - (let ((new (make-string len))) - (replace new res) - (setq res new))) - (setf (schar res index) ch) - (incf index))))))) + (return (values (shrink-vector res index) t))) + (t + (when (char= ch #\newline) + (return (values (shrink-vector res index) nil))) + (when (= index len) + (setq len (* len 2)) + (let ((new (make-string len))) + (replace new res) + (setq res new))) + (setf (schar res index) ch) + (incf index))))))) (defgeneric stream-clear-input (stream) #+sb-doc @@ -266,11 +266,11 @@ ;;; not updated, and the index of the next element is returned. (defun basic-io-type-stream-read-sequence (stream seq start end read-fun) (declare (type sequence seq) - (type stream stream) - (type index start) - (type sequence-end end) + (type stream stream) + (type index start) + (type sequence-end end) (type function read-fun) - (values index)) + (values index)) (let ((end (or end (length seq)))) (declare (type index end)) (etypecase seq @@ -372,13 +372,13 @@ STREAM-WRITE-CHAR.")) (defmethod stream-write-string ((stream fundamental-character-output-stream) - string &optional (start 0) end) + string &optional (start 0) end) (declare (string string) - (fixnum start)) + (fixnum start)) (let ((end (or end (length string)))) (declare (fixnum end)) (do ((pos start (1+ pos))) - ((>= pos end)) + ((>= pos end)) (declare (type index pos)) (stream-write-char stream (aref string pos)))) string) @@ -456,12 +456,12 @@ #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL.")) (defmethod stream-advance-to-column ((stream fundamental-character-output-stream) - column) + column) (let ((current-column (stream-line-column stream))) (when current-column (let ((fill (- column current-column))) - (dotimes (i fill) - (stream-write-char stream #\Space))) + (dotimes (i fill) + (stream-write-char stream #\Space))) T))) (defgeneric stream-write-sequence (stream seq &optional start end) @@ -471,11 +471,11 @@ ;;; Write the elements of SEQ bounded by START and END to STREAM. (defun basic-io-type-stream-write-sequence (stream seq start end write-fun) (declare (type sequence seq) - (type stream stream) - (type index start) - (type sequence-end end) + (type stream stream) + (type index start) + (type sequence-end end) (type function write-fun) - (values sequence)) + (values sequence)) (let ((end (or end (length seq)))) (declare (type index start end)) (etypecase seq diff --git a/version.lisp-expr b/version.lisp-expr index fa9e958..672c878 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.2.48" +"0.9.2.49"