@@@ mess!

diff --git a/NOTES b/NOTES
index c22de92..07e1180 100644 (file)
--- a/NOTES
+++ b/NOTES
@@ -6,15 +6,18 @@
     ~progn~-combination, and one for producing output, which subclasses
     can override.
 
     ~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
 
 
 * COMMENT Emacs cruft
 

diff --git a/configure.ac b/configure.ac
index 44f061c..1a45f9e 100644 (file)
--- a/configure.ac
+++ b/configure.ac
@@ -71,27 +71,17 @@ AC_SUBST([ASDF_VERSION])
 dnl--------------------------------------------------------------------------
 dnl Common Lisp things.
 
 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])
 
 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])
 
 AC_SUBST([fasl])
 AC_MSG_RESULT([.$fasl])
 

diff --git a/doc/Makefile.am b/doc/Makefile.am
index 052247f..89484a9 100644 (file)
--- 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)
 
 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') && \
 
 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 \
 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
 
                --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 --------------------------------------------------
 ###----- That's all, folks --------------------------------------------------

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 7f8414e..bcf22ae 100644 (file)
--- 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
 
 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
   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                                        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
   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
   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
   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
   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
   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
   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
   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
   option-parser-p                               function
   optionp                                       function
   options                                       macro

+  optmacro

   parse-option-form                             function
   cl:read                                       function opthandler
   sanity-check-option-list                      function
   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
   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
   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 (executable)
--- 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/^(.+)://;
     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; }
       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 '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; }
        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;
 }
 
   close $fh;
 }
 

-my %DEF = map { $_ => 1 }
+my %DEF = map { $_ => "<magic>" }

   "cls:array", "cls:class", "cls:error", "cls:float", "cls:function",
   "cls:list", "cls:string",
   "const:nil",
   "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',
   '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) = @_;
 
 sub scanaux (\%$) {
   my ($def, $f) = @_;


@@ -68,15 +76,23 @@ sub scanaux (\%$) {
   open my $fh, "<", "$AUXDIR$f";
   while (<$fh>) {
     chomp;
   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;
 }
 
   }
   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;
 
 
 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 =~ /^([^:]+):(.*)$/;
 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 "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 ($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 =~ /^([^:]+):(.*)$/;
   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 "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") { }
   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") { }
         $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})"; }
 }
   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 (file)
--- 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}
         @|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.
 \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}
 
   into.
 \end{describe}
 

+\begin{describe}{cty}{lisp @<form>^*}
+  Evaluates the @<form>s as an implicit @|progn|, and returns the value(s) of
+  the final @<form> as a C type.
+\end{describe}
+

 \begin{describe}{gf}
     {print-c-type @<stream> @<type> \&optional @<colon> @<atsign>}
   Print the C type object @<type> to @<stream> in S-expression form.  The
 \begin{describe}{gf}
     {print-c-type @<stream> @<type> \&optional @<colon> @<atsign>}
   Print the C type object @<type> to @<stream> in S-expression form.  The


@@ -193,6 +198,28 @@ type specifier.  Type specifiers fit into two syntactic categories.
   default method.
 \end{describe}
 
   default method.
 \end{describe}
 

