;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
(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.
inheriting its default behaviour.
The function type protocol is implemented on `basic-message' using slot
- reader methods. The actual values are computed on demand in methods
- defined on `slot-unbound'."))
+ reader methods. The actual values are computed on demand."))
-(defmethod slot-unbound (class
- (message basic-message)
- (slot-name (eql 'argument-tail)))
- (declare (ignore class))
+(define-on-demand-slot basic-message argument-tail (message)
(let ((seq 0))
- (setf (slot-value message 'argument-tail)
- (mapcar (lambda (arg)
- (if (or (eq arg :ellipsis) (argument-name arg)) arg
- (make-argument (make-instance 'temporary-argument
- :tag (prog1 seq
- (incf seq)))
- (argument-type arg))))
- (c-function-arguments (sod-message-type message))))))
-
-(defmethod slot-unbound (class
- (message basic-message)
- (slot-name (eql 'no-varargs-tail)))
- (declare (ignore class))
- (setf (slot-value message 'no-varargs-tail)
- (mapcar (lambda (arg)
- (if (eq arg :ellipsis)
- (make-argument *sod-ap* (c-type va-list))
- arg))
- (sod-message-argument-tail message))))
+ (mapcar (lambda (arg)
+ (if (or (eq arg :ellipsis) (argument-name arg)) arg
+ (make-argument (make-instance 'temporary-argument
+ :tag (prog1 seq
+ (incf seq)))
+ (argument-type arg))))
+ (c-function-arguments (sod-message-type message)))))
(defmethod sod-message-method-class
((message basic-message) (class sod-class) pset)
((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)
()
;;;--------------------------------------------------------------------------
;;; Direct method classes.
-(export 'basic-direct-method)
+(export '(basic-direct-method sod-method-role))
(defclass basic-direct-method (sod-method)
((role :initarg :role :type symbol :reader sod-method-role)
(function-type :type c-function-type :reader sod-method-function-type))
categorization.
The function type protocol is implemented on `basic-direct-method' using
- slot reader methods. The actual values are computed on demand in methods
- defined on `slot-unbound'."))
+ slot reader methods."))
(defmethod shared-initialize :after
((method basic-direct-method) slot-names &key pset)
(declare (ignore slot-names))
(default-slot (method 'role) (get-property pset :role :keyword nil)))
-(defmethod slot-unbound
- (class (method basic-direct-method) (slot-name (eql 'function-type)))
- (declare (ignore class))
- (let ((type (sod-method-type method)))
- (setf (slot-value method 'function-type)
- (c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (sod-method-class method))))
- . (c-function-arguments type))))))
+(defun direct-method-suppliedp-struct-tag (direct-method)
+ (with-slots ((class %class) role message) direct-method
+ (format nil "~A__~@[~(~A~)_~]suppliedp_~A__~A"
+ class role
+ (sod-class-nickname (sod-message-class message))
+ (sod-message-name message))))
+
+(defun effective-method-keyword-struct-tag (effective-method)
+ (with-slots ((class %class) message) effective-method
+ (format nil "~A__keywords_~A__~A"
+ class
+ (sod-class-nickname (sod-message-class message))
+ (sod-message-name message))))
+
+(defun fix-up-keyword-method-args (method args)
+ "Adjust the ARGS to include METHOD's `suppliedp' and keyword arguments.
+
+ Return the adjusted list. The `suppliedp' argument, if any, is prepended
+ to the list; the keyword arguments are added to the end.
+
+ (The input ARGS list is not actually modified.)"
+ (let* ((type (sod-method-type method))
+ (keys (c-function-keywords type))
+ (tag (direct-method-suppliedp-struct-tag method)))
+ (append (and keys
+ (list (make-argument "suppliedp" (c-type (struct tag)))))
+ args
+ (mapcar (lambda (key)
+ (make-argument (argument-name key)
+ (argument-type key)))
+ keys))))
+
+(define-on-demand-slot basic-direct-method function-type (method)
+ (let* ((message (sod-method-message method))
+ (type (sod-method-type method))
+ (method-args (c-function-arguments type)))
+ (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" (lisp (sod-message-receiver-type
+ message (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 role message) method
+ (with-slots ((class %class) role message) method
(format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
(sod-class-nickname (sod-message-class message))
(sod-message-name message))))
(defmethod check-method-type ((method daemon-direct-method)
(message sod-message)
(type c-function-type))
- (with-slots ((msgtype type)) message
- (unless (c-type-equal-p (c-type-subtype type) (c-type void))
- (error "Method return type ~A must be `void'" (c-type-subtype type)))
- (unless (argument-lists-compatible-p (c-function-arguments msgtype)
- (c-function-arguments type))
- (error "Method arguments ~A don't match message ~A" type msgtype))))
+ (with-slots ((msgtype %type)) message
+ (check-method-return-type type c-type-void)
+ (check-method-argument-lists type msgtype)))
(export 'delegating-direct-method)
(defclass delegating-direct-method (basic-direct-method)
its `next_method' function if necessary.)
The function type protocol is implemented on `delegating-direct-method'
- using slot reader methods. The actual values are computed on demand in
- methods defined on `slot-unbound'."))
+ using slot reader methods.."))
-(defmethod slot-unbound (class
- (method delegating-direct-method)
- (slot-name (eql 'next-method-type)))
- (declare (ignore class))
+(define-on-demand-slot delegating-direct-method next-method-type (method)
(let* ((message (sod-method-message method))
- (type (sod-message-type message)))
- (setf (slot-value method 'next-method-type)
- (c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (sod-method-class method))))
- .
- (c-function-arguments type))))))
-
-(defmethod slot-unbound (class
- (method delegating-direct-method)
- (slot-name (eql 'function-type)))
- (declare (ignore class))
+ (return-type (c-type-subtype (sod-message-type message)))
+ (msgargs (sod-message-argument-tail message))
+ (arguments (cond ((varargs-message-p message)
+ (cons (make-argument *sod-master-ap*
+ c-type-va-list)
+ (butlast msgargs)))
+ ((keyword-message-p message)
+ (cons (make-argument *sod-keywords*
+ (c-type (* (void :const))))
+ msgargs))
+ (t
+ msgargs))))
+ (c-type (fun (lisp return-type)
+ ("me" (lisp (sod-message-receiver-type
+ message (sod-method-class method))))
+ . arguments))))
+
+(define-on-demand-slot delegating-direct-method function-type (method)
(let* ((message (sod-method-message method))
(type (sod-method-type method))
- (method-args (c-function-arguments type)))
- (setf (slot-value method 'function-type)
- (c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (sod-method-class method))))
- ("next_method" (* (lisp (commentify-function-type
- (sod-method-next-method-type
- method)))))
- .
- (if (varargs-message-p message)
- (cons (make-argument *sod-master-ap*
- (c-type va-list))
- method-args)
- method-args))))))
+ (method-args (c-function-arguments type))
+ (next-method-arg (make-argument
+ "next_method"
+ (make-pointer-type
+ (commentify-function-type
+ (sod-method-next-method-type method))))))
+ (cond ((varargs-message-p message)
+ (push (make-argument *sod-master-ap* c-type-va-list)
+ method-args)
+ (push next-method-arg method-args))
+ ((keyword-message-p message)
+ (push (make-argument *sod-keywords* (c-type (* (void :const))))
+ method-args)
+ (push next-method-arg method-args)
+ (setf method-args
+ (fix-up-keyword-method-args method method-args)))
+ (t
+ (push next-method-arg method-args)))
+ (c-type (fun (lisp (c-type-subtype type))
+ ("me" (lisp (sod-message-receiver-type
+ message (sod-method-class method))))
+ . method-args))))
;;;--------------------------------------------------------------------------
;;; Effective method classes.
-(export 'basic-effective-method)
+(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. 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
+ 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)
correctly.
The argument names protocol is implemented on `basic-effective-method'
- using a slot reader method. The actual values are computed on demand in
- methods defined on `slot-unbound'."))
-
-(defmethod slot-unbound (class
- (method basic-effective-method)
- (slot-name (eql 'basic-argument-names)))
- (declare (ignore class))
- (let ((message (effective-method-message method)))
- (setf (slot-value method 'basic-argument-names)
- (subst *sod-master-ap* *sod-ap*
- (mapcar #'argument-name
- (sod-message-no-varargs-tail message))))))
+ using a slot reader method."))
+
+(define-on-demand-slot basic-effective-method basic-argument-names (method)
+ (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))
(sod-class-nickname message-class)
(sod-message-name message))))
-(defmethod slot-unbound
- (class (method basic-effective-method) (slot-name (eql 'functions)))
- (declare (ignore class))
- (setf (slot-value method 'functions)
- (compute-method-entry-functions method)))
+(define-on-demand-slot basic-effective-method functions (method)
+ (compute-method-entry-functions method))
(export 'simple-effective-method)
(defclass simple-effective-method (basic-effective-method)
(declare (ignore slot-names))
(with-slots (message target) codegen
(setf target
- (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
+ (if (eq (c-type-subtype (sod-message-type message)) c-type-void)
:void
:return))))
returned by the outermost `around' method -- or, if there are none,
delivered by the BODY -- is finally delivered to the TARGET."
- (with-slots (message class before-methods after-methods around-methods)
+ (with-slots (message (class %class)
+ before-methods after-methods around-methods)
method
(let* ((message-type (sod-message-type message))
(return-type (c-type-subtype message-type))
effective method out into its own function.")
(defmethod method-entry-function-name
- ((method effective-method) (chain-head sod-class))
+ ((method effective-method) (chain-head sod-class) role)
(let* ((class (effective-method-class method))
(message (effective-method-message method))
(message-class (sod-message-class message)))
(if (or (not (slot-boundp method 'functions))
(slot-value method 'functions))
- (format nil "~A__mentry_~A__~A__chain_~A"
- class
+ (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
+ class role
(sod-class-nickname message-class)
(sod-message-name message)
(sod-class-nickname chain-head))
- 0)))
+ *null-pointer*)))
+
+(defmethod method-entry-slot-name ((entry method-entry))
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
+ (name (sod-message-name message))
+ (role (method-entry-role entry)))
+ (method-entry-slot-name-by-role entry role name)))
(defmethod method-entry-function-type ((entry method-entry))
(let* ((method (method-entry-effective-method entry))
(message (effective-method-message method))
- (type (sod-message-type message)))
+ (type (sod-message-type message))
+ (keywordsp (keyword-message-p message))
+ (raw-tail (append (sod-message-argument-tail message)
+ (and keywordsp (list :ellipsis))))
+ (tail (ecase (method-entry-role entry)
+ ((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))))
- . (sod-message-argument-tail message)))))
+ ("me" (lisp (sod-message-receiver-type
+ message (method-entry-chain-tail entry))))
+ . tail))))
+
+(defgeneric effective-method-keyword-parser-function-name (method)
+ (:documentation
+ "Return the name of the keyword-parsing function for an effective METHOD.
+
+ See `make-keyword-parser-function' for details of what this function
+ actually does."))
+
+(defmethod effective-method-keyword-parser-function-name
+ ((method basic-effective-method))
+ (with-slots ((class %class) message) method
+ (format nil "~A__kwparse_~A__~A"
+ class
+ (sod-class-nickname (sod-message-class message))
+ (sod-message-name message))))
+
+(defun make-keyword-parser-function (codegen method tag set keywords)
+ "Construct and return a keyword-argument parsing function.
+
+ The function is contributed to the CODEGEN, with the name constructed from
+ the effective METHOD. It will populate an argument structure with the
+ given TAG. In case of error, it will mention the name SET in its report.
+ The KEYWORDS are a list of `argument' objects naming the keywords to be
+ accepted.
+
+ The generated function has the signature
+
+ void NAME(struct TAG *kw, va_list *ap, struct kwval *v, size_t n)
+
+ It assumes that AP includes the first keyword name. (This makes it
+ different from the keyword-parsing functions generated by the
+ `KWSET_PARSEFN' macro, but this interface is slightly more convenient and
+ we don't need to cope with functions which accept no required
+ arguments.)"
+
+ ;; Let's start, then.
+ (codegen-push codegen)
+
+ ;; Set up the local variables we'll need.
+ (macrolet ((var (name type)
+ `(ensure-var codegen ,name (c-type ,type))))
+ (var "k" const-string)
+ (var "aap" (* va-list))
+ (var "t" (* (struct "kwtab" :const)))
+ (var "vv" (* (struct "kwval" :const)))
+ (var "nn" size-t))
+
+ (flet ((call (target func &rest args)
+ ;; Call FUNC with ARGS; return result in TARGET.
+
+ (apply #'deliver-call codegen target func args))
+
+ (convert (target type)
+ ;; Fetch the object of TYPE pointed to by `v->val', and store it
+ ;; in TARGET.
+
+ (deliver-expr codegen target
+ (format nil "*(~A)v->val"
+ (make-pointer-type (qualify-c-type
+ type (list :const))))))
+
+ (namecheck (var name conseq alt)
+ ;; Return an instruction: if VAR matches the string NAME then do
+ ;; CONSEQ; otherwise do ALT.
+
+ (make-if-inst (make-call-inst "!strcmp"
+ var (prin1-to-string name))
+ conseq alt)))
+
+ ;; Prepare the main parsing loops. We're going to construct them both at
+ ;; the same time. They're not quite similar enough for it to be
+ ;; worthwhile abstracting this further, but carving up the keywords is
+ ;; too tedious to write out more than once.
+ (let ((va-act (make-expr-inst (make-call-inst "kw_unknown" set "k")))
+ (tab-act (make-expr-inst (make-call-inst "kw_unknown"
+ 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))
-(defmethod make-method-entry ((method basic-effective-method)
- (chain-head sod-class) (chain-tail sod-class))
- (make-instance 'method-entry
- :method method
- :chain-head chain-head
- :chain-tail chain-tail))
+ (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.
+ (dolist (key (reverse keywords))
+ (let* ((key-name (argument-name key))
+ (key-type (argument-type key)))
+
+ ;; Handle the varargs case.
+ (codegen-push codegen)
+ (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
+ (call (format nil "kw->~A" key-name) "va_arg" "*ap" key-type)
+ (setf va-act (namecheck "k" key-name
+ (codegen-pop-block codegen) va-act))
+
+ ;; Handle the table case.
+ (codegen-push codegen)
+ (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
+ (convert (format nil "kw->~A" key-name) key-type)
+ (setf tab-act (namecheck "v->kw" key-name
+ (codegen-pop-block codegen) tab-act))))
+
+ ;; Finish up the varargs loop.
+ (emit-banner codegen "Parse keywords from the variable-length tail.")
+ (codegen-push codegen)
+ (call "k" "va_arg" "*ap" c-type-const-string)
+ (emit-inst codegen (make-if-inst "!k" (make-break-inst)))
+ (emit-inst codegen va-act)
+ (let ((loop (make-for-inst nil nil nil (codegen-pop-block codegen))))
+ (emit-inst codegen
+ (make-if-inst "ap" (make-block-inst nil (list loop)))))
+
+ ;; 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++"))
+ (emit-inst codegen (make-expr-inst "n--"))
+ (emit-inst codegen (make-while-inst "n" (codegen-pop-block codegen)))
+
+ ;; Wrap the whole lot up with a nice bow.
+ (let ((message (effective-method-message method)))
+ (codegen-pop-function codegen name
+ (c-type (fun void
+ ("kw" (* (struct tag)))
+ ("ap" (* va-list))
+ ("v" (* (struct "kwval" :const)))
+ ("n" size-t)))
+ "Keyword parsing for `~A.~A' on class `~A'."
+ (sod-class-nickname
+ (sod-message-class message))
+ (sod-message-name message)
+ (effective-method-class method))))))
+
+(defmethod make-method-entries ((method basic-effective-method)
+ (chain-head sod-class)
+ (chain-tail sod-class))
+ (let ((entries nil)
+ (message (effective-method-message method)))
+ (flet ((make (role)
+ (push (make-instance 'method-entry
+ :method method :role role
+ :chain-head chain-head
+ :chain-tail chain-tail)
+ entries)))
+ (when (or (varargs-message-p message)
+ (keyword-message-p message))
+ (make :valist))
+ (make nil)
+ entries)))
(defmethod compute-method-entry-functions ((method basic-effective-method))
:class class
:method method))
- ;; Effective method function details.
- (emf-name (effective-method-function-name method))
- (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
- (emf-arg-tail (mapcar (lambda (arg)
- (if (eq (argument-name arg) *sod-ap*)
- (make-argument *sod-master-ap*
- (c-type va-list))
- arg))
- (sod-message-no-varargs-tail message)))
- (emf-type (c-type (fun (lisp return-type)
- ("sod__obj" (lisp ilayout-type))
- . (sod-message-no-varargs-tail message))))
-
;; Method entry details.
(chain-tails (remove-if-not (lambda (super)
(sod-subclass-p super message-class))
(mapcar #'car
(sod-class-chains class))))
(n-entries (length chain-tails))
- (entry-args (sod-message-argument-tail message))
- (parm-n (do ((prev "me" (car args))
- (args entry-args (cdr args)))
- ((endp args) nil)
- (when (eq (car args) :ellipsis)
- (return prev))))
- (entry-target (codegen-target codegen)))
+ (raw-entry-args (append (sod-message-argument-tail message)
+ (and (keyword-message-p message)
+ (list :ellipsis))))
+ (entry-args (reify-variable-argument-tail raw-entry-args))
+ (parm-n (let ((tail (last (cons (make-argument "me" c-type-void)
+ raw-entry-args) 2)))
+ (and tail (eq (cadr tail) :ellipsis)
+ (argument-name (car tail)))))
+ (entry-target (codegen-target codegen))
+
+ ;; Effective method function details.
+ (emf-name (effective-method-function-name method))
+ (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))))
(flet ((setup-entry (tail)
(let ((head (sod-class-chain-head tail)))
(codegen-push codegen)
(ensure-var codegen "sod__obj" ilayout-type
(make-convert-to-ilayout-inst class
- head "me"))))
- (varargs-prologue ()
- (ensure-var codegen *sod-master-ap* (c-type va-list))
- (emit-inst codegen
- (make-va-start-inst *sod-master-ap* parm-n)))
- (varargs-epilogue ()
- (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
+ head "me"))
+ (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))
(finish-entry (tail)
(let* ((head (sod-class-chain-head tail))
- (name (method-entry-function-name method head))
+ (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))))
+ (codegen-pop-function codegen name type
+ "~@(~@[~A ~]entry~) function ~:_~
+ for method `~A.~A' ~:_~
+ via chain headed by `~A' ~:_~
+ defined on `~A'."
+ (if parm-n "Indirect argument-tail" nil)
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ head class)
+
+ ;; If this is a varargs or keyword method then we've made the
+ ;; `:valist' role. Also make the `nil' role.
+ (when parm-n
+ (let ((call (apply #'make-call-inst name "me"
+ (mapcar #'argument-name entry-args)))
+ (main (method-entry-function-name method head nil))
+ (main-type (c-type (fun (lisp return-type)
+ ("me" (lisp my-type))
+ . raw-entry-args))))
+ (codegen-push codegen)
+ (ensure-var codegen *sod-ap* c-type-va-list)
+ (convert-stmts codegen entry-target return-type
+ (lambda (target)
+ (deliver-call codegen :void "va_start"
+ *sod-ap* parm-n)
+ (deliver-expr codegen target call)
+ (deliver-call codegen :void "va_end"
+ *sod-ap*)))
+ (codegen-pop-function codegen main main-type
+ "Variable-length argument list ~:_~
+ entry function ~:_~
+ for method `~A.~A' ~:_~
+ via chain headed by `~A' ~:_~
+ defined on `~A'."
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ head class))))))
;; Generate the method body. We'll work out what to do with it later.
(codegen-push codegen)
(ensure-var codegen (inst-name var)
(inst-type var) (inst-init var))
(emit-decl codegen var)))
- (when parm-n (varargs-prologue))
(emit-insts codegen insts)
- (when parm-n (varargs-epilogue))
(deliver-expr codegen entry-target result)
(finish-entry tail)))
;; function and call it a lot.
(codegen-build-function codegen emf-name emf-type vars
(nconc insts (and result
- (list (make-return-inst result)))))
-
- (let ((call (make-call-inst emf-name
- (cons "sod__obj" (mapcar #'argument-name
- emf-arg-tail)))))
+ (list (make-return-inst result))))
+ "Effective method function ~:_for `~A.~A' ~:_~
+ defined on `~A'."
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ (effective-method-class method))
+
+ (let ((call (apply #'make-call-inst emf-name "sod__obj"
+ (mapcar #'argument-name entry-args))))
(dolist (tail chain-tails)
(setup-entry tail)
- (cond (parm-n
- (varargs-prologue)
- (convert-stmts codegen entry-target return-type
- (lambda (target)
- (deliver-expr codegen
- target call)
- (varargs-epilogue))))
- (t
- (deliver-expr codegen entry-target call)))
+ (deliver-expr codegen entry-target call)
(finish-entry tail)))))))
(codegen-functions codegen))))
-(defmethod compute-method-entry-functions
- ((method simple-effective-method))
- (if (effective-method-primary-methods method)
+(defmethod compute-effective-method-body :around
+ ((method basic-effective-method) codegen target)
+ (let* ((message (effective-method-message method))
+ (keywordsp (keyword-message-p message))
+ (keywords (effective-method-keywords method))
+ (ap-addr (format nil "&~A" *sod-tmp-ap*))
+ (set (format nil "\"~A:~A.~A\""
+ (sod-class-name (effective-method-class method))
+ (sod-class-nickname (sod-message-class message))
+ (sod-message-name message))))
+ (labels ((call (target func &rest args)
+ (apply #'deliver-call codegen target func args))
+ (parse-keywords (body)
+ (ensure-var codegen *sod-tmp-ap* c-type-va-list)
+ (call :void "va_copy" *sod-tmp-ap* *sod-ap*)
+ (funcall body)
+ (call :void "va_end" *sod-tmp-ap*)))
+ (cond ((not keywordsp)
+ (call-next-method))
+ ((null keywords)
+ (let ((*keyword-struct-disposition* :null))
+ (parse-keywords (lambda ()
+ (with-temporary-var
+ (codegen kw c-type-const-string)
+ (call kw "va_arg"
+ *sod-tmp-ap* c-type-const-string)
+ (call :void "kw_parseempty" set
+ kw ap-addr *null-pointer* 0))))
+ (call-next-method)))
+ (t
+ (let* ((name
+ (effective-method-keyword-parser-function-name method))
+ (tag (effective-method-keyword-struct-tag method))
+ (kw-addr (format nil "&~A" *sod-keywords*))
+ (*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 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))
(defmethod primary-method-class ((message standard-message))
'delegating-direct-method)
-(defmethod message-effective-method-class ((message standard-message))
+(defmethod sod-message-effective-method-class ((message standard-message))
'standard-effective-method)
(defmethod simple-method-body
(effective-method-primary-methods method)
nil))
-;;;--------------------------------------------------------------------------
-;;; Aggregate method combinations.
-
-(export 'aggregating-message)
-(defclass aggregating-message (simple-message)
- ((combination :initarg :combination :type keyword
- :reader message-combination)
- (kernel-function :type function :reader message-kernel-function))
- (:documentation
- "Message class for aggregating method combinations.
-
- An aggregating method combination invokes the primary methods in order,
- most-specific first, collecting their return values, and combining them
- together in some way to produce a result for the effective method as a
- whole.
-
- Mostly, this is done by initializing an accumulator to some appropriate
- value, updating it with the result of each primary method in turn, and
- finally returning some appropriate output function of it. The order is
- determined by the `:most-specific' property, which may have the value
- `:first' or `:last'.
-
- The `progn' method combination is implemented as a slightly weird special
- case of an aggregating method combination with a trivial state. More
- typical combinations are `:sum', `:product', `:min', `:max', `:and', and
- `:or'. Finally, there's a `custom' combination which uses user-supplied
- code fragments to stitch everything together."))
-
-(export 'aggregating-message-properties)
-(defgeneric aggregating-message-properties (message combination)
- (:documentation
- "Return a description of the properties needed by the method COMBINATION.
-
- The description should be a plist of alternating property name and type
- keywords. The named properties will be looked up in the pset supplied at
- initialization time, and supplied to `compute-aggregating-message-kernel'
- as keyword arguments. Defaults can be supplied in method BVLs.
-
- The default is not to capture any property values.
-
- The reason for this is as not to retain the pset beyond message object
- initialization.")
- (:method (message combination) nil))
-
-(export 'compute-aggregating-message-kernel)
-(defgeneric compute-aggregating-message-kernel
- (message combination codegen target methods arg-names &key)
- (:documentation
- "Determine how to aggregate the direct methods for an aggregating message.
-
- The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
- METHODS): it should emit, to CODEGEN, an appropriate effective-method
- kernel which invokes the listed direct METHODS, in the appropriate order,
- collects and aggregates their values, and delivers to TARGET the final
- result of the method kernel.
-
- The easy way to implement this method is to use the macro
- `define-aggregating-method-combination'."))
-
-(defmethod shared-initialize :before
- ((message aggregating-message) slot-names &key pset)
- (declare (ignore slot-names))
- (with-slots (combination kernel-function) message
- (let ((most-specific (get-property pset :most-specific :keyword :first))
- (comb (get-property pset :combination :keyword)))
-
- ;; Check that we've been given a method combination and make sure it
- ;; actually exists.
- (unless comb
- (error "The `combination' property is required."))
- (unless (some (lambda (method)
- (let* ((specs (method-specializers method))
- (message-spec (car specs))
- (combination-spec (cadr specs)))
- (and (typep message-spec 'class)
- (typep message message-spec)
- (typep combination-spec 'eql-specializer)
- (eq (eql-specializer-object combination-spec)
- comb))))
- (generic-function-methods
- #'compute-aggregating-message-kernel))
- (error "Unknown method combination `~(~A~)'." comb))
- (setf combination comb)
-
- ;; Make sure the ordering is actually valid.
- (unless (member most-specific '(:first :last))
- (error "The `most_specific' property must be `first' or `last'."))
-
- ;; Set up the function which will compute the kernel.
- (let ((magic (cons nil nil))
- (keys nil))
-
- ;; Collect the property values wanted by the method combination.
- (do ((want (aggregating-message-properties message comb)
- (cddr want)))
- ((endp want))
- (let* ((name (car want))
- (type (cadr want))
- (prop (get-property pset name type magic)))
- (unless (eq prop magic)
- (setf keys (list* name prop keys)))))
-
- ;; Set the kernel function for later.
- (setf kernel-function
- (lambda (codegen target arg-names methods)
- (apply #'compute-aggregating-message-kernel
- message comb
- codegen target
- (ecase most-specific
- (:first methods)
- (:last (setf methods (reverse methods))))
- arg-names
- keys)))))))
-
-(export 'check-aggregating-message-type)
-(defgeneric check-aggregating-message-type (message combination type)
- (:documentation
- "Check that TYPE is an acceptable function TYPE for the COMBINATION.
-
- For example, `progn' messages must return `void', while `and' and `or'
- messages must return `int'.")
- (:method (message combination type)
- t))
-
-(defmethod check-message-type ((message aggregating-message) type)
- (with-slots (combination) message
- (check-aggregating-message-type message combination type)))
-
-(flet ((check (comb want type)
- (unless (eq (c-type-subtype type) want)
- (error "Messages with `~A' combination must return `~A'."
- (string-downcase comb) want))))
- (defmethod check-aggregating-message-type
- ((message aggregating-message)
- (combination (eql :progn))
- (type c-function-type))
- (check combination c-type-void type)
- (call-next-method))
- (defmethod check-aggregating-message-type
- ((message aggregating-message)
- (combination (eql :and))
- (type c-function-type))
- (check combination c-type-int type)
- (call-next-method))
- (defmethod check-aggregating-message-type
- ((message aggregating-message)
- (combination (eql :or))
- (type c-function-type))
- (check combination c-type-int type)
- (call-next-method)))
-
-(export 'define-aggregating-method-combination)
-(defmacro define-aggregating-method-combination
- (comb
- (vars
- &key (codegen (gensym "CODEGEN-"))
- (methods (gensym "METHODS-")))
- &key properties
- ((:around around-func) '#'funcall)
- ((:first-method first-method-func) nil firstp)
- ((:methods methods-func) '#'funcall))
- "Utility macro for definining aggregating method combinations.
-
- The VARS are a list of variable names to be bound to temporary variable
- objects of the method's return type. Additional keyword arguments define
- variables names to be bound to other possibly interesting values:
-
- * CODEGEN is the `codegen' object passed at effective-method computation
- time; and
-
- * METHODS is the list of primary methods, in the order in which they
- should be invoked. Note that this list must be non-empty, since
- otherwise the method on `compute-effective-method-body' specialized to
- `simple-effective-method' will suppress the method entirely.
-
- The PROPERTIES, if specified, are a list of properties to be collected
- during message-object initialization; items in the list have the form
-
- (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
-
- similar to a `&key' BVL entry, except for the additional TYPE entry. In
- particular, a symbolic NAME may be written in place of a singleton list.
- The KEYWORD names the property as it should be looked up in the pset,
- while the NAME names a variable to which the property value or default is
- bound.
-
- All of these variables, and the VARS, are available in the functions
- described below.
-
- The AROUND, FIRST-METHOD, and METHODS are function designators (probably
- `lambda' forms) providing pieces of the aggregating behaviour.
-
- The AROUND function is called first, with a single argument BODY, though
- the variables above are also in scope. It is expected to emit code to
- CODEGEN which invokes the METHODS in the appropriate order, and arranges
- to store the aggregated return value in the first of the VARS.
-
- It may call BODY as a function in order to assist with this; let ARGS be
- the list of arguments supplied to it. The default behaviour is to call
- BODY with no arguments. The BODY function first calls FIRST-METHOD,
- passing it as arguments a function INVOKE and the ARGS which were passed
- to BODY, and then calls METHODS once for each remaining method, again
- passing an INVOKE function and the ARGS. If FIRST-METHOD is not
- specified, then the METHODS function is used for all of the methods. If
- METHODS is not specified, then the behaviour is simply to call INVOKE
- immediately. (See the definition of the `:progn' method combination.)
-
- Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
- the appropriate direct method and deliver its return value to TARGET,
- which defaults to `:void'."
-
- (with-gensyms (type msg combvar target arg-names args
- meth targ func call-methfunc
- aroundfunc fmethfunc methfunc)
- `(progn
-
- ;; If properties are listed, arrange for them to be collected.
- ,@(and properties
- `((defmethod aggregating-message-properties
- ((,msg aggregating-message) (,combvar (eql ',comb)))
- ',(mapcan (lambda (prop)
- (list (let* ((name (car prop))
- (names (if (listp name) name
- (list name))))
- (if (cddr names) (car names)
- (intern (car names) :keyword)))
- (cadr prop)))
- properties))))
-
- ;; Define the main kernel-compuation method.
- (defmethod compute-aggregating-message-kernel
- ((,msg aggregating-message) (,combvar (eql ',comb))
- ,codegen ,target ,methods ,arg-names
- &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
- properties))
- (declare (ignore ,combvar))
-
- ;; Declare the necessary variables and give names to the functions
- ;; supplied by the caller.
- (let* (,@(and vars
- `((,type (c-type-subtype (sod-message-type ,msg)))))
- ,@(mapcar (lambda (var)
- (list var `(temporary-var ,codegen ,type)))
- vars)
- (,aroundfunc ,around-func)
- (,methfunc ,methods-func)
- (,fmethfunc ,(if firstp first-method-func methfunc)))
-
- ;; Arrange to release the temporaries when we're finished with
- ;; them.
- (unwind-protect
- (progn
-
- ;; Wrap the AROUND function around most of the work.
- (funcall ,aroundfunc
- (lambda (&rest ,args)
- (flet ((,call-methfunc (,func ,meth)
- ;; Call FUNC, passing it an INVOKE
- ;; function which will generate a call
- ;; to METH.
- (apply ,func
- (lambda
- (&optional (,targ :void))
- (invoke-method ,codegen
- ,targ
- ,arg-names
- ,meth))
- ,args)))
-
- ;; The first method might need special
- ;; handling.
- (,call-methfunc ,fmethfunc (car ,methods))
-
- ;; Call the remaining methods in the right
- ;; order.
- (dolist (,meth (cdr ,methods))
- (,call-methfunc ,methfunc ,meth)))))
-
- ;; Outside the AROUND function now, deliver the final
- ;; result to the right place.
- (deliver-expr ,codegen ,target ,(car vars)))
-
- ;; Finally, release the temporary variables.
- ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
- vars))))
-
- ',comb)))
-
-(define-aggregating-method-combination :progn (nil))
-
-(define-aggregating-method-combination :sum ((acc val) :codegen codegen)
- :first-method (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-set-inst acc val)))
- :methods (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-update-inst acc #\+ val))))
-
-(define-aggregating-method-combination :product ((acc val) :codegen codegen)
- :first-method (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-set-inst acc val)))
- :methods (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-update-inst acc #\* val))))
-
-(define-aggregating-method-combination :min ((acc val) :codegen codegen)
- :first-method (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-set-inst acc val)))
- :methods (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
- (make-set-inst acc val) nil))))
-
-(define-aggregating-method-combination :max ((acc val) :codegen codegen)
- :first-method (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-set-inst acc val)))
- :methods (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
- (make-set-inst acc val) nil))))
-
-(define-aggregating-method-combination :and ((ret val) :codegen codegen)
- :around (lambda (body)
- (codegen-push codegen)
- (deliver-expr codegen ret 0)
- (funcall body)
- (deliver-expr codegen ret 1)
- (emit-inst codegen
- (make-do-while-inst (codegen-pop-block codegen) 0)))
- :methods (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-if-inst (format nil "!~A" val)
- (make-break-inst) nil))))
-
-(define-aggregating-method-combination :or ((ret val) :codegen codegen)
- :around (lambda (body)
- (codegen-push codegen)
- (deliver-expr codegen ret 1)
- (funcall body)
- (deliver-expr codegen ret 0)
- (emit-inst codegen
- (make-do-while-inst (codegen-pop-block codegen) 0)))
- :methods (lambda (invoke)
- (funcall invoke val)
- (emit-inst codegen (make-if-inst val (make-break-inst) nil))))
-
-(defmethod aggregating-message-properties
- ((message aggregating-message) (combination (eql :custom)))
- '(:retvar :id
- :valvar :id
- :decls :fragment
- :before :fragment
- :first :fragment
- :each :fragment
- :after :fragment))
-
-(defmethod compute-aggregating-message-kernel
- ((message aggregating-message) (combination (eql :custom))
- codegen target methods arg-names
- &key (retvar "sod_ret") (valvar "sod_val")
- decls before each (first each) after)
- (let* ((type (c-type-subtype (sod-message-type message)))
- (not-void-p (not (eq type c-type-void))))
- (when not-void-p
- (ensure-var codegen retvar type)
- (ensure-var codegen valvar type))
- (when decls
- (emit-decl codegen decls))
- (labels ((maybe-emit (fragment)
- (when fragment (emit-inst codegen fragment)))
- (invoke (method fragment)
- (invoke-method codegen (if not-void-p valvar :void)
- arg-names method)
- (maybe-emit fragment)))
- (maybe-emit before)
- (invoke (car methods) first)
- (dolist (method (cdr methods)) (invoke method each))
- (maybe-emit after)
- (deliver-expr codegen target retvar))))
-
-(export 'standard-effective-method)
-(defclass aggregating-effective-method (simple-effective-method) ()
- (:documentation "Effective method counterpart to `aggregating-message'."))
-
-(defmethod message-effective-method-class ((message aggregating-message))
- 'aggregating-effective-method)
-
-(defmethod simple-method-body
- ((method aggregating-effective-method) codegen target)
- (let ((argument-names (effective-method-basic-argument-names method))
- (primary-methods (effective-method-primary-methods method)))
- (funcall (message-kernel-function (effective-method-message method))
- codegen target argument-names primary-methods)))
-
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff