|#
(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
;;; 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
;;; 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)
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
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
(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)))))
(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)
(defun check-gf-lambda-list (lambda-list)
(flet ((ensure (arg ok)
(unless ok
- (error 'generic-function-lambda-list-error
- :format-control
- "~@<invalid ~S ~_in the generic function lambda list ~S~:>"
- :format-arguments (list arg lambda-list)))))
+ (error 'generic-function-lambda-list-error
+ :format-control
+ "~@<invalid ~S ~_in the generic function lambda list ~S~:>"
+ :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
(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!
(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 <generic-function-name>)). Return
;;; 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)))))))
\f
(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
(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))
;;; 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
;; 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
- "~@<can't find type for presumed class ~S in ~S.~@:>"
- 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
+ "~@<can't find type for presumed class ~S in ~S.~@:>"
+ 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)
;; 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)
(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)
(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))
(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)))
(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
`(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))))
\f
(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)))))
\f
(defvar *method-function-plist* (make-hash-table :test 'eq))
(defvar *mf1* nil)
(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)
(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))
(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)
(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)))))))
\f
(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))
(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))
(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))
(!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
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)
(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 "~@<attempt to add the method~2I~_~S~I~_~
+ (error 'simple-program-error
+ :format-control "~@<attempt to add the method~2I~_~S~I~_~
to the generic function~2I~_~S;~I~_~
but ~?~:>"
- :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.
;;; 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)))))
(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)
(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)))))
\f
;; 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
;; 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)))
(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)))
;;; 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)
(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)))
(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
(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 ()
;; 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)
(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"))
\f
;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument
(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)))
(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)))))))
\f
(setq *boot-state* 'early)
\f
`(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))))
(in-package "SB-PCL")
\f
(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)))))
\f
;;;; BOOTSTRAP-META-BRAID
;;;;
(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
;; 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)))
(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))
;; 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))))
(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 ()
(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))))))
\f
(defmacro wrapper-of-macro (x)
`(layout-of ,x))
(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*)
\f
(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
;; 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)))
(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)
(!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 "~@<There is no applicable method for the generic function ~2I~_~S~
- ~I~_when called with arguments ~2I~_~S.~:>"
- 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 "~@<There is no next method for the generic function ~2I~_~S~
- ~I~_when called from method ~2I~_~S~I~_with arguments ~2I~_~S.~:>"
- 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
;;; applicable method. -- CSR, 2002-11-15
(defmethod no-primary-method (generic-function &rest args)
(error "~@<There is no primary method for the generic function ~2I~_~S~
- ~I~_when called with arguments ~2I~_~S.~:>"
- 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.~%~
;;; 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))
(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))
(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))
;;; ever return a larger cache.
(defun get-cache-vector (size)
(flush-cache-vector-internal (make-array size)))
-
+
\f
;;;; wrapper cache numbers
(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
(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))))
;; 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)
(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)
(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)))
(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))))))
\f
;;; the various implementations of computing a primary cache location from
;;; wrappers. Because some implementations of this must run fast there are
(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
;;; 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))))))
\f
-;;; 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 "~@<PCL cannot handle the specializer ~S ~
+ (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 "~@<PCL cannot handle the specializer ~S ~
(meta-specializer ~S).~@:>"
- 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 <anything> ===> <anything>
- ;; 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))))
\f
;;;; 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
(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)
`(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)))
\f
;;; Here is where we actually fill, recache and expand caches.
(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)
(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))
(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)
(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 <field> <cache-vector>)
;;;
(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 <cache>)
(defun expand-cache (cache wrappers value)
(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)))))
\f
;;; This is the heart of the cache filling mechanism. It implements
;;; the decisions about where entries are placed.
;;; Find a line in the cache at which a new entry can be inserted.
;;;
;;; <line>
-;;; <empty?> is <line> in fact empty?
+;;; <empty?> is <line> 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 <s>. <p> 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 <s>. <p> 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)
(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
;; 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*)
(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)))
(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))
(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))
(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)
(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))))
(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
(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))
(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))))))
\f
;;; 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 "~@<invalid keyword argument~P: ~
+ (when (and (invalid) (not allow-other-keys))
+ (error 'simple-program-error
+ :format-control "~@<invalid keyword argument~P: ~
~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
- :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 "~@<keyword argument not a symbol: ~S.~@:>"
- :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 "~@<keyword argument not a symbol: ~S.~@:>"
+ :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)))))
\f
;;;; the STANDARD method combination type. This is coded by hand
(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 "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
- 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 "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
- format-control
- format-arguments)))
+ format-control
+ format-arguments)))
(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)
(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 () "<illegal syntax>")))
- `(defmethod ,name "<illegal syntax>"))))
+ `(defmethod ,name ,@(subseq stuff 0 arg-pos)
+ ,(handler-case
+ (nth-value 2 (sb-pcl::parse-specialized-lambda-list
+ (elt stuff arg-pos)))
+ (error () "<illegal syntax>")))
+ `(defmethod ,name "<illegal syntax>"))))
(defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil)
(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)))
(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)
(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 ())
;; 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)))))
(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))))
(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
(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
;; 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))))))
\f
;;;; 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)
(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)))
(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.
(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))
(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))))))))
\f
;;; **************************************************
(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))
;;; 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
(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
;;; 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
;;; 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
;; 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)
(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)))))))
;;; 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)))))
\f
;;; *******************************
(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
;; 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))))
;; 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*))
(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)
(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 "~@<The value of the :metaclass option (~S) ~
(let (initargs arg-names)
(doplist (key val) (cdr option)
(when (member key arg-names)
- (error 'simple-program-error
+ (error 'simple-program-error
:format-control "~@<Duplicate initialization argument ~
name ~S in :DEFAULT-INITARGS of ~
- DEFCLASS ~S.~:>"
+ 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))
(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*))
(: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)))
(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))))))
((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
(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))
(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)))
;;(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 "~@<The defclass option ~S is not supported by ~
- the bootstrap object system.~:@>"
- 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 "~@<The defclass option ~S is not supported by ~
+ the bootstrap object system.~:@>"
+ initarg)))
+ (setq default-initargs
+ (nconc default-initargs (reverse (pop others)))))))
(reverse default-initargs)))
(defun !bootstrap-slot-index (class-name slot-name)
;;; 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))
(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)
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))
(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))))
\f
;;;; standard method combination
;;; 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."))
(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)
(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))))
\f
;;;; 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)
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)
(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:
(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
(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)
(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.
;;; 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 "~@<The value of the :ARGUMENTS option of ~
+ :format-control "~@<The value of the :ARGUMENTS option of ~
DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~
only appear first in the lambda list.~:>"
- :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
;; 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
;;; 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)))))
;;; 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."))
\f
;;; comments from CMU CL version of PCL:
;;; This is like fdefinition on the Lispm. If Common Lisp had
;;; 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
(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
(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)))
;;; 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
;;; 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))))))))
\f
(defvar *built-in-class-symbols* ())
(defvar *built-in-wrapper-symbols* ())
(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)))
\f
(pushnew '%class *var-declarations*)
(pushnew '%variable-rebinding *var-declarations*)
\f
(defun make-class-predicate-name (name)
(list 'class-predicate name))
-
+
(defun plist-value (object name)
(getf (object-plist object) name))
(if new-value
(setf (getf (object-plist object) name) new-value)
(progn
- (remf (object-plist object) name)
- nil)))
+ (remf (object-plist object) name)
+ nil)))
\f
;;;; built-in classes
(/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*")
\f
;;;; the classes that define the kernel of the metabraid
(: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))
;;; 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
(let ((name (class-name class)))
(unless (and name (eq (find-class name nil) class))
(error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
- class))
+ class))
`(find-class ',name)))
;;; The class PCL-CLASS is an implementation-specific common
(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))))
\f
;;;; slot definitions
: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
: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
(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) ())
(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)
: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
:initarg :documentation)))
(defclass standard-method-combination (definition-source-mixin
- method-combination)
+ method-combination)
((type
:reader method-combination-type
:initarg :type)
(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))
(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 "~&~@<Its proper name is ~S.~@:>" name)
- (ft "~&~@<Its name is ~S, but this is not a proper name.~@:>"
- name))
- (ft "~&~@<It has no name (the name is NIL).~@:>")))
+ (if name
+ (if (eq class (find-class name nil))
+ (ft "~&~@<Its proper name is ~S.~@:>" name)
+ (ft "~&~@<Its name is ~S, but this is not a proper name.~@:>"
+ name))
+ (ft "~&~@<It has no name (the name is NIL).~@:>")))
(ft "~&~@<The direct superclasses are: ~:S, and the direct ~
- subclasses are: ~:S.~I~_The class is ~:[not ~;~]finalized~
+ subclasses are: ~:S.~I~_The class is ~:[not ~;~]finalized~
~:[. ~;; its class precedence list is:~2I~_~:*~S.~]~I~_~
- There ~[are~;is~:;are~] ~:*~S method~:P specialized for ~
+ There ~[are~;is~:;are~] ~:*~S method~:P specialized for ~
this 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))))))
+ (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
- "~@[~&~@<It has nicknames ~2I~{~:_~S~^ ~}~:>~]"
- (package-nicknames package))
+ "~@[~&~@<It has nicknames ~2I~{~:_~S~^ ~}~:>~]"
+ (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
- "~@[~&~@<It uses packages named ~2I~{~:_~S~^ ~}~:>~]"
- (humanize (package-use-list package)))
+ "~@[~&~@<It uses packages named ~2I~{~:_~S~^ ~}~:>~]"
+ (humanize (package-use-list package)))
(format stream
- "~@[~&~@<It is used by packages named ~2I~{~:_~S~^ ~}~:>~]"
- (humanize (package-used-by-list package))))
+ "~@[~&~@<It is used by packages named ~2I~{~:_~S~^ ~}~:>~]"
+ (humanize (package-used-by-list package))))
(terpri stream))
;;; (<generator> . (<subentry> ...)).
;;; Each subentry is of the form
;;; (<args> <constructor> <system>).
-(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
(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 ~S of class ~S is unbound in object ~S~@:>"
- slot-name class object))
- value)
- (error "~@<cannot get standard value of slot ~S of class ~S ~
+ (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 ~S of class ~S is unbound in object ~S~@:>"
+ slot-name class object))
+ value)
+ (error "~@<cannot get standard value of slot ~S of class ~S ~
in object ~S~@:>"
- 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*))
(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*))
;;; 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
;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)
\f
(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)))
(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)))
(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)
(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))
(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)
(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)
(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)))
||#
;; 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)
(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))
(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)
(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)
(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)
(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)))
\f
(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
(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)
(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.)))))
(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
;; 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)))))))
\f
;;; Given a generic function and a set of arguments to that generic
;;; function, return a mess of values.
;;;
;;; <function> The compiled effective method function for this set of
-;;; arguments.
+;;; arguments.
;;;
;;; <applicable> Sorted list of applicable methods.
;;;
;;; <wrappers> 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.
;;;
;;; <invalidp> True if any of the specialized arguments had an invalid
-;;; wrapper, false otherwise.
+;;; wrapper, false otherwise.
;;;
;;; <type> 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.
;;;
;;; <index> If <type> 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)
(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
(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 "~@<vicious metacircle: The computation of an ~
- effective method of ~s for arguments of types ~s uses ~
- the effective method being computed.~@:>"
- 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*.
;;; 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)
(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)
(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)
(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))
(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)
(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)))))
\f
(defvar *effective-method-cache* (make-hash-table :test 'eq))
(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))
(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)))))
\f
(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)))
#|
(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))))
(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)
(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))
|#
(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))
(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
(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))))
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
(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))
(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)))
(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
;;; 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))
(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)
(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"))
(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))
(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))))
(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)
(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)))
(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)
(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))))
+
\f
;;; 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))
\f
;;; 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
;; 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
;;; #-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
(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)
(condition-classoid-p (find-classoid type nil))))
\f
(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*))
\f
(/show "finished with early-low.lisp")
(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)))
(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*)
(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))
;; 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)))
(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 "~@<don't know how to dump ~S (default ~S method called).~@>"
- object 'make-load-form))
+ object 'make-load-form))
(defmethod make-load-form ((object standard-object) &optional env)
(declare (ignore env))
(error "~@<don't know how to dump ~S (default ~S method called).~@>"
- object 'make-load-form))
+ object 'make-load-form))
(defmethod make-load-form ((object condition) &optional env)
(declare (ignore env))
(error "~@<don't know how to dump ~S (default ~S method called).~@>"
- object 'make-load-form))
+ object 'make-load-form))
(defun make-load-form-saving-slots (object &key slot-names environment)
(declare (ignore environment))
(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))))))
;;; 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)
(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))
(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))
\f
(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)))
(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.
(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))
\f
(defmacro precompile-function-generators (&optional system)
'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.
; `(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)
(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))
(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))
(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))
;;; 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))
;;;; 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))
\f
;;;; 5 arguments
(defgeneric make-method-initargs-form (proto-generic-function
- proto-method
- lambda-expression
- lambda-list
- environment))
+ proto-method
+ lambda-expression
+ lambda-list
+ environment))
\f
;;;; 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))
\f
;;;; &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))
(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))
#|
(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)))
|#
(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))
(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)))
\f
(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))
(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)))
\f
(defmethod output-stream-p ((stream fundamental-stream))
nil)
-
+
(defmethod output-stream-p ((stream fundamental-output-stream))
t)
(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
;;; 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
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)
#\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)
;;; 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
;;; 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"
projects / sbcl.git / commitdiff