X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftype-class.lisp;h=e4a1b6b9cb6ff0a3098552239620847826abc6d7;hb=4fc9d21ae1d8a6a2f8ff70f589d5da103203de13;hp=360a4e8d29b16bb16f509e6ca7de80c67a0bc225;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index 360a4e8..e4a1b6b 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -23,6 +23,7 @@ (error "~S is not a defined type class." name))) (defun must-supply-this (&rest foo) + (/show0 "failing in MUST-SUPPLY-THIS") (error "missing type method for ~S" foo)) ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly contains @@ -119,9 +120,9 @@ :complex-= (type-class-complex-= x) :unparse (type-class-unparse x))) -;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have to -;;; be tweaked to match. -- WHN 19991021 -(defconstant type-class-function-slots +;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here +;;; will have to be tweaked to match. -- WHN 19991021 +(defparameter *type-class-function-slots* '((:simple-subtypep . type-class-simple-subtypep) (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1) (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2) @@ -134,7 +135,7 @@ (:unparse . type-class-unparse))) (defun class-function-slot-or-lose (name) - (or (cdr (assoc name type-class-function-slots)) + (or (cdr (assoc name *type-class-function-slots*)) (error "~S is not a defined type class method." name))) ;;; FIXME: This seems to be called at runtime by cold init code. ;;; Make sure that it's not being called at runtime anywhere but @@ -142,22 +143,24 @@ ) ; EVAL-WHEN -(defmacro define-type-method ((class method &rest more-methods) - lambda-list &body body) - #!+sb-doc - "DEFINE-TYPE-METHOD (Class-Name Method-Name+) Lambda-List Form*" +(defmacro !define-type-method ((class method &rest more-methods) + lambda-list &body forms-and-decls) (let ((name (symbolicate CLASS "-" method "-TYPE-METHOD"))) - `(progn - (defun ,name ,lambda-list ,@body) - (!cold-init-forms - ,@(mapcar #'(lambda (method) - `(setf (,(class-function-slot-or-lose method) - (type-class-or-lose ',class)) - #',name)) - (cons method more-methods))) - ',name))) - -(defmacro define-type-class (name &key inherits) + (multiple-value-bind (forms decls) (parse-body forms-and-decls) + `(progn + (defun ,name ,lambda-list + ,@decls + (block punt-type-method + ,@forms)) + (!cold-init-forms + ,@(mapcar #'(lambda (method) + `(setf (,(class-function-slot-or-lose method) + (type-class-or-lose ',class)) + #',name)) + (cons method more-methods))) + ',name)))) + +(defmacro !define-type-class (name &key inherits) `(!cold-init-forms ,(once-only ((n-class (if inherits `(copy-type-class-coldly (type-class-or-lose @@ -168,13 +171,14 @@ (setf (gethash ',name *type-classes*) ,n-class) ',name)))) -;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same -;;; class, invoke the simple method. Otherwise, invoke any complex method. If -;;; there isn't a distinct COMPLEX-ARG1 method, then swap the arguments when -;;; calling TYPE1's method. If no applicable method, return DEFAULT. -(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key - (default '(values nil t)) - (complex-arg1 :foo complex-arg1-p)) +;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the +;;; same class, invoke the simple method. Otherwise, invoke any +;;; complex method. If there isn't a distinct COMPLEX-ARG1 method, +;;; then swap the arguments when calling TYPE1's method. If no +;;; applicable method, return DEFAULT. +(defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key + (default '(values nil t)) + (complex-arg1 :foo complex-arg1-p)) (declare (type keyword simple complex-arg1 complex-arg2)) `(multiple-value-bind (result-a result-b valid-p) (%invoke-type-method ',(class-function-slot-or-lose simple) @@ -190,16 +194,17 @@ (values result-a result-b) ,default))) -;;; most of the implementation of INVOKE-TYPE-METHOD +;;; most of the implementation of !INVOKE-TYPE-METHOD ;;; -;;; KLUDGE: This function must be INLINE in order for cold init to work, -;;; because the first three arguments are TYPE-CLASS structure accessor -;;; functions whose calls have to be compiled inline in order to work in calls -;;; to this function early in cold init. So don't conditionalize this INLINE -;;; declaration with #!+SB-FLUID or anything, unless you also rearrange things -;;; to cause the full function definitions of the relevant structure accessors -;;; to be available sufficiently early in cold init. -- WHN 19991015 -#!-sb-fluid (declaim (inline %invoke-type-method)) +;;; KLUDGE: This function must be INLINE in order for cold init to +;;; work, because the first three arguments are TYPE-CLASS structure +;;; accessor functions whose calls have to be compiled inline in order +;;; to work in calls to this function early in cold init. So don't +;;; conditionalize this INLINE declaration with #!-SB-FLUID or +;;; anything, unless you also rearrange things to cause the full +;;; function definitions of the relevant structure accessors to be +;;; available sufficiently early in cold init. -- WHN 19991015 +(declaim (inline %invoke-type-method)) (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2) (declare (type symbol simple cslot1 cslot2)) (multiple-value-bind (result-a result-b) @@ -215,11 +220,11 @@ (if complex-arg1-p (funcall complex1 type1 type2) (funcall complex1 type2 type1)) - ;; No meaningful result was found: the caller should use the - ;; default value instead. + ;; No meaningful result was found: the caller should + ;; use the default value instead. (return-from %invoke-type-method (values nil nil nil)))))))) - ;; If we get to here (without breaking out by calling RETURN-FROM) then - ;; a meaningful result was found, and we return it. + ;; If we get to here (without breaking out by calling RETURN-FROM) + ;; then a meaningful result was found, and we return it. (values result-a result-b t))) (!defun-from-collected-cold-init-forms !type-class-cold-init)