(export 'basic-message)
(defclass basic-message (sod-message)
- ((argument-tail :type list :reader sod-message-argument-tail)
- (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
+ ((argument-tail :type list :reader sod-message-argument-tail))
(:documentation
"Base class for built-in message classes.
(argument-type arg))))
(c-function-arguments (sod-message-type message)))))
-(define-on-demand-slot basic-message no-varargs-tail (message)
- (reify-variable-argument-tail (sod-message-argument-tail message)))
-
(defmethod sod-message-method-class
((message basic-message) (class sod-class) pset)
(let ((role (get-property pset :role :keyword nil)))
("me" (* (class (sod-method-class method))))
. method-args))))
+(defmethod sod-method-description ((method basic-direct-method))
+ (with-slots (role) method
+ (if role (string-downcase role)
+ "primary")))
+
(defmethod sod-method-function-name ((method basic-direct-method))
(with-slots ((class %class) role message) method
(format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
;;;--------------------------------------------------------------------------
;;; Effective method classes.
+(defmethod sod-message-keyword-argument-lists
+ ((message sod-message) (class sod-class) direct-methods state)
+ (and (keyword-message-p message)
+ (cons (cons (lambda (arg)
+ (let ((class (sod-message-class message)))
+ (info-with-location
+ message "Type `~A' declared in message ~
+ definition in `~A' (here)"
+ (argument-type arg) class)
+ (report-inheritance-path state class)))
+ (c-function-keywords (sod-message-type message)))
+ (mapcar (lambda (method)
+ (cons (lambda (arg)
+ (let ((class (sod-method-class method)))
+ (info-with-location
+ method "Type `~A' declared in ~A direct ~
+ method of `~A' (defined here)"
+ (argument-type arg)
+ (sod-method-description method) class)
+ (report-inheritance-path state class)))
+ (c-function-keywords (sod-method-type method))))
+ direct-methods))))
+
+(defmethod sod-message-check-methods
+ ((message sod-message) (class sod-class) direct-methods)
+ (compute-effective-method-keyword-arguments message class direct-methods))
+
(defmethod shared-initialize :after
((method effective-method) slot-names &key direct-methods)
(declare (ignore slot-names))
- ;; Set the keyword argument list.
- (with-slots (message keywords) method
- (setf keywords (and (keyword-message-p message)
- (merge-keyword-lists
- (mapcar (lambda (m)
- (let ((type (sod-method-type m)))
- (cons (c-function-keywords type)
- (format nil "method for ~A on ~A"
- message
- (sod-method-class m)))))
- direct-methods))))))
+ ;; Set the keyword argument list. Blame the class as a whole for mismatch
+ ;; errors, because they're fundamentally a non-local problem about the
+ ;; class construction.
+ (with-slots ((class %class) message keywords) method
+ (setf keywords
+ (compute-effective-method-keyword-arguments message
+ class
+ direct-methods))))
(export '(basic-effective-method
effective-method-around-methods effective-method-before-methods
using a slot reader method."))
(define-on-demand-slot basic-effective-method basic-argument-names (method)
- (let ((message (effective-method-message method)))
- (mapcar #'argument-name
- (sod-message-no-varargs-tail message))))
+ (let* ((message (effective-method-message method))
+ (raw-tail (sod-message-argument-tail message)))
+ (mapcar #'argument-name (reify-variable-argument-tail raw-tail))))
(defmethod effective-method-function-name ((method effective-method))
(let* ((class (effective-method-class method))
(codegen-push codegen)
(call "aap" "va_arg" "*ap" (c-type (* va-list)))
(call :void name "kw" "aap" *null-pointer* 0)
- (setf va-act (namecheck "k" "kw.va_list"
+ (setf va-act (namecheck "k" "kw.valist"
(codegen-pop-block codegen) va-act))
;; Finish up the varargs loop.
(codegen-push codegen)
(convert "aap" (c-type (* va-list)))
(call :void name "kw" "aap" *null-pointer* 0)
- (setf tab-act (namecheck "v->kw" "kw.va_list"
+ (setf tab-act (namecheck "v->kw" "kw.valist"
(codegen-pop-block codegen) tab-act))
;; Finish off the table loop.
(codegen-push codegen)
(ensure-var codegen "sod__obj" ilayout-type
(make-convert-to-ilayout-inst class
- head "me"))))
+ head "me"))
+ (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))
(finish-entry (tail)
(let* ((head (sod-class-chain-head tail))
(role (if parm-n :valist nil))
(*keyword-struct-disposition* :local))
(ensure-var codegen *sod-keywords* (c-type (struct tag)))
(make-keyword-parser-function codegen method tag set keywords)
+ (emit-insts codegen
+ (mapcar (lambda (keyword)
+ (make-set-inst
+ (format nil "~A.~A__suppliedp"
+ *sod-keywords*
+ (argument-name keyword))
+ 0))
+ keywords))
(parse-keywords (lambda ()
(call :void name kw-addr ap-addr
*null-pointer* 0)))
(call-next-method)))))))
-(defmethod compute-method-entry-functions
- ((method simple-effective-method))
- (if (effective-method-primary-methods method)
+(defmethod effective-method-live-p ((method simple-effective-method))
+ (effective-method-primary-methods method))
+
+(defmethod compute-method-entry-functions :around ((method effective-method))
+ (if (effective-method-live-p method)
(call-next-method)
nil))
~mdw / sod / blobdiff