* mdw/doc-reorg: (34 commits)
doc/refintro.tex, src/sod-module.5: Fix slightly garbled text.
doc/syntax.tex: Delete (wrong) duplicate rule for <argument-declarator>.
doc/syntax.tex: Consistently use baseline-level ellipses in syntax.
doc/concepts.tex: Fix a rather distant demonstrative.
test/: Add a simple rational-number class.
src/method-impl.lisp: Initialize `suppliedp' flags properly.
src/class-output.lisp: Fix missing parentheses around `me' in message macros.
doc/concepts.tex: Fix garbled fragment ordering rules.
doc/runtime.tex: Fix name of `SOD_XCHAIN' macro.
doc/structures.tex, lib/sod-structs.3: Fix in-chain ichain exemplar.
src/optparse.lisp: Indent a line correctly.
test/test.sod: Abbreviate the T1 class nicknames.
src/method-impl.lisp: Mark `sod__obj' as ignorable in effective methods.
src/method-aggregate.lisp: Allow useful behaviour if no primary methods.
doc/intro.tex: Begin a (rather extensive) comparison with C++.
doc/Makefile.am, doc/sod.tex: Actually include the stub intro.
doc/intro.tex: Fix erroneous `\manpage' to correct `\man'.
doc/concepts.tex: Include diagram of standard method combination.
doc/Makefile.am: Enable `\nonstopmode' in TeX processing.
doc/Makefile.am: Abstract out repeated TeX arguments into a variable.
...
* mdw/parser-fixes: (97 commits)
src/class-finalize.lisp: Improve reporting of CPL construction errors.
src/class-finalize-impl.lisp: Move error reporting to `merge-class-lists'.
src/class-finalize-impl.lisp (clos-cpl, dylan-cpl): Improve formatting.
src/class-finalize-impl.lisp (clos-tiebreaker): Refactor.
src/class-finalize.lisp (merge-class-lists): Zap pointless `:present' arg.
src/module-impl.lisp (c-fragment): Fix docstring formatting.
src/module-parse.lisp: Improve error recovery for core class items.
src/module-parse.lisp: Abstract out `parse-maybe-dotted-name'.
src/module-parse.lisp: Use `quote', not `list', to make constant lists.
src/module-parse.lisp: Use `dotted-name', not `dotted-identifier'.
src/module-parse.lisp: Catch errors during class-item construction.
src/module-parse.lisp: Factor out slot and maybe-initializer creation.
src/module-parse.lisp: Improve error recovery for `class' item framing.
src/class-utilities.lisp: Permit `temporary-name' objects as class names.
src/class-utilities.lisp: Improve reporting of multiple root classes.
src/module-parse.lisp: Improve error recovery for `initarg' class-items.
src/module-parse.lisp: Improve error recovery for `lisp' items.
src/module-parse.lisp: Improve error recovery for `load' and `import' items.
src/module-parse.lisp: Improve error recovery for `test' items.
src/module-parse.lisp: Improve error recovery for `code' items.
...
double-complex c-type
double-imaginary c-type
enum c-type
+ find-simple-c-type function
cl:float function class c-type
float-complex c-type
float-imaginary c-type
dylan-cpl function
flavors-cpl function
l*loops-cpl function
+ merge-class-lists function
python-cpl function
+ report-class-list-merge-error function
class-finalize-proto.lisp
check-sod-class generic
compute-chains generic
compute-cpl generic
+ finalization-error macro
+ finalization-failed function
finalize-sod-class generic
guess-metaclass generic
ichain-struct-tag function
ichain-union-tag function
ilayout-struct-tag function
+ inheritance-path-reporter-state class
islots-struct-tag function
+ make-inheritance-path-reporter-state function
message-macro-name function
+ report-inheritance-path function
+ select-minimal-class-property function
sod-subclass-p function
valid-name-p function
vtable-name function
lexer-proto.lisp
define-indicator function
cl:error function class parser
- lexer-error function
+ lexer-error function class
+ must parser
scan-comment function
- skip-until function parser
+ skip-until parser
sod-token-scanner class
- syntax-error function
+ syntax-error function class
method-aggregate.lisp
aggregating-effective-method class
simple-method-body generic
sod-message-argument-tail generic
sod-message-effective-method-class generic
+ sod-method-description generic
sod-method-function-name generic
sod-method-function-type generic
sod-method-next-method-type generic
sequencer-table generic
pset-parse.lisp
+ parse-property function
parse-property-set function
pset-proto.lisp
cl:t
sb-pcl::slot-object
cl:condition
+ sod-parser:condition-with-location
+ sod-parser:error-with-location [cl:error]
+ sod-parser:base-lexer-error
+ lexer-error [sod-parser:parser-error]
+ sod-parser:base-syntax-error
+ syntax-error [sod-parser:parser-error]
cl:serious-condition
cl:error
+ sod-parser:error-with-location [sod-parser:condition-with-location]
+ sod-parser:base-lexer-error
+ lexer-error [sod-parser:parser-error]
+ sod-parser:base-syntax-error
+ syntax-error [sod-parser:parser-error]
+ sod-parser:parser-error
+ lexer-error [sod-parser:base-lexer-error]
+ syntax-error [sod-parser:base-syntax-error]
cl:standard-object
alignas-storage-specifier
base-offset
sod-class-effective-slot
ichain
ilayout
+ inheritance-path-reporter-state
inst
banner-inst
block-inst
effective-method-keywords
effective-method
effective-method-live-p
+ aggregating-effective-method
sod::lifecycle-effective-method
simple-effective-method
effective-method-message
module
finalize-sod-class
sod-class
+ sod-class [:around]
find-slot-initargs
sod-class sod-slot
find-slot-initializer
method-entry-slot-name
method-entry
method-keyword-argument-lists
- effective-method t
- sod::initialization-effective-method t
+ effective-method t t
+ sod::initialization-effective-method t t
module-dependencies
module
(setf module-dependencies)
sod-method
sod-method-class
sod-method
+ sod-method-description
+ basic-direct-method
sod-method-function-name
basic-direct-method
sod-method-function-type
Package `sod-parser'
floc-proto.lisp
+ base-lexer-error class
+ base-syntax-error class
cerror* function
cerror*-with-location function
cerror-with-location function
+ classify-condition generic
condition-with-location class
count-and-report-errors macro
enclosed-condition generic
enclosing-condition class
enclosing-condition-with-location class
+ enclosing-condition-with-location-type generic
enclosing-error-with-location class
+ enclosing-information-with-location class
enclosing-warning-with-location class
error-with-location function class
file-location generic class
file-location-filename function
file-location-line function
file-location-p function
+ info function
+ info-with-location function
+ information class
+ information-with-location class
make-condition-with-location function
make-file-location function
+ noted function
+ parser-error class
+ parser-error-expected generic
+ parser-error-found generic
+ report-parser-error function
simple-condition-with-location class
simple-error-with-location class
+ simple-information class
+ simple-information-with-location class
+ simple-lexer-error class
+ simple-syntax-error class
simple-warning-with-location class
warn-with-location function
warning-with-location class
condition-with-location
enclosing-condition-with-location [enclosing-condition]
enclosing-error-with-location [cl:error]
+ enclosing-information-with-location [information]
enclosing-warning-with-location [cl:warning]
error-with-location [cl:error]
+ base-lexer-error
+ simple-lexer-error [simple-error-with-location]
+ base-syntax-error
+ simple-syntax-error [simple-error-with-location]
simple-error-with-location [cl:simple-error]
+ simple-lexer-error [base-lexer-error]
+ simple-syntax-error [base-syntax-error]
+ information-with-location [information]
+ simple-information-with-location [simple-information]
simple-condition-with-location [cl:simple-condition]
warning-with-location [cl:warning]
simple-warning-with-location [cl:simple-warning]
enclosing-condition
enclosing-condition-with-location [condition-with-location]
enclosing-error-with-location [cl:error]
+ enclosing-information-with-location [information]
enclosing-warning-with-location [cl:warning]
+ information
+ enclosing-information-with-location [enclosing-condition-with-location]
+ information-with-location [condition-with-location]
+ simple-information-with-location [simple-information]
+ simple-information [cl:simple-condition]
+ simple-information-with-location [information-with-location]
cl:serious-condition
cl:error
enclosing-error-with-location [enclosing-condition-with-location]
error-with-location [condition-with-location]
+ base-lexer-error
+ simple-lexer-error [simple-error-with-location]
+ base-syntax-error
+ simple-syntax-error [simple-error-with-location]
simple-error-with-location [cl:simple-error]
+ simple-lexer-error [base-lexer-error]
+ simple-syntax-error [base-syntax-error]
+ parser-error
cl:simple-error [cl:simple-condition]
simple-error-with-location [error-with-location]
+ simple-lexer-error [base-lexer-error]
+ simple-syntax-error [base-syntax-error]
cl:simple-condition
simple-condition-with-location [condition-with-location]
cl:simple-error [cl:error]
simple-error-with-location [error-with-location]
+ simple-lexer-error [base-lexer-error]
+ simple-syntax-error [base-syntax-error]
+ simple-information [information]
+ simple-information-with-location [information-with-location]
cl:simple-warning [cl:warning]
simple-warning-with-location [warning-with-location]
cl:warning
simple-unary-operator sod-parser::expression-parse-state
charbuf-scanner-map
charbuf-scanner t
+ classify-condition
+ cl:error
+ cl:warning
+ base-lexer-error
+ base-syntax-error
+ information
enclosed-condition
enclosing-condition
+ enclosing-condition-with-location-type
+ cl:condition
+ cl:error
+ cl:warning
+ information
expand-parser-form
t (eql cl:and) t
t (eql cl:list) t
list-parser (eql cl:type) t
token-parser-context (eql token) t
token-scanner-context (eql cl:error) t
+ token-scanner-context (eql sod:must) t
token-scanner-context (eql sod:skip-until) t
expand-parser-spec
t (eql :eof)
condition-with-location
file-location
position-aware-stream
+ string-scanner
token-scanner
token-scanner-place
cl:make-load-form
parser-current-char
character-scanner-context
string-parser
+ parser-error-expected
+ parser-error
+ parser-error-found
+ parser-error
parser-places-must-be-released-p
t
list-parser
scanner-column
t
charbuf-scanner
+ string-scanner
token-scanner
(setf scanner-column)
t token-scanner
scanner-filename
t
charbuf-scanner
+ string-scanner
token-scanner
scanner-interval
charbuf-scanner t
scanner-line
t
charbuf-scanner
+ string-scanner
token-scanner
(setf scanner-line)
t token-scanner
sod:sod-token-scanner
scanner-unread
charbuf-scanner t
+ string-scanner t
cl:shared-initialize
charbuf-scanner t [:after]
simple-binary-operator t [:after]
Package `sod-utilities'
utilities.lisp
+ aand macro
acase macro
acond macro
aecase macro
default-slot macro
define-access-wrapper macro
define-on-demand-slot macro
+ defvar-unbound macro
+ designated-condition function
+ distinguished-point-shortest-paths function
dosequence macro
sb-mop:eql-specializer class
sb-mop:eql-specializer-object generic
sb-mop:generic-function-methods generic setf
inconsistent-merge-error class
instance-initargs generic
+ invoke-associated-restart function
it
lbuild-add function
lbuild-add-list function
sb-mop:method-specializers generic
once-only macro
parse-body function
+ partial-order-minima function
print-ugly-stuff function
ref function setf
+ simple-control-error class
symbolicate function
update-position function
whitespace-char-p function
cl:condition
cl:serious-condition
cl:error
+ cl:control-error
+ simple-control-error [cl:simple-error]
inconsistent-merge-error
+ cl:simple-error [cl:simple-condition]
+ simple-control-error [cl:control-error]
+ cl:simple-condition
+ cl:simple-error [cl:error]
+ simple-control-error [cl:control-error]
cl:standard-object
sb-mop:metaobject
sb-mop:specializer
\def\ind{\quad\=\+\kill}
\def\@progcr{\futurelet\@tempa\@progcr@i}
{\def\:{\gdef\@progcr@sp}\: {\@progcr}}
+\atdef~{\textasciitilde}
\def\@progcr@i{%
\ifx\@tempa\@sptoken\let\next@\@progcr@sp\else
\if1\ifx\@tempa[1\else
\definedescribecategory{be-meth}{before method}
\definedescribecategory{af-meth}{after method}
\definedescribecategory{cls}{class}
+ \definedescribecategory{rst}{restart}
\definedescribecategory{ty}{type}
\definedescribecategory{type}{type}
\definedescribecategory{mac}{macro}
(definst suppliedp-struct (stream) (flags var)
(format stream
- "~@<struct { ~2I~_~{unsigned ~A : 1;~^ ~_~} ~I~_} ~A;~:>"
+ "~@<struct { ~2I~_~{unsigned ~A: 1;~^ ~_~} ~I~_} ~A;~:>"
flags var))
;; Initialization.
'initialization-effective-method)
(defmethod method-keyword-argument-lists
- ((method initialization-effective-method) direct-methods)
+ ((method initialization-effective-method) direct-methods state)
(append (call-next-method)
- (delete-duplicates
- (mapcan (lambda (class)
- (let ((initargs (sod-class-initargs class)))
- (and initargs
- (list (cons (mapcar #'sod-initarg-argument
- initargs)
- (format nil "initargs for ~A"
- class))))))
- (sod-class-precedence-list
- (effective-method-class method)))
- :key #'argument-name)))
+ (mapcan (lambda (class)
+ (let* ((initargs (sod-class-initargs class))
+ (map (make-hash-table))
+ (arglist (mapcar
+ (lambda (initarg)
+ (let ((arg (sod-initarg-argument
+ initarg)))
+ (setf (gethash arg map) initarg)
+ arg))
+ initargs)))
+ (and initargs
+ (list (cons (lambda (arg)
+ (info-with-location
+ (gethash arg map)
+ "Type `~A' from initarg ~
+ in class `~A' (here)"
+ (argument-type arg) class)
+ (report-inheritance-path
+ state class))
+ arglist)))))
+ (sod-class-precedence-list
+ (effective-method-class method)))))
(defmethod lifecycle-method-kernel
((method initialization-effective-method) codegen target)
;; Done.
(dolist (class classes)
- (finalize-sod-class class)
+ (unless (finalize-sod-class class)
+ (error "Failed to finalize built-in class"))
(add-to-module module class))))
(export '*builtin-module*)
- (defvar *builtin-module* nil
+ (defvar-unbound *builtin-module*
"The builtin module.")
(export 'make-builtin-module)
:case :common)
:state nil)))
(with-module-environment (module)
- (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
- (add-to-module module (make-instance 'type-item :name name)))
(flet ((header-name (name)
(concatenate 'string "\"" (string-downcase name) ".h\""))
(add-includes (reason &rest names)
(setf *builtin-module* module)))
(define-clear-the-decks builtin-module
- (unless *builtin-module* (make-builtin-module)))
+ (unless (boundp '*builtin-module*) (make-builtin-module)))
;;;----- That's all, folks --------------------------------------------------
(defmethod make-sod-slot
((class sod-class) name type pset &optional location)
(with-default-error-location (location)
+ (when (typep type 'c-function-type)
+ (error "Slot declarations cannot have function type"))
(let ((slot (make-instance (get-property pset :slot-class :symbol
'sod-slot)
:class class
(defmethod make-sod-user-initarg
((class sod-class) name type pset &optional default location)
- (declare (ignore pset))
(with-slots (initargs) class
- (push (make-instance 'sod-user-initarg :location (file-location location)
+ (push (make-instance (get-property pset :initarg-class :symbol
+ 'sod-user-initarg)
+ :location (file-location location)
:class class :name name :type type :default default)
initargs)))
(defmethod make-sod-slot-initarg-using-slot
((class sod-class) name (slot sod-slot) pset &optional location)
- (declare (ignore pset))
(with-slots (initargs) class
(with-slots ((type %type)) slot
- (push (make-instance 'sod-slot-initarg
+ (push (make-instance (get-property pset :initarg-class :symbol
+ 'sod-slot-initarg)
:location (file-location location)
:class class :name name :type type :slot slot)
initargs))))
(defclass aggregating-effective-method (simple-effective-method) ()
(:documentation "Effective method counterpart to `aggregating-message'."))
+(defgeneric aggregating-message-always-live-p (message combination)
+ (:documentation
+ "Return whether the method combination can work without primary methods.
+
+ Return non-nil if the corresponding effective method should be considered
+ live even if it doesn't have any methods.")
+ (:method ((message aggregating-message) (combination t)) nil))
+
+(defmethod effective-method-live-p ((method aggregating-effective-method))
+ (or (let* ((message (effective-method-message method))
+ (comb (sod-message-combination message)))
+ (aggregating-message-always-live-p message comb))
+ (call-next-method)))
+
;;;--------------------------------------------------------------------------
;;; Implementation.
;; Check that we've been given a method combination and make sure it
;; actually exists.
(unless comb
- (error "The `combination' property is required."))
+ (error "The `combination' property is required"))
(unless (some (lambda (method)
(let* ((specs (method-specializers method))
(message-spec (car specs))
comb))))
(generic-function-methods
#'compute-aggregating-message-kernel))
- (error "Unknown method combination `~(~A~)'." comb))
+ (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'."))
+ (error "The `most_specific' property must be `first' or `last'"))
;; Set up the function which will compute the kernel.
(let ((magic (cons nil nil))
(methods (gensym "METHODS-")))
&key properties return-type
((:around around-func) '#'funcall)
+ ((:empty empty-func) nil emptyp)
((:first-method first-method-func) nil firstp)
((:methods methods-func) '#'funcall))
"Utility macro for definining aggregating method combinations.
on `check-aggregating-message-type' to check the that the message's return
type matches RETURN-TYPE.
+ If an EMPTY function is given, then (a) it's OK if there are no primary
+ methods, because (b) the EMPTY function is called to set the return
+ value variable in this case. Note that EMPTY is only called when there
+ are no primary methods.
+
The AROUND, FIRST-METHOD, and METHODS are function designators (probably
`lambda' forms) providing pieces of the aggregating behaviour.
(with-gensyms (type msg combvar target arg-names args want-type
meth targ func call-methfunc
- aroundfunc fmethfunc methfunc)
+ aroundfunc fmethfunc methfunc bodyfunc)
`(progn
;; If properties are listed, arrange for them to be collected.
(unless (c-type-equal-p (c-type-subtype ,type)
,want-type)
(error "Messages with `~(~A~)' combination ~
- must return `~A'."
+ must return `~A'"
,combvar ,want-type)))
(call-next-method))))
+ ;; If there is an EMPTY function then the effective method is always
+ ;; live.
+ ,@(and emptyp
+ `((defmethod aggregating-message-always-live-p
+ ((,msg aggregating-message)
+ (,combvar (eql ',comb)))
+ t)))
+
;; Define the main kernel-compuation method.
(defmethod compute-aggregating-message-kernel
((,msg aggregating-message) (,combvar (eql ',comb))
;; 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)))))
+ `((,type (c-type-subtype (sod-message-type ,msg)))
+ (,(car vars) (temporary-var ,codegen ,type))))
,@(mapcar (lambda (var)
- (list var `(temporary-var ,codegen ,type)))
- vars)
+ (list var `(and ,methods
+ (temporary-var ,codegen ,type))))
+ (cdr 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)))))
+ (flet ((,bodyfunc ()
+ (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)))))))
+
+ ;; Arrange to release the temporaries when we're finished with
+ ;; them.
+ (unwind-protect
+ (progn
+
+ ;; If there are no direct methods, then just do the
+ ;; empty-effective-method thing to set the return
+ ;; variable. Otherwise, wrap AROUND round the main body.
+ ,(if emptyp
+ `(if (null ,methods)
+ (funcall ,empty-func)
+ (,bodyfunc))
+ `(,bodyfunc))
;; 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))))
+ ;; Finally, release the temporary variables.
+ ,@(mapcar (lambda (var)
+ `(when ,var (setf (var-in-use-p ,var) nil)))
+ vars)))))
',comb)))
;;; Fixed aggregating method combinations.
(define-aggregating-method-combination :progn (nil)
- :return-type void)
+ :return-type void
+ :empty (lambda () nil))
(define-aggregating-method-combination :sum ((acc val) :codegen codegen)
+ :empty (lambda () (emit-inst codegen (make-set-inst acc 0)))
:first-method (lambda (invoke)
(funcall invoke val)
(emit-inst codegen (make-set-inst acc val)))
(emit-inst codegen (make-update-inst acc #\+ val))))
(define-aggregating-method-combination :product ((acc val) :codegen codegen)
+ :empty (lambda () (emit-inst codegen (make-set-inst acc 1)))
:first-method (lambda (invoke)
(funcall invoke val)
(emit-inst codegen (make-set-inst acc val)))
(make-set-inst acc val)))))
(define-aggregating-method-combination :and ((ret) :codegen codegen)
+ :empty (lambda () (emit-inst codegen (make-set-inst ret 1)))
:around (lambda (body)
(codegen-push codegen)
(funcall body)
(make-break-inst)))))
(define-aggregating-method-combination :or ((ret) :codegen codegen)
+ :empty (lambda () (emit-inst codegen (make-set-inst ret 0)))
:around (lambda (body)
(codegen-push codegen)
(funcall body)
'(:retvar :id
:valvar :id
:methty :type
+ :empty :fragment
:decls :fragment
:before :fragment
:first :fragment
(getf (sod-message-plist message) :methty
(c-type-subtype (sod-message-type message))))
+(defmethod aggregating-message-always-live-p
+ ((message aggregating-message) (combination (eql :custom)))
+ (getf (sod-message-plist message) :empty))
+
(defmethod compute-aggregating-message-kernel
((message aggregating-message) (combination (eql :custom))
codegen target methods arg-names
&key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp)
- decls before each (first each) after count)
+ empty decls before each (first each) after count)
(let* ((type (c-type-subtype (sod-message-type message)))
(methty (if methtyp methty type)))
(unless (eq type c-type-void)
(ensure-var codegen retvar type))
- (unless (eq methty c-type-void)
+ (unless (or (null methods)
+ (eq methty c-type-void))
(ensure-var codegen valvar methty))
- (when count
+ (when (and methods count)
(ensure-var codegen count c-type-size-t (length methods)))
- (when decls
+ (when (and methods decls)
(emit-decl codegen decls))
(labels ((maybe-emit (fragment)
(when fragment (emit-inst codegen fragment)))
(if (eq methty c-type-void) :void valvar)
arg-names method)
(maybe-emit fragment)))
- (maybe-emit before)
- (invoke (car methods) first)
- (dolist (method (cdr methods)) (invoke method each))
- (maybe-emit after)
+ (cond ((and empty (null methods))
+ (emit-inst codegen empty))
+ (t
+ (maybe-emit before)
+ (invoke (car methods) first)
+ (dolist (method (cdr methods)) (invoke method each))
+ (maybe-emit after)))
(deliver-expr codegen target retvar))))
;;;----- That's all, folks --------------------------------------------------
("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 method-keyword-argument-lists
- ((method effective-method) direct-methods)
+ ((method effective-method) direct-methods state)
(with-slots (message) method
- (and (keyword-message-p message)
- (mapcar (lambda (m)
- (let ((type (sod-method-type m)))
- (cons (c-function-keywords type)
- (format nil "method for ~A on ~A (at ~A)"
- message
- (sod-method-class m)
- (file-location m)))))
- direct-methods))))
+ (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 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
+ ;; 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
- (merge-keyword-lists (method-keyword-argument-lists
- method direct-methods)))))
+ (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))))))
(export '(basic-effective-method
effective-method-around-methods effective-method-before-methods
(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)))
#+ecl (loop for i from 1
below (ext:argc)
collect (ext:argv i))))
- (error "Unsupported Lisp."))))))
+ (error "Unsupported Lisp"))))))
- *program-name* (pathname-name (car *command-line*))))
+ *program-name* (pathname-name (car *command-line*))))
;;;--------------------------------------------------------------------------
;;; Fancy conditionals.
(opt-long-name o)
(opt-arg-optional-p o)
(opt-arg-name o)
- (opt-documentation o)))))
+ (opt-%documentation o)))))
(:constructor %make-option
(&key long-name tag negated-tag short-name
arg-name arg-optional-p documentation
~mdw / sod / commitdiff