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
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
\begin{describe}{mac}
{define-simple-c-type
- \=@{ @<name> @! (@<name>^+) @} @<string> \+\\
+ \=@{ @<name> @! (@<name>^+) @}
+ @{ @<string> @! (@<string>^*) @} \+\\
@[[ @|:export| @<export-flag> @]]
\-\nlret @<name>}
Define type specifiers for a new simple C type. Each symbol @<name> is
defined as a symbolic type specifier for the (unique interned) simple C
- type whose name is the value of @<string>. Further, each @<name> is
- defined to be a type operator: the type specifier @|(@<name>
+ type whose name is the value of (the first) @<string>. Further, each
+ @<name> is defined to be a type operator: the type specifier @|(@<name>
@<qualifier>^*)| evaluates to the (unique interned) simple C type whose
- name is @<string> and which has the @<qualifiers> (which are evaluated).
+ name is (the first) @<string> and which has the @<qualifiers> (which are
+ evaluated).
- Furthermore, a variable @|c-type-@<name>| is defined, for the first @<name>
- only, and initialized with the newly constructed C type object.
+ Each of the @<string>s is associated with the resulting type for retrieval
+ by \descref{find-simple-c-type}{fun}. Furthermore, a variable
+ @|c-type-@<name>| is defined, for the first @<name> only, and initialized
+ with the newly constructed C type object.
If @<export-flag> is true, then the @|c-type-@<name>| variable name, and
all of the @<name>s, are exported from the current package.
\end{describe}
+\begin{describe}{fun}
+ {find-simple-c-type @<string> @> @{ @<simple-c-type> @! @|nil| @}}
+ If @<string> is the name of a simple C type, as established by the
+ \descref{define-simple-c-type}[macro]{mac}, then return the corresponding
+ @|simple-c-type| object; otherwise, return @|nil|.
+\end{describe}
+
\begin{describe}{cls}{tagged-c-type (qualifiable-c-type)
\&key :qualifiers :tag}
Provides common behaviour for C tagged types. A @<tag> is a string
original list is not modified, but may share structure with the new list.
\end{describe}
-\begin{describe}{fun}{merge-keyword-lists @<lists> @> @<list>}
+\begin{describe}{fun}
+ {merge-keyword-lists @<what-function> @<lists> @> @<list>}
Merge a number of keyword-argument lists together and return the result.
- The @<lists> parameter is a list consisting of a number of @|(@<args>
- . @<origin>)| pairs: in each pair, @<args> is a list of
- \descref{argument}{cls} objects, and @<origin> is either nil or an object
- whose printed representation describes the origin of the corresponding
- @<args> list, suitable for inclusion in an error message.
+ The @<what-function> is either nil or a function designator; see below.
+
+ The @<lists> parameter is a list consisting of a number of
+ @|(@<report-function> . @<args>)| pairs: in each pair, @<report-function>
+ is either nil or a function designator, and @<args> is a list of
+ \descref{argument}{cls} objects.
The resulting list contains exactly one argument for each distinct argument
name appearing in the input @<lists>; this argument will contain the
default value from the earliest occurrence in the input @<lists> of an
argument with that name.
- If the same name appears multiple times with different types, an error is
- signalled quoting the name, conflicting types, and (if non-nil) the origins
- of the offending argument objects.
+ If the same name appears multiple times with different types, a continuable
+ error will be signalled, and one of the conflicting argument types will be
+ chosen arbitrarily. The @<what-function> will be called to establish
+ information which will be reported to the user. It will be called with no
+ arguments and is expected to return two values:
+ \begin{itemize}
+ \item a file location @<floc> or other object acceptable to
+ \descref{file-location}{gf}, to be used as the location of the main
+ error; and
+ \item an object @<what>, whose printed representation should be a noun
+ phrase describing the object for which the argument lists are being
+ combined.
+ \end{itemize}
+ The phrasing of the error message is `type mismatch in @<what>'. Either,
+ or both, of @<floc> and @<what> may be nil, though this is considered poor
+ practice; if @<what-function> is nil, this is equivalent to a function
+ which returns two nil values. Following the error, the @<report-function>s
+ for the @<args> lists containing the conflicting argument objects are
+ called, in an arbitrary order, with a single argument which is the
+ offending @|argument| object; the function is expected to issue information
+ messages (see \descref{info}{fun}) to give more detail for diagnosing the
+ conflict. If a @<report-function> is nil, then nothing happens; this is
+ considered poor practice.
\end{describe}
\begin{describe}{fun}
\end{describe}
\begin{describe}{gf}
- {method-keyword-argument-lists @<method> @<direct-methods> @> @<list>}
+ {method-keyword-argument-lists @<method> @<direct-methods> @<state>
+ @> @<list>}
\end{describe}
\begin{describe}{gf}
\begin{describe}{gf}{sod-method-next-method-type @<method> @> @<c-type>}
\end{describe}
+\begin{describe}{gf}{sod-method-description @<method> @> @<string>}
+\end{describe}
+
\begin{describe}{gf}{sod-method-function-name @<method> @> @<string>}
\end{describe}
{find-superclass-by-nick @<class> @<nick> @> @<superclass>}
\end{describe}
+\begin{describe}{ty}{inheritance-path-reporter-state}
+\end{describe}
+
+\begin{describe}{fun}{make-inheritance-path-reporter-state @> @<state>}
+\end{describe}
+
+\begin{describe}{fun}{report-inheritance-path @<state> @<super>}
+\end{describe}
+
+\begin{describe}{fun}
+ {select-minimal-class-property
+ \=@<supers> @<key> @<order> @<default> @<what> \\
+ \>\&key :present :allow-empty
+ \nlret @<object>}
+\end{describe}
+
\begin{describe}{fun}
{sod-subclass-p @<class-a> @<class-b> @> @<generalized-boolean>}
\end{describe}
%%%--------------------------------------------------------------------------
\section{Class finalization protocol} \label{sec:meta.finalization}
+\begin{describe}{mac}
+ {finalization-error (@<token> @<arg>^*) \\ \ind
+ @<declaration>^* \\
+ @<form>^* \-
+ \nlret @<value>^*}
+\end{describe}
+
+\begin{describe}{fun}{finalization-failed}
+\end{describe}
+
\begin{describe*}
{\dhead{gf}{sod-class-precedence-list @<class> @> @<list>}
\dhead{gf}{sod-class-type @<class> @> @<c-type>}
\begin{describe}{gf}{compute-cpl @<class> @> @<list>}
\end{describe}
+\begin{describe}{fun}
+ {report-class-list-merge-error @<class> @<lists> @<error>}
+\end{describe}
+
+\begin{describe}{fun}{merge-class-lists @<class> @<lists> @<pick> @> @<list>}
+\end{describe}
+
\begin{describe}{gf}{compute-chains @<class> @> @<list>}
\end{describe}
\begin{describe}{gf}{check-sod-class @<class>}
\end{describe}
-\begin{describe}{gf}{finalize-sod-class @<class>}
+\begin{describe}{gf}{finalize-sod-class @<class> @> @<generalized-boolean>}
+ \begin{describe}{meth}{finalize-sod-class (@<class> sod-class)}
+ \end{describe}
+ \begin{describe}{ar-meth}{finalize-sod-class (@<class> sod-class)
+ @> @<generalized-boolean>}
+ \end{describe}
\end{describe}
\begin{describe}{fun}{clos-cpl @<class> @> @<list>}
\begin{describe}{mac}{aif @<condition> @<consequent> @[@<alt>@]}
\end{describe}
+\begin{describe}{mac}{aand @<form>^*}
+\end{describe}
+
\begin{describe}{mac}{awhen @<condition> @<form>^*}
\end{describe}
{mappend @<function> @<list> \&rest @<more-lists> @> @<result-list>}
\end{describe}
+\begin{describe}{fun}
+ {distinguished-point-shortest-paths @<root> @<neighbours-func>
+ @> @<list>}
+\end{describe}
+
\begin{describe}{cls}{inconsistent-merge-error (error) \&key :candidates}
\end{describe}
\end{describe}
\begin{describe}{fun}
- {merge-lists @<lists> \&key :pick (:test \#'eql) @> @<list>}
+ {merge-lists @<lists> \&key :pick (:test \#'eql) :present @> @<list>}
\end{describe}
\begin{describe}{mac}
\-\nlret @<value>^*}
\end{describe}
+\begin{describe}{fun}{partial-order-minima @<items> @<order> @> @<list>}
+\end{describe}
+
\begin{describe}{fun}
{frob-identifier @<string> \&key :swap-case :swap-hyphen
@> @<frobbed-string>}
{compose @<function> \&rest @<more-functions> @> @<function>}
\end{describe}
+\begin{describe}{mac}{defvar @<name> @<documentation> @> @<name>}
+\end{describe}
+
\begin{describe}{fun}{symbolicate \&rest @<symbols> @> @<symbol>}
\end{describe}
@[[ :read-only @<read-only-flag> @]]}
\end{describe}
+\begin{describe}{cls}
+ {simple-control-error (control-error simple-error)
+ \&key :format-control :format-arguments}
+\end{describe}
+
+\begin{describe}{fun}
+ {designated-condition
+ \=@<default-type> @<datum> @<arguments> \\
+ \>\&key :allow-pointless-arguments
+ \nlret @<condition>}
+\end{describe}
+
+\begin{describe}{fun}
+ {invoke-associated-restart @<restart> @<condition> \&rest @<arguments>}
+\end{describe}
+
\begin{describe}{mac}
{default-slot (@<instance> @<slot> @[@<slot-names>@]) \\ \ind
@<form>^*}
{enclosed-condition @<enclosing-condition> @> @<condition>}
\end{describe}
+\begin{describe}{cls}{information (condition) \&key}
+\end{describe}
+
+\begin{describe}{cls}
+ {simple-information (simple-condition information) \\ \ind
+ \&key :format-control :format-arguments}
+\end{describe}
+
+\begin{describe}{fun}{info @<datum> \&rest @<arguments> @> @<flag>}
+\end{describe}
+
+\begin{describe*}
+ {\dhead{rst}{noted}
+ \dhead{fun}{noted \&optional @<condition>}}
+\end{describe*}
+
\begin{describe}{fun}{cerror* @<datum> \&rest @<arguments>}
\end{describe}
\end{describe}
\begin{describe}{fun}
+ {parse-property @<scanner> @<pset>
+ @> @<result> @<success-flag> @<consumed-flag>}
+\end{describe}
+
+\begin{describe}{fun}
{parse-property-set @<scanner>
@> @<result> @<success-flag> @<consumed-flag>}
\end{describe}
\begin{describe}{var}{*debugout-pathname*}
\end{describe}
-\begin{describe}{fun}{test-module @<path> @<reason>}
+\begin{describe}{fun}
+ {test-module @<path> \&key :reason :clear :backtrace @> @<status>}
\end{describe}
\begin{describe}{fun}
\end{describe}
\begin{describe}{mac}
- {test-parser (@<scanner>) @<parser> @<input>
- @> @<success-flag> @<result> @<remainder>}
+ {test-parser (@<scanner>
\&key :backtrace) @<parser> @<input>
+ @> @<result> @<status> @<remainder>}
\end{describe}
\begin{describe}{fun}{exercise}
{warning-with-location (condition-with-location warning) \\ \>
\&key :location}
\dhead{cls}
+ {information-with-location (condition-with-location information) \\ \>
+ \&key :location}
+ \dhead{cls}
{enclosing-error-with-location
(enclosing-error-with-location error) \\ \>
\&key :condition :location}
(enclosing-condition-with-location warning) \\ \>
\&key :condition :location}
\dhead{cls}
+ {enclosing-information-with-location
+ (enclosing-condition-with-location information) \\ \>
+ \&key :condition :location}
+ \dhead{cls}
{simple-condition-with-location
(condition-with-location simple-condition) \\ \>
\&key :format-control :format-arguments :location}
\dhead{cls}
{simple-warning-with-location
(warning-with-location simple-warning) \\ \>
+ \&key :format-control :format-arguments :location}
+ \dhead{cls}
+ {simple-information-with-location
+ (information-with-location simple-information) \\ \>
\&key :format-control :format-arguments :location}}
\end{describe*}
+\begin{describe}{gf}
+ {enclosing-condition-with-location-type @<condition> @> @<symbol>}
+\end{describe}
+
\begin{describe}{fun}
{make-condition-with-location @<default-type> @<floc>
@<datum> \&rest @<arguments>
\dhead{fun}{warn-with-location @<floc> @<datum> \&rest @<arguments>}}
\end{describe*}
+\begin{describe*}
+ {\dhead{cls}{parser-error (error) \\ \ind
+ \&key :expected :found \-}
+ \dhead{gf}{parser-error-expected @<condition> @> @<list>}
+ \dhead{gf}{parser-error-found @<condition> @> @<value>}}
+\end{describe*}
+
+\begin{describe}{fun}
+ {report-parser-error @<error> @<stream> @<show-expected> @<show-found>}
+\end{describe}
+
+\begin{describe*}
+ {\quad\=\kill
+ \dhead{cls}{base-lexer-error (error-with-location) \&key :location}
+ \dhead{cls}{simple-lexer-error
+ (base-lexer-error simple-error-with-location) \\\>
+ \&key :format-control :format-arguments :location}
+ \dhead{cls}{base-syntax-error (error-with-location) \&key :location}
+ \dhead{cls}{simple-syntax-error
+ (base-syntax-error simple-error-with-location) \\\>
+ \&key :format-control :format-arguments :location}}
+\end{describe*}
+
\begin{describe}{mac}
{with-default-error-location (@<floc>) @<declaration>^* @<form>^*
@> @<value>^*}
\end{describe}
+\begin{describe}{gf}{classify-condition @<condition> @> @<string>}
+ \begin{describe*}
+ {\dhead{meth}{classify-condition (@<condition> error) @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> warning) @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> information)
+ @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> base-lexer-error)
+ @> @<string>}
+ \dhead{meth}{classify-condition (@<condition> base-syntax-error)
+ @> @<string>}}
+ \end{describe*}
+\end{describe}
+
\begin{describe}{mac}
{count-and-report-errors () @<declaration>^* @<form>^*
@> @<value> @<n-errors> @<n-warnings>}
\begin{describe}{fun}{define-indicator @<indicator> @<description>}
\end{describe}
-\begin{describe}{fun}{syntax-error @<scanner> @<expected> \&key :continuep}
+\begin{describe*}
+ {\dhead{cls}{lexer-error (parser-error base-lexer-error) \\ \ind
+ \&key :expected :found :location \-}
+ \dhead{cls}{syntax-error (parser-error base-syntax-error) \\ \ind
+ \&key :expected :found :location \-}}
+\end{describe*}
+
+\begin{describe}{fun}
+ {syntax-error @<scanner> @<expected> \&key :continuep :location}
\end{describe}
\begin{describe}{fun}
- {lexer-error @<char-scanner> @<expected> @<consumed-flag>}
+ {lexer-error @<char-scanner> @<expected> \&key :location}
\end{describe}
\begin{describe}{parseform}
\end{describe}
\begin{describe}{parseform}
- {error (@[[ :ignore-unconsumed @<flag> @]]) \\ \ind
- @<sub-parser> @<recover-parser>}
+ {error (@[[ :ignore-unconsumed @<flag> @!
+ :force-process @<flag> @]]) \\ \ind\ind
+ @<sub-parser> @<recover-parser> \-\\
+ @<declaration>^* \\
+ @<form>^*}
+\end{describe}
+
+\begin{describe}{parseform}{must @<sub-parser> @[@<default>@]}
\end{describe}
\begin{describe}{fun}
\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}
is in an argument named
.BR kwfirst_ ,
as set up by
-.B KWTAIL marker described above.
+.B KWTAIL
+marker described above.
.PP
The macro expands both to a variable declaration and a statement:
in C89, declarations must precede statements,
.I set
is an identifier then
.IP
-.B "KWPARSE_EMPTY(" set ");"
+.BI "KWPARSE_EMPTY(" set ");"
.PP
(note the lack of underscore)
checks that the enclosing function has been passed
'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 --------------------------------------------------
(atypecase (gethash name *module-type-map*)
(null nil)
(c-class-type it)
- (t (error "Type `~A' (~A) is not a class" name it))))
+ (t (error "Type `~A' is not a class" name))))
(export 'make-class-type)
(defun make-class-type (name &optional qualifiers)
(export 'find-sod-class)
(defun find-sod-class (name)
"Return the `sod-class' object with the given NAME."
- (aif (find-class-type name)
- (or (c-type-class it) (error "Class `~A' is incomplete" name))
- (error "Type `~A' not known" name)))
+ (acond ((find-class-type name)
+ (or (c-type-class it)
+ (error "Class `~A' is incomplete" name)))
+ ((find-simple-c-type name)
+ (error "Type `~A' is not a class" name))
+ (t
+ (error "Type `~A' not known" name))))
(export 'record-sod-class)
(defun record-sod-class (class)
(defun intern-c-type (class &rest initargs)
"If the CLASS and INITARGS have already been interned, then return the
existing object; otherwise make a new one."
- (let ((list (cons class initargs)))
+ (let ((list (cons (typecase class
+ ;; Canonify the class object; we'd prefer a name.
+ (standard-class (class-name class))
+ (t class))
+ (let ((alist nil) (plist initargs))
+ ;; Canonify the initargs. Arrange for them to be in
+ ;; ascending order by name. This is annoying because
+ ;; a plist isn't a readily sortable sequence.
+ (loop
+ (when (null plist) (return))
+ (let ((name (pop plist)) (value (pop plist)))
+ (push (cons name value) alist)))
+ (dolist (assoc (sort alist #'string> :key #'car))
+ (push (cdr assoc) plist)
+ (push (car assoc) plist))
+ plist))))
(or (gethash list *c-type-intern-map*)
(let ((new (apply #'make-instance class initargs)))
(setf (gethash new *c-type-intern-map*) t
;; S-expression notation protocol.
-(defparameter *simple-type-map* (make-hash-table)
+(defparameter *simple-type-map* (make-hash-table :test #'equal)
"Hash table mapping strings of C syntax to symbolic names.")
(defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
(export 'define-simple-c-type)
(defmacro define-simple-c-type (names type &key export)
"Define each of NAMES to be a simple type called TYPE."
- (let ((names (if (listp names) names (list names))))
- `(progn
- (setf (gethash ,type *simple-type-map*) ',(car names))
- (defctype ,names ,type :export ,export)
- (define-c-type-syntax ,(car names) (&rest quals)
- `(make-simple-type ,',type (list ,@quals))))))
+ (let ((names (if (listp names) names (list names)))
+ (types (if (listp type) type (list type))))
+ (with-gensyms (type name)
+ `(progn
+ (dolist (,type ',types)
+ (setf (gethash ,type *simple-type-map*) ',(car names)))
+ (dolist (,name ',names)
+ (setf (gethash ,name *simple-type-map*) ,(car types)))
+ (defctype ,names ,(car types) :export ,export)
+ (define-c-type-syntax ,(car names) (&rest quals)
+ `(make-simple-type ,',(car types) (list ,@quals)))))))
+
+(export 'find-simple-c-type)
+(defun find-simple-c-type (name)
+ "Return the `simple-c-type' with the given NAME, or nil."
+ (aand (gethash name *simple-type-map*)
+ (make-simple-type (gethash it *simple-type-map*))))
;; Built-in C types.
(define-simple-c-type double "double" :export t)
(define-simple-c-type long-double "long double" :export t)
-(define-simple-c-type bool "_Bool" :export t)
+(define-simple-c-type bool ("_Bool" "bool") :export t)
(define-simple-c-type float-complex "float _Complex" :export t)
(define-simple-c-type double-complex "double _Complex" :export t)
`(progn
(export '(,type ,kind ,constructor))
(defclass ,type (tagged-c-type) ()
- (:documentation ,(format nil "C ~a types." what)))
+ (:documentation ,(format nil "C ~A types." what)))
(defmethod c-tagged-type-kind ((type ,type))
',keyword)
(defmethod kind-c-tagged-type ((kind (eql ',keyword)))
(let ((this-name (argument-name this))
(prev-name (argument-name prev)))
(when (string= this-name prev-name)
- (error "Duplicate keyword argument name `~A'." this-name)))))
+ (error "Duplicate keyword argument name `~A'" this-name)))))
list))
(export 'merge-keyword-lists)
-(defun merge-keyword-lists (lists)
+(defun merge-keyword-lists (whatfn lists)
"Return the union of keyword argument lists.
- The LISTS parameter consists of pairs (ARGS . WHAT), where ARGS is a list
- of `argument' objects, and WHAT is either nil or a printable object
- describing the origin of the corresponding argument list suitable for
- quoting in an error message.
+ The WHATFN is either nil or a designator for a function (see below).
+
+ The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is
+ either nil or a designator for a function (see below); and and ARGS is a
+ list of `argument' objects.
The resulting list contains exactly one argument for each distinct
argument name appearing in the input lists; this argument will contain the
default value corresponding to the name's earliest occurrence in the input
LISTS.
- If the same name appears in multiple input lists with different types, an
- error is signalled; this error will quote the origins of a representative
- conflicting pair of arguments."
+ If the same name appears in multiple input lists with different types, a
+ continuable error is signalled.
+
+ The WHATFN function is given no arguments, and is expected to return a
+ file location (or other object convertible with `file-location'), and a
+ string (or other printable object) describing the site at which the
+ keyword argument lists are being merged or nil; a mismatch error will be
+ reported as being at the location returned by WHATFN, and the description
+ will be included in the error message. A nil WHATFN is equivalent to a
+ function which returns a nil location and description, though this is
+ considered poor practice.
+
+ The REPORTFN is given a single argument ARG, which is one of the
+ conflicting `argument' objects found in the REPORTFN's corresponding
+ argument list: the REPORTFN is expected to issue additional `info'
+ messages to help the user diagnose the problem. The (common) name of the
+ argument has already been reported. A nil REPORTFN is equivalent to one
+ which does nothing, though this is considered poor practice."
;; The easy way through all of this is with a hash table mapping argument
- ;; names to (ARGUMENT . WHAT) pairs.
+ ;; names to (WHAT . ARG) pairs.
(let ((argmap (make-hash-table :test #'equal)))
;; Set up the table. When we find a duplicate, check that the types
;; match.
(dolist (item lists)
- (let ((args (car item))
- (what (cdr item)))
+ (let ((reportfn (car item))
+ (args (cdr item)))
(dolist (arg args)
(let* ((name (argument-name arg))
(other-item (gethash name argmap)))
(if (null other-item)
- (setf (gethash name argmap) (cons arg what))
+ (setf (gethash name argmap) (cons reportfn arg))
(let* ((type (argument-type arg))
- (other (car other-item))
- (other-type (argument-type other))
- (other-what (cdr other-item)))
+ (other-reportfn (car other-item))
+ (other (cdr other-item))
+ (other-type (argument-type other)))
(unless (c-type-equal-p type other-type)
- (error "Type mismatch for keyword argument `~A': ~
- ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]."
- name
- type what
- other-type other-what))))))))
+ (multiple-value-bind (floc desc)
+ (if whatfn (funcall whatfn) (values nil nil))
+ (cerror*-with-location floc
+ "Type mismatch for keyword ~
+ argument `~A'~@[ in ~A~]"
+ name desc)
+ (when reportfn
+ (funcall reportfn arg))
+ (when other-reportfn
+ (funcall other-reportfn other))))))))))
;; Now it's just a matter of picking the arguments out again.
(let ((result nil))
(maphash (lambda (name item)
(declare (ignore name))
- (push (car item) result))
+ (push (cdr item) result))
argmap)
(fix-and-check-keyword-argument-list result))))
(defparameter *declspec-map*
(let ((map (make-hash-table :test #'equal)))
- (dolist (item '((type :void :char :int :float :double
- (:bool :compat "_Bool"))
+ (dolist (item '((type :char :int :float :double)
(complexity (:complex :compat "_Complex")
(:imaginary :compat "_Imaginary"))
((type :taggedp t) :enum :struct :union)
;; Turns out to be easier to do this by hand.
(let ((ds (and (eq (token-type scanner) :id)
(let ((kw (token-value scanner)))
- (or (and (boundp '*module-type-map*)
+ (or (gethash kw *declspec-map*)
+ (and (boundp '*module-type-map*)
(gethash kw *module-type-map*))
- (gethash kw *declspec-map*))))))
+ (find-simple-c-type kw))))))
(cond ((or (not ds) (and predicate (not (funcall predicate ds))))
(values (list indicator) nil nil))
((and (typep ds 'declspec) (ds-taggedp ds))
(disallow-keyword-functions (type)
(when (typep type 'c-keyword-function-type)
(error "Functions with keyword arguments are only ~
- allowed at top-level.")))
+ allowed at top-level")))
(star ()
;; Prefix: `*' qualifiers
((char= ch #\-)
(write-char #\_ out))
(t
- (error "Bad character in C name ~S." name))))))
+ (error "Bad character in C name ~S" name))))))
(t name)))
;;;--------------------------------------------------------------------------
;; Superclass Linearization for Dylan' for more detail.
;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
+;;; Utilities.
+
+(export 'report-class-list-merge-error)
+(defun report-class-list-merge-error (class lists error)
+ "Report a failure to merge superclasseses.
+
+ Here, CLASS is the class whose class precedence list we're trying to
+ compute; the LISTS are the individual superclass orderings being merged;
+ and ERROR is an `inconsistent-merge-error' describing the problem that was
+ encountered.
+
+ Each of the LISTS is assumed to begin with the class from which the
+ corresponding constraint originates; see `merge-class-lists'."
+
+ (let* ((state (make-inheritance-path-reporter-state class))
+ (candidates (merge-error-candidates error))
+ (focus (remove-duplicates
+ (remove nil
+ (mapcar (lambda (list)
+ (cons (car list)
+ (remove-if-not
+ (lambda (item)
+ (member item candidates))
+ list)))
+ lists)
+ :key #'cddr)
+ :test #'equal :key #'cdr)))
+
+ (cerror*-with-location class "Ill-formed superclass graph: ~
+ can't construct class precedence list ~
+ for `~A'"
+ class)
+ (dolist (offenders focus)
+ (let ((super (car offenders)))
+ (info-with-location super
+ "~{Class `~A' orders `~A' before ~
+ ~#[<BUG>~;`~A'~;`~A' and `~A'~:;~
+ ~@{`~A', ~#[~;and `~A'~]~}~]~}"
+ offenders)
+ (report-inheritance-path state super)))))
+
+(export 'merge-class-lists)
+(defun merge-class-lists (class lists pick)
+ "Merge the LISTS of superclasses of CLASS, using PICK to break ties.
+
+ This is a convenience wrapper around the main `merge-lists' function.
+ Given that class linearizations (almost?) always specify a custom
+ tiebreaker function, this isn't a keyword argument.
+
+ If a merge error occurs, this function translates it into a rather more
+ useful form, and tries to provide helpful notes.
+
+ For error reporting purposes, it's assumed that each of the LISTS begins
+ with the class from which the corresponding constraint originates. This
+ initial class does double-duty: it is also considered to be part of the
+ list for the purpose of the merge."
+
+ (handler-case (merge-lists lists :pick pick)
+ (inconsistent-merge-error (error)
+ (report-class-list-merge-error class lists error)
+ (continue error))))
+
;;; Tiebreaker functions.
(defun clos-tiebreaker (candidates so-far)
direct subclass then that subclass's direct superclasses list must order
them relative to each other."
- (let (winner)
- (dolist (class so-far)
- (dolist (candidate candidates)
- (when (member candidate (sod-class-direct-superclasses class))
- (setf winner candidate))))
- (unless winner
- (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
- winner))
+ (dolist (class so-far)
+ (dolist (candidate candidates)
+ (when (member candidate (sod-class-direct-superclasses class))
+ (return-from clos-tiebreaker candidate))))
+ (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
(defun c3-tiebreaker (candidates cpls)
"The C3 linearization tiebreaker function.
(dolist (candidate candidates)
(when (member candidate cpl)
(return-from c3-tiebreaker candidate))))
- (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
+ (error "SOD INTERNAL ERROR: Failed to break tie in C3"))
;;; Linearization functions.
(remove-duplicates (cons class
(mappend #'superclasses
direct-supers))))))
- (merge-lists (mapcar (lambda (class)
- (cons class
- (sod-class-direct-superclasses class)))
- (superclasses class))
- :pick #'clos-tiebreaker)))
+ (merge-class-lists class
+ (mapcar (lambda (c)
+ (cons c (sod-class-direct-superclasses c)))
+ (superclasses class))
+ #'clos-tiebreaker)))
(export 'dylan-cpl)
(defun dylan-cpl (class)
assuming that the superclass CPLs are already monotonic. If they aren't,
you're going to lose anyway."
- (let ((direct-supers (sod-class-direct-superclasses class)))
- (merge-lists (cons (cons class direct-supers)
- (mapcar #'sod-class-precedence-list direct-supers))
- :pick #'clos-tiebreaker)))
+ (let* ((direct-supers (sod-class-direct-superclasses class))
+ (cpls (mapcar #'sod-class-precedence-list direct-supers)))
+ (merge-class-lists class
+ (cons (cons class direct-supers) cpls)
+ #'clos-tiebreaker)))
(export 'c3-cpl)
(defun c3-cpl (class)
(let* ((direct-supers (sod-class-direct-superclasses class))
(cpls (mapcar #'sod-class-precedence-list direct-supers)))
- (merge-lists (cons (cons class direct-supers) cpls)
- :pick (lambda (candidates so-far)
+ (merge-class-lists class
+ (cons (cons class direct-supers) cpls)
+ (lambda (candidates so-far)
(declare (ignore so-far))
(c3-tiebreaker candidates cpls)))))
precedence order i.e., the direct-superclasses list orderings."
(let ((dfs (flavors-cpl class)))
- (cons class (merge-lists (mapcar #'sod-class-precedence-list
+ (cons class
+ (merge-class-lists class
+ (mapcar #'sod-class-precedence-list
(sod-class-direct-superclasses class))
- :pick (lambda (candidates so-far)
- (declare (ignore so-far))
- (dolist (class dfs)
- (when (member class candidates)
- (return class))))))))
+ (lambda (candidates so-far)
+ (declare (ignore so-far))
+ (dolist (class dfs)
+ (when (member class candidates)
+ (return class))))))))
;;; Default function.
(defmethod compute-cpl ((class sod-class))
- (handler-case (c3-cpl class)
- (inconsistent-merge-error ()
- (error "Failed to compute class precedence list for `~A'"
- (sod-class-name class)))))
+ (c3-cpl class))
;;;--------------------------------------------------------------------------
;;; Chains.
class))
(chain (cons class (and chain-link
(sod-class-chain chain-link))))
+ (state (make-inheritance-path-reporter-state class))
(table (make-hash-table)))
;; Check the chains. We work through each superclass, maintaining a
;; we've found an error. By the end of all of this, the classes
;; which don't have an entry are the chain tails.
(dolist (super class-precedence-list)
- (let ((link (sod-class-chain-link super)))
- (when link
- (when (gethash link table)
- (error "Conflicting chains in class ~A: ~
- (~A and ~A both link to ~A)"
- class super (gethash link table) link))
- (setf (gethash link table) super))))
+ (let* ((link (sod-class-chain-link super))
+ (found (and link (gethash link table))))
+ (cond ((not found) (setf (gethash link table) super))
+ (t
+ (cerror* "Conflicting chains in class `~A': ~
+ (`~A' and `~A' both link to `~A')"
+ class super found link)
+ (report-inheritance-path state super)
+ (report-inheritance-path state found)))))
;; Done.
(values head chain
;;;--------------------------------------------------------------------------
;;; Metaclasses.
-(defun maximum (items order what)
- "Return a maximum item according to the non-strict partial ORDER."
- (reduce (lambda (best this)
- (cond ((funcall order best this) best)
- ((funcall order this best) this)
- (t (error "Unable to choose best ~A." what))))
- items))
-
(defmethod guess-metaclass ((class sod-class))
"Default metaclass-guessing function for classes.
;; metaclasses resolved yet. If we find this, then throw `bootstrapping'
;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
;; across the bows of anyone else who calls us).
- (maximum (mapcar (lambda (super)
- (if (slot-boundp super 'metaclass)
- (slot-value super 'metaclass)
- (throw 'bootstrapping nil)))
- (sod-class-direct-superclasses class))
- #'sod-subclass-p
- (format nil "metaclass for `~A'" class)))
+ (finalization-error (:bad-metaclass)
+ (select-minimal-class-property (sod-class-direct-superclasses class)
+ (lambda (super)
+ (if (slot-boundp super 'metaclass)
+ (slot-value super 'metaclass)
+ (throw 'bootstrapping nil)))
+ #'sod-subclass-p class "metaclass")))
;;;--------------------------------------------------------------------------
;;; Sanity checking.
(with-default-error-location (class)
;; Check the names of things are valid.
- (with-slots (name nickname messages) class
- (unless (valid-name-p name)
- (error "Invalid class name `~A'" class))
- (unless (valid-name-p nickname)
- (error "Invalid class nickname `~A' on class `~A'" nickname class))
- (dolist (message messages)
- (unless (valid-name-p (sod-message-name message))
- (error "Invalid message name `~A' on class `~A'"
- (sod-message-name message) class))))
-
- ;; Check that the slots and messages have distinct names.
- (with-slots (slots messages class-precedence-list) class
- (flet ((check-list (list what namefunc)
- (let ((table (make-hash-table :test #'equal)))
+ (flet ((check-list (list what namefunc)
+ (dolist (item list)
+ (let ((name (funcall namefunc item)))
+ (unless (valid-name-p name)
+ (cerror*-with-location item
+ "Invalid ~A name `~A' ~
+ in class `~A'"
+ what name class))))))
+ (unless (valid-name-p (sod-class-name class))
+ (cerror* "Invalid class name `~A'" class))
+ (unless (valid-name-p (sod-class-nickname class))
+ (cerror* "Invalid class nickname `~A' for class `~A'"
+ (sod-class-nickname class) class))
+ (check-list (sod-class-messages class) "message" #'sod-message-name)
+ (check-list (sod-class-slots class) "slot" #'sod-slot-name))
+
+ ;; Check that the class doesn't define conflicting things.
+ (labels ((check-list (list keyfunc complain)
+ (let ((seen (make-hash-table :test #'equal)))
(dolist (item list)
- (let ((name (funcall namefunc item)))
- (if (gethash name table)
- (error "Duplicate ~A name `~A' on class `~A'"
- what name class)
- (setf (gethash name table) item)))))))
- (check-list slots "slot" #'sod-slot-name)
- (check-list messages "message" #'sod-message-name)
- (check-list class-precedence-list "nickname" #'sod-class-name)))
+ (let* ((key (funcall keyfunc item))
+ (found (gethash key seen)))
+ (if found (funcall complain item found)
+ (setf (gethash key seen) item))))))
+ (simple-previous (previous)
+ (info-with-location previous "Previous definition was here"))
+ (simple-complain (what namefunc)
+ (lambda (item previous)
+ (cerror*-with-location item
+ "Duplicate ~A `~A' in class `~A'"
+ what (funcall namefunc item) class)
+ (simple-previous previous))))
+
+ ;; Make sure direct slots have distinct names.
+ (check-list (sod-class-slots class) #'sod-slot-name
+ (simple-complain "slot name" #'sod-slot-name))
+
+ ;; Make sure there's at most one initializer for each slot.
+ (flet ((check-initializer-list (list kind)
+ (check-list list #'sod-initializer-slot
+ (lambda (initializer previous)
+ (let ((slot
+ (sod-initializer-slot initializer)))
+ (cerror*-with-location initializer
+ "Duplicate ~
+ initializer for ~
+ ~A slot `~A' ~
+ in class `~A'"
+ kind slot class)
+ (simple-previous previous))))))
+ (check-initializer-list (sod-class-instance-initializers class)
+ "instance")
+ (check-initializer-list (sod-class-class-initializers class)
+ "class"))
+
+ ;; Make sure messages have distinct names.
+ (check-list (sod-class-messages class) #'sod-message-name
+ (simple-complain "message name" #'sod-message-name))
+
+ ;; Make sure methods are sufficiently distinct.
+ (check-list (sod-class-methods class) #'sod-method-function-name
+ (lambda (method previous)
+ (cerror*-with-location method
+ "Duplicate ~A direct method ~
+ for message `~A' ~
+ in classs `~A'"
+ (sod-method-description method)
+ (sod-method-message method)
+ class)
+ (simple-previous previous)))
+
+ ;; Make sure superclasses have distinct nicknames.
+ (let ((state (make-inheritance-path-reporter-state class)))
+ (check-list (sod-class-precedence-list class) #'sod-class-nickname
+ (lambda (super previous)
+ (cerror*-with-location class
+ "Duplicate nickname `~A' ~
+ in superclasses of `~A': ~
+ used by `~A' and `~A'"
+ (sod-class-nickname super)
+ class super previous)
+ (report-inheritance-path state super)
+ (report-inheritance-path state previous)))))
;; Check that the CHAIN-TO class is actually a proper superclass. (This
;; eliminates hairy things like a class being its own link.)
- (with-slots (class-precedence-list chain-link) class
- (unless (or (not chain-link)
- (member chain-link (cdr class-precedence-list)))
- (error "In `~A~, chain-to class `~A' is not a proper superclass"
- class chain-link)))
+ (let ((link (sod-class-chain-link class)))
+ (unless (or (not link)
+ (member link (cdr (sod-class-precedence-list class))))
+ (cerror* "In `~A~, chain-to class `~A' is not a proper superclass"
+ class link)))
;; Check that the initargs declare compatible types. Duplicate entries,
;; even within a class, are harmless, but at most one initarg in any
;; class should declare a default value.
- (with-slots (class-precedence-list) class
- (let ((seen (make-hash-table :test #'equal)))
- (dolist (super class-precedence-list)
- (with-slots (initargs) super
- (dolist (initarg (reverse initargs))
- (let* ((initarg-name (sod-initarg-name initarg))
- (initarg-type (sod-initarg-type initarg))
- (initarg-default (sod-initarg-default initarg))
- (found (gethash initarg-name seen))
- (found-type (and found (sod-initarg-type found)))
- (found-default (and found (sod-initarg-default found)))
- (found-class (and found (sod-initarg-class found)))
- (found-location (and found (file-location found))))
- (with-default-error-location (initarg)
- (cond ((not found)
- (setf (gethash initarg-name seen) initarg))
- ((not (c-type-equal-p initarg-type found-type))
- (cerror* "Inititalization argument `~A' defined ~
- with incompatible types: ~
- ~A in class ~A, and ~
- ~A in class ~A (at ~A)"
- initarg-name initarg-type super
- found-type found-class found-location))
- ((and initarg-default found-default
- (eql super found-class))
- (cerror* "Initialization argument `~A' redefined ~
- with default value ~
- (previous definition at ~A)"
- initarg-name found-location))
- (initarg-default
- (setf (gethash initarg-name seen) initarg))))))))))
+ (let ((seen (make-hash-table :test #'equal))
+ (state (make-inheritance-path-reporter-state class)))
+ (dolist (super (sod-class-precedence-list class))
+ (dolist (initarg (reverse (sod-class-initargs super)))
+ (let* ((initarg-name (sod-initarg-name initarg))
+ (initarg-type (sod-initarg-type initarg))
+ (initarg-default (sod-initarg-default initarg))
+ (found (gethash initarg-name seen))
+ (found-type (and found (sod-initarg-type found)))
+ (found-default (and found (sod-initarg-default found)))
+ (found-class (and found (sod-initarg-class found)))
+ (found-location (and found (file-location found))))
+ (with-default-error-location (initarg)
+ (cond ((not found)
+ (setf (gethash initarg-name seen) initarg))
+ ((not (c-type-equal-p initarg-type found-type))
+ (cerror* "Inititalization argument `~A' defined ~
+ with incompatible types: ~
+ ~A in class `~A', but ~A in class `~A'"
+ initarg-name initarg-type super
+ found-type found-class found-location)
+ (report-inheritance-path state super))
+ ((and initarg-default found-default
+ (eql super found-class))
+ (cerror* "Initialization argument `~A' redefined ~
+ with default value"
+ initarg-name)
+ (info-with-location found-location
+ "Previous definition is here"))
+ (initarg-default
+ (setf (gethash initarg-name seen) initarg))))))))
;; Check for circularity in the superclass graph. Since the superclasses
;; should already be acyclic, it suffices to check that our class is not
(sod-subclass-p super class))
(sod-class-direct-superclasses class))))
(when circle
- (error "Circularity: ~A is already a superclass of ~A"
- class circle)))
+ (cerror* "`~A' is already a superclass of `~A'" class circle)
+ (report-inheritance-path (make-inheritance-path-reporter-state class)
+ circle)))
;; Check that the class has a unique root superclass.
(find-root-superclass class)
;; Check that the metaclass is a subclass of each direct superclass's
;; metaclass.
- (with-slots (metaclass direct-superclasses) class
- (dolist (super direct-superclasses)
- (unless (sod-subclass-p metaclass (sod-class-metaclass super))
- (error "Incompatible metaclass for `~A': ~
- `~A' isn't a subclass of `~A' (of `~A')"
- class metaclass (sod-class-metaclass super) super))))))
+ (finalization-error (:bad-metaclass)
+ (let ((meta (sod-class-metaclass class)))
+ (dolist (super (sod-class-direct-superclasses class))
+ (let ((supermeta (sod-class-metaclass super)))
+ (unless (sod-subclass-p meta supermeta)
+ (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'"
+ meta class supermeta)
+ (info-with-location super
+ "Direct superclass `~A' defined here ~
+ has metaclass `~A'"
+ super supermeta))))))))
;;;--------------------------------------------------------------------------
;;; Finalization.
-(defmethod finalize-sod-class ((class sod-class))
+(defmethod finalize-sod-class :around ((class sod-class))
+ "Common functionality for `finalize-sod-class'.
- ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
- ;; clone of the CPL and chain establishment code. If the interface changes
- ;; then `bootstrap-classes' will need to be changed too.
+ * If an attempt to finalize the CLASS has been made before, then we
+ don't try again. Similarly, attempts to finalize a class recursively
+ will fail.
+ * A condition handler is established to keep track of whether any errors
+ are signalled during finalization. The CLASS is only marked as
+ successfully finalized if no (unhandled) errors are encountered."
(with-default-error-location (class)
(ecase (sod-class-state class)
((nil)
- ;; If this fails, mark the class as a loss.
+ ;; If this fails, leave the class marked as a loss.
(setf (slot-value class 'state) :broken)
- ;; Set up the metaclass if it's not been set already. This is delayed
- ;; to give bootstrapping a chance to set up metaclass and superclass
- ;; circularities.
- (default-slot (class 'metaclass) (guess-metaclass class))
-
- ;; Finalize all of the superclasses. There's some special pleading
- ;; here to make bootstrapping work: we don't try to finalize the
- ;; metaclass if we're a root class (no direct superclasses -- because
- ;; in that case the metaclass will have to be a subclass of us!), or
- ;; if it's equal to us. This is enough to tie the knot at the top of
- ;; the class graph.
- (with-slots (name direct-superclasses metaclass) class
- (dolist (super direct-superclasses)
- (finalize-sod-class super))
- (unless (or (null direct-superclasses)
- (eq class metaclass))
- (finalize-sod-class metaclass)))
-
- ;; Stash the class's type.
- (setf (slot-value class '%type)
- (make-class-type (sod-class-name class)))
-
- ;; Clobber the lists of items if they've not been set.
- (dolist (slot '(slots instance-initializers class-initializers
- messages methods))
- (unless (slot-boundp class slot)
- (setf (slot-value class slot) nil)))
-
- ;; If the CPL hasn't been done yet, compute it.
- (with-slots (class-precedence-list) class
- (unless (slot-boundp class 'class-precedence-list)
- (setf class-precedence-list (compute-cpl class))))
-
- ;; Check that the class is fairly sane.
- (check-sod-class class)
-
- ;; Determine the class's layout.
- (with-slots (chain-head chain chains) class
- (setf (values chain-head chain chains) (compute-chains class)))
-
- ;; Done.
- (setf (slot-value class 'state) :finalized)
- t)
-
+ ;; Invoke the finalization method proper. If it signals any
+ ;; continuable errors, take note of them so that we can report failure
+ ;; properly.
+ ;;
+ ;; Catch: we get called recursively to clean up superclasses and
+ ;; metaclasses, but there should only be one such handler, so don't
+ ;; add another. (In turn, this means that other methods mustn't
+ ;; actually trap their significant errors.)
+ (let ((have-handler-p (boundp '*finalization-errors*))
+ (*finalization-errors* nil)
+ (*finalization-error-token* nil))
+ (catch '%finalization-failed
+ (if have-handler-p (call-next-method)
+ (handler-bind ((error (lambda (cond)
+ (declare (ignore cond))
+ (pushnew *finalization-error-token*
+ *finalization-errors*
+ :test #'equal)
+ :decline)))
+ (call-next-method)))
+ (when *finalization-errors* (finalization-failed))
+ (setf (slot-value class 'state) :finalized)
+ t)))
+
+ ;; If the class is broken, we're not going to be able to fix it now.
(:broken
nil)
+ ;; If we already finalized it, there's no point doing it again.
(:finalized
t))))
-(flet ((check-class-is-finalized (class)
- (unless (eq (sod-class-state class) :finalized)
- (error "Class ~S is not finalized" class))))
- (macrolet ((define-layout-slot (slot (class) &body body)
- `(define-on-demand-slot sod-class ,slot (,class)
- (check-class-is-finalized ,class)
- ,@body)))
- (define-layout-slot %ilayout (class)
- (compute-ilayout class))
- (define-layout-slot effective-methods (class)
- (compute-effective-methods class))
- (define-layout-slot vtables (class)
- (compute-vtables class))))
+(defmethod finalize-sod-class ((class sod-class))
+
+ ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief)
+ ;; clone of the CPL and chain establishment code. If the interface changes
+ ;; then `bootstrap-classes' will need to be changed too.
+
+ ;; Set up the metaclass if it's not been set already. This is delayed
+ ;; to give bootstrapping a chance to set up metaclass and superclass
+ ;; circularities.
+ (default-slot (class 'metaclass) (guess-metaclass class))
+
+ ;; Finalize all of the superclasses. There's some special pleading here to
+ ;; make bootstrapping work: we don't try to finalize the metaclass if we're
+ ;; a root class (no direct superclasses -- because in that case the
+ ;; metaclass will have to be a subclass of us!), or if it's equal to us.
+ ;; This is enough to tie the knot at the top of the class graph. If we
+ ;; can't manage this then we're doomed.
+ (flet ((try-finalizing (what other-class)
+ (unless (finalize-sod-class other-class)
+ (cerror* "Class `~A' has broken ~A `~A'" class what other-class)
+ (info-with-location other-class
+ "Class `~A' defined here" other-class)
+ (finalization-failed))))
+ (let ((supers (sod-class-direct-superclasses class))
+ (meta (sod-class-metaclass class)))
+ (dolist (super supers)
+ (try-finalizing "direct superclass" super))
+ (unless (or (null supers) (eq class meta))
+ (try-finalizing "metaclass" meta))))
+
+ ;; Stash the class's type.
+ (setf (slot-value class '%type)
+ (make-class-type (sod-class-name class)))
+
+ ;; Clobber the lists of items if they've not been set.
+ (dolist (slot '(slots instance-initializers class-initializers
+ messages methods))
+ (unless (slot-boundp class slot)
+ (setf (slot-value class slot) nil)))
+
+ ;; If the CPL hasn't been done yet, compute it. If we can't manage this
+ ;; then there's no hope at all.
+ (unless (slot-boundp class 'class-precedence-list)
+ (restart-case
+ (setf (slot-value class 'class-precedence-list) (compute-cpl class))
+ (continue () :report "Continue"
+ (finalization-failed))))
+
+ ;; Check that the class is fairly sane.
+ (check-sod-class class)
+
+ ;; Determine the class's layout.
+ (setf (values (slot-value class 'chain-head)
+ (slot-value class 'chain)
+ (slot-value class 'chains))
+ (compute-chains class)))
;;;----- That's all, folks --------------------------------------------------
(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
+;;; Finalization error handling.
+
+;; These variables are internal to the implementation.
+(defvar-unbound *finalization-errors*
+ "A list of tokens for errors reported about the class being finalized.
+
+ During finalization, this is bound to a list of tokens corresponding to
+ the problems which have been reported so far via `finalization-error'.")
+(defvar-unbound *finalization-error-token*
+ "The token to store in `*finalization-errors*' in the event of an error.")
+
+(export 'finalization-error)
+(defmacro finalization-error ((token &rest args) &body body)
+ "Check for a kind of finalization error denoted by TOKEN and the ARGS.
+
+ The TOKEN and ARGS are convered into an error token as follows. If no
+ ARGS are given, then the TOKEN itself is evaluated and used directly;
+ otherwise, the token is a list whose first element is the result of
+ evaluating TOKEN, and the remaining elements are the results of evaluating
+ the ARGS. Error tokens are compared with `equal'.
+
+ If a finalization error denoted by this token has already been reported,
+ then do nothing: the BODY is not evaluated, and the result is nil.
+ Special exception: a nil token denotes a `generic' error which can be
+ repeated indefintely.
+
+ If the BODY signals an error (and doesn't handle it), then the error token
+ is added to a list of reported errors. That way, future calls to
+ `finalization-error' with an equal error token won't cause the user to be
+ inundated with duplicate reports."
+ `(let ((*finalization-error-token* ,(if (null args) token
+ `(list ,token ,@args))))
+ ,@body))
+
+(export 'finalization-failed)
+(defun finalization-failed ()
+ "Give up on finalizing the current class."
+ (throw '%finalization-failed nil))
+
+;;;--------------------------------------------------------------------------
;;; Protocol definition.
(export 'compute-cpl)
* The chosen metaclass is actually a subclass of all of the
superclasses' metaclasses.
- Returns true if all is well; false (and signals errors) if anything was
- wrong."))
+ If no attempt has previously been made to finalize the class, then errors
+ are signalled for the problems found. If finalizing it has been tried
+ before and failed (or this is a recursive attempt to finalize the class)
+ then nil is returned immediately. Otherwise a non-nil value is
+ returned."))
(export 'finalize-sod-class)
(defgeneric finalize-sod-class (class)
* The class is checked for compiance with the well-formedness rules.
- * The layout chains are computed."))
+ * The layout chains are computed.
+
+ Returns a generalized boolean: non-nil if the class has been successfully
+ finalized -- either just now, or if it was finalized already and nothing
+ needed to be done -- or nil if finalization failed -- either just now, or
+ because the class had previously been marked as broken following a failed
+ finalization attempt.
+
+ User methods can assume that the class in question has not yet been
+ finalized. Errors during finalization can be reported in the usual way.
+ See also `finalization-error' and `finalization-failed' above."))
;;;----- That's all, folks --------------------------------------------------
(compute-vtable class (reverse chain)))
(sod-class-chains class)))
+;;;--------------------------------------------------------------------------
+;;; Layout interface.
+
+;; Just arrange to populate the necessary slots on demand.
+(flet ((check-class-is-finalized (class)
+ (unless (eq (sod-class-state class) :finalized)
+ (error "Class ~S is not finalized" class))))
+ (macrolet ((define-layout-slot (slot (class) &body body)
+ `(define-on-demand-slot sod-class ,slot (,class)
+ (check-class-is-finalized ,class)
+ ,@body)))
+ (define-layout-slot %ilayout (class)
+ (compute-ilayout class))
+ (define-layout-slot effective-methods (class)
+ (compute-effective-methods class))
+ (define-layout-slot vtables (class)
+ (compute-vtables class))))
+
;;;----- 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
(with-default-error-location (location)
(let* ((pset (property-set pset))
(best-class (or (get-property pset :lisp-metaclass :symbol nil)
- (if superclasses
- (maximum (mapcar #'class-of superclasses)
- #'subtypep
- (format nil "Lisp metaclass for ~A"
- name))
- 'sod-class)))
+ (select-minimal-class-property
+ superclasses #'class-of #'subtypep 'sod-class
+ "Lisp metaclass"
+ :present (lambda (class)
+ (format nil "`~S'"
+ (class-name class)))
+ :allow-empty t)))
(class (make-instance best-class
:name name
:superclasses superclasses
message-name #'sod-message-name))))
;;;--------------------------------------------------------------------------
+;;; Describing class inheritance paths in diagnostics.
+
+(export 'inheritance-path-reporter-state)
+(defclass inheritance-path-reporter-state ()
+ ((%class :type sod-class :initarg :class)
+ (paths :type list :initarg :paths)
+ (seen :type hash-table :initform (make-hash-table))))
+
+(export 'make-inheritance-path-reporter-state)
+(defun make-inheritance-path-reporter-state (class)
+ (make-instance 'inheritance-path-reporter-state :class class))
+
+(export 'report-inheritance-path)
+(defun report-inheritance-path (state super)
+ "Issue informational messages showing how CLASS inherits from SUPER."
+ (with-slots (paths (class %class) include-boundary seen) state
+ (unless (slot-boundp state 'paths)
+ (setf paths (distinguished-point-shortest-paths
+ class
+ (lambda (c)
+ (mapcar (lambda (super) (cons super 1))
+ (sod-class-direct-superclasses c))))))
+ (dolist (hop (mapcon (lambda (subpath)
+ (let ((super (car subpath))
+ (sub (and (cdr subpath)
+ (cadr subpath))))
+ (if (or (not sub) (gethash super seen))
+ nil
+ (progn
+ (setf (gethash super seen) t)
+ (list (cons super sub))))))
+ (cdr (find super paths :key #'cadr))))
+ (let ((super (car hop))
+ (sub (cdr hop)))
+ (info-with-location sub
+ "Class `~A' is a direct superclass ~
+ of `~A', defined here"
+ super sub)))))
+
+;;;--------------------------------------------------------------------------
+;;; Metaclass inference.
+
+(export 'select-minimal-class-property)
+(defun select-minimal-class-property (supers key order default what
+ &key (present (lambda (x)
+ (format nil "`~A'" x)))
+ allow-empty)
+ "Return the minimal partially-ordered key from the SUPERS.
+
+ KEY is a function of one argument which returns some interesting property
+ of a class. The keys are assumed to be partially ordered by ORDER, a
+ function of two arguments which returns non-nil if its first argument
+ precedes its second. If there is a unique minimal key then return it;
+ otherwise report a useful error and pick some candidate in an arbitrary
+ way; the DEFAULT may be chosen if no better choices are available. If
+ ALLOW-EMPTY is non-nil, then no error is reported if there are no SUPERS,
+ and the DEFAULT choice is returned immediately.
+
+ In an error message, the keys are described as WHAT, which should be a
+ noun phrase; keys are filtered through PRESENT, a function of one
+ argument, before presentation.
+
+ The function returns two values: the chosen value, and a flag which is
+ non-nil if it was chosen without errors."
+
+ (let ((candidates (partial-order-minima (mapcar key supers) order)))
+ (cond ((and (null candidates) allow-empty)
+ (values default t))
+ ((and candidates (null (cdr candidates)))
+ (values (car candidates) t))
+ (t
+ (cerror* "No obvious choice for implicit ~A: ~
+ ~{~#[root classes must specify explicitly~:;~
+ candidates are ~
+ ~#[~;~A~;~A and ~A~:;~@{~A, ~#[~;and ~A~]~}~]~]~:}"
+ what (mapcar present candidates))
+ (dolist (candidate candidates)
+ (let ((super (find candidate supers :key key)))
+ (info-with-location super
+ "Direct superclass `~A' defined here ~
+ has ~A ~A"
+ super what (funcall present candidate))))
+ (values (if candidates (car candidates) default) nil)))))
+
+;;;--------------------------------------------------------------------------
;;; Miscellaneous useful functions.
(export 'sod-subclass-p)
* all of whose characters are alphanumeric or underscores
* and which doesn't contain two consecutive underscores."
- (and (stringp name)
- (plusp (length name))
- (alpha-char-p (char name 0))
- (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
- (not (search "__" name))))
+ (or (typep name 'temporary-variable)
+ (and (stringp name)
+ (plusp (length name))
+ (alpha-char-p (char name 0))
+ (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
+ (not (search "__" name)))))
(export 'find-root-superclass)
(defun find-root-superclass (class)
(sod-class-chains super)))
supers)))
(list class))))
- (cond ((null roots) (error "Class ~A has no root class!" class))
- ((cdr roots) (error "Class ~A has multiple root classes ~
- ~{~A~#[~; and ~;, ~]~}"
- class roots))
+ (cond ((null roots)
+ (error "Class ~A has no root class!" class))
+ ((cdr roots)
+ (cerror* "Class ~A has multiple root classes ~
+ ~{~#[~;~A~;~A and ~A~:; ~@{~A, ~#[~;and ~A~]~}~]~}"
+ class roots)
+ (let ((state (make-inheritance-path-reporter-state class)))
+ (dolist (root roots)
+ (report-inheritance-path state root))))
(t (car roots)))))
(export 'find-root-metaclass)
(setf (codegen-vars codegen)
(cons (make-var-inst name type init) vars)))
((not (c-type-equal-p type (inst-type var)))
- (error "(Internal) Redefining type for variable ~A." name)))
+ (error "(Internal) Redefining type for variable ~A" name)))
name))
(export 'codegen)
(defvar *debugout-pathname* #p"debugout.c")
(export 'test-module)
-(defun test-module (path reason)
- "Reset the translator's state, read a module from PATH and output it with
- REASON, returning the result as a string."
- (clear-the-decks)
- (setf *module-map* (make-hash-table :test #'equal))
- (with-open-file (out *debugout-pathname*
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (output-module (read-module path) reason out)))
+(defun test-module (path &key reason clear backtrace)
+ "Read a module from PATH, to exercise the machinery.
+
+ If CLEAR is non-nil, then reset the translator's state before proceeding.
+
+ If REASON is non-nil, then output the module to `*debugout-pathname*' with
+ that REASON.
+
+ Return a two-element list (NERROR NWARNING) of the number of errors and
+ warnings encountered while processing the module."
+ (when clear (clear-the-decks))
+ (multiple-value-bind (module nerror nwarning)
+ (if backtrace (read-module path)
+ (count-and-report-errors () (read-module path)))
+ (when (and module reason)
+ (with-open-file (out *debugout-pathname*
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (output-module module reason out)))
+ (list nerror nwarning)))
(export 'test-parse-c-type)
(defun test-parse-c-type (string)
(values nil value)))))))
(export 'test-parser)
-(defmacro test-parser ((scanner &key) parser input)
+(defmacro test-parser ((scanner &key backtrace) parser input)
"Convenient macro for testing parsers at the REPL.
This is a macro so that the parser can use the fancy syntax. The name
SCANNER is bound to a `sod-token-scanner' reading tokens from the INPUT
- string. Then the PARSER is invoked and three values are returned: a
- `successp' flag indicating whether the parser succeeded; the result,
- output or error indicator, of the parser; and a list consisting of the
- lookahead token type and value, and a string containing the untokenized
- remaining input."
+ string. Then the PARSER is invoked and three values are returned: the
+ result of the parse, or `nil' if the main parse failed; a list containing
+ the number of errors and warnings (respectively) reported during the
+ parse; and a list consisting of the lookahead token type and value, and a
+ string containing the untokenized remaining input.
+
+ If BACKTRACE is nil (the default) then leave errors to the calling
+ environment to sort out (e.g., by entering the Lisp debugger); otherwise,
+ catch and report them as they happen so that you can test error recovery
+ strategies."
(once-only (input)
- (with-gensyms (char-scanner value winp consumedp where)
- `(let* ((,char-scanner (make-string-scanner ,input))
- (,scanner (make-instance 'sod-token-scanner
- :char-scanner ,char-scanner
- :filename "<test-input>")))
+ (with-gensyms (char-scanner value winp body consumedp where nerror nwarn)
+ `(let ((,char-scanner nil) (,scanner nil))
(with-parser-context (token-scanner-context :scanner ,scanner)
- (multiple-value-bind (,value ,winp ,consumedp) (parse ,parser)
- (declare (ignore ,consumedp))
+ (multiple-value-bind (,value ,nerror ,nwarn)
+ (flet ((,body ()
+ (setf ,char-scanner (make-string-scanner ,input)
+ ,scanner (make-instance
+ 'sod-token-scanner
+ :char-scanner ,char-scanner))
+ (with-default-error-location (,scanner)
+ (multiple-value-bind (,value ,winp ,consumedp)
+ (parse ,parser)
+ (declare (ignore ,consumedp))
+ (cond (,winp ,value)
+ (t (syntax-error ,scanner ,value)
+ nil))))))
+ (if ,backtrace (,body)
+ (count-and-report-errors ()
+ (,body))))
(let ((,where (scanner-capture-place ,char-scanner)))
- (values ,winp ,value
- (list (token-type ,scanner) (token-value ,scanner)
- (subseq ,input ,where))))))))))
+ (values ,value
+ (list ,nerror ,nwarn)
+ (and ,scanner (list (token-type ,scanner)
+ (token-value ,scanner)
+ (subseq ,input ,where)))))))))))
;;;--------------------------------------------------------------------------
;;; Calisthenics.
That's the theory anyway. Call this function before you dump an image and
see what happens."
- (clear-the-decks)
(dolist (reason '(:h :c))
(with-output-to-string (bitbucket)
(output-module *builtin-module* reason bitbucket)))
(clear-the-decks))
+;;;--------------------------------------------------------------------------
+;;; Make sure things work after loading the system.
+
+(clear-the-decks)
+
;;;----- That's all, folks --------------------------------------------------
takes into account comments (both C and C++ style), string and character
literals."
- (let ((char-scanner (token-scanner-char-scanner scanner))
- (delim nil)
- (stack nil))
+ (let* ((char-scanner (token-scanner-char-scanner scanner))
+ (delim-match nil) (delim-found nil) (delim-loc nil)
+ (stack nil) (start nil) (tokstart nil) (eofwhine t))
(with-parser-context (character-scanner-context :scanner char-scanner)
;; Hack. If the first character is a newline then discard it
(parse #\newline)
;; This seems the easiest way of gathering stuff.
+ (setf start (file-location char-scanner))
(with-scanner-place (place char-scanner)
- (flet ((push-delim (d)
- (push delim stack)
- (setf delim d))
+ (flet ((push-delim (found match)
+ (push (list delim-found delim-match delim-loc) stack)
+ (setf delim-found found
+ delim-match match
+ delim-loc tokstart))
+
+ (pop-delim ()
+ (destructuring-bind (found match loc) (pop stack)
+ (setf delim-found found
+ delim-match match
+ delim-loc loc)))
(result ()
(let* ((output (scanner-interval char-scanner place))
;; March through characters until we reach the end.
(loop
+ (setf tokstart (file-location char-scanner))
(cond-parse (:consumedp cp :expected exp)
;; Whitespace and comments are universally dull.
;; See if we've reached the end. We must leave the delimiter
;; in the scanner, so `if-char' and its various friends aren't
;; appropriate.
- ((lisp (if (and (null delim)
+ ((lisp (if (and (null delim-match)
+ (not (scanner-at-eof-p char-scanner))
(member (scanner-current-char char-scanner)
end-chars))
(values (result) t t)
(values end-chars nil nil)))
(return (values it t t)))
(:eof
- (lexer-error char-scanner '(:any) cp)
+ (when eofwhine
+ (lexer-error char-scanner nil))
+ (loop
+ (unless delim-found (return))
+ (info-with-location delim-loc
+ "Unmatched `~C' found here" delim-found)
+ (pop-delim))
+ (info-with-location start "C fragment started here")
(return (values (result) t t)))
;; Opening and closing brackets. Opening brackets push things
- ;; onto a stack; closing brackets pop things off again.
- (#\( (push-delim #\)))
- (#\[ (push-delim #\]))
- (#\{ (push-delim #\}))
- ((or #\) #\] #\})
- (if (eql it delim)
- (setf delim (pop stack))
- (cerror* "Unmatched `~C.'." it)))
+ ;; onto a stack; closing brackets pop things off again. Pop a
+ ;; bracket even if it doesn't match, to encourage progress
+ ;; towards finding an end-delimiter.
+ (#\( (push-delim #\( #\)))
+ (#\[ (push-delim #\[ #\]))
+ (#\{ (push-delim #\{ #\}))
+ ((lisp (let ((char (scanner-current-char char-scanner)))
+ (case char
+ ((#\) #\] #\})
+ (unless (eql char delim-match)
+ (lexer-error char-scanner
+ (and delim-match
+ (list delim-match)))
+ (when delim-loc
+ (info-with-location
+ delim-loc
+ "Mismatched `~C' found here" delim-found)))
+ (scanner-step char-scanner)
+ (when delim-match (pop-delim))
+ (values char t t))
+ (t
+ (values '(#\) #\] #\}) nil nil))))))
;; String and character literals.
((seq ((quote (or #\" #\'))
(nil (skip-many ()
- (or (and #\\ :any) (not quote))))
- (nil (char quote)))))
+ (or (and #\\ :any) (not quote))))
+ (nil (or (char quote)
+ (seq (:eof)
+ (lexer-error char-scanner (list quote))
+ (info-with-location tokstart
+ "Literal started here")
+ (setf eofwhine nil)))))))
;; Anything else.
(:any)
;; This really shouldn't be able to happen.
(t
(assert cp)
- (lexer-error char-scanner exp cp)))))))))
+ (when (scanner-at-eof-p char-scanner)
+ (setf eofwhine nil))
+ (lexer-error char-scanner exp)))))))))
(export 'parse-delimited-fragment)
(defun parse-delimited-fragment (scanner begin end &key keep-end)
(if (if (eq begin t)
(not (scanner-at-eof-p scanner))
(eql (token-type scanner) begin))
- (multiple-value-prog1 (values (scan-c-fragment scanner
- (if (listp end)
- end
- (list end)))
- t t)
+ (multiple-value-prog1
+ (values (scan-c-fragment scanner
+ (if (listp end) end
+ (list end)))
+ t
+ t)
(scanner-step scanner)
(unless keep-end (scanner-step scanner)))
(values (list begin) nil nil)))
;;;--------------------------------------------------------------------------
;;; Indicators and error messages.
-(defun show-char (stream char &optional colonp atsignp)
- "Format CHAR to STREAM in a readable way.
-
- Usable in `format''s ~/.../ command."
- (declare (ignore colonp atsignp))
- (cond ((null char) (write-string "<eof>" stream))
+(defun show-char (char)
+ "Format CHAR as a string in a readable way."
+ (cond ((null char) "<end-of-file>")
((and (graphic-char-p char) (char/= char #\space))
- (format stream "`~C'" char))
- (t (format stream "<~(~:C~)>" char))))
+ (format nil "`~C'" char))
+ (t (format nil "<~(~:C~)>" char))))
-(defun skip-until (scanner token-types &key keep-end)
+(defun %skip-until (scanner token-types
+ &key (keep-end (not (null (cdr token-types)))))
"This is the implementation of the `skip-until' parser."
(do ((consumedp nil t))
- ((member (token-type scanner) token-types)
+ ((let ((type (token-type scanner))
+ (value (token-value scanner)))
+ (some (lambda (spec)
+ (multiple-value-bind (want-type want-value)
+ (cond ((listp spec) (values (car spec) (cadr spec)))
+ (t (values spec t)))
+ (and (eq want-type type)
+ (or (eq want-value t)
+ (equal want-value value)))))
+ token-types))
(unless keep-end (scanner-step scanner))
(values nil t (or keep-end consumedp)))
(when (scanner-at-eof-p scanner)
(return (values token-types nil consumedp)))
(scanner-step scanner)))
-(defun parse-error-recover (scanner parser recover &key ignore-unconsumed)
+(defun parse-error-recover (scanner parser recover
+ &key ignore-unconsumed force-progress action)
"This is the implementation of the `error' parser."
(multiple-value-bind (result win consumedp) (funcall parser)
(cond ((or win
;; current token. Finally, if we are at EOF then our best bet is
;; simply to propagate the current failure back to the caller, but
;; we handled that case above.
- (syntax-error scanner result :continuep t)
- (unless consumedp (scanner-step scanner))
+ (syntax-error scanner result)
+ (when action (funcall action))
+ (when (and force-progress (not consumedp)) (scanner-step scanner))
(funcall recover)))))
;;;--------------------------------------------------------------------------
(parse (many (acc init (+ (* acc radix) it) :min min)
(label (list :digit radix)
(filter (lambda (ch)
- (digit-char-p ch radix))))))))
+ (digit-char-p ch radix)))))))
+ (start-floc ()
+ ;; This is a little nasty. We scan the first token during
+ ;; instance initialization, as a result of `shared-initialize'
+ ;; on `token-scanner'. Unfortunately, this happens before
+ ;; we've had a chance to initialize our own `filename' slot.
+ ;; This means that we can't use the SCANNER as a file
+ ;; location, however tempting it might be. So we have this
+ ;; hack.
+ (make-file-location (scanner-filename char-scanner)
+ (scanner-line scanner)
+ (scanner-column scanner))))
;; Skip initial junk, and remember the place.
(loop
(cond-parse (:consumedp cp :expected exp)
((satisfies whitespace-char-p) (parse :whitespace))
((scan-comment char-scanner))
- (t (if cp (lexer-error char-scanner exp cp) (return)))))
+ (t (if cp (lexer-error char-scanner exp) (return)))))
;; Now parse something.
(cond-parse (:consumedp cp :expected exp)
(progn (write-char it out) out)
:final (get-output-stream-string out))
(or (and #\\ :any) (not quote))))
- (nil (char quote)))
+ (nil (or (char quote)
+ (seq (:eof)
+ (lexer-error char-scanner (list quote))
+ (info-with-location
+ (start-floc) "Literal started here")))))
(ecase quote
(#\" contents)
(#\' (case (length contents)
(1 (char contents 0))
- (0 (cerror* "Empty character literal") #\?)
- (t (cerror* "Too many characters in literal")
+ (0 (cerror*-with-location (start-floc)
+ 'simple-lexer-error
+ :format-control
+ "Empty character literal")
+ #\?)
+ (t (cerror*-with-location (start-floc)
+ 'simple-lexer-error
+ :format-control
+ "Too many characters ~
+ in character literal")
(char contents 0))))))
(values (etypecase it
(character :char)
;; must make progress on every call.
(t
(assert cp)
- (lexer-error char-scanner exp cp)
+ (lexer-error char-scanner exp)
(scanner-token scanner)))))))
;;;----- That's all, folks --------------------------------------------------
indicator)
(export 'syntax-error)
-(defun syntax-error (scanner expected &key (continuep t))
+(define-condition syntax-error (parser-error base-syntax-error)
+ ((found :type cons))
+ (:report (lambda (error stream)
+ (labels ((show-token (type value)
+ (if (characterp type) (show-char type)
+ (case type
+ (:id (format nil "<identifier~@[ `~A'~]>"
+ value))
+ (:int "<integer-literal>")
+ (:string "<string-literal>")
+ (:char "<character-literal>")
+ (:eof "<end-of-file>")
+ (:ellipsis "`...'")
+ (t (format nil "<? ~S~@[ ~S~]>" type value)))))
+ (show-expected (thing)
+ (acond ((gethash thing *indicator-map*) it)
+ ((atom thing) (show-token thing nil))
+ ((eq (car thing) :id)
+ (format nil "`~A'" (cadr thing)))
+ (t (format nil "<? ~S>" thing)))))
+ (report-parser-error error stream
+ #'show-expected
+ (lambda (found)
+ (show-token (car found)
+ (cdr found))))))))
+(defun syntax-error (scanner expected &key (continuep t) location)
"Signal a (maybe) continuable syntax error."
- (labels ((show-token (type value)
- (if (characterp type)
- (format nil "~/sod::show-char/" type)
- (case type
- (:id (format nil "<identifier~@[ `~A'~]>" value))
- (:int "<integer-literal>")
- (:string "<string-literal>")
- (:char "<character-literal>")
- (:eof "<end-of-file>")
- (:ellipsis "`...'")
- (t (format nil "<? ~S~@[ ~S~]>" type value)))))
- (show-expected (thing)
- (acond ((gethash thing *indicator-map*) it)
- ((atom thing) (show-token thing nil))
- ((eq (car thing) :id)
- (format nil "`~A'" (cadr thing)))
- (t (format nil "<? ~S>" thing)))))
- (funcall (if continuep #'cerror* #'error)
- "Syntax error: ~
- expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
- but found ~A"
- (mapcar #'show-expected expected)
- (show-token (token-type scanner) (token-value scanner)))))
+ (funcall (if continuep #'cerror*-with-location #'error-with-location)
+ (or location scanner) 'syntax-error
+ :expected expected
+ :found (cons (token-type scanner) (token-value scanner))))
(export 'lexer-error)
-(defun lexer-error (char-scanner expected consumedp)
+(define-condition lexer-error (parser-error base-lexer-error)
+ ((found :type (or character nil)))
+ (:report (lambda (error stream)
+ (flet ((show-expected (exp)
+ (typecase exp
+ (character (show-char exp))
+ (string (format nil "`~A'" exp))
+ ((cons (eql :digit) *)
+ (format nil "<radix-~A digit>" (cadr exp)))
+ ((eql :eof) "<end-of-file>")
+ ((eql :any) "<character>")
+ (t (format nil "<? ~S>" exp)))))
+ (report-parser-error error stream
+ #'show-expected #'show-char)))))
+(defun lexer-error (char-scanner expected &key location)
"Signal a continuable lexical error."
- (cerror* "Lexical error: ~
- expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
- but found ~/sod::show-char/~
- ~@[ at ~A~]"
- (mapcar (lambda (exp)
- (typecase exp
- (character (format nil "~/sod::show-char/" exp))
- (string (format nil "`~A'" exp))
- ((cons (eql :digit) *) (format nil "<radix-~A digit>"
- (cadr exp)))
- ((eql :eof) "<end-of-file>")
- ((eql :any) "<character>")
- (t (format nil "<? ~S>" exp))))
- expected)
- (and (not (scanner-at-eof-p char-scanner))
- (scanner-current-char char-scanner))
- (and consumedp (file-location char-scanner))))
+ (cerror*-with-location (or location char-scanner) 'lexer-error
+ :expected expected
+ :found (and (not (scanner-at-eof-p char-scanner))
+ (scanner-current-char char-scanner))))
(export 'skip-until)
(defparse skip-until (:context (context token-scanner-context)
&rest token-types)
"Discard tokens until we find one listed in TOKEN-TYPES.
+ Each of the TOKEN-TYPES is an expression which evaluates to either a
+ two-item list (TYPE VALUE), or a singleton TYPE; the latter is equivalent
+ to a list (TYPE t). Such a pair matches a token with the corresponding
+ TYPE and VALUE, except that a VALUE of `t' matches any token value.
+
If KEEP-END is true then retain the found token for later; otherwise
discard it. KEEP-END defaults to true if multiple TOKEN-TYPES are given;
otherwise false. If end-of-file is encountered then the indicator list is
simply the list of TOKEN-TYPES; otherwise the result is `nil'."
- `(skip-until ,(parser-scanner context)
+ `(%skip-until ,(parser-scanner context)
(list ,@token-types)
:keep-end ,(if keep-end-p keep-end
(> (length token-types) 1))))
(export 'error)
(defparse error (:context (context token-scanner-context)
- (&key ignore-unconsumed)
- sub &optional (recover t))
+ (&key ignore-unconsumed force-progress)
+ sub &optional (recover t) &body body)
"Try to parse SUB; if it fails then report an error, and parse RECOVER.
This is the main way to recover from errors and continue parsing. Even
`(parse-error-recover ,(parser-scanner context)
(parser () ,sub)
(parser () ,recover)
- :ignore-unconsumed ,ignore-unconsumed))
+ :ignore-unconsumed ,ignore-unconsumed
+ :force-progress ,force-progress
+ :action ,(and body `(lambda () ,@body))))
+
+(export 'must)
+(defparse must (:context (context token-scanner-context)
+ sub &optional default)
+ "Try to parse SUB; if it fails, report an error, and return DEFAULT.
+
+ This parser can't actually fail."
+ `(parse (error () ,sub (t ,default))))
;;;--------------------------------------------------------------------------
;;; Lexical analysis utilities.
The result isn't interesting."
(with-parser-context (character-scanner-context :scanner char-scanner)
- (parse (or (and "/*"
- (and (skip-many ()
- (and (skip-many () (not #\*))
- (label "*/" (skip-many (:min 1) #\*)))
- (not #\/))
- #\/))
- (and "//"
- (skip-many () (not #\newline))
- (? #\newline))))))
+ (let ((start (file-location char-scanner)))
+ (parse (or (and "/*"
+ (lisp (let ((state nil))
+ (loop (cond ((scanner-at-eof-p char-scanner)
+ (lexer-error char-scanner
+ (list "*/"))
+ (info-with-location
+ start "Comment started here")
+ (return (values nil t t)))
+ ((char= (scanner-current-char
+ char-scanner)
+ #\*)
+ (setf state '*)
+ (scanner-step char-scanner))
+ ((and (eq state '*)
+ (char= (scanner-current-char
+ char-scanner)
+ #\/))
+ (scanner-step char-scanner)
+ (return (values nil t t)))
+ (t
+ (setf state nil)
+ (scanner-step char-scanner)))))))
+ (and "//"
+ (skip-many () (not #\newline))
+ (? #\newline)))))))
;;;----- That's all, folks --------------------------------------------------
;; 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))
(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))))
("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
This protocol is used by `simple-message' subclasses."))
(export 'method-keyword-argument-lists)
-(defgeneric method-keyword-argument-lists (method direct-methods)
+(defgeneric method-keyword-argument-lists (method direct-methods state)
(:documentation
"Returns a list of keyword argument lists to be merged.
This should return a list suitable for passing to `merge-keyword-lists',
- i.e., each element should be a pair consisting of a list of `argument'
- objects and a string describing the source of the argument list."))
+ i.e., each element should be a pair consisting of a function describing
+ the source of the argument list (returning location and description), and
+ a list of `argument' objects.
+
+ The METHOD is the effective method being processed; DIRECT-METHODS is the
+ complete list of applicable direct methods (most specific first); and
+ STATE is an `inheritance-path-reporter-state' object which can be used by
+ the returned reporting functions."))
(export 'compute-sod-effective-method)
(defgeneric compute-sod-effective-method (message class)
No `me' argument is prepended; any `:ellipsis' is left as it is."))
+(export 'sod-method-description)
+(defgeneric sod-method-description (method)
+ (:documentation
+ "Return an adjectival phrase describing METHOD.
+
+ The result will be placed into an error message reading something like
+ ``Conflicting definition of DESCRIPTION direct method `bogus'''. Two
+ direct methods which can coexist in the same class, defined on the same
+ message, should have differing descriptions."))
+
(export 'sod-method-function-type)
(defgeneric sod-method-function-type (method)
(:documentation
;;; Utilities.
-(defvar *keyword-struct-disposition* :unset
+(defvar-unbound *keyword-struct-disposition*
"The current state of the keyword structure.
- This can be one of four values.
-
- * `:unset' -- the top-level default, mostly because I can't leave it
- unbound and write this documentation. Nothing that matters should see
- this state.
+ This can be one of three values.
* `:local' -- the structure itself is in a local variable `sod__kw'.
This is used in the top-level effective method.
;;;--------------------------------------------------------------------------
;;; Module objects.
-(defparameter *module-map* (make-hash-table :test #'equal)
+(defvar-unbound *module-map*
"Hash table mapping true names to module objects.")
+(define-clear-the-decks reset-module-map
+ (setf *module-map* (make-hash-table :test #'equal)))
(defun build-module
(name thunk &key (truename (probe-file name)) location)
(:documentation
"Represents a fragment of C code to be written to an output file.
- A C fragment is aware of its original location, and will bear proper #line
- markers when written out."))
+ A C fragment is aware of its original location, and will bear proper
+ `#line' markers when written out."))
(defun output-c-excursion (stream location func)
"Invoke FUNC surrounding it by writing #line markers to STREAM.
;;; Type names.
(define-pluggable-parser module typename (scanner pset)
- ;; `typename' id ( `,' id )* `;'
+ ;; `typename' list[id] `;'
(declare (ignore pset))
(with-parser-context (token-scanner-context :scanner scanner)
(parse (and "typename"
- (skip-many (:min 1)
- (seq ((id :id))
- (if (gethash id *module-type-map*)
- (cerror* "Type `~A' already defined" id)
- (add-to-module *module*
- (make-instance 'type-item
- :name id))))
+ (skip-many ()
+ (error ()
+ (seq ((id :id))
+ (if (or (gethash id *module-type-map*)
+ (find-simple-c-type id))
+ (cerror* "Type `~A' already defined" id)
+ (add-to-module *module*
+ (make-instance 'type-item
+ :name id))))
+ (skip-until () #\, #\;))
#\,)
- #\;))))
+ (must #\;)))))
;;; Fragments.
(define-pluggable-parser module code (scanner pset)
;; `code' id `:' item-name [constraints] `{' c-fragment `}'
;;
- ;; constrains ::= `[' constraint-list `]'
+ ;; constraints ::= `[' list[constraint] `]'
;; constraint ::= item-name+
;; item-name ::= id | `(' id+ `)'
(declare (ignore pset))
(seq (#\( (names (list (:min 1) (kw))) #\))
names)))))
(parse (seq ("code"
- (reason (kw))
- #\:
- (name (item))
+ (reason (must (kw)))
+ (nil (must #\:))
+ (name (must (item)))
(constraints (? (seq (#\[
- (constraints (list (:min 1)
- (list (:min 1)
- (item))
- #\,))
+ (constraints
+ (list ()
+ (list (:min 1)
+ (error (:ignore-unconsumed t)
+ (item)
+ (skip-until ()
+ :id #\( #\, #\])))
+ #\,))
#\])
constraints)))
(fragment (parse-delimited-fragment scanner #\{ #\})))
- (add-to-module *module*
- (make-instance 'code-fragment-item
- :fragment fragment
- :constraints constraints
- :reason reason
- :name name)))))))
+ (when name
+ (add-to-module *module*
+ (make-instance 'code-fragment-item
+ :fragment fragment
+ :constraints constraints
+ :reason reason
+ :name name))))))))
;;; External files.
(define-module (pathname :location location :truename truename)
(with-open-file (f-stream pathname :direction :input)
(let* ((*readtable* (copy-readtable))
+ (*package* (find-package '#:sod-user))
(char-scanner (make-instance 'charbuf-scanner
- :stream f-stream))
+ :stream f-stream
+ :filename (namestring pathname)))
(scanner (make-instance 'sod-token-scanner
:char-scanner char-scanner)))
(with-default-error-location (scanner)
(with-parser-context (token-scanner-context :scanner scanner)
- (parse (skip-many ()
- (seq ((pset (parse-property-set scanner))
- (nil (error ()
- (plug module scanner pset))))
- (check-unused-properties pset))))))))))
+ (multiple-value-bind (result winp consumedp)
+ (parse (skip-many ()
+ (seq ((pset (parse-property-set scanner))
+ (nil (error ()
+ (plug module scanner pset)
+ (skip-until (:keep-end nil)
+ #\; #\}))))
+ (check-unused-properties pset))))
+ (declare (ignore consumedp))
+ (unless winp (syntax-error scanner result)))))))))
(define-pluggable-parser module test (scanner pset)
;; `demo' string `;'
(declare (ignore pset))
(with-parser-context (token-scanner-context :scanner scanner)
- (parse (seq ("demo" (string :string) #\;)
+ (parse (seq ("demo" (string (must :string)) (nil (must #\;)))
(format t ";; DEMO ~S~%" string)))))
(define-pluggable-parser module file (scanner pset)
;; `load' string `;'
(declare (ignore pset))
(flet ((common (name type what thunk)
- (find-file scanner
- (merge-pathnames name
- (make-pathname :type type
- :case :common))
- what
- thunk)))
+ (when name
+ (find-file scanner
+ (merge-pathnames name
+ (make-pathname :type type
+ :case :common))
+ what
+ thunk))))
(with-parser-context (token-scanner-context :scanner scanner)
- (parse (or (seq ("import" (name :string) #\;)
+ (parse (or (seq ("import" (name (must :string)) (nil (must #\;)))
(common name "SOD" "module"
(lambda (path true)
(handler-case
*module*))))
(file-error (error)
(cerror* "Error reading module ~S: ~A"
+ path error))
+ (error (error)
+ (cerror* "Unexpected error reading ~
+ module ~S: ~A"
path error))))))
- (seq ("load" (name :string) #\;)
+ (seq ("load" (name (must :string)) (nil (must #\;)))
(common name "LISP" "Lisp file"
(lambda (path true)
(handler-case
;;; Setting properties.
(define-pluggable-parser module set (scanner pset)
- ;; `set' property-list `;'
+ ;; `set' list[property] `;'
(with-parser-context (token-scanner-context :scanner scanner)
(parse (and "set"
(lisp (let ((module-pset (module-pset *module*)))
(when pset
(pset-map (lambda (prop)
- (add-property module-pset
- (p-name prop)
- (p-value prop)
- :type (p-type prop)
- :location (p-location prop))
+ (add-property
+ module-pset
+ (p-name prop) (p-value prop)
+ :type (p-type prop)
+ :location (p-location prop))
(setf (p-seenp prop) t))
pset))
- (parse (skip-many (:min 0)
+ (parse (skip-many (:min (if pset 0 1))
(error (:ignore-unconsumed t)
- (parse-property scanner module-pset)
- (skip-until (:keep-end t) #\, #\;))
+ (parse-property scanner module-pset)
+ (skip-until () #\, #\;))
#\,))))
#\;))))
(scanner-step scanner)
(values sexp t t))
(values '((:id "lisp")) nil nil)))
- #\;)
+ (nil (must #\;)))
(eval sexp)))))
;;;--------------------------------------------------------------------------
(funcall make class frag pset scanner)))))
(define-pluggable-parser class-item initargs (scanner class pset)
- ;; initarg-item ::= `initarg' declspec+ init-declarator-list
+ ;; initarg-item ::= `initarg' declspec+ list[init-declarator]
;; init-declarator ::= declarator [`=' initializer]
(with-parser-context (token-scanner-context :scanner scanner)
(parse (seq ("initarg"
(car declarator)
pset init scanner))
#\,))
- #\;)))))
+ (nil (must #\;)))))))
+
+(defun synthetic-name ()
+ "Return an obviously bogus synthetic not-identifier."
+ (let ((ix *temporary-index*))
+ (incf *temporary-index*)
+ (make-instance 'temporary-variable :tag (format nil "%%#~A" ix))))
(defun parse-class-body (scanner pset name supers)
;; class-body ::= `{' class-item* `}'
;;
;; class-item ::= property-set raw-class-item
(with-parser-context (token-scanner-context :scanner scanner)
- (make-class-type name)
- (let* ((class (make-sod-class name (mapcar #'find-sod-class supers)
+ (when name (make-class-type name))
+ (let* ((duff (null name))
+ (synthetic-name (or name
+ (let ((var (synthetic-name)))
+ (unless pset
+ (setf pset (make-property-set)))
+ (unless (pset-get pset "nick")
+ (add-property pset "nick" var :type :id))
+ var)))
+ (class (make-sod-class synthetic-name
+ (restart-case
+ (mapcar #'find-sod-class
+ (or supers (list "SodObject")))
+ (continue ()
+ (setf duff t)
+ (list (find-sod-class "SodObject"))))
pset scanner))
(nick (sod-class-nickname class)))
- (labels ((parse-maybe-dotted-declarator (base-type)
- ;; Parse a declarator or dotted-declarator, i.e., one whose
- ;; centre is
- ;;
- ;; maybe-dotted-identifier ::= [id `.'] id
+ (labels ((must-id ()
+ (parse (must :id (progn (setf duff t) (synthetic-name)))))
+
+ (parse-maybe-dotted-name ()
+ ;; maybe-dotted-name ::= [id `.'] id
;;
;; A plain identifier is returned as a string, as usual; a
;; dotted identifier is returned as a cons cell of the two
;; names.
- (parse-declarator
- scanner base-type
- :keywordp t
- :kernel (parser ()
- (seq ((name-a :id)
- (name-b (? (seq (#\. (id :id)) id))))
- (if name-b (cons name-a name-b)
- name-a)))))
+ (parse (seq ((name-a (must-id))
+ (name-b (? (seq (#\. (id (must-id))) id))))
+ (if name-b (cons name-a name-b)
+ name-a))))
+
+ (parse-maybe-dotted-declarator (base-type)
+ ;; Parse a declarator or dotted-declarator, i.e., one whose
+ ;; centre is maybe-dotted-name above.
+ (parse-declarator scanner base-type
+ :keywordp t
+ :kernel #'parse-maybe-dotted-name))
(parse-message-item (sub-pset type name)
;; message-item ::=
(parse (seq ((body (or (seq ("extern" #\;) nil)
(parse-delimited-fragment
scanner #\{ #\}))))
- (make-sod-method class sub-nick name type
- body sub-pset scanner))))
+ (restart-case
+ (make-sod-method class sub-nick name type
+ body sub-pset scanner)
+ (continue () :report "Continue")))))
(parse-initializer ()
;; initializer ::= `=' c-fragment
;;
;; Return a VALUE, ready for passing to a `sod-initializer'
;; constructor.
- (parse-delimited-fragment scanner #\= (list #\, #\;)
+ (parse-delimited-fragment scanner #\= '(#\, #\;)
:keep-end t))
(parse-slot-item (sub-pset base-type type name)
;; slot-item ::=
;; declspec+ declarator -!- [initializer]
- ;; [`,' init-declarator-list] `;'
+ ;; [`,' list[init-declarator]] `;'
;;
- ;; init-declarator-list ::=
- ;; declarator [initializer] [`,' init-declarator-list]
- (parse (and (seq ((init (? (parse-initializer))))
- (make-sod-slot class name type
- sub-pset scanner)
- (when init
- (make-sod-instance-initializer
- class nick name init sub-pset scanner)))
- (skip-many ()
- (seq (#\,
- (ds (parse-declarator scanner
- base-type))
- (init (? (parse-initializer))))
- (make-sod-slot class (cdr ds) (car ds)
- sub-pset scanner)
- (when init
- (make-sod-instance-initializer
- class nick (cdr ds) init
- sub-pset scanner))))
- #\;)))
+ ;; init-declarator ::= declarator [initializer]
+ (flet ((make-it (name type init)
+ (restart-case
+ (progn
+ (make-sod-slot class name type
+ sub-pset scanner)
+ (when init
+ (make-sod-instance-initializer class
+ nick name
+ init
+ sub-pset
+ scanner)))
+ (continue () :report "Continue"))))
+ (parse (and (error ()
+ (seq ((init (? (parse-initializer))))
+ (make-it name type init))
+ (skip-until () #\, #\;))
+ (skip-many ()
+ (error (:ignore-unconsumed t)
+ (seq (#\,
+ (ds (parse-declarator scanner
+ base-type))
+ (init (? (parse-initializer))))
+ (make-it (cdr ds) (car ds) init))
+ (skip-until () #\, #\;)))
+ (must #\;)))))
(parse-initializer-item (sub-pset must-init-p constructor)
;; initializer-item ::=
- ;; [`class'] -!- slot-initializer-list `;'
+ ;; [`class'] -!- list[slot-initializer] `;'
;;
;; slot-initializer ::= id `.' id [initializer]
- (let ((parse-init (if must-init-p
- #'parse-initializer
+ (let ((parse-init (if must-init-p #'parse-initializer
(parser () (? (parse-initializer))))))
(parse (and (skip-many ()
- (seq ((name-a :id) #\. (name-b :id)
- (init (funcall parse-init)))
- (funcall constructor class
- name-a name-b init
- sub-pset scanner))
+ (error (:ignore-unconsumed t)
+ (seq ((name-a :id) #\.
+ (name-b (must-id))
+ (init (funcall parse-init)))
+ (restart-case
+ (funcall constructor class
+ name-a name-b init
+ sub-pset scanner)
+ (continue () :report "Continue")))
+ (skip-until () #\, #\;))
#\,)
- #\;))))
+ (must #\;)))))
(class-item-dispatch (sub-pset base-type type name)
;; Logically part of `parse-raw-class-item', but the
;; definition; otherwise it might be a message or slot.
(cond ((not (typep type 'c-function-type))
(when (consp name)
- (cerror*-with-location
- scanner
- "Method declarations must have function type.")
+ (cerror*
+ "Method declarations must have function type")
(setf name (cdr name)))
(parse-slot-item sub-pset base-type type name))
((consp name)
(car dc)
(cdr dc))))))
(and "class"
- (parse-initializer-item
- sub-pset t
+ (parse-initializer-item sub-pset t
#'make-sod-class-initializer))
- (parse-initializer-item
- sub-pset nil
+ (parse-initializer-item sub-pset nil
#'make-sod-instance-initializer)))))
- (parse (seq (#\{
+ (parse (seq ((nil (must #\{))
(nil (skip-many ()
(seq ((sub-pset (parse-property-set scanner))
(nil (parse-raw-class-item sub-pset)))
(check-unused-properties sub-pset))))
- (nil (error () #\})))
- (finalize-sod-class class)
- (add-to-module *module* class)))))))
+ (nil (must #\})))
+ (unless (finalize-sod-class class)
+ (setf duff t))
+ (unless duff
+ (add-to-module *module* class))))))))
(define-pluggable-parser module class (scanner pset)
- ;; `class' id [`:' id-list] class-body
+ ;; `class' id `:' list[id] class-body
;; `class' id `;'
(with-parser-context (token-scanner-context :scanner scanner)
(parse (seq ("class"
- (name :id)
+ (name (must :id))
(nil (or (seq (#\;)
- (make-class-type name))
- (seq ((supers (? (seq (#\: (ids (list () :id #\,)))
- ids)))
+ (when name (make-class-type name)))
+ (seq ((supers (must (seq (#\:
+ (ids (list () :id #\,)))
+ ids)))
(nil (parse-class-body
scanner
pset name supers)))))))))))
#+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*))))
#:sod-utilities
#:sod-parser))
+(cl:defpackage #:sod-user
+ (:use #:common-lisp
+ #:sod))
+
(cl:in-package #:sod)
;;;----- That's all, folks --------------------------------------------------
(condition-with-location enclosing-condition)
())
+(export 'information)
+(define-condition information (condition)
+ ())
+
(export 'error-with-location)
(define-condition error-with-location (condition-with-location error)
())
(define-condition warning-with-location (condition-with-location warning)
())
+(export 'information-with-location)
+(define-condition information-with-location
+ (condition-with-location information)
+ ())
+
(export 'enclosing-error-with-location)
(define-condition enclosing-error-with-location
(enclosing-condition-with-location error)
(enclosing-condition-with-location warning)
())
+(export 'enclosing-information-with-location)
+(define-condition enclosing-information-with-location
+ (enclosing-condition-with-location information)
+ ())
+
(export 'simple-condition-with-location)
(define-condition simple-condition-with-location
(condition-with-location simple-condition)
(warning-with-location simple-warning)
())
+(export 'simple-information)
+(define-condition simple-information (simple-condition information)
+ ())
+
+(export 'info)
+(defun info (datum &rest arguments)
+ "Report some useful diagnostic information.
+
+ Establish a simple restart named `noted', and signal the condition of type
+ `information' designated by DATUM and ARGUMENTS. Return non-nil if the
+ restart was invoked, otherwise nil."
+ (restart-case
+ (signal (designated-condition 'simple-information datum arguments))
+ (noted () :report "Noted." t)))
+
+(export 'noted)
+(defun noted (&optional condition)
+ "Invoke the `noted' restart, possibly associated with the given CONDITION."
+ (invoke-associated-restart 'noted condition))
+
+(export 'simple-information-with-location)
+(define-condition simple-information-with-location
+ (information-with-location simple-information)
+ ())
+
;;;--------------------------------------------------------------------------
;;; Reporting errors.
+(export 'enclosing-condition-with-location-type)
+(defgeneric enclosing-condition-with-location-type (condition)
+ (:documentation
+ "Return a class suitable for attaching location information to CONDITION.
+
+ Specifically, return the name of a subclass of `enclosing-condition-
+ with-location' suitable to enclose CONDITION.")
+ (:method ((condition error)) 'enclosing-error-with-location)
+ (:method ((condition warning)) 'enclosing-warning-with-location)
+ (:method ((condition information)) 'enclosing-information-with-location)
+ (:method ((condition condition)) 'enclosing-condition-with-location))
+
(export 'make-condition-with-location)
(defun make-condition-with-location (default-type floc datum &rest arguments)
"Construct a `condition-with-location' given a condition designator.
if the condition was a subtype of ERROR or WARNING then the resulting
condition will also be subtype of ERROR or WARNING as appropriate."
- (labels ((wrap (condition)
+ (labels ((check-no-args ()
+ (unless (null arguments)
+ (error "Argument list provided with specific condition")))
+ (wrap (condition)
(make-condition
- (etypecase condition
- (error 'enclosing-error-with-location)
- (warning 'enclosing-warning-with-location)
- (condition 'enclosing-condition-with-location))
+ (enclosing-condition-with-location-type condition)
:condition condition
:location (file-location floc)))
(make (type &rest initargs)
:location (file-location floc)
initargs)
(wrap (apply #'make-condition type initargs)))))
- (etypecase datum
- (condition-with-location datum)
- (condition (wrap datum))
+ (typecase datum
+ (condition-with-location (check-no-args) datum)
+ (condition (check-no-args) (wrap datum))
(symbol (apply #'make datum arguments))
((or string function) (make default-type
:format-control datum
- :format-arguments arguments)))))
+ :format-arguments arguments))
+ (t (error "Unexpected condition designator datum ~S" datum)))))
(export 'error-with-location)
(defun error-with-location (floc datum &rest arguments)
'simple-warning-with-location
floc datum arguments)))
+(export 'info-with-location)
+(defun info-with-location (floc datum &rest arguments)
+ "Report some information with attached location information."
+ (info (apply #'make-condition-with-location
+ 'simple-information-with-location
+ floc datum arguments)))
+
(defun my-cerror (continue-string datum &rest arguments)
"Like standard `cerror', but robust against sneaky changes of conditions.
`(with-default-error-location* ,floc (lambda () ,@body)))
;;;--------------------------------------------------------------------------
+;;; Custom errors for parsers.
+
+;; Resolve dependency cycle.
+(export '(parser-error-expected parser-error-found))
+(defgeneric parser-error-expected (condition))
+(defgeneric parser-error-found (condition))
+
+(export 'report-parser-error)
+(defun report-parser-error (error stream show-expected show-found)
+ (format stream "~:[Unexpected~;~
+ Expected ~:*~{~#[~;~A~;~A or ~A~:;~
+ ~@{~A, ~#[~;or ~A~]~}~]~} but found~] ~
+ ~A"
+ (mapcar show-expected (parser-error-expected error))
+ (funcall show-found (parser-error-found error))))
+
+(export 'parser-error)
+(define-condition parser-error (error)
+ ((expected :initarg :expected :reader parser-error-expected :type list)
+ (found :initarg :found :reader parser-error-found :type t))
+ (:documentation "Standard error from a parser.
+
+ Supports the usual kinds of parser failure, where the parser was expecting
+ some kinds of things but found something else.")
+ (:report (lambda (error stream)
+ (report-parser-error error stream
+ #'prin1-to-string #'prin1-to-string))))
+
+(export '(base-lexer-error simple-lexer-error))
+(define-condition base-lexer-error (error-with-location) ())
+(define-condition simple-lexer-error
+ (base-lexer-error simple-error-with-location)
+ ())
+
+(export '(base-syntax-error simple-syntax-error))
+(define-condition base-syntax-error (error-with-location) ())
+(define-condition simple-syntax-error
+ (base-syntax-error simple-error-with-location)
+ ())
+
+;;;--------------------------------------------------------------------------
;;; Front-end error reporting.
+(export 'classify-condition)
+(defgeneric classify-condition (condition)
+ (:method ((condition error)) "error")
+ (:method ((condition base-lexer-error)) "lexical error")
+ (:method ((condition base-syntax-error)) "syntax error")
+ (:method ((condition warning)) "warning")
+ (:method ((condition information)) "note"))
+
(defun count-and-report-errors* (thunk)
"Invoke THUNK in a dynamic environment which traps and reports errors.
(warnings 0))
(restart-case
(let ((our-continue-restart (find-restart 'continue)))
- (handler-bind
- ((error (lambda (error)
- (let ((fatal (eq (find-restart 'continue error)
- our-continue-restart)))
- (format *error-output*
- "~&~A: ~:[~;Fatal error: ~]~A~%"
- (file-location error)
- fatal
- error)
- (incf errors)
- (if fatal
- (return-from count-and-report-errors*
- (values nil errors warnings))
- (invoke-restart 'continue)))))
- (warning (lambda (warning)
- (format *error-output* "~&~A: Warning: ~A~%"
- (file-location warning)
- warning)
- (incf warnings)
- (invoke-restart 'muffle-warning))))
- (values (funcall thunk)
- errors
- warnings)))
+ (flet ((report (condition &optional indicator)
+ (let ((*print-pretty* nil))
+ (format *error-output*
+ "~&~A: ~@[~A ~]~A: ~A~%"
+ (file-location condition)
+ indicator (classify-condition condition)
+ condition))))
+ (handler-bind
+ ((error (lambda (error)
+ (let ((fatal (eq (find-restart 'continue error)
+ our-continue-restart)))
+ (report error (and fatal "fatal"))
+ (incf errors)
+ (if fatal
+ (return-from count-and-report-errors*
+ (values nil errors warnings))
+ (continue error)))))
+ (warning (lambda (warning)
+ (report warning)
+ (incf warnings)
+ (muffle-warning warning)))
+ (information (lambda (info)
+ (report info)
+ (noted info))))
+ (values (funcall thunk)
+ errors
+ warnings))))
(continue ()
:report (lambda (stream) (write-string "Exit to top-level" stream))
(values nil errors warnings)))))
#+cmu #:extensions
#+ecl #.(if (find-package '#:gray) '#:gray '#:si)
#+clisp #:gray))
- (error "Unsupported Lisp (can't find Gray streams).")))
+ (error "Unsupported Lisp (can't find Gray streams)")))
;; CMUCL's `extensions' package has lots of cruft. Use our cruft instead.
#+cmu (:shadowing-import-from #:sod-utilities #:symbolicate #:once-only))
The return value may later be used with `parser-restore-place'. Be
careful: all of this is happening at macro-expansion time.")
(:method (context)
- (error "Parser context ~S doesn't support rewinding." context)))
+ (error "Parser context ~S doesn't support rewinding" context)))
(export 'parser-restore-place)
(defgeneric parser-restore-place (context place)
(defun commit-peeked-place ()
"Called by `commit' not lexically within `peek'."
- (error "`commit' is not within `peek'."))
+ (error "`commit' is not within `peek'"))
(export 'commit)
(defparse commit ()
:index index))))
(last-link (charbuf-scanner-place-link place-b)))
(flet ((bad ()
- (error "Incorrect places ~S and ~S to `scanner-interval'."
+ (error "Incorrect places ~S and ~S to `scanner-interval'"
place-a place-b)))
(do ((link (charbuf-scanner-place-link place-a)
(charbuf-chain-link-next link))
(export '(string-scanner make-string-scanner string-scanner-p))
(defstruct (string-scanner
(:constructor make-string-scanner
- (string &key (start 0) end
+ (string &key (start 0) end filename
&aux (%string string)
(index start)
(limit (or end (length string))))))
"Scanner structure for a simple string scanner."
(%string "" :type string :read-only t)
+ (filename "<string>" :type string :read-only t)
(index 0 :type (and fixnum unsigned-byte))
- (limit nil :type (and fixnum unsigned-byte) :read-only t))
+ (limit nil :type (and fixnum unsigned-byte) :read-only t)
+ (line 1 :type fixnum)
+ (column 0 :type fixnum))
(define-access-wrapper string-scanner-string string-scanner-%string
:read-only t)
(char (string-scanner-string scanner) (string-scanner-index scanner)))
(defmethod scanner-step ((scanner string-scanner))
- (incf (string-scanner-index scanner)))
+ (let ((index (string-scanner-index scanner)))
+ (setf (values (string-scanner-line scanner)
+ (string-scanner-column scanner))
+ (update-position (char (string-scanner-string scanner) index)
+ (string-scanner-line scanner)
+ (string-scanner-column scanner))
+ (string-scanner-index scanner) (1+ index))))
+
+(defmethod scanner-unread ((scanner string-scanner) char)
+ (let ((index (1- (string-scanner-index scanner))))
+ (setf (values (string-scanner-line scanner)
+ (string-scanner-column scanner))
+ (backtrack-position (char (string-scanner-string scanner) index)
+ (string-scanner-line scanner)
+ (string-scanner-column scanner))
+ (string-scanner-index scanner) index)))
+
+(defmethod scanner-filename ((scanner string-scanner))
+ (string-scanner-filename scanner))
+(defmethod scanner-line ((scanner string-scanner))
+ (string-scanner-line scanner))
+(defmethod scanner-column ((scanner string-scanner))
+ (string-scanner-column scanner))
+(defmethod file-location ((scanner string-scanner))
+ (make-file-location (string-scanner-filename scanner)
+ (string-scanner-line scanner)
+ (string-scanner-column scanner)))
(defmethod scanner-capture-place ((scanner string-scanner))
(string-scanner-index scanner))
(:documentation
"Capture the SCANNER's current place and return it.")
(:method (scanner)
- (error "Scanner ~S doesn't support rewinding." scanner)))
+ (error "Scanner ~S doesn't support rewinding" scanner)))
(export 'scanner-restore-place)
(defgeneric scanner-restore-place (scanner place)
(defmethod coerce-property-value
((value string) (type (eql :id)) (wanted (eql :type)))
- (or (gethash value *module-type-map*)
- (gethash value *declspec-map*)
- (error "Unknown type `~A'." value)))
+ (or (and (boundp '*module-type-map*)
+ (gethash value *module-type-map*))
+ (find-simple-c-type value)
+ (error "Unknown type `~A'" value)))
;;;--------------------------------------------------------------------------
;;; Property sets.
(sexp (read stream t)))
(scanner-step scanner)
(multiple-value-bind (type value)
- (decode-property sexp)
+ (restart-case (decode-property (eval sexp))
+ (continue () (values :invalid nil)))
(values (cons type value) t t))))
(#\{
(values (cons :fragment
;;;--------------------------------------------------------------------------
;;; Parsing property sets.
+(export 'parse-property)
(defun parse-property (scanner pset)
"Parse a single property using the SCANNER; add it to the PSET."
;; property ::= id `=' expression
(with-parser-context (token-scanner-context :scanner scanner)
(multiple-value-bind (result winp consumedp)
(handler-bind ((error (lambda (cond)
- (declare (ignore cond))
(setf errors t)
- (if (find-restart 'continue)
- (invoke-restart 'continue)
+ (if (find-restart 'continue cond)
+ (continue cond)
:decline))))
(parse-property-set scanner))
(declare (ignore consumedp))
;;; Testing.
(defmethod perform ((op test-op) (system (eql (find-system "sod-test"))))
- (handler-bind (((or warning style-warning)
- (lambda (cond)
- (declare (ignore cond))
- (invoke-restart 'muffle-warning))))
+ (handler-bind (((or warning style-warning) #'muffle-warning))
(operate 'load-op system)
(let ((result (funcall (find-symbol "RUN-TESTS" "SOD-TEST"))))
(unless (funcall (find-symbol "WAS-SUCCESSFUL" "XLUNIT") result)
("classes" "class-layout-impl" "method-impl" "output-proto"))
;; Finishing touches of various kinds.
- (:file "final" :depends-on ("builtin" "module-output"))))
+ (:file "final" :depends-on ("builtin" "module-output" "class-output"))))
;;;--------------------------------------------------------------------------
;;; Testing.
(defmethod perform ((op test-op) (component (eql (find-system "sod"))))
(declare (ignore op component))
- (handler-bind (((or warning style-warning)
- (lambda (cond)
- (declare (ignore cond))
- (invoke-restart 'muffle-warning))))
+ (handler-bind (((or warning style-warning) #'muffle-warning))
(operate 'test-op "sod-test")))
;;;----- That's all, folks --------------------------------------------------
"If COND, evaluate BODY as a progn with `it' bound to the value of COND."
`(let ((it ,cond)) (when it ,@body)))
+(export 'aand)
+(defmacro aand (&rest forms)
+ "Like `and', but anaphoric.
+
+ Each FORM except the first is evaluated with `it' bound to the value of
+ the previous one. If there are no forms, then the result it `t'; if there
+ is exactly one, then wrapping it in `aand' is pointless."
+ (labels ((doit (first rest)
+ (if (null rest)
+ first
+ `(let ((it ,first))
+ (if it ,(doit (car rest) (cdr rest)) nil)))))
+ (if (null forms)
+ 't
+ (doit (car forms) (cdr forms)))))
+
(export 'acond)
(defmacro acond (&body clauses &environment env)
"Like COND, but with `it' bound to the value of the condition.
(export 'mappend)
(defun mappend (function list &rest more-lists)
- "Like a nondestructive MAPCAN.
+ "Like a nondestructive `mapcan'.
Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
and return the result of appending all of the resulting lists."
(reduce #'append (apply #'mapcar function list more-lists) :from-end t))
+(export 'distinguished-point-shortest-paths)
+(defun distinguished-point-shortest-paths (root neighbours-func)
+ "Moderately efficient shortest-paths-from-root computation.
+
+ The ROOT is a distinguished vertex in a graph. The NEIGHBOURS-FUNC
+ accepts a VERTEX as its only argument, and returns a list of conses (V .
+ C) for each of the VERTEX's neighbours, indicating that there is an edge
+ from VERTEX to V, with cost C.
+
+ The return value is a list of entries (COST . REV-PATH) for each vertex
+ reachable from the ROOT; the COST is the total cost of the shortest path,
+ and REV-PATH is the path from the ROOT, in reverse order -- so the first
+ element is the vertex itself and the last element is the ROOT.
+
+ The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to
+ produce its output list. The computation as a whole takes O(N^2) time,
+ where N is the number of vertices in the graph, assuming there is at most
+ one edge between any pair of vertices."
+
+ ;; This is a listish version of Dijkstra's shortest-path algorithm. It
+ ;; could be made more efficient by using a fancy priority queue rather than
+ ;; a linear search for finding the nearest live element (see below), but it
+ ;; still runs pretty well.
+
+ (let ((map (make-hash-table))
+ (dead nil)
+ (live (list (list 0 root))))
+ (setf (gethash root map) (cons :live (car live)))
+ (loop
+ ;; The dead list contains a record, in output format (COST . PATH), for
+ ;; each vertex whose shortest path has been finally decided. The live
+ ;; list contains a record for the vertices of current interest, also in
+ ;; output format; the COST for a live record shows the best cost for a
+ ;; path using only dead vertices.
+ ;;
+ ;; Each time through here, we pull an item off the live list and
+ ;; push it onto the dead list, so we do at most N iterations total.
+
+ ;; If there are no more live items, then we're done; the remaining
+ ;; vertices, if any, are unreachable from the ROOT.
+ (when (null live) (return))
+
+ ;; Find the closest live vertex to the root. The linear scan through
+ ;; the live list costs at most N time.
+ (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live))
+ (best-cost (car best))
+ (best-path (cdr best))
+ (best-vertex (car best-path)))
+
+ ;; Remove the chosen vertex from the LIVE list, and add the
+ ;; appropriate record to the dead list. We must have the shortest
+ ;; path to this vertex now: we have the shortest path using currently
+ ;; dead vertices; any other path must use at least one live vertex,
+ ;; and, by construction, the path through any such vertex must be
+ ;; further than the path we already have.
+ ;;
+ ;; Removal from the live list uses a linear scan which costs N time.
+ (setf live (delete best live))
+ (push best dead)
+ (setf (car (gethash best-vertex map)) :dead)
+
+ ;; Work through the chosen vertex's neighbours, adding each of them
+ ;; to the live list if they're not already there. If a neighbour is
+ ;; already live, and we find a shorter path to it through our chosen
+ ;; vertex, then update the neighbour's record.
+ ;;
+ ;; The chosen vertex obviously has at most N neighbours. There's no
+ ;; more looping in here, so performance is as claimed.
+ (dolist (neigh (funcall neighbours-func best-vertex))
+ (let* ((neigh-vertex (car neigh))
+ (neigh-cost (+ best-cost (cdr neigh)))
+ (neigh-record (gethash neigh-vertex map)))
+ (cond ((null neigh-record)
+ ;; If the neighbour isn't known, then now's the time to
+ ;; make a fresh live record for it.
+ (let ((new-record (list* :live neigh-cost
+ neigh-vertex best-path)))
+ (push (cdr new-record) live)
+ (setf (gethash neigh-vertex map) new-record)))
+ ((and (eq (car neigh-record) :live)
+ (< neigh-cost (cadr neigh-record)))
+ ;; If the neighbour is live, and we've found a better path
+ ;; to it, then update its record.
+ (setf (cadr neigh-record) neigh-cost
+ (cdddr neigh-record) best-path)))))))
+ dead))
+
(export '(inconsistent-merge-error merge-error-candidates))
(define-condition inconsistent-merge-error (error)
((candidates :initarg :candidates
(:documentation
"Reports an inconsistency in the arguments passed to `merge-lists'.")
(:report (lambda (condition stream)
- (format stream "Merge inconsistency: failed to decide among ~A."
+ (format stream "Merge inconsistency: failed to decide between ~
+ ~{~#[~;~A~;~A and ~A~:;~
+ ~@{~A, ~#[~;and ~A~]~}~]~}"
(merge-error-candidates condition)))))
(export 'merge-lists)
-(defun merge-lists (lists &key pick (test #'eql))
+(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
"Return a merge of the given LISTS.
The resulting list contains the items of the given LISTS, with duplicates
the input LISTS in the sense that if A precedes B in some input list then
A will also precede B in the output list. If the lists aren't consistent
(e.g., some list contains A followed by B, and another contains B followed
- by A) then an error of type `inconsistent-merge-error' is signalled.
+ by A) then an error of type `inconsistent-merge-error' is signalled. The
+ offending items are filtered for presentation through the PRESENT function
+ before being attached to the condition, so as to produce a more useful
+ diagnostic message.
Item equality is determined by TEST.
candidates))
(winner (cond ((null leasts)
(error 'inconsistent-merge-error
- :candidates candidates))
+ :candidates (mapcar present candidates)))
((null (cdr leasts))
(car leasts))
(pick
cat-names cat-vars)
,@body))))
+(export 'partial-order-minima)
+(defun partial-order-minima (items order)
+ "Return a list of minimal items according to the non-strict partial ORDER.
+
+ The ORDER function describes the partial order: (funcall ORDER X Y) should
+ return true if X precedes or is equal to Y in the order."
+ (reduce (lambda (tops this)
+ (let ((new nil) (keep t))
+ (dolist (top tops)
+ (cond ((funcall order top this)
+ (setf keep nil)
+ (push top new))
+ ((not (funcall order this top))
+ (push top new))))
+ (nreverse (if keep (cons this new) new))))
+ items
+ :initial-value nil))
+
;;;--------------------------------------------------------------------------
;;; Strings and characters.
(reduce #'compose1 more-functions :initial-value function)))
;;;--------------------------------------------------------------------------
+;;; Variables.
+
+(export 'defvar-unbound)
+(defmacro defvar-unbound (var doc)
+ "Make VAR a special variable with documentation DOC, but leave it unbound."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar ,var)
+ (setf (documentation ',var 'variable) ',doc)
+ ',var))
+
+;;;--------------------------------------------------------------------------
;;; Symbols.
(export 'symbolicate)
(setf (,to object) value))))))
;;;--------------------------------------------------------------------------
+;;; Condition and error utilities.
+
+(export 'designated-condition)
+(defun designated-condition (default-type datum arguments
+ &key allow-pointless-arguments)
+ "Return the condition designated by DATUM and ARGUMENTS.
+
+ DATUM and ARGUMENTS together are a `condition designator' of (some
+ supertype of) DEFAULT-TYPE; return the condition so designated."
+ (typecase datum
+ (condition
+ (unless (or allow-pointless-arguments (null arguments))
+ (error "Argument list provided with specific condition"))
+ datum)
+ (symbol
+ (apply #'make-condition datum arguments))
+ ((or string function)
+ (make-condition default-type
+ :format-control datum
+ :format-arguments arguments))
+ (t
+ (error "Unexpected condition designator datum ~S" datum))))
+
+(export 'simple-control-error)
+(define-condition simple-control-error (control-error simple-error)
+ ())
+
+(export 'invoke-associated-restart)
+(defun invoke-associated-restart (restart condition &rest arguments)
+ "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.
+
+ Find an active restart designated by RESTART; if CONDITION is not nil,
+ then restrict the search to restarts associated with CONDITION, and
+ restarts not associated with any condition. If no such restart is found
+ then signal an error of type `control-error'; otherwise invoke the restart
+ with the given ARGUMENTS."
+ (apply #'invoke-restart
+ (or (find-restart restart condition)
+ (error 'simple-control-error
+ :format-control "~:[Restart ~S is not active~;~
+ No active `~(~A~)' restart~]~
+ ~@[ for condition ~S~]"
+ :format-arguments (list (symbolp restart)
+ restart
+ condition)))
+ arguments))
+
+;;;--------------------------------------------------------------------------
;;; CLOS hacking.
(export 'default-slot)
~mdw / sod / commitdiff