diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 832a02a..1e8bbac 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -49408,7 +49408,7 @@ Given \verb|("one" "two" "three")| generate \verb|"(one,two,three)"| (setq options (cdr G167749)) (progn (setq |$path| '(|functions| |cache|)) - (setq |htPage| (|htInitPage| (|mkSetTitle|) nil)) + (setq htPage (|htInitPage| (|mkSetTitle|) nil)) (setq |$valueList| nil) (|htMakePage| '((|text| @@ -50813,7 +50813,7 @@ There are 8 parts of an htPage: (let (|$conformsAreDomains| lt1 kind name nargs args constring domname conform conname heading data conlist attrlist oplist prefix page) (declare (special |$conformsAreDomains|)) - (setq lt1 (|htpProperty| htPage '|TPDparts|)) + (setq lt1 (|htpProperty| htPage '|parts|)) (setq kind (first lt1)) (setq name (second lt1)) (setq nargs (third lt1)) @@ -51047,6 +51047,378 @@ There are 8 parts of an htPage: \end{chunk} +\defun{kcPage}{kcPage} +\calls{kcPage}{htpProperty} +\calls{kcPage}{kDomainName} +\calls{kcPage}{qcar} +\calls{kcPage}{errorPage} +\calls{kcPage}{opOf} +\calls{kcPage}{form2HtString} +\calls{kcPage}{htInitPage} +\calls{kcPage}{htCopyProplist} +\calls{kcPage}{htpSetProperty} +\calls{kcPage}{dbpHasDefaultCategory?} +\calls{kcPage}{htSay} +\calls{kcPage}{brCon} +\calls{kcPage}{htSayStandard} +\calls{kcPage}{htBeginMenu} +\calls{kcPage}{htMakePage} +\calls{kcPage}{satBreak} +\calls{kcPage}{asharpConstructorName?} +\calls{kcPage}{nequal} +\calls{kcPage}{hget} +\calls{kcPage}{hasNewInfoAlist} +\calls{kcPage}{htEndMenu} +\calls{kcPage}{htShowPage} +\usesdollar{kcPage}{defaultPackageNamesHT} +\begin{chunk}{defun kcPage} +(defun |kcPage| (htPage junk) + (declare (ignore junk)) + (let (lt1 kind name nargs xpart domname conform conname heading page message) + (declare (special |$defaultPackageNamesHT|)) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq nargs (third lt1)) + (setq xpart (fourth lt1)) + (setq domname (|kDomainName| htPage kind name nargs)) + (cond + ((and (consp domname) (eq (qcar domname) '|error|)) + (|errorPage| htPage domname)) + (t + (setq conform (|htpProperty| htPage '|conform|)) + (setq conname (|opOf| conform)) + (setq heading + (if (null domname) + (|htpProperty| htPage '|heading|) + (list "{\\sf " (|form2HtString| domname nil t) "}"))) + (setq page + (|htInitPage| (cons "Cross Reference for " heading) + (|htCopyProplist| htPage))) + (when domname + (|htpSetProperty| htPage '|domname| domname) + (|htpSetProperty| htPage '|heading| heading)) + (when (and (string= kind "category") + (|dbpHasDefaultCategory?| xpart)) + (|htSay| "This category has default package ") + (|bcCon| (concat name (|char| '&)) "")) + (|htSayStandard| "\\newline") + (|htBeginMenu| 3) + (|htSayStandard| "\\item ") + (setq message + (if (string= kind "category") + (list "Categories it directly extends") + (list "Categories the " + (if (string= kind "default package") "package" kind) + " belongs to by assertion"))) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Parents}" + (list (list '|text| "\\tab{12}" message)) '|kcpPage| nil)))) + (|satBreak|) + (setq message + (if (string= kind "category") + (list "All categories it is an extension of") + (list "All categories the " kind " belongs to"))) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Ancestors}" + (list (list '|text| "\\tab{12}" message)) '|kcaPage| nil)))) + (when (string= kind "category") + (|satBreak|) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Children}" + (list (list '|text| "\\tab{12}" + "Categories which directly extend this category")))))) + (|satBreak|) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Descendants}" + (list (list '|text| "\\tab{12}" + "All categories which extend this category"))))))) + (unless (|asharpConstructorName?| conname) + (|satBreak|) + (setq message "Constructors mentioning this as an argument type") + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Dependents}" + (list (list '|text| "\\tab{12}" message)) '|kcdePage| nil))))) + (when (and (null (|asharpConstructorName?| conname)) + (nequal kind "category")) + (|satBreak|) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Lineage}" + "\\tab{12}Constructor hierarchy used for operation lookup" + '|ksPage| nil))))) + (unless (|asharpConstructorName?| conname) + (when (string= kind "category") + (|satBreak|) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Domains}" + (list (list '|text| "\\tab{12}" + "All domains which are of this category")) + '|kcdoPage| nil))))) + (unless (string= kind "category") + (|satBreak|) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Clients}" "\\tab{12}Constructors" + '|kcuPage| nil)))) + (if (hget |$defaultPackageNamesHT| conname) + (|htSay| " which {\\em may use} this default package") + (|htSay| " which {\\em use} this " kind)))) + (when (or (nequal kind "category") (|dbpHasDefaultCategory?| xpart)) + (|satBreak|) + (setq message + (if (string= kind "category") + (list "Constructors {\\em used by} its default package") + (list "Constructors {\\em used by} the " kind))) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{Benefactors}" + (list (list '|text| "\\tab{12}" message) '|kcnPage| nil)))))) + (when (and (null (|asharpConstructorName?| conname)) + (|hasNewInfoAlist| conname)) + (|satBreak|) + (setq message (list "Cross reference for capsule implementation")) + (|htMakePage| + (list + (list '|bcLinks| + (list "\\menuitemstyle{CapsuleInfo}" + (list (list '|text| "\\tab{12}" message)) '|kciPage| nil))))) + (|htEndMenu| 3) + (|htShowPage|))))) + +\end{chunk} + +\defun{kcpPage}{kcpPage} +\calls{kcpPage}{htpProperty} +\calls{kcpPage}{kDomainName} +\calls{kcpPage}{errorPage} +\calls{kcpPage}{qcar} +\calls{kcpPage}{form2HtString} +\calls{kcpPage}{htpSetProperty} +\calls{kcpPage}{opOf} +\calls{kcpPage}{htInitPage} +\calls{kcpPage}{htCopyProplist} +\calls{kcpPage}{parentsOf} +\calls{kcpPage}{sublislis} +\calls{kcpPage}{dbShowCons} +\begin{chunk}{defun kcpPage} +(defun |kcpPage| (htPage junk) + (declare (ignore junk)) + (let (lt1 kind name nargs domname heading conform conname page parents choice) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq nargs (third lt1)) + (setq domname (|kDomainName| htPage kind name nargs)) + (cond + ((and (consp domname) (eq (qcar domname) '|error|)) + (|errorPage| htPage domname)) + (t + (setq heading + (if (null domname) + (|htpProperty| htPage '|heading|) + (list "{\\sf " (|form2HtString| domname nil t) "}"))) + (when domname + (|htpSetProperty| htPage '|domname| domname) + (|htpSetProperty| htPage '|heading| heading)) + (setq conform (|htpProperty| htPage '|conform|)) + (setq conname (|opOf| conform)) + (setq page + (|htInitPage| (cons "Parents of " heading) (|htCopyProplist| htPage))) + (setq parents (|parentsOf| conname)) + (when domname + (setq parents (sublislis (cdr domname) (cdr conform) parents))) + (|htpSetProperty| htPage '|cAlist| parents) + (|htpSetProperty| htPage '|thing| "parent") + (setq choice (if domname '|parameters| '|names|)) + (|dbShowCons| htPage choice))))) + +\end{chunk} + +\defun{reduceAlistForDomain}{reduceAlistForDomain} +\calls{reduceAlistForDomain}{sublislis} +\calls{reduceAlistForDomain}{simpHasPred} +\calls{reduceAlistForDomain}{nreverse0} +\begin{chunk}{defun reduceAlistForDomain} +(defun |reduceAlistForDomain| (alist domform conform) + (let (pred result) + (setq alist (sublislis (cdr domform) (cdr conform) alist)) + (dolist (pair alist) + (rplacd pair (|simpHasPred| (cdr pair) domform))) + (dolist (pair alist (nreverse0 result)) + (setq pred (cdr pair)) + (when pred (setq result (cons pair result)))))) + +\end{chunk} + +\defun{kcaPage}{kcaPage} +\calls{kcaPage}{kcaPage1} +\calls{kcaPage}{ancestorsOf} +\begin{chunk}{defun kcaPage} +(defun |kcaPage| (htPage junk) + (declare (ignore junk)) + (|kcaPage1| htPage "category" " an " + "ancestor" (|function| |ancestorsOf|) nil)) + +\end{chunk} + +\defun{kcdPage}{kcdPage} +\calls{kcdPage}{kcaPage1} +\calls{kcdPage}{descendantsOf} +\begin{chunk}{defun kcdPage} +(defun |kcdPage| (htPage junk) + (declare (ignore junk)) + (|kcaPage1| htPage "category" " a " + "descendant" (|function| |descendantsOf|) t)) + +\end{chunk} + +\defun{kcdoPage}{kcdoPage} +\calls{kcdoPage}{kcdoPage} +\calls{kcdoPage}{domainsOf} +\begin{chunk}{defun kcdoPage} +(defun |kcdoPage| (htPage junk) + (declare (ignore junk)) + (|kcaPage1| htPage "domain" " a " + "descendant" (|function| |domainsOf|) nil)) + +\end{chunk} + +\defun{kcaPage1}{kcaPage1} +\calls{kcaPage1}{htpProperty} +\calls{kcaPage1}{kDomainName} +\calls{kcaPage1}{errorPage} +\calls{kcaPage1}{form2HtString} +\calls{kcaPage1}{htpSetProperty} +\calls{kcaPage1}{opOf} +\calls{kcaPage1}{augmentHasArgs} +\calls{kcaPage1}{listSort} +\calls{kcaPage1}{function} +\calls{kcaPage1}{dbShowCons} +\begin{chunk}{defun kcaPage1} +(defun |kcaPage1| (htPage kind article whichever fn isCatDescendants?) + (declare (ignore article)) + (let (lt1 name nargs domname heading conform conname ancestors choice) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq nargs (third lt1)) + (setq domname (|kDomainName| htPage kind name nargs)) + (cond + ((and (consp domname) (eq (qcar domname) '|error|)) + (|errorPage| htPage domname)) + (t + (setq heading + (if (null domname) + (|htpProperty| htPage '|heading|) + (list "{\\sf " (|form2HtString| domname nil t) "}"))) + (when (and domname (null isCatDescendants?)) + (|htpSetProperty| htPage '|domname| domname) + (|htpSetProperty| htPage '|heading| heading)) + (setq conform (|htpProperty| htPage '|conform|)) + (setq conname (|opOf| conform)) + (setq ancestors (FUNCALL fn conform domname)) + (unless (string= whichever "ancestor") + (setq ancestors (|augmentHasArgs| ancestors conform))) + (setq ancestors (|listSort| (|function| glesseqp) ancestors)) + (|htpSetProperty| htPage '|cAlist| ancestors) + (|htpSetProperty| htPage '|thing| whichever) + (setq choice '|names|) + (|dbShowCons| htPage choice))))) + +\end{chunk} + +\defun{kccPage}{kccPage} +\calls{kccPage}{htpProperty} +\calls{kccPage}{kDomainName} +\calls{kccPage}{qcar} +\calls{kccPage}{errorPage} +\calls{kccPage}{form2HtString} +\calls{kccPage}{htpSetProperty} +\calls{kccPage}{opOf} +\calls{kccPage}{htInitPage} +\calls{kccPage}{htCopyProplist} +\calls{kccPage}{augmentHasArgs} +\calls{kccPage}{childrenOf} +\calls{kccPage}{reduceAlistForDomain} +\calls{kccPage}{dbShowCons} +\begin{chunk}{defun kccPage} +(defun |kccPage| (htPage junk) + (declare (ignore junk)) + (let (lt1 kind name nargs domname heading conform conname page children) + (setq lt1 (|htpProperty| htPage '|parts|)) + (setq kind (first lt1)) + (setq name (second lt1)) + (setq nargs (third lt1)) + (setq domname (|kDomainName| htPage kind name nargs)) + (cond + ((and (consp domname) (eq (qcar domname) '|error|)) + (|errorPage| htPage domname)) + (t + (setq heading + (if (null domname) + (|htpProperty| htPage '|heading|) + (list "{\\sf " (|form2HtString| domname nil t) "}"))) + (when domname + (|htpSetProperty| htPage '|domname| domname) + (|htpSetProperty| htPage '|heading| heading)) + (setq conform (|htpProperty| htPage '|conform|)) + (setq conname (|opOf| conform)) + (setq page + (|htInitPage| (cons "Children of " heading) (|htCopyProplist| htPage))) + (setq children (|augmentHasArgs| (|childrenOf| conform) conform)) + (when domname + (setq children (|reduceAlistForDomain| children domname conform))) + (|htpSetProperty| htPage '|cAlist| children) + (|htpSetProperty| htPage '|thing| "child") + (|dbShowCons| htPage '|names|))))) + +\end{chunk} + +\defun{augmentHasArgs}{augmentHasArgs} +\calls{augmentHasArgs}{opOf} +\calls{augmentHasArgs}{kdr} +\calls{augmentHasArgs}{length} +\calls{augmentHasArgs}{nreverse0} +\calls{augmentHasArgs}{extractHasArgs} +\calls{augmentHasArgs}{getConstructorForm} +\begin{chunk}{defun augmentHasArgs} +(defun |augmentHasArgs| (alist conform) + (let (conname args n name p result pred) + (setq conname (|opOf| conform)) + (setq args (kdr conform)) + (cond + (args + (setq n (|#| args)) + (dolist (item alist (nreverse0 result)) + (setq name (car item)) + (setq p (cdr item)) + (setq pred + (if (consp (|extractHasArgs| p)) + p + (|quickAnd| p + (cons '|hasArgs| + (take n (kdr (|getConstructorForm| (|opOf| name)))))))) + (setq result (cons (cons name pred) result)))) + (t alist)))) + +\end{chunk} + \chapter{The Interpreter} \begin{chunk}{Interpreter} (setq *print-array* nil) @@ -51480,6 +51852,7 @@ There are 8 parts of an htPage: \getchunk{defun alreadyOpened?} \getchunk{defun apropos} \getchunk{defun assertCond} +\getchunk{defun augmentHasArgs} \getchunk{defun augmentTraceNames} \getchunk{defun basicLookup} @@ -52014,6 +52387,13 @@ There are 8 parts of an htPage: \getchunk{defun justifyMyType} \getchunk{defun kArgPage} +\getchunk{defun kcaPage} +\getchunk{defun kcaPage1} +\getchunk{defun kccPage} +\getchunk{defun kcdPage} +\getchunk{defun kcdoPage} +\getchunk{defun kcPage} +\getchunk{defun kcpPage} \getchunk{defun kdPageInfo} \getchunk{defun KeepPart?} \getchunk{defun kePage} @@ -52650,6 +53030,7 @@ There are 8 parts of an htPage: \getchunk{defun recordNewValue0} \getchunk{defun recordOldValue} \getchunk{defun recordOldValue0} +\getchunk{defun reduceAlistForDomain} \getchunk{defun redundant} \getchunk{defun regress} \getchunk{defun remFile} diff --git a/changelog b/changelog index a1605e3..279b352 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20130531 tpd src/axiom-website/patches.html 20130531.01.tpd.patch +20130531 tpd src/interp/br-con.lisp move code to bookvol5 +20130531 tpd books/bookvol5 rewrite code from br-con 20130529 jzc src/axiom-website/patches.html 20130529.01.jzc.patch 20130529 jzc books/bookvol4 fix typos 20130529 jzc books/bookvol2 fix typos diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 86b590a..a6a89d7 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -4189,6 +4189,8 @@ books/bookvol5 incremental rewrite of br-con.lisp books/bookvol* standardize the table of contents 20130529.01.jzc.patch books/bookvol{0,1,2,4} fix typos +20130531.01.tpd.patch +books/bookvol5 rewrite code from br-con diff --git a/src/interp/br-con.lisp.pamphlet b/src/interp/br-con.lisp.pamphlet index e478a0e..c3ebdfb 100644 --- a/src/interp/br-con.lisp.pamphlet +++ b/src/interp/br-con.lisp.pamphlet @@ -12,663 +12,6 @@ \begin{chunk}{*} (IN-PACKAGE "BOOT" ) -;kcPage(htPage,junk) == -; [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; domname := kDomainName(htPage,kind,name,nargs) -; domname is ['error,:.] => errorPage(htPage,domname) -;-- domain := (kind = '"category" => nil; EVAL domname) -; conform := htpProperty(htPage,'conform) -; conname := opOf conform -; heading := -; null domname => htpProperty(htPage,'heading) -; ['"{\sf ",form2HtString(domname,nil,true),'"}"] -; page := htInitPage(['"Cross Reference for ",:heading],htCopyProplist htPage) -; if domname then -; htpSetProperty(htPage,'domname,domname) -; htpSetProperty(htPage,'heading,heading) -; if kind = '"category" and dbpHasDefaultCategory? xpart then -; htSay '"This category has default package " -; bcCon(STRCONC(name,char '_&),'"") -; htSayStandard '"\newline" -; htBeginMenu(3) -; htSayStandard '"\item " -; message := -; kind = '"category" => ['"Categories it directly extends"] -; ['"Categories the ",(kind = '"default package" => '"package"; kind),'" belongs to by assertion"] -; htMakePage [['bcLinks,['"\menuitemstyle{Parents}", -; [['text,'"\tab{12}",:message]],'kcpPage,nil]]] -; satBreak() -; message := -; kind = '"category" => ['"All categories it is an extension of"] -; ['"All categories the ",kind,'" belongs to"] -; htMakePage [['bcLinks,['"\menuitemstyle{Ancestors}", -; [['text,'"\tab{12}",:message]],'kcaPage,nil]]] -; if kind = '"category" then -; satBreak() -; htMakePage [['bcLinks,['"\menuitemstyle{Children}",[['text,'"\tab{12}", -; '"Categories which directly extend this category"]],'kccPage,nil]]] -; satBreak() -; htMakePage [['bcLinks,['"\menuitemstyle{Descendants}",[['text,'"\tab{12}", -; '"All categories which extend this category"]],'kcdPage,nil]]] -; if not asharpConstructorName? conname then -; satBreak() -; message := '"Constructors mentioning this as an argument type" -; htMakePage [['bcLinks,['"\menuitemstyle{Dependents}", -; [['text,'"\tab{12}",message]],'kcdePage,nil]]] -; if not asharpConstructorName? conname and kind ^= '"category" then -; satBreak() -; htMakePage [['bcLinks,['"\menuitemstyle{Lineage}", -; '"\tab{12}Constructor hierarchy used for operation lookup",'ksPage,nil]]] -; if not asharpConstructorName? conname then -; if kind = '"category" then -; satBreak() -; htMakePage [['bcLinks,['"\menuitemstyle{Domains}",[['text,'"\tab{12}", -; '"All domains which are of this category"]],'kcdoPage,nil]]] -; if kind ^= '"category" then -; satBreak() -; htMakePage [['bcLinks,['"\menuitemstyle{Clients}",'"\tab{12}Constructors",'kcuPage,nil]]] -; if HGET($defaultPackageNamesHT,conname) -; then htSay('" which {\em may use} this default package") -;-- htMakePage [['bcLinks,['"files",'"",'kcuPage,true]]] -; else htSay('" which {\em use} this ",kind) -; if kind ^= '"category" or dbpHasDefaultCategory? xpart then -; satBreak() -; message := -; kind = '"category" => ['"Constructors {\em used by} its default package"] -; ['"Constructors {\em used by} the ",kind] -; htMakePage [['bcLinks,['"\menuitemstyle{Benefactors}", -; [['text,'"\tab{12}",:message]],'kcnPage,nil]]] -; --to remove "Capsule Information", comment out the next 5 lines -; if not asharpConstructorName? conname and hasNewInfoAlist conname then -; satBreak() -; message := ['"Cross reference for capsule implementation"] -; htMakePage [['bcLinks,['"\menuitemstyle{CapsuleInfo}", -; [['text,'"\tab{12}",:message]],'kciPage,nil]]] -; htEndMenu(3) -; htShowPage() - -(DEFUN |kcPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (PROG (|LETTMP#1| |kind| |name| |nargs| |xpart| |sig| |args| |abbrev| - |comments| |domname| |conform| |conname| |heading| |page| - |message|) - (declare (special |$defaultPackageNamesHT|)) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) - (SPADLET |kind| (CAR |LETTMP#1|)) - (SPADLET |name| (CADR |LETTMP#1|)) - (SPADLET |nargs| (CADDR |LETTMP#1|)) - (SPADLET |xpart| (CADDDR |LETTMP#1|)) - (SPADLET |sig| (CAR (CDDDDR |LETTMP#1|))) - (SPADLET |args| (CADR (CDDDDR |LETTMP#1|))) - (SPADLET |abbrev| (CADDR (CDDDDR |LETTMP#1|))) - (SPADLET |comments| (CADDDR (CDDDDR |LETTMP#1|))) - (SPADLET |domname| - (|kDomainName| |htPage| |kind| |name| |nargs|)) - (COND - ((AND (CONSP |domname|) (EQ (QCAR |domname|) '|error|)) - (|errorPage| |htPage| |domname|)) - ('T (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) - (SPADLET |conname| (|opOf| |conform|)) - (SPADLET |heading| - (COND - ((NULL |domname|) - (|htpProperty| |htPage| '|heading|)) - ('T - (CONS "{\\sf " - (CONS (|form2HtString| |domname| NIL 'T) - (CONS "}" NIL)))))) - (SPADLET |page| - (|htInitPage| - (CONS "Cross Reference for " - |heading|) - (|htCopyProplist| |htPage|))) - (COND - (|domname| - (|htpSetProperty| |htPage| '|domname| |domname|) - (|htpSetProperty| |htPage| '|heading| |heading|))) - (COND - ((AND (BOOT-EQUAL |kind| "category") - (|dbpHasDefaultCategory?| |xpart|)) - (|htSay| "This category has default package ") - (|bcCon| (STRCONC |name| (|char| '&)) ""))) - (|htSayStandard| "\\newline") (|htBeginMenu| 3) - (|htSayStandard| "\\item ") - (SPADLET |message| - (COND - ((BOOT-EQUAL |kind| "category") - (CONS "Categories it directly extends" - NIL)) - ('T - (CONS "Categories the " - (CONS (COND - ((BOOT-EQUAL |kind| - "default package") - "package") - ('T |kind|)) - (CONS - " belongs to by assertion" - NIL)))))) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS "\\menuitemstyle{Parents}" - (CONS - (CONS - (CONS '|text| - (CONS - "\\tab{12}" - |message|)) - NIL) - (CONS '|kcpPage| - (CONS NIL NIL)))) - NIL)) - NIL)) - (|satBreak|) - (SPADLET |message| - (COND - ((BOOT-EQUAL |kind| "category") - (CONS "All categories it is an extension of" - NIL)) - ('T - (CONS "All categories the " - (CONS |kind| - (CONS " belongs to" - NIL)))))) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS "\\menuitemstyle{Ancestors}" - (CONS - (CONS - (CONS '|text| - (CONS - "\\tab{12}" - |message|)) - NIL) - (CONS '|kcaPage| - (CONS NIL NIL)))) - NIL)) - NIL)) - (COND - ((BOOT-EQUAL |kind| "category") (|satBreak|) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{Children}" - (CONS - (CONS - (CONS '|text| - (CONS "\\tab{12}" - (CONS - "Categories which directly extend this category" - NIL))) - NIL) - (CONS '|kccPage| (CONS NIL NIL)))) - NIL)) - NIL)) - (|satBreak|) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{Descendants}" - (CONS - (CONS - (CONS '|text| - (CONS "\\tab{12}" - (CONS - "All categories which extend this category" - NIL))) - NIL) - (CONS '|kcdPage| (CONS NIL NIL)))) - NIL)) - NIL)))) - (COND - ((NULL (|asharpConstructorName?| |conname|)) (|satBreak|) - (SPADLET |message| - "Constructors mentioning this as an argument type") - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{Dependents}" - (CONS - (CONS - (CONS '|text| - (CONS "\\tab{12}" - (CONS |message| NIL))) - NIL) - (CONS '|kcdePage| (CONS NIL NIL)))) - NIL)) - NIL)))) - (COND - ((AND (NULL (|asharpConstructorName?| |conname|)) - (NEQUAL |kind| "category")) - (|satBreak|) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{Lineage}" - (CONS - "\\tab{12}Constructor hierarchy used for operation lookup" - (CONS '|ksPage| (CONS NIL NIL)))) - NIL)) - NIL)))) - (COND - ((NULL (|asharpConstructorName?| |conname|)) - (COND - ((BOOT-EQUAL |kind| "category") - (|satBreak|) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{Domains}" - (CONS - (CONS - (CONS '|text| - (CONS - "\\tab{12}" - (CONS - "All domains which are of this category" - NIL))) - NIL) - (CONS '|kcdoPage| - (CONS NIL NIL)))) - NIL)) - NIL)))) - (COND - ((NEQUAL |kind| "category") (|satBreak|) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{Clients}" - (CONS - "\\tab{12}Constructors" - (CONS '|kcuPage| - (CONS NIL NIL)))) - NIL)) - NIL)) - (COND - ((HGET |$defaultPackageNamesHT| |conname|) - (|htSay| " which {\\em may use} this default package")) - ('T - (|htSay| " which {\\em use} this " - |kind|)))) - ('T NIL)))) - (COND - ((OR (NEQUAL |kind| "category") - (|dbpHasDefaultCategory?| |xpart|)) - (|satBreak|) - (SPADLET |message| - (COND - ((BOOT-EQUAL |kind| "category") - (CONS "Constructors {\\em used by} its default package" - NIL)) - ('T - (CONS "Constructors {\\em used by} the " - (CONS |kind| NIL))))) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{Benefactors}" - (CONS - (CONS - (CONS '|text| - (CONS "\\tab{12}" - |message|)) - NIL) - (CONS '|kcnPage| (CONS NIL NIL)))) - NIL)) - NIL)))) - (COND - ((AND (NULL (|asharpConstructorName?| |conname|)) - (|hasNewInfoAlist| |conname|)) - (|satBreak|) - (SPADLET |message| - (CONS "Cross reference for capsule implementation" - NIL)) - (|htMakePage| - (CONS (CONS '|bcLinks| - (CONS (CONS - "\\menuitemstyle{CapsuleInfo}" - (CONS - (CONS - (CONS '|text| - (CONS "\\tab{12}" - |message|)) - NIL) - (CONS '|kciPage| (CONS NIL NIL)))) - NIL)) - NIL)))) - (|htEndMenu| 3) (|htShowPage|))))))) - -;kcpPage(htPage,junk) == -; [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; domname := kDomainName(htPage,kind,name,nargs) -; domname is ['error,:.] => errorPage(htPage,domname) -; heading := -; null domname => htpProperty(htPage,'heading) -; ['"{\sf ",form2HtString(domname,nil,true),'"}"] -; if domname then -; htpSetProperty(htPage,'domname,domname) -; htpSetProperty(htPage,'heading,heading) -; conform := htpProperty(htPage,'conform) -; conname := opOf conform -; page := htInitPage(['"Parents of ",:heading],htCopyProplist htPage) -; parents := parentsOf conname --was listSort(function GLESSEQP, =this) -; if domname then parents := SUBLISLIS(rest domname,rest conform,parents) -; htpSetProperty(htPage,'cAlist,parents) -; htpSetProperty(htPage,'thing,'"parent") -; choice := -; domname => 'parameters -; 'names -; dbShowCons(htPage,choice) - -(DEFUN |kcpPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (PROG (|LETTMP#1| |kind| |name| |nargs| |xpart| |sig| |args| |abbrev| - |comments| |domname| |heading| |conform| |conname| |page| - |parents| |choice|) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) - (SPADLET |kind| (CAR |LETTMP#1|)) - (SPADLET |name| (CADR |LETTMP#1|)) - (SPADLET |nargs| (CADDR |LETTMP#1|)) - (SPADLET |xpart| (CADDDR |LETTMP#1|)) - (SPADLET |sig| (CAR (CDDDDR |LETTMP#1|))) - (SPADLET |args| (CADR (CDDDDR |LETTMP#1|))) - (SPADLET |abbrev| (CADDR (CDDDDR |LETTMP#1|))) - (SPADLET |comments| (CADDDR (CDDDDR |LETTMP#1|))) - (SPADLET |domname| - (|kDomainName| |htPage| |kind| |name| |nargs|)) - (COND - ((AND (CONSP |domname|) (EQ (QCAR |domname|) '|error|)) - (|errorPage| |htPage| |domname|)) - ('T - (SPADLET |heading| - (COND - ((NULL |domname|) - (|htpProperty| |htPage| '|heading|)) - ('T - (CONS "{\\sf " - (CONS (|form2HtString| |domname| NIL 'T) - (CONS "}" NIL)))))) - (COND - (|domname| - (|htpSetProperty| |htPage| '|domname| |domname|) - (|htpSetProperty| |htPage| '|heading| |heading|))) - (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) - (SPADLET |conname| (|opOf| |conform|)) - (SPADLET |page| - (|htInitPage| - (CONS "Parents of " |heading|) - (|htCopyProplist| |htPage|))) - (SPADLET |parents| (|parentsOf| |conname|)) - (COND - (|domname| (SPADLET |parents| - (SUBLISLIS (CDR |domname|) - (CDR |conform|) |parents|)))) - (|htpSetProperty| |htPage| '|cAlist| |parents|) - (|htpSetProperty| |htPage| '|thing| "parent") - (SPADLET |choice| - (COND (|domname| '|parameters|) ('T '|names|))) - (|dbShowCons| |htPage| |choice|))))))) - -;reduceAlistForDomain(alist,domform,conform) == --called from kccPage -; alist := SUBLISLIS(rest domform,rest conform,alist) -; for pair in alist repeat RPLACD(pair,simpHasPred(CDR pair,domform)) -; [pair for (pair := [.,:pred]) in alist | pred] - -(DEFUN |reduceAlistForDomain| (|alist| |domform| |conform|) - (PROG (|pred|) - (RETURN - (SEQ (PROGN - (SPADLET |alist| - (SUBLISLIS (CDR |domform|) (CDR |conform|) - |alist|)) - (DO ((G166424 |alist| (CDR G166424)) (|pair| NIL)) - ((OR (ATOM G166424) - (PROGN (SETQ |pair| (CAR G166424)) NIL)) - NIL) - (SEQ (EXIT (RPLACD |pair| - (|simpHasPred| (CDR |pair|) - |domform|))))) - (PROG (G166436) - (SPADLET G166436 NIL) - (RETURN - (DO ((G166443 |alist| (CDR G166443)) (|pair| NIL)) - ((OR (ATOM G166443) - (PROGN (SETQ |pair| (CAR G166443)) NIL) - (PROGN - (PROGN - (SPADLET |pred| (CDR |pair|)) - |pair|) - NIL)) - (NREVERSE0 G166436)) - (SEQ (EXIT (COND - (|pred| (SETQ G166436 - (CONS |pair| G166436)))))))))))))) - -;kcaPage(htPage,junk) == -; kcaPage1(htPage,'"category",'" an ",'"ancestor",function ancestorsOf, false) - -(DEFUN |kcaPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (|kcaPage1| |htPage| "category" " an " - "ancestor" (|function| |ancestorsOf|) NIL)) - -;kcdPage(htPage,junk) == -; kcaPage1(htPage,'"category",'" a ",'"descendant",function descendantsOf,true) - -(DEFUN |kcdPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (|kcaPage1| |htPage| "category" " a " - "descendant" (|function| |descendantsOf|) 'T)) - -;kcdoPage(htPage,junk)== -; kcaPage1(htPage,'"domain",'" a ",'"descendant",function domainsOf, false) - -(DEFUN |kcdoPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (|kcaPage1| |htPage| "domain" " a " - "descendant" (|function| |domainsOf|) NIL)) - -;kcaPage1(htPage,kind,article,whichever,fn, isCatDescendants?) == -; [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; domname := kDomainName(htPage,kind,name,nargs) -; domname is ['error,:.] => errorPage(htPage,domname) -; heading := -; null domname => htpProperty(htPage,'heading) -; ['"{\sf ",form2HtString(domname,nil,true),'"}"] -; if domname and not isCatDescendants? then -; htpSetProperty(htPage,'domname,domname) -; htpSetProperty(htPage,'heading,heading) -; conform := htpProperty(htPage,'conform) -; conname := opOf conform -; ancestors := FUNCALL(fn, conform, domname) -; if whichever ^= '"ancestor" then -; ancestors := augmentHasArgs(ancestors,conform) -; ancestors := listSort(function GLESSEQP,ancestors) -;--if domname then ancestors := SUBST(domname,'$,ancestors) -; htpSetProperty(htPage,'cAlist,ancestors) -; htpSetProperty(htPage,'thing,whichever) -; choice := -;-- domname => 'parameters -; 'names -; dbShowCons(htPage,choice) - -(DEFUN |kcaPage1| - (|htPage| |kind| |article| |whichever| |fn| |isCatDescendants?|) - (declare (ignore |article|)) - (PROG (|LETTMP#1| |name| |nargs| |xpart| |sig| |args| |abbrev| - |comments| |domname| |heading| |conform| |conname| - |ancestors| |choice|) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) - (SPADLET |kind| (CAR |LETTMP#1|)) - (SPADLET |name| (CADR |LETTMP#1|)) - (SPADLET |nargs| (CADDR |LETTMP#1|)) - (SPADLET |xpart| (CADDDR |LETTMP#1|)) - (SPADLET |sig| (CAR (CDDDDR |LETTMP#1|))) - (SPADLET |args| (CADR (CDDDDR |LETTMP#1|))) - (SPADLET |abbrev| (CADDR (CDDDDR |LETTMP#1|))) - (SPADLET |comments| (CADDDR (CDDDDR |LETTMP#1|))) - (SPADLET |domname| - (|kDomainName| |htPage| |kind| |name| |nargs|)) - (COND - ((AND (CONSP |domname|) (EQ (QCAR |domname|) '|error|)) - (|errorPage| |htPage| |domname|)) - ('T - (SPADLET |heading| - (COND - ((NULL |domname|) - (|htpProperty| |htPage| '|heading|)) - ('T - (CONS "{\\sf " - (CONS (|form2HtString| |domname| NIL 'T) - (CONS "}" NIL)))))) - (COND - ((AND |domname| (NULL |isCatDescendants?|)) - (|htpSetProperty| |htPage| '|domname| |domname|) - (|htpSetProperty| |htPage| '|heading| |heading|))) - (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) - (SPADLET |conname| (|opOf| |conform|)) - (SPADLET |ancestors| (FUNCALL |fn| |conform| |domname|)) - (COND - ((NEQUAL |whichever| "ancestor") - (SPADLET |ancestors| - (|augmentHasArgs| |ancestors| |conform|)))) - (SPADLET |ancestors| - (|listSort| (|function| GLESSEQP) |ancestors|)) - (|htpSetProperty| |htPage| '|cAlist| |ancestors|) - (|htpSetProperty| |htPage| '|thing| |whichever|) - (SPADLET |choice| '|names|) - (|dbShowCons| |htPage| |choice|))))))) - -;kccPage(htPage,junk) == -; [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) -; domname := kDomainName(htPage,kind,name,nargs) -; domname is ['error,:.] => errorPage(htPage,domname) -; heading := -; null domname => htpProperty(htPage,'heading) -; ['"{\sf ",form2HtString(domname,nil,true),'"}"] -; if domname then -; htpSetProperty(htPage,'domname,domname) -; htpSetProperty(htPage,'heading,heading) -; conform := htpProperty(htPage,'conform) -; conname := opOf conform -; page := htInitPage(['"Children of ",:heading],htCopyProplist htPage) -; children:= augmentHasArgs(childrenOf conform,conform) -; if domname then children := reduceAlistForDomain(children,domname,conform) -; htpSetProperty(htPage,'cAlist,children) -; htpSetProperty(htPage,'thing,'"child") -; dbShowCons(htPage,'names) - -(DEFUN |kccPage| (|htPage| |junk|) - (declare (ignore |junk|)) - (PROG (|LETTMP#1| |kind| |name| |nargs| |xpart| |sig| |args| |abbrev| - |comments| |domname| |heading| |conform| |conname| |page| - |children|) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) - (SPADLET |kind| (CAR |LETTMP#1|)) - (SPADLET |name| (CADR |LETTMP#1|)) - (SPADLET |nargs| (CADDR |LETTMP#1|)) - (SPADLET |xpart| (CADDDR |LETTMP#1|)) - (SPADLET |sig| (CAR (CDDDDR |LETTMP#1|))) - (SPADLET |args| (CADR (CDDDDR |LETTMP#1|))) - (SPADLET |abbrev| (CADDR (CDDDDR |LETTMP#1|))) - (SPADLET |comments| (CADDDR (CDDDDR |LETTMP#1|))) - (SPADLET |domname| - (|kDomainName| |htPage| |kind| |name| |nargs|)) - (COND - ((AND (CONSP |domname|) (EQ (QCAR |domname|) '|error|)) - (|errorPage| |htPage| |domname|)) - ('T - (SPADLET |heading| - (COND - ((NULL |domname|) - (|htpProperty| |htPage| '|heading|)) - ('T - (CONS "{\\sf " - (CONS (|form2HtString| |domname| NIL 'T) - (CONS "}" NIL)))))) - (COND - (|domname| - (|htpSetProperty| |htPage| '|domname| |domname|) - (|htpSetProperty| |htPage| '|heading| |heading|))) - (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) - (SPADLET |conname| (|opOf| |conform|)) - (SPADLET |page| - (|htInitPage| - (CONS "Children of " |heading|) - (|htCopyProplist| |htPage|))) - (SPADLET |children| - (|augmentHasArgs| (|childrenOf| |conform|) - |conform|)) - (COND - (|domname| - (SPADLET |children| - (|reduceAlistForDomain| |children| |domname| - |conform|)))) - (|htpSetProperty| |htPage| '|cAlist| |children|) - (|htpSetProperty| |htPage| '|thing| "child") - (|dbShowCons| |htPage| '|names|))))))) - -;augmentHasArgs(alist,conform) == -; conname := opOf conform -; args := KDR conform or return alist -; n := #args -; [[name,:pred] for [name,:p] in alist] where pred == -; extractHasArgs p is [a,:b] => p -; quickAnd(p,['hasArgs,:TAKE(n,KDR getConstructorForm opOf name)]) - -(DEFUN |augmentHasArgs| (|alist| |conform|) - (PROG (|conname| |args| |n| |name| |p| |ISTMP#1| |a| |b|) - (RETURN - (SEQ (PROGN - (SPADLET |conname| (|opOf| |conform|)) - (SPADLET |args| (OR (KDR |conform|) (RETURN |alist|))) - (SPADLET |n| (|#| |args|)) - (PROG (G166581) - (SPADLET G166581 NIL) - (RETURN - (DO ((G166592 |alist| (CDR G166592)) - (G166557 NIL)) - ((OR (ATOM G166592) - (PROGN (SETQ G166557 (CAR G166592)) NIL) - (PROGN - (PROGN - (SPADLET |name| (CAR G166557)) - (SPADLET |p| (CDR G166557)) - G166557) - NIL)) - (NREVERSE0 G166581)) - (SEQ (EXIT (SETQ G166581 - (CONS - (CONS |name| - (COND - ((PROGN - (SPADLET |ISTMP#1| - (|extractHasArgs| |p|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#1|)) - (SPADLET |b| - (QCDR |ISTMP#1|)) - 'T))) - |p|) - ('T - (|quickAnd| |p| - (CONS '|hasArgs| - (TAKE |n| - (KDR - (|getConstructorForm| - (|opOf| |name|))))))))) - G166581)))))))))))) - ;kcdePage(htPage,junk) == ; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) ; conname := INTERN name