From: Mark Wooding Date: Fri, 8 Jun 2018 19:09:02 +0000 (+0100) Subject: Merge branches 'mdw/doc-reorg' and 'mdw/parser-fixes' X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/3a774b55edfea441c1715994924c2999e9202143?hp=-c Merge branches 'mdw/doc-reorg' and 'mdw/parser-fixes' * mdw/doc-reorg: (34 commits) doc/refintro.tex, src/sod-module.5: Fix slightly garbled text. doc/syntax.tex: Delete (wrong) duplicate rule for . 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. ... --- 3a774b55edfea441c1715994924c2999e9202143 diff --combined doc/SYMBOLS index 63f081c,dcd96ec..ca7dc8f --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@@ -70,6 -70,7 +70,7 @@@ c-types-impl.lis 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 @@@ -195,12 -196,16 +196,16 @@@ class-finalize-impl.lis 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 @@@ -305,8 -310,12 +310,12 @@@ class-utilities.lis 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 @@@ -461,11 -470,12 +470,12 @@@ fragment-parse.lis 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 @@@ -533,6 -543,7 +543,7 @@@ method-proto.lis 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 @@@ -598,6 -609,7 +609,7 @@@ output-proto.lis sequencer-table generic pset-parse.lisp + parse-property function parse-property-set function pset-proto.lisp @@@ -630,8 -642,22 +642,22 @@@ Classes 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 @@@ -667,6 -693,7 +693,7 @@@ sod-class-effective-slot ichain ilayout + inheritance-path-reporter-state inst banner-inst block-inst @@@ -927,7 -954,6 +954,7 @@@ effective-method-function-nam effective-method-keywords effective-method effective-method-live-p + aggregating-effective-method sod::lifecycle-effective-method simple-effective-method effective-method-message @@@ -1073,6 -1099,7 +1100,7 @@@ finalize-modul module finalize-sod-class sod-class + sod-class [:around] find-slot-initargs sod-class sod-slot find-slot-initializer @@@ -1277,8 -1304,8 +1305,8 @@@ method-entry-function-typ 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) @@@ -1496,6 -1523,8 +1524,8 @@@ sod-method-bod sod-method sod-method-class sod-method + sod-method-description + basic-direct-method sod-method-function-name basic-direct-method sod-method-function-type @@@ -1567,15 -1596,20 +1597,20 @@@ Methods 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 @@@ -1583,10 -1617,23 +1618,23 @@@ 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 @@@ -1725,27 -1772,56 +1773,56 @@@ cl: 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 @@@ -1856,8 -1932,19 +1933,19 @@@ apply-operato 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 @@@ -1885,6 -1972,7 +1973,7 @@@ 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) @@@ -1914,6 -2002,7 +2003,7 @@@ file-locatio condition-with-location file-location position-aware-stream + string-scanner token-scanner token-scanner-place cl:make-load-form @@@ -1947,6 -2036,10 +2037,10 @@@ parser-capture-plac 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 @@@ -2001,6 -2094,7 +2095,7 @@@ scanner-capture-plac scanner-column t charbuf-scanner + string-scanner token-scanner (setf scanner-column) t token-scanner @@@ -2010,6 -2104,7 +2105,7 @@@ scanner-current-cha scanner-filename t charbuf-scanner + string-scanner token-scanner scanner-interval charbuf-scanner t @@@ -2017,6 -2112,7 +2113,7 @@@ scanner-line t charbuf-scanner + string-scanner token-scanner (setf scanner-line) t token-scanner @@@ -2038,6 -2134,7 +2135,7 @@@ scanner-toke sod:sod-token-scanner scanner-unread charbuf-scanner t + string-scanner t cl:shared-initialize charbuf-scanner t [:after] simple-binary-operator t [:after] @@@ -2167,6 -2264,7 +2265,7 @@@ cl:print-objec Package `sod-utilities' utilities.lisp + aand macro acase macro acond macro aecase macro @@@ -2183,6 -2281,9 +2282,9 @@@ 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 @@@ -2190,6 -2291,7 +2292,7 @@@ 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 @@@ -2205,8 -2307,10 +2308,10 @@@ 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 @@@ -2219,7 -2323,14 +2324,14 @@@ cl: 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 diff --combined doc/sod.sty index 5538bd7,d77c038..2cdb499 --- a/doc/sod.sty +++ b/doc/sod.sty @@@ -136,7 -136,6 +136,7 @@@ \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 @@@ -187,6 -186,7 +187,7 @@@ \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} diff --combined src/builtin.lisp index c10e5ad,be9a8e5..7357752 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@@ -279,7 -279,7 +279,7 @@@ static const SodClass *const ~A__cpl[] (definst suppliedp-struct (stream) (flags var) (format stream - "~@" + "~@" flags var)) ;; Initialization. @@@ -295,19 -295,30 +295,30 @@@ '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) @@@ -541,11 -552,12 +552,12 @@@ ;; 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) @@@ -564,8 -576,6 +576,6 @@@ :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) @@@ -584,6 -594,6 +594,6 @@@ (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 -------------------------------------------------- diff --combined src/class-make-impl.lisp index 3c5bb35,78f8fed..7495c01 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@@ -66,6 -66,8 +66,8 @@@ (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 @@@ -144,10 -146,9 +146,10 @@@ (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))) @@@ -158,10 -159,10 +160,10 @@@ (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)))) diff --combined src/method-aggregate.lisp index dcafd8d,eeea9df..82ff2ca --- a/src/method-aggregate.lisp +++ b/src/method-aggregate.lisp @@@ -106,20 -106,6 +106,20 @@@ (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. @@@ -147,7 -133,7 +147,7 @@@ ;; 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)) @@@ -159,12 -145,12 +159,12 @@@ 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)) @@@ -213,7 -199,6 +213,7 @@@ (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. @@@ -248,11 -233,6 +248,11 @@@ 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. @@@ -277,7 -257,7 +277,7 @@@ (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. @@@ -303,18 -283,10 +303,18 @@@ (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)) @@@ -326,63 -298,51 +326,63 @@@ ;; 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))) @@@ -390,11 -350,9 +390,11 @@@ ;;; 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))) @@@ -403,7 -361,6 +403,7 @@@ (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))) @@@ -430,7 -387,6 +430,7 @@@ (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) @@@ -442,7 -398,6 +442,7 @@@ (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) @@@ -460,7 -415,6 +460,7 @@@ '(:retvar :id :valvar :id :methty :type + :empty :fragment :decls :fragment :before :fragment :first :fragment @@@ -473,25 -427,20 +473,25 @@@ (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))) @@@ -500,13 -449,10 +500,13 @@@ (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 -------------------------------------------------- diff --combined src/method-impl.lisp index 4bf3214,5ea09e3..e93fb3a --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@@ -152,6 -152,11 +152,11 @@@ ("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 @@@ -245,27 -250,47 +250,47 @@@ ;;; 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 @@@ -661,8 -686,7 +686,8 @@@ (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)) @@@ -793,14 -817,6 +818,14 @@@ (*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))) diff --combined src/optparse.lisp index 2234595,6460c54..367fc50 --- a/src/optparse.lisp +++ b/src/optparse.lisp @@@ -83,9 -83,9 +83,9 @@@ #+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. @@@ -165,7 -165,7 +165,7 @@@ (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