X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=9ba3364f4ac51f11b8771246283f8976c115c963;hb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;hp=4fe14b3fcd2dfe65e3795d1ee83ef51ed6e90f58;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 4fe14b3..9ba3364 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -23,22 +23,6 @@ (in-package "SB-PCL") -(defmethod shared-initialize :after ((slotd standard-slot-definition) - slot-names &key) - (declare (ignore slot-names)) - (with-slots (allocation class) - slotd - (setq allocation (if (eq allocation :class) class allocation)))) - -(defmethod shared-initialize :after ((slotd structure-slot-definition) - slot-names - &key (allocation :instance)) - (declare (ignore slot-names)) - (unless (eq allocation :instance) - (error "Structure slots must have :INSTANCE allocation."))) - -(defmethod inform-type-system-about-class ((class structure-class) (name t)) - nil) ;;; methods ;;; @@ -291,7 +275,7 @@ (cond ((or (null (fboundp generic-function-name)) (not (generic-function-p (setq generic-function - (symbol-function generic-function-name))))) + (fdefinition generic-function-name))))) (error "~S does not name a generic function." generic-function-name)) ((null (setq method (get-method generic-function @@ -312,8 +296,7 @@ lambda-list &rest other-initargs) (unless (and (fboundp generic-function-name) - (typep (symbol-function generic-function-name) - 'generic-function)) + (typep (fdefinition generic-function-name) 'generic-function)) (sb-kernel::style-warn "implicitly creating new generic function ~S" generic-function-name)) ;; XXX What about changing the class of the generic function if @@ -604,6 +587,12 @@ t))) #'(lambda (&rest args) (funcall mf args nil)))) + +(defun error-need-at-least-n-args (function n) + (error "~@" + function + n)) + (defun types-from-arguments (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) @@ -613,9 +602,8 @@ (dotimes-fixnum (i nreq) i (unless arguments - (error "The function ~S requires at least ~D arguments" - (generic-function-name generic-function) - nreq)) + (error-need-at-least-n-args (generic-function-name generic-function) + nreq)) (let ((arg (pop arguments))) (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) (values (nreverse types-rev) arg-info)))) @@ -623,7 +611,7 @@ (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) (dolist (class (if (listp classes) classes (list classes))) - (unless (eq 't (car mt-tail)) + (unless (eq t (car mt-tail)) (let ((c-w (class-wrapper class))) (unless c-w (return-from get-wrappers-from-classes nil)) (if (eql nkeys 1) @@ -911,7 +899,7 @@ (defmacro class-test (arg class) (cond ((eq class *the-class-t*) - 't) + t) ((eq class *the-class-slot-object*) `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class))) ((eq class *the-class-std-object*) @@ -1003,7 +991,7 @@ #'identity))) (defun class-from-type (type) - (if (or (atom type) (eq (car type) 't)) + (if (or (atom type) (eq (car type) t)) *the-class-t* (case (car type) (and (dolist (type (cdr type) *the-class-t*) @@ -1045,7 +1033,7 @@ ;;; We know that known-type implies neither new-type nor `(not ,new-type). (defun augment-type (new-type known-type) - (if (or (eq known-type 't) + (if (or (eq known-type t) (eq (car new-type) 'eql)) new-type (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and)) @@ -1071,7 +1059,7 @@ (if p-tail (let* ((position (car p-tail)) (known-type (or (nth position types) t))) - (if (eq (nth position metatypes) 't) + (if (eq (nth position metatypes) t) (do-column (cdr p-tail) contenders (cons (cons position known-type) known-types)) @@ -1132,10 +1120,10 @@ (defvar *case-table-limit* 10) (defun compute-mcase-parameters (case-list) - (unless (eq 't (caar (last case-list))) + (unless (eq t (caar (last case-list))) (error "The key for the last case arg to mcase was not T")) (let* ((eq-p (dolist (case case-list t) - (unless (or (eq (car case) 't) + (unless (or (eq (car case) t) (symbolp (caar case))) (return nil)))) (len (1- (length case-list))) @@ -1151,7 +1139,7 @@ (list eq-p type))) (defmacro mlookup (key info default &optional eq-p type) - (unless (or (eq eq-p 't) (null eq-p)) + (unless (or (eq eq-p t) (null eq-p)) (error "Invalid eq-p argument")) (ecase type (:simple @@ -1333,7 +1321,7 @@ ;;; argument , and returns a result , that result must not be ;;; passed to apply or funcall directly. Rather, must be stored as ;;; the funcallable instance function of the same generic function -;;; (using set-funcallable-instance-function). Then the generic function +;;; (using set-funcallable-instance-fun). Then the generic function ;;; can be passed to funcall or apply. ;;; ;;; An important exception is that methods on this generic function are @@ -1375,7 +1363,7 @@ ;;; #'(lambda (arg) ;;; (cond ( ;;; -;;; (set-funcallable-instance-function +;;; (set-funcallable-instance-fun ;;; gf ;;; (compute-discriminating-function gf)) ;;; (funcall gf arg)) @@ -1387,7 +1375,7 @@ ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; #'(lambda (arg) ;;; (cond ( -;;; (set-funcallable-instance-function +;;; (set-funcallable-instance-fun ;;; gf ;;; #'(lambda (a) ..)) ;;; (funcall gf arg)) @@ -1508,11 +1496,11 @@ (state 'required) (arglist (method-lambda-list method))) (dolist (arg arglist) - (cond ((eq arg '&optional) (setq state 'optional)) - ((eq arg '&rest) (setq state 'rest)) - ((eq arg '&key) (setq state 'key)) - ((eq arg '&allow-other-keys) (setq allow-other-keys 't)) - ((memq arg lambda-list-keywords)) + (cond ((eq arg '&optional) (setq state 'optional)) + ((eq arg '&rest) (setq state 'rest)) + ((eq arg '&key) (setq state 'key)) + ((eq arg '&allow-other-keys) (setq allow-other-keys t)) + ((memq arg lambda-list-keywords)) (t (ecase state (required (push arg required))