From 684d95c7eb6ec755d38efacbc377e9e60ba7044e Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Mon, 17 May 2021 23:22:11 +0100 Subject: [PATCH] @@@ mess! --- NOTES | 19 +- configure.ac | 26 +-- doc/Makefile.am | 53 +++-- doc/SYMBOLS | 9 +- doc/check-docs | 52 +++-- doc/clang.tex | 261 +++++++++++++++--------- doc/list-exports | 33 ++- doc/misc.tex | 33 ++- doc/sod.sty | 19 +- doc/sod.words | 521 ++++++++++++++++++++++++------------------------ src/Makefile.am | 47 ++--- src/asdf-hack.lisp.in | 2 +- src/builtin.lisp | 10 + src/c-types-impl.lisp | 1 + src/c-types-proto.lisp | 30 ++- src/codegen-proto.lisp | 135 +++++++++---- src/frontend.lisp | 8 +- src/method-proto.lisp | 9 + src/optparse.lisp | 149 +++++++------- src/sod-frontend.asd.in | 25 +-- src/sod-test.asd.in | 30 +-- src/sod.asd.in | 291 ++++++++++++++++----------- src/utilities.lisp | 11 + vars.am | 7 + 24 files changed, 1014 insertions(+), 767 deletions(-) diff --git a/NOTES b/NOTES index c22de92..07e1180 100644 --- a/NOTES +++ b/NOTES @@ -6,15 +6,18 @@ ~progn~-combination, and one for producing output, which subclasses can override. - + Investigate a `robust-ABI' layout using pointers rather than simple - inclusion. Each class's islots and vtmsgs will be found by - following a pointer rather than just magically knowing the offsets. - If you allocate objects dynamically, using ~CLASS->cls.initsz~ - rather than ~sizeof(CLASS__ilayout)~ then this isolates you from - added slots and messages at all superclasses. I expect this to - require a separate root class, but it /might/ be possible to - mix-and-match. + + Implement `indirect' slots and messages, which can be added (once a + class has declared support) /without/ breaking the class's ABI. + Indirect messages can be added to an indirect `vtmsgs' structure via + a pointer in the main vtable. Indirect slots must be added to a + region of the `ilayout' located via an offset stored in the vtable. + * Add `documentation' methods for all of the myriad kinds of things + that can be defined. A useful utility will find methods on a + generic function with an `eql'-specializer in some specified place. + + * Define static initializers for class layouts which obviate the need + for imprinting. * COMMENT Emacs cruft diff --git a/configure.ac b/configure.ac index 44f061c..1a45f9e 100644 --- a/configure.ac +++ b/configure.ac @@ -71,27 +71,17 @@ AC_SUBST([ASDF_VERSION]) dnl-------------------------------------------------------------------------- dnl Common Lisp things. -AC_ARG_WITH([lisp-system], - [AS_HELP_STRING([--with-lisp-system=SYSTEMS], - [preference order of cl-launch Lisp systems])], - [], [with_lisp_system="sbcl clisp"]) - -AC_CHECK_PROGS([CL_LAUNCH], [cl-launch], [not-found]) -case "$CL_LAUNCH" in - not-found) AC_MSG_ERROR([\`cl-launch' not found]) ;; -esac +WORKING_LISPS="sbcl,clisp,ecl"; AC_SUBST([WORKING_LISPS]) -AC_MSG_CHECKING([for best choice of Lisp system]) -if ! LISPSYS=$($CL_LAUNCH -l "$with_lisp_system" \ - -ip '(string-downcase (lisp-implementation-type))'); then - AC_MSG_ERROR([cl-launch didn't like any Lisp system]) -fi -AC_SUBST([LISPSYS]) -AC_MSG_RESULT([$LISPSYS]) +AC_CHECK_PROGS([RUNLISP], [runlisp], [not-found]) +case "$RUNLISP" in + not-found) AC_MSG_ERROR([\`runlisp' not found]) ;; +esac AC_MSG_CHECKING([FASL file extension]) -fasl=$($CL_LAUNCH -l $LISPSYS -ip \ - '(pathname-type (compile-file-pathname "foo.lisp"))') +fasl=$($RUNLISP -L$WORKING_LISPS -e \ + '(format t "~A~%" + (pathname-type (compile-file-pathname "foo.lisp")))') AC_SUBST([fasl]) AC_MSG_RESULT([.$fasl]) diff --git a/doc/Makefile.am b/doc/Makefile.am index 052247f..89484a9 100644 --- a/doc/Makefile.am +++ b/doc/Makefile.am @@ -32,22 +32,27 @@ BIB_FILES = CLEANFILES += *.aux *.out *.log *.toc *.ind *.idx *.ilg EXTRA_DIST += $(TEX_FILES) $(BIB_FILES) -TEXFLAGS = --interaction=batchmode \ - --output-directory=$(abs_builddir) -BIBTEXFLAGS = --terse -MAKEINDEXFLAGS = -q +V_LATEX = $(V_LATEX_@AM_V@) +V_LATEX_ = $(V_LATEX_@AM_DEFAULT_V@) +V_LATEX_0 = @echo " LATEX $@"; -V_LATEX = $(V_LATEX_@AM_V@) -V_LATEX_ = $(V_LATEX_@AM_DEFAULT_V@) -V_LATEX_0 = @echo " LATEX $@"; +V_TEXMODE = $(V_TEXMODE_@AM_V@) +V_TEXMODE_ = $(V_TEXMODE_@AM_DEFAULT_V@) +V_TEXMODE_0 = batchmode +V_TEXMODE_1 = nonstopmode -V_BIBTEX = $(V_BIBTEX_@AM_V@) -V_BIBTEX_ = $(V_BIBTEX_@AM_DEFAULT_V@) -V_BIBTEX_0 = @echo " BIBTEX $@"; +V_BIBTEX = $(V_BIBTEX_@AM_V@) +V_BIBTEX_ = $(V_BIBTEX_@AM_DEFAULT_V@) +V_BIBTEX_0 = @echo " BIBTEX $@"; -V_MAKEINDEX = $(V_MAKEINDEX_@AM_V@) -V_MAKEINDEX_ = $(V_MAKEINDEX_@AM_DEFAULT_V@) -V_MAKEINDEX_0 = @echo " MAKEIDX $@"; +V_MAKEINDEX = $(V_MAKEINDEX_@AM_V@) +V_MAKEINDEX_ = $(V_MAKEINDEX_@AM_DEFAULT_V@) +V_MAKEINDEX_0 = @echo " MAKEIDX $@"; + +TEXFLAGS = --interaction=$(V_TEXMODE) \ + --output-directory=$(abs_builddir) +BIBTEXFLAGS = --terse +MAKEINDEXFLAGS = -q run_pdflatex = $(V_LATEX)cd $(srcdir) && \ version=$$(echo '$(VERSION)' | sed 's/~/\\textasciitilde /g') && \ @@ -122,10 +127,30 @@ babelbst.tex: mdwalpha.bst mdwalpha.bst: mdwalpha.dbj (cd $(srcdir) && $(TEX) \ --jobname=mdwalpha \ - --interaction=batchmode \ + --interaction=$(V_TEXMODE) \ --output-directory=$(abs_builddir) \ '\let\ifbatching\iftrue \input mdwalpha.dbj') endif endif +###-------------------------------------------------------------------------- +### Maintenance rules. + +fixup-wordlist: + { IFS= read -r hdr && echo "$$hdr" && \ + LC_COLLATE=POSIX sort -f; \ + } <$(srcdir)/sod.words >$(srcdir)/sod.words.new && \ + mv $(srcdir)/sod.words.new $(srcdir)/sod.words +.PHONY: fixup-wordlist + +update-symbols: + $(ASDF_ENV) $(RUNLISP) -L$(WORKING_LISPS) $(srcdir)/list-exports \ + >$(srcdir)/SYMBOLS.new && \ + mv $(srcdir)/SYMBOLS.new $(srcdir)/SYMBOLS +.PHONY: update-symbols + +check-manual: update-symbols sod.pdf + $(srcdir)/check-docs sod.aux $(srcdir)/SYMBOLS +.PHONY: check-manual + ###----- That's all, folks -------------------------------------------------- diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 7f8414e..bcf22ae 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -16,7 +16,7 @@ c-types-class-impl.lisp c-types-impl.lisp cl:* variable function c-type-form - alignas + alignas c-storage-form alignas-storage-specifier class cl:array class c-type-form atomic c-type-form @@ -221,6 +221,7 @@ c-types-proto.lisp c-type macro class c-type-alias macro c-type-equal-p generic + c-type-form c-type-qualifier-keywords function c-type-qualifiers generic c-type-space function @@ -1936,7 +1937,7 @@ parser-proto.lisp if-parse macro sod-utilities:it label parser-form - lisp c-type-form parser-form + lisp c-type-form c-storage-form parser-form cl:list function class parser-form opthandler many parser-form cl:not function parser-form @@ -2453,7 +2454,6 @@ optparse.lisp die-usage function do-options macro do-usage function - exit function help-options optmacro inc opthandler sod-utilities:int c-type-spec c-type-form opthandler @@ -2476,6 +2476,7 @@ optparse.lisp opt-negated-tag function setf-function opt-short-name function setf-function opt-tag function setf-function + opthandler option class option-parse-error function class option-parse-next function @@ -2486,6 +2487,7 @@ optparse.lisp option-parser-p function optionp function options macro + optmacro parse-option-form function cl:read function opthandler sanity-check-option-list function @@ -2546,6 +2548,7 @@ utilities.lisp sb-mop:eql-specializer class sb-mop:eql-specializer-object generic find-duplicates function + find-eql-specialized-method function frob-identifier function sb-mop:generic-function-methods generic setf-generic inconsistent-merge-error class diff --git a/doc/check-docs b/doc/check-docs index c721da2..e7bc9de 100755 --- a/doc/check-docs +++ b/doc/check-docs @@ -22,7 +22,7 @@ sub scansyms (\%$) { elsif ($st eq LIST) { my @F = split; (my $sym = shift @F) =~ s/^(.+)://; - $labels->{"sym:$sym"} = 1 unless @F; + $labels->{"sym:$sym"} = $file; for my $t (@F) { if ($t eq 'constant') { $labels->{"const:$sym"} = $file; } elsif ($t eq 'variable') { $labels->{"var:$sym"} = $file; } @@ -34,6 +34,8 @@ sub scansyms (\%$) { elsif ($t eq 'class') { $labels->{"cls:$sym"} = $file; } elsif ($t eq 'c-type-spec') { $labels->{"cty:$sym"} = $file; } elsif ($t eq 'c-type-form') { $labels->{"cty:$sym"} = $file; } + elsif ($t eq 'c-storage-spec') { $labels->{"cstg:$sym"} = $file; } + elsif ($t eq 'c-storage-form') { $labels->{"cstg:$sym"} = $file; } elsif ($t eq 'parser-spec') { $labels->{"parse:$sym"} = $file; } elsif ($t eq 'parser-form') { $labels->{"parseform:$sym"} = $file; } elsif ($t eq 'opthandler') { $labels->{"opt:$sym"} = $file; } @@ -45,7 +47,7 @@ sub scansyms (\%$) { close $fh; } -my %DEF = map { $_ => 1 } +my %DEF = map { $_ => "" } "cls:array", "cls:class", "cls:error", "cls:float", "cls:function", "cls:list", "cls:string", "const:nil", @@ -58,9 +60,15 @@ my %CAT = map { $_ => 1 } 'sym', 'const', 'var', 'mac', 'fun', 'gf', 'cls', 'modvar', 'const', 'meth', 'ar-meth', 'be-meth', 'af-meth', 'msg', 'feat', - 'rst', 'ty', 'lmac', 'parse', 'parseform', 'opt', 'optmac', 'plug'; + 'rst', 'ty', 'lmac', 'parse', 'parseform', 'opt', 'optmac', 'plug', + 'cty', 'cstg'; -my $AUXDIR = "build/doc/"; +sub die_usage () { die "usage: $0 AUXFILE SYMFILE\n"; } +die_usage unless @ARGV; my $auxfile = shift @ARGV; +die_usage unless @ARGV; my $symfile = shift @ARGV; +die_usage if @ARGV; +(my $AUXDIR = $auxfile) =~ s![^/]*$!!; +$auxfile =~ s!^.*/!!; sub scanaux (\%$) { my ($def, $f) = @_; @@ -68,15 +76,23 @@ sub scanaux (\%$) { open my $fh, "<", "$AUXDIR$f"; while (<$fh>) { chomp; - if (/^\\\@input\{([^}]*\.aux)\}$/) { scanaux($def, $1); } - elsif (/^\\newlabel\{([^:]+):([^}]+)\}/ && $CAT{$1}) - { $def->{"$1:$2"} = $s; } + if (/^\\\@input\{([^}]*\.aux)\}$/) + { scanaux($def, $1); } + elsif (/^\\newlabel\{([^:]+):([^}]+)\}/ && $CAT{$1}) { + my ($cat, $sym) = ($1, $2); + $def->{"$cat:$sym"} = $s; + $def->{"sym:$sym"} //= $s unless $sym =~ m!^setf/|\(.*\)$!; + } } close $fh; } -scansyms %LABEL, "doc/SYMBOLS"; -scanaux %DEF, "sod.aux"; +scansyms %LABEL, $symfile; +scanaux %DEF, $auxfile; + +##use Data::Dumper; +##print "LABELS = " . Dumper(\%LABEL) . "\n"; +##print "DEF = " . Dumper(\%DEF) . "\n"; my $BAD = 0; @@ -89,26 +105,25 @@ sub bad ($) { SYM: for my $sym (sort keys %LABEL) { if ($DEF{$sym}) { next SYM; } my ($tag, $name) = $sym =~ /^([^:]+):(.*)$/; - if ($tag eq "cls" && $DEF{"ty:$name"}) { } + if ($name eq "nil" && $DEF{"$tag:()"}) { } + elsif ($tag eq "cls" && $DEF{"ty:$name"}) { } elsif ($tag eq "gf" && $DEF{"fun:$name"}) { } elsif ($tag eq "var" && $DEF{"const:$name"}) { } elsif ($tag eq "sym" && $DEF{"plug:$name"}) { } - elsif ($tag eq "sym" && $DEF{"lmac:$name"}) { } - elsif ($sym eq "sym:alignas" && $DEF{"cls:alignas-storage-specifier"}) { } - elsif ($sym eq "fun:main" && $DEF{"fun:sod-frontend:main"}) { } - elsif ($sym eq "fun:augment-options" && - $DEF{"fun:sod-frontend:augment-options"}) { } + elsif ($sym =~ /^(fun|sym):(main|augment-options)$/ && + $DEF{"$tag:sod-frontend:$name"}) { } elsif ($sym eq "gf:setf/generic-function-methods") { } - elsif ($tag eq "cty") { } else { bad "missing $tag:$name (defined in $LABEL{$sym})"; } } SYM: for my $sym (sort keys %DEF) { if ($LABEL{$sym}) { next SYM; } my ($tag, $name) = $sym =~ /^([^:]+):(.*)$/; - if ($tag eq "ty" && $LABEL{"cls:$name"}) { } + if ($name eq "()" && $LABEL{"$tag:nil"}) { } + elsif ($tag eq "ty" && $LABEL{"cls:$name"}) { } elsif ($tag eq "const" && $LABEL{"var:$name"}) { } elsif ($tag eq "fun" && $LABEL{"gf:$name"}) { } + elsif ($tag eq "sym" && $name =~ /^:/) { } elsif ($DEF{$sym} eq "runtime.tex") { } elsif ($DEF{$sym} eq "structures.tex") { } elsif ($sym eq "lmac:parse") { } @@ -121,7 +136,8 @@ SYM: for my $sym (sort keys %DEF) { $sym eq "parse:t" || $sym eq "parseform:t" || $sym eq "parseform:when") { } elsif ($sym eq "plug:class-item" || $sym eq "plug:module") { } - elsif ($sym eq "sym:int") { } + elsif ($sym eq "sym:int" || $sym eq "sym:atom" || $sym eq "sym:t" || + $sym eq "sym:when") { } elsif ($name =~ /^sod-frontend:(.*)$/ && $LABEL{"$tag:$1"}) { } else { bad "unexpected $tag:$name (described in $DEF{$sym})"; } } diff --git a/doc/clang.tex b/doc/clang.tex index d35387d..de9e8df 100644 --- a/doc/clang.tex +++ b/doc/clang.tex @@ -53,7 +53,7 @@ The class hierarchy is shown in~\xref{fig:codegen.c-types.classes}. @|c-keyword-function-type| \- \end{tabbing}} \caption{Classes representing C types} -\label{fig:codegen.c-types.classes} + \label{fig:codegen.c-types.classes} \end{figure} C type objects are immutable unless otherwise specified. @@ -181,6 +181,11 @@ type specifier. Type specifiers fit into two syntactic categories. into. \end{describe} +\begin{describe}{cty}{lisp @
^*} + Evaluates the @s as an implicit @|progn|, and returns the value(s) of + the final @ as a C type. +\end{describe} + \begin{describe}{gf} {print-c-type @ @ \&optional @ @} Print the C type object @ to @ in S-expression form. The @@ -193,6 +198,28 @@ type specifier. Type specifiers fit into two syntactic categories. default method. \end{describe} +\begin{describe*} + {\dhead{sym}{c-type} + \dhead{meth}{symbol,(eql 'c-type)} + {documentation (@ symbol) + (@ (eql 'c-type))} + \dhead{meth}{symbol,(eql 'c-type)} + {setf \=(documentation (@ symbol) + (@ (eql 'c-type))) \\ + \>@}} +\end{describe*} + +\begin{describe*} + {\dhead{sym}{c-type-form} + \dhead{meth}{symbol,(eql 'c-type-form)} + {documentation (@ symbol) + (@ (eql 'c-type-form))} + \dhead{meth}{symbol,(eql 'c-type-form)} + {setf \=(documentation (@ symbol) + (@ (eql 'c-type-form))) \\ + \>@}} +\end{describe*} + \subsection{Comparing C types} \label{sec:clang.c-types.cmp} @@ -407,16 +434,18 @@ Every Lisp keyword is potentially a storage specifier, which simply maps to its lower-case print name in C; but other storage specifiers may be more complicated objects. -\begin{describe}{cls} - {c-storage-specifiers-type (c-type) \&key :subtype :specifiers} +\begin{describe*} + {\dhead{cls}{c-storage-specifiers-type (c-type) + \&key :subtype :specifiers} + \dhead{cty}{specs @ @^*}} A type which carries storage specifiers. The @ is the actual type, and may be any C type; the @ are a list of storage-specifier objects. - The type specifier @|(specs @ @^*)| wraps the - @ in a @|c-storage-specifiers-type|, carrying the @s, - which are a list of storage specifiers in S-expression notation. -\end{describe} + The type specifier @|specs| wraps the @ in a + @|c-storage-specifiers-type|, carrying the @s, which are a list + of storage specifiers in S-expression notation. +\end{describe*} \begin{describe}{fun}{c-type-specifiers @ @> @} Returns the list of type specifiers attached to the @ object, which @@ -454,7 +483,13 @@ complicated objects. @|(c-type (specs @ (@ . @)))|. \end{describe} +\begin{describe}{cstg}{lisp @^*} + Evaluates the @s as an implicit @|progn|, and returns the value(s) of + the final @ as a storage-specifier. +\end{describe} + \begin{describe}{gf}{pprint-c-storage-specifier @ @} + Prints the storage-specifier @ to @, in C syntax. \end{describe} \begin{describe}{gf} @@ -474,14 +509,16 @@ complicated objects. @. \end{describe} -\begin{describe}{cls}{alignas-storage-specifier () \&key :alignment} - The class of @|_Alignas| storage specifiers; an instance denotes the - specifier @|_Alignas(@)|. The @ parameter may be any - printable object, but is usually a string or C fragment. - - The storage specifier form @|(alignas @)| returns a storage - specifier @|_Alignas(@)|, where @ is evaluated. -\end{describe} +\begin{describe*} + {\dhead{cls}{alignas-storage-specifier () \&key :alignment} + \dhead{cstg}{alignas @}} + The class of \mbox{@|_Alignas|} storage specifiers; an instance denotes the + specifier \mbox{@|_Alignas(@)|}. The @ parameter may + be any printable object, but is usually a string or C fragment. + + The storage specifier form @|alignas| returns a storage specifier + \mbox{@|_Alignas(@)|}, where @ is evaluated. +\end{describe*} \subsection{Leaf types} \label{sec:clang.c-types.leaf} @@ -508,15 +545,21 @@ In Sod, the leaf types are Two simple type objects are equal if and only if they have @|string=| names and matching qualifiers. - \def\x#1{\desclabel{const}{c-type-#1}} - \x{bool} \x{char} \x{wchar-t} \x{signed-char} \x{unsigned-char} \x{short} - \x{unsigned-short} \x{int} \x{unsigned} \x{long} \x{unsigned-long} - \x{long-long} \x{unsigned-long-long} \x{size-t} \x{ptrdiff-t} \x{float} - \x{double} \x{long-double} \x{float-imaginary} \x{double-imaginary} - \x{long-double-imaginary} \x{float-complex} \x{double-complex} - \x{long-double-complex} \x{va-list} \x{void} - \crossproduct\x{{{int}{uint}}{{}{-least}{-fast}}{{8}{16}{32}{64}}{{-t}}} - \crossproduct\x{{{int}{uint}}{{ptr}{max}}{{-t}}} + \def\x#1{\desclabel{cty}{#1}} + \def\y#1{\desclabel{const}{c-type-#1}\x{#1}} + \y{bool} \y{wchar-t} + \y{int} \x{signed} \y{unsigned} \y{signed-char} + \crossproduct\y{{{}{unsigned-}}{{char}{short}{long}{long-long}}} + \crossproduct\x{{{}{signed-}{unsigned-}}{{short}{long}{long-long}}{{-int}}} + \crossproduct\x{{{signed-}{unsigned-}}{{int}}} + \crossproduct\x{{{signed-}}{{short}{int}{long}{long-long}}} + \crossproduct\x{{{s}{u}}{{char}{short}{int}{long}{llong}}} \x{llong} + \y{size-t} \y{ptrdiff-t} \y{float} + \y{double} \y{long-double} \y{float-imaginary} \y{double-imaginary} + \y{long-double-imaginary} \y{float-complex} \y{double-complex} + \y{long-double-complex} \y{va-list} \y{void} + \crossproduct\y{{{int}{uint}}{{}{-least}{-fast}}{{8}{16}{32}{64}}{{-t}}} + \crossproduct\y{{{int}{uint}}{{ptr}{max}}{{-t}}} A number of symbolic type specifiers for builtin types are predefined as shown in \xref{tab:codegen.c-types.simple}. These are all defined as if by @@ -665,14 +708,15 @@ In Sod, the leaf types are type class as a symbol. \end{describe} -\begin{describe}{cls}{c-enum-type (tagged-c-type) \&key :qualifiers :tag} +\begin{describe*} + {\dhead{cls}{c-enum-type (tagged-c-type) \&key :qualifiers :tag} + \dhead{cty}{enum @ @^*}} Represents a C enumerated type. An instance denotes the C type @|enum| @. See the direct superclass @|tagged-c-type| for details. - The type specifier @|(enum @ @^*)| returns the (unique - interned) enumerated type with the given @ and @s (all - evaluated). -\end{describe} + The type specifier @|enum| returns the (unique interned) enumerated type + with the given @ and @s (all evaluated). +\end{describe*} \begin{describe}{fun} {make-enum-type @ \&optional @ @> @} @@ -681,14 +725,15 @@ In Sod, the leaf types are keywords). \end{describe} -\begin{describe}{cls}{c-struct-type (tagged-c-type) \&key :qualifiers :tag} +\begin{describe*} + {\dhead{cls}{c-struct-type (tagged-c-type) \&key :qualifiers :tag} + \dhead{cty}{struct @ @^*}} Represents a C structured type. An instance denotes the C type @|struct| @. See the direct superclass @|tagged-c-type| for details. - The type specifier @|(struct @ @^*)| returns the (unique - interned) structured type with the given @ and @s (all - evaluated). -\end{describe} + The type specifier @|struct| returns the (unique interned) structured type + with the given @ and @s (all evaluated). +\end{describe*} \begin{describe}{fun} {make-struct-type @ \&optional @ @> @} @@ -697,15 +742,17 @@ In Sod, the leaf types are keywords). \end{describe} -\begin{describe}{cls}{c-union-type (tagged-c-type) \&key :qualifiers :tag} +\begin{describe*} + {\dhead{cls}{c-union-type (tagged-c-type) \&key :qualifiers :tag} + \dhead{cty}{union @ @^*}} Represents a C union type. An instance denotes the C type @|union| @. See the direct superclass @|tagged-c-type| for details. - The type specifier @|(union @ @^*)| returns the (unique - interned) union type with the given @ and @s (all - evaluated). -\end{describe} + The type specifier @|union| returns the (unique interned) union type with + the given @ and @s (all evaluated). +\end{describe*} + \begin{describe}{fun} {make-union-type @ \&optional @ @> @} Return the (unique interned) C type object for the union C type whose tag @@ -733,8 +780,10 @@ underlying type of the object. Note that, as far as Sod is concerned, atomic types are not the same as atomic-qualified types: you must be consistent about which you use. -\begin{describe}{cls} - {c-atomic-type (qualifiable-c-type) \&key :qualifiers :subtype} +\begin{describe*} + {\dhead{cls}{c-atomic-type (qualifiable-c-type) + \&key :qualifiers :subtype} + \dhead{cty}{atomic @ @^*}} Represents an atomic type. An instance denotes the C type @|_Atomic(@)|. @@ -744,11 +793,10 @@ about which you use. have matching qualifiers. It is possible, though probably not useful, to have an atomic-qualified atomic type. - The type specifier @|(atomic @ @^*)| returns a type - qualified atomic @, where @ is the type specified by - @ and the @s are qualifier keywords (which are - evaluated). -\end{describe} + The type specifier @|atomic| returns a type qualified atomic @, + where @ is the type specified by @ and the + @s are qualifier keywords (which are evaluated). +\end{describe*} \begin{describe}{fun} {make-atomic-type @ \&optional @ @> @} @@ -763,24 +811,29 @@ about which you use. Pointers are compound types. The subtype of a pointer type is the type it points to. -\begin{describe}{cls} - {c-pointer-type (qualifiable-c-type) \&key :qualifiers :subtype} +\begin{describe*} + {\dhead{cls}{c-pointer-type (qualifiable-c-type) + \&key :qualifiers :subtype} + \dhead{cty}{* @ @^*} + \dhead{cty}{string} + \dhead{cty}{const-string}} Represents a C pointer type. An instance denotes the C type @ @|*|@. The @ may be any C type. Two pointer types are equal if and only if their subtypes are equal and they have matching qualifiers. - The type specifier @|(* @ @^*)| returns a type - qualified pointer-to-@, where @ is the type specified by - @ and the @s are qualifier keywords (which are - evaluated). The synonyms @|ptr| and @|pointer| may be used in place of the - star @`*'. + \desclabel{cty}{ptr} + \desclabel{cty}{pointer} + The type specifier @|*| returns a type qualified pointer-to-@, + where @ is the type specified by @ and the + @s are qualifier keywords (which are evaluated). The synonyms + @|ptr| and @|pointer| may be used in place of the star @`*'. The symbol @|string| is a type specifier for the type pointer to characters; the symbol @|const-string| is a type specifier for the type pointer to constant characters. -\end{describe} +\end{describe*} \begin{describe}{fun} {make-pointer-type @ \&optional @ @@ -796,7 +849,11 @@ points to. Arrays implement the compound-type protocol. The subtype of an array type is the array element type. -\begin{describe}{cls}{c-array-type (c-type) \&key :subtype :dimensions} +\begin{describe*} + {\dhead{cls}{c-array-type (c-type) \&key :subtype :dimensions} + \dhead{cty}{[] @ @^*}} + \desclabel{cty}{array}[|(] + \desclabel{cty}{vec}[|(] Represents a multidimensional C array type. The @ are a list of dimension specifiers $d_0$, $d_1$, \ldots, $d_{n-1}$; an instance then denotes the C type @ @|[$d_0$][$d_1$]$\ldots$[$d_{n-1}$]|. An @@ -813,12 +870,15 @@ the array element type. $d_1$ of \ldots\ arrays of $d_{n-1}$ elements of type @. We shall continue to abuse terminology and refer to multidimensional arrays. - The type specifier @|([] @ @^*)| constructs a - multidimensional array with the given @s whose elements have the - type specified by @. If no dimensions are given then a - single-dimensional array with unspecified extent. The synonyms @|array| - and @|vector| may be used in place of the brackets @`[]'. -\end{describe} + The type specifier @|[]| constructs a multidimensional array with the given + @s whose elements have the type specified by @. If + no dimensions are given then a single-dimensional array with unspecified + extent. The synonyms @|array| and @|vec| may be used in place of the + brackets @`[]'. + + \desclabel{cty}{array}[|)] + \desclabel{cty}{vec}[|)] +\end{describe*} \begin{describe}{fun} {make-array-type @ @ @> @} @@ -910,7 +970,16 @@ function type is the type of the function's return value. unchanged. \end{describe} -\begin{describe}{cls}{c-function-type (c-type) \&key :subtype :arguments} +\begin{describe*} + {\dhead{cls}{c-function-type (c-type) \&key :subtype :arguments} + \dhead*{cty}{fun @ + @{ (@ @) @}^* + @[:ellipsis @! . @@]}} + \desclabel{cty}{()}[|(] + \desclabel{cty}{fn}[|(] + \desclabel{cty}{func}[|(] + \desclabel{cty}{function}[|(] + \descindex{cty}{fun}[|(] Represents C function types. An instance denotes the type of a C function which accepts the @ and returns @. @@ -928,19 +997,13 @@ function type is the type of the function's return value. in the same order, and either both or neither argument list ends with @|:ellipsis|; argument names are not compared. - The type specifier - \begin{prog} - (fun @ - @{ (@ @) @}^* - @[:ellipsis @! . @@]) - \end{prog} - constructs a function type. The function has the subtype @. - The remaining items in the type-specifier list are used to construct the - argument list. The argument items are a possibly improper list, beginning - with zero or more \emph{explicit arguments}: two-item - @/@ lists. For each such list, an @|argument| object - is constructed with the given name (evaluated) and type. Following the - explicit arguments, there may be + The type specifier @|fun| constructs a function type. The function has the + subtype @. The remaining items in the type-specifier list are + used to construct the argument list. The argument items are a possibly + improper list, beginning with zero or more \emph{explicit arguments}: + two-item @/@ lists. For each such list, an @|argument| + object is constructed with the given name (evaluated) and type. Following + the explicit arguments, there may be \begin{itemize} \item nothing, in which case the function's argument list consists only of the explicit arguments; @@ -968,11 +1031,18 @@ function type is the type of the function's return value. (ret (c-type-subtype other-func))) \-\\ \ind (c-type (fun \=(lisp ret) ("first" int) . args) \end{prog} -\end{describe} + \descindex{cty}{fun}[|)] +\end{describe*} -\begin{describe}{cls} - {c-keyword-function-type (c-function-type) - \&key :subtype :arguments :keywords} +\begin{describe*} + {\dhead{cls}{c-keyword-function-type (c-function-type) + \&key :subtype :arguments :keywords} + \dhead{cty}{fun \=@ + @{ (@ @) @}^* \+\\ + @{ \=:keys @{ (@ @ + @[@@]) @}^* + @[. @@] @! \+\\ + . @ @}}} Represents `functions' which accept keyword arguments. Of course, actual C functions can't accept keyword arguments directly, but this type is useful for describing messages and methods which deal with keyword arguments. @@ -998,19 +1068,11 @@ function type is the type of the function's return value. arguments accepted by the functions is not significant. Keyword functions are constructed using an extended version of the @|fun| - specifier used for ordinary C function types. The extended syntax is as - follows. - \begin{prog} - (fun \=@ - @{ (@ @) @}^* \+\\ - @{ \=:keys @{ (@ @ @[@@]) @}^* - @[. @@] @! \+\\ - . @ @} - \end{prog} - where either the symbol @|:keys| appears literally in the specifier, or the - @ evaluates to a list containing the symbol @|:keys|. (If neither of - these circumstances obtains, then the specifier constructs an ordinary - function type.) + specifier (or any of its synonyms) used for ordinary C function types. + Either the symbol @|:keys| must appear literally in the specifier, or the + @ must evaluate to a list containing the symbol @|:keys|. (If + neither of these circumstances obtains, then the specifier constructs an + ordinary function type.) See the description of \descref{cls}{c-function-type} for how a trailing @ is handled. @@ -1018,7 +1080,12 @@ function type is the type of the function's return value. The list of @s and @s describes the positional arguments. The list of @s, @s and @s describes the keyword arguments. -\end{describe} + + \descindex{cty}{()}[|)] + \descindex{cty}{fn}[|)] + \descindex{cty}{func}[|)] + \descindex{cty}{function}[|)] +\end{describe*} \begin{describe}{fun} {make-function-type @ @ @> @} @@ -1151,9 +1218,11 @@ function type is the type of the function's return value. \subsection{Class types} \label{sec:clang.c-types.class} -\begin{describe}{cls} - {c-class-type (simple-c-type) \&key :class :tag :qualifiers :name} -\end{describe} +\begin{describe*} + {\dhead{cls}{c-class-type (simple-c-type) + \&key :class :tag :qualifiers :name} + \dhead{cty}{class @ @^*}} +\end{describe*} \begin{describe*} {\dhead{gf}{c-type-class @ @> @} diff --git a/doc/list-exports b/doc/list-exports index 1d9b0c4..87d85be 100755 --- a/doc/list-exports +++ b/doc/list-exports @@ -1,9 +1,5 @@ -#! /bin/sh -":"; ### -*-lisp-*- -":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/: -":"; ASDF_OUTPUT_TRANSLATIONS=$(pwd)/src:$(pwd)/build/src -":"; export CL_SOURCE_REGISTRY ASDF_OUTPUT_TRANSLATIONS -":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(sod-exports::main)" -- "$0" "$@" || exit 1 +#! /usr/bin/runlisp -Lsbcl,cmucl +;;; -*-lisp-*- (cl:defpackage #:sod-exports (:use #:common-lisp @@ -13,7 +9,8 @@ ;; Load the target system so that we can poke about in it. (cl:in-package #:sod-exports) (eval-when (:compile-toplevel :load-toplevel :execute) - (mapc #'asdf:load-system '(:sod :sod-frontend))) + (asdf:clear-configuration) + (mapc #'asdf:load-system '(:sod :sod/frontend))) ;;;-------------------------------------------------------------------------- ;;; Miscelleneous utilities. @@ -376,13 +373,17 @@ (push :c-type-spec things)) (when (specialized-on-p #'sod:expand-c-type-form 0 symbol) (push :c-type-form things)) + (when (specialized-on-p #'sod:expand-c-storage-specifier 0 symbol) + (push :c-storage-spec things)) + (when (specialized-on-p #'sod:expand-c-storage-specifier-form 0 symbol) + (push :c-storage-form things)) (when (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol) (push :parser-spec things)) (when (specialized-on-p #'sod-parser:expand-parser-form 1 symbol) (push :parser-form things)) - (when (get symbol 'optparse::opthandler) + (when (get symbol 'optparse::opthandler-function) (push :opthandler things)) - (when (get symbol 'optparse::optmacro) + (when (get symbol 'optparse::optmacro-function) (push :optmacro things)) (nreverse things))) @@ -892,7 +893,7 @@ (let* ((sod (asdf:find-system "sod")) (parser-files (files (by-name sod "parser"))) (utilities (by-name sod "utilities")) - (sod-frontend (asdf:find-system "sod-frontend")) + (sod-frontend (asdf:find-system "sod/frontend")) (optparse (by-name sod "optparse")) (frontend (by-name sod-frontend "frontend")) (sod-files (set-difference (files sod) (list optparse utilities)))) @@ -908,13 +909,9 @@ ;;; Command-line use. (defun main () - "Write a report to `doc/SYMBOLS'." - (with-open-file (*standard-output* #p"doc/SYMBOLS" - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (report-project-symbols))) - -#+interactive (main) + "Write a report to *standard-output*." + (report-project-symbols)) + +#+runlisp-script (main) ;;;----- That's all, folks -------------------------------------------------- diff --git a/doc/misc.tex b/doc/misc.tex index 353c948..f1e3cde 100644 --- a/doc/misc.tex +++ b/doc/misc.tex @@ -303,6 +303,14 @@ metaobject protocol. \end{describe} \end{describe*} +\begin{describe}{fun} + {find-eql-specialized-method @ @ @} + Find and return a method defined on a generic @ whose @th + argument (counting from zero) is @|eql|-specialized on the givan + @. If there is no such method on @ then return @|nil|. + If there are multiple such methods, return one of them arbitrarily. +\end{describe} + \begin{describe*} {\dhead{gf}{generic-function-methods @ @> @} \dhead{gf}{method-specializers @ @> @} @@ -913,9 +921,6 @@ The following definitions are useful when working with conditions. Most of these symbols are defined in the @|optparse| package. -\begin{describe}{fun}{exit \&optional (@ 0) \&key :abrupt} -\end{describe} - \begin{describe}{var}{*program-name*} \end{describe} @@ -1021,6 +1026,17 @@ Most of these symbols are defined in the @|optparse| package. @^*} \end{describe} +\begin{describe*} + {\dhead{sym}{opthandler} + \dhead{meth}{symbol,(eql 'opthandler)} + {documentation (@ symbol) + (@ (eql 'opthandler))} + \dhead{meth}{symbol,(eql 'opthandler)} + {setf \=(documentation (@ symbol) + (@ (eql 'opthandler))) \\ + \>@}} +\end{describe*} + \begin{describe}{fun} {invoke-option-handler @ @ @ @} \end{describe} @@ -1058,6 +1074,17 @@ Most of these symbols are defined in the @|optparse| package. @^*} \end{describe} +\begin{describe*} + {\dhead{sym}{optmacro} + \dhead{meth}{symbol,(eql 'optmacro)} + {documentation (@ symbol) + (@ (eql 'optmacro))} + \dhead{meth}{symbol,(eql 'optmacro)} + {setf \=(documentation (@ symbol) + (@ (eql 'optmacro))) \\ + \>@}} +\end{describe*} + \begin{describe}{fun}{parse-option-form @} \end{describe} diff --git a/doc/sod.sty b/doc/sod.sty index 592ff5c..3f49516 100644 --- a/doc/sod.sty +++ b/doc/sod.sty @@ -433,9 +433,10 @@ \else\def\next@{#1{plain}{#2}{#3}{#5}{#4}}\fi\fi\fi% \next@% } -\def\parse@dhd@csetf#1#2#3#4(#5 #6\q@{% +\def\parse@dhd@csetf#1#2#3#4#5(#6 #7\q@{% % {NEXT}{CAT}{{...}...}{SYNOPSIS}(NAME [ARGS...])\q@ - #1{setf}{#2}{#3}{#5}{#4}} + #1{setf}{#2}{#3}{#6}{#4}} + %% \dhead[MOD]{CAT}{...}...[NAME]{SYNOPSIS} %% \dhead*[MOD]{CAT}{...}...[NAME]{SYNOPSIS} @@ -461,12 +462,12 @@ \protected@edef\@tempa##1{% \noexpand\index{\@desc@dispatch{descindex}{#2}{#1}{#2}#3{#4}##1}}% \toks@\expandafter{\@tempa{|)}}% - \toks\tw@\expandafter{\after@desc}% - \xdef\after@desc{\the\toks\tw@\the\toks@}% - \@tempa{|(}}% + \toks\tw@\expandafter{\after@desc}% + \xdef\after@desc{\the\toks\tw@\the\toks@}% + \@tempa{|(}}% \fi% \rlap{\hb@xt@\linewidth{\hfil\normalfont\bfseries - [\describecategoryname[#1]{#2}]}}% + [\describecategoryname[#1]{#2}]}}% #5% } @@ -563,8 +564,8 @@ %% %% The MOD is the modifier to apply, similar (but subtly different from) to %% the `describe' environment. If omitted, it will usually default to -%% `plain', but in the absence of a NAME, some kinds of synopses are -%% recognized specially: +%% `plain', but in the absence of a NAME, some kinds of labels are recognized +%% specially: %% %% * `*NAME*': defaults MOD to `muffs'. %% @@ -659,6 +660,8 @@ \definedescribecategory{opt}{option handler} \definedescribecategory{optmac}{option macro} \definedescribecategory{plug}{pluggable parser} +\definedescribecategory{cty}{C type form} +\definedescribecategory{cstg}{C storage specifier} %%%----- That's all, folks -------------------------------------------------- \endinput diff --git a/doc/sod.words b/doc/sod.words index 8ed4934..27b6730 100644 --- a/doc/sod.words +++ b/doc/sod.words @@ -1,291 +1,290 @@ -personal_ws-1.1 en 290 -structs +personal_ws-1.1 en 292 +aand +ABI +ABIs +abstractp +acase +accessor +accessors +ACM +acond +acyclic +aecase +aetypecase +afterness +aif +alice +alignas +allocators +anaphoric +anaphorics +ansi +aor +ap +api +ar +arg +args argumentp -SIG -prog -goto -uchar -dylan -valist -paren -MyClass -rprec -toset -CLASSOF -llong -kwparse -KWPARSE +asdf asetf -cls -lbuild -uint -ecase -anaphorics +atsign +atypecase +awhen +barrett +binop +bool buf -qualifiable -unspecialized -dir -lvalue -aand +canonfied +canonifies +canonify +Cassels +cdr +cerror +charbuf +chead +circularities +CLASSOF +clos +cls +cmu +coercions +commentified +commentify +commitp +cond +const +constantp +constp +consumedp +continuable +continuep +CONV +cplusplus +ctype +cv Cygwin -rst -initarg's -initargs -kwtab -asdf -ASDF -linearization +dec +decl declarator -ABIs -args -Haahr -iostream -atypecase -KWSET -dosequence -PARSEFN -initarg +declarators declp -Habib -constp decls -psetp -decl -plist -fputs -eof -fil -ichainsz -initializer -setf -continuable -ptrs -env -ptrdiff -postop -lmac -notational +defctype defn -eql -vhv -perl -insts -sym -alignas -Accessor -accessor -wchar defs -initsz -nref -optionp -kwval -cerror -url -initializers -acyclic -slong -allocators -gensym -dæmon -Mugnier -aecase -specializers -IEC -there'd -enum -numericp -undef -progn -unix -parsers -parser's -inher -bool -unary -incf -awhen -vtmsgs -XCHAIN -unescaped -rôles -locf -vtu -dflt -typedefs -lprec -unkhook -floc -specializer -sint -rôle -seenp -radix -multip -nreverse -vtable -equalp -instsz -accessors -init -resignalling -acond -ifdef defun -printf -vtables -varargsp -CLOS -clos -chead -KWCALL -unkhookfn -ish -onwards -ulong -jmp -canonfied -iso -fixnum -commentify -ap -ar -lex +designator +destructuring +dflt +dir +dirs disambiguated -offsetof -peekp -charbuf -eval +docp +donep +dosequence +ducournau +dylan +dæmon +ecase eg -mLib -oldunk +endif +enum +enums +env +eof +eq +eql +equalp +errno +etypecase EuLisp -const -ichains -cv +eval +expr +extern +externp +externs +fil +fixme +fixnum +fixnums +floc +fp +fputs +frob +func gc -kwfirst -ichainu +gensym +gensyms gf -cplusplus -eq -initv -monot gh -consumedp -fp -propertyp -cond -vmsgs -coercions -acase -lparen +goto +Haahr +Habib +Huchard hv -dirs -yacc -defctype -abstractp -canonify -endif -CONV +ichain +ichains +ichainsz +ichainu +IEC +ifdef +ifndef +ilayout +incf +inher +init +initarg +initarg's +initargs +initializer +initializers +initsz +initv +insts +instsz +invariance +invariants +iostream isbn -methty -upcast -subclassp -Cassels -extern -barrett +ish +islots +islotsz +iso +issn +jmp +kwargs +KWCALL +KWDECL +kwfirst +kwparse +KWSET +kwtab +KWTAIL +kwval +lbuild +lex +linearization +linearizations linearize -Shalit -upcasts -commentified -oct -signedness -morep -continuep -Invariance -invariance -ifndef -Huchard -nitty -locative -externp -tc -gensyms -msg -designator -anaphoric -externs -th -ABI -va linearizes +llong +lmac +locative +locativep +locatives +locf +lparen +lprec +lvalue makev -frob -vh -destructuring -preop -ACM -ty -schar -scrutinee -vt malloc -ilayout -islotsz -docp -alice -stmts -rparen -enums -aif -linearizations -declarators -etypecase -ichain +methty +mLib +monot +morep +msg +Mugnier +multip +MyClass nestedp +nitty +notational +nref +nreverse +numericp +oct +offsetof +oldunk +onwards +optionp +paren +PARSEFN +parser's +parsers +peekp +perl +plist +postop +pre prec -aetypecase +preop +prin +princ +printf +prog +progn +propertyp +pset +psetp +ptr +ptrdiff +ptrs +qualifiable +radix +resignalling +ret +rparen +rprec +rst +rôle +rôles +schar +scrutinee +seenp +setf +Shalit +SIG +signedness +sint +sizeof sllong -kwargs -KWARGS -issn -expr -islots -strcmp -KWTAIL +slong spacep -constantp -fixnums -pre -ret -atsign +specializer +specializers sshort -sizeof -suppliedp -commitp +stmts +strcmp struct -cdr -api -KWDECL +structs +subclassp +suppliedp +sym +sys +tc +th +there'd +toset +ty +typedefs +uchar +uint +uiop ullong -prin -canonifies -aor -afterness -locativep -func -arg -invariants -locatives -ducournau -pset -dec -binop -ptr -ansi -donep -circularities -fixme +ulong +unary +undef +unescaped +unix +unkhook +unkhookfn +unspecialized +upcast +upcasts +url ushort -princ +va +valist +varargsp +vh +vhv +vmsgs +vt +vtable +vtables +vtmsgs +vtu +wchar +XCHAIN +yacc diff --git a/src/Makefile.am b/src/Makefile.am index 0dfb320..8a23b69 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -29,10 +29,6 @@ nobase_dist_pkglispsrc_DATA = $(LISP_SOURCES) LISP_SOURCES = SYSDEFS = -ASDF_ENV = \ - CL_SOURCE_REGISTRY=$$(pwd): \ - ASDF_OUTPUT_TRANSLATIONS=$$(cd $(srcdir); pwd):$(abs_builddir): - ###-------------------------------------------------------------------------- ### The source files. @@ -114,18 +110,13 @@ sod.asd: sod.asd.in Makefile $(SUBST) $(srcdir)/sod.asd.in >$@.new $(SUBSTITUTIONS) && \ mv $@.new $@ -EXTRA_DIST += sod-frontend.asd.in -CLEANFILES += sod-frontend.asd -sod-frontend.asd: sod-frontend.asd.in Makefile - $(SUBST) $(srcdir)/sod-frontend.asd.in >$@.new $(SUBSTITUTIONS) && \ - mv $@.new $@ - ## Building the executable image. bin_PROGRAMS += sod sod_SOURCES = -sod$(EXEEXT): $(LISP_SOURCES) sod.asd sod-frontend.asd auto.lisp - $(V_DUMP)$(ASDF_ENV) $(CL_LAUNCH) -o $@ -d ! -l $(LISPSYS) +I \ - -s sod-frontend -r sod-frontend:main +sod$(EXEEXT): $(LISP_SOURCES) sod.asd auto.lisp + $(V_DUMP)$(ASDF_ENV) $(RUNLISP) -L$(WORKING_LISPS) \ + -e "(asdf:clear-configuration)" \ + -e "(asdf:operate 'asdf:program-op \"sod/frontend\")" ## The executable is needed if we're just distributing. dist-hook: sod$(EXEEXT) @@ -133,9 +124,6 @@ dist-hook: sod$(EXEEXT) ###-------------------------------------------------------------------------- ### Unit testing. -## The system definition. -EXTRA_DIST += sod-test.asd.in - ## Basic utilities. EXTRA_DIST += test-base.lisp @@ -148,24 +136,14 @@ EXTRA_DIST += c-types-test.lisp EXTRA_DIST += codegen-test.lisp EXTRA_DIST += lexer-test.lisp -## The system definition. -EXTRA_DIST += sod-test.asd.in -CLEANFILES += sod-test.asd -sod-test.asd: sod-test.asd.in Makefile - $(SUBST) $(srcdir)/sod-test.asd.in >$@.new $(SUBSTITUTIONS) && \ - mv $@.new $@ - ## Running the Lisp tests. -check-local: sod sod-test.asd - $(V_TEST)$(ASDF_ENV) $(CL_LAUNCH) -l $(LISPSYS) \ - -s sod-frontend +I \ - -i '(handler-case ;\ - (progn ;\ - (asdf:load-system "sod-test") ;\ - (asdf:test-system "sod")) ;\ - (error (cond) ;\ - (format *error-output* "ERR: ~A~%" cond) ;\ - (optparse:exit 1)))' +check-local: sod sod.asd + $(V_TEST)$(ASDF_ENV) $(RUNLISP) -L$(WORKING_LISPS) -e \ + '(asdf:clear-configuration) ;\ + (handler-case (asdf:test-system "sod") ;\ + (error (cond) ;\ + (format *error-output* "ERR: ~A~%" cond) ;\ + (uiop:quit 1)))' ###-------------------------------------------------------------------------- ### Manual pages. @@ -199,9 +177,10 @@ install-data-local: done; \ dots=$$(echo $$fwd | sed 's/[^ ][^ ]*/../g'); \ rel=$$(echo $$dots $$twd | tr " " "/"); \ - for i in sod.asd sod-frontend.asd; do \ + for i in sod.asd; do \ echo >&2 "CREATE $$to/$$i"; \ sed -e '/#|@-auto-@|#/ { r auto.lisp' -e ' d; }' \ + -e '/#|@-del-@|#/ d' \ -e '/#|@-path-@|#/ d' \ $(srcdir)/$$i.in >$(DESTDIR)$(pkglispsrcdir)/$$i.new; \ mv $(DESTDIR)$(pkglispsrcdir)/$$i.new \ diff --git a/src/asdf-hack.lisp.in b/src/asdf-hack.lisp.in index 6358dab..54fa75f 100644 --- a/src/asdf-hack.lisp.in +++ b/src/asdf-hack.lisp.in @@ -2,5 +2,5 @@ (declaim (optimize debug)) (asdf:initialize-source-registry - `(:source-registry (:directory ,*load-pathname*) + `(:source-registry (:directory ,*load-truename*) :inherit-configuration)) diff --git a/src/builtin.lisp b/src/builtin.lisp index d07f539..6310741 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -278,6 +278,16 @@ static const SodClass *const ~A__cpl[] = { list)) (definst suppliedp-struct (stream) (flags var) + "Declare a `suppliedp' structure VAR containing a bit for each named FLAG. + + The output looks like this: + + struct { + unsigned FLAG: 1; + /* ... */ + } VAR; + + Note that this will not be valid C unless there is at least one flag." (format stream "~@" flags var)) diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index e5ead1b..7a2ff16 100644 --- a/src/c-types-impl.lisp +++ b/src/c-types-impl.lisp @@ -236,6 +236,7 @@ (setf (gethash ,name *simple-type-map*) ,(car types))) (defctype ,names ,(car types) :export ,export) (define-c-type-syntax ,(car names) (&rest quals) + ,(format nil "Return a possibly-qualified `~A' type." (car types)) `(make-simple-type ,',(car types) (list ,@quals))))))) (export 'find-simple-c-type) diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp index 0ce2cf3..98c6269 100644 --- a/src/c-types-proto.lisp +++ b/src/c-types-proto.lisp @@ -178,6 +178,15 @@ "Expands to code to construct a C type, using `expand-c-type-spec'." (expand-c-type-spec spec)) +(defmethod documentation ((symbol symbol) (doc-type (eql 'c-type))) + (let ((method (find-eql-specialized-method #'expand-c-type-spec 0 symbol))) + (and method (documentation method t)))) +(defmethod (setf documentation) + (string (symbol symbol) (doc-type (eql 'c-type))) + (let ((method (find-eql-specialized-method #'expand-c-type-spec 0 symbol))) + (unless method (error "No C type spec found with name `~S'." symbol)) + (setf (documentation method t) string))) + (export 'define-c-type-syntax) (defmacro define-c-type-syntax (name bvl &body body) "Define a C-type syntax function. @@ -195,6 +204,16 @@ (block ,name ,@body))) ',name)))) +(export 'c-type-form) +(defmethod documentation ((symbol symbol) (doc-type (eql 'c-type-form))) + (let ((method (find-eql-specialized-method #'expand-c-type-form 0 symbol))) + (and method (documentation method t)))) +(defmethod (setf documentation) + (string (symbol symbol) (doc-type (eql 'c-type-form))) + (let ((method (find-eql-specialized-method #'expand-c-type-form 0 symbol))) + (unless method (error "No C type spec found with name `~S'." symbol)) + (setf (documentation method t) string))) + (export 'c-type-alias) (defmacro c-type-alias (original &rest aliases) "Make ALIASES behave the same way as the ORIGINAL type." @@ -203,6 +222,7 @@ ,@(mapcar (lambda (alias) `(defmethod expand-c-type-form ((,head (eql ',alias)) ,tail) + ,(format nil "Alias for `~(~S~)'." original) (expand-c-type-form ',original ,tail))) aliases) ',aliases))) @@ -215,7 +235,10 @@ The VALUE is a C type S-expression, acceptable to `expand-c-type-spec'. It will be expanded once at run-time." (let* ((names (if (listp names) names (list names))) - (namevar (gensym "NAME")) + (namevar (gensym "NAME-")) + (avar (gensym "A")) + (tvar (gensym "T")) + (svar (gensym "S")) (typevar (symbolicate 'c-type- (car names)))) `(progn ,@(and export @@ -226,6 +249,11 @@ `(defmethod expand-c-type-spec ((,namevar (eql ',name))) ',typevar)) names)) + (dolist (,avar '(,@names)) + (let ((,tvar (format nil "Return a C `~A' type." + (with-output-to-string (,svar) + (pprint-c-type ,typevar ,svar nil))))) + (setf (documentation ,avar 'c-type) ,tvar))) 'names))) (export 'c-name-case) diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index a3f3e51..0c5040c 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -277,43 +277,57 @@ (constructor-name (symbolicate 'make- code '-inst)) (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword)) public))) - - ;; We have many jobs to do in the expansion. - `(progn - - ;; A class to hold the data. - (defclass ,class-name (inst) - ,(mapcar (lambda (public-slot private-slot key) - `(,private-slot :initarg ,key - :reader ,(symbolicate 'inst- public-slot))) - public private keys)) - - ;; A constructor to make an instance of the class. - (defun ,constructor-name (,@bvl) - (make-instance ',class-name ,@(mappend #'list keys public))) - - ;; A method on `inst-metric', to feed into inlining heuristics. - (defmethod inst-metric ((,inst-var ,class-name)) - (with-slots (,@private) ,inst-var - (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) private)))) - - ;; A method to actually produce the necessary output. - (defmethod print-object ((,inst-var ,class-name) ,streamvar) - (with-slots ,(mapcar #'list public private) ,inst-var - (if *print-escape* - (print-unreadable-object (,inst-var ,streamvar :type t) - (format ,streamvar "~@<~@{~S ~@_~S~^ ~_~}~:>" - ,@(mappend #'list keys public))) - (block ,code ,@body)))) - - ;; Maybe export all of this stuff. - ,@(and export `((export '(,class-name ,constructor-name - ,@(mapcar (lambda (slot) - (symbolicate 'inst- slot)) - public))))) - - ;; And try not to spam a REPL. - ',code)))) + (multiple-value-bind (docs decls body) (parse-body body) + + ;; We have many jobs to do in the expansion. + `(progn + + ;; A class to hold the data. + (defclass ,class-name (inst) + ,(mapcar (lambda (public-slot private-slot key) + `(,private-slot :initarg ,key + :reader + ,(symbolicate 'inst- public-slot))) + public private keys)) + + ;; A constructor to make an instance of the class. + (defun ,constructor-name (,@bvl) + (make-instance ',class-name ,@(mappend #'list keys public))) + + ;; A method on `inst-metric', to feed into inlining heuristics. + (defmethod inst-metric ((,inst-var ,class-name)) + (with-slots (,@private) ,inst-var + (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) + private)))) + + ;; A method to actually produce the necessary output. + (defmethod print-object ((,inst-var ,class-name) ,streamvar) + (with-slots ,(mapcar #'list public private) ,inst-var + (if *print-escape* + (print-unreadable-object (,inst-var ,streamvar :type t) + (format ,streamvar "~@<~@{~S ~@_~S~^ ~_~}~:>" + ,@(mappend #'list keys public))) + (block ,code + ,@(if (null decls) body + `((locally ,@decls ,@body))))))) + + ;; Maybe export all of this stuff. + ,@(and export `((export '(,class-name ,constructor-name + ,@(mapcar (lambda (slot) + (symbolicate 'inst- slot)) + public))))) + + ;; Remember the documentation. + ,@(and docs `((setf (get ',class-name 'inst-documentation) + ,@docs))) + + ;; And try not to spam a REPL. + ',code))))) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'inst))) + (get symbol 'inst-documentation)) +(defmethod (setf documentation) (doc (symbol symbol) (doc-type (eql 'inst))) + (setf (get symbol 'inst-documentation) doc)) ;; Formatting utilities. @@ -352,11 +366,20 @@ (export 'format-banner-comment) (defun format-banner-comment (stream control &rest args) + "Format a comment, built from a `format' CONTROL string and ARGS. + + The comment is wrapped in the usual `/* ... */' C comment delimiters, and + word-wrapped if necessary. If multiple lines are needed, then a column of + `*'s is left down the left hand side, and the final `*/' ends up properly + aligned on a line by itself." (format stream "~@~_ */~:>" control args)) ;; Important instruction classes. (definst var (stream :export t) (name %type &optional init) + "Declare a variable: TYPE NAME [= INIT]. + + This usually belongs in the DECLS of a `block'." (pprint-logical-block (stream nil) (pprint-c-type type stream name) (when init @@ -365,6 +388,16 @@ (definst function (stream :export t) (name %type body &optional %banner &rest banner-args) + "Define a function. + + The TYPE must be a function type. The BANNER and BANNER-ARGS are a + `format' control string and its argument list. Output looks like: + + /* BANNER */ + TYPE NAME(ARGS-FROM-TYPE) + { + BODY + }" (pprint-logical-block (stream nil) (when banner (apply #'format-banner-comment stream banner banner-args) @@ -375,24 +408,32 @@ ;; Expression statements. (definst expr (stream :export t) (%expr) + "An expression statement: EXPR;" (format stream "~A;" expr)) (definst set (stream :export t) (var %expr) + "An assignment statement: VAR = EXPR;" (format stream "~@<~A = ~2I~_~A;~:>" var expr)) (definst update (stream :export t) (var op %expr) + "An update statement: VAR OP= EXPR;" (format stream "~@<~A ~A= ~2I~_~A;~:>" var op expr)) ;; Special kinds of expressions. (definst call (stream :export t) (%func &rest args) + "A function-call expression: FUNC(ARGS)" (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" func args)) (definst cond (stream :export t) (%cond conseq alt) + "A conditional expression: COND ? CONSEQ : ALT" (format stream "~@<~A ~2I~@_~@~:>" cond conseq alt)) ;; Simple statements. (definst return (stream :export t) (%expr) + "A `return' statement: return [(EXPR)];" (format stream "return~@[ (~A)~];" expr)) (definst break (stream :export t) () + "A `break' statement: break;" (format stream "break;")) (definst continue (stream :export t) () + "A `continue' statement: continue;" (format stream "continue;")) ;; Compound statements. @@ -404,15 +445,31 @@ they get the formatting right between them.") (definst banner (stream :export t) (control &rest args) + "A banner comment, built from a `format' CONTROL string and ARGS. + + See `format-banner-comment' for more details." (pprint-logical-block (stream nil) (unless *first-statement-p* (pprint-newline :mandatory stream)) (apply #'format-banner-comment stream control args))) (export 'emit-banner) (defun emit-banner (codegen control &rest args) + "Emit a `banner-inst' to CODEGEN, with the given CONTROL and ARGS." (emit-inst codegen (apply #'make-banner-inst control args))) (definst block (stream :export t) (decls body) + "A compound statement. + + The output looks like + + { + DECLS + + BODY + } + + If controlled by `if', `while', etc., then the leading brace ends up on + the same line, following K&R conventions." (write-char #\{ stream) (pprint-newline :mandatory stream) (pprint-logical-block (stream nil) @@ -437,6 +494,7 @@ (write-char #\} stream)) (definst if (stream :export t) (%cond conseq &optional alt) + "An `if' statement: if (COND) CONSEQ [else ALT]" (let ((stmt "if")) (loop (format-compound-statement (stream conseq (if alt t nil)) (format stream "~A (~A)" stmt cond)) @@ -451,15 +509,18 @@ (return)))))) (definst while (stream :export t) (%cond body) + "A `while' statement: while (COND) BODY" (format-compound-statement (stream body) (format stream "while (~A)" cond))) (definst do-while (stream :export t) (body %cond) + "A `do'/`while' statement: do BODY while (COND);" (format-compound-statement (stream body :space) (write-string "do" stream)) (format stream "while (~A);" cond)) (definst for (stream :export t) (init %cond update body) + "A `for' statement: for (INIT; COND; UPDATE) BODY" (format-compound-statement (stream body) (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)" init cond update))) diff --git a/src/frontend.lisp b/src/frontend.lisp index 92573e7..6fb9d2e 100644 --- a/src/frontend.lisp +++ b/src/frontend.lisp @@ -31,12 +31,6 @@ (cl:in-package #:sod-frontend) ;;;-------------------------------------------------------------------------- -;;; Preparation for dumping. - -(clear-the-decks) -(exercise) - -;;;-------------------------------------------------------------------------- ;;; The main program. (defvar-unbound *option-parser* @@ -238,6 +232,6 @@ ~[~:; ~:*~D error~:P~[~:; and~]~:*~]~ ~[~:; ~:*~D warning~:P~]~%" *program-name* nerror nwarn)) - (exit (if (plusp nerror) 2 0))))))) + (uiop:quit (if (plusp nerror) 2 0))))))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/method-proto.lisp b/src/method-proto.lisp index e72044e..0a20f39 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -347,6 +347,15 @@ (definst convert-to-ilayout (stream :export t) (%class chain-head %expr) + "Expression to convert EXPR to point to its enclosing `ilayout'. + + Given a pointer EXPR which points into a direct instance of CLASS, + specifically to the `ichain' whose head class is CHAIN-HEAD, evaluate the + base address of the enclosing `ilayout' structure. + + The output looks like: + + SOD_ILAYOUT(CLASS, NICK, EXPR)" (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" class (sod-class-nickname chain-head) expr)) diff --git a/src/optparse.lisp b/src/optparse.lisp index d03b9cc..3b4b263 100644 --- a/src/optparse.lisp +++ b/src/optparse.lisp @@ -33,24 +33,6 @@ ;;;-------------------------------------------------------------------------- ;;; Program environment things. -(export 'exit) -(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning - sb-ext:compiler-note)) - (defun exit (&optional (code 0) &key abrupt) - "End program, returning CODE to the caller." - (declare (type (unsigned-byte 32) code) - ) - #.(car '(#+sbcl (sb-ext:exit :code code :abort abrupt) - #+cmu (if abrupt - (unix::void-syscall ("_exit" c-call:int) code) - (ext:quit code)) - #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code) - #+ecl (ext:quit code) - (unless (zerop code) - (format *error-output* - "~&Exiting unsuccessfully with code ~D.~%" code)))) - (abort))) - (export '(*program-name* *command-line*)) (defvar *program-name* "" "Program name, as retrieved from the command line.") @@ -62,34 +44,7 @@ "Retrieve command-line arguments. Set `*command-line*' and `*program-name*'." - - (setf *command-line* - (let ((uiop-package (find-package :uiop)) - (cll-package (find-package :cl-launch))) - (cons (or (and uiop-package - (funcall (intern "ARGV0" uiop-package))) - (and cll-package - (some (intern "GETENV" cll-package) - (list "__CL_ARGV0" "CL_LAUNCH_FILE"))) - #+sbcl (car sb-ext:*posix-argv*) - #+cmu (car ext:*command-line-strings*) - #+clisp (aref (ext:argv) 0) - #+ecl (ext:argv 0) - "sod") - (cond (uiop-package - (funcall (intern "COMMAND-LINE-ARGUMENTS" - uiop-package))) - (cll-package - (symbol-value (intern "*ARGUMENTS*" cll-package))) - (t #.(or (car '(#+sbcl (cdr sb-ext:*posix-argv*) - #+cmu (cdr ext:*command-line-strings*) - #+clisp (coerce (subseq (ext:argv) 8) - 'list) - #+ecl (loop for i from 1 - below (ext:argc) - collect (ext:argv i)))) - (error "Unsupported Lisp")))))) - + (setf *command-line* (cons (uiop:argv0) uiop:*command-line-arguments*) *program-name* (pathname-name (car *command-line*)))) ;;;-------------------------------------------------------------------------- @@ -144,7 +99,7 @@ (defun die (&rest args) "Report an error message and exit." (apply #'moan args) - (exit 1)) + (uiop:quit 1)) ;;;-------------------------------------------------------------------------- ;;; The main option parser. @@ -164,9 +119,15 @@ (lambda (o s k) (declare (ignore k)) (print-unreadable-object (o s :type t) - (format s "~@[-~C, ~]~@[--~A~]~ - ~*~@[~2:*~:[=~A~;[=~A]~]~]~ - ~@[ ~S~]" + (format s "~*~:[~2:*~:[~3*~@[~S~]~ + ~;~ + ~:*-~C~ + ~2*~@[~:*~:[ ~A~;[~A]~]~]~ + ~@[ ~S~]~]~ + ~;~ + ~2:*~@[-~C, ~]--~A~ + ~*~@[~:*~:[=~A~;[=~A]~]~]~ + ~@[ ~S~]~]" (opt-short-name o) (opt-long-name o) (opt-arg-optional-p o) @@ -562,7 +523,7 @@ (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name)))) (multiple-value-bind (docs decls body) (parse-body body) `(progn - (setf (get ',name 'opthandler) ',func) + (setf (get ',name 'opthandler-function) ',func) (defun ,func (,var ,arg ,@args) ,@docs ,@decls (declare (ignorable ,arg)) @@ -570,6 +531,16 @@ (block ,name ,@body))) ',name)))) +(export 'opthandler) +(defmethod documentation ((symbol symbol) (doc-type (eql 'opthandler))) + (let ((func (get symbol 'opthandler-function))) + (and func (documentation func 'function)))) +(defmethod (setf documentation) + (string (symbol symbol) (doc-type (eql 'opthandler))) + (let ((func (get symbol 'optmacro-function))) + (unless func (error "No option handler defined with name `~S'." symbol)) + (setf (documentation func 'function) string))) + (defun parse-c-integer (string &key radix (start 0) end) "Parse (a substring of) STRING according to the standard C rules. @@ -623,10 +594,12 @@ (export 'invoke-option-handler) (defun invoke-option-handler (handler loc arg args) - "Call HANDLER, giving it LOC to update, the option-argument ARG, and the - remaining ARGS." + "Call an option HANDLER. + + The handler is invoked to update the locative LOC, given an + option-argument ARG, and the remaining ARGS." (apply (if (functionp handler) handler - (fdefinition (get handler 'opthandler))) + (fdefinition (get handler 'opthandler-function))) loc arg args)) ;;;-------------------------------------------------------------------------- @@ -634,26 +607,30 @@ (export 'set) (defopthandler set (var) (&optional (value t)) - "Sets VAR to VALUE; defaults to t." + "Sets VAR to VALUE; defaults to `t'." (setf var value)) (export 'clear) (defopthandler clear (var) (&optional (value nil)) - "Sets VAR to VALUE; defaults to nil." + "Sets VAR to VALUE; defaults to `'nil'." (setf var value)) (export 'inc) (defopthandler inc (var) (&optional max (step 1)) - "Increments VAR by STEP (defaults to 1), but not greater than MAX (default - nil for no maximum). No errors are signalled." + "Increments VAR by STEP (defaults to 1). + + If MAX is not nil then VAR will not be made larger than MAX. No errors + are signalled." (incf var step) (when (and max (>= var max)) (setf var max))) (export 'dec) (defopthandler dec (var) (&optional min (step 1)) - "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil - for no maximum). No errors are signalled." + "Decrements VAR by STEP (defaults to 1). + + If MIN is not nil, then VAR will not be made smaller than MIN. No errors + are signalled." (decf var step) (when (and min (<= var min)) (setf var min))) @@ -760,11 +737,22 @@ structure each." (multiple-value-bind (docs decls body) (parse-body body) `(progn - (setf (get ',name 'optmacro) (lambda ,args - ,@docs ,@decls - (block ,name ,@body))) + (setf (get ',name 'optmacro-function) + (lambda ,args + ,@docs ,@decls + (block ,name ,@body))) ',name))) +(export 'optmacro) +(defmethod documentation ((symbol symbol) (doc-type (eql 'optmacro))) + (let ((func (get symbol 'optmacro-function))) + (and func (documentation func t)))) +(defmethod (setf documentation) + (string (symbol symbol) (doc-type (eql 'optmacro))) + (let ((func (get symbol 'optmacro-function))) + (unless func (error "No option macro defined with name `~S'." symbol)) + (setf (documentation func t) string))) + (export 'parse-option-form) (eval-when (:compile-toplevel :load-toplevel :execute) (defun parse-option-form (form) @@ -820,7 +808,8 @@ (:opt-arg (setf arg-name (cadr f)) (setf arg-optional-p t)) (:doc (setf doc (doc (cdr f)))) - (t (let ((handler (get (car f) 'opthandler))) + (t (let ((handler (get (car f) + 'opthandler-function))) (unless handler (error "No handler `~S' defined." (car f))) (let* ((var (cadr f)) @@ -895,7 +884,7 @@ ((and (consp form) (symbolp (car form))) (values (car form) (cdr form))) (t (values nil nil))) - (let ((macro (and sym (get sym 'optmacro)))) + (let ((macro (and sym (get sym 'optmacro-function)))) (if macro (apply macro args) (list (parse-option-form form)))))) @@ -908,9 +897,11 @@ (defun print-text (string &optional (stream *standard-output*) &key (start 0) (end nil)) - "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and - newlines in the obvious way. Stuff between square brackets is not broken: - this makes usage messages work better." + "Prints and line-breaks STRING to a pretty-printed STREAM. + + The string is broken at whitespace and newlines in the obvious way. + Stuff between square brackets is not broken: this makes usage messages + work better." (let ((i start) (nest 0) (splitp nil)) @@ -942,8 +933,11 @@ (export 'simple-usage) (defun simple-usage (opts &optional mandatory-args) - "Build a simple usage list from a list of options, and (optionally) - mandatory argument names." + "Build a simple usage list. + + The usage list is constructed from a list OPTS of `option' values, and + a list MANDATORY-ARGS of mandatory argument names; the latter defaults to + nil if omitted." (let (short-simple long-simple short-arg long-arg) (dolist (o opts) (cond ((not (and (opt-documentation o) @@ -1049,9 +1043,10 @@ (export 'sanity-check-option-list) (defun sanity-check-option-list (opts) - "Check the option list OPTS for basic sanity. Reused short and long option - names are diagnosed. Maybe other problems will be reported later. - Returns a list of warning strings." + "Check the option list OPTS for basic sanity. + + Reused short and long option names are diagnosed. Maybe other problems + will be reported later. Returns a list of warning strings." (let ((problems nil) (longs (make-hash-table :test #'equal)) (shorts (make-hash-table))) @@ -1085,7 +1080,7 @@ (export 'die-usage) (defun die-usage () (do-usage *error-output*) - (exit 1)) + (uiop:quit 1)) (defun opt-help (arg) (declare (ignore arg)) @@ -1095,15 +1090,15 @@ (null nil) ((or function symbol) (terpri) (funcall *help*))) (format t "~&") - (exit 0)) + (uiop:quit 0)) (defun opt-version (arg) (declare (ignore arg)) (format t "~A, version ~A~%" *program-name* *version*) - (exit 0)) + (uiop:quit 0)) (defun opt-usage (arg) (declare (ignore arg)) (do-usage) - (exit 0)) + (uiop:quit 0)) (export 'help-options) (defoptmacro help-options (&key (short-help #\h) diff --git a/src/sod-frontend.asd.in b/src/sod-frontend.asd.in index d508bae..1710100 100644 --- a/src/sod-frontend.asd.in +++ b/src/sod-frontend.asd.in @@ -29,33 +29,12 @@ (cl:in-package #:sod-frontend-sysdef) -#|@-auto-@|# (load (merge-pathnames "auto.lisp" *load-pathname*)) +#|@-auto-@|# (load (make-pathname :name "AUTO" :type "LISP" :version :newest + :case :common :defaults *load-pathname*)) ;;;-------------------------------------------------------------------------- ;;; Definition. -(defsystem sod-frontend - ;; Boring copyright stuff. - :version #.*sysdef-version* - :author "Mark Wooding" - :license "GNU General Public License, version 2 or later" - #|@-path-@|# :pathname "@srcdir@" - - ;; Documentation. - :description "A Sensible Object Design for C, command-line frontend." - - :long-description - "The Sensible Object Design (SOD) is a fairly simple, yet powerful object - system for plain old C. - - This system provides a command-line interface to the SOD translator. It's - a separate system because it has additional dependencies and - Lisp-system-specific code." - - :depends-on ("cl-launch" "sod") - - :components - ((:file "frontend"))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/sod-test.asd.in b/src/sod-test.asd.in index c65f4dc..72fc649 100644 --- a/src/sod-test.asd.in +++ b/src/sod-test.asd.in @@ -29,39 +29,13 @@ (cl:in-package #:sod-test-sysdef) -#|@-auto-@|# (load (merge-pathnames "auto.lisp" *load-pathname*)) +#|@-auto-@|# (load (make-pathname :name "AUTO" :type "LISP" :version :newest + :case :common :defaults *load-pathname*)) ;;;-------------------------------------------------------------------------- ;;; Definition. -(defsystem sod-test - ;; Boring copyright stuff. - :version #.*sysdef-version* - :author "Mark Wooding" - :license "GNU General Public License, version 2 or later" - #|@-path-@|# :pathname "@srcdir@" - - ;; Documentation. - :description "Tests for the Sensible Object Design translator." - - :long-description - "This system provides unit tests for the Sod translator." - - :depends-on ("sod" "xlunit") - - :components - ((:file "test-base") - - ;; Test the parser edifice. - (:module "parser" :depends-on ("test-base") :components - ((:file "parser-test") - (:file "scanner-charbuf-test"))) - - ;; The actual tests. - (:file "c-types-test" :depends-on ("test-base")) - (:file "codegen-test" :depends-on ("test-base")) - (:file "lexer-test" :depends-on ("test-base")))) ;;;-------------------------------------------------------------------------- ;;; Testing. diff --git a/src/sod.asd.in b/src/sod.asd.in index 894d50b..82839dd 100644 --- a/src/sod.asd.in +++ b/src/sod.asd.in @@ -24,13 +24,13 @@ ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (cl:defpackage #:sod-sysdef - (:use #:common-lisp #:asdf) + (:use #:common-lisp #:asdf #:uiop) (:export #:*version*)) (cl:in-package #:sod-sysdef) #|@-auto-@|# (load (make-pathname :name "AUTO" :type "LISP" :version :newest - :case :common :defaults *load-pathname*)) +#|@-del-@|# :case :common :defaults *load-pathname*)) #+cmu (require :gray-streams) @@ -63,124 +63,191 @@ statically predicting which superclass's method to delegate to. Multiple inheritance makes this approach (taken by C++) fail: the right next method might be an unknown sibling, and two siblings might - be in either order depending on descendents. + be in either order depending on descendants. * Minimal runtime support requirements, so that it's suitable for use wherever C is -- e.g., interfacing to other languages." + :depends-on ("uiop") + :in-order-to ((test-op (load-op "sod/test"))) + :perform (test-op (op comp) + (let ((result (symbol-call :sod-test :run-tests))) + (unless (symbol-call :xlunit :was-successful result) + (error "Failed test")))) + :components - ((:file "utilities") - (:file "optparse") - - ;; Parser equipment. This is way more elaborate than it needs to be, but - ;; it was interesting, and it may well get split off into a separate - ;; library. - (:module "parser" :depends-on ("utilities") :components - ((:file "package") - - ;; File location protocol (including error reporting). - (:file "floc-proto" :depends-on ("package")) - (:file "floc-impl" :depends-on ("floc-proto")) - - ;; Position-aware streams. - (:file "streams-proto" :depends-on ("package")) - (:file "streams-impl" :depends-on ("streams-proto" "floc-proto")) - - ;; Scanner protocol, and various scanner implementations. - (:file "scanner-proto" :depends-on ("package")) - (:file "scanner-impl" :depends-on ("scanner-proto")) - (:file "scanner-charbuf-impl" :depends-on - ("scanner-proto" "floc-proto" "streams-proto")) - (:file "scanner-token-impl" :depends-on ("scanner-proto")) - - ;; Parser notation macro support. - (:file "parser-proto" :depends-on ("package")) - (:file "parser-impl" :depends-on ("parser-proto")) - - ;; Expression parser support. - (:file "parser-expr-proto" :depends-on ("parser-proto")) - (:file "parser-expr-impl" :depends-on ("parser-expr-proto")) - - ;; Stitching parsers to scanners. - (:file "scanner-context-impl" :depends-on - ("parser-proto" "scanner-proto")))) - - (:file "package" :depends-on ("utilities" "parser")) - - ;; Lexical analysis. - (:file "lexer-proto" :depends-on ("package" "parser")) - (:file "lexer-impl" :depends-on ("lexer-proto")) - (:file "fragment-parse" :depends-on ("lexer-proto")) - - ;; C type representation protocol. - (:file "c-types-proto" :depends-on ("package")) - (:file "c-types-impl" :depends-on ("c-types-proto" "codegen-proto")) - (:file "c-types-parse" :depends-on - ("c-types-proto" "c-types-class-impl" "fragment-parse")) - - ;; Property set protocol. - (:file "pset-proto" :depends-on ("package" "c-types-proto")) - (:file "pset-impl" :depends-on ("pset-proto" "module-proto")) - (:file "pset-parse" :depends-on ("pset-proto" "lexer-proto")) - - ;; Code generation protocol. - (:file "codegen-proto" :depends-on ("module-proto")) - (:file "codegen-impl" :depends-on ("codegen-proto")) - - ;; Modules. - (:file "module-proto" :depends-on ("pset-proto" "package")) - (:file "module-impl" :depends-on - ("module-proto" "pset-proto" "c-types-class-impl" "builtin")) - (:file "builtin" :depends-on - ("module-proto" "pset-proto" "c-types-impl" "c-types-class-impl" - "classes" "class-layout-proto" "method-proto")) - (:file "module-parse" :depends-on - ("class-make-proto" "class-finalize-proto" - "fragment-parse" "lexer-proto" "module-impl")) - (:file "module-output" :depends-on ("module-impl" "output-proto")) - - ;; Output. - (:file "output-proto" :depends-on ("package")) - (:file "output-impl" :depends-on ("output-proto")) - - ;; Class representation. - (:file "classes" :depends-on ("package" "c-types-proto")) - (:file "c-types-class-impl" :depends-on ("classes" "module-proto")) - (:file "class-utilities" :depends-on - ("classes" "codegen-impl" "pset-impl" - "c-types-impl" "c-types-class-impl")) - - ;; Class construction. - (:file "class-make-proto" :depends-on ("class-utilities")) - (:file "class-make-impl" :depends-on ("class-make-proto")) - - ;; Class layout. - (:file "class-layout-proto" :depends-on ("class-utilities")) - (:file "class-layout-impl" :depends-on - ("class-layout-proto" "method-proto")) - - ;; Class finalization. - (:file "class-finalize-proto" :depends-on ("class-utilities")) - (:file "class-finalize-impl" :depends-on ("class-finalize-proto")) - - ;; Method generation. - (:file "method-proto" :depends-on ("class-make-proto")) - (:file "method-impl" :depends-on ("method-proto")) - (:file "method-aggregate" :depends-on ("method-impl")) - - ;; Class output. - (:file "class-output" :depends-on - ("classes" "class-layout-impl" "method-impl" "output-proto")) - - ;; Finishing touches of various kinds. - (:file "final" :depends-on ("builtin" "module-output" "class-output")))) + ((:file "utilities") + (:file "optparse") + + ;; Parser equipment. This is way more elaborate than it needs to be, + ;; but it was interesting, and it may well get split off into a separate + ;; library. + (:module "parser" + :depends-on ("utilities") + :components + ((:file "package") + + ;; File location protocol (including error reporting). + (:file "floc-proto" :depends-on ("package")) + (:file "floc-impl" :depends-on ("floc-proto")) + + ;; Position-aware streams. + (:file "streams-proto" :depends-on ("package")) + (:file "streams-impl" + :depends-on ("streams-proto" "floc-proto")) + + ;; Scanner protocol, and various scanner implementations. + (:file "scanner-proto" :depends-on ("package")) + (:file "scanner-impl" :depends-on ("scanner-proto")) + (:file "scanner-charbuf-impl" + :depends-on + ("scanner-proto" "floc-proto" "streams-proto")) + (:file "scanner-token-impl" :depends-on ("scanner-proto")) + + ;; Parser notation macro support. + (:file "parser-proto" :depends-on ("package")) + (:file "parser-impl" :depends-on ("parser-proto")) + + ;; Expression parser support. + (:file "parser-expr-proto" :depends-on ("parser-proto")) + (:file "parser-expr-impl" :depends-on ("parser-expr-proto")) + + ;; Stitching parsers to scanners. + (:file "scanner-context-impl" + :depends-on ("parser-proto" "scanner-proto")))) + + (:file "package" :depends-on ("utilities" "parser")) + + ;; Lexical analysis. + (:file "lexer-proto" :depends-on ("package" "parser")) + (:file "lexer-impl" :depends-on ("lexer-proto")) + (:file "fragment-parse" :depends-on ("lexer-proto")) + + ;; C type representation protocol. + (:file "c-types-proto" :depends-on ("package")) + (:file "c-types-impl" :depends-on ("c-types-proto" "codegen-proto")) + (:file "c-types-parse" + :depends-on + ("c-types-proto" "c-types-class-impl" "fragment-parse")) + + ;; Property set protocol. + (:file "pset-proto" :depends-on ("package" "c-types-proto")) + (:file "pset-impl" :depends-on ("pset-proto" "module-proto")) + (:file "pset-parse" :depends-on ("pset-proto" "lexer-proto")) + + ;; Code generation protocol. + (:file "codegen-proto" :depends-on ("module-proto")) + (:file "codegen-impl" :depends-on ("codegen-proto")) + + ;; Modules. + (:file "module-proto" :depends-on ("pset-proto" "package")) + (:file "module-impl" + :depends-on + ("module-proto" "pset-proto" "c-types-class-impl" "builtin")) + (:file "builtin" + :depends-on + ("module-proto" "pset-proto" + "c-types-impl" "c-types-class-impl" + "classes" "class-layout-proto" "method-proto")) + (:file "module-parse" + :depends-on + ("class-make-proto" "class-finalize-proto" + "fragment-parse" "lexer-proto" "module-impl")) + (:file "module-output" :depends-on ("module-impl" "output-proto")) + + ;; Output. + (:file "output-proto" :depends-on ("package")) + (:file "output-impl" :depends-on ("output-proto")) + + ;; Class representation. + (:file "classes" :depends-on ("package" "c-types-proto")) + (:file "c-types-class-impl" :depends-on ("classes" "module-proto")) + (:file "class-utilities" + :depends-on + ("classes" "codegen-impl" "pset-impl" + "c-types-impl" "c-types-class-impl")) + + ;; Class construction. + (:file "class-make-proto" :depends-on ("class-utilities")) + (:file "class-make-impl" :depends-on ("class-make-proto")) + + ;; Class layout. + (:file "class-layout-proto" :depends-on ("class-utilities")) + (:file "class-layout-impl" + :depends-on ("class-layout-proto" "method-proto")) + + ;; Class finalization. + (:file "class-finalize-proto" :depends-on ("class-utilities")) + (:file "class-finalize-impl" :depends-on ("class-finalize-proto")) + + ;; Method generation. + (:file "method-proto" :depends-on ("class-make-proto")) + (:file "method-impl" :depends-on ("method-proto")) + (:file "method-aggregate" :depends-on ("method-impl")) + + ;; Class output. + (:file "class-output" + :depends-on + ("classes" "class-layout-impl" "method-impl" "output-proto")) + + ;; Finishing touches of various kinds. + (:file "final" :depends-on ("builtin" "module-output" "class-output")))) + +(defsystem sod/frontend + + ;; Boring copyright stuff. + :version #.*sysdef-version* + :author "Mark Wooding" + :license "GNU General Public License, version 2 or later" + #|@-path-@|# :pathname "@srcdir@" + + ;; Documentation. + :description "A Sensible Object Design for C, command-line frontend." + + :long-description + "The Sensible Object Design (SOD) is a fairly simple, yet powerful object + system for plain old C. + + This system provides a command-line interface to the SOD translator. It's + a separate system because it has additional dependencies and + Lisp-system-specific code." + + :entry-point "sod-frontend:main" + :build-pathname "sod" + :depends-on ("uiop" "sod") + :components ((:file "frontend"))) ;;;-------------------------------------------------------------------------- ;;; Testing. -(defmethod perform ((op test-op) (component (eql (find-system "sod")))) - (declare (ignore op component)) - (handler-bind (((or warning style-warning) #'muffle-warning)) - (operate 'test-op "sod-test"))) +(defsystem sod/test + + ;; Boring copyright stuff. + :version #.*sysdef-version* + :author "Mark Wooding" + :license "GNU General Public License, version 2 or later" + #|@-path-@|# :pathname "@srcdir@" + + ;; Documentation. + :description "Tests for the Sensible Object Design translator." + + :long-description + "This system provides unit tests for the Sod translator." + + :depends-on ("sod" "xlunit") + + :components + ((:file "test-base") + + ;; Test the parser edifice. + (:module "parser" + :depends-on ("test-base") + :components ((:file "parser-test") + (:file "scanner-charbuf-test"))) + + ;; The actual tests. + (:file "c-types-test" :depends-on ("test-base")) + (:file "codegen-test" :depends-on ("test-base")) + (:file "lexer-test" :depends-on ("test-base")))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/utilities.lisp b/src/utilities.lisp index 82a387b..9ff9daf 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -404,6 +404,17 @@ except where overridden by INITARGS." (apply #'copy-instance-using-class (class-of object) object initargs)) +(export 'find-eql-specialized-method) +(defun find-eql-specialized-method (function arg object) + "Return a method defined on FUNCTION whose ARGth argument is + `eql'-specialized on OBJECT." + (find-if (lambda (method) + (let ((spec (nth arg (method-specializers method)))) + (and spec + (typep spec 'eql-specializer) + (eq (eql-specializer-object spec) object)))) + (generic-function-methods function))) + (export '(generic-function-methods method-specializers eql-specializer eql-specializer-object)) diff --git a/vars.am b/vars.am index 1409100..ed0c03a 100644 --- a/vars.am +++ b/vars.am @@ -77,6 +77,13 @@ V_SUBST_0 = @echo " SUBST $@"; SUBST = $(V_SUBST)$(confsubst) ###-------------------------------------------------------------------------- +### Wrangling ASDF. + +ASDF_ENV = \ + CL_SOURCE_REGISTRY=$$(cd $(top_builddir)/src && pwd): \ + ASDF_OUTPUT_TRANSLATIONS=$$(cd $(top_srcdir)/src && pwd):$$(cd $(top_builddir)/src && pwd): + +###-------------------------------------------------------------------------- ### Translating SOD input files. ## The tool location. -- 2.11.0