+\begin{describe*}
+    {\dhead{sym}{c-type}
+     \dhead{meth}{symbol,(eql 'c-type)}
+                 {documentation (@<symbol> symbol)
+                                (@<doc-type> (eql 'c-type))}
+     \dhead{meth}{symbol,(eql 'c-type)}
+                 {setf \=(documentation (@<symbol> symbol)
+                                        (@<doc-type> (eql 'c-type))) \\
+                       \>@<string>}}
+\end{describe*}
+
+\begin{describe*}
+    {\dhead{sym}{c-type-form}
+     \dhead{meth}{symbol,(eql 'c-type-form)}
+                 {documentation (@<symbol> symbol)
+                                (@<doc-type> (eql 'c-type-form))}
+     \dhead{meth}{symbol,(eql 'c-type-form)}
+                 {setf \=(documentation (@<symbol> symbol)
+                                        (@<doc-type> (eql 'c-type-form))) \\
+                       \>@<string>}}
+\end{describe*}
+

 
 \subsection{Comparing C types} \label{sec:clang.c-types.cmp}
 
 
 \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.
 
 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 @<subtype> @<specifier>^*}}

   A type which carries storage specifiers.  The @<subtype> is the actual
   type, and may be any C type; the @<specifiers> are a list of
   storage-specifier objects.
 
   A type which carries storage specifiers.  The @<subtype> is the actual
   type, and may be any C type; the @<specifiers> are a list of
   storage-specifier objects.
 

-  The type specifier @|(specs @<subtype> @<specifier>^*)| wraps the
-  @<subtype> in a @|c-storage-specifiers-type|, carrying the @<specifier>s,
-  which are a list of storage specifiers in S-expression notation.
-\end{describe}
+  The type specifier @|specs| wraps the @<subtype> in a
+  @|c-storage-specifiers-type|, carrying the @<specifier>s, which are a list
+  of storage specifiers in S-expression notation.
+\end{describe*}

 
 \begin{describe}{fun}{c-type-specifiers @<type> @> @<list>}
   Returns the list of type specifiers attached to the @<type> object, which
 
 \begin{describe}{fun}{c-type-specifiers @<type> @> @<list>}
   Returns the list of type specifiers attached to the @<type> object, which


@@ -454,7 +483,13 @@ complicated objects.
   @|(c-type (specs @<subtype> (@<head> . @<tail>)))|.
 \end{describe}
 
   @|(c-type (specs @<subtype> (@<head> . @<tail>)))|.
 \end{describe}
 

+\begin{describe}{cstg}{lisp @<form>^*}
+  Evaluates the @<form>s as an implicit @|progn|, and returns the value(s) of
+  the final @<form> as a storage-specifier.
+\end{describe}
+

 \begin{describe}{gf}{pprint-c-storage-specifier @<spec> @<stream>}
 \begin{describe}{gf}{pprint-c-storage-specifier @<spec> @<stream>}

+  Prints the storage-specifier @<spec> to @<stream>, in C syntax.

 \end{describe}
 
 \begin{describe}{gf}
 \end{describe}
 
 \begin{describe}{gf}


@@ -474,14 +509,16 @@ complicated objects.
   @<base-type>.
 \end{describe}
 
   @<base-type>.
 \end{describe}
 

-\begin{describe}{cls}{alignas-storage-specifier () \&key :alignment}
-  The class of @|_Alignas| storage specifiers; an instance denotes the
-  specifier @|_Alignas(@<alignment>)|.  The @<alignment> parameter may be any
-  printable object, but is usually a string or C fragment.
-
-  The storage specifier form @|(alignas @<alignment>)| returns a storage
-  specifier @|_Alignas(@<alignment>)|, where @<alignment> is evaluated.
-\end{describe}
+\begin{describe*}
+    {\dhead{cls}{alignas-storage-specifier () \&key :alignment}
+     \dhead{cstg}{alignas @<alignment>}}
+  The class of \mbox{@|_Alignas|} storage specifiers; an instance denotes the
+  specifier \mbox{@|_Alignas(@<alignment>)|}.  The @<alignment> 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(@<alignment>)|}, where @<alignment> is evaluated.
+\end{describe*}

 
 
 \subsection{Leaf types} \label{sec:clang.c-types.leaf}
 
 
 \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.
 
   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
 
   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}
 
   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 @<tag> @<qualifier>^*}}

   Represents a C enumerated type.  An instance denotes the C type @|enum|
   @<tag>.  See the direct superclass @|tagged-c-type| for details.
 
   Represents a C enumerated type.  An instance denotes the C type @|enum|
   @<tag>.  See the direct superclass @|tagged-c-type| for details.
 

-  The type specifier @|(enum @<tag> @<qualifier>^*)| returns the (unique
-  interned) enumerated type with the given @<tag> and @<qualifier>s (all
-  evaluated).
-\end{describe}
+  The type specifier @|enum| returns the (unique interned) enumerated type
+  with the given @<tag> and @<qualifier>s (all evaluated).
+\end{describe*}

 
 \begin{describe}{fun}
     {make-enum-type @<tag> \&optional @<qualifiers> @> @<c-enum-type>}
 
 \begin{describe}{fun}
     {make-enum-type @<tag> \&optional @<qualifiers> @> @<c-enum-type>}


@@ -681,14 +725,15 @@ In Sod, the leaf types are
   keywords).
 \end{describe}
 
   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 @<tag> @<qualifier>^*}}

   Represents a C structured type.  An instance denotes the C type @|struct|
   @<tag>.  See the direct superclass @|tagged-c-type| for details.
 
   Represents a C structured type.  An instance denotes the C type @|struct|
   @<tag>.  See the direct superclass @|tagged-c-type| for details.
 

-  The type specifier @|(struct @<tag> @<qualifier>^*)| returns the (unique
-  interned) structured type with the given @<tag> and @<qualifier>s (all
-  evaluated).
-\end{describe}
+  The type specifier @|struct| returns the (unique interned) structured type
+  with the given @<tag> and @<qualifier>s (all evaluated).
+\end{describe*}

 
 \begin{describe}{fun}
     {make-struct-type @<tag> \&optional @<qualifiers> @> @<c-struct-type>}
 
 \begin{describe}{fun}
     {make-struct-type @<tag> \&optional @<qualifiers> @> @<c-struct-type>}


@@ -697,15 +742,17 @@ In Sod, the leaf types are
   keywords).
 \end{describe}
 
   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 @<tag> @<qualifier>^*}}

   Represents a C union type.  An instance denotes the C type @|union|
   @<tag>.  See the direct superclass @|tagged-c-type|
   for details.
 
   Represents a C union type.  An instance denotes the C type @|union|
   @<tag>.  See the direct superclass @|tagged-c-type|
   for details.
 

-  The type specifier @|(union @<tag> @<qualifier>^*)| returns the (unique
-  interned) union type with the given @<tag> and @<qualifier>s (all
-  evaluated).
-\end{describe}
+  The type specifier @|union| returns the (unique interned) union type with
+  the given @<tag> and @<qualifier>s (all evaluated).
+\end{describe*}
+

 \begin{describe}{fun}
     {make-union-type @<tag> \&optional @<qualifiers> @> @<c-union-type>}
   Return the (unique interned) C type object for the union C type whose tag
 \begin{describe}{fun}
     {make-union-type @<tag> \&optional @<qualifiers> @> @<c-union-type>}
   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.
 
 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 @<type-spec> @<qualifier>^*}}

   Represents an atomic type.  An instance denotes the C type
   @|_Atomic(@<subtype>)|.
 
   Represents an atomic type.  An instance denotes the C type
   @|_Atomic(@<subtype>)|.
 


@@ -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.
 
   have matching qualifiers.  It is possible, though probably not useful, to
   have an atomic-qualified atomic type.
 

-  The type specifier @|(atomic @<type-spec> @<qualifier>^*)| returns a type
-  qualified atomic @<subtype>, where @<subtype> is the type specified by
-  @<type-spec> and the @<qualifier>s are qualifier keywords (which are
-  evaluated).
-\end{describe}
+  The type specifier @|atomic| returns a type qualified atomic @<subtype>,
+  where @<subtype> is the type specified by @<type-spec> and the
+  @<qualifier>s are qualifier keywords (which are evaluated).
+\end{describe*}

 
 \begin{describe}{fun}
     {make-atomic-type @<c-type> \&optional @<qualifiers> @> @<c-atomic-type>}
 
 \begin{describe}{fun}
     {make-atomic-type @<c-type> \&optional @<qualifiers> @> @<c-atomic-type>}


@@ -763,24 +811,29 @@ about which you use.
 Pointers are compound types.  The subtype of a pointer type is the type it
 points to.
 
 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}{* @<type-spec> @<qualifier>^*}
+     \dhead{cty}{string}
+     \dhead{cty}{const-string}}

   Represents a C pointer type.  An instance denotes the C type @<subtype>
   @|*|@<qualifiers>.
 
   The @<subtype> may be any C type.  Two pointer types are equal if and only
   if their subtypes are equal and they have matching qualifiers.
 
   Represents a C pointer type.  An instance denotes the C type @<subtype>
   @|*|@<qualifiers>.
 
   The @<subtype> 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 @|(* @<type-spec> @<qualifier>^*)| returns a type
-  qualified pointer-to-@<subtype>, where @<subtype> is the type specified by
-  @<type-spec> and the @<qualifier>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-@<subtype>,
+  where @<subtype> is the type specified by @<type-spec> and the
+  @<qualifier>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.
 
   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 @<c-type> \&optional @<qualifiers>
 
 \begin{describe}{fun}
     {make-pointer-type @<c-type> \&optional @<qualifiers>


@@ -796,7 +849,11 @@ points to.
 Arrays implement the compound-type protocol.  The subtype of an array type is
 the array element type.
 
 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}{[] @<type-spec> @<dimension>^*}}
+  \desclabel{cty}{array}[|(]
+  \desclabel{cty}{vec}[|(]

   Represents a multidimensional C array type.  The @<dimensions> are a list
   of dimension specifiers $d_0$, $d_1$, \ldots, $d_{n-1}$; an instance then
   denotes the C type @<subtype> @|[$d_0$][$d_1$]$\ldots$[$d_{n-1}$]|.  An
   Represents a multidimensional C array type.  The @<dimensions> are a list
   of dimension specifiers $d_0$, $d_1$, \ldots, $d_{n-1}$; an instance then
   denotes the C type @<subtype> @|[$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 @<subtype>.  We shall
   continue to abuse terminology and refer to multidimensional arrays.
 
   $d_1$ of \ldots\ arrays of $d_{n-1}$ elements of type @<subtype>.  We shall
   continue to abuse terminology and refer to multidimensional arrays.
 

-  The type specifier @|([] @<type-spec> @<dimension>^*)| constructs a
-  multidimensional array with the given @<dimension>s whose elements have the
-  type specified by @<type-spec>.  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
+  @<dimension>s whose elements have the type specified by @<type-spec>.  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 @<subtype> @<dimensions> @> @<c-array-type>}
 
 \begin{describe}{fun}
     {make-array-type @<subtype> @<dimensions> @> @<c-array-type>}


@@ -910,7 +970,16 @@ function type is the type of the function's return value.
   unchanged.
 \end{describe}
 
   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 @<return-type>
+                      @{ (@<arg-name> @<arg-type>) @}^*
+                      @[:ellipsis @! . @<form>@]}}
+  \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 @<arguments> and returns @<subtype>.
 
   Represents C function types.  An instance denotes the type of a C
   function which accepts the @<arguments> and returns @<subtype>.
 


@@ -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.
 
   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 @<return-type>
-         @{ (@<arg-name> @<arg-type>) @}^*
-         @[:ellipsis @! . @<form>@])
-  \end{prog}
-  constructs a function type.  The function has the subtype @<return-type>.
-  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
-  @<arg-name>/@<arg-type> 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 @<return-type>.  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 @<arg-name>/@<arg-type> 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;
   \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}
             (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 \=@<return-type>
+                       @{ (@<arg-name> @<arg-type>) @}^*      \+\\
+                       @{ \=:keys @{ (@<kw-name> @<kw-type>
+                                      @[@<kw-default>@]) @}^*
+                               @[. @<form>@] @!               \+\\
+                             . @<form> @}}}

   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.
   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|
   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 \=@<return-type>
