((nil) (error "How odd: a primary method slipped through the net"))
(t (error "Unknown method role ~A" role)))))
+(defmethod sod-message-receiver-type ((message sod-message)
+ (class sod-class))
+ (c-type (* (class class
+ (and (sod-message-readonly-p message) :const)))))
+
(export 'simple-message)
(defclass simple-message (basic-message)
()
(when (keyword-message-p message)
(setf method-args (fix-up-keyword-method-args method method-args)))
(c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (sod-method-class method))))
+ ("me" (lisp (sod-message-receiver-type
+ message (sod-method-class method))))
. method-args))))
(defmethod sod-method-description ((method basic-direct-method))
(t
msgargs))))
(c-type (fun (lisp return-type)
- ("me" (* (class (sod-method-class method))))
+ ("me" (lisp (sod-message-receiver-type
+ message (sod-method-class method))))
. arguments))))
(define-on-demand-slot delegating-direct-method function-type (method)
(t
(push next-method-arg method-args)))
(c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (sod-method-class method))))
+ ("me" (lisp (sod-message-receiver-type
+ message (sod-method-class method))))
. method-args))))
;;;--------------------------------------------------------------------------
;;; Effective method classes.
-(defmethod method-keyword-argument-lists
- ((method effective-method) direct-methods state)
- (with-slots (message) method
- (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 (m)
- (cons (lambda (arg)
- (let ((class (sod-method-class m)))
- (info-with-location
- m "Type `~A' declared in ~A direct ~
- method of `~A' (defined here)"
- (argument-type arg)
- (sod-method-description m) class)
- (report-inheritance-path state class)))
- (c-function-keywords (sod-method-type m))))
- direct-methods)))))
+(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)
;; class construction.
(with-slots ((class %class) message keywords) method
(setf keywords
- (merge-keyword-lists
- (lambda ()
- (values class
- (format nil
- "methods for message `~A' ~
- applicable to class `~A'"
- message class)))
- (method-keyword-argument-lists method direct-methods
- (make-inheritance-path-reporter-state class))))))
+ (compute-effective-method-keyword-arguments message
+ class
+ direct-methods))))
(export '(basic-effective-method
effective-method-around-methods effective-method-before-methods
- effective-method-after-methods))
+ effective-method-after-methods effective-method-functions))
(defclass basic-effective-method (effective-method)
((around-methods :initarg :around-methods :initform nil
:type list :reader effective-method-around-methods)
((nil) raw-tail)
(:valist (reify-variable-argument-tail raw-tail)))))
(c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (method-entry-chain-tail entry))))
+ ("me" (lisp (sod-message-receiver-type
+ message (method-entry-chain-tail entry))))
. tail))))
(defgeneric effective-method-keyword-parser-function-name (method)
set "v->kw")))
(name (effective-method-keyword-parser-function-name method)))
+ ;; Deal with the special `kw.' keywords read via varargs. We're
+ ;; building the dispatch up backwards, so if we do these first, they
+ ;; get checked last, which priviliges the function-specific arguments
+ ;; over these special effects.
+ (codegen-push codegen)
+ (call "vv" "va_arg" "*ap" (c-type (* (struct "kwval" :const))))
+ (call "nn" "va_arg" "*ap" c-type-size-t)
+ (call :void name "kw" *null-pointer* "vv" "nn")
+ (setf va-act (namecheck "k" "kw.tab"
+ (codegen-pop-block codegen) va-act))
+
+ (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.valist"
+ (codegen-pop-block codegen) va-act))
+
+ ;; Deal with the special `kw.' keywords read from a table.
+ (codegen-push codegen)
+ (deliver-expr codegen "t"
+ (format nil "(~A)v->val"
+ (c-type (* (struct "kwtab" :const)))))
+ (call :void name "kw" *null-pointer* "t->v" "t->n")
+ (setf tab-act (namecheck "v->kw" "kw.tab"
+ (codegen-pop-block codegen) tab-act))
+
+ (codegen-push codegen)
+ (convert "aap" (c-type (* va-list)))
+ (call :void name "kw" "aap" *null-pointer* 0)
+ (setf tab-act (namecheck "v->kw" "kw.valist"
+ (codegen-pop-block codegen) tab-act))
+
;; Work through the keywords. We're going to be building up the
;; conditional dispatch from the end, so reverse the (nicely sorted)
;; list before processing it.
(setf tab-act (namecheck "v->kw" key-name
(codegen-pop-block codegen) tab-act))))
- ;; Deal with the special `kw.' keywords read via varargs.
- (codegen-push codegen)
- (call "vv" "va_arg" "*ap" (c-type (* (struct "kwval" :const))))
- (call "nn" "va_arg" "*ap" c-type-size-t)
- (call :void name "kw" *null-pointer* "vv" "nn")
- (setf va-act (namecheck "k" "kw.tab"
- (codegen-pop-block codegen) va-act))
-
- (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"
- (codegen-pop-block codegen) va-act))
-
;; Finish up the varargs loop.
(emit-banner codegen "Parse keywords from the variable-length tail.")
(codegen-push codegen)
(emit-inst codegen
(make-if-inst "ap" (make-block-inst nil (list loop)))))
- ;; Deal with the special `kw.' keywords read from a table.
- (codegen-push codegen)
- (deliver-expr codegen "t"
- (format nil "(~A)v->val"
- (c-type (* (struct "kwtab" :const)))))
- (call :void name "kw" *null-pointer* "t->v" "t->n")
- (setf tab-act (namecheck "v->kw" "kw.tab"
- (codegen-pop-block codegen) tab-act))
-
- (emit-banner codegen "Parse keywords from the argument table.")
- (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"
- (codegen-pop-block codegen) tab-act))
-
;; Finish off the table loop.
+ (emit-banner codegen "Parse keywords from the argument table.")
(codegen-push codegen)
(emit-inst codegen tab-act)
(emit-inst codegen (make-expr-inst "v++"))
;; Effective method function details.
(emf-name (effective-method-function-name method))
- (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
+ (ilayout-type (c-type (* (struct (ilayout-struct-tag class)
+ (and (sod-message-readonly-p
+ message)
+ :const)))))
(emf-type (c-type (fun (lisp return-type)
("sod__obj" (lisp ilayout-type))
. entry-args))))
(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))
+ (my-type (sod-message-receiver-type message tail))
(role (if parm-n :valist nil))
(name (method-entry-function-name method head role))
(type (c-type (fun (lisp return-type)
- ("me" (* (class tail)))
+ ("me" (lisp my-type))
. entry-args))))
(codegen-pop-function codegen name type
"~@(~@[~A ~]entry~) function ~:_~
(mapcar #'argument-name entry-args)))
(main (method-entry-function-name method head nil))
(main-type (c-type (fun (lisp return-type)
- ("me" (* (class tail)))
+ ("me" (lisp my-type))
. raw-entry-args))))
(codegen-push codegen)
(ensure-var codegen *sod-ap* c-type-va-list)
(*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)))
~mdw / sod / blobdiff