(in-package "SB-PCL")
\f
-(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
;;;
(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
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
t)))
#'(lambda (&rest args) (funcall mf args nil))))
+
+(defun error-need-at-least-n-args (function n)
+ (error "~@<The function ~2I~_~S ~I~_requires at least ~D argument~:P.~:>"
+ function
+ n))
+
(defun types-from-arguments (generic-function arguments
&optional type-modifier)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
(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))))
(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)
(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*)
#'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*)
;;; 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))
(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))
(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)))
(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
;;; argument <gf1>, and returns a result <df1>, that result must not be
;;; passed to apply or funcall directly. Rather, <df1> must be stored as
;;; the funcallable instance function of the same generic function <gf1>
-;;; (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
;;; #'(lambda (arg)
;;; (cond (<some condition>
;;; <store some info in the generic function>
-;;; (set-funcallable-instance-function
+;;; (set-funcallable-instance-fun
;;; gf
;;; (compute-discriminating-function gf))
;;; (funcall gf arg))
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
;;; #'(lambda (arg)
;;; (cond (<some condition>
-;;; (set-funcallable-instance-function
+;;; (set-funcallable-instance-fun
;;; gf
;;; #'(lambda (a) ..))
;;; (funcall gf arg))
(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))
projects / sbcl.git / blobdiff