-           @{ (@<arg-name> @<arg-type>) @}^*                  \+\\
-           @{ \=:keys @{ (@<kw-name> @<kw-type> @[@<kw-default>@]) @}^*
-                   @[. @<form>@] @!                           \+\\
-                 . @<form> @}
-  \end{prog}
-  where either the symbol @|:keys| appears literally in the specifier, or the
-  @<form> 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
+  @<form> 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
   @<form> is handled.
 
   See the description of \descref{cls}{c-function-type} for how a trailing
   @<form> is handled.


@@ -1018,7 +1080,12 @@ function type is the type of the function's return value.
   The list of @<arg-name>s and @<arg-type>s describes the positional
   arguments.  The list of @<kw-name>s, @<kw-type>s and @<kw-defaults>s
   describes the keyword arguments.
   The list of @<arg-name>s and @<arg-type>s describes the positional
   arguments.  The list of @<kw-name>s, @<kw-type>s and @<kw-defaults>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 @<subtype> @<arguments> @> @<c-function-type>}
 
 \begin{describe}{fun}
     {make-function-type @<subtype> @<arguments> @> @<c-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}
 
 
 \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 @<name> @<qualifier>^*}}
+\end{describe*}

 
 \begin{describe*}
     {\dhead{gf}{c-type-class @<class-type> @> @<class>}
 
 \begin{describe*}
     {\dhead{gf}{c-type-class @<class-type> @> @<class>}

diff --git a/doc/list-exports b/doc/list-exports
index 1d9b0c4..87d85be 100755 (executable)
--- 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
 
 (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)
 ;; 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.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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))
       (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 (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))
       (push :opthandler things))

