diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index 5f3c821..42d0346 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -19560,6 +19560,295 @@ deleting entries from u assumes that the first element is useless \end{chunk} +\chapter{Building libdb.text} +\defun{extendLocalLibdb}{extendLocalLibdb} +\calls{extendLocalLibdb}{buildLibdb} +\calls{extendLocalLibdb}{union} +\calls{extendLocalLibdb}{purgeNewConstructorLines} +\calls{extendLocalLibdb}{dbReadLines} +\calls{extendLocalLibdb}{dbWriteLines} +\seebook{extendLocalLibdb}{deleteFile}{5} +\calls{extendLocalLibdb}{msort} +\refsdollar{extendLocalLibdb}{createLocalLibDb} +\refsdollar{extendLocalLibdb}{newConstructorList} +\defsdollar{extendLocalLibdb}{newConstructorList} +\begin{chunk}{defun extendLocalLibdb} +(defun |extendLocalLibdb| (conlist) + (let (localLibdb oldlines newlines) + (declare (special |$createLocalLibDb| |$newConstructorList|)) + (cond + ((null |$createLocalLibDb|) nil) + ((null conlist) nil) + (t + (|buildLibdb| conlist) + (setq |$newConstructorList| (|union| conlist |$newConstructorList|)) + (setq localLibdb "libdb.text") + (cond + ((null (probe-file "libdb.text")) + (rename-file "temp.text" "libdb.text")) + (t + (setq oldlines + (|purgeNewConstructorLines| (|dbReadLines| localLibdb) conlist)) + (setq newlines (|dbReadLines| "temp.text")) + (|dbWriteLines| (msort (|union| oldlines newlines)) "libdb.text") + (|deleteFile| "temp.text"))))))) + +\end{chunk} + +\defun{buildLibdb}{buildLibdb} +This function appears to have two use cases, one in which the domainList +variable is undefined, in which case it writes out all of the constructors, +and the other case where it writes out a single constructor. +Formal for libdb.text: +\begin{verbatim} + constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) + operations Op \#\E\sig \conname\pred\comments (E is one of U/E) + attributes Aname\#\E\args\conname\pred\comments + I = +\end{verbatim} +\calls{buildLibdb}{dsetq} +\calls{buildLibdb}{ifcar} +\seebook{buildLibdb}{deleteFile}{5} +\seebook{buildLibdb}{make-outstream}{5} +\calls{buildLibdb}{writedb} +\calls{buildLibdb}{buildLibdbString} +\seebook{buildLibdb}{allConstructors}{5} +\calls{buildLibdb}{buildLibdbConEntry} +\calls{buildLibdb}{getConstructorExports} +\calls{buildLibdb}{buildLibOps} +\calls{buildLibdb}{buildLibAttrs} +\calls{buildLibdb}{shut} +\calls{buildLibdb}{obey} +\calls{buildLibdb}{deleteFile} +\refsdollar{buildLibdb}{outStream} +\refsdollar{buildLibdb}{conform} +\defsdollar{buildLibdb}{kind} +\defsdollar{buildLibdb}{doc} +\defsdollar{buildLibdb}{exposed?} +\defsdollar{buildLibdb}{conform} +\defsdollar{buildLibdb}{conname} +\defsdollar{buildLibdb}{outStream} +\defsdollar{buildLibdb}{DefLst} +\defsdollar{buildLibdb}{PakLst} +\defsdollar{buildLibdb}{catLst} +\defsdollar{buildLibdb}{DomLst} +\defsdollar{buildLibdb}{AttrLst} +\defsdollar{buildLibdb}{OpLst} +\begin{chunk}{defun buildLibdb} +(defun |buildLibdb| (&rest G168131 &AUX options) + (dsetq options G168131) + (let (|$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| |$DefLst| + |$outStream| |$conname| |$conform| |$exposed?| |$doc| + |$kind| domainList comments constructorList tmp1 attrlist oplist) + (declare (special |$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| + |$DefLst| |$outStream| |$conname| |$conform| + |$exposed?| |$doc| |$kind|)) + (setq domainList (ifcar options)) + (setq |$OpLst| nil) + (setq |$AttrLst| nil) + (setq |$DomLst| nil) + (setq |$CatLst| nil) + (setq |$PakLst| nil) + (setq |$DefLst| nil) + (|deleteFile| "temp.text") + (setq |$outStream| (make-outstream "temp.text")) + (unless domainList + (setq comments + (concatenate 'string + "\\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to " + "represent objects of type \\spad{A} or of type \\spad{B} or...or " + "of type \\spad{C}.")) + (|writedb| + (|buildLibdbString| + (list "dUnion" 1 "x" "special" "(A,B,...,C)" 'UNION comments))) + (setq comments + (concatenate 'string + "\\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used " + "to represent composite objects made up of objects of type " + "\\spad{A}, \\spad{B},..., \\spad{C} which are indexed by \"keys\"" + " (identifiers) \\spad{a},\\spad{b},...,\\spad{c}.")) + (|writedb| + (|buildLibdbString| + (list "dRecord" 1 "x" "special" "(a:A,b:B,...,c:C)" 'RECORD comments))) + (setq comments + (concatenate 'string + "\\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent" + " mappings from source type \\spad{S} to target type \\spad{T}. " + "Similarly, \\spad{Mapping(T,A,B)} denotes a mapping from source " + "type \\spad{(A,B)} to target type \\spad{T}.")) + (|writedb| + (|buildLibdbString| + (list "dMapping" 1 "x" "special" "(T,S)" 'MAPPING comments))) + (setq comments + (concatenate 'string + "\\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to " + "represent the object composed of the symbols \\spad{a},\\spad{b}," + "..., and \\spad{c}.")) + (|writedb| + (|buildLibdbString| + (list "dEnumeration" 1 "x" "special" "(a,b,...,c)" 'ENUM comments)))) + (setq |$conname| nil) + (setq |$conform| nil) + (setq |$exposed?| nil) + (setq |$doc| nil) + (setq |$kind| nil) + (setq constructorList (or domainList (|allConstructors|))) + (loop for con in constructorList do + (|writedb| (|buildLibdbConEntry| con)) + (setq tmp1 (|getConstructorExports| |$conform|)) + (setq attrlist (car tmp1)) + (setq oplist (cdr tmp1)) + (|buildLibOps| oplist) + (|buildLibAttrs| attrlist)) + (shut |$outStream|) + (unless domainList + (obey "sort \"temp.text\" > \"libdb.text\"") + (rename-file "libdb.text" "olibdb.text") + (|deleteFile| "temp.text")))) + +\end{chunk} + +\defun{buildLibdbString}{buildLibdbString} +\calls{buildLibdbString}{strconc} +\calls{buildLibdbString}{stringimage} +\begin{chunk}{defun buildLibdbString} +(defun |buildLibdbString| (arg) + (let (x u (result "")) + (setq x (car arg)) + (setq u (cdr arg)) + (strconc (stringimage x) + (let ((result "")) + (loop for y in u + collect (setq result (strconc result (strconc "`" (stringimage y))))) + result)))) + +\end{chunk} + +\defun{dbReadLines}{dbReadLines} +\calls{dbReadLines}{eofp} +\calls{dbReadLines}{readline} +\begin{chunk}{defun dbReadLines} +(defun |dbReadLines| (target) + (let (instream lines) + (setq instream (open target)) + (setq lines + (loop while (not (eofp instream)) + collect (readline instream))) + (close instream) + lines)) + +\end{chunk} + +\defun{purgeNewConstructorLines}{purgeNewConstructorLines} +\calls{purgeNewConstructorLines}{screenLocalLine} +\begin{chunk}{defun purgeNewConstructorLines} +(defun |purgeNewConstructorLines| (lines conlist) + (loop for x in lines + when (null (|screenLocalLine| x conlist)) + collect x)) + +\end{chunk} + +\defun{dbWriteLines}{dbWriteLines} +\calls{dbWriteLines}{ifcar} +\calls{dbWriteLines}{getTempPath} +\calls{dbWriteLines}{make-outstream} +\calls{dbWriteLines}{writedb} +\calls{dbWriteLines}{shut} +\defsdollar{dbWriteLines}{outStream} +\refsdollar{dbWriteLines}{outStream} +\begin{chunk}{defun dbWriteLines} +(defun |dbWriteLines| (&rest G176369 &aux options s) + (dsetq (s . options) G176369) + (let (|$outStream| pathname) + (declare (special |$outStream|)) + (setq pathname (or (ifcar options) (|getTempPath| '|source|))) + (setq |$outStream| (make-outstream pathname)) + (loop for x in s do (|writedb| x)) + (shut |$outStream|) + pathname)) + +\end{chunk} + +\defun{buildLibdbConEntry}{buildLibdbConEntry} +\calls{buildLibdbConEntry}{getdatabase} +\calls{buildLibdbConEntry}{dbMkForm} +\calls{buildLibdbConEntry}{msubst} +\calls{buildLibdbConEntry}{isExposedConstructor} +\calls{buildLibdbConEntry}{pname} +\calls{buildLibdbConEntry}{maxindex} +\calls{buildLibdbConEntry}{downcase} +\calls{buildLibdbConEntry}{lassoc} +\calls{buildLibdbConEntry}{libdbTrim} +\calls{buildLibdbConEntry}{concatWithBlanks} +\calls{buildLibdbConEntry}{form2HtString} +\calls{buildLibdbConEntry}{libConstructorSig} +\calls{buildLibdbConEntry}{strconc} +\calls{buildLibdbConEntry}{buildLibdbString} +\calls{buildLibdbConEntry}{length} +\refsdollar{buildLibdbConEntry}{exposed?} +\refsdollar{buildLibdbConEntry}{kind} +\refsdollar{buildLibdbConEntry}{conform} +\defsdollar{buildLibdbConEntry}{kind} +\defsdollar{buildLibdbConEntry}{doc} +\defsdollar{buildLibdbConEntry}{exposed?} +\defsdollar{buildLibdbConEntry}{conname} +\begin{chunk}{defun buildLibdbConEntry} +(defun |buildLibdbConEntry| (conname) + (let (abb conform pname tmp3 z kind argl tmp1 tmp2 r conComments argpart + sigpart header) + (declare (special |$exposed?| |$doc| |$kind| |$conname| |$conform|)) + (cond + ((null (getdatabase conname 'constructormodemap)) nil) + (t + (setq abb (getdatabase conname 'abbreviation)) + (setq |$conname| conname) + (setq conform (or (getdatabase conname 'constructorform) (list conname))) + (setq |$conform| (|dbMkForm| (msubst 't 'T$ conform))) + (cond + ((null |$conform|) nil) + (t + (setq |$exposed?| (if (|isExposedConstructor| conname) "x" "n")) + (setq |$doc| (getdatabase conname 'documentation)) + (setq pname (pname conname)) + (setq kind (getdatabase conname 'constructorkind)) + (cond + ((and (eq kind '|domain|) + (progn + (setq tmp1 (getdatabase conname 'constructormodemap)) + (and (consp tmp1) + (consp (qcar tmp1)) + (consp (qcdar tmp1)))) + (consp (qcadar tmp1)) (eq (qcaadar tmp1) 'category) + (progn + (and (consp (qcdadar tmp1)) + (eq (qcar (qcdadar tmp1)) '|package|)))) + (setq kind '|package|))) + (setq |$kind| + (if (char= (elt pname (maxindex pname)) #\&) + '|x| + (downcase (elt (pname kind) 0)))) + (setq argl (cdr |$conform|)) + (setq conComments + (cond + ((progn + (setq tmp1 (lassoc '|constructor| |$doc|)) + (and (consp tmp1) + (eq (qcdr tmp1) nil) + (consp (qcar tmp1)) + (equal (qcaar tmp1) nil))) + (|libdbTrim| (|concatWithBlanks| (qcdar tmp1)))) + (t ""))) + (setq argpart (substring (|form2HtString| (cons '|f| argl)) 1 nil)) + (setq sigpart (|libConstructorSig| |$conform|)) + (setq header (strconc |$kind| (pname conname))) + (|buildLibdbString| + (list header (|#| argl) |$exposed?| + sigpart argpart abb conComments)))))))) + +\end{chunk} + + \chapter{Comment Syntax Checking} This is the graph of the functions used for comment syntax checking. @@ -23806,207 +24095,6 @@ And the {\bf s-process} function which returns a parsed version of the input. \end{chunk} -\defun{extendLocalLibdb}{extendLocalLibdb} -\calls{extendLocalLibdb}{buildLibdb} -\calls{extendLocalLibdb}{union} -\calls{extendLocalLibdb}{purgeNewConstructorLines} -\calls{extendLocalLibdb}{dbReadLines} -\calls{extendLocalLibdb}{dbWriteLines} -\calls{extendLocalLibdb}{deleteFile} -\calls{extendLocalLibdb}{msort} -\refsdollar{extendLocalLibdb}{createLocalLibDb} -\refsdollar{extendLocalLibdb}{newConstructorList} -\defsdollar{extendLocalLibdb}{newConstructorList} -\begin{chunk}{defun extendLocalLibdb} -(defun |extendLocalLibdb| (conlist) - (let (localLibdb oldlines newlines) - (declare (special |$createLocalLibDb| |$newConstructorList|)) - (cond - ((null |$createLocalLibDb|) nil) - ((null conlist) nil) - (t - (|buildLibdb| conlist) - (setq |$newConstructorList| (|union| conlist |$newConstructorList|)) - (setq localLibdb "libdb.text") - (cond - ((null (probe-file "libdb.text")) - (rename-file "temp.text" "libdb.text")) - (t - (setq oldlines - (|purgeNewConstructorLines| (|dbReadLines| localLibdb) conlist)) - (setq newlines (|dbReadLines| "temp.text")) - (|dbWriteLines| (msort (|union| oldlines newlines)) "libdb.text") - (|deleteFile| "temp.text"))))))) - -\end{chunk} - -\defun{buildLibdb}{buildLibdb} -This function appears to have two use cases, one in which the domainList -variable is undefined, in which case it writes out all of the constructors, -and the other case where it writes out a single constructor. -Formal for libdb.text: -\begin{verbatim} - constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) - operations Op \#\E\sig \conname\pred\comments (E is one of U/E) - attributes Aname\#\E\args\conname\pred\comments - I = -\end{verbatim} -\calls{buildLibdb}{dsetq} -\calls{buildLibdb}{ifcar} -\calls{buildLibdb}{deleteFile} -\calls{buildLibdb}{make-outstream} -\calls{buildLibdb}{writedb} -\calls{buildLibdb}{buildLibdbString} -\calls{buildLibdb}{allConstructors} -\calls{buildLibdb}{buildLibdbConEntry} -\calls{buildLibdb}{getConstructorExports} -\calls{buildLibdb}{buildLibOps} -\calls{buildLibdb}{buildLibAttrs} -\calls{buildLibdb}{shut} -\calls{buildLibdb}{obey} -\calls{buildLibdb}{deleteFile} -\refsdollar{buildLibdb}{outStream} -\refsdollar{buildLibdb}{conform} -\defsdollar{buildLibdb}{kind} -\defsdollar{buildLibdb}{doc} -\defsdollar{buildLibdb}{exposed?} -\defsdollar{buildLibdb}{conform} -\defsdollar{buildLibdb}{conname} -\defsdollar{buildLibdb}{outStream} -\defsdollar{buildLibdb}{DefLst} -\defsdollar{buildLibdb}{PakLst} -\defsdollar{buildLibdb}{catLst} -\defsdollar{buildLibdb}{DomLst} -\defsdollar{buildLibdb}{AttrLst} -\defsdollar{buildLibdb}{OpLst} -\begin{chunk}{defun buildLibdb} -(defun |buildLibdb| (&rest G168131 &AUX options) - (dsetq options G168131) - (let (|$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| |$DefLst| - |$outStream| |$conname| |$conform| |$exposed?| |$doc| - |$kind| domainList comments constructorList tmp1 attrlist oplist) - (declare (special |$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| - |$DefLst| |$outStream| |$conname| |$conform| - |$exposed?| |$doc| |$kind|)) - (setq domainList (ifcar options)) - (setq |$OpLst| nil) - (setq |$AttrLst| nil) - (setq |$DomLst| nil) - (setq |$CatLst| nil) - (setq |$PakLst| nil) - (setq |$DefLst| nil) - (|deleteFile| "temp.text") - (setq |$outStream| (make-outstream "temp.text")) - (unless domainList - (setq comments - (concatenate 'string - "\\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to " - "represent objects of type \\spad{A} or of type \\spad{B} or...or " - "of type \\spad{C}.")) - (|writedb| - (|buildLibdbString| - (list "dUnion" 1 "x" "special" "(A,B,...,C)" 'UNION comments))) - (setq comments - (concatenate 'string - "\\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used " - "to represent composite objects made up of objects of type " - "\\spad{A}, \\spad{B},..., \\spad{C} which are indexed by \"keys\"" - " (identifiers) \\spad{a},\\spad{b},...,\\spad{c}.")) - (|writedb| - (|buildLibdbString| - (list "dRecord" 1 "x" "special" "(a:A,b:B,...,c:C)" 'RECORD comments))) - (setq comments - (concatenate 'string - "\\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent" - " mappings from source type \\spad{S} to target type \\spad{T}. " - "Similarly, \\spad{Mapping(T,A,B)} denotes a mapping from source " - "type \\spad{(A,B)} to target type \\spad{T}.")) - (|writedb| - (|buildLibdbString| - (list "dMapping" 1 "x" "special" "(T,S)" 'MAPPING comments))) - (setq comments - (concatenate 'string - "\\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to " - "represent the object composed of the symbols \\spad{a},\\spad{b}," - "..., and \\spad{c}.")) - (|writedb| - (|buildLibdbString| - (list "dEnumeration" 1 "x" "special" "(a,b,...,c)" 'ENUM comments)))) - (setq |$conname| nil) - (setq |$conform| nil) - (setq |$exposed?| nil) - (setq |$doc| nil) - (setq |$kind| nil) - (setq constructorList (or domainList (|allConstructors|))) - (loop for con in constructorList do - (|writedb| (|buildLibdbConEntry| con)) - (setq tmp1 (|getConstructorExports| |$conform|)) - (setq attrlist (car tmp1)) - (setq oplist (cdr tmp1)) - (|buildLibOps| oplist) - (|buildLibAttrs| attrlist)) - (shut |$outStream|) - (unless domainList - (obey "sort \"temp.text\" > \"libdb.text\"") - (rename-file "libdb.text" "olibdb.text") - (|deleteFile| "temp.text")))) - -\end{chunk} - -\defun{dbReadLines}{dbReadLines} -\calls{dbReadLines}{eofp} -\calls{dbReadLines}{readline} -\begin{chunk}{defun dbReadLines} -(defun |dbReadLines| (target) - (let (instream lines) - (setq instream (open target)) - (setq lines - (loop while (not (eofp instream)) - collect (readline instream))) - (close instream) - lines)) - -\end{chunk} - -\defun{purgeNewConstructorLines}{purgeNewConstructorLines} -\calls{purgeNewConstructorLines}{screenLocalLine} -\begin{chunk}{defun purgeNewConstructorLines} -(defun |purgeNewConstructorLines| (lines conlist) - (loop for x in lines - when (null (|screenLocalLine| x conlist)) - collect x)) - -\end{chunk} - -;dbWriteLines(s, :options) == -; pathname := IFCAR options or getTempPath 'source -; $outStream: local := MAKE_-OUTSTREAM pathname -; for x in s repeat writedb x -; SHUT $outStream -; pathname - -\defun{dbWriteLines}{dbWriteLines} -\calls{dbWriteLines}{ifcar} -\calls{dbWriteLines}{getTempPath} -\calls{dbWriteLines}{make-outstream} -\calls{dbWriteLines}{writedb} -\calls{dbWriteLines}{shut} -\defsdollar{dbWriteLines}{outStream} -\refsdollar{dbWriteLines}{outStream} -\begin{chunk}{defun dbWriteLines} -(defun |dbWriteLines| (&rest G176369 &aux options s) - (dsetq (s . options) G176369) - (let (|$outStream| pathname) - (declare (special |$outStream|)) - (setq pathname (or (ifcar options) (|getTempPath| '|source|))) - (setq |$outStream| (make-outstream pathname)) - (loop for x in s do (|writedb| x)) - (shut |$outStream|) - pathname)) - -\end{chunk} - - \defun{print-defun}{print-defun} \calls{print-defun}{is-console} \calls{print-defun}{print-full} @@ -26115,6 +26203,8 @@ The current input line. \getchunk{defun blankp} \getchunk{defun bootStrapError} \getchunk{defun buildLibdb} +\getchunk{defun buildLibdbConEntry} +\getchunk{defun buildLibdbString} \getchunk{defun bumperrorcount} \getchunk{defun canReturn} diff --git a/changelog b/changelog index 06cd895..61bd44b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20120101 tpd src/axiom-website/patches.html 20120101.02.tpd.patch +20120101 tpd src/interp/br-con.lisp treeshake compiler +20120101 tpd books/bookvol9 treeshake compiler 20120101 tpd src/axiom-website/patches.html 20120101.01.tpd.patch 20120101 tpd src/interp/br-con.lisp treeshake compiler 20120101 tpd books/bookvol9 treeshake compiler diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 6b1f228..af070dc 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3755,5 +3755,7 @@ src/axiom-website/axiomgraph/js/axiomcode.js default compiler
books/bookvol9 treeshake compiler
20120101.01.tpd.patch books/bookvol9 treeshake compiler
+20120101.02.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/br-con.lisp.pamphlet b/src/interp/br-con.lisp.pamphlet index f02e07e..77c02ff 100644 --- a/src/interp/br-con.lisp.pamphlet +++ b/src/interp/br-con.lisp.pamphlet @@ -4533,146 +4533,10 @@ ;--============================================================================ ;-- Build Library Database (libdb.text,...) ;--============================================================================ -;buildLibdbConEntry conname == -; NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil -; abb:=GETDATABASE(conname,'ABBREVIATION) -; $conname := conname -; conform := GETDATABASE(conname,'CONSTRUCTORFORM) or [conname] --hack for Category,.. -; $conform := dbMkForm SUBST('T,"T$",conform) -; null $conform => nil -; $exposed? := (isExposedConstructor conname => '"x"; '"n") -; $doc := GETDATABASE(conname, 'DOCUMENTATION) -; pname := PNAME conname -; kind := GETDATABASE(conname,'CONSTRUCTORKIND) -; if kind = 'domain -; and GETDATABASE(conname,'CONSTRUCTORMODEMAP) is [[.,t,:.],:.] -; and t is ['CATEGORY,'package,:.] then kind := 'package -; $kind := -; pname.(MAXINDEX pname) = char '_& => 'x -; DOWNCASE (PNAME kind).0 -; argl := rest $conform -; conComments := -; LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r -; '"" -; argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil) -; sigpart:= libConstructorSig $conform -; header := STRCONC($kind,PNAME conname) -; buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments] - -(DEFUN |buildLibdbConEntry| (|conname|) - (PROG (|abb| |conform| |pname| |ISTMP#3| |t| |kind| |argl| |ISTMP#1| - |ISTMP#2| |r| |conComments| |argpart| |sigpart| - |header|) - (declare (special |$exposed?| |$doc| |$kind| |$conname| |$conform|)) - (RETURN - (COND - ((NULL (GETDATABASE |conname| 'CONSTRUCTORMODEMAP)) NIL) - ('T (SPADLET |abb| (GETDATABASE |conname| 'ABBREVIATION)) - (SPADLET |$conname| |conname|) - (SPADLET |conform| - (OR (GETDATABASE |conname| 'CONSTRUCTORFORM) - (CONS |conname| NIL))) - (SPADLET |$conform| (|dbMkForm| (MSUBST 'T 'T$ |conform|))) - (COND - ((NULL |$conform|) NIL) - ('T - (SPADLET |$exposed?| - (COND - ((|isExposedConstructor| |conname|) - "x") - ('T "n"))) - (SPADLET |$doc| (GETDATABASE |conname| 'DOCUMENTATION)) - (SPADLET |pname| (PNAME |conname|)) - (SPADLET |kind| (GETDATABASE |conname| 'CONSTRUCTORKIND)) - (COND - ((AND (BOOT-EQUAL |kind| '|domain|) - (PROGN - (SPADLET |ISTMP#1| - (GETDATABASE |conname| - 'CONSTRUCTORMODEMAP)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (PROGN - (SPADLET |t| (QCAR |ISTMP#3|)) - 'T))))))) - (CONSP |t|) (EQ (QCAR |t|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|package|)))) - (SPADLET |kind| '|package|))) - (SPADLET |$kind| - (COND - ((BOOT-EQUAL (ELT |pname| (MAXINDEX |pname|)) - (|char| '&)) - '|x|) - ('T (DOWNCASE (ELT (PNAME |kind|) 0))))) - (SPADLET |argl| (CDR |$conform|)) - (SPADLET |conComments| - (COND - ((PROGN - (SPADLET |ISTMP#1| - (LASSOC '|constructor| |$doc|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQUAL (QCAR |ISTMP#2|) NIL) - (PROGN - (SPADLET |r| (QCDR |ISTMP#2|)) - 'T))))) - (|libdbTrim| (|concatWithBlanks| |r|))) - ('T ""))) - (SPADLET |argpart| - (SUBSTRING (|form2HtString| (CONS '|f| |argl|)) 1 - NIL)) - (SPADLET |sigpart| (|libConstructorSig| |$conform|)) - (SPADLET |header| (STRCONC |$kind| (PNAME |conname|))) - (|buildLibdbString| - (CONS |header| - (CONS (|#| |argl|) - (CONS |$exposed?| - (CONS |sigpart| - (CONS |argpart| - (CONS |abb| - (CONS |conComments| NIL))))))))))))))) - ;dbMkForm x == atom x and [x] or x (DEFUN |dbMkForm| (|x|) (OR (AND (ATOM |x|) (CONS |x| NIL)) |x|)) -;buildLibdbString [x,:u] == -; STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u]) - -(DEFUN |buildLibdbString| (G168195) - (PROG (|x| |u|) - (RETURN - (SEQ (PROGN - (SPADLET |x| (CAR G168195)) - (SPADLET |u| (CDR G168195)) - (STRCONC (STRINGIMAGE |x|) - (PROG (G168204) - (SPADLET G168204 "") - (RETURN - (DO ((G168209 |u| (CDR G168209)) - (|y| NIL)) - ((OR (ATOM G168209) - (PROGN - (SETQ |y| (CAR G168209)) - NIL)) - G168204) - (SEQ (EXIT (SETQ G168204 - (STRCONC G168204 - (STRCONC "`" - (STRINGIMAGE |y|))))))))))))))) - ;libConstructorSig [conname,:argl] == ; [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) ; formals := TAKE(#argl,$FormalMapVariableList)