-    (when (get symbol 'optparse::optmacro)
+    (when (get symbol 'optparse::optmacro-function)

       (push :optmacro things))
     (nreverse things)))
 
       (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"))
   (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))))
         (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 ()
 ;;; 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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/doc/misc.tex b/doc/misc.tex
index 353c948..f1e3cde 100644 (file)
--- a/doc/misc.tex
+++ b/doc/misc.tex
@@ -303,6 +303,14 @@ metaobject protocol.
   \end{describe}
 \end{describe*}
 
   \end{describe}
 \end{describe*}
 

+\begin{describe}{fun}
+    {find-eql-specialized-method @<function> @<arg> @<objcet>}
+  Find and return a method defined on a generic @<function> whose @<arg>th
+  argument (counting from zero) is @|eql|-specialized on the givan
+  @<object>.  If there is no such method on @<function> then return @|nil|.
+  If there are multiple such methods, return one of them arbitrarily.
+\end{describe}
+

 \begin{describe*}
     {\dhead{gf}{generic-function-methods @<generic-function> @> @<list>}
      \dhead{gf}{method-specializers @<method> @> @<list>}
 \begin{describe*}
     {\dhead{gf}{generic-function-methods @<generic-function> @> @<list>}
      \dhead{gf}{method-specializers @<method> @> @<list>}


@@ -913,9 +921,6 @@ The following definitions are useful when working with conditions.
 
 Most of these symbols are defined in the @|optparse| package.
 
 
 Most of these symbols are defined in the @|optparse| package.
 

-\begin{describe}{fun}{exit \&optional (@<code> 0) \&key :abrupt}
-\end{describe}
-

 \begin{describe}{var}{*program-name*}
 \end{describe}
 
 \begin{describe}{var}{*program-name*}
 \end{describe}
 


@@ -1021,6 +1026,17 @@ Most of these symbols are defined in the @|optparse| package.
       @<form>^*}
 \end{describe}
 
       @<form>^*}
 \end{describe}
 

+\begin{describe*}
+    {\dhead{sym}{opthandler}
+     \dhead{meth}{symbol,(eql 'opthandler)}
+                 {documentation (@<symbol> symbol)
+                                (@<doc-type> (eql 'opthandler))}
+     \dhead{meth}{symbol,(eql 'opthandler)}
+                 {setf \=(documentation (@<symbol> symbol)
+                                        (@<doc-type> (eql 'opthandler))) \\
+                       \>@<string>}}
+\end{describe*}
+

 \begin{describe}{fun}
     {invoke-option-handler @<handler> @<locative> @<arg> @<arguments>}
 \end{describe}
 \begin{describe}{fun}
     {invoke-option-handler @<handler> @<locative> @<arg> @<arguments>}
 \end{describe}


@@ -1058,6 +1074,17 @@ Most of these symbols are defined in the @|optparse| package.
       @<form>^*}
 \end{describe}
 
       @<form>^*}
 \end{describe}
 

+\begin{describe*}
+    {\dhead{sym}{optmacro}
+     \dhead{meth}{symbol,(eql 'optmacro)}
+                 {documentation (@<symbol> symbol)
+                                (@<doc-type> (eql 'optmacro))}
+     \dhead{meth}{symbol,(eql 'optmacro)}
+                 {setf \=(documentation (@<symbol> symbol)
+                                        (@<doc-type> (eql 'optmacro))) \\
+                       \>@<string>}}
+\end{describe*}
+

 \begin{describe}{fun}{parse-option-form @<form>}
 \end{describe}
 
 \begin{describe}{fun}{parse-option-form @<form>}
 \end{describe}
 

diff --git a/doc/sod.sty b/doc/sod.sty
index 592ff5c..3f49516 100644 (file)
--- 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@%
 }
       \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@
   % {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}
 
 %% \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{|)}}%
      \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
   \fi%
   \rlap{\hb@xt@\linewidth{\hfil\normalfont\bfseries

-      [\describecategoryname[#1]{#2}]}}%
+        [\describecategoryname[#1]{#2}]}}%

   #5%
 }
 
   #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
 %%
 %% 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'.
 %%
 %%
 %%   * `*NAME*': defaults MOD to `muffs'.
 %%


@@ -659,6 +660,8 @@
 \definedescribecategory{opt}{option handler}
 \definedescribecategory{optmac}{option macro}
 \definedescribecategory{plug}{pluggable parser}
 \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
 
 %%%----- That's all, folks --------------------------------------------------
 \endinput

diff --git a/doc/sod.words b/doc/sod.words
index 8ed4934..27b6730 100644 (file)
--- 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
 argumentp

-SIG
-prog
-goto
-uchar
-dylan
-valist
-paren
-MyClass
-rprec
-toset
-CLASSOF
-llong
-kwparse
-KWPARSE
+asdf

 asetf
 asetf

-cls
-lbuild
-uint
-ecase
-anaphorics
+atsign
+atypecase
+awhen
+barrett
+binop
+bool

 buf
 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
 Cygwin

-rst
-initarg's
-initargs
-kwtab
-asdf
-ASDF
-linearization
+dec
+decl

 declarator
 declarator

-ABIs
-args
-Haahr
-iostream
-atypecase
-KWSET
-dosequence
-PARSEFN
-initarg
+declarators

 declp
 declp

-Habib
-constp

 decls
 decls

-psetp
-decl
-plist
-fputs
-eof
-fil
-ichainsz
-initializer
-setf
-continuable
-ptrs
-env
-ptrdiff
-postop
-lmac
-notational
+defctype

 defn
 defn

-eql
-vhv
-perl
-insts
-sym
-alignas
-Accessor
-accessor
-wchar

 defs
 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
 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
 disambiguated

-offsetof
-peekp
-charbuf
-eval
+docp
+donep
+dosequence
+ducournau
+dylan
+dæmon
+ecase

 eg
 eg

-mLib
-oldunk
+endif
+enum
+enums
+env
+eof
+eq
+eql
+equalp
+errno
+etypecase

 EuLisp
 EuLisp

-const
-ichains
-cv
+eval
+expr
+extern
+externp
+externs
+fil
+fixme
+fixnum
+fixnums
+floc
+fp
+fputs
+frob
+func

 gc
 gc

-kwfirst
-ichainu
+gensym
+gensyms

 gf
 gf

-cplusplus
-eq
-initv
-monot

 gh
 gh

-consumedp
-fp
-propertyp
-cond
-vmsgs
-coercions
-acase
-lparen
+goto
+Haahr
+Habib
+Huchard

 hv
 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
 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
 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
 linearizes

+llong
+lmac
+locative
+locativep
+locatives
+locf
+lparen
+lprec
+lvalue

 makev
 makev

-frob
-vh
-destructuring
-preop
-ACM
-ty
-schar
-scrutinee
-vt

 malloc
 malloc

-ilayout
-islotsz
-docp
-alice
-stmts
-rparen
-enums
-aif
-linearizations
-declarators
-etypecase
-ichain
+methty
+mLib
+monot
+morep
+msg
+Mugnier
+multip
+MyClass

 nestedp
 nestedp

+nitty
+notational
+nref
+nreverse
+numericp
+oct
+offsetof
+oldunk
+onwards
+optionp
+paren
+PARSEFN
+parser's
+parsers
+peekp
+perl
+plist
+postop
+pre

 prec
 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
 sllong

-kwargs
-KWARGS
-issn
-expr
-islots
-strcmp
-KWTAIL
+slong

 spacep
 spacep

-constantp
-fixnums
-pre
-ret
-atsign
+specializer
+specializers

 sshort
 sshort

-sizeof
-suppliedp
-commitp
+stmts
+strcmp

 struct
 struct

-cdr
-api
-KWDECL
+structs
+subclassp
+suppliedp
+sym
+sys
+tc
+th
+there'd
+toset
+ty
+typedefs
+uchar
+uint
+uiop

 ullong
 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
 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 (file)
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -29,10 +29,6 @@ nobase_dist_pkglispsrc_DATA = $(LISP_SOURCES)
 LISP_SOURCES            =
 SYSDEFS                         =
 
 LISP_SOURCES            =
 SYSDEFS                         =
 

-ASDF_ENV                = \
-       CL_SOURCE_REGISTRY=$$(pwd): \
-       ASDF_OUTPUT_TRANSLATIONS=$$(cd $(srcdir); pwd):$(abs_builddir):
-

 ###--------------------------------------------------------------------------
 ### The source files.
 
 ###--------------------------------------------------------------------------
 ### The source files.
 


@@ -114,18 +110,13 @@ sod.asd: sod.asd.in Makefile
        $(SUBST) $(srcdir)/sod.asd.in >$@.new $(SUBSTITUTIONS) && \
                mv $@.new $@
 
        $(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             =
 ## 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)
 
 ## The executable is needed if we're just distributing.
 dist-hook: sod$(EXEEXT)


@@ -133,9 +124,6 @@ dist-hook: sod$(EXEEXT)
 ###--------------------------------------------------------------------------
 ### Unit testing.
 
 ###--------------------------------------------------------------------------
 ### Unit testing.
 

-## The system definition.
-EXTRA_DIST             += sod-test.asd.in
-

 ## Basic utilities.
 EXTRA_DIST             += test-base.lisp
 
 ## 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
 
 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.
 ## 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.
 
 ###--------------------------------------------------------------------------
 ### Manual pages.


@@ -199,9 +177,10 @@ install-data-local:
        done; \
        dots=$$(echo $$fwd | sed 's/[^ ][^ ]*/../g'); \
        rel=$$(echo $$dots $$twd | tr " " "/"); \
        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; }' \
          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 \
              -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 (file)
--- a/src/asdf-hack.lisp.in
+++ b/src/asdf-hack.lisp.in
@@ -2,5 +2,5 @@
 
 (declaim (optimize debug))
 (asdf:initialize-source-registry
 
 (declaim (optimize debug))
 (asdf:initialize-source-registry

- `(:source-registry (:directory ,*load-pathname*)
+ `(:source-registry (:directory ,*load-truename*)

                    :inherit-configuration))
                    :inherit-configuration))

diff --git a/src/builtin.lisp b/src/builtin.lisp
index d07f539..6310741 100644 (file)
--- 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)
     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
          "~@<struct { ~2I~_~{unsigned ~A: 1;~^ ~_~} ~I~_} ~A;~:>"
          flags var))
   (format stream
          "~@<struct { ~2I~_~{unsigned ~A: 1;~^ ~_~} ~I~_} ~A;~:>"
          flags var))

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index e5ead1b..7a2ff16 100644 (file)
--- 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)
           (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)
           `(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 (file)
--- 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))
 
   "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.
 (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))))
 
             (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."
 (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)
        ,@(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)))
                      (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)))
    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
         (typevar (symbolicate 'c-type- (car names))))
     `(progn
        ,@(and export


@@ -226,6 +249,11 @@
                     `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
                        ',typevar))
                   names))
                     `(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)
        'names)))
 
 (export 'c-name-case)

diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index a3f3e51..0c5040c 100644 (file)
--- 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)))
           (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.
 
 
 ;; Formatting utilities.
 


@@ -352,11 +366,20 @@
 
 (export 'format-banner-comment)
 (defun format-banner-comment (stream control &rest args)
 
 (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)
   (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
   (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)
 
 (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)
   (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)
 
 ;; Expression statements.
 (definst expr (stream :export t) (%expr)

+  "An expression statement: EXPR;"

   (format stream "~A;" expr))
 (definst set (stream :export t) (var %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)
   (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)
   (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)
   (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~@_~@<? ~A ~_: ~A~:>~:>" cond conseq alt))
 
 ;; Simple statements.
 (definst return (stream :export t) (%expr)
   (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" 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) ()
   (format stream "return~@[ (~A)~];" expr))
 (definst break (stream :export t) ()

+  "A `break' statement: break;"

   (format stream "break;"))
 (definst continue (stream :export t) ()
   (format stream "break;"))
 (definst continue (stream :export t) ()

+  "A `continue' statement: continue;"

   (format stream "continue;"))
 
 ;; Compound statements.
   (format stream "continue;"))
 
 ;; Compound statements.


@@ -404,15 +445,31 @@
    they get the formatting right between them.")
 
 (definst banner (stream :export t) (control &rest args)
    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)
   (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)
   (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)
   (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)
   (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))
   (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)
               (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)
   (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)
   (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)))
   (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 (file)
--- a/src/frontend.lisp
+++ b/src/frontend.lisp
@@ -31,12 +31,6 @@
 (cl:in-package #:sod-frontend)
 
 ;;;--------------------------------------------------------------------------
 (cl:in-package #:sod-frontend)
 
 ;;;--------------------------------------------------------------------------

-;;; Preparation for dumping.
-
-(clear-the-decks)
-(exercise)
-
-;;;--------------------------------------------------------------------------

 ;;; The main program.
 
 (defvar-unbound *option-parser*
 ;;; The main program.
 
 (defvar-unbound *option-parser*


@@ -238,6 +232,6 @@
                                      ~[~:; ~:*~D error~:P~[~:; and~]~:*~]~
                                      ~[~:; ~:*~D warning~:P~]~%"
                      *program-name* nerror nwarn))
                                      ~[~:; ~:*~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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index e72044e..0a20f39 100644 (file)
--- 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)
 
 (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))
 
   (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 (file)
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -33,24 +33,6 @@
 ;;;--------------------------------------------------------------------------
 ;;; Program environment things.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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* "<unknown>"
   "Program name, as retrieved from the command line.")
 (export '(*program-name* *command-line*))
 (defvar *program-name* "<unknown>"
   "Program name, as retrieved from the command line.")


@@ -62,34 +44,7 @@
   "Retrieve command-line arguments.
 
    Set `*command-line*' and `*program-name*'."
   "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*))))
 
 ;;;--------------------------------------------------------------------------
        *program-name* (pathname-name (car *command-line*))))
 
 ;;;--------------------------------------------------------------------------


@@ -144,7 +99,7 @@
 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)
 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)

-  (exit 1))
+  (uiop:quit 1))

 
 ;;;--------------------------------------------------------------------------
 ;;; The main option parser.
 
 ;;;--------------------------------------------------------------------------
 ;;; The main option parser.


@@ -164,9 +119,15 @@
                (lambda (o s k)
                  (declare (ignore k))
                  (print-unreadable-object (o s :type t)
                (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)
                            (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
   (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))
         (defun ,func (,var ,arg ,@args)
           ,@docs ,@decls
           (declare (ignorable ,arg))


@@ -570,6 +531,16 @@
             (block ,name ,@body)))
         ',name))))
 
             (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.
 
 (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)
 
 (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
   (apply (if (functionp handler) handler

-            (fdefinition (get handler 'opthandler)))
+            (fdefinition (get handler 'opthandler-function)))

         loc arg args))
 
 ;;;--------------------------------------------------------------------------
         loc arg args))
 
 ;;;--------------------------------------------------------------------------


@@ -634,26 +607,30 @@
 
 (export 'set)
 (defopthandler set (var) (&optional (value t))
 
 (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))
   (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))
   (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))
   (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)))
   (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
    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)))
 
        ',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)
 (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))))
                        (: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))
                             (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)))
                               ((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))))))
                         (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))
   (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))
     (let ((i start)
          (nest 0)
          (splitp nil))


@@ -942,8 +933,11 @@
 
 (export 'simple-usage)
 (defun simple-usage (opts &optional mandatory-args)
 
 (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)
   (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)
 
 (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)))
   (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*)
 (export 'die-usage)
 (defun die-usage ()
   (do-usage *error-output*)

-  (exit 1))
+  (uiop:quit 1))

 
 (defun opt-help (arg)
   (declare (ignore arg))
 
 (defun opt-help (arg)
   (declare (ignore arg))


@@ -1095,15 +1090,15 @@
     (null nil)
     ((or function symbol) (terpri) (funcall *help*)))
   (format t "~&")
     (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*)
 (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)
 (defun opt-usage (arg)
   (declare (ignore arg))
   (do-usage)

-  (exit 0))
+  (uiop:quit 0))

 
 (export 'help-options)
 (defoptmacro help-options (&key (short-help #\h)
 
 (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 (file)
--- a/src/sod-frontend.asd.in
+++ b/src/sod-frontend.asd.in
@@ -29,33 +29,12 @@
 
 (cl:in-package #:sod-frontend-sysdef)
 
 
 (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.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/src/sod-test.asd.in b/src/sod-test.asd.in
index c65f4dc..72fc649 100644 (file)
--- a/src/sod-test.asd.in
+++ b/src/sod-test.asd.in
@@ -29,39 +29,13 @@
 
 (cl:in-package #:sod-test-sysdef)
 
 
 (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.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Testing.

diff --git a/src/sod.asd.in b/src/sod.asd.in
index 894d50b..82839dd 100644 (file)
--- 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
 ;;; 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
   (: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)
 
 
 #+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
        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."
 
 
      * 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
   :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.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 82a387b..9ff9daf 100644 (file)
--- 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))
 
    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))
 
 (export '(generic-function-methods method-specializers
          eql-specializer eql-specializer-object))
 

diff --git a/vars.am b/vars.am
index 1409100..ed0c03a 100644 (file)
--- a/vars.am
+++ b/vars.am
@@ -77,6 +77,13 @@ V_SUBST_0 = @echo "  SUBST    $@";
 SUBST = $(V_SUBST)$(confsubst)
 
 ###--------------------------------------------------------------------------
 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.
 ### Translating SOD input files.
 
 ## The tool location.