diff --git a/changelog b/changelog index 6dba97d..e22f56c 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090830 tpd src/axiom-website/patches.html 20090830.01.tpd.patch +20090830 tpd src/interp/Makefile move br-con.boot to br-con.lisp +20090830 tpd src/interp/br-con.lisp added, rewritten from br-con.boot +20090830 tpd src/interp/br-con.boot removed, rewritten to br-con.lisp 20090828 tpd src/axiom-website/patches.html 20090828.05.tpd.patch 20090828 tpd src/interp/Makefile remove all .dvi usage 20090828 tpd src/axiom-website/patches.html 20090828.04.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 5e57f9e..d36f6c6 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1938,5 +1938,7 @@ compiler.lisp rewrite from boot to lisp
sfsfun.lisp rewrite from boot to lisp
20090828.05.tpd.patch src/interp/Makefile remove all .dvi usage
+20090830.01.tpd.patch +src/interp/br-con rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index c17e40f..badd6f7 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -3505,6 +3505,7 @@ ${MID}/ax.clisp: ${IN}/ax.boot.pamphlet @ +\subsection{br-con.lisp} \subsection{br-con.boot} <>= ${AUTO}/br-con.${O}: ${OUT}/br-con.${O} @@ -3513,32 +3514,24 @@ ${AUTO}/br-con.${O}: ${OUT}/br-con.${O} @ <>= -${OUT}/br-con.${O}: ${MID}/br-con.clisp - @ echo 466 making ${OUT}/br-con.${O} from ${MID}/br-con.clisp - @ (cd ${MID} ; \ +${OUT}/br-con.${O}: ${MID}/br-con.lisp + @ echo 136 making ${OUT}/br-con.${O} from ${MID}/br-con.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/br-con.clisp"' \ - ':output-file "${OUT}/br-con.${O}") (${BYE}))' | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/br-con.lisp"' \ + ':output-file "${OUT}/br-con.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/br-con.clisp"' \ - ':output-file "${OUT}/br-con.${O}") (${BYE}))' | ${DEPSYS} \ + echo '(progn (compile-file "${MID}/br-con.lisp"' \ + ':output-file "${OUT}/br-con.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/br-con.clisp: ${IN}/br-con.boot.pamphlet - @ echo 467 making ${MID}/br-con.clisp from ${IN}/br-con.boot.pamphlet +<>= +${MID}/br-con.lisp: ${IN}/br-con.lisp.pamphlet + @ echo 137 making ${MID}/br-con.lisp from ${IN}/br-con.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/br-con.boot.pamphlet >br-con.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "br-con.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "br-con.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm br-con.boot ) + ${TANGLE} ${IN}/br-con.lisp.pamphlet >br-con.lisp ) @ @@ -4531,7 +4524,7 @@ clean: <> <> -<> +<> <> <> diff --git a/src/interp/br-con.boot.pamphlet b/src/interp/br-con.boot.pamphlet deleted file mode 100644 index 4426017..0000000 --- a/src/interp/br-con.boot.pamphlet +++ /dev/null @@ -1,7999 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp br-con.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - ---====================> WAS b-con.boot <================================ - ---======================================================================= --- Pages Initiated from HyperDoc Pages ---======================================================================= ---NOTE: This duplicate version was discovered 3/20/94 in br-search.boot ---called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon ---conPage(a,:b) == --- --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) --- $conArgstrings: local := --- atom a => b --- a := conform2OutputForm a --- [mathform2HtString x for x in rest a] --- if not atom a then a := first a --- da := DOWNCASE a --- pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) => --- downlink pageName --special jump out for primitive domains --- line := conPageFastPath a => kPage line --lower case name of cons? --- line := conPageFastPath UPCASE a => kPage line --upper case an abbr? --- ySearch a --slow search (include default packages) --- - ---called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon -conPage(a,:b) == - --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) - form := - atom a => [a,:b] - a - $conArgstrings: local := [form2HtString x for x in KDR a] - if not atom a then a := first a - da := DOWNCASE a - pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) => - downlink pageName --special jump out for primitive domains - line := conPageFastPath da => kPage(line,form) --lower case name of cons? - line := conPageFastPath UPCASE a => kPage(line,form) --upper case an abbr? - ySearch a --slow search (include default packages) - -conPageFastPath x == --called by conPage and constructorSearch ---gets line quickly for constructor name or abbreviation - s := STRINGIMAGE x - charPosition(char '_*,s,0) < #s => nil --quit if name has * in it - name := (STRINGP x => INTERN x; x) - entry := HGET($lowerCaseConTb,name) or return nil - lineNumber := LASSQ('dbLineNumber,CDDR entry) => - --'dbLineNumbers property is set by function dbAugmentConstructorDataTable - dbRead lineNumber --read record for constructor from libdb.text - conPageConEntry first entry - -conPageConEntry entry == - $conname: local := nil - $conform: local := nil - $exposed?:local := nil - $doc: local := nil - $kind: local := nil - buildLibdbConEntry entry - ---======================================================================= --- Constructor Page ---======================================================================= --- in br-saturn.boot now ---% kPage(line,:options) == --any cat, dom, package, default package ---% --constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) ---% ------------------> BRANCH OUT FOR SATURN ---% true => kPageSaturn(line,options) ---% parts := dbXParts(line,7,1) ---% [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts ---% form := IFCAR options ---% isFile := null kind ---% kind := kind or '"package" ---% RPLACA(parts,kind) ---% conform := mkConform(kind,name,args) ---% conname := opOf conform ---% capitalKind := capitalize kind ---% signature := ncParseFromString sig ---% sourceFileName := dbSourceFile INTERN name ---% constrings := ---% KDR form => dbConformGenUnder form ---% [STRCONC(name,args)] ---% emString := ['"{\sf ",:constrings,'"}"] ---% heading := [capitalKind,'" ",:emString] ---% if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] ---% if name=abbrev then abbrev := asyAbbreviation(conname,nargs) ---% page := htInitPage(heading,nil) ---% htpSetProperty(page,'isFile,true) ---% htpSetProperty(page,'parts,parts) ---% htpSetProperty(page,'heading,heading) ---% htpSetProperty(page,'kind,kind) ---% if asharpConstructorName? conname then ---% htpSetProperty(page,'isAsharpConstructor,true) ---% htpSetProperty(page,'conform,conform) ---% htpSetProperty(page,'signature,signature) ---% kdPageInfo(name,abbrev,nargs,conform,signature,isFile) ---% htSayStandard '"\newline" ---% htBeginMenu(3) ---% htSayStandard '"\item " ---% htMakePage [['bcLinks,['"\menuitemstyle{Description}", ---% [['text,'"\tab{19}",'"General description"]],'kiPage,nil]]] ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Operations}", ---% [['text,'"\tab{19}All exported operations"]],'koPage,'"operation"]]] ---% if not asharpConstructorName? conname then ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Attributes}", ---% [['text,'"\tab{19}All exported attributes"]],'koPage,'"attribute"]]] ---% if kind ^= 'category and (pathname := dbHasExamplePage conname) then ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Examples}", ---% [['text,'"\tab{19}Examples illustrating use"]],'kxPage,pathname]]] ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Exports}", ---% [['text,'"\tab{19}Explicit categories and operations"]],'kePage,nil]]] ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Cross Reference}", ---% [['text,'"\tab{19}Hierarchy and usage information"]],'kcPage,nil]]] ---% htEndMenu(3) ---% if kind ^= 'category and nargs > 0 then addParameterTemplates conform ---% htShowPage() ---% -conform2String u == - x := form2String u - atom x => STRINGIMAGE x - "STRCONC"/[STRINGIMAGE y for y in x] - -kxPage(htPage,name) == downlink name - -kdPageInfo(name,abbrev,nargs,conform,signature,file?) == - htSay("{\sf ",name,'"}") - if abbrev ^= name then bcHt [" has abbreviation ",abbrev] - if file? then bcHt ['" is a source file."] - if nargs = 0 then (if abbrev ^= name then bcHt '".") - else - if abbrev ^= name then bcHt '" and" - bcHt - nargs = 1 => '" takes one argument:" - [" takes ",STRINGIMAGE nargs," arguments:"] - htSaturnBreak() - htSayStandard '"\indentrel{2}" - if nargs > 0 then kPageArgs(conform,signature) - htSayStandard '"\indentrel{-2}" - if name.(#name-1) = char "&" then name := SUBSEQ(name, 0, #name-1) ---sourceFileName := dbSourceFile INTERN name - sourceFileName := GETDATABASE(INTERN name,'SOURCEFILE) - filename := extractFileNameFromPath sourceFileName - if filename ^= '"" then - htSayStandard '"\newline{}" - htSay('"The source code for the constructor is found in ") - htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", - sourceFileName, '" ", name, '"}"]] - if nargs ^= 0 then htSay '"." - htSaturnBreak() - -kPageArgs([op,:args],[.,.,:source]) == -------------------> OBSELETE - firstTime := true - coSig := rest GETDATABASE(op,'COSIG) - for x in args for t in source for pred in coSig repeat - if not firstTime then htSay '", and" - htSay('"\newline ") - typeForm := (t is [":",.,t1] => t1; t) - if pred = true - then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] - else htSay('"{\em ",x,'"}") - htSay( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ") - htSay - pred => '"a domain of category " - '"an element of the domain " - bcConform(typeForm,true) - -kArgPage(htPage,arg) == - [op,:args] := conform := htpProperty(htPage,'conform) - domname := htpProperty(htPage,'domname) - heading := htpProperty(htPage,'heading) - source := CDDAR getConstructorModemap op - n := position(arg,args) - typeForm := sublisFormal(args,source . n) - domTypeForm := mkDomTypeForm(typeForm,conform,domname) - descendants := domainDescendantsOf(typeForm,domTypeForm) - htpSetProperty(htPage,'cAlist,descendants) - rank := - n > 4 => nil - ('(First Second Third Fourth Fifth)).n - htpSetProperty(htPage,'rank,rank) - htpSetProperty(htPage,'thing,'"argument") ---htpSetProperty(htPage,'specialMessage,['reportCategory,conform,typeForm,arg]) - dbShowCons(htPage,'names) - -reportCategory(conform,typeForm,arg) == - htSay('"Argument {\em ",arg,'"}") - [conlist,attrlist,:oplist] := categoryParts(conform,typeForm,true) - htSay '" must " - if conlist then - htSay '"belong to " - if conlist is [u] then - htSay('"category ") - bcConform first u - bcPred rest u - else - htSay('"categories:") - bcConPredTable(conlist,opOf conform) - htSay '"\newline " - if attrlist then - if conlist then htSay '" and " - reportAO('"attribute",attrlist) - htSay '"\newline " - if oplist then - if conlist or attrlist then htSay '" and " - reportAO('"operation",oplist) - -reportAO(kind,oplist) == - htSay('"have ",kind,'":") - for [op,sig,:pred] in oplist repeat - htSay '"\newline " - if #oplist = 1 then htSay '"\centerline{" - if kind = '"attribute" then - attr := form2String [op,:sig] - satDownLink(attr,['"(|attrPage| '|",attr,'"|)"]) - else - ops := escapeSpecialChars STRINGIMAGE op - sigs := form2HtString ['Mapping,:sig] - satDownLink(ops,['"(|opPage| '|",ops,'"| |",sigs,'"|)"]) - htSay '": " - bcConform ['Mapping,:sig] - if #oplist = 1 then htSay '"}" - htSay '"\newline " - -mkDomTypeForm(typeForm,conform,domname) == --called by kargPage - domname => SUBLISLIS(rest domname,rest conform,typeForm) - typeForm is ['Join,:r] => ['Join,:[mkDomTypeForm(t,conform,domname) for t in r]] - null hasIdent typeForm => typeForm - nil - -domainDescendantsOf(conform,domform) == main where --called by kargPage - main == - conform is [op,:r] => - op = 'Join => jfn(DELETE('(Type Object),r),DELETE('(Type Object),IFCDR domform)) - op = 'CATEGORY => nil - domainsOf(conform,domform) - domainsOf(conform,domform) - jfn([y,:r],domlist) == --keep only those domains that appear in ALL parts of Join - alist := domainsOf(y,IFCAR domlist) - for x in r repeat - domlist := IFCDR domlist - x is ['CATEGORY,.,:r] => alist := catScreen(r,alist) - keepList := nil - for [item,:pred] in domainsOf(x,IFCAR domlist) repeat - u := ASSOC(item,alist) => - keepList := [[item,:quickAnd(CDR u,pred)],:keepList] - alist := keepList - for pair in alist repeat RPLACD(pair,simpHasPred CDR pair) - listSort(function GLESSEQP, alist) - catScreen(r,alist) == - for x in r repeat - x isnt [op1,:.] and MEMQ(op1,'(ATTRIBUTE SIGNATURE)) => systemError x - alist := [[item,:npred] for [item,:pred] in alist | - (pred1 := simpHasPred ['has,item,x]) and (npred := quickAnd(pred1,pred))] - alist - ---======================================================================= --- Branches of Constructor Page ---======================================================================= - -kiPage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - conform := mkConform(kind,name,args) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := ['"Description of ", capitalize kind,'" {\sf ",name,args,'"}"] - page := htInitPage(heading,htCopyProplist htPage) - $conformsAreDomains := domname - dbShowConsDoc1(htPage,conform,nil) - htShowPage() - -kePage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - constring := STRCONC(name,args) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - htpSetProperty(htPage,'domname,domname) - $conformsAreDomains: local := domname - conform := mkConform(kind,name,args) - conname := opOf conform - heading := [capitalize kind,'" {\sf ", - (domname => form2HtString(domname,nil,true); constring),'"}"] - data := sublisFormal(IFCDR domname or rest conform, - getConstructorExports((domname or conform),true)) - [conlist,attrlist,:oplist] := data - if domname then - for x in conlist repeat RPLAC(CDR x,simpHasPred CDR x) - for x in attrlist repeat RPLAC(CDDR x,simpHasPred CDDR x) - for x in oplist repeat RPLAC(CDDR x,simpHasPred CDDR x) - prefix := pluralSay(#conlist + #attrlist + #oplist,'"Export",'"Exports") - page := htInitPage([:prefix,'" of ",:heading],htCopyProplist htPage) - htSayStandard '"\beginmenu " - htpSetProperty(page,'data,data) - if conlist then - htMakePage [['bcLinks,[menuButton(),'"",'dbShowCons1,conlist,'names]]] - htSayStandard '"\tab{2}" - htSay '"All attributes and operations from:" - bcConPredTable(conlist,opOf conform,rest conform) - if attrlist then - if conlist then htBigSkip() - kePageDisplay(page,'"attribute",kePageOpAlist attrlist) - if oplist then - if conlist or attrlist then htBigSkip() - kePageDisplay(page,'"operation",kePageOpAlist oplist) - htSayStandard '" \endmenu " - htShowPage() - -kePageOpAlist oplist == - opAlist := nil - for [op,sig,:pred] in oplist repeat - u := LASSOC(op,opAlist) ---was --- opAlist := insertAlist(op,[[sig,pred],:u],opAlist) - opAlist := insertAlist(zeroOneConvert op,[[sig,pred],:u],opAlist) - opAlist - -kePageDisplay(htPage,which,opAlist) == - count := #opAlist - total := +/[#(rest entry) for entry in opAlist] - count = 0 => nil - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'lists) --mark as unexpanded - htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,'names]]] - htSayStandard '"\tab{2}" - if count ^= total then - if count = 1 - then htSay('"1 name for ") - else htSay(STRINGIMAGE count,'" names for ") - if total > 1 - then htSay(STRINGIMAGE total,'" ",pluralize which,'" are explicitly exported:") - else htSay('"1 ",which,'" is explicitly exported:") - htSaySaturn '"\\" - data := dbGatherData(htPage,opAlist,which,'names) - dbShowOpItems(which,data,false) - -ksPage(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) - domain := (kind = '"category" => nil; EVAL domname) - conform:= htpProperty(htPage,'conform) - page := htInitPageNoScroll(htCopyProplist htPage, - ['"Search order for ",:heading]) - htSay '"When an operation is not defined by the domain, the following domains are searched in order for a _"default definition" - htSayStandard '"\beginscroll " - u := dbSearchOrder(conform,domname,domain) - htpSetProperty(htPage,'cAlist,u) - htpSetProperty(htPage,'thing,'"constructor") - dbShowCons(htPage,'names) - -dbSearchOrder(conform,domname,$domain) == --domain = nil or set to live domain - conform := domname or conform - name:= opOf conform - $infovec: local := dbInfovec name or return nil --exit for categories - u := $infovec.3 - $predvec:= - $domain => $domain . 3 - GETDATABASE(name,'PREDICATES) - catpredvec := CAR u - catinfo := CADR u - catvec := CADDR u - catforms := [[pakform,:pred] for i in 0..MAXINDEX catvec | test ] where - test == - pred := simpCatPredicate - p:=SUBLISLIS(rest conform,$FormalMapVariableList,kTestPred catpredvec.i) - $domain => EVAL p - p - if domname and CONTAINED('$,pred) then pred := SUBST(domname,'$,pred) --- which = '"attribute" => pred --all categories - (pak := catinfo . i) and pred --only those with default packages - pakform == - pak and not IDENTP pak => devaluate pak --in case it has been instantiated - catform := kFormatSlotDomain catvec . i --- which = '"attribute" => dbSubConform(rest conform,catform) - res := dbSubConform(rest conform,[pak,"$",:rest catform]) - if domname then res := SUBST(domname,'$,res) - res - [:dbAddChain conform,:catforms] - -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() - -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) - -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] - -kcaPage(htPage,junk) == - kcaPage1(htPage,'"category",'" an ",'"ancestor",function ancestorsOf, false) - -kcdPage(htPage,junk) == - kcaPage1(htPage,'"category",'" a ",'"descendant",function descendantsOf,true) - -kcdoPage(htPage,junk)== - kcaPage1(htPage,'"domain",'" a ",'"descendant",function domainsOf, false) - -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) - -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) - -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)]) - -kcdePage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - conname := INTERN name - constring := STRCONC(name,args) - conform := - kind ^= '"default package" => ncParseFromString constring - [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & - pakname := --- kind = '"category" => INTERN STRCONC(name,char '_&) - opOf conform - domList := getDependentsOfConstructor pakname - cAlist := [[getConstructorForm x,:true] for x in domList] - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"dependent") - dbShowCons(htPage,'names) - -kcuPage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - conname := INTERN name - constring := STRCONC(name,args) - conform := - kind ^= '"default package" => ncParseFromString constring - [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & - pakname := - kind = '"category" => INTERN STRCONC(name,char '_&) - opOf conform - domList := getUsersOfConstructor pakname - cAlist := [[getConstructorForm x,:true] for x in domList] - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"user") - dbShowCons(htPage,'names) - -kcnPage(htPage,junk) == ---if reached by a category, that category has a default package - [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) - pakname := - kind = '"category" => INTERN STRCONC(PNAME conname,char '_&) - opOf conform - domList := getImports pakname - if domname then - domList := SUBLISLIS([domname,:rest domname],['$,:rest conform],domList) - cAlist := [[x,:true] for x in domList] - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"benefactor") - dbShowCons(htPage,'names) - -koPageInputAreaUnchanged?(htPage, nargs) == - [htpLabelInputString(htPage,INTERN STRCONC('"*",STRINGIMAGE i)) for i in 1..nargs] - = htpProperty(htPage,'inputAreaList) - -kDomainName(htPage,kind,name,nargs) == - htpSetProperty(htPage,'domname,nil) - inputAreaList := - [htpLabelInputString(htPage,var) for i in 1..nargs for var in $PatternVariableList] - htpSetProperty(htPage,'inputAreaList,inputAreaList) - conname := INTERN name - args := [kArgumentCheck(domain?,x) or nil for x in inputAreaList - for domain? in rest GETDATABASE(conname,'COSIG)] - or/[null x for x in args] => - (n := +/[1 for x in args | x]) > 0 => - ['error,nil,'"\centerline{You gave values for only {\em ",n,'" } of the {\em ",#args,'"}}",'"\centerline{parameters of {\sf ",name,'"}}\vspace{1}\centerline{Please enter either {\em all} or {\em none} of the type parameters}"] - nil - argString := - null args => '"()" - argTailPart := - "STRCONC"/["STRCONC"/ ['",",:x] for x in KDR args] - "STRCONC"/['"(",:first args,argTailPart,'")"] - typeForm := CATCH('SPAD__READER, unabbrev mkConform(kind,name,argString)) or - ['error,'invalidType,STRCONC(name,argString)] - null (evaluatedTypeForm := kisValidType typeForm) => - ['error,'invalidType,STRCONC(name,argString)] - dbMkEvalable evaluatedTypeForm - -kArgumentCheck(domain?,s) == - s = '"" => nil - domain? and (form := conSpecialString? s) => - null KDR form => [STRINGIMAGE opOf form] - form2String form - [s] - -dbMkEvalable form == ---like mkEvalable except that it does NOT quote domains ---does not do "loadIfNecessary" - [op,:.] := form - kind := GETDATABASE(op,'CONSTRUCTORKIND) - kind = 'category => form - mkEvalable form - -topLevelInterpEval x == - $ProcessInteractiveValue: fluid := true - $noEvalTypeMsg: fluid := true - processInteractive(x,nil) - -kisValidType typeForm == - $ProcessInteractiveValue: fluid := true - $noEvalTypeMsg: fluid := true - CATCH('SPAD__READER, processInteractive(typeForm,nil)) - is [[h,:.],:t] and MEMBER(h,'(Domain SubDomain)) => - kCheckArgumentNumbers t and t - false - -kCheckArgumentNumbers t == - [conname,:args] := t - cosig := KDR GETDATABASE(conname,'COSIG) - #cosig ^= #args => false - and/[foo for domain? in cosig for x in args] where foo == - domain? => kCheckArgumentNumbers x - true - -parseNoMacroFromString(s) == - s := next(function ncloopParse, - next(function lineoftoks,incString s)) - StreamNull s => nil - pf2Sex first rest first s - - - -mkConform(kind,name,argString) == - kind ^= '"default package" => - form := STRCONC(name,argString) - parse := parseNoMacroFromString form - null parse => - sayBrightlyNT '"Won't parse: " - pp form - systemError '"Keywords in argument list?" - ATOM parse => [parse] - parse - [INTERN name,:rest ncParseFromString STRCONC(char 'd,argString)] --& case - ---======================================================================= --- Operation Page for a Domain Form from Scratch ---======================================================================= -conOpPage(htPage,conform) == - updown := dbCompositeWithMap htPage - updown = '"DOWN" => - domname := htpProperty(htPage,'domname) - conOpPage1(dbExtractUnderlyingDomain domname,[['updomain,:domname]]) - domname := htpProperty(htPage,'updomain) - conOpPage1(domname,nil) - -dbCompositeWithMap htPage == - htpProperty(htPage,'updomain) => '"UP" - domain := htpProperty(htPage,'domname) - null domain => false - opAlist := htpProperty(htPage,'opAlist) ---not LASSOC('map,opAlist) => false - dbExtractUnderlyingDomain htpProperty(htPage,'domname) => '"DOWN" - false - -dbExtractUnderlyingDomain domain == or/[x for x in KDR domain | isValidType x] - ---conform is atomic if no parameters, otherwise must be valid domain form -conOpPage1(conform,:options) == ---constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) - bindingsAlist := IFCAR options - conname := opOf conform - MEMQ(conname,$Primitives) => - dbSpecialOperations conname - domname := --> !!note!! <-- - null atom conform => conform - nil - line := conPageFastPath conname - [kind,name,nargs,xflag,sig,args,abbrev,comments]:=parts:= dbXParts(line,7,1) - isFile := null kind - kind := kind or '"package" - RPLACA(parts,kind) - constring := STRCONC(name,args) - conform := mkConform(kind,name,args) - capitalKind := capitalize kind - signature := ncParseFromString sig - sourceFileName := dbSourceFile INTERN name - emString := ['"{\sf ",constring,'"}"] - heading := [capitalKind,'" ",:emString] - if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] - page := htInitPage(heading,nil) - htpSetProperty(page,'isFile,true) - htpSetProperty(page,'fromConOpPage1,true) - htpSetProperty(page,'parts,parts) - htpSetProperty(page,'heading,heading) - htpSetProperty(page,'kind,kind) - htpSetProperty(page,'domname,domname) --> !!note!! <-- - htpSetProperty(page,'conform,conform) - htpSetProperty(page,'signature,signature) - if selectedOperation := LASSOC('selectedOperation,IFCDR options) then - htpSetProperty(page,'selectedOperation,selectedOperation) - for [a,:b] in bindingsAlist repeat htpSetProperty(page,a,b) - koPage(page,'"operation") - ---======================================================================= --- Operation Page from Main Page ---======================================================================= -koPage(htPage,which) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - constring := STRCONC(name,args) - conname := INTERN name - domname := - (u := htpProperty(htPage,'domname)) is [=conname,:.] - and (htpProperty(htPage,'fromConOpPage1) = true or - koPageInputAreaUnchanged?(htPage,nargs)) => u - kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - htpSetProperty(htPage,'domname,domname) - headingString := - domname => form2HtString(domname,nil,true) - constring - heading := [capitalize kind,'" {\sf ",headingString,'"}"] - htpSetProperty(htPage,'which,which) - htpSetProperty(htPage,'heading,heading) - koPageAux(htPage,which,domname,heading) - -koPageFromKKPage(htPage,ao) == - koPageAux(htPage,ao,htpProperty(htPage,'domname),htpProperty(htPage,'heading)) - -koPageAux(htPage,which,domname,heading) == --from koPage, koPageFromKKPage - htpSetProperty(htPage,'which,which) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - heading := htpProperty(htPage,'heading) - opAlist := - which = '"attribute" => koAttrs(conform,domname) - which = '"general operation" => koOps(conform,domname,true) - koOps(conform,domname) - if selectedOperation := htpProperty(htPage,'selectedOperation) then - opAlist := [ASSOC(selectedOperation,opAlist) or systemError()] - dbShowOperationsFromConform(htPage,which,opAlist) - -koPageAux1(htPage,opAlist) == - which := htpProperty(htPage,'which) - dbShowOperationsFromConform(htPage,which,opAlist) - -koaPageFilterByName(htPage,functionToCall) == - htpLabelInputString(htPage,'filter) = '"" => - koaPageFilterByCategory(htPage,functionToCall) - filter := pmTransFilter(dbGetInputString htPage) ---WARNING: this call should check for ['error,:.] returned - which := htpProperty(htPage,'which) - opAlist := - [x for x in htpProperty(htPage,'opAlist) | superMatch?(filter,DOWNCASE STRINGIMAGE first x)] - htpSetProperty(htPage,'opAlist,opAlist) - FUNCALL(functionToCall,htPage,nil) - ---======================================================================= --- Get Constructor Documentation ---======================================================================= - -dbConstructorDoc(conform,$op,$sig) == fn conform where - fn (conform := [conname,:$args]) == - or/[gn y for y in GETDATABASE(conname,'DOCUMENTATION)] - gn([op,:alist]) == - op = $op and or/[doc or '("") for [sig,:doc] in alist | hn sig] - hn sig == - #$sig = #sig and $sig = SUBLISLIS($args,$FormalMapVariableList,sig) - -dbDocTable conform == ---assumes $docTableHash bound --see dbExpandOpAlistIfNecessary - table := HGET($docTableHash,conform) => table - $docTable : local := MAKE_-HASHTABLE 'ID - --process in reverse order so that closest cover up farthest - for x in originsInOrder conform repeat dbAddDocTable x - dbAddDocTable conform - HPUT($docTableHash,conform,$docTable) - $docTable - -originsInOrder conform == --domain = nil or set to live domain ---from dcCats - [con,:argl] := conform - GETDATABASE(con,'CONSTRUCTORKIND) = 'category => - ASSOCLEFT ancestorsOf(conform,nil) - acc := ASSOCLEFT parentsOf con - for x in acc repeat - for y in originsInOrder x repeat acc := insert(y,acc) - acc - -dbAddDocTable conform == - conname := opOf conform - storedArgs := rest getConstructorForm conname - for [op,:alist] in SUBLISLIS(["$",:rest conform], - ["%",:storedArgs],GETDATABASE(opOf conform,'DOCUMENTATION)) - repeat - op1 := - op = '(Zero) => 0 - op = '(One) => 1 - op - for [sig,doc] in alist repeat - HPUT($docTable,op1,[[conform,:alist],:HGET($docTable,op1)]) - --note opOf is needed!!! for some reason, One and Zero appear within prens - -dbGetDocTable(op,$sig,docTable,$which,aux) == main where ---docTable is [[origin,entry1,...,:code] ...] where --- each entry is [sig,doc] and code is NIL or else a topic code for op - main == - if null FIXP op and - DIGITP (s := STRINGIMAGE op).0 then op := string2Integer s - -- the above hack should be removed after 3/94 when 0 is not |0| - aux is [[packageName,:.],:pred] => - doc := dbConstructorDoc(first aux,$op,$sig) - origin := - pred => ['ifp,:aux] - first aux - [origin,:doc] - or/[gn x for x in HGET(docTable,op)] - gn u == --u is [origin,entry1,...,:code] - $conform := CAR u --origin - if ATOM $conform then $conform := [$conform] - code := LASTATOM u --optional topic code - comments := or/[p for entry in CDR u | p := hn entry] or return nil - [$conform,first comments,:code] - hn [sig,:doc] == - $which = '"attribute" => sig is ['attribute,: =$sig] and doc - pred := #$sig = #sig and - alteredSig := SUBLISLIS(KDR $conform,$FormalMapVariableList,sig) - alteredSig = $sig - pred => - doc => - doc is ['constant,:r] => r - doc - '("") - false - -kTestPred n == - n = 0 => true - $domain => testBitVector($predvec,n) - simpHasPred $predvec.(n - 1) - -dbAddChainDomain conform == - [name,:args] := conform - $infovec := dbInfovec name or return nil --exit for categories - template := $infovec . 0 - null (form := template . 5) => nil - dbSubConform(args,kFormatSlotDomain devaluate form) - -dbSubConform(args,u) == - atom u => - (n := position(u,$FormalMapVariableList)) >= 0 => args . n - u - u is ['local,y] => dbSubConform(args,y) - [dbSubConform(args,x) for x in u] - -dbAddChain conform == - u := dbAddChainDomain conform => - atom u => nil - [[u,:true],:dbAddChain u] - nil - ---======================================================================= --- Constructor Page Menu ---======================================================================= ----------> !OBSELETE! <------------- -dbPresentCons(htPage,kind,:exclusions) == -- calist is ((catform . pred)...) - $saturn => dbPresentConsSaturn(htPage,kind,exclusions) - htSay('"{\em Views:}") - htpSetProperty(htPage,'exclusion,first exclusions) - cAlist := htpProperty(htPage,'cAlist) - empty? := null cAlist - exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 - star? := true --always include information on exposed/unexposed 4/92 - htSayStandard(if star? then '"\tab{13}" else '"\tab{9}") - if empty? or MEMBER('names,exclusions) - then htSay '"{\em names}" - else htMakePage [['bcLispLinks,['"names",'"",'dbShowCons,'names]]] - htSayStandard(if star? then '"\tab{21}" else '"\tab{17}") - if empty? or MEMBER('kinds,exclusions) or kind ^= 'constructor - then htSay '"{\em kinds}" - else htMakePage [['bcLispLinks,['"kinds",'"",'dbShowCons,'kinds]]] - htSayStandard(if star? then '"\tab{29}" else '"\tab{25}") - if empty? or MEMBER('parameters,exclusions) or not or/[CDAR x for x in cAlist] - then htSay '"{\em parameters}" - else htMakePage [['bcLispLinks,['"parameters",'"",'dbShowCons,'parameters]]] - if star? then htSayStandard('"\tab{42}") else htSayStandard('"\tab{38}") - if empty? or null CDR cAlist - then htSay '"{\em filter}" - else htMakePage [['bcLinks,['"filter",'"",'dbShowCons,'filter]]] - htMakePage [['bcStrings, [11,'"",'filter,'EM]]] - htSay('"\newline") - if exposedUnexposedFlag then - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"exposed",'" {\em only}",'dbShowCons,'exposureOff]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'dbShowCons,'exposureOn]]] - htSayStandard(if star? then '"\tab{13}" else '"\tab{9}") - if empty? or MEMBER('abbrs,exclusions) - then htSay '"{\em abbrs}" - else htMakePage [['bcLispLinks,['"abbrs",'"",'dbShowCons,'abbrs]]] - htSayStandard(if star? then '"\tab{21}" else '"\tab{17}") - if empty? or MEMBER('files,exclusions) - then htSay '"{\em files}" - else htMakePage [['bcLispLinks,['"files",'"",'dbShowCons,'files]]] - htSayStandard(if star? then '"\tab{29}" else '"\tab{25}") - if empty? or MEMBER('conditions,exclusions) or and/[CDR x = true for x in cAlist] - then htSay '"{\em conditions}" - else htMakePage [['bcLispLinks,['"conditions",'"",'dbShowCons,'conditions]]] - if star? then htSayStandard('"\tab{42}") else htSayStandard('"\tab{38}") - if empty? or MEMBER('documentation,exclusions) - then htSay '"{\em descriptions}" - else htMakePage [['bcLispLinks,['"descriptions",'"",'dbShowCons,'documentation]]] - -dbShowCons(htPage,key,:options) == - cAlist := htpProperty(htPage,'cAlist) - key = 'filter => - --if $saturn, IFCAR options is the filter string - filter := pmTransFilter(IFCAR options or dbGetInputString htPage) - filter is ['error,:.] => bcErrorPage filter - abbrev? := htpProperty(htPage,'exclusion) = 'abbrs - u := [x for x in cAlist | test] where test == - conname := CAAR x - subject := (abbrev? => constructor? conname; conname) - superMatch?(filter,DOWNCASE STRINGIMAGE subject) - null u => emptySearchPage('"constructor",filter) - htPage := htInitPageNoScroll(htCopyProplist htPage) - htpSetProperty(htPage,'cAlist,u) - dbShowCons(htPage,htpProperty(htPage,'exclusion)) - if MEMQ(key,'(exposureOn exposureOff)) then - $exposedOnlyIfTrue := - key = 'exposureOn => 'T - NIL - key := htpProperty(htPage,'exclusion) - dbShowCons1(htPage,cAlist,key) - -conPageChoose conname == - cAlist := [[getConstructorForm conname,:true]] - dbShowCons1(nil,cAlist,'names) - -dbShowCons1(htPage,cAlist,key) == - conlist := REMDUP [item for x in cAlist | pred] where - pred == - item := CAR x - $exposedOnlyIfTrue => isExposedConstructor opOf item - item ---$searchFirstTime and (conlist is [.]) => conPage first conlist ---$searchFirstTime := false - conlist is [.] => conPage - htPage and htpProperty(htPage,'domname) => first conlist - opOf first conlist - conlist := [opOf x for x in conlist] - kinds := "UNION"/[dbConstructorKind x for x in conlist] - kind := - kinds is [a] => a - 'constructor - proplist := - htPage => htCopyProplist htPage - nil - page := htInitPageNoScroll(proplist,dbConsHeading(htPage,conlist,key,kind)) - if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) - htSayStandard('"\beginscroll ") - htpSetProperty(page,'cAlist,cAlist) - $conformsAreDomains: local := htpProperty(page,'domname) - do - --key = 'catfilter => dbShowCatFilter(page,key) - key = 'names => bcNameConTable conlist - key = 'abbrs => - bcAbbTable [getCDTEntry(con,true) for con in conlist] - key = 'files => - flist := - [y for con in conlist | - y := (fn := GETDATABASE(con,'SOURCEFILE))] - bcUnixTable(listSort(function GLESSEQP,REMDUP flist)) - key = 'documentation => dbShowConsDoc(page,conlist) - if $exposedOnlyIfTrue then - cAlist := [x for x in cAlist | isExposedConstructor opOf CAR x] - key = 'conditions => dbShowConditions(page,cAlist,kind) - key = 'parameters => bcConTable REMDUP ASSOCLEFT cAlist - key = 'kinds => dbShowConsKinds cAlist - dbConsExposureMessage() - htSayStandard("\endscroll ") - dbPresentCons(page,kind,key) - htShowPageNoScroll() - - -dbConsExposureMessage() == - $atLeastOneUnexposed => - htSay '"\newline{}-------------\newline{}{\em *} = unexposed" - --- DUPLICATE DEF - ALSO in br-saturn.boot --- dbShowConsKinds cAlist == --- ---------> !OBSELETE! <------------- --- cats := doms := paks := defs := nil --- for x in cAlist repeat --- op := CAAR x --- kind := dbConstructorKind op --- kind = 'category => cats := [x,:cats] --- kind = 'domain => doms := [x,:doms] --- kind = 'package => paks:= [x,:paks] --- defs := [x,:defs] --- lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] --- htBeginMenu(2) --- htSayStandard '"\indent{1}" --- kinds := +/[1 for x in lists | #x > 0] --- for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat --- htSay('"\item") --- if kinds = 1 then htSay menuButton() else --- htMakePage [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] --- htSayStandard '"\tab{1}" --- htSay '"{\em " --- htSay (c := #x) --- htSay '" " --- htSay (c > 1 => pluralize kind; kind) --- htSay '":}" --- bcConTable REMDUP [CAAR y for y in x] --- htEndMenu(2) --- htSay '"\indent{0}" - -dbShowConsKindsFilter(htPage,[kind,cAlist]) == - htpSetProperty(htPage,'cAlist,cAlist) - dbShowCons(htPage,htpProperty(htPage,'exclusion)) - -dbShowConsDoc(htPage,conlist) == - null rest conlist => dbShowConsDoc1(htPage,getConstructorForm opOf first conlist,nil) - cAlist := htpProperty(htPage,'cAlist) - --the following code is necessary to skip over duplicates on cAlist - index := 0 - for x in REMDUP conlist repeat - -- for x in conlist repeat - dbShowConsDoc1(htPage,getConstructorForm x,i) where i == - while CAAAR cAlist ^= x repeat - index := index + 1 - cAlist := rest cAlist - null cAlist => systemError () - index - -dbShowConsDoc1(htPage,conform,indexOrNil) == - [conname,:conargs] := conform - MEMQ(conname,$Primitives) => - conname := htpProperty(htPage,'conname) - [["constructor",["NIL",doc]],:.] := GET(conname,'documentation) - sig := '((CATEGORY domain) (SetCategory) (SetCategory)) - displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,nil,nil) - exposeFlag := isExposedConstructor conname - doc := [getConstructorDocumentation conname] - signature := getConstructorSignature conname - sig := - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - SUBLISLIS(conargs,$TriangleVariableList,signature) - sublisFormal(conargs,signature) - htSaySaturn '"\begin{description}" - displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,null exposeFlag,nil) - htSaySaturn '"\end{description}" - --NOTE that we pass conform is as "origin" - -getConstructorDocumentation conname == - LASSOC('constructor,GETDATABASE(conname,'DOCUMENTATION)) - is [[nil,line,:.],:.] and line or '"" - -dbSelectCon(htPage,which,index) == - conPage opOf first htpProperty(htPage,'cAlist) . index - -dbShowConditions(htPage,cAlist,kind) == - conform := htpProperty(htPage,'conform) - conname := opOf conform - article := htpProperty(htPage,'article) - whichever := htpProperty(htPage,'whichever) - [consNoPred,:consPred] := splitConTable cAlist - singular := [kind,'" is"] - plural := [pluralize STRINGIMAGE kind,'" are"] - dbSayItems(#consNoPred,singular,plural,'" unconditional") - htSaySaturn '"\\" - bcConPredTable(consNoPred,conname) - htSayHrule() - dbSayItems(#consPred,singular,plural,'" conditional") - htSaySaturn '"\\" - bcConPredTable(consPred,conname) - -dbConsHeading(htPage,conlist,view,kind) == - thing := htPage and htpProperty(htPage,'thing) or '"constructor" - place := - htPage => htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - nil - count := #(REMDUP conlist) - -- count := #conlist - thing = '"benefactor" => - [STRINGIMAGE count,'" Constructors Used by ",form2HtString(place,nil,true)] - modifier := - thing = '"argument" => - rank := htPage and htpProperty(htPage,'rank) - ['" Possible ",rank,'" "] - kind = 'constructor => ['" "] - ['" ",capitalize STRINGIMAGE kind,'" "] --- count = 1 => --- ['"Select name or a {\em view} at the bottom"] - exposureWord := - $exposedOnlyIfTrue => '(" Exposed ") - nil - prefix := - count = 1 => [STRINGIMAGE count,:modifier,capitalize thing] - firstWord := (count = 0 => '"No "; STRINGIMAGE count) - [firstWord,:exposureWord, :modifier,capitalize pluralize thing] - placepart := - place => ['" of {\em ",form2HtString(place,nil,true),"}"] - nil - heading := [:prefix,:placepart] - connective := - MEMBER(view,'(abbrs files kinds)) => '" as " - '" with " - if count ^= 0 and MEMBER(view,'(abbrs files parameters conditions)) then heading:= [:heading,'" viewed",connective,'"{\em ",STRINGIMAGE view,'"}"] - heading - -dbShowConstructorLines lines == - cAlist := [[getConstructorForm intern dbName line,:true] for line in lines] - dbShowCons1(nil,listSort(function GLESSEQP,cAlist),'names) - -bcUnixTable(u) == - htSay '"\newline" - htBeginTable() - firstTime := true - for x in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - ft := - isAsharpFileName? x => '("AS") - '("SPAD") - filename := NAMESTRING $FINDFILE(STRINGIMAGE x, ft) - htMakePage [['text, '"\unixcommand{",PATHNAME_-NAME x, '"}{$AXIOM/lib/SPADEDIT ", filename, '"} "]] - htSay '"}" - htEndTable() - -isAsharpFileName? con == false - ---======================================================================= --- Special Code for Union, Mapping, and Record ---======================================================================= - -dbSpecialDescription(conname) == - conform := getConstructorForm conname - heading := ['"Description of Domain {\sf ",form2HtString conform,'"}"] - page := htInitPage(heading,nil) - htpSetProperty(page,'conname,conname) - $conformsAreDomains := nil - dbShowConsDoc1(page,conform,nil) - htShowPage() - -dbSpecialOperations(conname) == - page := htInitPage(nil,nil) - conform := getConstructorForm conname - opAlist := dbSpecialExpandIfNecessary(conform,rest GET(conname,'documentation)) - fromHeading := ['" from domain {\sf ",form2HtString conform,'"}"] - htpSetProperty(page,'fromHeading,fromHeading) - htpSetProperty(page,'conform,conform) - htpSetProperty(page,'opAlist,opAlist) - htpSetProperty(page,'noUsage,true) - htpSetProperty(page,'condition?,'no) - dbShowOp1(page,opAlist,'"operation",'names) - -dbSpecialExports(conname) == - conform := getConstructorForm conname - page := htInitPage(['"Exports of {\sf ",form2HtString conform,'"}"],nil) - opAlist := dbSpecialExpandIfNecessary(conform,rest GET(conname,'documentation)) - kePageDisplay(page,'"operation",opAlist) - htShowPage() - -dbSpecialExpandIfNecessary(conform,opAlist) == - opAlist is [[op,[sig,:r],:.],:.] and rest r => opAlist - for [op,:u] in opAlist repeat - for pair in u repeat - [sig,comments] := pair - RPLACD(pair,['T,conform,'T,comments]) --[sig,pred,origin,exposeFg,doc] - opAlist - -X := '"{\sf Record(a:A,b:B)} is used to create the class of pairs of objects made up of a value of type {\em A} selected by the symbol {\em a} and a value of type {\em B} selected by the symbol {\em b}. " - -Y := '"In general, the {\sf Record} constructor can take any number of arguments and thus can be used to create aggregates of heterogeneous components of arbitrary size selectable by name. " - -Z := '"{\sf Record} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y,Z) - -PUT('Record,'documentation,SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) _$ _$) - "\spad{r = s} tests for equality of two records \spad{r} and \spad{s}")) - (coerce (((OutputForm) _$) - "\spad{coerce(r)} returns an representation of \spad{r} as an output form") - ((_$ (List (Any))) - "\spad{coerce(u)}, where \spad{u} is the list \spad{[x,y]} for \spad{x} of type \spad{A} and \spad{y} of type \spad{B}, returns the record \spad{[a:x,b:y]}")) - (elt ((A $ "a") - "\spad{r . a} returns the value stored in record \spad{r} under selector \spad{a}.") - ((B $ "b") - "\spad{r . b} returns the value stored in record \spad{r} under selector \spad{b}.")) - (setelt ((A $ "a" A) - "\spad{r . a := x} destructively replaces the value stored in record \spad{r} under selector \spad{a} by the value of \spad{x}. Error: if \spad{r} has not been previously assigned a value.") - ((B $ "b" B) - "\spad{r . b := y} destructively replaces the value stored in record \spad{r} under selector \spad{b} by the value of \spad{y}. Error: if \spad{r} has not been previously assigned a value.")) - ))) - -X := '"{\sf Union(A,B)} denotes the class of objects which are which are either members of domain {\em A} or of domain {\em B}. The {\sf Union} constructor can take any number of arguments. " - -Y := '"For an alternate form of {\sf Union} with _"tags_", see \downlink{Union(a:A,b:B)}{DomainUnion}. {\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y) - -PUT('UntaggedUnion,'documentation,SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) $ $) - "\spad{u = v} tests if two objects of the union are equal, that is, u and v are hold objects of same branch which are equal.")) - (case (((Boolean) $ "A") - "\spad{u case A} tests if \spad{u} is of the type \spad{A} branch of the union.") - (((Boolean) $ "B") - "\spad{u case B} tests if \spad{u} is of the \spad{B} branch of the union.")) - (coerce ((A $) - "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of the \spad{A} branch of the union. Error: if \spad{u} is of the \spad{B} branch of the union.") - ((B $) - "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of the \spad{B} branch of the union. Error: if \spad{u} is of the \spad{A} branch of the union.") - (($ A) - "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") - (($ B) - "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) - ))) - -X := '"{\sf Union(a:A,b:B)} denotes the class of objects which are either members of domain {\em A} or of domain {\em B}. " - -Y := '"The symbols {\em a} and {\em b} are called _"tags_" and are used to identify the two _"branches_" of the union. " - -Z := '"The {\sf Union} constructor can take any number of arguments and has an alternate form without {\em tags} (see \downlink{Union(A,B)}{UntaggedUnion}). " - -W := '"This tagged {\sf Union} type is necessary, for example, to disambiguate two branches of a union where {\em A} and {\em B} denote the same type. " - -A := '"{\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y,Z,W,A) - -PUT('Union,'documentation,SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) $ $) - "\spad{u = v} tests if two objects of the union are equal, that is, \spad{u} and \spad{v} are objects of same branch which are equal.")) - (case (((Boolean) $ "A") - "\spad{u case a} tests if \spad{u} is of branch \spad{a} of the union.") - (((Boolean) $ "B") - "\spad{u case b} tests if \spad{u} is of branch \spad{b} of the union.")) - (coerce ((A $) - "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of branch \spad{a} of the union. Error: if \spad{u} is of branch \spad{b} of the union.") - ((B $) - "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of branch \spad{b} branch of the union. Error: if \spad{u} is of the \spad{a} branch of the union.") - (($ A) - "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") - (($ B) - "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) - ))) - -X := '"{\sf Mapping(T,S,...)} denotes the class of objects which are mappings from a source domain ({\em S,...}) into a target domain {\em T}. The {\sf Mapping} constructor can take any number of arguments." - -Y := '" All but the first argument is regarded as part of a source tuple for the mapping. For example, {\sf Mapping(T,A,B)} denotes the class of mappings from {\em (A,B)} into {\em T}. " - -Z := '"{\sf Mapping} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y,Z) - -PUT('Mapping,'documentation, SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) $ $) - "\spad{u = v} tests if mapping objects are equal.")) - ))) - -X := '"{\em Enumeration(a1, a2 ,..., aN)} creates an object which is exactly one of the N symbols {\em a1}, {\em a2}, ..., or {\em aN}, N > 0. " - -Y := '" The {\em Enumeration} can constructor can take any number of symbols as arguments." - -MESSAGE := STRCONC(X, Y) - -PUT('Enumeration, 'documentation, SUBST(MESSAGE, 'MESSAGE, '( - (constructor (NIL MESSAGE)) - (_= (((Boolean) _$ _$) - "\spad{e = f} tests for equality of two enumerations \spad{e} and \spad{f}")) - (_^_= (((Boolean) _$ _$) - "\spad{e ^= f} tests that two enumerations \spad{e} and \spad{f} are nont equal")) - (coerce (((OutputForm) _$) - "\spad{coerce(e)} returns a representation of enumeration \spad{r} as an output form") - ((_$ (Symbol)) - "\spad{coerce(s)} converts a symbol \spad{s} into an enumeration which has \spad{s} as a member symbol")) - ))) - - -mkConArgSublis args == - [[arg,:INTERN digits2Names PNAME arg] for arg in args - | (s := PNAME arg) and or/[DIGITP ELT(s,i) for i in 0..MAXINDEX s]] - -digits2Names s == ---This is necessary since arguments of conforms CANNOT have digits in TechExplorer - str := '"" - for i in 0..MAXINDEX s repeat - c := s.i - segment := - n := DIGIT_-CHAR_-P c => - ('("Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine")).n - c - CONCAT(str, segment) - str - -lefts u == - [x for x in HKEYS _*HASCATEGORY_-HASH_* | CDR x = u] - - - ---====================> WAS b-data.boot <================================ - ---============================================================================ --- Build Library Database (libdb.text,...) ---============================================================================ ---Formal for libdb.text: --- 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 = -buildLibdb(:options) == --called by make-databases (daase.lisp.pamphlet) - domainList := IFCAR options --build local libdb if list of domains is given - $OpLst: local := nil - $AttrLst: local := nil - $DomLst : local := nil - $CatLst : local := nil - $PakLst : local := nil - $DefLst : local := nil - deleteFile '"temp.text" - $outStream: local := MAKE_-OUTSTREAM '"temp.text" - if null domainList then - comments := - '"\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 ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'UNION,comments] - comments := - '"\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 ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] - comments := - '"\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 ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] - comments := - '"\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 ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] - $conname: local := nil - $conform: local := nil - $exposed?:local := nil - $doc: local := nil - $kind: local := nil - constructorList := domainList or allConstructors() - for con in constructorList repeat - writedb buildLibdbConEntry con - [attrlist,:oplist] := getConstructorExports $conform - buildLibOps oplist - buildLibAttrs attrlist - SHUT $outStream - domainList => 'done --leave new database in temp.text - OBEY - $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_" > _"libdb.text_"" - $machineType = 'SPARC => '"sort -f _"temp.text_" > _"libdb.text_"" - '"sort _"temp.text_" > _"libdb.text_"" - --OBEY '"mv libdb.text olibdb.text" - RENAME_-FILE('"libdb.text", '"olibdb.text") - deleteFile '"temp.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] - -dbMkForm x == atom x and [x] or x - -buildLibdbString [x,:u] == - STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u]) - -libConstructorSig [conname,:argl] == - [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) - formals := TAKE(#argl,$FormalMapVariableList) - sig := SUBLISLIS(formals,$TriangleVariableList,sig) - keys := [g(f,sig,i) for f in formals for i in 1..] where - g(x,u,i) == --does x appear in any but i-th element of u? - or/[CONTAINED(x,y) for y in u for j in 1.. | j ^= i] - sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where - fn x == - atom x => x - x is ['Join,a,:r] => ['Join,fn a,'etc] - x is ['CATEGORY,:.] => 'etc - [fn y for y in x] - sig := [first sig,:[(k => [":",a,s]; s) - for a in argl for s in rest sig for k in keys]] - sigpart:= form2LispString ['Mapping,:sig] - if null ncParseFromString sigpart then - sayBrightly ['"Won't parse: ",sigpart] - sigpart - -concatWithBlanks r == - r is [head,:tail] => - tail => STRCONC(head,'" ",concatWithBlanks tail) - head - '"" - -writedb(u) == - not STRINGP u => nil --skip if not a string - PRINTEXP(addPatchesToLongLines(u,500),$outStream) - --positions for tick(1), dashes(2), and address(9), i.e. 12 - TERPRI $outStream - -addPatchesToLongLines(s,n) == - #s > n => STRCONC(SUBSTRING(s,0,n), - addPatchesToLongLines(STRCONC('"--",SUBSTRING(s,n,nil)),n)) - s - -buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred) - -buildLibOp(op,sig,pred) == ---operations OKop \#\sig \conname\pred\comments (K is U or C) - nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig) - pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) - nsig := SUBST('T,"T$",nsig) --this ancient artifact causes troubles! - pred := SUBST('T,"T$",pred) - sigpart:= form2LispString ['Mapping,:nsig] - predString := (pred = 'T => '""; form2LispString pred) - sop := - (s := STRINGIMAGE op) = '"One" => '"1" - s = '"Zero" => '"0" - s - header := STRCONC('"o",sop) - conform:= STRCONC($kind,form2LispString $conform) - comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc)) - checkCommentsForBraces('operation,sop,sigpart,comments) - writedb - buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments] - -libdbTrim s == - k := MAXINDEX s - k < 0 => s - for i in 0..k repeat - s.i = $Newline => SETELT(s,i,char '_ ) - trimString s - -checkCommentsForBraces(kind,sop,sigpart,comments) == - count := 0 - for i in 0..MAXINDEX comments repeat - c := comments.i - c = char '_{ => count := count + 1 - c = char '_} => - count := count - 1 - count < 0 => missingLeft := true - if count < 0 or missingLeft then - tail := - kind = 'attribute => [sop,'"(",sigpart,'")"] - [sop,'": ",sigpart] - sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail] - if count > 0 then - sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail] - if count ^= 0 or missingLeft then pp comments - -buildLibAttrs attrlist == - for [name,argl,:pred] in attrlist repeat buildLibAttr(name,argl,pred) - -buildLibAttr(name,argl,pred) == ---attributes AKname\#\args\conname\pred\comments (K is U or C) - header := STRCONC('"a",STRINGIMAGE name) - argPart:= SUBSTRING(form2LispString ['f,:argl],1,nil) - pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) - predString := (pred = 'T => '""; form2LispString pred) - header := STRCONC('"a",STRINGIMAGE name) - conname := STRCONC($kind,form2LispString $conname) - comments:= concatWithBlanks LASSOC(['attribute,:argl],LASSOC(name,$doc)) - checkCommentsForBraces('attribute,STRINGIMAGE name,argl,comments) - writedb - buildLibdbString [header,# argl,$exposed?,argPart,conname,predString,comments] - -dbAugmentConstructorDataTable() == - instream := MAKE_-INSTREAM '"libdb.text" - while not EOFP instream repeat - fp := FILE_-POSITION instream - line := READLINE instream - cname := INTERN dbName line - entry := getCDTEntry(cname,true) => --skip over Mapping, Union, Record - [name,abb,:.] := entry - RPLACD(CDR entry,PUTALIST(CDDR entry,'dbLineNumber,fp)) --- if xname := constructorHasExamplePage entry then --- RPLACD(CDR entry,PUTALIST(CDDR entry,'dbExampleFile,xname)) - args := IFCDR GETDATABASE(name,'CONSTRUCTORFORM) - if args then RPLACD(CDR entry,PUTALIST(CDDR entry,'constructorArgs,args)) - 'done - -dbHasExamplePage conname == - sname := STRINGIMAGE conname - abb := constructor? conname - ucname := UPCASE STRINGIMAGE abb - pathname :=STRCONC(getEnv '"AXIOM",'"/doc/hypertex/pages/",ucname,'".ht") - isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage") - nil - -dbRead(n) == - instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"), '"/algebra/libdb.text") - FILE_-POSITION(instream,n) - line := READLINE instream - SHUT instream - line - -dbReadComments(n) == - n = 0 => '"" - instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"),'"/algebra/comdb.text") - FILE_-POSITION(instream,n) - line := READLINE instream - k := dbTickIndex(line,1,1) - line := SUBSTRING(line,k + 1,nil) - while not EOFP instream and (x := READLINE instream) and - (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and - x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat - xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] - SHUT instream - STRCONC(line, "STRCONC"/NREVERSE xtralines) - -dbSplitLibdb() == - instream := MAKE_-INSTREAM '"olibdb.text" - outstream:= MAKE_-OUTSTREAM '"libdb.text" - comstream:= MAKE_-OUTSTREAM '"comdb.text" - PRINTEXP(0, comstream) - PRINTEXP($tick,comstream) - PRINTEXP('"", comstream) - TERPRI(comstream) - while not EOFP instream repeat - line := READLINE instream - outP := FILE_-POSITION outstream - comP := FILE_-POSITION comstream - [prefix,:comments] := dbSplit(line,6,1) - PRINTEXP(prefix,outstream) - PRINTEXP($tick ,outstream) - null comments => - PRINTEXP(0,outstream) - TERPRI(outstream) - PRINTEXP(comP,outstream) - TERPRI(outstream) - PRINTEXP(outP ,comstream) - PRINTEXP($tick ,comstream) - PRINTEXP(first comments,comstream) - TERPRI(comstream) - for c in rest comments repeat - PRINTEXP(outP ,comstream) - PRINTEXP($tick ,comstream) - PRINTEXP(c, comstream) - TERPRI(comstream) - SHUT instream - SHUT outstream - SHUT comstream - OBEY '"rm olibdb.text" - -dbSplit(line,n,k) == - k := charPosition($tick,line,k + 1) - n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)] - dbSplit(line,n - 1,k) - -dbSpreadComments(line,n) == - line = '"" => nil - k := charPosition(char '_-,line,n + 2) - k >= MAXINDEX line => [SUBSTRING(line,n,nil)] - line.(k + 1) ^= char '_- => - u := dbSpreadComments(line,k) - [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u] - [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)] - ---============================================================================ --- Build Glossary ---============================================================================ -buildGloss() == --called by buildDatabase (database.boot) ---starting with gloss.text, build glosskey.text and glossdef.text - $constructorName : local := nil - $exposeFlag : local := true - $outStream: local := MAKE_-OUTSTREAM '"temp.text" - $x : local := nil - $attribute? : local := true --do not surround first word - pathname := STRCONC(getEnv '"AXIOM",'"/algebra/gloss.text") - instream := MAKE_-INSTREAM pathname - keypath := '"glosskey.text" - OBEY STRCONC('"rm -f ",keypath) - outstream:= MAKE_-OUTSTREAM keypath - htpath := '"gloss.ht" - OBEY STRCONC('"rm -f ",htpath) - htstream:= MAKE_-OUTSTREAM htpath - defpath := '"glossdef.text" - defstream:= MAKE_-OUTSTREAM defpath - pairs := getGlossLines instream - PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream) - for [name,:line] in pairs repeat - outP := FILE_-POSITION outstream - defP := FILE_-POSITION defstream - lines := spreadGlossText transformAndRecheckComments(name,[line]) - PRINTEXP(name, outstream) - PRINTEXP($tick,outstream) - PRINTEXP(defP, outstream) - TERPRI(outstream) --- PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream) - PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream) - PRINTEXP(name, htstream) - PRINTEXP('"}\space{}",htstream) - TERPRI(htstream) - for x in lines repeat - PRINTEXP(outP, defstream) - PRINTEXP($tick,defstream) - PRINTEXP(x, defstream) - TERPRI defstream - PRINTEXP("STRCONC"/lines,htstream) - TERPRI htstream - PRINTEXP('"\endmenu\endscroll",htstream) - PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream) - PRINTEXP('"\end{page}",htstream) - SHUT instream - SHUT outstream - SHUT defstream - SHUT htstream - SHUT $outStream - -spreadGlossText(line) == ---this function breaks up a line into chunks ---eventually long line is put into gloss.text as several chunks as follows: ------ key1`this is the first chunk ------ XXX`and this is the second ------ XXX`and this is the third ------ key2`and this is the fourth ---where XXX is the file position of key1 ---this is because grepping will only pick up the first 512 characters - line = '"" => nil - MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))] - [line] - -getGlossLines instream == ---instream has text of the form: ------ key1`this is the first line ------ and this is the second ------ key2'and this is the third ---result is ------ key1'this is the first line and this is the second ------ key2'and this is the third - keys := nil - text := nil - lastLineHadTick := false - while not EOFP instream repeat - line := READLINE instream - #line = 0 => 'skip - n := charPosition($tick,line,0) - last := IFCAR text - n > MAXINDEX line => --this line is continuation of previous line; concat it - fill := - #last = 0 => - lastLineHadTick => '"" - '"\blankline " - #last > 0 and last.(MAXINDEX last) ^= $charBlank => $charBlank - '"" - lastLineHadTick := false - text := [STRCONC(last,fill,line),:rest text] - lastLineHadTick := true - keys := [SUBSTRING(line,0,n),:keys] - text := [SUBSTRING(line,n + 1,nil),:text] - ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text]) - --this complication sorts them after lower casing the keys - ---============================================================================ --- Build Users HashTable --- This database is written out as users.database (database.boot) --- and read using function getUsersOfConstructor. See functions --- whoUses and kcuPage in browser. ---============================================================================ -mkUsersHashTable() == --called by make-databases (daase.lisp.pamphlet) - $usersTb := MAKE_-HASH_-TABLE() - for x in allConstructors() repeat - for conform in getImports x repeat - name := opOf conform - if not MEMQ(name,'(QUOTE)) then - HPUT($usersTb,name,insert(x,HGET($usersTb,name))) - for k in HKEYS $usersTb repeat - HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k))) - for x in allConstructors() | isDefaultPackageName x repeat - HPUT($usersTb,x,getDefaultPackageClients x) - $usersTb - -getDefaultPackageClients con == --called by mkUsersHashTable - catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) - for [catAncestor,:.] in childrenOf([catname]) repeat - pakname := INTERN STRCONC(PNAME catAncestor,'"&") - if getCDTEntry(pakname,true) then acc := [pakname,:acc] - acc := UNION([CAAR x for x in domainsOf([catAncestor],nil)],acc) - listSort(function GLESSEQP,acc) - ---============================================================================ --- Build Dependents Hashtable --- This hashtable is written out by database.boot as dependents.DATABASE --- and read back in by getDependentsOfConstructor (see daase.lisp) --- This information is used by function kcdePage when a user asks for the --- dependents of a constructor. ---============================================================================ -mkDependentsHashTable() == --called by make-databases (daase.lisp.pamphlet) - $depTb := MAKE_-HASH_-TABLE() - for nam in allConstructors() repeat - for con in getArgumentConstructors nam repeat - HPUT($depTb,con,[nam,:HGET($depTb,con)]) - for k in HKEYS $depTb repeat - HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k))) - $depTb - -getArgumentConstructors con == --called by mkDependentsHashTable - argtypes := IFCDR IFCAR getConstructorModemap con or return nil - fn argtypes where - fn(u) == "UNION"/[gn x for x in u] - gn(x) == - atom x => nil - x is ['Join,:r] => fn(r) - x is ['CATEGORY,:.] => nil - constructor? first x => [first x,:fn rest x] - fn rest x - -getImports conname == --called by mkUsersHashTable - conform := GETDATABASE(conname,'CONSTRUCTORFORM) - infovec := dbInfovec conname or return nil - template := infovec.0 - u := [import(i,template) - for i in 5..(MAXINDEX template) | test] where - test == template.i is [op,:.] and IDENTP op - and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local)) - import(x,template) == - x is [op,:args] => - op = 'QUOTE or op = 'NRTEVAL => CAR args - op = 'local => first args - op = 'Record => - ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]] - ---TTT next three lines: handles some tagged/untagged Union case. - op = 'Union=> - args is [['_:,:x1],:x2] => --- CAAR args = '_: => -- tagged! - ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]] - [op,:[import(y,template) for y in args]] - - [op,:[import(y,template) for y in args]] - INTEGERP x => import(template.x,template) - x = '$ => '$ - x = "$$" => "$$" - STRINGP x => x - systemError '"bad argument in template" - listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u)) - - ---============================================================================ --- Get Hierarchical Information ---============================================================================ -getParentsFor(cname,formalParams,constructorCategory) == ---called by compDefineFunctor1 - acc := nil - formals := TAKE(#formalParams,$TriangleVariableList) - constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM) - for x in folks constructorCategory repeat - x := SUBLISLIS(formalParams,formals,x) - x := SUBLISLIS(IFCDR constructorForm,formalParams,x) - x := SUBST('Type,'Object,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -parentsOf con == --called by kcpPage, ancestorsRecur - if null BOUNDP '$parentsCache then SETQ($parentsCache,MAKE_-HASHTABLE 'ID) - HGET($parentsCache,con) or - parents := getParentsForDomain con - HPUT($parentsCache,con,parents) - parents - -parentsOfForm [op,:argl] == - parents := parentsOf op - null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) => - parents - SUBLISLIS(argl, newArgl, parents) - -getParentsForDomain domname == --called by parentsOf - acc := nil - for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat - x := - GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => - sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) - sublisFormal(IFCDR getConstructorForm domname,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -explodeIfs x == main where --called by getParents, getParentsForDomain - main == - x is ['IF,p,a,b] => fn(p,a,b) - [[x,:true]] - fn(p,a,b) == - [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]] - gn(p,a) == - a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil) - [[a,:p]] - -folks u == --called by getParents and getParentsForDomain - atom u => nil - u is [op,:v] and MEMQ(op,'(Join PROGN)) - or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v] - u is ['SIGNATURE,:.] => nil - u is ['TYPE,:.] => nil - u is ['ATTRIBUTE,a] => - PAIRP a and constructor? opOf a => folks a - nil - u is ['IF,p,q,r] => - q1 := folks q - r1 := folks r - q1 or r1 => [['IF,p,q1,r1]] - nil - [u] - -descendantsOf(conform,domform) == --called by kcdPage - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => - cats := catsOf(conform,domform) - [op,:argl] := conform - null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) - => cats - SUBLISLIS(argl, newArgl, cats) - 'notAvailable - -childrenOf conform == - [pair for pair in descendantsOf(conform,nil) | - childAssoc(conform,parentsOfForm first pair)] - -childAssoc(form,alist) == - null (argl := CDR form) => ASSOC(form,alist) - u := assocCar(opOf form, alist) => childArgCheck(argl,rest CAR u) and u - nil - -assocCar(x, al) == or/[pair for pair in al | x = CAAR pair] - -childArgCheck(argl, nargl) == - and/[fn for x in argl for y in nargl for i in 0..] where - fn == - x = y or constructor? opOf y => true - isSharpVar y => i = POSN1(y, $FormalMapVariableList) - false - ---computeDescendantsOf cat == ---dynamically generates descendants --- hash := MAKE_-HASHTABLE 'UEQUAL --- for [child,:pred] in childrenOf cat repeat --- childForm := getConstructorForm child --- HPUT(hash,childForm,pred) --- for [form,:pred] in descendantsOf(childForm,nil) repeat --- newPred := --- oldPred := HGET(hash,form) => quickOr(oldPred,pred) --- pred --- HPUT(hash,form,newPred) --- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] - -ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => - alist := GETDATABASE(conname,'ANCESTORS) - argl := IFCDR domform or IFCDR conform - [pair for [a,:b] in alist | pair] where pair == - left := sublisFormal(argl,a) - right := sublisFormal(argl,b) - if domform then right := simpHasPred right - null right => false - [left,:right] - computeAncestorsOf(conform,domform) - -computeAncestorsOf(conform,domform) == - $done: local := MAKE_-HASHTABLE 'UEQUAL - $if: local := MAKE_-HASHTABLE 'ID - ancestorsRecur(conform,domform,true,true) - acc := nil - for op in listSort(function GLESSEQP,HKEYS $if) repeat - for pair in HGET($if,op) repeat acc := [pair,:acc] - NREVERSE acc - -ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf - op := opOf conform - pred = HGET($done,conform) => nil --skip if already processed - parents := - firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => - $lisplibParents - parentsOf op - originalConform := - firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => $form - getConstructorForm op - if conform ^= originalConform then - parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents) - for [newform,:p] in parents repeat - if domform and rest domform then - newdomform := SUBLISLIS(rest domform,rest conform,newform) - p := SUBLISLIS(rest domform,rest conform,p) - newPred := quickAnd(pred,p) - ancestorsAdd(simpHasPred newPred,newdomform or newform) - ancestorsRecur(newform,newdomform,newPred,false) - HPUT($done,conform,pred) --mark as already processed - -ancestorsAdd(pred,form) == --called by ancestorsRecur - null pred => nil - op := IFCAR form or form - alist := HGET($if,op) - existingNode := ASSOC(form,alist) => - RPLACD(existingNode,quickOr(CDR existingNode,pred)) - HPUT($if,op,[[form,:pred],:alist]) - -domainsOf(conform,domname,:options) == - $hasArgList := IFCAR options - conname := opOf conform - u := [key for key in HKEYS _*HASCATEGORY_-HASH_* - | key is [anc,: =conname]] - --u is list of pairs (a . b) where b = conname - --we sort u then replace each b by the predicate for which this is true - s := listSort(function GLESSEQP,COPY u) - s := [[CAR pair,:GETDATABASE(pair,'HASCATEGORY)] for pair in s] - transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) - -catsOf(conform,domname,:options) == - $hasArgList := IFCAR options - conname := opOf conform - alist := nil - for key in allConstructors() repeat - for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat - [[op,:args],:pred] := item - newItem := - args => [[args,:pred],:LASSOC(key,alist)] - pred - alist := insertShortAlist(key,newItem,alist) - transKCatAlist(conform,domname,listSort(function GLESSEQP,alist)) - -transKCatAlist(conform,domname,s) == main where - main == - domname => --accept only exact matches after substitution - domargs := rest domname - acc := nil - rest conform => - for pair in s repeat --pair has form [con,[conargs,:pred],...]] - leftForm := getConstructorForm CAR pair - for (ap := [args,:pred]) in CDR pair repeat - match? := - domargs = args => true - HAS__SHARP__VAR args => domargs = sublisFormal(KDR domname,args) - nil - null match? => 'skip - npred := sublisFormal(KDR leftForm,pred) - acc := [[leftForm,:npred],:acc] - NREVERSE acc - --conform has no arguments so each pair has form [con,:pred] - for pair in s repeat - leftForm := getConstructorForm CAR pair or systemError nil - RPLACA(pair,leftForm) - RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) - s - --no domname, so look for special argument combinations - acc := nil - KDR conform => - farglist := TAKE(#rest conform,$FormalMapVariableList) - for pair in s repeat --pair has form [con,[conargs,:pred],...]] - leftForm := getConstructorForm CAR pair - for (ap := [args,:pred]) in CDR pair repeat - hasArgsForm? := args ^= farglist - npred := sublisFormal(KDR leftForm,pred) - if hasArgsForm? then - subargs := sublisFormal(KDR leftForm,args) - hpred := --- $hasArgsList => mkHasArgsPred subargs - ['hasArgs,:subargs] - npred := quickAnd(hpred,npred) - acc := [[leftForm,:npred],:acc] - NREVERSE acc - for pair in s repeat --pair has form [con,:pred] - leftForm := getConstructorForm CAR pair - RPLACA(pair,leftForm) - RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) - s - -mkHasArgsPred subargs == ---$hasArgsList gives arguments of original constructor,e.g. LODO(A,M) ---M is required to be Join(B,...); in looking for the domains of B --- we can find that if B has special value C, it can - systemError subargs - -sublisFormal(args,exp,:options) == main where - main == --use only on LIST structures; see also sublisFormalAlist - $formals: local := IFCAR options or $FormalMapVariableList - null args => exp - sublisFormal1(args,exp,#args - 1) - sublisFormal1(args,x,n) == --[sublisFormal1(args,y) for y in x] - x is [.,:.] => - acc := nil - y := x - while null atom y repeat - acc := [sublisFormal1(args,QCAR y,n),:acc] - y := QCDR y - r := NREVERSE acc - if y then - nd := LASTNODE r - RPLACD(nd,sublisFormal1(args,y,n)) - r - IDENTP x => - j := or/[i for f in $formals for i in 0..n | EQ(f,x)] => - args.j - x - x - ---======================================================================= --- Build Table of Lower Case Constructor Names ---======================================================================= - -buildDefaultPackageNamesHT() == - $defaultPackageNamesHT := MAKE_-HASH_-TABLE() - for nam in allConstructors() | isDefaultPackageName nam repeat - HPUT($defaultPackageNamesHT,nam,true) - $defaultPackageNamesHT - -$defaultPackageNamesHT := buildDefaultPackageNamesHT() - ---======================================================================= --- Code for Private Libdbs ---======================================================================= --- $createLocalLibDb := false - -extendLocalLibdb conlist == -- called by astran - not $createLocalLibDb => nil - null conlist => nil - buildLibdb conlist --> puts datafile into temp.text - $newConstructorList := UNION(conlist, $newConstructorList) - localLibdb := '"libdb.text" - not PROBE_-FILE '"libdb.text" => - RENAME_-FILE('"temp.text",'"libdb.text") - oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) - newlines := dbReadLines '"temp.text" - dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") - deleteFile '"temp.text" - -purgeLocalLibdb() == --used for debugging purposes only - $newConstructorList := nil - obey '"rm libdb.text" - - -$returnNowhereFromGoGet := false - -showSummary dom == - showPredicates dom - showAttributes dom - showFrom dom - showImp dom - ---======================================================================= --- Show Where Functions in Domain are Implemented ---======================================================================= -showImp(dom,:options) == - sayBrightly '"-------------Operation summary-----------------" - missingOnlyFlag := KAR options - domainForm := devaluate dom - [nam,:$domainArgs] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - predVector := dom.3 - u := getDomainOpTable(dom,true) - --sort into 4 groups: domain exports, unexports, default exports, others - for (x := [.,.,:key]) in u repeat - key = domainForm => domexports := [x,:domexports] - FIXP key => unexports := [x,:unexports] - isDefaultPackageForm? key => defexports := [x,:defexports] - key = 'nowhere => nowheres := [x,:nowheres] - key = 'constant => constants := [x,:constants] - others := [x,:others] --add chain domains go here - sayBrightly - nowheres => ['"Functions exported but not implemented by", - :bright form2String domainForm,'":"] - [:bright form2String domainForm,'"implements all exported operations"] - showDomainsOp1(nowheres,'nowhere) - missingOnlyFlag => 'done - - --first display those exported by the domain, then add chain guys - u := [:domexports,:constants,:SORTBY('CDDR,others)] - while u repeat - [.,.,:key] := CAR u - sayBrightly - key = 'constant => - ["Constants implemented by",:bright form2String key,'":"] - ["Functions implemented by",:bright form2String key,'":"] - u := showDomainsOp1(u,key) - u := SORTBY('CDDR,defexports) - while u repeat - [.,.,:key] := CAR u - defop := INTERN(SUBSTRING((s := PNAME CAR key),0,MAXINDEX s)) - domainForm := [defop,:CDDR key] - sayBrightly ["Default functions from",:bright form2String domainForm,'":"] - u := showDomainsOp1(u,key) - u := SORTBY('CDDR,unexports) - while u repeat - [.,.,:key] := CAR u - sayBrightly ["Not exported: "] - u := showDomainsOp1(u,key) - ---======================================================================= --- Show Information Directly From Domains ---======================================================================= -showFrom(D,:option) == - ops := KAR option - alist := nil - domainForm := devaluate D - [nam,:.] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - for (opSig := [op,sig]) in getDomainSigs1(D,ops) repeat - u := from?(D,op,sig) - x := ASSOC(u,alist) => RPLACD(x,[opSig,:rest x]) - alist := [[u,opSig],:alist] - for [conform,:l] in alist repeat - sayBrightly concat('"From ",form2String conform,'":") - for [op,sig] in l repeat sayBrightly ['" ",:formatOpSignature(op,sig)] - ---======================================================================= --- Functions implementing showFrom ---======================================================================= -getDomainOps D == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - REMDUP listSort(function GLESSEQP,ASSOCLEFT getDomainOpTable(D,nil)) - -getDomainSigs(D,:option) == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - getDomainSigs1(D,first option) - -getDomainSigs1(D,ops) == listSort(function GLESSEQP,u) where - u == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] - -getDomainDocs(D,:option) == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - ops := KAR option - [[op,sig,:getInheritanceByDoc(D,op,sig)] for [op,sig] in getDomainSigs1(D,ops)] - ---======================================================================= --- Getting Inheritance Info from Documentation in Lisplib ---======================================================================= -from?(D,op,sig) == KAR KDR getInheritanceByDoc(D,op,sig) - -getExtensionsOfDomain domain == - u := getDomainExtensionsOfDomain domain - cats := getCategoriesOfDomain domain - for x in u repeat - cats := UNION(cats,getCategoriesOfDomain EVAL x) - [:u,:cats] - -getDomainExtensionsOfDomain domain == - acc := nil - d := domain - while (u := devaluateSlotDomain(5,d)) repeat - acc := [u,:acc] - d := EVAL u - acc - -devaluateSlotDomain(u,dollar) == - u = '$ => devaluate dollar - FIXP u and VECP (y := dollar.u) => devaluate y - u is ['NRTEVAL,y] => MKQ eval y - u is ['QUOTE,y] => u - u is [op,:argl] => [op,:[devaluateSlotDomain(x,dollar) for x in argl]] - devaluate evalSlotDomain(u,dollar) - -getCategoriesOfDomain domain == - predkeyVec := domain.4.0 - catforms := CADR domain.4 - [fn for i in 0..MAXINDEX predkeyVec | test] where - test == predkeyVec.i and - (x := catforms . i) isnt ['DomainSubstitutionMacro,:.] - fn == - VECP x => devaluate x - devaluateSlotDomain(x,domain) - -getInheritanceByDoc(D,op,sig,:options) == ---gets inheritance and documentation information by looking in the LISPLIB ---for each ancestor of the domain - catList := KAR options or getExtensionsOfDomain D - getDocDomainForOpSig(op,sig,devaluate D,D) or - or/[fn for x in catList] or '(NIL NIL) - where fn == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) - -getDocDomainForOpSig(op,sig,dollar,D) == - (u := LASSOC(op,GETDATABASE(CAR dollar,'DOCUMENTATION))) - and (doc := or/[[d,dollar] for [s,:d] in u | compareSig(sig,s,D,dollar)]) - ---======================================================================= --- Functions implementing showImp ---======================================================================= -showDomainsOp1(u,key) == - while u and CAR u is [op,sig,: =key] repeat - sayBrightly ['" ",:formatOpSignature(op,sig)] - u := rest u - u - -getDomainRefName(dom,nam) == - PAIRP nam => [getDomainRefName(dom,x) for x in nam] - not FIXP nam => nam - slot := dom.nam - VECP slot => slot.0 - slot is ['SETELT,:.] => getDomainRefName(dom,getDomainSeteltForm slot) - slot - -getDomainSeteltForm ['SETELT,.,.,form] == - form is ['evalSlotDomain,u,d] => devaluateSlotDomain(u,d) - VECP form => systemError() - form - -showPredicates dom == - sayBrightly '"--------------------Predicate summary-------------------" - conname := CAR dom.0 - predvector := dom.3 - predicateList := GETDATABASE(conname,'PREDICATES) - for i in 1.. for p in predicateList repeat - prefix := - testBitVector(predvector,i) => '"true : " - '"false: " - sayBrightly [prefix,:pred2English p] - -showAttributes dom == - sayBrightly '"--------------------Attribute summary-------------------" - conname := CAR dom.0 - abb := getConstructorAbbreviation conname - predvector := dom.3 - for [a,:p] in dom.2 repeat - prefix := - testBitVector(predvector,p) => '"true : " - '"false: " - sayBrightly concat(prefix,form2String a) - -showGoGet dom == - numvec := CDDR dom.4 - for i in 6..MAXINDEX dom | (slot := dom.i) is ['newGoGet,dol,index,:op] repeat - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) - signumList := - [formatLazyDomainForm(dom,numvec.(index + i)) for i in 0..numOfArgs] - index := index + numOfArgs + 1 - namePart := - concat(bright "from",form2String formatLazyDomainForm(dom,whereNumber)) - sayBrightly [i,'": ",:formatOpSignature(op,signumList),:namePart] - -formatLazyDomain(dom,x) == - VECP x => devaluate x - x is [dollar,slotNumber,:form] => formatLazyDomainForm(dom,form) - systemError nil - -formatLazyDomainForm(dom,x) == - x = 0 => ["$"] - FIXP x => formatLazyDomain(dom,dom.x) - atom x => x - x is ['NRTEVAL,y] => (atom y => [y]; y) - [first x,:[formatLazyDomainForm(dom,y) for y in rest x]] - - ---====================> WAS b-op1.boot <================================ - ---======================================================================= --- Operation Page Menu ---======================================================================= ---opAlist has form [[op,:alist],:.] where each alist --- has form [sig,pred,origin,exposeFlag,comments] - -dbFromConstructor?(htPage) == htpProperty(htPage,'conform) - -dbPresentOps(htPage,which,:exclusions) == - true => dbPresentOpsSaturn(htPage,which,exclusions) ---Flags: --- fromConPage?: came (originally) from a constructor page --- usage?: display usage? --- star?: display exposed/*=unexposed --- implementation?: display implementation? - htSay('"{\em Views:}") - asharp? := htpProperty(htPage,'isAsharpConstructor) - fromConPage? := (conname := opOf htpProperty(htPage,'conform)) - usage? := $UserLevel = 'development and fromConPage? and which = '"operation" - and not (GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - and not asharp? - star? := not fromConPage? or which = '"package operation" - implementation? := not asharp? and - $UserLevel = 'development and $conformsAreDomains - --and not $includeUnexposed? - rightmost? := star? or (implementation? and not $includeUnexposed?) - tabs := - which = '"attribute" => '("12" "12" "25" "40" 13) - star? => '("12" "19" "31" "43" 10) - implementation? => '("9" "16" "28" "44" 9) - '("9" "16" "28" "41" 12) - if INTEGERP first exclusions then exclusions := ['documentation] - htpSetProperty(htPage,'exclusion,first exclusions) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - empty? := null opAlist - htTab - which = '"attribute" => tabs.1 - tabs.0 - if empty? or MEMBER('names,exclusions) or null KDR opAlist - then htSay '"{\em names}" - else htMakePage [['bcLispLinks,['"names",'"",'dbShowOps,which,'names]]] - if which ^= '"attribute" then - htTab tabs.1 - if empty? or MEMBER('signatures,exclusions) - then htSay '"{\em signatures}" - else htMakePage _ - [['bcLispLinks,['"signatures",'"",'dbShowOps,which,'signatures]]] - htTab tabs.2 - if empty? or MEMBER('parameters,exclusions) --also test for some parameter - or not dbDoesOneOpHaveParameters? opAlist - then htSay '"{\em parameters}" - else htMakePage _ - [['bcLispLinks,['"parameters",'"",'dbShowOps,which,'parameters]]] - htTab tabs.3 - if not empty? and null IFCDR opAlist and not htpProperty(htPage,'noUsage) - then - if htpProperty(htPage,'conform) - then htMakePage - [['bcLinks,['"generalise",'"",'dbShowOps,which,'generalise]]] - else htMakePage - [['bcLinks,['"all domains",'"",'dbShowOps,which,'allDomains]]] - else - if empty? or MEMQ('usage,exclusions) or _ - htpProperty(htPage,'noUsage) then htSay '"{\em filter}" else - htMakePage [['bcLinks,['"filter",'"",'dbShowOps,which,'filter]]] - htMakePage [['bcStrings, [tabs.4,'"",'filter,'EM]]] - htSay('"\newline ") - if star? - then - if $exposedOnlyIfTrue - then htMakePage - [['bcLinks,['"exposed",'" {\em only}",'dbShowOps,which,'exposureOff]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'dbShowOps,which,'exposureOn]]] --- else if (updown := dbCompositeWithMap htPage) --- then htMakePage [['bcLispLinks,[updown,'"",'dbShowUpDown,updown]]] - htTab tabs.0 - if usage? then - if empty? or MEMBER('usage,exclusions) _ - or GETDATABASE(conname,'CONSTRUCTORKIND) = 'category _ - or HGET($defaultPackageNamesHT,conname) _ - or htpProperty(htPage,'noUsage) - then htSay '"{\em usage}" - else htMakePage _ - [['bcLispLinks,['"usage",'"",'whoUsesOperation,which,nil]]] - htTab tabs.1 - if empty? or MEMBER('origins,exclusions) - then htSay '"{\em origins}" - else htMakePage [['bcLispLinks,['"origins",'"",'dbShowOps,which,'origins]]] - htTab tabs.2 - if implementation? then - if MEMBER('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) _ - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - then htSay '"{\em implementation}" - else htMakePage _ - [['bcLispLinks,['"implementation",'"",'dbShowOps,which,'implementation]]] - else if empty? or MEMBER('conditions,exclusions) _ - or (htpProperty(htPage,'condition?) = 'no) - then htSay '"{\em conditions}" - else htMakePage _ - [['bcLispLinks,['"conditions",'"",'dbShowOps,which,'conditions]]] - htTab tabs.3 - if empty? or MEMBER('documentation,exclusions) - then htSay '"{\em description}" - else htMakePage _ - [['bcLispLinks,['"description",'"",'dbShowOps,which,'documentation]]] - htShowPageNoScroll() - -htTab s == htSay('"\tab{",s,'"}") - -dbDoesOneOpHaveParameters? opAlist == - or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn == - STRINGP x => dbPart(x,2,1) ^= '"0" - KAR x ---============================================================================ --- Master Switch Functions for Operation Views ---============================================================================ - -dbShowOps(htPage,which,key,:options) == - --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string - which := STRINGIMAGE which - if MEMQ(key,'(extended basic all)) then - $groupChoice := key - key := htpProperty(htPage,'key) or 'names - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) --- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist)) --- htpSetProperty(htPage,'opAlist,al) --- al - htpProperty(htPage,'attrAlist) - key = 'generalise => - arg := STRINGIMAGE CAAR opAlist - which = '"attribute" => aPage arg - oPage arg - key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which) - key = 'filter => - --if $saturn, IFCAR options contains filter string - filter := IFCAR options or pmTransFilter(dbGetInputString htPage) - filter is ['error,:.] => bcErrorPage filter - opAlist:= _ - [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)] - null opAlist => emptySearchPage(which,filter) - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOps(htPage,which,htpProperty(htPage,'exclusion)) - htpSetProperty(htPage,'key,key) - if MEMQ(key,'(exposureOn exposureOff)) then - $exposedOnlyIfTrue := - key = 'exposureOn => 'T - nil - key := htpProperty(htPage,'exclusion) - dbShowOp1(htPage,opAlist,which,key) - -reduceByGroup(htPage,opAlist) == - not dbFromConstructor?(htPage) or null $groupChoice => opAlist - dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false) - bitNumber := HGET($topicHash,$groupChoice) - res := [[op,:newItems] for [op,:items] in opAlist | newItems] where - newItems == - null bitNumber => items - [x for x in items | FIXP (code := myLastAtom x) _ - and LOGBITP(bitNumber,code)] - res - - -dbShowOp1(htPage,opAlist,which,key) == - --set up for filtering below in dbGatherData - $which: local := which - if INTEGERP key then - opAlist := dbSelectData(htPage,opAlist,key) - ------> Jump out for constructor names in file <-------- - INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile) - and constructor? con => return conPageChoose con - if INTEGERP key then - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - --opAlist is expanded to form - -- [[op,[sig,pred,origin,exposed,comments],...],...] - opAlist:=[item for [op,:items] in opAlist | item] where - item == - acc := nil - for x in items | x.3 repeat acc:= [x,:acc] - null acc => nil - [op,:NREVERSE acc] - $conformsAreDomains : local := htpProperty(htPage,'domname) - opCount := opAlistCount(opAlist, which) - branch := - INTEGERP key => - opCount <= $opDescriptionThreshold => 'documentation - 'names - key = 'names and null rest opAlist => --means a single op - opCount <= $opDescriptionThreshold => 'documentation - 'names - key - [what,whats,fn] := LASSOC(branch,$OpViewTable) - data := dbGatherData(htPage,opAlist,which,branch) - dataCount := +/[1 for x in data | (what = '"Name" and _ - $exposedOnlyIfTrue => atom x; true)] - namedPart := - null rest opAlist => - ops := escapeSpecialChars STRINGIMAGE CAAR opAlist - ['" {\em ",ops,'"}"] - nil - if what = '"Condition" and null KAR KAR data then dataCount := dataCount - 1 - exposurePart := - $exposedOnlyIfTrue => '(" Exposed ") - nil - firstPart := - opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which] - dataCount = 1 or dataCount = opCount => - opCount = 1 => [:exposurePart, capitalize which,:namedPart] - [STRINGIMAGE opCount,'" ",:exposurePart, - pluralize capitalize which,:namedPart] - prefix := pluralSay(dataCount,what,whats) - [:prefix,'" for ",STRINGIMAGE opCount,'" ",_ - pluralize capitalize which,:namedPart] - page := htInitPageNoScroll(htCopyProplist htPage) - ------------>above line used to call htInitPageHoHeading<---------- - htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) - htpSetProperty(page,'data,data) - htpSetProperty(page,'branch,branch) - -- only place where specialMessage property is set seems to be commented. out - if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) - htSayStandard('"\beginscroll ") - FUNCALL(fn,page,opAlist,which,data) --apply branch function - dbOpsExposureMessage() - htSayStandard("\endscroll ") - dbPresentOps(page,which,branch) - htShowPageNoScroll() - -opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo == - null $exposedOnlyIfTrue or which = '"attribute" => #items - --count if unexpanded---CDDR(w) = nil---or if w.3 = true - +/[1 for w in items | null (p := CDDR w) or p . 1] - -dbShowOpHeading(heading, branch) == - suffix := --- branch = 'signatures => '" viewed as signatures" - branch = 'parameters => '" viewed with parameters" - branch = 'origins => '" organized by origins" - branch = 'conditions => '" organized by conditions" - '"" - [:heading, suffix] - -dbOpsExposureMessage() == - $atLeastOneUnexposed => htSay '"{\em *} = unexposed" - -fromHeading htPage == - null htPage => '"" - $pn := [htPage.0,'"}{"] - updomain := htpProperty(htPage,'updomain) => - dnForm := dbExtractUnderlyingDomain updomain - dnString:= form2StringList dnForm - dnFence := form2Fence dnForm --- upString:= form2StringList updomain - upFence := form2Fence updomain - upOp := PNAME opOf updomain - ['" {\em from} ",:dbConformGen dnForm,'" {\em under} _ - \ops{",upOp,'"}{",:$pn,:upFence,'"}"] - domname := htpProperty(htPage,'domname) - numberOfUnderlyingDomains := #[x for x in rest _ - GETDATABASE(opOf domname,'COSIG) | x] --- numberOfUnderlyingDomains = 1 and --- KDR domname and (dn := dbExtractUnderlyingDomain domname) => --- ['" {\em from} ",:pickitForm(domname,dn)] - KDR domname => ['" {\em from} ",:dbConformGen domname] - htpProperty(htPage,'fromHeading) - -pickitForm(form,uarg) == - conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg) - -conformString(form) == - KDR form => - conform2StringList(form,FUNCTION conname2StringList,_ - FUNCTION conformString,nil) - form2StringList form - -conform2StringList(form,opFn,argFn,exception) == - exception := exception or '"%%%nothing%%%" - [op1,:args] := form - op := IFCAR HGET($lowerCaseConTb,op1) or op1 - null args => APPLY(opFn,[op]) - special := MEMQ(op,'(Union Record Mapping)) - cosig := - special => ['T for x in args] - rest GETDATABASE(op,'COSIG) - atypes := - special => cosig - rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == - keyword := - x is [":",y,t] => - x := t - y - nil - res := - x = exception => dbOpsForm exception - pred => - STRINGP x => [x] - u := APPLY(argFn,[x]) - atom u and [u] or u - typ := sublisFormal(args,atype) - if x is ['QUOTE,a] then x := a - u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u] - NUMBERP x or STRINGP x => [x] - systemError() - keyword => [keyword,'": ",:res] - res - op = 'Mapping => dbMapping2StringList sargl - head := - special => [op] - APPLY(opFn,[form]) - [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"] - - -dbMapping2StringList [target,:sl] == - null sl => target - restPart := - null rest sl => nil - "append"/[[",",:y] for y in rest sl] - sourcePart := - restPart => ['"(",:first sl,:restPart,'")"] - first sl - [:sourcePart,'" -> ",:target] - -dbOuttran form == - if LISTP form then - [op,:args] := form - else - op := form - args := nil - cosig := rest GETDATABASE(op,'COSIG) - atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - argl := [fn for x in args for atype in atypes for pred in cosig] where fn == - pred => x - typ := sublisFormal(args,atype) - arg := - x is ['QUOTE,a] => a - x - res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) - NUMBERP res or STRINGP res => res - ['QUOTE,res] - [op,:argl] - -dbOpsForm form == ---one button for the operations of a type ---1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted ---2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|)) - ["\ops{",:conform2StringList(form,FUNCTION conname2StringList,_ - FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"] - -dbConform form == ---------------------> OBSELETE <-------------------------- ---one button for the main constructor page of a type ---NOTE: Next line should be as follows---but form2Fence form will --- put, e.g. '((2 1 . 0) (0 1 . 0)) instead of x**2 + 1 - $saturn => ["\conf{",:form2StringList opOf form, - '"}{\lispLink{\verb!{(|conForm| '",:form2Fence dbOuttran form,'")!}}}"] - ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] ---["\conf{",:form2StringList opOf form,'"}{",:form2Fence opOf form,'"}"] - - -dbConformGen form == dbConformGen1(form,true) ---many buttons: one for the type and one for each inner type ---NOTE: must only be called on types KNOWN to be correct - -dbConformGenUnder form == dbConformGen1(form,false) ---same as above, except buttons only for the inner types - -dbConformGen1(form,opButton?) == - opFunction := - opButton? => FUNCTION dbConform - FUNCTION conname2StringList - originalOp := opOf form - op := unAbbreviateIfNecessary opOf form - args := IFCDR form - form := - originalOp=op => form - [op, :args] - args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil) - APPLY(opFunction,[form]) - -unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op - -conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form] - ---=========================================================================== --- Data Gathering Code ---============================================================================ -dbGatherData(htPage,opAlist,which,key) == - key = 'implementation => dbGatherDataImplementation(htPage,opAlist) - dataFunction := LASSOC(key,table) where - table == - $dbDataFunctionAlist or - ($dbDataFunctionAlist := [ - ['signatures,:function dbMakeSignature], - ['parameters,:function dbContrivedForm], - ['origins,:function dbGetOrigin], - ['domains,:function dbGetOrigin], - ['conditions,:function dbGetCondition]]) - null dataFunction => - --key= names or filter or documentation; do not expand - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - opAlist := --to get indexing correct - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - acc := nil - initialExposure := - htPage and htpProperty(htPage,'conform) and which ^= '"package operation" - => true - --never star ops from a constructor - nil - for [op,:alist] in opAlist repeat - exposureFlag := initialExposure - while alist repeat - item := first alist - isExposed? := - STRINGP item => dbExposed?(item,char 'o) --unexpanded case - null (r := rest rest item) => true --assume true if unexpanded - r . 1 --expanded case - if isExposed? then return (exposureFlag := true) - alist := rest alist - node := - exposureFlag => op - [op,nil] - acc := [node,:acc] - NREVERSE acc - data := nil - dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in _ - '(origins documentation),false) - --create data, a list of the form ((entry,exposeFlag,:entries)...) - for [op,:alist] in opAlist repeat - for item in alist repeat - entry := FUNCALL(dataFunction,op,item)--get key item - exposeFlag := --is the current op-sig exposed? - null (r := rest rest item) => true --not given, assume yes - r . 1 --is given, use value - tail := - item is [.,'ASCONST,:.] => 'ASCONST - nil - newEntry := - u := ASSOC(entry,data) => --key seen before? look on DATA - RPLACA(CDR u,CADR u or exposeFlag)--yes, expose if any 1 is exposed - u - data := [y := [entry,exposeFlag,:tail],:data] - y --no, create new entry in DATA - if MEMBER(key,'(origins conditions)) then - r := CDDR newEntry - if atom r then r := nil --clear out possible 'ASCONST - RPLACD(CDR newEntry, --store op/sigs under key if needed - insert([dbMakeSignature(op,item),exposeFlag,:tail],r)) - if MEMBER(key,'(origins conditions)) then - for entry in data repeat --sort list of entries (after the 2nd) - tail := CDDR entry - tail := - atom tail => tail - listSort(function LEXLESSEQP,tail) - RPLACD(CDR entry,tail) - data := listSort(function LEXLESSEQP,data) - data - -dbGatherDataImplementation(htPage,opAlist) == ---returns data, of form ((implementor exposed? entry entry...)... --- where entry has form ((op sig . implementor) . stuff) - conform := htpProperty(htPage,'conform) - domainForm := htpProperty(htPage,'domname) - dom := EVAL domainForm - which := '"operation" - [nam,:$domainArgs] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - predVector := dom.3 - u := getDomainOpTable(dom,true,ASSOCLEFT opAlist) - --u has form ((op,sig,:implementor)...) - --sort into 4 groups: domain exports, unexports, default exports, others - - for (x := [.,.,:key]) in u for i in 0.. repeat - key = domainForm => domexports := [x,:domexports] - INTEGERP key => unexports := [x,:unexports] - isDefaultPackageForm? key => defexports := [x,:defexports] - key = 'nowhere => nowheres := [x,:nowheres] - key = 'constant =>constants := [x,:constants] - others := [x,:others] --add chain domains go here - fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR, - NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where - fn l == - alist := nil - for u in l repeat - while u repeat - key := CDDAR u --implementor - entries := - [[CAR u,true],:[u and [CAR u,true] while key = CDDAR (u := rest u)]] - alist := [[key,gn key,:entries],:alist] - NREVERSE alist - gn key == - atom key => true - isExposedConstructor CAR key - -dbSelectData(htPage,opAlist,key) == - branch := htpProperty(htPage,'branch) - data := htpProperty(htPage,'data) - MEMQ(branch,'(signatures parameters)) => - dbReduceOpAlist(opAlist,data.key,branch) - MEMQ(branch,'(origins conditions implementation)) => - key < 8192 => dbReduceOpAlist(opAlist,data.key,branch) - [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large - innerData := CDDR data.(newkey - 1) - dbReduceOpAlist(opAlist,innerData.binkey,'signatures) - [opAlist . key] - -dbReduceOpAlist(opAlist,data,branch) == - branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data) - branch = 'origins => dbReduceBySelection(opAlist,CAR data,function CADDR) - branch = 'conditions => dbReduceBySelection(opAlist,CAR data,function CADR) - branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data) - branch = 'parameters => dbReduceByForm(opAlist,CAR data) - systemError ['"Unexpected branch: ",branch] - -dbReduceByOpSignature(opAlist,datalist) == ---reduces opAlist by implementation datalist, one of the form --- (((op,sig,:implementor),:stuff),...) - ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.] - acc := nil - for [op,:alist] in opAlist | MEMQ(op,ops) repeat - entryList := [entry for (entry := [sig,:.]) in alist | test] where test == - or/[x for x in datalist | x is [[=op,=sig,:.],:.]] - entryList => acc := [[op,:NREVERSE entryList],:acc] - NREVERSE acc - -dbReduceBySignature(opAlist,op,sig) == ---reduces opAlist to one with a fixed op and sig - [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]] - -dbReduceByForm(opAlist,form) == - acc := nil - for [op,:alist] in opAlist repeat - items := [x for x in alist | dbContrivedForm(op,x) = form] => - acc := [[op,:items],:acc] - NREVERSE acc - -dbReduceBySelection(opAlist,key,fn) == - acc := nil - for [op,:alist] in opAlist repeat - items := [x for x in alist | FUNCALL(fn,x) = key] => - acc := [[op,:items],:acc] - NREVERSE acc - -dbContrivedForm(op,[sig,:.]) == - $which = '"attribute" => [op,sig] - dbMakeContrivedForm(op,sig) - -dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format - -dbGetOrigin(op,[.,.,origin,:.]) == origin - -dbGetCondition(op,[.,pred,:.]) == pred - ---dbInsertOpAlist(op,item,opAlist) == --- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist) - ---dbSortOpAlist opAlist == --- [[op,:listSort(function LEXLESSEQP,alist)] --- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)] - ---============================================================================ --- Branches of Views ---============================================================================ -dbShowOpNames(htPage,opAlist,which,data) == - single? := opAlist and null rest data - single? => - ops := escapeSpecialChars STRINGIMAGE CAAR opAlist - htSayStandard('"Select a view below") - htSaySaturn '"Select a view with the right mouse button" - exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage) - dbShowOpItems(which,data,exposedOnly?) - -dbShowOpItems(which,data,exposedOnly?) == - htBeginTable() - firstTime := true - for i in 0.. for item in data repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - if atom item then - op := item - exposeFlag := true - else - [op,exposeFlag] := item - ops := escapeSpecialChars STRINGIMAGE op - exposeFlag or not exposedOnly? => - htSay('"{") - bcStarSpaceOp(ops,exposeFlag) - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]] - htSay('"}") - htEndTable() - -dbShowOpAllDomains(htPage,opAlist,which) == - dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - catOriginAlist := nil --list of category origins - domOriginAlist := nil --list of domain origins - for [op,:items] in opAlist repeat - for [.,predicate,origin,:.] in items repeat - conname := CAR origin - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true) - catOriginAlist := insertAlist(conname,pred,catOriginAlist) - pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true) - domOriginAlist := insertAlist(conname,pred,domOriginAlist) - --the following is similar to "domainsOf" but do not sort immediately - u := [COPY key for key in HKEYS _*HASCATEGORY_-HASH_* - | LASSQ(CDR key,catOriginAlist)] - for pair in u repeat - [dom,:cat] := pair - LASSQ(cat,catOriginAlist) = 'etc => RPLACD(pair,'etc) - RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true)) - --now add all of the domains - for [dom,:pred] in domOriginAlist repeat - u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u) - cAlist := listSort(function GLESSEQP,u) - for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair) - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"constructor") - htpSetProperty(htPage,'specialHeading,'"hoho") - dbShowCons(htPage,'names) - -simpOrDumb(new,old) == - new = 'etc => 'etc - atom new => old - 'etc - -dbShowOpOrigins(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,true,_ - '"from",function bcStarConform) - -dbShowOpImplementations(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform) - -dbShowOpConditions(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred) - -dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == ------------------> OBSELETE - single? := null rest data - htSay('"\beginmenu ") - bincount := 0 - for [thing,exposeFlag,:items] in data repeat - htSay('"\item ") - if single? then htSay(menuButton()) - else htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] - htSay '"{\em " - htSay - thing = 'nowhere => '"implemented nowhere" - thing = 'constant => '"constant" - thing = '_$ => '"by the domain" - INTEGERP thing => '"unexported" - constructorIfTrue => - htSay word - atom thing => '" an unknown constructor" - '"" - atom thing => '"unconditional" - '"" - htSay '"}" - if null atom thing then - if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") - htSay '" " - FUNCALL(fn,thing) - htSay('":\newline ") - dbShowOpSigList(which,items,(1 + bincount) * 8192) - bincount := bincount + 1 - htSay '"\endmenu " - -dbShowKind conform == - conname := CAR conform - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - kind = 'domain => - (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" - '"domain" - PNAME kind - -dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0) - -dbShowOpSigList(which,dataItems,count) == ---dataItems is (((op,sig,:.),exposureFlag,...) - single? := null rest dataItems - htBeginTable() - firstTime := true - for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat - if firstTime then firstTime := false - else htSaySaturn '"&"; - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" --- if single? then htSay('"{\em ",ops,'"}") else..... - htSayExpose(ops,exposureFlag) - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] - if which = '"attribute" then htSay args2HtString (sig and [sig]) else - htSay '": " - tail = 'ASCONST => bcConform first sig - bcConform ['Mapping,:sig] - htSay '"}" - count := count + 1 - htEndTable() - count - -dbShowOpParameters(htPage,opAlist,which,data) == - single? := null rest data - count := 0 - htBeginTable() - firstTime := true - for item in data repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - [opform,exposeFlag,:tail] := item - op := intern IFCAR opform - args := IFCDR opform - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" - htSayExpose(ops,exposeFlag) - n := #opform - do - n = 2 and LASSOC('Nud,PROPLIST op) => - dbShowOpParameterJump(ops,which,count,single?) - htSay('" {\em ",KAR args,'"}") - n = 3 and LASSOC('Led,PROPLIST op) => - htSay('"{\em ",KAR args,'"} ") - dbShowOpParameterJump(ops,which,count,single?) - htSay('" {\em ",KAR KDR args,'"}") - dbShowOpParameterJump(ops,which,count,single?) - tail = 'ASCONST or MEMBER(op,'(0 1)) or _ - which = '"attribute" and null IFCAR args => 'skip - htSay('"(") - if IFCAR args then htSay('"{\em ",IFCAR args,'"}") - for x in IFCDR args repeat - htSay('",{\em ",x,'"}") - htSay('")") - htSay '"}" - count := count + 1 - htEndTable() - -dbShowOpParameterJump(ops,which,count,single?) == - single? => htSay('"{\em ",ops,'"}") - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] - -dbShowOpDocumentation(htPage,opAlist,which,data) == - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - --NOTE: this line is necessary to get indexing right. - --The test below for $exposedOnlyIfTrue causes unexposed items - --to be skipped. - newWhich := - conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - which = '"package operation" => '"operation" - which - expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - if expand then - condata := dbGatherData(htPage,opAlist,which,'conditions) - htpSetProperty(htPage,'conditionData,condata) - base := -8192 - exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp - htSaySaturn '"\begin{description}" - for [op,:alist] in opAlist repeat - base := 8192 + base - for item in alist for j in 0.. repeat - [sig,predicate,origin,exposeFlag,comments] := item - exposeFlag or not $exposedOnlyIfTrue => - if comments ^= '"" and STRINGP comments _ - and (k := string2Integer comments) then - comments := - MEMQ(k,'(0 1)) => '"" - dbReadComments k - tail := CDDDDR item - RPLACA(tail,comments) - doc := (STRINGP comments and comments ^= '"" => comments; nil) - pred := predicate or true - index := (exactlyOneOpSig => nil; base + j) - if which = '"package operation" then - sig := SUBST(conform,'_$,sig) - origin := SUBST(conform,'_$,origin) - displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,_ - index,'dbChooseDomainOp,null exposeFlag,true) - htSaySaturn '"\end{description}" - -dbChooseDomainOp(htPage,which,index) == - [opKey,entryKey] := DIVIDE(index,8192) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - [op,:entries] := opAlist . opKey - entry := entries . entryKey - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,[[op,entry]]) - else htpSetProperty(htPage,'attrAlist,[[op,entry]]) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOps(htPage,which,'documentation) - -htSayExpose(op,flag) == - $includeUnexposed? => - flag => htBlank() - op.0 = char '_* => htSay '"{\em *} " - htSayUnexposed() - htSay '"" ---============================================================================ --- Branch-in From Other Places ---============================================================================ -dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists - $groupChoice := nil - conform := htpProperty(htPage,'conform) - --prepare opAlist for possible filtering of groups - if null BOUNDP '$topicHash then - $topicHash := MAKE_-HASHTABLE 'ID - for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat - HPUT($topicHash,x,c) - if domform := htpProperty(htPage,'domname) then - $conformsAreDomains : local := true - reduceOpAlistForDomain(opAlist,domform,conform) - conform := domform or conform - kind := capitalize htpProperty(htPage,'kind) - exposePart := - isExposedConstructor opOf conform => '"" - '" Unexposed " - fromPart := - domform => evalableConstructor2HtString domform - form2HtString conform - heading := - ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"] - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'lists) - htpSetProperty(htPage,'fromHeading,heading) - reducedOpAlist := - which = '"operation" => reduceByGroup(htPage,opAlist) - opAlist - if which = '"operation" - then - htpSetProperty(htPage,'principalOpAlist,opAlist) - htpSetProperty(htPage,'opAlist,reducedOpAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if domform - then htpSetProperty(htPage,'condition?,'no) - else dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOp1(htPage,reducedOpAlist,which,'names) - -reduceOpAlistForDomain(opAlist,domform,conform) == ---destructively simplify all predicates; filter out any that fail - form1 := [domform,:rest domform] - form2 := ['$,:rest conform] - for pair in opAlist repeat - RPLACD(pair,[test for item in rest pair | test]) where test == - [head,:tail] := item - CAR tail = true => item - pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail) - null pred => false - RPLACD(item,[pred]) - item - opAlist - -dbShowOperationLines(which,linelist) == --branch in with lines - htPage := htInitPage(nil,nil) --create empty page - opAlist := nil - lines := linelist - while lines repeat - name := dbName (x := first lines) - pile := [x] - while (lines := rest lines) and name = dbName (x := first lines) repeat - pile := [x,:pile] - opAlist := [[name,:NREVERSE pile],:opAlist] - opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'strings) - dbResetOpAlistCondition(htPage,which,opAlist) - if which = '"attribute" and BOUNDP '$attributeArgs and $attributeArgs then - --code needed to handle commutative("*"); called from aPage - --must completely expand the opAlist then check for those with - --arguments equal to $attributeArgs - --here: opAlist is [[op,:itemlist]] - dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false) - opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | _ - first item = $attributeArgs]]] - dbShowOp1(htPage,opAlist,which,'names) - ---============================================================================ --- Code to Expand opAlist ---============================================================================ -dbResetOpAlistCondition(htPage,which,opAlist) == - value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) - htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) - value - -dbSetOpAlistCondition(htPage,opAlist,which) == ---called whenever a new opAlist is needed ---property can only be inherited if 'no (a subset says NO if whole says NO) - condition := htpProperty(htPage,'condition?) - MEMQ(condition,'(yes no)) => condition = 'yes - value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) - htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) - value - -dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) == ---if condition? = true, stop when you find a non-trivial predicate ---otherwise, expand in full ---RETURNS: --- non-trivial predicate, if condition? = true and it finds one --- nil, otherwise ---SIDE-EFFECT: this function references the "expand" property (set elsewhere): --- 'strings, if not fully expanded and it contains strings --- i.e. opAlist is ((op . (string ...))...) if unexpanded --- 'lists, if not fully expanded and it contains lists --- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded - condition? := condition? and not $exposedOnlyIfTrue - value := nil --return value - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - expandFlag := htpProperty(htPage,expandProperty) - expandFlag = 'fullyExpanded => nil - expandFlag = 'strings => --strings are partially expanded - for pair in opAlist repeat - [op,:lines] := pair - acc := nil - for line in lines repeat - --NOTE: we must expand all lines here for a given op - -- since below we will change opAlist - --Case 1: Already expanded; just cons it onto ACC - null STRINGP line => --already expanded - if condition? then --this could have been expanded at a lower level - if null atom (pred := CADR line) then value := pred - acc := [line,:acc] --this one is already expanded; record it anyway - --Case 2: unexpanded; expand it then cons it onto ACC - [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1) - predicate := ncParseFromString pred - if condition? and null atom predicate then value := predicate - sig := ncParseFromString sigs --is (Mapping,:.) - if which = '"operation" then - if sig isnt ['Mapping,:.] - then sayBrightly ['"Unexpected signature for ",name,'": ",sigs] - else sig := rest sig - conname := intern dbNewConname line - origin := [conname,:getConstructorArgs conname] - exposeFlag := dbExposed?(line,char 'o) - acc := [[sig,predicate,origin,exposeFlag,comments],:acc] - --always store the fruits of our labor: - RPLACD(pair,NREVERSE acc) --at least partially expand it - condition? and value => return value --early exit - value => value - condition? => nil - htpSetProperty(htPage,expandProperty,'fullyExpanded) - expandFlag = 'lists => --lists are partially expanded - -- entry is [sig, predicate, origin, exposeFlag, comments] - $value: local := nil - $docTableHash := MAKE_-HASHTABLE 'EQUAL - packageSymbol := false - domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - if isDefaultPackageName opOf domform then - catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s) - packageSymbol := first rest domform - domform := [catname,:rest rest domform] --skip first argument ($) - docTable:= dbDocTable domform - for [op,:alist] in opAlist repeat - for [sig,:tail] in alist repeat - condition? => --the only purpose here is to find a non-trivial pred - null atom (pred := CAR tail) => return ($value := pred) - 'skip - u := - tail is [.,origin,:.] and origin => --- must change any % into $ otherwise we will not pick up comments properly --- delete the SUBLISLIS when we fix on % or $ - dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,_ - which,nil) - if packageSymbol then sig := SUBST('_$,packageSymbol,sig) - dbGetDocTable(op,sig,docTable,which,nil) - origin := IFCAR u or origin - docCode := IFCDR u --> (doc . code) --- if null FIXP CDR docCode then harhar(op) --> - if null doc and which = '"attribute" then doc := getRegistry(op,sig) - RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode]) - $value => return $value - $value => $value - condition? => nil - htpSetProperty(htPage,expandProperty,'fullyExpanded) - 'done - -getRegistry(op,sig) == - u := GETDATABASE('AttributeRegistry,'DOCUMENTATION) - v := LASSOC(op,u) - match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match - '"" - -evalableConstructor2HtString domform == - if VECP domform then domform := devaluate domform - conname := first domform - coSig := rest GETDATABASE(conname,'COSIG) - --entries are T for args which are domains; NIL for computational objects - and/[x for x in coSig] => form2HtString(domform,nil,true) - arglist := [unquote x for x in rest domform] where - unquote arg == - arg is [f,:args] => - f = 'QUOTE => first args - [f,:[unquote x for x in args]] - arg - fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) ---argtypes:= sublisFormal(arglist,fargtypes) - form2HtString([conname,:[fn for arg in arglist for x in coSig - for ftype in fargtypes]],nil,true) where - fn == - x => arg - typ := sublisFormal(arglist,ftype) - mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) - -mathform2HtString form == escapeString - $fortInts2Floats: local := false - form := niladicHack form - form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a) - form is ['BRACKET,['AGGLST,:arg]] => - if arg is ['construct,:r] then arg := r - arg := - atom arg => [arg] - [y for x in arg | y := (x is ['QUOTE,a] => a; x)] - tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg] - STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]") - form is ['BRACKET,['AGGLST,'QUOTE,arg]] => - if atom arg then arg := [arg] - tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] - STRCONC('"[",first arg,tailPart,'"]") - atom form => form - "STRCONC"/fortexp0 form - -niladicHack form == - atom form => form - form is [x] and GET(x,'NILADIC) => x - [niladicHack x for x in form] - ---============================================================================ --- Getting Operations from Domain ---============================================================================ - -getDomainOpTable(dom,fromIfTrue,:options) == - ops := KAR options - $predEvalAlist : local := nil - $returnNowhereFromGoGet: local := true - domname := dom.0 - conname := CAR domname - abb := getConstructorAbbreviation conname - opAlist := getOperationAlistFromLisplib conname - "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u - | key ^= 'Subsumed and ((null ops and (op1 := op)) _ - or (op1 := memq(op,ops)))] - for [op,:u] in opAlist] where - memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One - MEMQ(op,ops) => op - EQ(op,'One) => MEMQ(1,ops) and 1 - EQ(op,'Zero) => MEMQ(0,ops) and 0 - false - fn == - sig1 := sublisFormal(rest domname,sig) - predValue := evalDomainOpPred(dom,pred) - info := - null predValue => - 1 -- signifies not exported - null fromIfTrue => nil - cell := compiledLookup(op,sig1,dom) => - [f,:r] := cell - f = 'nowhere => 'nowhere --see replaceGoGetSlot - f = 'makeSpadConstant => 'constant - f = function IDENTITY => 'constant - f = 'newGoGet => SUBST('_$,domname,devaluate CAR r) - null VECP r => systemError devaluateList r - SUBST('_$,domname,devaluate r) - 'nowhere - [sig1,:info] - -evalDomainOpPred(dom,pred) == process(dom,pred) where - process(dom,pred) == - u := convert(dom,pred) - u = 'T => true - evpred(dom,u) - convert(dom,pred) == - pred is [op,:argl] => - MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]] - MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]] - MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)] - op = 'has => - [arg,p] := argl - p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a] - ['HasCategory,arg,convertCatArg p] - systemError '"unknown predicate form" - pred = 'T => true - systemError nil - convertCatArg p == - atom p or #p = 1 => MKQ p - ['LIST,MKQ first p,:[convertCatArg x for x in rest p]] - evpred(dom,pred) == - k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) - evpred1(dom,pred) - evpred1(dom,pred) == - pred is [op,:argl] => - MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl] - MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl] - op = 'NOT => not evpred1(dom,first argl) - k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) - op = 'HasAttribute => - [arg,[.,a]] := argl - attPredIndex := LASSOC(a,dom.2) - null attPredIndex => nil - attPredIndex = 0 => true - testBitVector(dom.3,attPredIndex) - nil - pred = 'T => true - systemError '"unknown atomic predicate form" - ---====================> WAS br-op2.boot <================================ - ---======================================================================= --- Operation Description ---======================================================================= - -displayDomainOp(htPage,which,origin,op,sig,predicate, - doc,index,chooseFn,unexposed?,$generalSearch?) == ------------------------> OBSELETE - $saturn => - displayDomainOp1(htPage,which,origin,op,sig,predicate, - doc,index,chooseFn,unexposed?,$generalSearch?) - $chooseDownCaseOfType : local := true --see dbGetContrivedForm - $whereList : local := nil - $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 _ - i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) - $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 _ - x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) - $FunctionList:local := '(f g h d e F G H) - $DomainList: local := '(D R S E T A B C M N P Q U V W) - exactlyOneOpSig := null index - conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - or origin - if $generalSearch? then $DomainList := rest $DomainList - opform := - which = '"attribute" => - null sig => [op] - [op,sig] - which = '"constructor" => origin - dbGetDisplayFormForOp(op,sig,doc) - htSay('"\newline") - if exactlyOneOpSig then htSay('"\menuitemstyle{}") - else htMakePage [['bcLinks,['"\menuitemstyle{}",'"",chooseFn,which,index]]] - htSay('"\tab{2}") - op := IFCAR opform - args := IFCDR opform - ops := escapeSpecialChars STRINGIMAGE op - n := #sig - do - n = 2 and LASSOC('Nud,PROPLIST op) => _ - htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") - n = 3 and LASSOC('Led,PROPLIST op) => _ - htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,_ - '" {\em ",quickForm2HtString KAR KDR args,'"}") - if unexposed? and $includeUnexposed? then - htSayUnexposed() - htSaySaturn '"\unexposed{{\em " - htSaySaturn ops - htSaySaturn '"}" - htSayStandard(ops) - predicate='ASCONST or GETDATABASE(op,'NILADIC) _ - or MEMBER(op,'(0 1)) => 'skip - which = '"attribute" and null args => 'skip - htSay('"(") - if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") - for x in IFCDR args repeat - htSay('",{\em ",quickForm2HtString x,'"}") - htSay('")") - constring := form2HtString conform - conname := first conform - $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" - or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) - $conlength : local := #constring - $conform : local := conform - $conargs : local := rest conform - if which = '"operation" then - $signature : local := - MEMQ(conname,$Primitives) => nil - CDAR getConstructorModemap conname - --RDJ: this next line is necessary until compiler bug is fixed - --that forgets to substitute #variables for t#variables; - --check the signature for SegmentExpansionCategory, e.g. - tvarlist := TAKE(# $conargs,$TriangleVariableList) - $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) - $sig := - which = '"attribute" or which = '"constructor" => sig - $conkind ^= '"package" => sig - symbolsUsed := [x for x in rest conform | IDENTP x] - $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) - getSubstSigIfPossible sig - if MEMBER(which,'("operation" "constructor")) then - $displayReturnValue: local := nil - if args then - htSay('"\newline") - htSayStandard '"\tab{2}" - htSay '"{\em Arguments:}" - for a in args for t in rest $sig repeat - htSayIndentRel(15,true) - htSay('"{\em ",form2HtString(a),'"}, ") - htSayValue t - htSayIndentRel(-15,true) - htSay('"\newline ") - if first $sig then - $displayReturnValue := true - htSay('"\newline\tab{2}{\em Returns:}") - htSayIndentRel(15) - htSayValue first $sig - htSayIndentRel(-15) - htSay('"\newline ") - if origin and ($generalSearch? or origin ^= conform) _ - and opOf(origin)^=op then - htSay('"\newline\tab{2}{\em Origin:}") - htSayIndentRel(15) - if not isExposedConstructor opOf origin and $includeUnexposed? _ - then htSayUnexposed() - bcConform(origin,true) - htSayIndentRel(-15) - if not MEMQ(predicate,'(T ASCONST)) then - pred := sublisFormal(KDR conform,predicate) - count := #pred - htSay('"\newline\tab{2}{\em Conditions:}") - for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat - htSayIndentRel(15,count > 1) - bcPred(p,$conform,true) - htSayIndentRel(-15,count > 1) - htSay('"\newline ") - if $whereList then - count := #$whereList - htSay('"\newline\tab{2}{\em Where:}") - if ASSOC("$",$whereList) then - htSayIndentRel(15,true) - htSayStandard '"{\em \$} is " - htSaySaturn '"{\em \%} is " - htSay - $conkind = '"category" => '"of category " - '"the domain " - bcConform(conform,true,true) - htSayIndentRel(-15,true) - for [d,key,:t] in $whereList | d ^= "$" repeat - htSayIndentRel(15,count > 1) - htSay("{\em ",d,"} is ") - htSayConstructor(key,sublisFormal(KDR conform,t)) - htSayIndentRel(-15,count > 1) - if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then - htSay('"\newline\tab{2}{\em Description:}") - htSayIndentRel(15) - if doc = $charFauxNewline then htSay $charNewline - else - ndoc:= - -- we are confused whether doc is a string or a list of strings - CONSP doc => _ - [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] - SUBSTITUTE($charNewline, $charFauxNewline,doc) - htSay ndoc - htSayIndentRel(-15) - if exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then - displayInfoOp(htPage,infoAlist,op,sig) - - -htSayIndentRel(n,:options) == ------------------> OBSELETE - flag := IFCAR options - m := ABSVAL n - if flag then m := m + 2 - htSay - n > 0 => - flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] - ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] - n < 0 => ['"\indent{0}\newline "] - -htSayConstructor(key,u) == - u is ['CATEGORY,kind,:r] => - htSay('"a ",kind,'" ") - htSayExplicitExports(r) - key = 'is => - htSay '"the domain " - bcConform(u,true) - htSay - key = 'is => '"the domain " - kind := GETDATABASE(opOf u,'CONSTRUCTORKIND) - kind = 'domain => '"an element of " - '"a domain of " - u is ['Join,:middle,r] => - rest middle => - htSay '"categories " - bcConform(first middle,true) - for x in rest middle repeat - htSay '", " - bcConform(x,true) - r is ['CATEGORY,.,:r] => - htSay '" and " - htSayExplicitExports(r) - htSay '" and " - bcConform(r,true) - htSay '"category " - bcConform(first middle,true) - r is ['CATEGORY,.,:r] => - htSay '" " - htSayExplicitExports(r) - htSay '" and " - bcConform(r,true) - htSay(kind,'" ") - bcConform(u,true) - -htSayExplicitExports r == - htSay '"with explicit exports" - $displayReturnValue => nil - htSay '":" - for x in r repeat - htSay '"\newline " - x is ['SIGNATURE,op,sig] => - ops := escapeSpecialChars STRINGIMAGE op - htMakePage [['bcLinks,[ops,'"",'oPage,ops]]] - htSay '": " - bcConform ['Mapping,:sig] - x is ['ATTRIBUTE,a] => - s := form2HtString a - htMakePage [['bcLinks,[ops,'"",'aPage,s]]] - x is ['IF,:.] => - htSay('"{\em if ...}") - systemError() - -displayBreakIntoAnds pred == - pred is [op,:u] and MEMBER(op,'(and AND)) => u - [pred] - -htSayValue t == - t is ['Mapping,target,:source] => - htSay('"a function from ") - htSayTuple source - htSay '" to " - htSayArgument target - t = '(Category) => htSay('"a category") - t is [op,:.] and MEMQ(op,'(Join CATEGORY)) or constructor? opOf t => - htSayConstructor(nil,t) - htSay('"an element of domain ") - htSayArgument t --continue for operations - -htSayArgument t == --called only for operations not for constructors - null $signature => htSay ['"{\em ",t,'"}"] - MEMQ(t, '(_$ _%)) => - $conkind = '"category" and $conlength > 20 => - $generalSearch? => htSay '"{\em D} of the origin category" - addWhereList("$",'is,nil) - htSayStandard '"{\em $}" - htSaySaturn '"{\em \%}" - htSayStandard '"{\em $}" - htSaySaturn '"{\em \%}" - not IDENTP t => bcConform(t,true) - k := position(t,$conargs) - if k > -1 then - typeOfArg := (rest $signature).k - addWhereList(t,'member,typeOfArg) - htSay('"{\em ",t,'"}") - -addWhereList(id,kind,typ) == - $whereList := insert([id,kind,:typ],$whereList) - -htSayTuple t == - null t => htSay '"()" - null rest t => htSayArgument first t - htSay '"(" - htSayArgument first t - for d in rest t repeat - htSay '"," - htSayArgument d - htSay '")" - -dbGetDisplayFormForOp(op,sig,doc) == - dbGetFormFromDocumentation(op,sig,doc) or dbGetContrivedForm(op,sig) - -dbGetFormFromDocumentation(op,sig,x) == - doc := (STRINGP x => x; first x) - STRINGP doc and - (stringPrefix?('"\spad{",doc) and (k := 6) or - stringPrefix?('"\s{",doc) and (k := 3)) => - n := charPosition($charRbrace,doc,k) - s := SUBSTRING(doc,k,n - k) - parse := ncParseFromString s - parse is [=op,:.] and #parse = #sig => parse - nil - -dbMakeContrivedForm(op,sig,:options) == - $chooseDownCaseOfType : local := IFCAR options - $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 _ - i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) - $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 _ - x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) - $FunctionList:local := '(f g h d e F G H) - $DomainList: local := '(R S D E T A B C M N P Q U V W) - dbGetContrivedForm(op,sig) - -dbGetContrivedForm(op,sig) == - op = '"0" => [0] - op = '"1" => [1] - [op,:[dbChooseOperandName s for s in rest sig]] - -dbChooseOperandName(typ) == - typ is ['Mapping,:.] => - x := first $FunctionList - $FunctionList := rest $FunctionList - x - name := opOf typ - kind := - name = "$" => 'domain - GETDATABASE(name,'CONSTRUCTORKIND) - s := PNAME opOf typ - kind ^= 'category => - anySubstring?('"Integer",s,0) or anySubstring?('"Number",s,0) => - x := first $NumberList - $NumberList := rest $NumberList - x - x := - $chooseDownCaseOfType => - y := DOWNCASE typ - x := - MEMBER(y,$ElementList) => y - first $ElementList - first $ElementList - $ElementList := DELETE(x,$ElementList) - x - x := first $DomainList - $DomainList := rest $DomainList - x - -getSubstSigIfPossible sig == - getSubstSignature sig or sig - --- --- while (u := getSubstSignature sig) repeat --- sig := u --- sig - -fullSubstitute(x,y,z) == --substitutes deeply: x for y in list z - z = y => x - atom z => z - [fullSubstitute(x,y,u) for u in z] - -getSubstCandidates sig == - candidates := nil - for x in sig for i in 1.. | x is [.,.,:.] repeat - getSubstQualify(x,i,sig) => candidates := getSubstInsert(x,candidates) - y := or/[getSubstQualify(y,i,sig) for y in rest x | y is [.,.,:.]] => - candidates := insert(y,candidates) - candidates - -getSubstSignature sig == - candidates := getSubstCandidates sig - null candidates => nil - D := first $DomainList - $DomainList := rest $DomainList - winner := first candidates - newsig := fullSubstitute(D,winner,sig) - sig := - null rest candidates => newsig - count := NUMOFNODES newsig - for x in rest candidates repeat - trial := fullSubstitute(D,x,sig) - trialCount := NUMOFNODES trial - trialCount < count => - newsig := trial - count := trialCount - winner := x - newsig - addWhereList(D,'is,winner) - newsig - -getSubstQualify(x,i,sig) == - or/[CONTAINED(x,y) for y in sig for j in 1.. | j ^= i] => x - false - -getSubstInsert(x,candidates) == - return insert(x,candidates) - null candidates => [x] - or/[CONTAINED(x,y) for y in candidates] => candidates - y := or/[CONTAINED(y,x) for y in candidates] => SUBST(x,y,candidates) - candidates - - ---======================================================================= --- Who Uses ---======================================================================= -whoUsesOperation(htPage,which,key) == --see dbPresentOps - key = 'filter => koaPageFilterByName(htPage,'whoUsesOperation) - opAlist := htpProperty(htPage,'opAlist) - conform := htpProperty(htPage,'conform) - conargs := rest conform - opl := nil - for [op,:alist] in opAlist repeat - for [sig,:.] in alist repeat - opl := [[op,:SUBLISLIS($FormalMapVariableList,rest conform,sig)],:opl] - opl := NREVERSE opl - u := whoUses(opl,conform) - prefix := pluralSay(#u,'"constructor uses",'"constructors use") - suffix := - opAlist is [[op1,.]] => - ['" operation {\em ",escapeSpecialChars STRINGIMAGE op1,_ - '":",form2HtString ['Mapping,:sig],'"}"] - ['" these operations"] - page := htInitPage([:prefix,:suffix],htCopyProplist htPage) - nopAlist := nil - for [name,:opsigList] in u repeat - for opsig in opsigList repeat - sofar := LASSOC(opsig,nopAlist) - nopAlist := insertAlist(opsig,[name,:LASSOC(opsig,nopAlist)],nopAlist) - usedList := nil - for [(pair := [op,:sig]),:namelist] in nopAlist repeat - ops := escapeSpecialChars STRINGIMAGE op - usedList := [pair,:usedList] - htSay('"Users of {\em ",ops,'": ") - bcConform ['Mapping,:sublisFormal(conargs,sig)] - htSay('"}\newline") - bcConTable listSort(function GLESSEQP,REMDUP namelist) - noOneUses := SETDIFFERENCE(opl,usedList) - if #noOneUses > 0 then - htSay('"No constructor uses the ") - htSay - #noOneUses = 1 => '"operation: " - [#noOneUses,'" operations:"] - htSay '"\newline " - for [op,:sig] in noOneUses repeat - htSay('"\tab{2}{\em ",escapeSpecialChars STRINGIMAGE op,'": ") - bcConform ['Mapping,:sublisFormal(conargs,sig)] - htSay('"}\newline") - htSayStandard '"\endscroll " - dbPresentOps(page,which,'usage) - htShowPageNoScroll() - -whoUses(opSigList,conform) == - opList := REMDUP ASSOCLEFT opSigList - numOfArgsList := REMDUP [-1 + #sig for [.,:sig] in opSigList] - acc := nil - $conname : local := first conform - domList := getUsersOfConstructor $conname - hash := MAKE_-HASH_-TABLE() - for name in allConstructors() | MEMQ(name,domList) repeat - $infovec : local := dbInfovec name - null $infovec => 'skip --category - template := $infovec . 0 - found := false - opacc := nil - for i in 7..MAXINDEX template repeat - item := template . i - item isnt [n,:op] or not MEMQ(op,opList) => 'skip - index := n - numvec := getCodeVector() - numOfArgs := numvec . index - null MEMBER(numOfArgs,numOfArgsList) => 'skip - whereNumber := numvec.(index := index + 1) - template . whereNumber isnt [= $conname,:.] => 'skip - signumList := dcSig(numvec,index + 1,numOfArgs) - opsig := or/[pair for (pair := [op1,:sig]) in opSigList _ - | op1 = op and whoUsesMatch?(signumList,sig,nil)] - => opacc := [opsig,:opacc] - if opacc then acc := [[name,:opacc],:acc] - acc - -whoUsesMatch?(signumList,sig,al) == - #signumList = #sig and whoUsesMatch1?(signumList,sig,al) - -whoUsesMatch1?(signumList,sig,al) == - signumList is [subject,:r] and sig is [pattern,:s] => - x := LASSOC(pattern,al) => - x = subject => whoUsesMatch1?(r,s,al) - false - pattern = '_$ => - subject is [= $conname,:.] => whoUsesMatch1?(r,s,[['_$,:subject],:al]) - false - whoUsesMatch1?(r,s,[[pattern,:subject],:al]) - true - ---======================================================================= --- Get Attribute/Operation Alist ---======================================================================= - -koAttrs(conform,domname) == - [conname,:args] := conform ---asharpConstructorName? conname => nil --assumed - 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => - koCatAttrs(conform,domname) - $infovec: local := dbInfovec conname or return nil - $predvec: local := - $domain => $domain . 3 - GETDATABASE(conname,'PREDICATES) - u := [[a,:pred] for [a,:i] in $infovec . 2 _ - | a ^= 'nil and (pred := sublisFormal(args,kTestPred i))] - --------- CHECK for a = nil - listSort(function GLESSEQP,fn u) where fn u == - alist := nil - for [a,:pred] in u repeat - op := opOf a - args := IFCDR a - alist := insertAlist(op,insertAlist(args,[pred],LASSOC(op,alist)),alist) - alist - -koOps(conform,domname,:options) == main where ---returns alist of form ((op (sig . pred) ...) ...) - main == - $packageItem: local := nil --- relatives? := IFCAR options - ours := --- relatives? = 'onlyRelatives => nil - fn(conform,domname) --- if relatives? then --- relatives := relativesOf(conform,domname) --- if domname then relatives := --- SUBLISLIS([domname,:rest domname],['_$,:rest conform],relatives) --- --kill all relatives that have a sharp variable remaining in them --- for x in relatives repeat --- or/[y for y in CDAR x | isSharpVar y] => 'skip --- acc := [x,:acc] --- relatives := NREVERSE acc --- for (pair := [pakform,:.]) in relatives repeat --- $packageItem := sublisFormal(rest conform,pair) --- ours := merge(fn(pakform,nil),ours) - listSort(function GLESSEQP,trim ours) - trim u == [pair for pair in u | IFCDR pair] - fn(conform,domname) == - conform := domname or conform - [conname,:args] := conform - subargs: local := args - ----------> new <------------------ - u := koCatOps(conform,domname) => u --- 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => --- koCatOps(conform,domname) - asharpConstructorName? opOf conform => nil - ----------> new <------------------ - $infovec: local := dbInfovec conname--------> removed 94/10/24 - exposureTail := - null $packageItem => '(NIL NIL) - isExposedConstructor opOf conform => [conform,:'(T)] - [conform,:'(NIL)] - for [op,:u] in getOperationAlistFromLisplib conname repeat - op1 := zeroOneConvert op - acc := - [[op1,:[[sig,npred,:exposureTail] _ - for [sig,slot,pred,key,:.] in sublisFormal(subargs,u) | - (key ^= 'Subsumed) and (npred := simpHasPred pred)]],:acc] - acc - merge(alist,alist1) == --alist1 takes precedence - for [op,:al] in alist1 repeat - u := LASSOC(op,alist) => - for [sig,:item] in al | not LASSOC(sig,u) repeat - u := insertAlist(sig,item,u) - alist := insertAlist(op,u,DELASC(op,alist)) --add merge of two alists - alist := insertAlist(op,al,alist) --add the whole inner alist - alist - -zeroOneConvert x == - x = 'Zero => 0 - x = 'One => 1 - x - -kFormatSlotDomain x == fn formatSlotDomain x where fn x == - atom x => x - (op := CAR x) = '_$ => '_$ - op = 'local => CADR x - op = ":" => [":",CADR x,fn CADDR x] - MEMQ(op,$Primitives) or constructor? op => - [fn y for y in x] - INTEGERP op => op - op = 'QUOTE and atom CADR x => CADR x - x - -koCatOps(conform,domname) == - conname := opOf conform - oplist := REVERSE GETDATABASE(conname,'OPERATIONALIST) - oplist := sublisFormal(IFCDR domname or IFCDR conform ,oplist) - --check below for INTEGERP key to avoid subsumed signatures - [[zeroOneConvert op,:nalist] for [op,:alist] in oplist _ - | nalist := koCatOps1(alist)] - -koCatOps1 alist == [x for item in alist | x := pair] where - pair == - [sig,:r] := item - null r => [sig,true] - [key,:options] := r - null (pred := IFCAR options) => - IFCAR IFCDR options = 'ASCONST => [sig,'ASCONST] - [sig,true] - npred := simpHasPred pred => [sig,npred] - false - -koCatAttrs(catform,domname) == - $if: local := MAKE_-HASHTABLE 'ID - catname := opOf catform - koCatAttrsAdd(domname or catform,true) - ancestors := ancestorsOf(catform,domname) - for [conform,:pred] in ancestors repeat koCatAttrsAdd(conform,pred) - hashTable2Alist $if - -hashTable2Alist tb == - [[op,:HGET(tb,op)] for op in listSort(function GLESSEQP,HKEYS $if)] - -koCatAttrsAdd(catform,pred) == - for [name,argl,:p] in CAR getConstructorExports catform repeat - npred := quickAnd(pred,p) - exists := HGET($if,name) - if existingPred := LASSOC(argl,exists)_ - then npred := quickOr(npred,existingPred) - if not MEMQ(name,'(nil nothing)) _ - then HPUT($if,name,[[argl,simpHasPred npred],:exists]) - ---======================================================================= --- Filter by Category ---======================================================================= - -koaPageFilterByCategory(htPage,calledFrom) == - opAlist := htpProperty(htPage,'opAlist) - which := htpProperty(htPage,'which) - page := htInitPageNoScroll(htCopyProplist htPage, - dbHeading(opAlist,which,htpProperty(htPage,'heading))) - htSay('"Select a category ancestor below or ") - htMakePage [['bcLispLinks,['"filter",'"on:",calledFrom,'filter]]] - htMakePage [['bcStrings, [13,'"",'filter,'EM]]] - htSay('"\beginscroll ") - conform := htpProperty(htPage,'conform) - domname := htpProperty(htPage,'domname) - ancestors := ASSOCLEFT ancestorsOf(conform,domname) - htpSetProperty(page,'ancestors,listSort(function GLESSEQP,ancestors)) - bcNameCountTable(ancestors,'form2HtString,'koaPageFilterByCategory1,true) - htShowPage() - -dbHeading(items,which,heading,:options) == - names? := IFCAR options - count := - names? => #items - +/[#(rest x) for x in items] - capwhich := capitalize which - prefix := - count < 2 => - names? => pluralSay(count,STRCONC(capwhich," Name"),nil) - pluralSay(count,capwhich,nil) - names? => pluralSay(count,nil,STRCONC(capwhich," Names")) - pluralSay(count,nil,pluralize capwhich) - [:prefix,'" for ",:heading] - -koaPageFilterByCategory1(htPage,i) == - ancestor := htpProperty(htPage,'ancestors) . i - ancestorList := [ancestor,:ASSOCLEFT ancestorsOf(ancestor,nil)] - newOpAlist := nil - which := htpProperty(htPage,'which) - opAlist := htpProperty(htPage,'opAlist) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - heading := htpProperty(htPage,'heading) - docTable := dbDocTable(domname or conform) - for [op,:alist] in opAlist repeat - nalist := [[origin,:item] for item in alist | split] - where split == - [sig,pred,:aux] := item - u := dbGetDocTable(op,sig,docTable,which,aux) - origin := IFCAR u - doc := IFCDR u - true - for [origin,:item] in nalist | origin repeat - MEMBER(origin,ancestorList) => - newEntry := [item,:LASSOC(op,newOpAlist)] - newOpAlist := insertAlist(op,newEntry,newOpAlist) - falist := nil - for [op,:alist] in newOpAlist repeat - falist := [[op,:NREVERSE alist],:falist] - htpSetProperty(htPage,'fromcat,[_ - '" from category {\sf ",form2HtString ancestor,'"}"]) - dbShowOperationsFromConform(htPage,which,falist) - ---======================================================================= --- New code for search operation alist for exact matches ---======================================================================= - -opPageFast opAlist == --called by oSearch - htPage := htInitPage(nil,nil) - htpSetProperty(htPage,'opAlist,opAlist) - htpSetProperty(htPage,'expandOperations,'lists) - which := '"operation" ---dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOp1(htPage,opAlist,which,'names) - -opPageFastPath opstring == ---return nil - x := STRINGIMAGE opstring - charPosition(char '_*,x,0) < #x => nil --quit if name has * in it - op := (STRINGP x => INTERN x; x) - mmList := getAllModemapsFromDatabase(op,nil) or return nil - opAlist := [[op,:[item for mm in mmList]]] where item == - [predList, origin, sig] := modemap2Sig(op, mm) - predicate := predList and MKPF(predList,'AND) - exposed? := isExposedConstructor opOf origin - [sig, predicate, origin, exposed?] - opAlist - -modemap2Sig(op,mm) == - [dcSig, conds] := mm - [dc, :sig] := dcSig - partial? := - conds is ['partial,:r] => conds := r - false - condlist := modemap2SigConds conds - [origin, vlist, flist] := getDcForm(dc, condlist) or return nil - subcondlist := SUBLISLIS(flist, vlist, condlist) - [predList,vlist, flist] := getSigSubst(subcondlist, nil, vlist, flist) - if partial? then - target := dcSig . 1 - ntarget := ['Union, target, '"failed"] - dcSig := SUBST(ntarget, target, dcSig) - alist := findSubstitutionOrder? pairlis(vlist, flist) or systemError() - predList := substInOrder(alist, predList) - nsig := substInOrder(alist, sig) - if hasPatternVar nsig or hasPatternVar predList then - pp '"--------------" - pp op - pp predList - pp nsig - pp mm - $badStack := [[op, mm], :$badStack] ---pause nsig - [predList, origin, SUBST("%", origin, nsig)] - -modemap2SigConds conds == - conds is ['OR,:r] => modemap2SigConds first r - conds is ['AND,:r] => r - [conds] - -hasPatternVar x == - IDENTP x and (x ^= "**") => isPatternVar x - atom x => false - or/[hasPatternVar y for y in x] - -getDcForm(dc, condlist) == - [ofWord,id,cform] := or/[x for x in condlist | x is [k,=dc,:.] - and MEMQ(k, '(ofCategory isDomain))] or return nil - conform := getConstructorForm opOf cform - ofWord = 'ofCategory => - [conform, ["*1", :rest cform], ["%", :rest conform]] - ofWord = 'isDomain => - [conform, ["*1", :rest cform], ["%", :rest conform]] - systemError() - -getSigSubst(u, pl, vl, fl) == - u is [item, :r] => - item is ['AND,:s] => - [pl, vl, fl] := getSigSubst(s, pl, vl, fl) - getSigSubst(r, pl, vl, fl) - [key, v, f] := item - key = 'isDomain => getSigSubst(r, pl, [v, :vl], [f, :fl]) - key = 'ofCategory => getSigSubst(r, pl, ['D, :vl], [f, :fl]) - key = 'ofType => getSigSubst(r, pl, vl, fl) - key = 'has => getSigSubst(r, [item, :pl], vl, fl) - key = 'not => getSigSubst(r, [item, :pl], vl, fl) - systemError() - [pl, vl, fl] - - -pairlis(u,v) == - null u or null v => nil - [[first u,:first v],:pairlis(rest u, rest v)] - - ---====================> WAS b-search.boot <================================ - ---======================================================================= --- Grepping Database libdb.text --- Redone 12/95 for Saturn; previous function grep renamed as grepFile --- This function now either returns a filename or a list of strings ---======================================================================= -grepConstruct(s,key,:options) == --key = a o c d p x k (all) . (aok) w (doc) ---Called from genSearch with key = "." and "w" ---key = "." means a o c d p x ---option1 = true means return the result as a file ---All searches of the database call this function to get relevant lines ---from libdb.text. Returns either a list of lines (usual case) or else ---an alist of the form ((kind . ) ...) - $localLibdb : local := fnameExists? '"libdb.text" and '"libdb.text" - lines := grepConstruct1(s,key) - IFCAR options => grepSplit(lines,key = 'w) --leave now if a constructor - MEMQ(key,'(o a)) => dbScreenForDefaultFunctions lines --kill default lines if a/o - lines - -grepConstruct1(s,key) == ---returns the name of file (WITHOUT .text.$SPADNUM on the end) - $key : local := key - if key = 'k and --convert 'k to 'y if name contains an "&" - or/[s . i = char '_& for i in 0..MAXINDEX s] then key := 'y - filter := pmTransFilter STRINGIMAGE s --parses and-or-not form - filter is ['error,:.] => filter --exit on parser error - pattern := mkGrepPattern(filter,key) --create string to pass to "grep" - grepConstructDo(pattern, key) --do the "grep"---see b-saturn.boot - -grepConstructDo(x, key) == - $orCount := 0 ---atom x => grepFile(x, key,'i) - $localLibdb => - oldLines := purgeNewConstructorLines(grepf(x,key,false),$newConstructorList) - newLines := grepf(x,$localLibdb,false) - UNION(oldLines, newLines) - grepf(x,key,false) - -dbExposed?(line,kind) == -- does line come from an unexposed constructor? - conname := INTERN - kind = char 'a or kind = char 'o => dbNewConname line --get conname from middle - dbName line - isExposedConstructor conname - -dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x] - -isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char 'x - -grepForAbbrev(s,key) == ---checks that filter s is not * and is all uppercase; if so, look for abbrevs - u := HGET($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first - s := STRINGIMAGE s - someLowerCaseChar := false - someUpperCaseChar := false - for i in 0..MAXINDEX s repeat - c := s . i - LOWER_-CASE_-P c => return (someLowerCaseChar := true) - UPPER_-CASE_-P c => someUpperCaseChar := true - someLowerCaseChar or not someUpperCaseChar => false - pattern := DOWNCASE s - ['Abbreviations ,:[GETDATABASE(x,'CONSTRUCTORFORM) - for x in allConstructors() | test]] where test == - not $includeUnexposed? and not isExposedConstructor x => false - a := GETDATABASE(x,'ABBREVIATION) - match?(pattern,PNAME a) and not HGET($defaultPackageNamesHT,x) - -applyGrep(x,filename) == --OBSELETE with $saturn--> see applyGrepSaturn - atom x => grepFile(x,filename,'i) - $localLibdb => - a := purgeNewConstructorLines(grepf(x,filename,false),$newConstructorList) - b := grepf(x,$localLibdb,false) - grepCombine(a,b) - grepf(x,filename,false) - -grepCombine(a,b) == MSORT UNION(a,b) - -grepf(pattern,s,not?) == --s=sourceFile or list of strings - pattern is [op,:argl] => - op = "and" => - while argl is [arg,:argl] repeat - s := grepf(arg,s,not?) -- filter by successive greps - s - op = "or" => - targetStack := nil - "UNION"/[grepf(arg,s,not?) for arg in argl] - op = "not" => - not? => grepf(first argl,s,false) - --could be the first time so have to get all of same $key - lines := grepf(mkGrepPattern('"*",$key),s,false) - grepf(first argl,lines,true) - systemError nil - option := - not? => 'iv - 'i - source := - LISTP s => dbWriteLines s - s - grepFile(pattern,source,option) - -pmTransFilter s == ---result is either a string or (op ..) where op= and,or,not and arg are results - if $browseMixedCase = true then s := DOWNCASE s - or/[isFilterDelimiter? s.i or s.i = $charUnderscore for i in 0..MAXINDEX s] - => (parse := pmParseFromString s) and checkPmParse parse or - ['error,'"Illegal search string",'"\vspace{3}\center{{\em Your search string} ",escapeSpecialChars s,'" {\em has incorrect syntax}}"] - or/[s . i = char '_* and s.(i + 1) = char '_* - and (i=0 or s . (i - 1) ^= char $charUnderscore) for i in 0..(MAXINDEX s - 1)] - => ['error,'"Illegal search string",'"\vspace{3}\center{Consecutive {\em *}'s are not allowed in search patterns}"] - s - -checkPmParse parse == - STRINGP parse => parse - fn parse => parse where fn(u) == - u is [op,:args] => - MEMQ(op,'(and or not)) and and/[checkPmParse x for x in args] - STRINGP u => true - false - nil - -dnForm x == - STRINGP x => x - x is ['not,argl] => - argl is ['or,:orargs]=> - ['and, :[dnForm negate u for u in orargs]] where negate s == - s is ['not,argx] => argx - ['not,s] - argl is ['and,:andargs]=> - ['or,:[dnForm negate u for u in andargs]] - argl is ['not,notargl]=> - dnForm notargl - x - x is ['or,:argl1] => ['or,:[dnForm u for u in argl1]] - x is ['and,:argl2] => ['and,:[dnForm u for u in argl2]] - x - -pmParseFromString s == - u := ncParseFromString pmPreparse s - dnForm flatten u where flatten s == - s is [op,:argl] => - STRINGP op => STRCONC(op,"STRCONC"/[STRCONC('" ",x) for x in argl]) - [op,:[flatten x for x in argl]] - s - -pmPreparse s == hn fn(s,0,#s) where--stupid insertion of chars to get correct parse - hn x == SUBLISLIS('(and or not),'("and" "or" "not"),x) - fn(s,n,siz) == --main function: s is string, n is origin - n = siz => '"" - i := firstNonDelim(s,n) or return SUBSTRING(s,n,nil) - j := firstDelim(s,i + 1) or siz - t := gn(s,i,j - 1) - middle := - MEMBER(t,'("and" "or" "not")) => t - --the following 2 lines make commutative("*") parse correctly!!!! - t.0 = char '_" => t - j < siz - 1 and s.j = char '_( => t - STRCONC(char '_",t,char '_") - STRCONC(SUBSTRING(s,n,i - n),middle,fn(s,j,siz)) - gn(s,i,j) == --replace each underscore by 4 underscores! - n := or/[k for k in i..j | s.k = $charUnderscore] => - STRCONC(SUBSTRING(s,i,n - i + 1),$charUnderscore,gn(s,n + 1,j)) - SUBSTRING(s,i,j - i + 1) - -firstNonDelim(s,n) == or/[k for k in n..MAXINDEX s | not isFilterDelimiter? s.k] -firstDelim(s,n) == or/[k for k in n..MAXINDEX s | isFilterDelimiter? s.k] - -isFilterDelimiter? c == MEMQ(c,$pmFilterDelimiters) - -grepSplit(lines,doc?) == - if doc? then - instream2 := OPEN STRCONC(getEnv '"AXIOM",'"/algebra/libdb.text") - cons := atts := doms := nil - while lines is [line, :lines] repeat - if doc? then - N:=PARSE_-INTEGER dbPart(line,1,-1) - if NUMBERP N then - FILE_-POSITION(instream2,N) - line := READLINE instream2 - kind := dbKind line - not $includeUnexposed? and not dbExposed?(line,kind) => 'skip - (kind = char 'a or kind = char 'o) and isDefaultOpAtt line => 'skip - PROGN - kind = char 'c => cats := insert(line,cats) - kind = char 'd => doms := insert(line,doms) - kind = char 'x => defs := insert(line,defs) - kind = char 'p => paks := insert(line,paks) - kind = char 'a => atts := insert(line,atts) - kind = char 'o => ops := insert(line,ops) - kind = char '_- => 'skip --for now - systemError 'kind - if doc? then CLOSE instream2 - [['"attribute",:NREVERSE atts], - ['"operation",:NREVERSE ops], - ['"category",:NREVERSE cats], - ['"domain",:NREVERSE doms], - ['"package",:NREVERSE paks] --- ['"default_ package",:NREVERSE defs] -- drop defaults - ] - -mkUpDownPattern s == recurse(s,0,#s) where - recurse(s,i,n) == - i = n => '"" - STRCONC(fixchar(s.i),recurse(s,i + 1,n)) - fixchar(c) == - ALPHA_-CHAR_-P c => - STRCONC(char '_[,CHAR_-UPCASE c,CHAR_-DOWNCASE c,char '_]) - c - -mkGrepPattern(s,key) == - --called by grepConstruct1 and grepf - atom s => mkGrepPattern1(s,key) - [first s,:[mkGrepPattern(x,key) for x in rest s]] - -mkGrepPattern1(x,:options) == --called by mkGrepPattern (and grepConstructName?) - $options : local := options - s := STRINGIMAGE x ---s := DOWNCASE STRINGIMAGE x - addOptions remUnderscores addWilds split(g s,char '_*) where - addWilds sl == --add wild cards (sl is list of parts between *'s) - IFCAR sl = '"" => h(IFCDR sl,[$wild1]) - h(sl,nil) - g s == --remove "*"s around pattern for text match - not MEMQ('w,$options) => s - if s.0 = char '_* then s := SUBSTRING(s,1,nil) - if s.(k := MAXINDEX s) = char '_* then s := SUBSTRING(s,0,k) - s - h(sl,res) == --helper for wild cards - sl is [s,:r] => h(r,[$wild1,s,:res]) - res := rest res - if not MEMQ('w,$options) then - if first res ^= '"" then res := ['"`",:res] - else if res is [.,p,:r] and p = $wild1 then res := r - "STRCONC"/NREVERSE res - remUnderscores s == - (k := charPosition(char $charUnderscore,s,0)) < MAXINDEX s => - STRCONC(SUBSTRING(s,0,k),'"[",s.(k + 1),'"]", - remUnderscores(SUBSTRING(s,k + 2,nil))) - s - split(s,char) == - max := MAXINDEX s + 1 - f := -1 - [SUBSTRING(s,i,f-i) - while ((i := f + 1) <= max) and (f := charPosition(char,s,i))] - charPosition(c,t,startpos) == --honors underscores - n := SIZE t - if startpos < 0 or startpos > n then error "index out of range" - k:= startpos - for i in startpos .. n-1 while c ^= ELT(t,i) - or i > startpos and ELT(t,i-1) = '__ repeat (k := k+1) - k - addOptions s == --add front anchor - --options a o c d p x denote standard items - --options w means comments - --option t means text - --option s means signature - --option n means number of arguments - --option i means predicate - --option none means NO PREFIX - one := ($options is [x,:$options] and x => x; '"[^x]") - tick := '"[^`]*`" - one = 'w => s - one = 'none => (s = '"`" => '"^."; STRCONC('"^",s)) - prefix := - one = 't => STRCONC(tick,tick,tick,tick,tick,".*") - one = 'n => tick - one = 'i => STRCONC(tick,tick,tick,tick) - one = 's => STRCONC(tick,tick,tick) --- true => '"" ----> never put on following prefixes - one = 'k => '"[cdp]" - one = 'y => '"[cdpx]" - STRINGIMAGE one - s = $wild1 => STRCONC('"^",prefix) - STRCONC('"^",prefix,s) - -conform2OutputForm(form) == - [op,:args] := form - null args => form - cosig := rest GETDATABASE(op,'COSIG) - atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == - pp [x,atype,pred] - pred => conform2OutputForm x - typ := sublisFormal(args,atype) - if x is ['QUOTE,a] then x := a - algCoerceInteractive(x,typ,'(OutputForm)) - [op,:sargl] - -oPage(a,:b) == --called by \spadfun{opname} - oSearch (IFCAR b or a) --always take slow path - -oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname} - htPage := htInitPage(nil,nil) --create empty page and fill in needed properties - htpSetProperty(htPage,'conform,conform := getConstructorForm conname) - htpSetProperty(htPage,'kind,STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)) - itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname" - null itemlist => systemError [conform,'" has no operation named ",opname] - opAlist := [itemlist] - dbShowOperationsFromConform(htPage,'"operation",opAlist) - -aPage(a,:b) == --called by \spadatt{a} - $attributeArgs : local := nil - arg := IFCAR b or a - s := pmParseFromString STRINGIMAGE arg - searchOn := - ATOM s => s - IFCAR s - $attributeArgs : local := IFCAR IFCDR s - aSearch searchOn ---must recognize that not all attributes can be found in database ---e.g. constant(deriv) is not but appears in a conditional in LODO - -spadType(x) == --called by \spadtype{x} from HyperDoc - s := PNAME x - form := ncParseFromString s or - systemError ['"Argument: ",s,'" to spadType won't parse"] - if atom form then form := [form] - op := opOf form - looksLikeDomainForm form => APPLY(function conPage,form) - conPage(op) - -looksLikeDomainForm x == - entry := getCDTEntry(opOf x,true) or return false - coSig := LASSOC('coSig,CDDR entry) - k := #coSig - atom x => k = 1 - k ^= #x => false - and/[p for key in rest coSig for arg in rest x] where - p == - key => looksLikeDomainForm arg - not IDENTP arg - -spadSys(x) == --called by \spadsyscom{x} - s := PNAME x - if s.0 = char '_) then s := SUBSTRING(s,1,nil) - form := ncParseFromString s or - systemError ['"Argument: ",s,'" to spadType won't parse"] - htSystemCommands PNAME opOf form - ---======================================================================= --- Name and General Search ---======================================================================= -aokSearch filter == genSearch(filter,true) --"General" from HD (see man0.ht) ---General search for constructs but NOT documentation - -genSearch(filter,:options) == --"Complete" from HD (see man0.ht) and aokSearch ---General + documentation search - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => htErrorStar() - includeDoc? := not IFCAR options ---give summaries for how many a o c d p x match filter - regSearchAlist := grepConstruct(STRINGIMAGE filter,".",true) - regSearchAlist is ['error,:.] => bcErrorPage regSearchAlist - key := removeSurroundingStars filter - if includeDoc? then - docSearchAlist := grepConstruct(key,'w,true) - docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist - docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x]--drop defaults - genSearch1(filter,genSearchTran regSearchAlist,genSearchTran docSearchAlist) - -genSearchTran alist == [[x,y,:y] for [x,:y] in alist] - - -genSearch1(filter,reg,doc) == - regSearchAlist := searchDropUnexposedLines reg - docSearchAlist := searchDropUnexposedLines doc - key := removeSurroundingStars filter - regCount := searchCount regSearchAlist - docCount := searchCount docSearchAlist - count := regCount + docCount - count = 0 => emptySearchPage('"entry",filter,true) - count = 1 => - alist := (regCount = 1 => regSearchAlist; docSearchAlist) - showNamedConstruct(or/[x for x in alist | CADR x]) - summarize? := - docSearchAlist => true - nonEmpties := [pair for pair in regSearchAlist | #(CADR pair) > 0] - not(nonEmpties is [pair]) - not summarize? => showNamedConstruct pair - -----------generate a summary page--------------------------- - plural := - $exposedOnlyIfTrue => '"exposed entries match" - '"entries match" - prefix := pluralSay(count,'"", plural) - emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] - header := [:prefix,'" ",:emfilter] - page := htInitPage(header,nil) - htpSetProperty(page,'regSearchAlist,regSearchAlist) - htpSetProperty(page,'docSearchAlist,docSearchAlist) - htpSetProperty(page,'filter,filter) - if docSearchAlist then - dbSayItems(['"{\bf Construct Summary:} ",regCount],'"name matches",'"names match") - for [kind,:pair] in regSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt '"\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,summarize?,kind,i,'showConstruct) - if docSearchAlist then - htSaySaturn '"\bigskip{}" - dbSayItems(['"\newline{\bf Documentation Summary:} ",docCount],'"mention",'"mentions",'" of {\em ",key,'"}") - for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt "\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,true,kind,i,'showDoc) - htShowPageStar() -searchDropUnexposedLines alist == - [[op,[pred for line in lines | pred],:lines] for [op,.,:lines] in alist] where - pred == - not $exposedOnlyIfTrue or dbExposed?(line,dbKind line) => line - nil - -htShowPageStar() == -------------> OBSELETE - htSayStandard '"\endscroll " - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"Exposed",'" {\em only}",'repeatSearch,NIL]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'repeatSearch,'T]]] - htShowPageNoScroll() - -repeatSearch(htPage,newValue) == - $exposedOnlyIfTrue := newValue - filter := htpProperty(htPage,'filter) - reg := htpProperty(htPage,'regSearchAlist) - doc := htpProperty(htPage,'docSearchAlist) - reg => genSearch1(filter,reg,doc) - docSearch1(filter,doc) - -searchCount u == +/[# y for [x,y,:.] in u] - -showDoc(htPage,count) == - showIt(htPage,count,htpProperty(htPage,'docSearchAlist)) - -showConstruct(htPage,count) == - showIt(htPage,count,htpProperty(htPage,'regSearchAlist)) - -showIt(htPage,index,searchAlist) == - filter := htpProperty(htPage,'filter) - [relativeIndex,n] := DIVIDE(index,8) - relativeIndex = 0 => showNamedConstruct(searchAlist.n) - [kind,items,:.] := searchAlist . n - for j in 1.. while j < relativeIndex repeat items := rest items - firstName := dbName first items --select name then gather all of same name - lines := [line for line in items while dbName line = firstName] - showNamedConstruct [kind,nil,:lines] - -showNamedConstruct([kind,.,:lines]) == dbSearch(lines,kind,'"") - -genSearchSay(pair,summarize,kind,who,fn) == - [u,:fullLineList] := pair - count := #u - uniqueCount := genSearchUniqueCount u - short := summarize and uniqueCount >= $browseCountThreshold - htMakePage - [['bcLinks,[menuButton(),'"",'genSearchSayJump,[fullLineList,kind]]]] - if count = 0 then htSay('"{\em No ",kind,'"} ") - else if count = 1 then - htSay('"{\em 1 ",kind,'"} ") - else - htSay('"{\em ",count,'" ",pluralize kind,'"} ") - short => 'done - if uniqueCount ^= 1 then - htSayStandard '"\indent{4}" - htSay '"\newline " - htBeginTable() - lastid := nil - groups := organizeByName u - i := 1 - for group in groups repeat - id := dbGetName first group - if $includeUnexposed? then - exposed? := or/[dbExposed?(item,dbKind item) for item in group] - bcHt '"{" - if $includeUnexposed? then - exposed? => htBlank() - htSayUnexposed() - htMakePage [['bcLinks, [id,'"",fn,who + 8*i]]] - i := i + #group - bcHt '"}" - if uniqueCount ^= 1 then - htEndTable() - htSayStandard '"\indent{0}" - -organizeByName u == - [[(u := rest u; x) while u and head = dbName (x := first u)] - while u and (head := dbName first u)] - -genSearchSayJump(htPage,[lines,kind]) == - filter := htpProperty(htPage,'filter) - dbSearch(lines,kind,filter) - -genSearchUniqueCount(u) == ---count the unique number of items (if less than $browseCountThreshold) - count := 0 - lastid := nil - for item in u while count < $browseCountThreshold repeat - id := dbGetName item - if id ^= lastid then - count := count + 1 - lastid := id - count - -dbGetName line == SUBSTRING(line,1,charPosition($tick,line,1) - 1) - -pluralSay(count,singular,plural,:options) == - item := (options is [x,:options] => x; '"") - colon := (IFCAR options => '":"; '"") - count = 0 => concat('"No ",singular,item) - count = 1 => concat('"1 ",singular,item,colon) - concat(count,'" ",plural,item,colon) - - ---======================================================================= --- Documentation Search ---======================================================================= -docSearch filter == --"Documentation" from HD (see man0.ht) - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => htErrorStar() - key := removeSurroundingStars filter - docSearchAlist := grepConstruct(filter,'w,true) - docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist - docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x] --drop defaults - docSearch1(filter,genSearchTran docSearchAlist) - -docSearch1(filter,doc) == - docSearchAlist := searchDropUnexposedLines doc - count := searchCount docSearchAlist - count = 0 => emptySearchPage('"entry",filter,true) - count = 1 => showNamedConstruct(or/[x for x in docSearchAlist | CADR x],1) - prefix := pluralSay(count,'"entry matches",'"entries match") - emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] - header := [:prefix,'" ",:emfilter] - page := htInitPage(header,nil) - htpSetProperty(page,'docSearchAlist,docSearchAlist) - htpSetProperty(page,'regSearchAlist,nil) - htpSetProperty(page,'filter,filter) - dbSayItems(['"\newline Documentation Summary: ",count],'"mention",'"mentions",'" of {\em ",filter,'"}") - for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt '"\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,true,kind,i,'showDoc) - htShowPageStar() - -removeSurroundingStars filter == - key := STRINGIMAGE filter - if key.0 = char '_* then key := SUBSTRING(key,1,nil) - if key.(max := MAXINDEX key) = char '_* then key := SUBSTRING(key,0,max) - key - -showNamedDoc([kind,:lines],index) == - dbGather(kind,lines,index - 1,true) - -sayDocMessage message == - htSay('"{\em ") - if message is [leftEnd,left,middle,right,rightEnd] then - htSay(leftEnd,left,'"}") - if left ^= '"" and left.(MAXINDEX left) = $blank then htBlank() - htSay middle - if right ^= '"" and right.0 = $blank then htBlank() - htSay('"{\em ",right,rightEnd) - else - htSay message - htSay ('"}") - -stripOffSegments(s,n) == - progress := true - while n > 0 and progress = true repeat - n := n - 1 - k := charPosition(char '_`,s,0) - new := SUBSTRING(s,k + 1,nil) - #new < #s => s := new - progress := false - n = 0 => s - nil - -replaceTicksBySpaces s == - n := -1 - max := MAXINDEX s - while (n := charPosition(char '_`,s,n + 1)) <= max repeat SETELT(s,n,char '_ ) - s - -checkFilter filter == - filter := STRINGIMAGE filter - filter = '"" => '"*" - trimString filter - -aSearch filter == --called from HD (man0.ht): general attribute search - null (filter := checkFilter filter) => nil --in case of filter error - dbSearch(grepConstruct(filter,'a),'"attribute",filter) - -oSearch filter == -- called from HD (man0.ht): operation search - opAlist := opPageFastPath filter => opPageFast opAlist - key := 'o - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => grepSearchQuery('"operation",[filter,key,'"operation",'oSearchGrep]) - oSearchGrep(filter,key,'"operation") - -oSearchGrep(filter,key,kind) == --called from grepSearchQuery/oSearch - dbSearch(grepConstruct(filter,'o),kind,filter) - -grepSearchQuery(kind,items) == - page := htInitPage('"Query Page",nil) - htpSetProperty(page,'items,items) - htQuery(['"{\em Do you want a list of {\em all} ",pluralize kind,'"?\vspace{1}}"],'grepSearchJump,true) - htShowPage() - -cSearch filter == --called from HD (man0.ht): category search - constructorSearch(checkFilter filter,'c,'"category") - -dSearch filter == --called from HD (man0.ht): domain search - constructorSearch(checkFilter filter,'d,'"domain") - -pSearch filter == --called from HD (man0.ht): package search - constructorSearch(checkFilter filter,'p,'"package") - -xSearch filter == --called from HD (man0.ht): default package search - constructorSearch(checkFilter filter,'x,'"default package") - -kSearch filter == --called from HD (man0.ht): constructor search (no defaults) - constructorSearch(checkFilter filter,'k,'"constructor") - -ySearch filter == --called from conPage: like kSearch but defaults included - constructorSearch(checkFilter filter,'y,'"constructor") - -constructorSearch(filter,key,kind) == - null filter => nil --in case of filter error - (parse := conSpecialString? filter) => conPage parse - pageName := LASSOC(DOWNCASE filter,'(("union" . DomainUnion)("record" . DomainRecord)("mapping" . DomainMapping) ("enumeration" . DomainEnumeration))) => - downlink pageName - name := (STRINGP filter => INTERN filter; filter) - if u := HGET($lowerCaseConTb,name) then filter := STRINGIMAGE first u - line := conPageFastPath DOWNCASE filter => - code := dbKind line - newkind := - code = char 'p => '"package" - code = char 'd => '"domain" - code = char 'c => '"category" - nil - kind = '"constructor" or kind = newkind => kPage line - page := htInitPage('"Query Page",nil) - htpSetProperty(page,'line,line) - message := - ['"{\em ",dbName line,'"} is not a {\em ",kind,'"} but a {\em ", - newkind,'"}. Would you like to view it?\vspace{1}"] - htQuery(message, 'grepConstructorSearch,true) - htShowPage() - filter = '"*" => grepSearchQuery(kind,[filter,key,kind,'constructorSearchGrep]) - constructorSearchGrep(filter,key,kind) - -grepConstructorSearch(htPage,yes) == kPage htpProperty(htPage,'line) - -conSpecialString?(filter,:options) == - secondTime := IFCAR options - parse := - words := string2Words filter is [s] => ncParseFromString s - and/[not MEMBER(x,'("and" "or" "not")) for x in words] => ncParseFromString filter - false - null parse => nil - form := conLowerCaseConTran parse - MEMQ(KAR form,'(and or not)) or CONTAINED("*",form) => nil - filter = '"Mapping" =>nil - u := kisValidType form => u - secondTime => false - u := "STRCONC"/[string2Constructor x for x in dbString2Words filter] - conSpecialString?(u, true) - -dbString2Words l == - i := 0 - [w while dbWordFrom(l,i) is [w,i]] - -$dbDelimiters := [char " " , char "(", char ")"] - -dbWordFrom(l,i) == - maxIndex := MAXINDEX l - while maxIndex >= i and l.i = char " " repeat i := i + 1 - if maxIndex >= i and MEMBER(l.i, $dbDelimiters) then return [l.i, i + 1] - k := or/[j for j in i..maxIndex | not MEMBER(l.j, $dbDelimiters)] or return nil - buf := '"" - while k <= maxIndex and not MEMBER(c := l.k, $dbDelimiters) repeat - ch := - c = char '__ => l.(k := 1+k) --this may exceed bounds - c - buf := STRCONC(buf,ch) - k := k + 1 - [buf,k] - -conLowerCaseConTran x == - IDENTP x => IFCAR HGET($lowerCaseConTb, x) or x - atom x => x - [conLowerCaseConTran y for y in x] - -string2Constructor x == - not STRINGP x => x - IFCAR HGET($lowerCaseConTb, INTERN DOWNCASE x) or x - -conLowerCaseConTranTryHarder x == - IDENTP x => IFCAR HGET($lowerCaseConTb,DOWNCASE x) or x - atom x => x - [conLowerCaseConTranTryHarder y for y in x] - -constructorSearchGrep(filter,key,kind) == - dbSearch(grepConstruct(filter,key),kind,filter) - -grepSearchJump(htPage,yes) == - [filter,key,kind,fn] := htpProperty(htPage,'items) - FUNCALL(fn,filter,key,kind) - ---======================================================================= --- Branch Functions After Database Search ---======================================================================= -dbSearch(lines,kind,filter) == --called by attribute, operation, constructor search - lines is ['error,:.] => bcErrorPage lines - null filter => nil --means filter error - lines is ['Abbreviations,:r] => dbSearchAbbrev(lines,kind,filter) - if MEMBER(kind,'("attribute" "operation")) then --should not be necessary!! - lines := dbScreenForDefaultFunctions lines - count := #lines - count = 0 => emptySearchPage(kind,filter) - MEMBER(kind,'("attribute" "operation")) => dbShowOperationLines(kind,lines) - dbShowConstructorLines lines - -dbSearchAbbrev([.,:conlist],kind,filter) == - null conlist => emptySearchPage('"abbreviation",filter) - kind := intern kind - if kind ^= 'constructor then - conlist := [x for x in conlist | LASSOC('kind,IFCDR IFCDR x) = kind] - conlist is [[nam,:.]] => conPage DOWNCASE nam - cAlist := [[con,:true] for con in conlist] - htPage := htInitPage('"",nil) - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,nil) - return dbShowCons(htPage,'names) - page := htInitPage([#conlist, - '" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil) - for [nam,abbr,:r] in conlist repeat - kind := LASSOC('kind,r) - htSay('"\newline{\em ",s := STRINGIMAGE abbr) - htSayStandard '"\tab{10}" - htSay '"}" - htSay kind - htSayStandard '"\tab{19}" - bcCon nam - htShowPage() - ---======================================================================= --- Selectable Search ---======================================================================= -detailedSearch(filter) == - page := htInitPage('"Detailed Search with Options",nil) - filter := escapeSpecialChars PNAME filter - bcHt '"Select what you want to search for, then click on {\em Search} below" - bcHt '"\newline{\it Note:} Logical searches using {\em and}, {\em or}, and {\em not} are not permitted here." - htSayHrule() - htMakePage '( - (text . "\newline") - (bcRadioButtons which - ( "\tab{3}{\em Operations}" - ((text . "\newline\space{3}") - (text . "name") (bcStrings (14 "*" opname EM)) - (text . " \#args") (bcStrings (1 "*" opnargs EM)) - (text . " signature") (bcStrings (14 "*" opsig EM)) - (text . "\vspace{1}\newline ")) - ops) - ( "\tab{3}{\em Attributes}" - ((text . "\newline\space{3}") - (text . "name") (bcStrings (14 "*" attrname EM)) - (text . " \#args ") (bcStrings (1 "*" attrnargs EM)) - (text . " arguments ")(bcStrings (14 "*" attrargs EM)) - (text . "\vspace{1}\newline ")) - attrs) - ( "\tab{3}{\em Constructors}" - ((text . "\tab{17}") - (bcButtons (1 cats)) (text . " {\em categories} ") - (bcButtons (1 doms)) (text . " {\em domains} ") - (bcButtons (1 paks)) (text . " {\em packages} ") - (bcButtons (1 defs)) (text . " {\em defaults} ") - (text . "\newline\tab{3}") - (text . "name") (bcStrings (14 "*" conname EM)) - (text . " \#args") (bcStrings (1 "*" connargs EM)) - (text . "signature") (bcStrings (14 "*" consig EM)) - (text . "\vspace{1}\newline ")) - cons) --- ( "\tab{3}{\em Documentation}" --- ((text . "\tab{26}key") --- (bcStrings (28 "*" docfilter EM))) --- doc) - ) - (text . "\vspace{1}\newline\center{ ") - (bcLinks ("\box{Search}" "" generalSearchDo NIL)) - (text . "}")) - htShowPage() - -generalSearchDo(htPage,flag) == ---$exposedOnlyIfTrue := (flag => 'T; nil) - $htPage := htPage - alist := htpInputAreaAlist htPage - which := htpButtonValue(htPage,'which) - selectors := - which = 'cons => '(conname connargs consig) - which = 'ops => '(opname opnargs opsig) - '(attrname attrnargs attrargs) - name := generalSearchString(htPage,selectors.0) - nargs:= generalSearchString(htPage,selectors.1) - npat := standardizeSignature generalSearchString(htPage,selectors.2) - kindCode := - which = 'ops => char 'o - which = 'attrs => char 'a - acc := '"" - if htButtonOn?(htPage,'cats) then acc := STRCONC(char 'c,acc) - if htButtonOn?(htPage,'doms) then acc := STRCONC(char 'd,acc) - if htButtonOn?(htPage,'paks) then acc := STRCONC(char 'p,acc) - if htButtonOn?(htPage,'defs) then acc := STRCONC(char 'x,acc) - n := #acc - n = 0 or n = 4 => '"[cdpx]" - n = 1 => acc - STRCONC(char '_[,acc,char '_]) - form := mkDetailedGrepPattern(kindCode,name,nargs,npat) - lines := applyGrep(form,'libdb) ---lines := dbReadLines resultFile - if MEMQ(which,'(ops attrs)) then lines := dbScreenForDefaultFunctions lines - kind := - which = 'cons => - n = 1 => - htButtonOn?(htPage,'cats) => '"category" - htButtonOn?(htPage,'doms) => '"domain" - htButtonOn?(htPage,'paks) => '"package" - '"default package" - '"constructor" - which = 'ops => '"operation" - '"attribute" - null lines => emptySearchPage(kind,nil) - dbSearch(lines,kind,'"filter") - -generalSearchString(htPage,sel) == - string := htpLabelInputString(htPage,sel) - string = '"" => '"*" - string - -htButtonOn?(htPage,key) == - LASSOC(key,htpInputAreaAlist htPage) is [a,:.] and a = '" t" - -mkDetailedGrepPattern(kind,name,nargs,argOrSig) == main where - main == - nottick := '"[^`]" - name := replaceGrepStar name - firstPart := - $saturn => STRCONC(char '_^,name) - STRCONC(char '_^,kind,name) - nargsPart := replaceGrepStar nargs - exposedPart := char '_. --always get exposed/unexposed - patPart := replaceGrepStar argOrSig - simp STRCONC(conc(firstPart,conc(nargsPart,conc(exposedPart, patPart))),$tick) - conc(a,b) == - b = '"[^`]*" or b = char '_. => a - STRCONC(a,$tick,b) - simp a == - m := MAXINDEX a - m > 6 and a.(m-5) = char '_[ and a.(m-4) = char '_^ - and a.(m-3) = $tick and a.(m-2) = char '_] - and a.(m-1) = char '_* and a.m = $tick - => simp SUBSTRING(a,0,m-5) - a - -replaceGrepStar s == - s = "" => s - final := MAXINDEX s - i := charPosition(char '_*,s,0) - i > final => s - STRCONC(SUBSTRING(s,0,i),'"[^`]*",replaceGrepStar SUBSTRING(s,i + 1,nil)) - -standardizeSignature(s) == underscoreDollars - s.0 = char '_( => s - k := STRPOS('"->",s,0,nil) or return s --will fail except perhaps on constants - s.(k - 1) = char '_) => STRCONC(char '_(,s) - STRCONC(char '_(,SUBSTRING(s,0,k),char '_),SUBSTRING(s,k,nil)) - -underscoreDollars(s) == fn(s,0,MAXINDEX s) where - fn(s,i,n) == - i > n => '"" - (m := charPosition(char '_$,s,i)) > n => SUBSTRING(s,i,nil) - STRCONC(SUBSTRING(s,i,m - i),'"___$",fn(s,m + 1,n)) - ---======================================================================= --- Code dependent on $saturn ---======================================================================= - -obey x == - $saturn and not $aixTestSaturn => nil - OBEY x - ---======================================================================= --- I/O Code ---======================================================================= - -getTempPath kind == - pathname := mkGrepFile kind - obey STRCONC('"rm -f ", pathname) - pathname - -dbWriteLines(s, :options) == - pathname := IFCAR options or getTempPath 'source - $outStream: local := MAKE_-OUTSTREAM pathname - for x in s repeat writedb x - SHUT $outStream - pathname - -dbReadLines target == --AIX only--called by grepFile - instream := OPEN target - lines := [READLINE instream while not EOFP instream] - CLOSE instream - lines - -dbGetCommentOrigin line == ---Given a comment line in comdb, returns line in libdb pointing to it ---Comment lines have format [dcpxoa]xxxxxx`ccccc... where ---x's give pointer into libdb, c's are comments - firstPart := dbPart(line,1,-1) - key := INTERN SUBSTRING(firstPart,0,1) --extract this and throw away - address := SUBSTRING(firstPart, 1, nil) --address in libdb - instream := OPEN grepSource key --this always returns libdb now - FILE_-POSITION(instream,PARSE_-INTEGER address) - line := READLINE instream - CLOSE instream - line - -grepSource key == - key = 'libdb => STRCONC($SPADROOT,'"/algebra/libdb.text") - key = 'gloss => STRCONC($SPADROOT,'"/algebra/glosskey.text") - key = $localLibdb => $localLibdb - mkGrepTextfile - MEMQ(key, '(_. a c d k o p x)) => 'libdb - 'comdb - -mkGrepTextfile s == STRCONC($SPADROOT,"/algebra/", STRINGIMAGE s, '".text") - -mkGrepFile s == --called to generate a path name for a temporary grep file - prefix := - $standard or $aixTestSaturn => '"/tmp/" - STRCONC($SPADROOT,'"/algebra/") - suffix := getEnv '"SPADNUM" - STRCONC(prefix, PNAME s,'".txt.", suffix) - ---======================================================================= --- Grepping Code ---======================================================================= - -grepFile(pattern,:options) == - key := (x := IFCAR options => (options := rest options; x); nil) - source := grepSource key - lines := - not PROBE_-FILE source => NIL - $standard or $aixTestSaturn => - -----AIX Version---------- - target := getTempPath 'target - casepart := - MEMQ('iv,options)=> '"-vi" - '"-i" - command := STRCONC('"grep ",casepart,'" _'",pattern,'"_' ",source) - obey - MEMBER(key,'(a o c d p x)) => - STRCONC(command, '" | sed 's/~/", STRINGIMAGE key, '"/' > ", target) - STRCONC(command, '" > ",target) - dbReadLines target - ----Windows Version------ - invert? := MEMQ('iv, options) - GREP(source, pattern, false, not invert?) - dbUnpatchLines lines - -dbUnpatchLines lines == --concatenate long lines together, skip blank lines - dash := char '_- - acc := nil - while lines is [line, :lines] repeat - #line = 0 => 'skip --skip blank lines - acc := - line.0 = dash and line.1 = dash => - [STRCONC(first acc,SUBSTRING(line,2,nil)),:rest acc] - [line,:acc] - -- following call to NREVERSE needed to keep lines properly sorted - NREVERSE acc ------> added by BMT 12/95 - ---====================> WAS b-util.boot <================================ - ---======================================================================= --- AXIOM Browser --- Initial entry is from man0.ht page to one of these functions: --- kSearch (cSearch, dSearch, or pSearch), for constructors --- oSearch, for operations --- aSearch, for attributes --- aokSearch, for general search --- docSearch, for documentation search --- genSearch, for complete search ---======================================================================= - -browserAutoloadOnceTrigger() == nil - -----------------------> Global Variables <----------------------- -$includeUnexposed? := true --default setting -$tick := char '_` --field separator for database files -$charUnderscore := ('__) --needed because of parser bug -$wild1 := '"[^`]*" --phrase used to convert keys to grep strings -$browseCountThreshold := 10 --the maximum number of names that will display - --on a general search -$opDescriptionThreshold := 4 --if <= 4 operations with unique name, give desc - --otherwise, give signatures -$browseMixedCase := true --distinquish case in the browser? -$docTable := nil --cache for documentation table -$conArgstrings := nil --bound by conPage so that kPage - --will display arguments if given -$conformsAreDomains := false --are all arguments of a constructor given? -$returnNowhereFromGoGet := false --special branch out for goget for browser -$dbDataFunctionAlist := nil --set by dbGatherData -$domain := nil --bound in koOps -$infovec := nil --bound in koOps -$predvec := nil --bound in koOps -$exposedOnlyIfTrue := nil --see repeatSearch, dbShowOps, dbShowCon -$bcMultipleNames := nil --see bcNameConTable -$bcConformBincount := nil --see bcConform1 -$docTableHash := MAKE_-HASHTABLE 'EQUAL --see dbExpandOpAlistIfNecessary -$groupChoice := nil --see dbShowOperationsFromConform - -------------------> Initial Settings <--------------------- -$pmFilterDelimiters := [char '_(,char '_),char '_ ] -$dbKindAlist := - [[char 'a,:'"attribute"],[char 'o,:'"operation"], - [char 'd,:'"domain"],[char 'p,:'"package"], - [char 'c,:'"category"],[char 'x,:'"default_ package"]] -$OpViewTable := '( - (names "Name" "Names" dbShowOpNames) - (documentation "Name" "Names" dbShowOpDocumentation) - (domains "Domain" "Domains" dbShowOpDomains) - (signatures "Signature" "Signatures" dbShowOpSignatures) - (parameters "Form" "Forms" dbShowOpParameters) - (origins "Origin" "Origins" dbShowOpOrigins) - (implementation nil "Implementation Domains" dbShowOpImplementations) - (conditions "Condition" "Conditions" dbShowOpConditions)) - -bcBlankLine() == bcHt '"\vspace{1}\newline " - -pluralize k == - k = '"child" => '"children" - k = '"category" => '"categories" - k = '"entry" => '"entries" - STRCONC(k,'"s") - -capitalize s == - LASSOC(s,'( - ("domain" . "Domain") - ("category" . "Category") - ("package" . "Package") - ("default package" . "Default Package"))) or - res := COPY_-SEQ s - SETELT(res,0,UPCASE res.0) - res - -escapeSpecialIds u == --very expensive function - x := LASSOC(u,$htCharAlist) => [x] - #u = 1 => - member(u, $htSpecialChars) => [CONCAT('"_\", u)] - [u] - c := char u.0 - or/[c = char y for y in $htSpecialChars] => - [CONCAT('"_\",u)] - [u] - -escapeString com == --this makes changes on single comment lines --- was htexCom - look := 0 - while look repeat - look >= SIZE com => look := [] - - - look := STRPOSL ('"${}#%", com, look, []) - if look then - com := RPLACSTR (com,look,0,'"\") --note RPLACSTR copies!!! - look := look + 2 - com - -htPred2English(x,:options) == - $emList :local := IFCAR options --list of identifiers to be emphasised - $precList: local := '((OR 10 . "or") (AND 9 . "and") - (_< 5) (_<_= 5) (_> 5) (_>_= 5) (_= 5) (_^_= 5) (or 10) (and 9)) - fn(x,100) where - fn(x,prec) == - x is [op,:l] => - LASSOC(op,$precList) is [iprec,:rename] => - if iprec > prec then htSay '"(" - fn(first l,iprec) - for y in rest l repeat - htSay('" ",rename or op,'" ") - fn(y,iprec) - if iprec > prec then htSay '")" - if prec < 5 then htSay '"(" - gn(x,op,l,prec) - if prec < 5 then htSay '")" - x = 'etc => htSay '"..." - IDENTP x and not MEMQ(x,$emList) => htSay escapeSpecialIds PNAME x - htSay form2HtString(x,$emList) - gn(x,op,l,prec) == - MEMQ(op,'(NOT not)) => - htSay('"not ") - fn(first l,0) - op = 'HasCategory => - bcConform(first l,$emList) - htSay('" has ") - bcConform(CADADR l,$emList) - op = 'HasAttribute => - bcConform(first l,$emList) - htSay('" has ") - fnAttr CADADR l - MEMQ(op,'(has ofCategory)) => - bcConform(first l,$emList) - htSay('" has ") - [a,b] := l - b is ['ATTRIBUTE,c] and not constructor? c => fnAttr c - bcConform(b, $emList) - bcConform(x,$emList) - fnAttr c == - s := form2HtString c - MEMBER(s,$emList) => htSay('"{\em ",s,'"}") - satDownLink(s, ['"(|aPage| '|",s,'"|)"]) - -unMkEvalable u == - u is ['QUOTE,a] => a - u is ['LIST,:r] => [unMkEvalable x for x in r] - u - -lisp2HT u == ['"_'",:fn u] where fn u == - IDENTP u => escapeSpecialIds PNAME u - STRINGP u => escapeString u - ATOM u => systemError() - ['"_(",:"append"/[fn x for x in u],'")"] - -args2HtString(x,:options) == - null x => '"" - emList := IFCAR options - SUBSTRING(form2HtString(['f,:x],emList),1,nil) - -quickForm2HtString(x) == - atom x => STRINGIMAGE x - form2HtString x - -form2HtString(x,:options) == - $emList:local := IFCAR options --list of atoms to be emphasized - $brief: local := IFCAR IFCDR options --see dbShowOperationsFromConform (lib11) - fn(x) where - fn x == - atom x => - MEMQ(x,$FormalMapVariableList) => STRCONC('"\",STRINGIMAGE x) - u := escapeSpecialChars STRINGIMAGE x - MEMQ(x,$emList) => STRCONC('"{\em ",u,'"}") - STRINGP x => STRCONC('"_"",u,'"_"") - u - first x = 'QUOTE => STRCONC('"'",sexpr2HtString first rest x) - first x = ":" => STRCONC(fn first rest x,'": ",fn first rest rest x) - first x = 'Mapping => - STRCONC(fnTail(rest rest x,'"()"),'"->",fn first rest x) - first x = 'construct => fnTail(rest x,'"[]") - tail := fnTail(rest x,'"()") - head := fn first x --- $brief and #head + #tail > 35 => STRCONC(head,'"(...)") - STRCONC(head,tail) - fnTail(x,str) == - null x => '"" - STRCONC(str . 0,fn first x,fnTailTail rest x,str . 1) - fnTailTail x == - null x => '"" - STRCONC('",",fn first x,fnTailTail rest x) - -sexpr2HtString x == - atom x => form2HtString x - STRCONC('"(",fn x,'")") where fn x == - r := rest x - suffix := - null r => '"" - atom r => STRCONC('" . ",form2HtString rest x) - STRCONC('" ",fn r) - STRCONC(sexpr2HtString first x,suffix) - -form2LispString(x) == - atom x => - x = '_$ => '"__$" - MEMQ(x,$FormalMapVariableList) => STRCONC(STRINGIMAGE '__, STRINGIMAGE x) - STRINGP x => STRCONC('"_"",STRINGIMAGE x,'"_"") - STRINGIMAGE x - x is ['QUOTE,a] => STRCONC('"'",sexpr2LispString a) - x is [":",a,b] => STRCONC(form2LispString a,'":",form2LispString b) - first x = 'Mapping => - null rest (r := rest x) => STRCONC('"()->",form2LispString first r) - STRCONC(args2LispString rest r,'"->",form2LispString first r) - STRCONC(form2LispString first x,args2LispString rest x) - -sexpr2LispString x == - atom x => form2LispString x - STRCONC('"(",fn x,'")") where fn x == - r := rest x - suffix := - null r => '"" - atom r => STRCONC('" . ",form2LispString rest x) - STRCONC('" ",fn r) - STRCONC(sexpr2HtString first x,suffix) - -args2LispString x == - null x => '"" - STRCONC('"(",form2LispString first x,fnTailTail rest x,'")") where - fnTailTail x == - null x => '"" - STRCONC('",",form2LispString first x,fnTailTail rest x) - -dbConstructorKind x == - target := CADAR GETDATABASE(x,'CONSTRUCTORMODEMAP) - target = '(Category) => 'category - target is ['CATEGORY,'package,:.] => 'package - HGET($defaultPackageNamesHT,x) => 'default_ package - 'domain - -getConstructorForm name == - name = 'Union => '(Union (_: a A) (_: b B)) - name = 'UntaggedUnion => '(Union A B) - name = 'Record => '(Record (_: a A) (_: b B)) - name = 'Mapping => '(Mapping T S) - name = 'Enumeration => '(Enumeration a b) - GETDATABASE(name,'CONSTRUCTORFORM) - -getConstructorArgs conname == CDR getConstructorForm conname - -htSay(x,:options) == ---if x = $charEscape then x := $charNewline else ---if x = $stringEscape then x := $stringNewline - bcHt x - for y in options repeat bcHt y - -bcComments(comments,:options) == - italics? := not IFCAR options - STRINGP comments => - comments = '"" => nil - htSay('"\newline ") - if italics? then htSay '"{\em " - htSay comments - if italics? then htSay '"}" - null comments => nil - htSay('"\newline ") - if italics? then htSay "{\em " - htSay first comments - for x in rest comments repeat htSay('" ",x) - if italics? then htSay '"}" - -bcConform(form,:options) == - $italics? : local := IFCAR options - $italicHead? : local := IFCAR IFCDR options - bcConform1 form - -bcConform1 form == main where ------------------> OBSELETE - main == - form is ['ifp,form1,:pred] => - hd form1 - bcPred pred - hd form - hd form == - atom form => - not MEMQ(form,'(Mapping Union Record)) and null constructor? form => - s := STRINGIMAGE form - (s.0 = char '_#) and (n := POSN1(form, $FormalFunctionParameterList)) => - htSay form2HtString ($FormalMapVariableList . n) - htSay form - s := STRINGIMAGE form - $italicHead? => htSayItalics s - $bcMultipleNames => - satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"]) - satTypeDownLink(s, ["(|conPage| '|",s,'"|)"]) - (head := QCAR form) = 'QUOTE => - htSay('"'") - hd CADR form - head = 'SIGNATURE => - htSay(CADR form,'": ") - mapping CADDR form - head = 'Mapping and rest form => rest form => mapping rest form - head = ":" => - hd CADR form - htSay '": " - hd CADDR form - QCDR form and dbEvalableConstructor? form - => bcConstructor(form,head) - hd head - null (r := QCDR form) => nil - tl QCDR form - mapping [target,:source] == - tuple source - bcHt - $saturn => '" {\ttrarrow} " - '" -> " - hd target - tuple u == - null u => bcHt '"()" - null rest u => hd u - bcHt '"(" - hd first u - for x in rest u repeat - bcHt '"," - hd x - bcHt '")" - tl u == - bcHt '"(" - firstTime := true - for x in u repeat - if not firstTime then bcHt '"," - firstTime := false - hd x - bcHt '")" - say x == - if $italics? then bcHt '"{\em " - if x = 'etc then x := '"..." - bcHt escapeSpecialIds STRINGIMAGE x - if $italics? then bcHt '"}" - -bcConstructor(form is [op,:arglist],cname) == --called only when $conformsAreDomains - htSayList dbConformGen form - -htSayList u == - for x in u repeat htSay x - -conform2HtString form == - for u in form2String form repeat - htSay u - -dbEvalableConstructor? form == ---form is constructor form; either ---(a) all arguments are specified or (b) none are specified - form is [op,:argl] => - null argl => true - op = 'QUOTE => 'T --is a domain valued object - and/[dbEvalableConstructor? x for x in argl] - INTEGERP form => true - false - -htSayItalics s == htSay('"{\em ",s,'"}") - -bcCon(name,:options) == - argString := IFCAR options or '"" - s := STRINGIMAGE name - bcStar name - htSayConstructorName(s,s) - htSay argString - -bcAbb(name,abb) == - s := STRINGIMAGE name - a := STRINGIMAGE abb - bcStar name - htSayConstructorName(a,s) - -bcStar name == - if $includeUnexposed? and not isExposedConstructor name then htSayUnexposed() - -bcStarSpace name == - null $includeUnexposed? => nil - not isExposedConstructor name => htSayUnexposed() - htBlank() - -bcStarSpaceOp(op,exposed?) == - null $includeUnexposed? => nil - not exposed? => - htSayUnexposed() - if op.0 = char '_* then htSay '" " - htBlank() - -bcStarConform form == - bcStar opOf form - bcConform form - -dbSourceFile name == - u:= GETDATABASE(name,'SOURCEFILE) - null u => '"" - n := PATHNAME_-NAME u - t := PATHNAME_-TYPE u - STRCONC(n,'".",t) - -asharpConstructorName? name == - u:= GETDATABASE(name,'SOURCEFILE) - u and PATHNAME_-TYPE u = '"as" - -asharpConstructors() == - [x for x in allConstructors() | not asharpConstructorName? x] - -extractFileNameFromPath s == fn(s,0,#s) where - fn(s,i,m) == - k := charPosition(char '_/,s,i) - k = m => SUBSTRING(s,i,nil) - fn(s,k + 1,m) - -bcOpTable(u,fn) == - htBeginTable() - firstTime := true - for op in u for i in 0.. repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - htMakePage [['bcLinks,[escapeSpecialChars STRINGIMAGE opOf op,'"",fn,i]]] - htSay '"}" - htEndTable() - -bcNameConTable u == - $bcMultipleNames: local := (#u ^= 1) - bcConTable REMDUP u - -- bcConTable u - -bcConTable u == - htBeginTable() - firstTime := true - for con in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - bcStarSpace opOf con - bcConform con - htSay '"}" - htEndTable() - -bcAbbTable u == - htBeginTable() - firstTime := true - for x in REMDUP u repeat --allow x to be NIL meaning "no abbreviation" - -- for x in u repeat --allow x to be NIL meaning "no abbreviation" - if firstTime then firstTime := false - else htSaySaturn '"&" - if x is [con,abb,:.] then - htSay '"{" - bcAbb(con,abb) - htSay '"}" - htEndTable() - -bcConPredTable(u,conname,:options) == - italicList := IFCAR options - htBeginTable() - firstTime := true - for [conform,:pred] in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - bcStarSpace opOf conform - form := - atom conform => getConstructorForm conform - conform - bcConform(form,italicList) - if extractHasArgs pred is [arglist,:pred] then - htSay('" {\em of} ") - bcConform([conname,:arglist],italicList,true) - if pred ^= 'etc then bcPred(pred,italicList) - htSay '"}" - htEndTable() - -bcPred(pred,:options) == - pred = '"" or pred = true or null pred => 'skip - italicList := IFCAR options - if not IFCAR IFCDR options then htSay '" {\em if} " - htPred2English(pred,italicList) - -extractHasArgs pred == - x := find pred or return nil where find x == - x is [op,:argl] => - op = 'hasArgs => x - MEMQ(op,'(AND OR NOT)) => or/[find y for y in argl] - nil - nil - [rest x,:simpBool SUBST('T,x,pred)] - -splitConTable cons == - uncond := cond := nil - for (pair := [con,:pred]) in cons repeat - null pred => 'skip - pred = 'T or pred is ['hasArgs,:.] => uncond := [pair,:uncond] - cond := [pair,:cond] - [NREVERSE uncond,:NREVERSE cond] - -bcNameTable(u,fn,:option) == --option if * prefix - htSay '"\newline" - htBeginTable() - firstTime := true - for x in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - if IFCAR option then bcStar x - htMakePage [['bcLinks,[s := escapeSpecialChars STRINGIMAGE x,'"",fn,s]]] - htSay '"}" - htEndTable() - -bcNameCountTable(u,fn,gn,:options) == - linkFunction := - IFCAR options => 'bcLispLinks - 'bcLinks - htSay '"\newline" - htBeginTable() - firstTime := true - for i in 0.. for x in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - htMakePage [[linkFunction,[FUNCALL(fn,x),'"",gn,i]]] - htSay '"}" - htEndTable() - -dbSayItemsItalics(:u) == - htSay '"{\em " - APPLY(function dbSayItems,u) - htSay '"}" - -dbSayItems(countOrPrefix,singular,plural,:options) == - bcHt '"\newline " - count := - countOrPrefix is [:prefix,c] => - htSay prefix - c - countOrPrefix - if count = 0 then htSay('"No ",singular) - else if count = 1 then htSay('"1 ",singular) - else htSay(count,'" ",plural) - for x in options repeat bcHt x - if count ^= 0 then bcHt '":" - -dbBasicConstructor? conname == MEMBER(dbSourceFile conname,'("catdef" "coerce")) - -nothingFoundPage(:options) == - htInitPage('"Sorry, no match found",nil) - htShowPage() - -htCopyProplist htPage == [[x,:y] for [x,:y] in htpPropertyList htPage] - -dbInfovec name == - 'category = GETDATABASE(name,'CONSTRUCTORKIND) => nil - GETDATABASE(name, 'ASHARP?) => nil - loadLibIfNotLoaded(name) - u := GET(name,'infovec) => u - -emptySearchPage(kind,filter,:options) == - skipNamePart := IFCAR options - heading := ['"No ",capitalize kind,'" Found"] - htInitPage(heading,nil) - exposePart := - null $includeUnexposed? => '"{\em exposed} " - '"" - htSay('"\vspace{1}\newline\centerline{There is no ",exposePart,kind,'" matching pattern}\newline\centerline{{\em ") - if filter then htPred2English filter - htSay '"}}" - htShowPage() - -isLoaded? conform == GET(constructor? opOf conform,'LOADED) - -string2Integer s == - and/[DIGIT_-CHAR_-P (s.i) for i in 0..MAXINDEX s] => PARSE_-INTEGER s - nil - -dbGetInputString htPage == - s := htpLabelInputString(htPage,'filter) - null s or s = '"" => '"*" - s - - - ---======================================================================= --- Error Pages ---======================================================================= -bcErrorPage u == - u is ['error,:r] => - htInitPage(first r,nil) - bcBlankLine() - for x in rest r repeat htSay x - htShowPage() - systemError '"Unexpected error message" - -errorPage(htPage,[heading,kind,:info]) == - kind = 'invalidType => kInvalidTypePage first info - if heading = 'error then htInitPage('"Error",nil) else - htInitPage(heading,nil) - bcBlankLine() - for x in info repeat htSay x - htShowPage() - -htErrorStar() == - errorPage(nil,['"{\em *} not a valid search string",nil,'"\vspace{3}\centerline{{\em *} is not a valid search string for a general search}\centerline{\em {it would match everything!}}"]) - -htQueryPage(htPage,heading,message,query,fn) == - htInitPage(heading,nil) - htSay message - htQuery(query,fn) - htShowPage() - -htQuery(question,fn,:options) == - upLink? := IFCAR options - if question then - htSay('"\vspace{1}\centerline{") - htSay question - htSay('"}") - htSay('"\centerline{") - htMakePage [['bcLispLinks,['"\fbox{Yes}",'"",fn,'yes]]] - htBlank 4 - if upLink? - then htSay('"\downlink{\fbox{No}}{UpPage}") - else htMakePage [['bcLispLinks,['"\fbox{No}",'"",fn,'no]]] - htSay('"}") - -kInvalidTypePage form == - htInitPage('"Error",nil) - bcBlankLine() - htSay('"\centerline{You gave an invalid type:}\newline\centerline{{\sf ") - htSay(form2HtString form,'"}}") - htShowPage() - -dbNotAvailablePage(:options) == - htInitPage('"Missing Page",nil) - bcBlankLine() - htSay(IFCAR options or '"\centerline{This page is not available yet}") - htShowPage() - ---======================================================================= --- Utility Functions for Manipulating Browse Datalines ---======================================================================= -dbpHasDefaultCategory? s == #s > 1 and s.1 = char 'x --s is part 3 of line - -dbKind line == line.0 - -dbKindString kind == LASSOC(kind,$dbKindAlist) - -dbName line == escapeString SUBSTRING(line,1,charPosition($tick,line,1) - 1) - -dbAttr line == STRCONC(dbName line,escapeString dbPart(line,4,0)) - -dbPart(line,n,k) == --returns part n of line (n=1,..) beginning in column k - n = 1 => SUBSTRING(line,k + 1,charPosition($tick,line,k + 1) - k - 1) - dbPart(line,n - 1,charPosition($tick,line,k + 1)) - -dbXParts(line,n,m) == - [.,nargs,:r] := dbParts(line,n,m) - [dbKindString line.0,dbName line,PARSE_-INTEGER nargs,:r] - -dbParts(line,n,m) == --split line into n parts beginning in column m - n = 0 => nil - [SUBSTRING(line,m,-m + (k := charPosition($tick,line,m))), - :dbParts(line,n - 1,k + 1)] - -dbConname(line) == dbPart(line,5,1) - -dbComments line == dbReadComments(string2Integer dbPart(line,7,1)) - -dbNewConname(line) == --dbName line unless kind is 'a or 'o => name in 5th pos. - (kind := line.0) = char 'a or kind = char 'o => - conform := dbPart(line,5,1) - k := charPosition(char '_(,conform,1) - SUBSTRING(conform,1,k - 1) - dbName line - -dbTickIndex(line,n,k) == --returns index of nth tick in line starting at k - n = 1 => charPosition($tick,line,k) - dbTickIndex(line,n - 1,1 + charPosition($tick,line,k)) - -mySort u == listSort(function GLESSEQP,u) - ---====================> WAS b-prof.boot <================================ - ---============================================================================ --- Browser Code for Profiling ---============================================================================ -kciPage(htPage,junk) == - --info alist must have NEW format with [op,:sig] in its CAARs - which:= '"operation" - htpSetProperty(htPage,'which,which) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - heading := ['"Capsule Cross Reference for ",:htpProperty(htPage,'heading)] - page := htInitPage(heading,htCopyProplist htPage) - conname := opOf conform - htpSetProperty(page,'infoAlist,infoAlist := getInfoAlist conname) - dbGetExpandedOpAlist page --expand opAlist "in place" - opAlist := kciReduceOpAlist(htpProperty(page,'opAlist),infoAlist) - dbShowOperationsFromConform(page,which,opAlist) - -kciReduceOpAlist(opAlist,infoAlist) == ---count opAlist - res := [pair for [op,:items] in opAlist | pair] where pair == - u := LASSOC(op,infoAlist) => - y := [x for x in items - | x is [sig,:.] and or/[sig = sig1 for [sig1,:.] in u]] => [op,:y] - nil - nil - res - -displayInfoOp(htPage,infoAlist,op,sig) == - (sigAlist := LASSOC(op,infoAlist)) and (itemlist := LASSOC(sig,sigAlist)) => - dbShowInfoOp(htPage,op,sig,itemlist) - nil - -dbShowInfoOp(htPage,op,sig,alist) == - heading := htpProperty(htPage,'heading) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - opAlist := htpProperty(htPage,'opAlist) - conname := opOf conform - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - honestConform := - kind = 'category => - [INTERN STRCONC(PNAME conname,'"&"),"$",:CDR conform] - conform - faTypes := CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) - - conArgTypes := - SUBLISLIS(IFCDR conform,TAKE(#faTypes,$FormalMapVariableList),faTypes) - conform := htpProperty(htPage,'conform) - conname := opOf conform ---argTypes := REVERSE ASSOCRIGHT LASSOC('arguments,alist) ---sig := or/[sig for [sig,:.] in LASSOC(op,opAlist) | rest sig = argTypes] - ops := escapeSpecialChars STRINGIMAGE zeroOneConvert op - oppart := ['"{\em ", ops, '"}"] - head := - sig => [:oppart,'": ",:dbConformGen dbInfoSig sig] - oppart - heading := [:head,'" from {\sf ",form2HtString conform,'"}"] - for u in alist repeat - [x,:y] := u - x = 'locals => locals := y - x = 'arguments => arguments := y - fromAlist := [[x,:zeroOneConvertAlist y], :fromAlist] - fromAlist := - cons := args := nil - for (p := [x,:y]) in fromAlist repeat - x = $ => dollar := [[honestConform,:y]] - x = 'Rep => rep := [['Rep,:y]] - IDENTP x => args := [dbInfoFindCat(conform,conArgTypes,p), :args] - cons := [dbInfoTran(x,y), :cons] - [:mySort args, :dollar, :rep, :mySort cons] - sigAlist := LASSOC(op,opAlist) - item := or/[x for x in sigAlist | x is [sig1,:.] and sig1 = sig] or - systemError '"cannot find signature" - --item is [sig,pred,origin,exposeFlag,comments] - [sig,pred,origin,exposeFlag,doc] := item - htpSetProperty(htPage,'fromAlist,fromAlist) - htSayHline() - htSay('"\center{Cross Reference for definition of {\em ",ops,'"}}\beginmenu ") --- if arguments then --- htSay '"\item\menuitemstyle{}{\em arguments:}\newline" --- dbShowInfoList(arguments,0,false) - if locals then - htSay '"\item\menuitemstyle{}{\em local variables:}\newline" - dbShowInfoList(locals,8192,false) - bincount := 2 - for [con,:fns] in fromAlist repeat - htSay '"\item" - if IDENTP con then - htSay '"\menuitemstyle{} {\em calls to} " - if con ^= 'Rep then htSay '"{\em argument} " - htSay con - if and/[fn is ['origin,orig,.] and - (null origin and (origin := orig) or origin = orig) for fn in fns] then - htSay '" {\em of type} " - bcConform orig - buttonForOp := false - else - htMakePage [['bcLinks,['"\menuitemstyle{}",'"",'dbInfoChoose,bincount]]] - htSay '"{\em calls to} " - bcConform con - buttonForOp := true - htSay('":\newline ") - dbShowInfoList(fns, bincount * 8192,buttonForOp) - bincount := bincount + 1 - htSay '"\endmenu " - -dbShowInfoList(dataItems,count,buttonForOp?) == ---dataItems are [op,:sig] - single? := null rest dataItems - htSay '"\table{" - for item in dataItems repeat - [op,:sig] := - item is ['origin,.,s] => - buttonForOp? := true - s - item - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" - if count < 16384 or not buttonForOp? then - htSay [ops,'": "] - atom sig => bcConform sig - bcConform dbInfoSig sig - else - htMakePage [['bcLinks,[ops,'"",'dbInfoChooseSingle,count]]] - htSay '": " - if atom sig then htSay sig else - bcConform dbInfoSig sig - htSay '"}" - count := count + 1 - htSay '"} " - count - -dbInfoFindCat(conform,conArgTypes,u) == - [argName,:opSigList] := u - n := POSITION(argName,IFCDR conform) or systemError() - t := conArgTypes . n - [argName,:[dbInfoWrapOrigin(x,t) for x in opSigList]] - -dbInfoWrapOrigin(x, t) == - [op, :sig] := x - origin := dbInfoOrigin(op,sig,t) => ['origin, origin, x] - x - -dbInfoOrigin(op,sig,t) == - t is ['Join, :r] => or/[dbInfoOrigin(op,sig,x) for x in r] - t is ['CATEGORY,:.] => false - [sig = sig1 for [sig1,:.] in LASSOC(op, koOps(t,nil))] => t - false - -dbInfoTran(con,opSigList) == [con,:SUBST("$",con,mySort opSigList)] - -zeroOneConvertAlist u == [[zeroOneConvert x,:y] for [x,:y] in u] - -dbInfoChoose(htPage,count) == - fromAlist := htpProperty(htPage,'fromAlist) - index := count - 2 - [con, :alist] := fromAlist.index - dbInfoChoose1(htPage,con,alist) - -dbInfoChooseSingle(htPage,count) == - fromAlist := htpProperty(htPage,'fromAlist) - [index, binkey] := DIVIDE(count, 8192) - [con, :alist] := fromAlist.(index - 2) - item := alist . binkey - alist := - item is ['origin,origin,s] => - con := origin - [s] - [item] - dbInfoChoose1(htPage,con,alist) - -dbInfoChoose1(htPage,con,alist) == - $conform: local := con - opAlist := [pair for x in koOps(con,nil) | pair:=dbInfoSigMatch(x,alist)] - page := htInitPage(nil,nil) - htpSetProperty(page,'conform,con) - htpSetProperty(page,'kind,PNAME GETDATABASE(opOf con,'CONSTRUCTORKIND)) - dbShowOperationsFromConform(page,'"operation",opAlist) - -dbInfoSigMatch(x,alist) == - [op,:sigAlist] := x - candidates := [sig for [op1,:sig] in alist | op1 = op] or return nil - sigs := [s for s in sigAlist | "or"/[first s = s1 for s1 in candidates] or - (s2 := SUBST($conform,"$",s)) and "or"/[first s2 = s1 for s1 in candidates]] - sigs and [op,:sigs] - - -dbInfoSig sig == - null rest sig => first sig - ['Mapping,:sig] - ---============================================================================ --- Code to Expand opAlist ---============================================================================ -dbGetExpandedOpAlist htPage == - expand := htpProperty(htPage,'expandOperations) - if expand ^= 'fullyExpanded then - if null expand then htpSetProperty(htPage,'expandOperations,'lists) - opAlist := koOps(htpProperty(htPage,'conform),nil) - htpSetProperty(htPage,'opAlist,opAlist) - dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",false,false) - htpProperty(htPage,'opAlist) - ---============================================================================ --- Get Info File Alist ---============================================================================ -hasNewInfoAlist conname == - (u := getInfoAlist conname) and hasNewInfoText u - -hasNewInfoText u == - and/[ATOM op and and/[item is [sig,:alist] and - null sig or null atom sig and null atom alist for item in items] for [op,:items] in u] - -getInfoAlist conname == - cat? := GETDATABASE(conname,'CONSTRUCTORKIND) = 'category - if cat? then conname := INTERN STRCONC(STRINGIMAGE conname,'"&") - abb := constructor? conname or return '"not a constructor" - fs := STRCONC(PNAME abb,'".nrlib/info") - inStream := - PROBE_-FILE fs => OPEN fs - filename := STRCONC('"/spad/int/algebra/",PNAME abb,'".nrlib/info") - PROBE_-FILE filename => OPEN filename - return nil - alist := mySort READ inStream - if cat? then - [.,dollarName,:.] := GETDATABASE(conname,'CONSTRUCTORFORM) - alist := SUBST("$",dollarName,alist) - alist - - ---====================> WAS b-saturn.boot <================================ --- New file as of 6/95 -$aixTestSaturn := false ---These will be set in patches.lisp: ---$saturn := false --true to write SATURN output to $browserOutputStream ---$standard:= true --true to write browser output on AIX -$saturnAmpersand := '"\&\&" -$saturnFileNumber --true to write DOS files for Thinkpad (testing only) - := false -$kPageSaturnArguments := nil --bound by $kPageSaturn -$atLeastOneUnexposed := false -$saturnContextMenuLines := nil -$saturnContextMenuIndex := 0 -$saturnMacros := '( - "\def\unixcommand#1#2{{\em #1}}"_ - "\def\lispFunctionLink#1#2{\lispLink[d]{#1}{{\bf #2}}}"_ - "\def\lispTypeLink#1#2{\lispLink[d]{#1}{{\sf #2}}}"_ - "\def\menuitemstyle{\menubutton}"_ - "\def\browseTitle#1{\windowTitle{#1}\section{#1}}"_ - "\def\ttrarrow{$\rightarrow$}"_ - "\def\spadtype#1{\lispLink[d]{\verb!(|spadtype| '|#1|)!}{\sf #1}}"_ - "\def\spad#1{{\em #1}}"_ - "\def\spadfun#1{{\em #1}}"_ -) -$FormalFunctionParameterList := '(_#_#1 _#_#2 _#_#3 _#_#4 _#_#5 _#_#6 _#_#7 _#_#8 _#_#9 _#_#10 _#_#11 _#_#12 _#_#13 _#_#14 _#_#15) - -on() == - $saturn := true - $standard := false -off()== - $saturn := false - $standard := true - ---======================================================================= --- Function for testing SATURN output ---======================================================================= --- protectedEVAL x == --- $saturn => --- protectedEVAL0(x, true, false) --- if $aixTestSaturn then protectedEVAL0(x, false, true) --- protectedEVAL1 x --- ---protectedEVAL0(x, $saturn, $standard) == --- protectedEVAL1 x --- ---protectedEVAL1 x == --- error := true --- val := NIL --- UNWIND_-PROTECT((val := saturnEVAL x; error := NIL), --- error => (resetStackLimits(); sendHTErrorSignal())) --- val --- ---saturnEVAL x == --- fn := --- $aixTestSaturn => '"/tmp/sat.text" --- '"/windows/temp/browser.text" --- $saturn => --- saturnEvalToFile(x, fn) --- OBEY '"cat /tmp/sat.text" --- EVAL x - - ---======================================================================= --- Functions to write DOS files to disk ---======================================================================= -ts(command) == - $saturn := true - $saturnFileNumber := false - $standard := false - saturnEvalToFile(command, '"/tmp/sat.text") - -ut() == - $saturn := false - $standard := true - 'done - -onDisk() == - $saturnFileNumber := 1 - obey '"dosdir" - -offDisk() == - $saturnFileNumber := false - -page() == - $standard => $curPage - $saturnPage ---======================================================================= --- Functions that affect $saturnPage ---======================================================================= - ---------------------> OLD DEFINITION (override in br-util.boot.pamphlet) -htSay(x,:options) == --say for possibly both $saturn and standard code - htSayBind(x, options) - -htSayCold x == - htSay '"\lispLink{}{" - htSay x - htSay '"}" - -htSayIfStandard(x, :options) == --do only for $standard - $standard => htSayBind(x,options) - -htSayStandard(x, :options) == --do AT MOST for $standard - $saturn: local := nil - htSayBind(x, options) - -htSaySaturn(x, :options) == --do AT MOST for $saturn - $standard: local := nil - htSayBind(x, options) - -htSayBind(x, options) == - bcHt x - for y in options repeat bcHt y - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -bcHt line == - $newPage => --this path affects both saturn and old lines - text := - PAIRP line => [['text, :line]] - STRINGP line => line - [['text, line]] - if $saturn then htpAddToPageDescription($saturnPage, text) - if $standard then htpAddToPageDescription($curPage, text) - PAIRP line => - $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) - $htLineList := [basicStringize line, :$htLineList] - ---======================================================================= --- New issueHT ---======================================================================= - ---------------------> NEW DEFINITION (see ht-util.boot.pamphlet) -htShowPage() == --- show the page which has been computed - htSayStandard '"\endscroll" - htShowPageNoScroll() - -------------------> NEW DEFINITION (see ht-util.boot.pamphlet) -htShowPageNoScroll() == --- show the page which has been computed - htSayStandard '"\autobuttons" - if $standard then - htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) - if $saturn then - htpSetPageDescription($saturnPage, nreverse htpPageDescription $saturnPage) - $newPage := false - ---------------------- - if $standard then - $htLineList := nil - htMakePage htpPageDescription $curPage - if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) - issueHTStandard line - ---------------------- - if $saturn then - $htLineList := nil - htMakePage htpPageDescription $saturnPage - if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) - issueHTSaturn line - ---------------------- - endHTPage() - ---------------------> NEW DEFINITION <-------------------------- -issueHTSaturn line == --called by htMakePageNoScroll and htMakeErrorPage - if $saturn then - $marg : local := 0 - $linelength: local := 80 - writeSaturn '"\inputonce{/doc/browser/browmacs.tex}" - writeSaturnPrefix() - writeSaturn(line) - writeSaturnSuffix() - if $saturnFileNumber then - fn := STRCONC('"sat", STRINGIMAGE $saturnFileNumber, '".tex") - obey STRCONC('"doswrite -a saturn.tex ",fn, '".tex") - $saturnFileNumber := $saturnFileNumber + 1 - -writeSaturnPrefix() == - $saturnContextMenuLines => - index := - STRINGIMAGE ($saturnContextMenuIndex := $saturnContextMenuIndex + 1) - writeSaturnLines - ['"\newmenu{BCM", index, - '"}{",:nreverse $saturnContextMenuLines, - '"}\usemenu{BCM", index,'"}{\vbox{"] - -writeSaturnSuffix() == - $saturnContextMenuLines => saturnPRINTEXP '"}}" - -issueHTStandard line == --called by htMakePageNoScroll and htMakeErrorPage - if $standard then - --unescapeStringsInForm line - sockSendInt($MenuServer, $SendLine) - sockSendString($MenuServer, line) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htMakeErrorPage htPage == - $newPage := false - $htLineList := nil - if $standard then $curPage := htPage - if $saturn then $saturnPage := htPage - htMakePage htpPageDescription htPage - line := APPLY(function CONCAT, nreverse $htLineList) - issueHT line - endHTPage() - -writeSaturnLines lines == - for line in lines repeat - if line ^= '"" and line.0 = char '_\ then saturnTERPRI() - saturnPRINTEXP line - -writeSaturn(line) == - k := 0 - n := MAXINDEX line - while --advance k if true - k > n => false - line.k ^= char '_\ => true - code := isBreakSegment?(line, k + 1,n) => false - true - repeat (k := k + 1) - k > n => writeSaturnPrint(line) - segment := SUBSTRING(line,0,k) - writeSaturnPrint(segment) - code = 1 => - writeSaturnPrint('"\\") - writeSaturn SUBSTRING(line,k + 2, nil) - code = 2 => - writeSaturnPrint('" &") - writeSaturn SUBSTRING(line,k + 4, nil) - code = 3 => - writeSaturnPrint('"\item") - writeSaturn SUBSTRING(line,k + 5,nil) - code = 4 => - writeSaturnPrint('"\newline") - writeSaturn SUBSTRING(line,k + 8,nil) - code = 5 => - writeSaturnPrint('"\table{") - $marg := $marg + 3 - writeSaturnTable SUBSTRING(line,k + 7,nil) - code = 6 => - i := charPosition(char '_},line,k + 4) - tabCode := SUBSTRING(line,k, i - k + 1) - writeSaturnPrint tabCode - line := SUBSTRING(line,i + 1, nil) - writeSaturn line - code = 7 => - saturnTERPRI() - writeSaturn SUBSTRING(line, k + 2,nil) - code = 8 => - i := - substring?('"\beginmenu", line,k) => k + 9 - substring?('"\beginscroll",line,k) => k + 11 - charPosition(char '_},line,k) - if char '_[ = line.(i + 1) then - i := charPosition(char '_], line, i + 2) - beginCode := SUBSTRING(line,k, i - k + 1) - writeSaturnPrint(beginCode) - line := SUBSTRING(line,i + 1,nil) - writeSaturn line - code = 9 => - i := - substring?('"\endmenu",line,k) => k + 7 - substring?('"\endscroll",line,k) => k + 9 - charPosition(char '_},line,k) - endCode := SUBSTRING(line,k, i - k + 1) - writeSaturnPrint(endCode) - line := SUBSTRING(line,i + 1,nil) - $marg := $marg - 3 - writeSaturn line - systemError code - -isBreakSegment?(line, k, n) == - k > n => nil - char2 := line . k - char2 = (char '_\) => 1 - char2 = (char '_&) => - substring?('"&\&", line, k) => 2 - nil - char2 = char 'i => - substring?('"item",line,k) => 3 - nil - char2 = char 'n => - substring?('"newline",line,k) => 4 - nil - char2 = char 't => - (k := k + 2) > n => nil - line.(k - 1) = char 'a and line.k = char 'b => - (k := k + 1) > n => nil - line.k = char "{" => 6 - substring?('"table",line,k - 3) => 5 - nil - char2 = (char '_!) => 7 - char2 = char 'b => - substring?('"begin",line,k) => 8 - nil - char2 = (char 'e) => - substring?('"end",line,k) => 9 - nil - nil - -writeSaturnPrint s == - for i in 0..($marg - 1) repeat saturnPRINTEXP '" " - saturnPRINTEXP s - saturnTERPRI() - -saturnPRINTEXP s == - $browserOutputStream => PRINTEXP(s,$browserOutputStream) - PRINTEXP s - -saturnTERPRI() == - $browserOutputStream => TERPRI($browserOutputStream) - TERPRI() - -writeSaturnTable line == - open := charPosition(char '"_{",line,0) - close:= charPosition(char '"_}",line,0) - open < close => - close := findBalancingBrace(line,open + 1,MAXINDEX line,0) or error '"no balancing brace" - writeSaturnPrint SUBSTRING(line,0,close + 1) - writeSaturnTable SUBSTRING(line,close + 1,nil) - $marg := $marg - 3 - writeSaturnPrint SUBSTRING(line,0,close + 1) - writeSaturn SUBSTRING(line, close + 1,nil) - -findBalancingBrace(s,k,n,level) == - k > n => nil - c := s . k - c = char '_{ => findBalancingBrace(s, k + 1, n, level + 1) - c = char '_} => - level = 0 => k - findBalancingBrace(s, k + 1, n, level - 1) - findBalancingBrace(s, k + 1, n, level) - ---======================================================================= --- htMakePage and friends ---======================================================================= -htMakePageStandard itemList == - $saturn => nil - htMakePage itemList - -htMakePageSaturn itemList == - $standard => nil - htMakePage itemList - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htMakePage itemList == - if $newPage then - if $saturn then htpAddToPageDescription($saturnPage, saturnTran itemList) - if $standard then htpAddToPageDescription($curPage, itemList) - htMakePage1 itemList - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htMakePage1 itemList == --- make a page given the description in itemList - for u in itemList repeat - itemType := 'text - items := - STRINGP u => u - ATOM u => STRINGIMAGE u - STRINGP first u => u - u is ['text, :s] => s - itemType := first u - rest u - itemType = 'text => iht items --- $saturn => bcHt items --- $standard => iht items - itemType = 'lispLinks => htLispLinks items - itemType = 'lispmemoLinks => htLispMemoLinks items - itemType = 'bcLinks => htBcLinks items ---> - itemType = 'bcLinksNS => htBcLinks(items,true) - itemType = 'bcLispLinks => htBcLispLinks items ---> - itemType = 'radioButtons => htRadioButtons items - itemType = 'bcRadioButtons => htBcRadioButtons items - itemType = 'inputStrings => htInputStrings items - itemType = 'domainConditions => htProcessDomainConditions items - itemType = 'bcStrings => htProcessBcStrings items - itemType = 'toggleButtons => htProcessToggleButtons items - itemType = 'bcButtons => htProcessBcButtons items - itemType = 'doneButton => htProcessDoneButton items - itemType = 'doitButton => htProcessDoitButton items - systemError '"unexpected branch" - -saturnTran x == - x is [[kind, [s1, s2, :callTail]]] and MEMQ(kind,'(bcLinks bcLispLinks)) => - text := saturnTranText s2 - fs := getCallBackFn callTail - y := isMenuItemStyle? s1 => ----> y is text for button in 2nd column - t1 := mkDocLink(fs, mkMenuButton()) - y = '"" => - s2 = '"" => t1 - mkTabularItem [t1, text] - t2 := mkDocLink(fs, y) - mkTabularItem [t1, t2, text] - t := mkDocLink(fs, s1) - [:t, :text] - x is [['text,:r],:.] => r - error nil - -mkBold s == - secondPart := - atom s => [s, '"}"] - [:s, '"}"] - ['"{\bf ", :secondPart] - -mkMenuButton() == [menuButton()] - -menuButton() == '"\menuitemstyle{}" --- Saturn must translate \menuitemstyle ==> {\menuButton} - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) ---replaces htMakeButton -getCallBackFn form == - func := mkCurryFun(first form, rest form) - STRCONC('"(|htDoneButton| '|", func, '"| ",htpName page(), '")") - -mkDocLink(code,s) == - if atom code then code := [code] - if atom s then s := [s] - ['"\lispLink[d]{\verb!", :code, '"!}{", :s, '"}"] - -saturnTranText x == - STRINGP x => [unTab x] - null x => nil - r is [s,fn,:.] and s = '"\unixcommand{" => ['"{\it ",s,'".spad}"] - x is [['text, :s],:r] => unTab [:s, :saturnTranText r] - error nil - -isMenuItemStyle? s == - 15 = STRING_<('"\menuitemstyle{", s) => SUBSTRING(s,15,(MAXINDEX s) - 15) - nil - -getCallBack callTail == - LASSOC(callTail, $callTailList) or - callTail is [fn] => callTail - error nil - ---======================================================================= --- Redefinitions from hypertex.boot ---======================================================================= ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -endHTPage() == - $standard => sockSendInt($MenuServer, $EndOfPage) - nil - ---======================================================================= --- Redefinitions from ht-util.boot ---======================================================================= -htSayHrule() == bcHt - $saturn => '"\hrule{}\newline{}" - '"\horizontalline{}\newline{}" - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htpAddInputAreaProp(htPage, label, prop) == -------------> Add STRINGIMAGE - SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htpSetLabelInputString(htPage, label, val) == -------------> Add STRINGIMAGE --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 0, STRINGIMAGE val) - nil - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htDoneButton(func, htPage, :optionalArgs) == -------> Handle argument values passed from page if present - if optionalArgs then - htpSetInputAreaAlist(htPage,CAR optionalArgs) - typeCheckInputAreas htPage => - htMakeErrorPage htPage - NULL FBOUNDP func => - systemError ['"unknown function", func] - FUNCALL(SYMBOL_-FUNCTION func, htPage) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htBcLinks(links,:options) == - skipStateInfo? := IFCAR options - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - link := - $saturn => '"\lispLink[d]" - '"\lispdownlink" - htMakeButton(link,message, - mkCurryFun(func, value),skipStateInfo?) - bcIssueHt info - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htBcLispLinks links == - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - link := - $saturn => '"\lispLink[n]" - '"\lisplink" - htMakeButton(link ,message, mkCurryFun(func, value)) - bcIssueHt info - -htMakeButton(htCommand, message, func,:options) == - $saturn => htMakeButtonSaturn(htCommand, message, func, options) - skipStateInfo? := IFCAR options - iht [htCommand, '"{"] - bcIssueHt message - skipStateInfo? => - iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] - iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] - for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat - iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] - if type = 'string then - iht ['"_"\stringvalue{", id, '"}_""] - else - iht ['"_"\boxvalue{", id, '"}_""] - iht '") " - iht [htpName $curPage, '"))}"] - -htMakeButtonSaturn(htCommand, message, func,options) == - skipStateInfo? := IFCAR options - iht htCommand - skipStateInfo? => - iht ['"{\verb!(|htDoneButton| '|", func, '"| ",htpName page(), '")!}{"] - bcIssueHt message - iht '"}" - iht ['"{\verb!(|htDoneButton| '|", func, '"| "] - if $kPageSaturnArguments then - iht '"(PROGN " - for id in $kPageSaturnArguments for var in $PatternVariableList repeat - iht ['"(|htpSetLabelInputString| ", htpName page(), '"'|", var, '"| "] - iht ["'|!\", id, '"\verb!|"] - iht '")" - iht htpName $saturnPage - iht '")" - else - iht htpName $saturnPage - iht '")!}{" - bcIssueHt message - iht '"}" - -htpAddToPageDescription(htPage, pageDescrip) == - newDescript := - STRINGP pageDescrip => [pageDescrip, :ELT(htPage, 7)] - nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7)) - SETELT(htPage, 7, newDescript) - - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htProcessBcStrings strings == - for [numChars, default, stringName, spadType, :filter] in strings repeat - mess2 := '"" - if NULL LASSOC(stringName, htpInputAreaAlist page()) then - setUpDefault(stringName, ['string, default, spadType, filter]) - if htpLabelErrorMsg(page(), stringName) then - iht ['"\centerline{{\em ", htpLabelErrorMsg(page(), stringName), '"}}"] - mess2 := CONCAT(mess2, bcSadFaces()) - htpSetLabelErrorMsg(page(), stringName, nil) - iht ['"\inputstring{", stringName, '"}{", - numChars, '"}{", htpLabelDefault(page(),stringName), '"} ", mess2] - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -setUpDefault(name, props) == - htpAddInputAreaProp(page(), name, props) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htInitPage(title, propList) == --- start defining a hyperTeX page - htInitPageNoScroll(propList, title) - htSayStandard '"\beginscroll " - page() - ---------------------> NEW DEFINITION <-------------------------- -htInitPageNoScroll(propList, :options) == ---start defining a hyperTeX page - $atLeastOneUnexposed := nil --reset every time a new page is initialized - $saturnContextMenuLines := nil - title := IFCAR options - $curPage := - $standard => htpMakeEmptyPage(propList) - nil - if $saturn then $saturnPage := htpMakeEmptyPage(propList) - $newPage := true - $htLineList := nil - if title then - if $standard then htSayStandard ['"\begin{page}{", htpName $curPage, '"}{"] - htSaySaturn '"\browseTitle{" - htSay title - htSaySaturn '"}" - htSayStandard '"} " - page() ---------------------> NEW DEFINITION <-------------------------- -htInitPageNoHeading(propList) == ---start defining a hyperTeX page - $curPage := - $standard => htpMakeEmptyPage(propList) - if $saturn then $saturnPage := htpMakeEmptyPage(propList) - $newPage := true - $htLineList := nil - page() - ---------------------> NEW DEFINITION <-------------------------- -htpMakeEmptyPage(propList,:options) == - name := IFCAR options or GENTEMP() - if not $saturn then - $activePageList := [name, :$activePageList] - SET(name, val := VECTOR(name, nil, nil, nil, nil, nil, propList, nil)) - val - ---======================================================================= --- Redefinitions from br-con.boot ---======================================================================= -kPage(line,:options) == --any cat, dom, package, default package ---constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) - parts := dbXParts(line,7,1) - [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts - form := IFCAR options - isFile := null kind - kind := kind or '"package" - RPLACA(parts,kind) - conform := mkConform(kind,name,args) - $kPageSaturnArguments: local := rest conform - conname := opOf conform - capitalKind := capitalize kind - signature := ncParseFromString sig - sourceFileName := dbSourceFile INTERN name - constrings := - KDR form => dbConformGenUnder form - [STRCONC(name,args)] - emString := ['"{\sf ",:constrings,'"}"] - heading := [capitalKind,'" ",:emString] - if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] - if name=abbrev then abbrev := asyAbbreviation(conname,nargs) - page := htInitPageNoScroll nil - htAddHeading heading - htSayStandard("\beginscroll ") - htpSetProperty(page,'argSublis,mkConArgSublis rest conform) - htpSetProperty(page,'isFile,true) - htpSetProperty(page,'parts,parts) - htpSetProperty(page,'heading,heading) - htpSetProperty(page,'kind,kind) - if asharpConstructorName? conname then - htpSetProperty(page,'isAsharpConstructor,true) - htpSetProperty(page,'conform,conform) - htpSetProperty(page,'signature,signature) - ---what follows is stuff from kiPage with domain = nil - $conformsAreDomains := nil - dbShowConsDoc1(page,conform,nil) - if kind ^= 'category and nargs > 0 then addParameterTemplates(page,conform) - if $atLeastOneUnexposed then htSay '"\newline{}{\em *} = unexposed" - htSayStandard("\endscroll ") - kPageContextMenu page - htShowPageNoScroll() - -kPageContextMenu page == - $saturn => kPageContextMenuSaturn page - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) - conform := htpProperty(page,'conform) - conname := opOf conform - htBeginTable() - htSay '"{" - htMakePage [['bcLinks,['Ancestors,'"",'kcaPage,nil]]] - htSay '"}{" - htMakePage [['bcLinks,['Attributes,'"",'koPage,'"attribute"]]] - if kind = '"category" then - htSay '"}{" - htMakePage [['bcLinks,['Children,'"",'kccPage,nil]]] - if not asharpConstructorName? conname then - htSay '"}{" - htMakePage [['bcLinks,['Dependents,'"",'kcdePage,nil]]] - if kind = '"category" then - htSay '"}{" - htMakePage [['bcLinks,['Descendents,'"",'kcdPage,nil]]] - if kind = '"category" then - htSay '"}{" - if not asharpConstructorName? conname then - htMakePage [['bcLinks,['Domains,'"",'kcdoPage,nil]]] - else htSay '"{\em Domains}" - htSay '"}{" - if kind ^= '"category" and (pathname := dbHasExamplePage conname) - then htMakePage [['bcLinks,['Examples,'"",'kxPage,pathname]]] - else htSay '"{\em Examples}" - htSay '"}{" - htMakePage [['bcLinks,['Exports,'"",'kePage,nil]]] - htSay '"}{" - htMakePage [['bcLinks,['Operations,'"",'koPage,'"operation"]]] - htSay '"}{" - htMakePage [['bcLinks,['Parents,'"",'kcpPage,'"operation"]]] - if kind ^= '"category" then - htSay '"}{" - if not asharpConstructorName? conname - then htMakePage [['bcLinks,["Search Path",'"",'ksPage,nil]]] - else htSay '"{\em Search Path}" - if kind ^= '"category" then - htSay '"}{" - htMakePage [['bcLinks,['Users,'"",'kcuPage,nil]]] - htSay '"}{" - htMakePage [['bcLinks,['Uses,'"",'kcnPage,nil]]] - htSay '"}" - if $standard then htEndTable() - -kPageContextMenuSaturn page == - $newPage : local := nil - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) - $htLineList : local := nil - conform := htpProperty(page,'conform) - conname := opOf conform - htMakePage [['bcLinks,['"\&Ancestors",'"",'kcaPage,nil]]] - htMakePage [['bcLinks,['"Attri\&butes",'"",'koPage,'"attribute"]]] - if kind = '"category" then - htMakePage [['bcLinks,['"\&Children",'"",'kccPage,nil]]] - if not asharpConstructorName? conname then - htMakePage [['bcLinks,['"\&Dependents",'"",'kcdePage,nil]]] - if kind = '"category" then - htMakePage [['bcLinks,['"Desce\&ndents",'"",'kcdPage,nil]]] - if kind = '"category" then - if not asharpConstructorName? conname then - htMakePage [['bcLinks,['"Do\&mains",'"",'kcdoPage,nil]]] - else htSayCold '"Do\&mains" - if kind ^= '"category" and (name := saturnHasExamplePage conname) - then saturnExampleLink name - else htSayCold '"E\&xamples" - htMakePage [['bcLinks,['"\&Exports",'"",'kePage,nil]]] - htMakePage [['bcLinks,['"\&Operations",'"",'koPage,'"operation"]]] - htMakePage [['bcLinks,['"\&Parents",'"",'kcpPage,'"operation"]]] - if not asharpConstructorName? conname - then htMakePage [['bcLinks,['"Search O\&rder",'"",'ksPage,nil]]] - else htSayCold '"Search Order" - if kind ^= '"category" or dbpHasDefaultCategory? xpart - then - htMakePage [['bcLinks,['"\&Users",'"",'kcuPage,nil]]] - htMakePage [['bcLinks,['"U\&ses",'"",'kcnPage,nil]]] - else - htSayCold '"\&Users" - htSayCold '"U\&ses" - $saturnContextMenuLines := $htLineList - -saturnExampleLink lname == - htSay '"\docLink{\csname " - htSay STRCONC(CAR(CDR(lname)), '"\endcsname}{E&xamples}") - -$exampleConstructors := nil - -saturnHasExamplePage conname == - if not $exampleConstructors then - $exampleConstructors := getSaturnExampleList() - ASSQ(conname, $exampleConstructors) - -getSaturnExampleList() == - file := STRCONC( getEnv('"AXIOM"), "/doc/axug/examples.lsp") - not PROBE_-FILE file => nil - fp := MAKE_-INSTREAM file - lst := READ fp - SHUT fp - lst - ---------------------> NEW DEFINITION (see br-con.boot.pamphlet) -dbPresentCons(htPage,kind,:exclusions) == - $saturn => dbPresentConsSaturn(htPage,kind,exclusions) - htpSetProperty(htPage,'exclusion,first exclusions) - cAlist := htpProperty(htPage,'cAlist) - empty? := null cAlist - one? := null CDR cAlist - one? := empty? or one? - exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 - star? := true --always include information on exposed/unexposed 4/92 - if $standard then htBeginTable() - htSay '"{" - if one? or MEMBER('abbrs,exclusions) - then htSay '"{\em Abbreviations}" - else htMakePage [['bcLispLinks,['"Abbreviations",'"",'dbShowCons,'abbrs]]] - htSay '"}{" - if one? or MEMBER('conditions,exclusions) or and/[CDR x = true for x in cAlist] - then htSay '"{\em Conditions}" - else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowCons,'conditions]]] - htSay '"}{" - if empty? or MEMBER('documentation,exclusions) - then htSay '"{\em Descriptions}" - else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowCons,'documentation]]] - htSay '"}{" - if one? or null CDR cAlist - then htSay '"{\em Filter}" - else htMakePage - [['bcLinks,['"Filter",'"",'htFilterPage,['dbShowCons,'filter]]]] - htSay '"}{" - if one? or MEMBER('kinds,exclusions) or kind ^= 'constructor - then htSay '"{\em Kinds}" - else htMakePage [['bcLispLinks,['"Kinds",'"",'dbShowCons,'kinds]]] - htSay '"}{" - if one? or MEMBER('names,exclusions) - then htSay '"{\em Names}" - else htMakePage [['bcLispLinks,['"Names",'"",'dbShowCons,'names]]] - htSay '"}{" - if one? or MEMBER('parameters,exclusions) or not or/[CDAR x for x in cAlist] - then htSay '"{\em Parameters}" - else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowCons,'parameters]]] - htSay '"}{" - if $exposedOnlyIfTrue - then - if one? - then htSay '"{\em Unexposed Also}" - else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowCons,'exposureOff]]] - else - if one? - then htSay '"{\em Exposed Only}" - else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowCons,'exposureOn]]] - htSay '"}" - if $standard then htEndTable() - -dbPresentConsSaturn(htPage,kind,exclusions) == - $htLineList : local := nil - $newPage : local := nil - htpSetProperty(htPage,'exclusion,first exclusions) - cAlist := htpProperty(htPage,'cAlist) - empty? := null cAlist - one? := null KDR cAlist - one? := empty? or one? - exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 - star? := true --always include information on exposed/unexposed 4/92 - if $standard then htBeginTable() - if one? or MEMBER('abbrs,exclusions) - then htSayCold '"\&Abbreviations" - else htMakePage [['bcLispLinks,['"\&Abbreviations",'"",'dbShowCons,'abbrs]]] - if one? or MEMBER('conditions,exclusions) or and/[CDR x = true for x in cAlist] - then htSayCold '"\&Conditions" - else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowCons,'conditions]]] - if empty? or MEMBER('documentation,exclusions) - then htSayCold '"\&Descriptions" - else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowCons,'documentation]]] - if one? or null CDR cAlist - then htSayCold '"\&Filter" - else htMakeSaturnFilterPage ['dbShowCons, 'filter] - if one? or MEMBER('kinds,exclusions) or kind ^= 'constructor - then htSayCold '"\&Kinds" - else htMakePage [['bcLispLinks,['"\&Kinds",'"",'dbShowCons,'kinds]]] - if one? or MEMBER('names,exclusions) - then htSayCold '"\&Names" - else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowCons,'names]]] - if one? or MEMBER('parameters,exclusions) or not or/[CDAR x for x in cAlist] - then htSayCold '"\&Parameters" - else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowCons,'parameters]]] - htSaySaturn '"\hrule" - if $exposedOnlyIfTrue - then - if one? then htSayCold '"\&Unexposed Also" - else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowCons,'exposureOff]]] - else - if one? then htSayCold '"\Exposed Only\&y" - else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowCons,'exposureOn]]] - if $standard then htEndTable() - $saturnContextMenuLines := $htLineList - -htFilterPage(htPage,args) == - htInitPage("Filter String",htCopyProplist htPage) - htSay "\centerline{Enter filter string (use {\em *} for wild card):}" - htSay '"\centerline{" - htMakePage [['bcStrings, [50,'"",'filter,'EM]]] - htSay '"}\vspace{1}\centerline{" - htMakePage [['bcLispLinks,['"\fbox{Filter}",'"",:args]]] - htSay '"}" - htShowPage() - -htMakeSaturnFilterPage [fn2Call,:args] == - htSay '"\inputboxLink[\lispLink[d]{\verb+(|" - htSay fn2Call - htSay '"| " - htSay htpName $saturnPage - for x in args repeat - htSay '" '|" - htSay x - htSay '"|" - htSay '" _"+_\FILTERSTRING\verb+_")+}{}]{\FILTERSTRING}{*}" - htSay '"{\centerline{Enter filter string (use {\em *} for wild card):}}" - htSay '"{Filter Page}{\&Filter}" - -dbShowConsKinds cAlist == - cats := doms := paks := defs := nil - for x in cAlist repeat - op := CAAR x - kind := dbConstructorKind op - kind = 'category => cats := [x,:cats] - kind = 'domain => doms := [x,:doms] - kind = 'package => paks := [x,:paks] - defs := [x,:defs] - lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] - htBeginMenu 'description - htSayStandard '"\indent{1}" - kinds := +/[1 for x in lists | #x > 0] - firstTime := true - for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat - if firstTime then firstTime := false - else htSaySaturn '"\\" - htSaySaturn '"\item[" - htSayStandard '"\item" - if kinds = 1 - then htSay menuButton() - else htMakePage - [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] - htSaySaturn '"]" - htSayStandard '"\tab{1}" - htSay('"{\em ",c := #x,'" ") - htSay(c > 1 => pluralize kind; kind) - htSay '":}" - htSaySaturn '"\\" - bcConTable REMDUP [CAAR y for y in x] - htEndMenu 'description - htSayStandard '"\indent{0}" - -addParameterTemplates(page, conform) == ----------------> from kPage <----------------------- - parlist := [STRINGIMAGE par for par in rest conform] - manuelsCode? := "MAX"/[#s for s in parlist] > 10 - w := (manuelsCode? => 55; 23) - htSaySaturn '"\colorbuttonbox{lightgray}{" - htSay '"Optional argument value" - htSay - CDR parlist => '"s:" - '":" - htSaySaturn '"}" - if CDR conform then htSaySaturn '"\newline{}" - htSaySaturn '"\begin{tabular}{p{.25in}l}" - firstTime := true - odd := false - argSublis := htpProperty(page,'argSublis) - for parname in $PatternVariableList for par in rest conform repeat - htSayStandard (odd or manuelsCode? => "\newline";"\tab{29}") - if firstTime then firstTime := false - else htSaySaturn '"\\" - odd := not odd - argstring := - $conArgstrings is [a,:r] => ($conArgstrings := r; a) - '"" - htMakePageStandard [['text,'"{\em ",par,'"} = "], - ['bcStrings,[w - #STRINGIMAGE par,argstring,parname,'EM]]] - if $saturn then - setUpDefault(parname, ['string, '"", 'EM, nil]) - htSaySaturn '"{\em " - htSaySaturn par - htSaySaturn '" = }" - htSaySaturnAmpersand() - htSaySaturn '"\colorbuttonbox{lightgray}{\inputbox[2.5in]{\" - htSaySaturn SUBLIS(argSublis,par) - htSaySaturn '"}{" - htSaySaturn argstring - htSaySaturn '"}}" - htEndTabular() - ---------------------> NEW DEFINITION (see br-con.boot.pamphlet) -kPageArgs([op,:args],[.,.,:source]) == - htSaySaturn '"\begin{tabular}{p{.25in}lp{0in}}" - firstTime := true - coSig := rest GETDATABASE(op,'COSIG) - for x in args for t in source for pred in coSig repeat - if firstTime then firstTime := false - else - htSaySaturn '"\\" - htSayStandard '", and" - htSayStandard '"\newline " - htSaySaturnAmpersand() - typeForm := (t is [":",.,t1] => t1; t) - if pred = true - then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] - else htSay('"{\em ",x,'"}") - htSayStandard( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ") - htSaySaturnAmpersand() - htSay - pred => '"a domain of category " - '"an element of the domain " - bcConform(typeForm,true) - htEndTabular() - ---======================================================================= --- Redefinitions from br-op1.boot ---======================================================================= ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -dbConform form == ---one button for the main constructor page of a type - $saturn => ["\lispLink[d]{\verb!(|conPage| '",:form2Fence dbOuttran form,'")!}{", - :form2StringList opOf form,"}"] - ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] - ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -htTab s == if $standard then htSayStandard ('"\tab{",s,'"}") - ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == - single? := null rest data - htBeginMenu 'description - bincount := 0 - for [thing,exposeFlag,:items] in data repeat - htSaySaturn '"\item[" - htSayStandard ('"\item") - if single? then htSay(menuButton()) - else - htMakePageStandard - [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] - button := mkButtonBox (1 + bincount) - htMakePageSaturn [['bcLinks,[button,'"",'dbShowOps,which,bincount]]] - htSaySaturn '"]" - htSay '"{\em " - htSay - thing = 'nowhere => '"implemented nowhere" - thing = 'constant => '"constant" - thing = '_$ => '"by the domain" - INTEGERP thing => '"unexported" - constructorIfTrue => - htSay word - atom thing => '" an unknown constructor" - '"" - atom thing => '"unconditional" - '"" - htSay '"}" - if null atom thing then - if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") - htSay '" " - FUNCALL(fn,thing) - htSay('":\newline ") - dbShowOpSigList(which,items,(1 + bincount) * 8192) - bincount := bincount + 1 - htEndMenu 'description - ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -dbPresentOps(htPage,which,:exclusions) == - $saturn => dbPresentOpsSaturn(htPage,which,exclusions) - asharp? := htpProperty(htPage,'isAsharpConstructor) - fromConPage? := (conname := opOf htpProperty(htPage,'conform)) - usage? := nil - star? := not fromConPage? or which = '"package operation" - implementation? := not asharp? and - $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? - rightmost? := star? or (implementation? and not $includeUnexposed?) - if INTEGERP first exclusions then exclusions := ['documentation] - htpSetProperty(htPage,'exclusion,first exclusions) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - empty? := null opAlist - one? := opAlist is [entry] and 2 = #entry - one? := empty? or one? - htBeginTable() - htSay '"{" - if one? or MEMBER('conditions,exclusions) - or (htpProperty(htPage,'condition?) = 'no) - then htSay '"{\em Conditions}" - else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowOps,which,'conditions]]] - htSay '"}{" - if empty? or MEMBER('documentation,exclusions) - then htSay '"{\em Descriptions}" - else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowOps,which,'documentation]]] - htSay '"}{" - if null IFCDR opAlist - then htSay '"{\em Filter}" - else htMakePage [['bcLinks,['"Filter ",'"",'htFilterPage,['dbShowOps,which,'filter]]]] - htSay '"}{" - if one? or MEMBER('names,exclusions) or null KDR opAlist - then htSay '"{\em Names}" - else htMakePage [['bcLispLinks,['"Names",'"",'dbShowOps,which,'names]]] - if not star? then - htSay '"}{" - if not implementation? or MEMBER('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - then htSay '"{\em Implementations}" - else htMakePage - [['bcLispLinks,['"Implementations",'"",'dbShowOps,which,'implementation]]] - htSay '"}{" - if one? or MEMBER('origins,exclusions) - then htSay '"{\em Origins}" - else htMakePage [['bcLispLinks,['"Origins",'"",'dbShowOps,which,'origins]]] - htSay '"}{" - if one? or MEMBER('parameters,exclusions) --also test for some parameter - or not dbDoesOneOpHaveParameters? opAlist - then htSay '"{\em Parameters}" - else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowOps,which,'parameters]]] - htSay '"}{" - if which ^= '"attribute" then - if one? or MEMBER('signatures,exclusions) - then htSay '"{\em Signatures}" - else htMakePage [['bcLispLinks,['"Signatures",'"",'dbShowOps,which,'signatures]]] - htSay '"}" - if star? then - htSay '"{" - if $exposedOnlyIfTrue - then if one? - then htSay '"{\em Unexposed Also}" - else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] - else if one? - then htSay '"{\em Exposed Only}" - else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowOps, which,'exposureOn]]] - htSay '"}" - htEndTable() - -dbPresentOpsSaturn(htPage,which,exclusions) == - $htLineList : local := nil - $newPage : local := nil - asharp? := htpProperty(htPage,'isAsharpConstructor) - fromConPage? := (conname := opOf htpProperty(htPage,'conform)) - usage? := nil - star? := not fromConPage? or which = '"package operation" - implementation? := not asharp? and - $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? - rightmost? := star? or (implementation? and not $includeUnexposed?) - if INTEGERP first exclusions then exclusions := ['documentation] - htpSetProperty(htPage,'exclusion,first exclusions) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - empty? := null opAlist - one? := opAlist is [entry] and 2 = #entry - one? := empty? or one? - if one? or MEMBER('conditions,exclusions) - or (htpProperty(htPage,'condition?) = 'no) - then htSayCold '"\&Conditions" - else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowOps,which,'conditions]]] - if empty? or MEMBER('documentation,exclusions) - then htSayCold '"\&Descriptions" - else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowOps,which,'documentation]]] - if null IFCDR opAlist - then htSayCold '"\&Filter" - else htMakeSaturnFilterPage ['dbShowOps, which, 'filter] - if not implementation? or MEMBER('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - then htSayCold '"\&Implementations" - else htMakePage - [['bcLispLinks,['"\&Implementations",'"",'dbShowOps,which,'implementation]]] - if one? or MEMBER('names,exclusions) or null KDR opAlist - then htSayCold '"\&Names" - else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowOps,which,'names]]] - if one? or MEMBER('origins,exclusions) - then htSayCold '"\&Origins" - else htMakePage [['bcLispLinks,['"\&Origins",'"",'dbShowOps,which,'origins]]] - if one? or MEMBER('parameters,exclusions) --also test for some parameter - or not dbDoesOneOpHaveParameters? opAlist - then htSayCold '"\&Parameters" - else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowOps,which,'parameters]]] - if which ^= '"attribute" then - if one? or MEMBER('signatures,exclusions) - then htSayCold '"\&Signatures" - else htMakePage [['bcLispLinks,['"\&Signatures",'"",'dbShowOps,which,'signatures]]] - if star? then - htSay '"\hrule" - if $exposedOnlyIfTrue - then if one? then htSayCold '"\&Unexposed Also" - else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] - else - if one? then htSayCold '"Exposed Onl\&y" - else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowOps,which,'exposureOn]]] - $saturnContextMenuLines := $htLineList - ---======================================================================= --- Redefinitions from br-search.boot ---======================================================================= ----------------------> OLD DEFINITION (override in br-search.boot.pamphlet) -htShowPageStar() == - $saturn => htShowPageStarSaturn() - htSayStandard '"\endscroll " - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] - else - htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] - htShowPageNoScroll() - -htShowPageStarSaturn() == - $newPage : local := nil - $htLineList : local := nil - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] - else - htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] - $saturnContextMenuLines := $htLineList - htShowPageNoScroll() - ---======================================================================= --- Redefinitions from br-op2.boot ---======================================================================= - ---------------> NEW DEFINITION (see br-op2.boot.pamphlet) -displayDomainOp(htPage,which,origin,op,sig,predicate, - doc,index,chooseFn,unexposed?,$generalSearch?) == - $chooseDownCaseOfType : local := true --see dbGetContrivedForm - $whereList : local := nil - $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) - $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) - $FunctionList:local := '(f g h d e F G H) - $DomainList: local := '(D R S E T A B C M N P Q U V W) - exactlyOneOpSig := null index - conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - or origin - if $generalSearch? then $DomainList := rest $DomainList - opform := - which = '"attribute" => - null sig => [op] - [op,sig] - which = '"constructor" => origin - dbGetDisplayFormForOp(op,sig,doc) - htSayStandard('"\newline") - ----------------------------------------------------------- - htSaySaturn '"\item[" - if exactlyOneOpSig - then htSay menuButton() - else htMakePage - [['bcLinks,[menuButton(),'"",chooseFn,which,index]]] - htSaySaturn '"]" - htSayStandard '"\tab{2}" - op := IFCAR opform - args := IFCDR opform - ops := escapeSpecialChars STRINGIMAGE op - n := #sig - do - n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") - n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") - if unexposed? and $includeUnexposed? then - htSayUnexposed() - htSay(ops) - predicate='ASCONST or GETDATABASE(op,'NILADIC) or MEMBER(op,'(0 1)) => 'skip - which = '"attribute" and null args => 'skip - htSay('"(") - if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") - for x in IFCDR args repeat - htSay('",{\em ",quickForm2HtString x,'"}") - htSay('")") - -----------prepare to print description--------------------- - constring := form2HtString conform - conname := first conform - $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" - or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) - $conlength : local := #constring - $conform : local := conform - $conargs : local := rest conform - if which = '"operation" then - $signature : local := - MEMQ(conname,$Primitives) => nil - CDAR getConstructorModemap conname - --RDJ: this next line is necessary until compiler bug is fixed - --that forgets to substitute #variables for t#variables; - --check the signature for SegmentExpansionCategory, e.g. - tvarlist := TAKE(# $conargs,$TriangleVariableList) - $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) - $sig := - which = '"attribute" or which = '"constructor" => sig - $conkind ^= '"package" => sig - symbolsUsed := [x for x in rest conform | IDENTP x] - $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) - getSubstSigIfPossible sig - ----------------------------------------------------------- - htSaySaturn '"\begin{tabular}{lp{0in}}" - ----------------------------------------------------------- - if MEMBER(which,'("operation" "constructor")) then - $displayReturnValue: local := nil - if args then - htSayStandard('"\newline\tab{2}{\em Arguments:}") - htSaySaturn '"{\em Arguments:}" - htSaySaturnAmpersand() - firstTime := true - coSig := KDR GETDATABASE(op,'COSIG) --check if op is constructor - for a in args for t in rest $sig repeat - if not firstTime then - htSaySaturn '"\\ " - htSaySaturnAmpersand() - firstTime := false - htSayIndentRel(15, true) - position := KAR relatives - relatives := KDR relatives - if KAR coSig and t ^= '(Type) - then htMakePage [['bcLinks,[a,'"",'kArgPage,a]]] - else htSay('"{\em ",form2HtString(a),'"}") - htSay ", " - coSig := KDR coSig - htSayValue t - htSayIndentRel(-15,true) - htSayStandard('"\newline ") - htSaySaturn '"\\" - if first $sig then - $displayReturnValue := true - htSayStandard('"\newline\tab{2}") - htSay '"{\em Returns:}" - htSaySaturnAmpersand() - htSayIndentRel(15, true) - htSayValue first $sig - htSayIndentRel(-15, true) - htSaySaturn '"\\" - ----------------------------------------------------------- - if origin and ($generalSearch? or origin ^= conform) and op^=opOf origin then - htSaySaturn '"{\em Origin:}" - htSaySaturnAmpersand() - htSayStandard('"\newline\tab{2}{\em Origin:}") - htSayIndentRel(15) - if not isExposedConstructor opOf origin and $includeUnexposed? - then htSayUnexposed() - bcConform(origin,true) - htSayIndentRel(-15) - htSaySaturn '"\\" - ----------------------------------------------------------- - if not MEMQ(predicate,'(T ASCONST)) then - pred := sublisFormal(KDR conform,predicate) - count := #pred - htSaySaturn '"{\em Conditions:}" - htSayStandard('"\newline\tab{2}{\em Conditions:}") - firstTime := true - for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat - if not firstTime then htSaySaturn '"\\" - htSayIndentRel(15,count > 1) - firstTime := false - htSaySaturnAmpersand() - bcPred(p,$conform,true) - htSayIndentRel(-15,count > 1) - htSayStandard('"\newline ") - htSaySaturn '"\\" - ----------------------------------------------------------- - if $whereList then - count := #$whereList - htSaySaturn '"{\em Where:}" - htSayStandard('"\newline\tab{2}{\em Where:}") - firstTime := true - if ASSOC("$",$whereList) then - htSayIndentRel(15,true) - htSaySaturnAmpersand() - htSayStandard '"{\em \$} is " - htSaySaturn '"{\em \%} is " - htSay - $conkind = '"category" => '"of category " - '"the domain " - bcConform(conform,true,true) - firstTime := false - htSayIndentRel(-15,true) - for [d,key,:t] in $whereList | d ^= "$" repeat - htSayIndentRel(15,count > 1) - if not firstTime then htSaySaturn '"\\ " - htSaySaturnAmpersand() - firstTime := false - htSay("{\em ",d,"} is ") - htSayConstructor(key,sublisFormal(KDR conform,t)) - htSayIndentRel(-15,count > 1) - htSaySaturn '"\\" - ----------------------------------------------------------- - if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then - htSaySaturn '"{\em Description:}" - htSaySaturnAmpersand() - htSayStandard('"\newline\tab{2}{\em Description:}") - htSayIndentRel(15) - if doc = $charFauxNewline then htSay $charNewline - else - ndoc:= - -- we are confused whether doc is a string or a list of strings - CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] - SUBSTITUTE($charNewline, $charFauxNewline,doc) - htSay ndoc --- htSaySaturn '"\\" - htSayIndentRel(-15) - --------> print abbr and source file for constructors <--------- - if which = '"constructor" then - if (abbr := GETDATABASE(conname,'ABBREVIATION)) then - htSaySaturn '"\\" - htSaySaturn '"{\em Abbreviation:}" - htSaySaturnAmpersand() - htSayStandard('"\tab{2}{\em Abbreviation:}") - htSayIndentRel(15) - htSay abbr - htSayIndentRel(-15) - htSayStandard('"\newline{}") - if ( $saturn and (link := saturnHasExamplePage conname)) then - htSaySaturn '"\\" - htSaySaturn '"{\em Examples:}" - htSaySaturnAmpersand() - htSayIndentRel(15) - htSay '"\spadref{" - htSay CAR(CDR(link)) - htSay '"}" - htSayIndentRel(-15) - htSayStandard('"\newline{}") - htSaySaturn '"\\" - htSaySaturn '"{\em Source File:}" - htSaySaturnAmpersand() - htSayStandard('"\tab{2}{\em Source File:}") - htSayIndentRel(15) - htSaySourceFile conname - htSayIndentRel(-15) - ------------------> remove profile printouts for now <------------------- - if $standard and - exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then - displayInfoOp(htPage,infoAlist,op,sig) - ----------------------------------------------------------- - htSaySaturn '"\end{tabular}" - -htSaySourceFile conname == - sourceFileName := (GETDATABASE(conname,'SOURCEFILE) or '"none") - filename := extractFileNameFromPath sourceFileName - htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", - sourceFileName, '" ", conname, '"}"]] - ---------------------> NEW DEFINITION (see br-op2.boot.pamphlet) -htSayIndentRel(n,:options) == - flag := IFCAR options - m := ABSVAL n - if flag then m := m + 2 - if $standard then htSayStandard - n > 0 => - flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] - ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] - n < 0 => ['"\indent{0}\newline "] - -htSayUnexposed() == - htSay '"{\em *}" - $atLeastOneUnexposed := true ---======================================================================= --- Page Operations ---======================================================================= - -htEndTabular() == - htSaySaturn '"\end{tabular}" - -htPopSaturn s == - pageDescription := ELT($saturnPage, 7) - pageDescription is [=s,:b] => SETELT($saturnPage, 7, CDR pageDescription) - nil - -htBeginTable() == - htSaySaturn '"\begin{dirlist}[lv]" - htSayStandard '"\table{" - -htEndTable() == - htSaySaturn '"\end{dirlist}" - htSayStandard '"}" - -htBeginMenu(kind,:options) == - skip := IFCAR options - if $saturn then - kind = 'description => htSaySaturn '"\begin{description}" - htSaySaturn '"\begin{tabular}" - htSaySaturn - kind = 3 => '"{llp{0in}}" - kind = 2 => '"{lp{0in}}" - error nil - null skip => htSayStandard '"\beginmenu " - nil - -htEndMenu(kind) == - if $saturn then - kind = 'description => htSaySaturn '"\end{description}" - htPopSaturn '"\\" - htSaySaturn '"\end{tabular}" - htSayStandard '"\endmenu " - -htSayConstructorName(nameShown, name) == - if $saturn then - code := ['"(|conPage| '|", name, '"|)"] - htSaySaturn mkDocLink(code,nameShown) - if $standard then - htSayStandard ["\lispdownlink{",nameShown,'"}{(|conPage| '|",name,'"|)}"] - ---------------------> NEW DEFINITION (see ht-util.boot.pamphlet) -htAddHeading(title) == - htNewPage title - page() - -------------> called by htAddHeading, htInitPageNoScroll <----------- -htNewPage title == - if $saturn then - htSaySaturn '"\browseTitle{" - htSaySaturn title - htSaySaturn '"}" - if $standard then htSayStandard('"\begin{page}{", htpName $curPage, '"}{") - htSayStandard title - htSayStandard '"}" - ---======================================================================= --- Utilities ---======================================================================= -mkTabularItem u == [:first u,:fn rest u] where fn x == - null x => nil - [$saturnAmpersand, x,:fn rest x] - -htSaySaturnAmpersand() == htSaySaturn $saturnAmpersand - -htBlank(:options) == - options is [n] => - htSaySaturn("STRCONC"/['"\phantom{*}" for i in 1..n]) - htSayStandard STRCONC('"\space{",STRINGIMAGE n,'"}") - htSaySaturn '"\phantom{*}" - htSayStandard '"\space{1}" - -unTab s == - STRINGP s => unTab1 s - atom s => s - [unTab1 first s, :rest s] - -unTab1 s == - STRING_<('"\tab{", s) = 5 and (k := charPosition(char '_}, s, 4)) => - SUBSTRING(s, k + 1, nil) - s - -satBreak() == - htSaySaturn '"\\ " - htSayStandard '"\item " - -htBigSkip() == - htSaySaturn '"\bigskip{}" - htSayStandard '"\vspace{1}\newline " - -htSaturnBreak() == htSaySaturn '"\!" - -satDownLink(s,code) == - htSaySaturn '"\lispFunctionLink{\verb!" - htSaySaturn code - htSaySaturn '"!}{" - htSaySaturn s - htSaySaturn '"}" - ------------------ - htSayStandard '"\lispdownlink{" - htSayStandard s - htSayStandard '"}{" - htSayStandard code - htSayStandard '"}" - -satTypeDownLink(s,code) == - htSaySaturn '"\lispLink[d]{\verb!" - htSaySaturn code - htSaySaturn '"!}{" - htSaySaturn s - htSaySaturn '"}" - ------------------ - htSayStandard '"\lispdownlink{" - htSayStandard s - htSayStandard '"}{" - htSayStandard code - htSayStandard '"}" - -mkButtonBox n == STRCONC('"\buttonbox{", STRINGIMAGE n, '"}") - ---======================================================================= --- Create separate databases for operations, constructors ---======================================================================= ------------> use br-data.boot definition ---dbSplitLibdb() == ---This function splits lidbd.text into files to make searching quicker. --- alibdb.text attributes --- clibdb.text categories --- dlibdb.text domains --- plibdb.text packages --- olibdb.text operations --- xlibdb.text default packages ---These files have the same format as the single file libdb.text did in old --- version: e.g. `````` --- for constructors where is a single character, one of acdopx --- (identifying it as an attribute, category, domain, operator, package, --- or default package), its name, number of arguments, whether exposed or --- unexposed, its signature (sometimes abbreviated), its arguments as given --- in the original definition, its abbreviation, and documentation. --- For example, domain Matrix has line "dMatrix`1`x``(R)`MATRIX`" --- where is "(Ring)->Join(MatrixCategory(R,Vector(R),Vector(R)),etc)". --- The comment field contains the character address of the comments --- for Matrix in file comdb.text. ---There is thus ONE file comdb.text for documentation of all structures --- (to facilitate a general search through all documentation) --- into for comments. The format of entries in comdb.text are lines with --- two fields of the form d`, where is the character --- address of the line "dMatrix`.." in dlibdb.text (the first character --- "d" tells which lidbdb file it comes from, the is the --- documentation for Matrix. ---NOTE: In each file, the first character, one of acdpox, is retained --- so that lines have the same format as the previous version of the browser --- (this minimized the number of lines of code that had to be changed from --- previous version of the browser). --- key := nil --dummy first key --- instream := MAKE_-INSTREAM '"libdb.text" --- comstream := MAKE_-OUTSTREAM '"comdb.text" --- PRINTEXP(0, comstream) --- PRINTEXP($tick,comstream) --- PRINTEXP('"", comstream) --- TERPRI(comstream) --- while not EOFP instream repeat --- line := READLINE instream --- comP := FILE_-POSITION comstream --- if key ^= line.0 then --- if outstream then SHUT outstream --- key := line . 0 --- outstream := MAKE_-OUTSTREAM STRCONC(STRINGIMAGE key,'"libdb.text") --- outP := FILE_-POSITION outstream --- [prefix,:comments] := dbSplit(line,6,1) --- PRINTEXP(prefix,outstream) --- PRINTEXP($tick ,outstream) --- null comments => --- PRINTEXP(0,outstream) --- TERPRI(outstream) --- PRINTEXP(comP,outstream) --- TERPRI(outstream) --- PRINTEXP(key, comstream) --identifies file the backpointer is to --- PRINTEXP(outP ,comstream) --- PRINTEXP($tick ,comstream) --- PRINTEXP(first comments,comstream) --- TERPRI(comstream) --- for c in rest comments repeat --- PRINTEXP(key, comstream) --identifies file the backpointer is to --- PRINTEXP(outP ,comstream) --- PRINTEXP($tick ,comstream) --- PRINTEXP(c, comstream) --- TERPRI(comstream) --- SHUT instream --- SHUT outstream --- SHUT comstream ---OBEY '"rm libdb.text" - -dbSort(x,y) == - sin := STRINGIMAGE x - sout:= STRINGIMAGE y - OBEY STRCONC('"sort -f _"",sin,'".text_" > _"", sout, '".text_"") - OBEY STRCONC('"rm ", sin, '".text") - - ---======================================================================= --- from define.boot ---======================================================================= -----------------------> (override in define.boot.pamphlet) -compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], - m,oldE,$prefix,$formalArgList) == - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local := nil - $op: local := nil - $functionStats: local:= [0,0] - $argumentConditionList: local := nil - $finalEnv: local := nil - --used by ReplaceExitEtc to get a common environment - $initCapsuleErrorCount: local:= #$semanticErrorStack - $insideCapsuleFunctionIfTrue: local:= true - $CapsuleModemapFrame: local:= e - $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) - $insideExpressionIfTrue: local:= true - $returnMode:= m - [$op,:argl]:= form - $form:= [$op,:argl] - argl:= stripOffArgumentConditions argl - $formalArgList:= [:argl,:$formalArgList] - - --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,first signature,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) - [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [first signature,:argModeList] - if null identSig then --make $op a local function - oldE := put($op,'mode,['Mapping,:signature'],oldE) - - --obtain target type if not given - if null first signature' then signature':= - identSig => identSig - getSignature($op,rest signature',e) or return nil - - --replace ##1,.. in signature by arguments --- pp signature' - signature':= SUBLISLIS(argl,$FormalFunctionParameterList,signature') --- pp '"------after----" --- pp signature' - e:= giveFormalParametersValues(argl,e) - - $signatureOfForm:= signature' --this global is bound in compCapsuleItems - $functionLocations := [[[$op,$signatureOfForm],:lineNumber], - :$functionLocations] - e:= addDomain(first signature',e) - e:= compArgumentConditions e - - if $profileCompiler then - for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) - - - --4. introduce needed domains into extendedEnv - for domain in signature' repeat e:= addDomain(domain,e) - - --6. compile body in environment with extended environment - rettype:= resolve(signature'.target,$returnMode) - - localOrExported := - null MEMBER($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local - 'exported - - --6a skip if compiling only certain items but not this one - -- could be moved closer to the top - formattedSig := formatUnabbreviated ['Mapping,:signature'] - $compileOnlyCertainItems and _ - not MEMBER($op, $compileOnlyCertainItems) => - sayBrightly ['" skipping ", localOrExported,:bright $op] - [nil,['Mapping,:signature'],oldE] - sayBrightly ['" compiling ",localOrExported, - :bright $op,'": ",:formattedSig] - - if $newComp = true then - wholeBody := ['DEF, form, signature', specialCases, body] - T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) - or [" ",rettype,e] - T := [T.expr.2.2, rettype, T.env] - if $newCompCompare=true then - oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] - SAY '"The old compiler generates:" - prTriple oldT - SAY '"The new compiler generates:" - prTriple T - else - T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] ---+ - NRTassignCapsuleFunctionSlot($op,signature') - if $newCompCompare=true then - SAY '"The old compiler generates:" - prTriple T --- A THROW to the above CATCH occurs if too many semantic errors occur --- see stackSemanticError - catchTag:= MKQ GENSYM() - fun:= - body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) - body':= addArgumentConditions(body',$op) - finalBody:= ["CATCH",catchTag,body'] - compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) - $functorStats:= addStats($functorStats,$functionStats) - - --- 7. give operator a 'value property - val:= [fun,signature',e] - [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) - ---from postpar ---------------------> NEW DEFINITION (override in postpar.boot.pamphlet) -postSignature ['Signature,op,sig] == - sig is ["->",:.] => - sig1:= postType sig - op:= postAtom (STRINGP op => INTERN op; op) - ["SIGNATURE",op,:removeSuperfluousMapping killColons postDoubleSharp sig1] - -postDoubleSharp sig == - sig is [['Mapping,target,:r]] => - -- replace #1,... by ##1,... - [['Mapping, SUBLISLIS($FormalFunctionParameterList, $FormalMapVariableList, target), - :r]] - sig - --- override in br-util.boot.pamphlet -bcConform1 form == main where - main == - form is ['ifp,form1,:pred] => - hd form1 - bcPred pred - hd form - hd form == - atom form => - not MEMQ(form,$Primitives) and null constructor? form => - s := STRINGIMAGE form - (s.0 = char '_#) => - (n := POSN1(form, $FormalFunctionParameterList)) => - htSay form2HtString ($FormalMapVariableList . n) - htSay '"\" - htSay form - htSay escapeSpecialChars STRINGIMAGE form - s := STRINGIMAGE form - $italicHead? => htSayItalics s - $bcMultipleNames => - satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"]) - satTypeDownLink(s, ["(|conPage| '|",s,'"|)"]) - (head := QCAR form) = 'QUOTE => - htSay('"'") - hd CADR form - head = 'SIGNATURE => - htSay(CADR form,'": ") - mapping CADDR form - head = 'Mapping and rest form => rest form => mapping rest form - head = ":" => - hd CADR form - htSay '": " - hd CADDR form - QCDR form and dbEvalableConstructor? form - => bcConstructor(form,head) - hd head - null (r := QCDR form) => nil - tl QCDR form - mapping [target,:source] == - tuple source - bcHt - $saturn => '" {\ttrarrow} " - '" -> " - hd target - tuple u == - null u => bcHt '"()" - null rest u => hd u - bcHt '"(" - hd first u - for x in rest u repeat - bcHt '"," - hd x - bcHt '")" - tl u == - bcHt '"(" - firstTime := true - for x in u repeat - if not firstTime then bcHt '"," - firstTime := false - hd x - bcHt '")" - say x == - if $italics? then bcHt '"{\em " - if x = 'etc then x := '"..." - bcHt escapeSpecialIds STRINGIMAGE x - if $italics? then bcHt '"}" - ---======================================================================= --- Code for Private Libdbs ---======================================================================= ---extendLocalLibdb conlist == --called by function "compiler"(see above) --- buildLibdb conlist --> puts datafile into temp.text --- $newConstructorList := UNION(conlist, $newConstructorList) --- localLibdb := '"libdb.text" --- not isExistingFile '"libdb.text" => RENAME_-FILE('"temp.text",'"libdb.text") --- oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) --- newlines := dbReadLines '"temp.text" --- dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") --- deleteFile '"temp.text" - -purgeNewConstructorLines(lines, conlist) == - [x for x in lines | not screenLocalLine(x, conlist)] - --- Got rid of debugging statement and deleted screenLocalLine1, MCD 26/3/96 ---screenLocalLine(line,conlist) == --- u := screenLocalLine1(line,conlist) --- if u then --- sayBrightly ['"Purging--->", line] --- u - --- screenLocalLine1(line, conlist) == -screenLocalLine(line, conlist) == - k := dbKind line - con := INTERN - k = char 'o or k = char 'a => - s := dbPart(line,5,1) - k := charPosition(char '_(,s,1) - SUBSTRING(s,1,k - 1) - dbName line - MEMQ(con, conlist) - ---------------> NEW DEFINITION (see br-data.boot.pamphlet) -purgeLocalLibdb() == --called by the user through a clear command? - $newConstructorList := nil - deleteFile '"libdb.text" - ---moveFile(before,after) == --- $saturn => MOVE_-FILE(before, after) --- RENAME_-FILE(before, after) --- --obey STRCONC('"mv ", before, '" ", after) - --- deleted JHD/MCD, since already one in pathname.boot ---deleteFile fn == --- $saturn => DELETE_-FILE fn --- obey STRCONC('"rm ",fn) - ---======================================================================= --- from daase.lisp ---======================================================================= ---library(args) == --- $newConlist: local := nil --- LOCALDATABASE(args,$options) --- extendLocalLibdb $newConlist --- TERSYSCOMMAND() - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} - diff --git a/src/interp/br-con.lisp.pamphlet b/src/interp/br-con.lisp.pamphlet new file mode 100644 index 0000000..0cd00e2 --- /dev/null +++ b/src/interp/br-con.lisp.pamphlet @@ -0,0 +1,27390 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp br-con.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +@ +<<*>>= +(IN-PACKAGE "BOOT" ) + +;--====================> WAS b-con.boot <================================ +;--======================================================================= +;-- Pages Initiated from HyperDoc Pages +;--======================================================================= +;--NOTE: This duplicate version was discovered 3/20/94 in br-search.boot +;--called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon +;--conPage(a,:b) == +;-- --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) +;-- $conArgstrings: local := +;-- atom a => b +;-- a := conform2OutputForm a +;-- [mathform2HtString x for x in rest a] +;-- if not atom a then a := first a +;-- da := DOWNCASE a +;-- pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) => +;-- downlink pageName --special jump out for primitive domains +;-- line := conPageFastPath a => kPage line --lower case name of cons? +;-- line := conPageFastPath UPCASE a => kPage line --upper case an abbr? +;-- ySearch a --slow search (include default packages) +;-- +;--called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon +;conPage(a,:b) == +; --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) +; form := +; atom a => [a,:b] +; a +; $conArgstrings: local := [form2HtString x for x in KDR a] +; if not atom a then a := first a +; da := DOWNCASE a +; pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) => +; downlink pageName --special jump out for primitive domains +; line := conPageFastPath da => kPage(line,form) --lower case name of cons? +; line := conPageFastPath UPCASE a => kPage(line,form) --upper case an abbr? +; ySearch a --slow search (include default packages) + +(DEFUN |conPage| (&REST G165763 &AUX |b| |a|) + (DSETQ (|a| . |b|) G165763) + (PROG (|$conArgstrings| |form| |da| |pageName| |line|) + (DECLARE (SPECIAL |$conArgstrings|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| + (COND ((ATOM |a|) (CONS |a| |b|)) ('T |a|))) + (SPADLET |$conArgstrings| + (PROG (G165739) + (SPADLET G165739 NIL) + (RETURN + (DO ((G165744 (KDR |a|) (CDR G165744)) + (|x| NIL)) + ((OR (ATOM G165744) + (PROGN + (SETQ |x| (CAR G165744)) + NIL)) + (NREVERSE0 G165739)) + (SEQ (EXIT (SETQ G165739 + (CONS (|form2HtString| |x|) + G165739)))))))) + (COND ((NULL (ATOM |a|)) (SPADLET |a| (CAR |a|)))) + (SPADLET |da| (DOWNCASE |a|)) + (COND + ((SPADLET |pageName| + (LASSQ |da| + '((|type| . |CategoryType|) + (|union| . |DomainUnion|) + (|record| . |DomainRecord|) + (|mapping| . |DomainMapping|) + (|enumeration| . |DomainEnumeration|)))) + (|downlink| |pageName|)) + ((SPADLET |line| (|conPageFastPath| |da|)) + (|kPage| |line| |form|)) + ((SPADLET |line| (|conPageFastPath| (UPCASE |a|))) + (|kPage| |line| |form|)) + ('T (|ySearch| |a|)))))))) + +;conPageFastPath x == --called by conPage and constructorSearch +;--gets line quickly for constructor name or abbreviation +; s := STRINGIMAGE x +; charPosition(char '_*,s,0) < #s => nil --quit if name has * in it +; name := (STRINGP x => INTERN x; x) +; entry := HGET($lowerCaseConTb,name) or return nil +; lineNumber := LASSQ('dbLineNumber,CDDR entry) => +; --'dbLineNumbers property is set by function dbAugmentConstructorDataTable +; dbRead lineNumber --read record for constructor from libdb.text +; conPageConEntry first entry + +(DEFUN |conPageFastPath| (|x|) + (PROG (|s| |name| |entry| |lineNumber|) + (declare (special |$lowerCaseConTb|)) + (RETURN + (PROGN + (SPADLET |s| (STRINGIMAGE |x|)) + (COND + ((> (|#| |s|) (|charPosition| (|char| '*) |s| 0)) NIL) + ('T + (SPADLET |name| + (COND ((STRINGP |x|) (INTERN |x|)) ('T |x|))) + (SPADLET |entry| + (OR (HGET |$lowerCaseConTb| |name|) (RETURN NIL))) + (COND + ((SPADLET |lineNumber| + (LASSQ '|dbLineNumber| (CDDR |entry|))) + (|dbRead| |lineNumber|)) + ('T (|conPageConEntry| (CAR |entry|)))))))))) + +;conPageConEntry entry == +; $conname: local := nil +; $conform: local := nil +; $exposed?:local := nil +; $doc: local := nil +; $kind: local := nil +; buildLibdbConEntry entry + +(DEFUN |conPageConEntry| (|entry|) + (PROG (|$conname| |$conform| |$exposed?| |$doc| |$kind|) + (DECLARE (SPECIAL |$conname| |$conform| |$exposed?| |$doc| |$kind|)) + (RETURN + (PROGN + (SPADLET |$conname| NIL) + (SPADLET |$conform| NIL) + (SPADLET |$exposed?| NIL) + (SPADLET |$doc| NIL) + (SPADLET |$kind| NIL) + (|buildLibdbConEntry| |entry|))))) + +;--======================================================================= +;-- Constructor Page +;--======================================================================= +;-- in br-saturn.boot now +;--% kPage(line,:options) == --any cat, dom, package, default package +;--% --constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) +;--% ------------------> BRANCH OUT FOR SATURN +;--% true => kPageSaturn(line,options) +;--% parts := dbXParts(line,7,1) +;--% [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts +;--% form := IFCAR options +;--% isFile := null kind +;--% kind := kind or '"package" +;--% RPLACA(parts,kind) +;--% conform := mkConform(kind,name,args) +;--% conname := opOf conform +;--% capitalKind := capitalize kind +;--% signature := ncParseFromString sig +;--% sourceFileName := dbSourceFile INTERN name +;--% constrings := +;--% KDR form => dbConformGenUnder form +;--% [STRCONC(name,args)] +;--% emString := ['"{\sf ",:constrings,'"}"] +;--% heading := [capitalKind,'" ",:emString] +;--% if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] +;--% if name=abbrev then abbrev := asyAbbreviation(conname,nargs) +;--% page := htInitPage(heading,nil) +;--% htpSetProperty(page,'isFile,true) +;--% htpSetProperty(page,'parts,parts) +;--% htpSetProperty(page,'heading,heading) +;--% htpSetProperty(page,'kind,kind) +;--% if asharpConstructorName? conname then +;--% htpSetProperty(page,'isAsharpConstructor,true) +;--% htpSetProperty(page,'conform,conform) +;--% htpSetProperty(page,'signature,signature) +;--% kdPageInfo(name,abbrev,nargs,conform,signature,isFile) +;--% htSayStandard '"\newline" +;--% htBeginMenu(3) +;--% htSayStandard '"\item " +;--% htMakePage [['bcLinks,['"\menuitemstyle{Description}", +;--% [['text,'"\tab{19}",'"General description"]],'kiPage,nil]]] +;--% satBreak() +;--% htMakePage [['bcLinks,['"\menuitemstyle{Operations}", +;--% [['text,'"\tab{19}All exported operations"]],'koPage,'"operation"]]] +;--% if not asharpConstructorName? conname then +;--% satBreak() +;--% htMakePage [['bcLinks,['"\menuitemstyle{Attributes}", +;--% [['text,'"\tab{19}All exported attributes"]],'koPage,'"attribute"]]] +;--% if kind ^= 'category and (pathname := dbHasExamplePage conname) then +;--% satBreak() +;--% htMakePage [['bcLinks,['"\menuitemstyle{Examples}", +;--% [['text,'"\tab{19}Examples illustrating use"]],'kxPage,pathname]]] +;--% satBreak() +;--% htMakePage [['bcLinks,['"\menuitemstyle{Exports}", +;--% [['text,'"\tab{19}Explicit categories and operations"]],'kePage,nil]]] +;--% satBreak() +;--% htMakePage [['bcLinks,['"\menuitemstyle{Cross Reference}", +;--% [['text,'"\tab{19}Hierarchy and usage information"]],'kcPage,nil]]] +;--% htEndMenu(3) +;--% if kind ^= 'category and nargs > 0 then addParameterTemplates conform +;--% htShowPage() +;--% +;conform2String u == +; x := form2String u +; atom x => STRINGIMAGE x +; "STRCONC"/[STRINGIMAGE y for y in x] + +(DEFUN |conform2String| (|u|) + (PROG (|x|) + (RETURN + (SEQ (PROGN + (SPADLET |x| (|form2String| |u|)) + (COND + ((ATOM |x|) (STRINGIMAGE |x|)) + ('T + (PROG (G165793) + (SPADLET G165793 "") + (RETURN + (DO ((G165798 |x| (CDR G165798)) (|y| NIL)) + ((OR (ATOM G165798) + (PROGN (SETQ |y| (CAR G165798)) NIL)) + G165793) + (SEQ (EXIT (SETQ G165793 + (STRCONC G165793 + (STRINGIMAGE |y|))))))))))))))) + +;kxPage(htPage,name) == downlink name + +(DEFUN |kxPage| (|htPage| |name|) + (declare (ignore |htPage|)) + (|downlink| |name|)) + +;kdPageInfo(name,abbrev,nargs,conform,signature,file?) == +; htSay("{\sf ",name,'"}") +; if abbrev ^= name then bcHt [" has abbreviation ",abbrev] +; if file? then bcHt ['" is a source file."] +; if nargs = 0 then (if abbrev ^= name then bcHt '".") +; else +; if abbrev ^= name then bcHt '" and" +; bcHt +; nargs = 1 => '" takes one argument:" +; [" takes ",STRINGIMAGE nargs," arguments:"] +; htSaturnBreak() +; htSayStandard '"\indentrel{2}" +; if nargs > 0 then kPageArgs(conform,signature) +; htSayStandard '"\indentrel{-2}" +; if name.(#name-1) = char "&" then name := SUBSEQ(name, 0, #name-1) +;--sourceFileName := dbSourceFile INTERN name +; sourceFileName := GETDATABASE(INTERN name,'SOURCEFILE) +; filename := extractFileNameFromPath sourceFileName +; if filename ^= '"" then +; htSayStandard '"\newline{}" +; htSay('"The source code for the constructor is found in ") +; htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", +; sourceFileName, '" ", name, '"}"]] +; if nargs ^= 0 then htSay '"." +; htSaturnBreak() + +(DEFUN |kdPageInfo| + (|name| |abbrev| |nargs| |conform| |signature| |file?|) + (PROG (|sourceFileName| |filename|) + (RETURN + (PROGN + (|htSay| '|{\\sf | |name| (MAKESTRING "}")) + (COND + ((NEQUAL |abbrev| |name|) + (|bcHt| (CONS '| has abbreviation | (CONS |abbrev| NIL))))) + (COND + (|file?| (|bcHt| (CONS (MAKESTRING " is a source file.") NIL)))) + (COND + ((EQL |nargs| 0) + (COND + ((NEQUAL |abbrev| |name|) (|bcHt| (MAKESTRING "."))) + ('T NIL))) + ('T + (COND + ((NEQUAL |abbrev| |name|) (|bcHt| (MAKESTRING " and")))) + (|bcHt| (COND + ((EQL |nargs| 1) + (MAKESTRING " takes one argument:")) + ('T + (CONS '| takes | + (CONS (STRINGIMAGE |nargs|) + (CONS '| arguments:| NIL)))))))) + (|htSaturnBreak|) + (|htSayStandard| (MAKESTRING "\\indentrel{2}")) + (COND ((> |nargs| 0) (|kPageArgs| |conform| |signature|))) + (|htSayStandard| (MAKESTRING "\\indentrel{-2}")) + (COND + ((BOOT-EQUAL (ELT |name| (SPADDIFFERENCE (|#| |name|) 1)) + (|char| '&)) + (SPADLET |name| + (SUBSEQ |name| 0 (SPADDIFFERENCE (|#| |name|) 1))))) + (SPADLET |sourceFileName| + (GETDATABASE (INTERN |name|) 'SOURCEFILE)) + (SPADLET |filename| + (|extractFileNameFromPath| |sourceFileName|)) + (COND + ((NEQUAL |filename| (MAKESTRING "")) + (|htSayStandard| (MAKESTRING "\\newline{}")) + (|htSay| (MAKESTRING + "The source code for the constructor is found in ")))) + (|htMakePage| + (CONS (CONS '|text| + (CONS (MAKESTRING "\\unixcommand{") + (CONS |filename| + (CONS + (MAKESTRING + "}{\\$AXIOM/lib/SPADEDIT ") + (CONS |sourceFileName| + (CONS (MAKESTRING " ") + (CONS |name| + (CONS (MAKESTRING "}") NIL)))))))) + NIL)) + (COND ((NEQUAL |nargs| 0) (|htSay| (MAKESTRING ".")))) + (|htSaturnBreak|))))) + +;kArgPage(htPage,arg) == +; [op,:args] := conform := htpProperty(htPage,'conform) +; domname := htpProperty(htPage,'domname) +; heading := htpProperty(htPage,'heading) +; source := CDDAR getConstructorModemap op +; n := position(arg,args) +; typeForm := sublisFormal(args,source . n) +; domTypeForm := mkDomTypeForm(typeForm,conform,domname) +; descendants := domainDescendantsOf(typeForm,domTypeForm) +; htpSetProperty(htPage,'cAlist,descendants) +; rank := +; n > 4 => nil +; ('(First Second Third Fourth Fifth)).n +; htpSetProperty(htPage,'rank,rank) +; htpSetProperty(htPage,'thing,'"argument") +;--htpSetProperty(htPage,'specialMessage,['reportCategory,conform,typeForm,arg]) +; dbShowCons(htPage,'names) + +(DEFUN |kArgPage| (|htPage| |arg|) + (PROG (|conform| |op| |args| |domname| |heading| |source| |n| + |typeForm| |domTypeForm| |descendants| |rank|) + (RETURN + (PROGN + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |op| (CAR |conform|)) + (SPADLET |args| (CDR |conform|)) + (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) + (SPADLET |heading| (|htpProperty| |htPage| '|heading|)) + (SPADLET |source| (CDDAR (|getConstructorModemap| |op|))) + (SPADLET |n| (|position| |arg| |args|)) + (SPADLET |typeForm| (|sublisFormal| |args| (ELT |source| |n|))) + (SPADLET |domTypeForm| + (|mkDomTypeForm| |typeForm| |conform| |domname|)) + (SPADLET |descendants| + (|domainDescendantsOf| |typeForm| |domTypeForm|)) + (|htpSetProperty| |htPage| '|cAlist| |descendants|) + (SPADLET |rank| + (COND + ((> |n| 4) NIL) + ('T + (ELT '(|First| |Second| |Third| |Fourth| |Fifth|) + |n|)))) + (|htpSetProperty| |htPage| '|rank| |rank|) + (|htpSetProperty| |htPage| '|thing| (MAKESTRING "argument")) + (|dbShowCons| |htPage| '|names|))))) + +;reportCategory(conform,typeForm,arg) == +; htSay('"Argument {\em ",arg,'"}") +; [conlist,attrlist,:oplist] := categoryParts(conform,typeForm,true) +; htSay '" must " +; if conlist then +; htSay '"belong to " +; if conlist is [u] then +; htSay('"category ") +; bcConform first u +; bcPred rest u +; else +; htSay('"categories:") +; bcConPredTable(conlist,opOf conform) +; htSay '"\newline " +; if attrlist then +; if conlist then htSay '" and " +; reportAO('"attribute",attrlist) +; htSay '"\newline " +; if oplist then +; if conlist or attrlist then htSay '" and " +; reportAO('"operation",oplist) + +(DEFUN |reportCategory| (|conform| |typeForm| |arg|) + (PROG (|LETTMP#1| |conlist| |attrlist| |oplist| |u|) + (RETURN + (PROGN + (|htSay| (MAKESTRING "Argument {\\em ") |arg| (MAKESTRING "}")) + (SPADLET |LETTMP#1| (|categoryParts| |conform| |typeForm| 'T)) + (SPADLET |conlist| (CAR |LETTMP#1|)) + (SPADLET |attrlist| (CADR |LETTMP#1|)) + (SPADLET |oplist| (CDDR |LETTMP#1|)) + (|htSay| (MAKESTRING " must ")) + (COND + (|conlist| (|htSay| (MAKESTRING "belong to ")) + (COND + ((AND (PAIRP |conlist|) (EQ (QCDR |conlist|) NIL) + (PROGN (SPADLET |u| (QCAR |conlist|)) 'T)) + (|htSay| (MAKESTRING "category ")) + (|bcConform| (CAR |u|)) (|bcPred| (CDR |u|))) + ('T (|htSay| (MAKESTRING "categories:")) + (|bcConPredTable| |conlist| (|opOf| |conform|)) + (|htSay| (MAKESTRING "\\newline ")))))) + (COND + (|attrlist| (COND (|conlist| (|htSay| (MAKESTRING " and ")))) + (|reportAO| (MAKESTRING "attribute") |attrlist|) + (|htSay| (MAKESTRING "\\newline ")))) + (COND + (|oplist| + (COND + ((OR |conlist| |attrlist|) + (|htSay| (MAKESTRING " and ")))) + (|reportAO| (MAKESTRING "operation") |oplist|)) + ('T NIL)))))) + +;reportAO(kind,oplist) == +; htSay('"have ",kind,'":") +; for [op,sig,:pred] in oplist repeat +; htSay '"\newline " +; if #oplist = 1 then htSay '"\centerline{" +; if kind = '"attribute" then +; attr := form2String [op,:sig] +; satDownLink(attr,['"(|attrPage| '|",attr,'"|)"]) +; else +; ops := escapeSpecialChars STRINGIMAGE op +; sigs := form2HtString ['Mapping,:sig] +; satDownLink(ops,['"(|opPage| '|",ops,'"| |",sigs,'"|)"]) +; htSay '": " +; bcConform ['Mapping,:sig] +; if #oplist = 1 then htSay '"}" +; htSay '"\newline " + +(DEFUN |reportAO| (|kind| |oplist|) + (PROG (|op| |sig| |pred| |attr| |ops| |sigs|) + (RETURN + (SEQ (PROGN + (|htSay| (MAKESTRING "have ") |kind| (MAKESTRING ":")) + (DO ((G165885 |oplist| (CDR G165885)) (G165871 NIL)) + ((OR (ATOM G165885) + (PROGN (SETQ G165871 (CAR G165885)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G165871)) + (SPADLET |sig| (CADR G165871)) + (SPADLET |pred| (CDDR G165871)) + G165871) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING "\\newline ")) + (COND + ((EQL (|#| |oplist|) 1) + (|htSay| (MAKESTRING "\\centerline{")))) + (COND + ((BOOT-EQUAL |kind| + (MAKESTRING "attribute")) + (SPADLET |attr| + (|form2String| + (CONS |op| |sig|))) + (|satDownLink| |attr| + (CONS (MAKESTRING "(|attrPage| '|") + (CONS |attr| + (CONS (MAKESTRING "|)") NIL))))) + ('T + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE |op|))) + (SPADLET |sigs| + (|form2HtString| + (CONS '|Mapping| |sig|))) + (|satDownLink| |ops| + (CONS (MAKESTRING "(|opPage| '|") + (CONS |ops| + (CONS (MAKESTRING "| |") + (CONS |sigs| + (CONS (MAKESTRING "|)") NIL)))))) + (|htSay| (MAKESTRING ": ")) + (|bcConform| (CONS '|Mapping| |sig|)))) + (COND + ((EQL (|#| |oplist|) 1) + (|htSay| (MAKESTRING "}"))) + ('T NIL)))))) + (|htSay| (MAKESTRING "\\newline "))))))) + +;mkDomTypeForm(typeForm,conform,domname) == --called by kargPage +; domname => SUBLISLIS(rest domname,rest conform,typeForm) +; typeForm is ['Join,:r] => ['Join,:[mkDomTypeForm(t,conform,domname) for t in r]] +; null hasIdent typeForm => typeForm +; nil + +(DEFUN |mkDomTypeForm| (|typeForm| |conform| |domname|) + (PROG (|r|) + (RETURN + (SEQ (COND + (|domname| + (SUBLISLIS (CDR |domname|) (CDR |conform|) |typeForm|)) + ((AND (PAIRP |typeForm|) (EQ (QCAR |typeForm|) '|Join|) + (PROGN (SPADLET |r| (QCDR |typeForm|)) 'T)) + (CONS '|Join| + (PROG (G165906) + (SPADLET G165906 NIL) + (RETURN + (DO ((G165911 |r| (CDR G165911)) (|t| NIL)) + ((OR (ATOM G165911) + (PROGN + (SETQ |t| (CAR G165911)) + NIL)) + (NREVERSE0 G165906)) + (SEQ (EXIT (SETQ G165906 + (CONS + (|mkDomTypeForm| |t| |conform| + |domname|) + G165906))))))))) + ((NULL (|hasIdent| |typeForm|)) |typeForm|) + ('T NIL)))))) + +;domainDescendantsOf(conform,domform) == main where --called by kargPage +; main == +; conform is [op,:r] => +; op = 'Join => jfn(DELETE('(Type Object),r),DELETE('(Type Object),IFCDR domform)) +; op = 'CATEGORY => nil +; domainsOf(conform,domform) +; domainsOf(conform,domform) +; jfn([y,:r],domlist) == --keep only those domains that appear in ALL parts of Join +; alist := domainsOf(y,IFCAR domlist) +; for x in r repeat +; domlist := IFCDR domlist +; x is ['CATEGORY,.,:r] => alist := catScreen(r,alist) +; keepList := nil +; for [item,:pred] in domainsOf(x,IFCAR domlist) repeat +; u := ASSOC(item,alist) => +; keepList := [[item,:quickAnd(CDR u,pred)],:keepList] +; alist := keepList +; for pair in alist repeat RPLACD(pair,simpHasPred CDR pair) +; listSort(function GLESSEQP, alist) +; catScreen(r,alist) == +; for x in r repeat +; x isnt [op1,:.] and MEMQ(op1,'(ATTRIBUTE SIGNATURE)) => systemError x +; alist := [[item,:npred] for [item,:pred] in alist | +; (pred1 := simpHasPred ['has,item,x]) and (npred := quickAnd(pred1,pred))] +; alist + +(DEFUN |domainDescendantsOf,catScreen| (|r| |alist|) + (PROG (|op1| |item| |pred| |pred1| |npred|) + (RETURN + (SEQ (DO ((G165951 |r| (CDR G165951)) (|x| NIL)) + ((OR (ATOM G165951) + (PROGN (SETQ |x| (CAR G165951)) NIL)) + NIL) + (SEQ (IF (AND (NULL (AND (PAIRP |x|) + (PROGN + (SPADLET |op1| (QCAR |x|)) + 'T))) + (MEMQ |op1| '(ATTRIBUTE SIGNATURE))) + (EXIT (|systemError| |x|))) + (EXIT (SPADLET |alist| + (PROG (G165963) + (SPADLET G165963 NIL) + (RETURN + (DO + ((G165970 |alist| + (CDR G165970)) + (G165937 NIL)) + ((OR (ATOM G165970) + (PROGN + (SETQ G165937 + (CAR G165970)) + NIL) + (PROGN + (PROGN + (SPADLET |item| + (CAR G165937)) + (SPADLET |pred| + (CDR G165937)) + G165937) + NIL)) + (NREVERSE0 G165963)) + (SEQ + (EXIT + (COND + ((AND + (SPADLET |pred1| + (|simpHasPred| + (CONS '|has| + (CONS |item| + (CONS |x| NIL))))) + (SPADLET |npred| + (|quickAnd| |pred1| + |pred|))) + (SETQ G165963 + (CONS + (CONS |item| |npred|) + G165963))))))))))))) + (EXIT |alist|))))) + +(DEFUN |domainDescendantsOf,jfn| (G165987 |domlist|) + (PROG (|y| |ISTMP#1| |r| |item| |pred| |u| |keepList| |alist|) + (RETURN + (SEQ (PROGN + (SPADLET |y| (CAR G165987)) + (SPADLET |r| (CDR G165987)) + G165987 + (SEQ (SPADLET |alist| (|domainsOf| |y| (IFCAR |domlist|))) + (DO ((G166013 |r| (CDR G166013)) (|x| NIL)) + ((OR (ATOM G166013) + (PROGN (SETQ |x| (CAR G166013)) NIL)) + NIL) + (SEQ (SPADLET |domlist| (IFCDR |domlist|)) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (EXIT (SPADLET |alist| + (|domainDescendantsOf,catScreen| + |r| |alist|)))) + (SPADLET |keepList| NIL) + (DO ((G166023 + (|domainsOf| |x| (IFCAR |domlist|)) + (CDR G166023)) + (G165931 NIL)) + ((OR (ATOM G166023) + (PROGN + (SETQ G165931 (CAR G166023)) + NIL) + (PROGN + (PROGN + (SPADLET |item| (CAR G165931)) + (SPADLET |pred| (CDR G165931)) + G165931) + NIL)) + NIL) + (SEQ (EXIT (IF + (SPADLET |u| + (|assoc| |item| |alist|)) + (EXIT + (SPADLET |keepList| + (CONS + (CONS |item| + (|quickAnd| (CDR |u|) + |pred|)) + |keepList|))))))) + (EXIT (SPADLET |alist| |keepList|)))) + (DO ((G166033 |alist| (CDR G166033)) + (|pair| NIL)) + ((OR (ATOM G166033) + (PROGN (SETQ |pair| (CAR G166033)) NIL)) + NIL) + (SEQ (EXIT (RPLACD |pair| + (|simpHasPred| (CDR |pair|)))))) + (EXIT (|listSort| (|function| GLESSEQP) |alist|)))))))) + +(DEFUN |domainDescendantsOf| (|conform| |domform|) + (PROG (|op| |r|) + (RETURN + (COND + ((AND (PAIRP |conform|) + (PROGN + (SPADLET |op| (QCAR |conform|)) + (SPADLET |r| (QCDR |conform|)) + 'T)) + (COND + ((BOOT-EQUAL |op| '|Join|) + (|domainDescendantsOf,jfn| + (|delete| '(|Type| |Object|) |r|) + (|delete| '(|Type| |Object|) (IFCDR |domform|)))) + ((BOOT-EQUAL |op| 'CATEGORY) NIL) + ('T (|domainsOf| |conform| |domform|)))) + ('T (|domainsOf| |conform| |domform|)))))) + +;--======================================================================= +;-- Branches of Constructor Page +;--======================================================================= +;kiPage(htPage,junk) == +; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) +; conform := mkConform(kind,name,args) +; domname := kDomainName(htPage,kind,name,nargs) +; domname is ['error,:.] => errorPage(htPage,domname) +; heading := ['"Description of ", capitalize kind,'" {\sf ",name,args,'"}"] +; page := htInitPage(heading,htCopyProplist htPage) +; $conformsAreDomains := domname +; dbShowConsDoc1(htPage,conform,nil) +; htShowPage() + +(DEFUN |kiPage| (|htPage| |junk|) + (declare (ignore |junk|)) + (PROG (|LETTMP#1| |kind| |name| |nargs| |xflag| |sig| |args| |abbrev| + |comments| |conform| |domname| |heading| |page|) + (declare (special |$conformsAreDomains|)) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) + (SPADLET |kind| (CAR |LETTMP#1|)) + (SPADLET |name| (CADR |LETTMP#1|)) + (SPADLET |nargs| (CADDR |LETTMP#1|)) + (SPADLET |xflag| (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 |conform| (|mkConform| |kind| |name| |args|)) + (SPADLET |domname| + (|kDomainName| |htPage| |kind| |name| |nargs|)) + (COND + ((AND (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T + (SPADLET |heading| + (CONS (MAKESTRING "Description of ") + (CONS (|capitalize| |kind|) + (CONS (MAKESTRING " {\\sf ") + (CONS |name| + (CONS |args| + (CONS (MAKESTRING "}") NIL))))))) + (SPADLET |page| + (|htInitPage| |heading| + (|htCopyProplist| |htPage|))) + (SPADLET |$conformsAreDomains| |domname|) + (|dbShowConsDoc1| |htPage| |conform| NIL) (|htShowPage|))))))) + +;kePage(htPage,junk) == +; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) +; constring := STRCONC(name,args) +; domname := kDomainName(htPage,kind,name,nargs) +; domname is ['error,:.] => errorPage(htPage,domname) +; htpSetProperty(htPage,'domname,domname) +; $conformsAreDomains: local := domname +; conform := mkConform(kind,name,args) +; conname := opOf conform +; heading := [capitalize kind,'" {\sf ", +; (domname => form2HtString(domname,nil,true); constring),'"}"] +; data := sublisFormal(IFCDR domname or rest conform, +; getConstructorExports((domname or conform),true)) +; [conlist,attrlist,:oplist] := data +; if domname then +; for x in conlist repeat RPLAC(CDR x,simpHasPred CDR x) +; for x in attrlist repeat RPLAC(CDDR x,simpHasPred CDDR x) +; for x in oplist repeat RPLAC(CDDR x,simpHasPred CDDR x) +; prefix := pluralSay(#conlist + #attrlist + #oplist,'"Export",'"Exports") +; page := htInitPage([:prefix,'" of ",:heading],htCopyProplist htPage) +; htSayStandard '"\beginmenu " +; htpSetProperty(page,'data,data) +; if conlist then +; htMakePage [['bcLinks,[menuButton(),'"",'dbShowCons1,conlist,'names]]] +; htSayStandard '"\tab{2}" +; htSay '"All attributes and operations from:" +; bcConPredTable(conlist,opOf conform,rest conform) +; if attrlist then +; if conlist then htBigSkip() +; kePageDisplay(page,'"attribute",kePageOpAlist attrlist) +; if oplist then +; if conlist or attrlist then htBigSkip() +; kePageDisplay(page,'"operation",kePageOpAlist oplist) +; htSayStandard '" \endmenu " +; htShowPage() + +(DEFUN |kePage| (|htPage| |junk|) + (declare (ignore |junk|)) + (PROG (|$conformsAreDomains| |LETTMP#1| |kind| |name| |nargs| |xflag| + |sig| |args| |abbrev| |comments| |constring| |domname| + |conform| |conname| |heading| |data| |conlist| |attrlist| + |oplist| |prefix| |page|) + (DECLARE (SPECIAL |$conformsAreDomains|)) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) + (SPADLET |kind| (CAR |LETTMP#1|)) + (SPADLET |name| (CADR |LETTMP#1|)) + (SPADLET |nargs| (CADDR |LETTMP#1|)) + (SPADLET |xflag| (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 |constring| (STRCONC |name| |args|)) + (SPADLET |domname| + (|kDomainName| |htPage| |kind| |name| |nargs|)) + (COND + ((AND (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T (|htpSetProperty| |htPage| '|domname| |domname|) + (SPADLET |$conformsAreDomains| |domname|) + (SPADLET |conform| (|mkConform| |kind| |name| |args|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |heading| + (CONS (|capitalize| |kind|) + (CONS (MAKESTRING " {\\sf ") + (CONS + (COND + (|domname| + (|form2HtString| |domname| NIL + 'T)) + ('T |constring|)) + (CONS (MAKESTRING "}") NIL))))) + (SPADLET |data| + (|sublisFormal| + (OR (IFCDR |domname|) (CDR |conform|)) + (|getConstructorExports| + (OR |domname| |conform|) 'T))) + (SPADLET |conlist| (CAR |data|)) + (SPADLET |attrlist| (CADR |data|)) + (SPADLET |oplist| (CDDR |data|)) + (COND + (|domname| + (DO ((G166133 |conlist| (CDR G166133)) + (|x| NIL)) + ((OR (ATOM G166133) + (PROGN (SETQ |x| (CAR G166133)) NIL)) + NIL) + (SEQ (EXIT (RPLAC (CDR |x|) + (|simpHasPred| (CDR |x|)))))) + (DO ((G166142 |attrlist| (CDR G166142)) + (|x| NIL)) + ((OR (ATOM G166142) + (PROGN (SETQ |x| (CAR G166142)) NIL)) + NIL) + (SEQ (EXIT (RPLAC (CDDR |x|) + (|simpHasPred| (CDDR |x|)))))) + (DO ((G166151 |oplist| (CDR G166151)) + (|x| NIL)) + ((OR (ATOM G166151) + (PROGN (SETQ |x| (CAR G166151)) NIL)) + NIL) + (SEQ (EXIT (RPLAC (CDDR |x|) + (|simpHasPred| (CDDR |x|)))))))) + (SPADLET |prefix| + (|pluralSay| + (PLUS (PLUS (|#| |conlist|) + (|#| |attrlist|)) + (|#| |oplist|)) + (MAKESTRING "Export") + (MAKESTRING "Exports"))) + (SPADLET |page| + (|htInitPage| + (APPEND |prefix| + (CONS (MAKESTRING " of ") + |heading|)) + (|htCopyProplist| |htPage|))) + (|htSayStandard| (MAKESTRING "\\beginmenu ")) + (|htpSetProperty| |page| '|data| |data|) + (COND + (|conlist| + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS (|menuButton|) + (CONS (MAKESTRING "") + (CONS '|dbShowCons1| + (CONS |conlist| + (CONS '|names| NIL))))) + NIL)) + NIL)) + (|htSayStandard| (MAKESTRING "\\tab{2}")) + (|htSay| (MAKESTRING + "All attributes and operations from:")) + (|bcConPredTable| |conlist| (|opOf| |conform|) + (CDR |conform|)))) + (COND + (|attrlist| (COND (|conlist| (|htBigSkip|))) + (|kePageDisplay| |page| (MAKESTRING "attribute") + (|kePageOpAlist| |attrlist|)))) + (COND + (|oplist| + (COND ((OR |conlist| |attrlist|) (|htBigSkip|))) + (|kePageDisplay| |page| (MAKESTRING "operation") + (|kePageOpAlist| |oplist|)))) + (|htSayStandard| (MAKESTRING " \\endmenu ")) + (|htShowPage|)))))))) + +;kePageOpAlist oplist == +; opAlist := nil +; for [op,sig,:pred] in oplist repeat +; u := LASSOC(op,opAlist) +;--was +;-- opAlist := insertAlist(op,[[sig,pred],:u],opAlist) +; opAlist := insertAlist(zeroOneConvert op,[[sig,pred],:u],opAlist) +; opAlist + +(DEFUN |kePageOpAlist| (|oplist|) + (PROG (|op| |sig| |pred| |u| |opAlist|) + (RETURN + (SEQ (PROGN + (SPADLET |opAlist| NIL) + (DO ((G166196 |oplist| (CDR G166196)) (G166184 NIL)) + ((OR (ATOM G166196) + (PROGN (SETQ G166184 (CAR G166196)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G166184)) + (SPADLET |sig| (CADR G166184)) + (SPADLET |pred| (CDDR G166184)) + G166184) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |u| (LASSOC |op| |opAlist|)) + (SPADLET |opAlist| + (|insertAlist| + (|zeroOneConvert| |op|) + (CONS + (CONS |sig| (CONS |pred| NIL)) + |u|) + |opAlist|)))))) + |opAlist|))))) + +;kePageDisplay(htPage,which,opAlist) == +; count := #opAlist +; total := +/[#(rest entry) for entry in opAlist] +; count = 0 => nil +; if which = '"operation" +; then htpSetProperty(htPage,'opAlist,opAlist) +; else htpSetProperty(htPage,'attrAlist,opAlist) +; expandProperty := +; which = '"operation" => 'expandOperations +; 'expandAttributes +; htpSetProperty(htPage,expandProperty,'lists) --mark as unexpanded +; htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,'names]]] +; htSayStandard '"\tab{2}" +; if count ^= total then +; if count = 1 +; then htSay('"1 name for ") +; else htSay(STRINGIMAGE count,'" names for ") +; if total > 1 +; then htSay(STRINGIMAGE total,'" ",pluralize which,'" are explicitly exported:") +; else htSay('"1 ",which,'" is explicitly exported:") +; htSaySaturn '"\\" +; data := dbGatherData(htPage,opAlist,which,'names) +; dbShowOpItems(which,data,false) + +(DEFUN |kePageDisplay| (|htPage| |which| |opAlist|) + (PROG (|count| |total| |expandProperty| |data|) + (RETURN + (SEQ (PROGN + (SPADLET |count| (|#| |opAlist|)) + (SPADLET |total| + (PROG (G166214) + (SPADLET G166214 0) + (RETURN + (DO ((G166219 |opAlist| (CDR G166219)) + (|entry| NIL)) + ((OR (ATOM G166219) + (PROGN + (SETQ |entry| (CAR G166219)) + NIL)) + G166214) + (SEQ (EXIT (SETQ G166214 + (PLUS G166214 + (|#| (CDR |entry|)))))))))) + (COND + ((EQL |count| 0) NIL) + ('T + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpSetProperty| |htPage| '|opAlist| |opAlist|)) + ('T + (|htpSetProperty| |htPage| '|attrAlist| |opAlist|))) + (SPADLET |expandProperty| + (COND + ((BOOT-EQUAL |which| + (MAKESTRING "operation")) + '|expandOperations|) + ('T '|expandAttributes|))) + (|htpSetProperty| |htPage| |expandProperty| '|lists|) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (|menuButton|) + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|names| NIL))))) + NIL)) + NIL)) + (|htSayStandard| (MAKESTRING "\\tab{2}")) + (COND + ((NEQUAL |count| |total|) + (COND + ((EQL |count| 1) + (|htSay| (MAKESTRING "1 name for "))) + ('T + (|htSay| (STRINGIMAGE |count|) + (MAKESTRING " names for ")))))) + (COND + ((> |total| 1) + (|htSay| (STRINGIMAGE |total|) (MAKESTRING " ") + (|pluralize| |which|) + (MAKESTRING " are explicitly exported:"))) + ('T + (|htSay| (MAKESTRING "1 ") |which| + (MAKESTRING " is explicitly exported:")))) + (|htSaySaturn| (MAKESTRING "\\\\")) + (SPADLET |data| + (|dbGatherData| |htPage| |opAlist| |which| + '|names|)) + (|dbShowOpItems| |which| |data| NIL)))))))) + +;ksPage(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) +; domain := (kind = '"category" => nil; EVAL domname) +; conform:= htpProperty(htPage,'conform) +; page := htInitPageNoScroll(htCopyProplist htPage, +; ['"Search order for ",:heading]) +; htSay '"When an operation is not defined by the domain, the following domains are searched in order for a _"default definition" +; htSayStandard '"\beginscroll " +; u := dbSearchOrder(conform,domname,domain) +; htpSetProperty(htPage,'cAlist,u) +; htpSetProperty(htPage,'thing,'"constructor") +; dbShowCons(htPage,'names) + +(DEFUN |ksPage| (|htPage| |junk|) + (declare (ignore |junk|)) + (PROG (|LETTMP#1| |kind| |name| |nargs| |xpart| |sig| |args| |abbrev| + |comments| |domname| |heading| |domain| |conform| |page| + |u|) + (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 (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T + (SPADLET |heading| + (COND + ((NULL |domname|) + (|htpProperty| |htPage| '|heading|)) + ('T + (CONS (MAKESTRING "{\\sf ") + (CONS (|form2HtString| |domname| NIL 'T) + (CONS (MAKESTRING "}") NIL)))))) + (COND + (|domname| + (|htpSetProperty| |htPage| '|domname| |domname|) + (|htpSetProperty| |htPage| '|heading| |heading|))) + (SPADLET |domain| + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) NIL) + ('T (EVAL |domname|)))) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |page| + (|htInitPageNoScroll| (|htCopyProplist| |htPage|) + (CONS (MAKESTRING "Search order for ") + |heading|))) + (|htSay| (MAKESTRING + "When an operation is not defined by the domain, the following domains are searched in order for a \"default definition")) + (|htSayStandard| (MAKESTRING "\\beginscroll ")) + (SPADLET |u| (|dbSearchOrder| |conform| |domname| |domain|)) + (|htpSetProperty| |htPage| '|cAlist| |u|) + (|htpSetProperty| |htPage| '|thing| + (MAKESTRING "constructor")) + (|dbShowCons| |htPage| '|names|))))))) + +;dbSearchOrder(conform,domname,$domain) == --domain = nil or set to live domain +; conform := domname or conform +; name:= opOf conform +; $infovec: local := dbInfovec name or return nil --exit for categories +; u := $infovec.3 +; $predvec:= +; $domain => $domain . 3 +; GETDATABASE(name,'PREDICATES) +; catpredvec := CAR u +; catinfo := CADR u +; catvec := CADDR u +; catforms := [[pakform,:pred] for i in 0..MAXINDEX catvec | test ] where +; test == +; pred := simpCatPredicate +; p:=SUBLISLIS(rest conform,$FormalMapVariableList,kTestPred catpredvec.i) +; $domain => EVAL p +; p +; if domname and CONTAINED('$,pred) then pred := SUBST(domname,'$,pred) +;-- which = '"attribute" => pred --all categories +; (pak := catinfo . i) and pred --only those with default packages +; pakform == +; pak and not IDENTP pak => devaluate pak --in case it has been instantiated +; catform := kFormatSlotDomain catvec . i +;-- which = '"attribute" => dbSubConform(rest conform,catform) +; res := dbSubConform(rest conform,[pak,"$",:rest catform]) +; if domname then res := SUBST(domname,'$,res) +; res +; [:dbAddChain conform,:catforms] + +(DEFUN |dbSearchOrder| (|conform| |domname| |$domain|) + (DECLARE (SPECIAL |$domain|)) + (PROG (|$infovec| |name| |u| |catpredvec| |catinfo| |catvec| |p| + |pred| |pak| |catform| |res| |catforms|) + (DECLARE (SPECIAL |$infovec| |$predvec|)) + (RETURN + (SEQ (PROGN + (SPADLET |conform| (OR |domname| |conform|)) + (SPADLET |name| (|opOf| |conform|)) + (SPADLET |$infovec| + (OR (|dbInfovec| |name|) (RETURN NIL))) + (SPADLET |u| (ELT |$infovec| 3)) + (SPADLET |$predvec| + (COND + (|$domain| (ELT |$domain| 3)) + ('T (GETDATABASE |name| 'PREDICATES)))) + (SPADLET |catpredvec| (CAR |u|)) + (SPADLET |catinfo| (CADR |u|)) + (SPADLET |catvec| (CADDR |u|)) + (SPADLET |catforms| + (PROG (G166285) + (SPADLET G166285 NIL) + (RETURN + (DO ((G166291 (MAXINDEX |catvec|)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166291) + (NREVERSE0 G166285)) + (SEQ (EXIT (COND + ((PROGN + (SPADLET |pred| + (|simpCatPredicate| + (PROGN + (SPADLET |p| + (SUBLISLIS + (CDR |conform|) + |$FormalMapVariableList| + (|kTestPred| + (ELT |catpredvec| + |i|)))) + (COND + (|$domain| + (EVAL |p|)) + ('T |p|))))) + (COND + ((AND |domname| + (CONTAINED '$ |pred|)) + (SPADLET |pred| + (MSUBST |domname| '$ + |pred|)))) + (AND + (SPADLET |pak| + (ELT |catinfo| |i|)) + |pred|)) + (SETQ G166285 + (CONS + (CONS + (COND + ((AND |pak| + (NULL (IDENTP |pak|))) + (|devaluate| |pak|)) + ('T + (SPADLET |catform| + (|kFormatSlotDomain| + (ELT |catvec| |i|))) + (SPADLET |res| + (|dbSubConform| + (CDR |conform|) + (CONS |pak| + (CONS '$ + (CDR |catform|))))) + (COND + (|domname| + (SPADLET |res| + (MSUBST |domname| + '$ |res|)))) + |res|)) + |pred|) + G166285)))))))))) + (APPEND (|dbAddChain| |conform|) |catforms|)))))) + +;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 (PAIRP |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 (MAKESTRING "{\\sf ") + (CONS (|form2HtString| |domname| NIL 'T) + (CONS (MAKESTRING "}") NIL)))))) + (SPADLET |page| + (|htInitPage| + (CONS (MAKESTRING "Cross Reference for ") + |heading|) + (|htCopyProplist| |htPage|))) + (COND + (|domname| + (|htpSetProperty| |htPage| '|domname| |domname|) + (|htpSetProperty| |htPage| '|heading| |heading|))) + (COND + ((AND (BOOT-EQUAL |kind| (MAKESTRING "category")) + (|dbpHasDefaultCategory?| |xpart|)) + (|htSay| (MAKESTRING + "This category has default package ")) + (|bcCon| (STRCONC |name| (|char| '&)) (MAKESTRING "")))) + (|htSayStandard| (MAKESTRING "\\newline")) (|htBeginMenu| 3) + (|htSayStandard| (MAKESTRING "\\item ")) + (SPADLET |message| + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (CONS (MAKESTRING + "Categories it directly extends") + NIL)) + ('T + (CONS (MAKESTRING "Categories the ") + (CONS (COND + ((BOOT-EQUAL |kind| + (MAKESTRING "default package")) + (MAKESTRING "package")) + ('T |kind|)) + (CONS + (MAKESTRING + " belongs to by assertion") + NIL)))))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING + "\\menuitemstyle{Parents}") + (CONS + (CONS + (CONS '|text| + (CONS + (MAKESTRING "\\tab{12}") + |message|)) + NIL) + (CONS '|kcpPage| + (CONS NIL NIL)))) + NIL)) + NIL)) + (|satBreak|) + (SPADLET |message| + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (CONS (MAKESTRING + "All categories it is an extension of") + NIL)) + ('T + (CONS (MAKESTRING "All categories the ") + (CONS |kind| + (CONS (MAKESTRING " belongs to") + NIL)))))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING + "\\menuitemstyle{Ancestors}") + (CONS + (CONS + (CONS '|text| + (CONS + (MAKESTRING "\\tab{12}") + |message|)) + NIL) + (CONS '|kcaPage| + (CONS NIL NIL)))) + NIL)) + NIL)) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) (|satBreak|) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{Children}") + (CONS + (CONS + (CONS '|text| + (CONS (MAKESTRING "\\tab{12}") + (CONS + (MAKESTRING + "Categories which directly extend this category") + NIL))) + NIL) + (CONS '|kccPage| (CONS NIL NIL)))) + NIL)) + NIL)) + (|satBreak|) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{Descendants}") + (CONS + (CONS + (CONS '|text| + (CONS (MAKESTRING "\\tab{12}") + (CONS + (MAKESTRING + "All categories which extend this category") + NIL))) + NIL) + (CONS '|kcdPage| (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((NULL (|asharpConstructorName?| |conname|)) (|satBreak|) + (SPADLET |message| + (MAKESTRING + "Constructors mentioning this as an argument type")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{Dependents}") + (CONS + (CONS + (CONS '|text| + (CONS (MAKESTRING "\\tab{12}") + (CONS |message| NIL))) + NIL) + (CONS '|kcdePage| (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((AND (NULL (|asharpConstructorName?| |conname|)) + (NEQUAL |kind| (MAKESTRING "category"))) + (|satBreak|) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{Lineage}") + (CONS + (MAKESTRING + "\\tab{12}Constructor hierarchy used for operation lookup") + (CONS '|ksPage| (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((NULL (|asharpConstructorName?| |conname|)) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (|satBreak|) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{Domains}") + (CONS + (CONS + (CONS '|text| + (CONS + (MAKESTRING "\\tab{12}") + (CONS + (MAKESTRING + "All domains which are of this category") + NIL))) + NIL) + (CONS '|kcdoPage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((NEQUAL |kind| (MAKESTRING "category")) (|satBreak|) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{Clients}") + (CONS + (MAKESTRING + "\\tab{12}Constructors") + (CONS '|kcuPage| + (CONS NIL NIL)))) + NIL)) + NIL)) + (COND + ((HGET |$defaultPackageNamesHT| |conname|) + (|htSay| (MAKESTRING + " which {\\em may use} this default package"))) + ('T + (|htSay| (MAKESTRING " which {\\em use} this ") + |kind|)))) + ('T NIL)))) + (COND + ((OR (NEQUAL |kind| (MAKESTRING "category")) + (|dbpHasDefaultCategory?| |xpart|)) + (|satBreak|) + (SPADLET |message| + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (CONS (MAKESTRING + "Constructors {\\em used by} its default package") + NIL)) + ('T + (CONS (MAKESTRING + "Constructors {\\em used by} the ") + (CONS |kind| NIL))))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{Benefactors}") + (CONS + (CONS + (CONS '|text| + (CONS (MAKESTRING "\\tab{12}") + |message|)) + NIL) + (CONS '|kcnPage| (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((AND (NULL (|asharpConstructorName?| |conname|)) + (|hasNewInfoAlist| |conname|)) + (|satBreak|) + (SPADLET |message| + (CONS (MAKESTRING + "Cross reference for capsule implementation") + NIL)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING + "\\menuitemstyle{CapsuleInfo}") + (CONS + (CONS + (CONS '|text| + (CONS (MAKESTRING "\\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 (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T + (SPADLET |heading| + (COND + ((NULL |domname|) + (|htpProperty| |htPage| '|heading|)) + ('T + (CONS (MAKESTRING "{\\sf ") + (CONS (|form2HtString| |domname| NIL 'T) + (CONS (MAKESTRING "}") NIL)))))) + (COND + (|domname| + (|htpSetProperty| |htPage| '|domname| |domname|) + (|htpSetProperty| |htPage| '|heading| |heading|))) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |page| + (|htInitPage| + (CONS (MAKESTRING "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| (MAKESTRING "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| (MAKESTRING "category") (MAKESTRING " an ") + (MAKESTRING "ancestor") (|function| |ancestorsOf|) NIL)) + +;kcdPage(htPage,junk) == +; kcaPage1(htPage,'"category",'" a ",'"descendant",function descendantsOf,true) + +(DEFUN |kcdPage| (|htPage| |junk|) + (declare (ignore |junk|)) + (|kcaPage1| |htPage| (MAKESTRING "category") (MAKESTRING " a ") + (MAKESTRING "descendant") (|function| |descendantsOf|) 'T)) + +;kcdoPage(htPage,junk)== +; kcaPage1(htPage,'"domain",'" a ",'"descendant",function domainsOf, false) + +(DEFUN |kcdoPage| (|htPage| |junk|) + (declare (ignore |junk|)) + (|kcaPage1| |htPage| (MAKESTRING "domain") (MAKESTRING " a ") + (MAKESTRING "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 (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T + (SPADLET |heading| + (COND + ((NULL |domname|) + (|htpProperty| |htPage| '|heading|)) + ('T + (CONS (MAKESTRING "{\\sf ") + (CONS (|form2HtString| |domname| NIL 'T) + (CONS (MAKESTRING "}") 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| (MAKESTRING "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 (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T + (SPADLET |heading| + (COND + ((NULL |domname|) + (|htpProperty| |htPage| '|heading|)) + ('T + (CONS (MAKESTRING "{\\sf ") + (CONS (|form2HtString| |domname| NIL 'T) + (CONS (MAKESTRING "}") NIL)))))) + (COND + (|domname| + (|htpSetProperty| |htPage| '|domname| |domname|) + (|htpSetProperty| |htPage| '|heading| |heading|))) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |page| + (|htInitPage| + (CONS (MAKESTRING "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| (MAKESTRING "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 (PAIRP |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 +; constring := STRCONC(name,args) +; conform := +; kind ^= '"default package" => ncParseFromString constring +; [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & +; pakname := +;-- kind = '"category" => INTERN STRCONC(name,char '_&) +; opOf conform +; domList := getDependentsOfConstructor pakname +; cAlist := [[getConstructorForm x,:true] for x in domList] +; htpSetProperty(htPage,'cAlist,cAlist) +; htpSetProperty(htPage,'thing,'"dependent") +; dbShowCons(htPage,'names) + +(DEFUN |kcdePage| (|htPage| |junk|) + (declare (ignore |junk|)) + (PROG (|LETTMP#1| |kind| |name| |nargs| |xflag| |sig| |args| |abbrev| + |comments| |conname| |constring| |conform| |pakname| + |domList| |cAlist|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) + (SPADLET |kind| (CAR |LETTMP#1|)) + (SPADLET |name| (CADR |LETTMP#1|)) + (SPADLET |nargs| (CADDR |LETTMP#1|)) + (SPADLET |xflag| (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 |conname| (INTERN |name|)) + (SPADLET |constring| (STRCONC |name| |args|)) + (SPADLET |conform| + (COND + ((NEQUAL |kind| (MAKESTRING "default package")) + (|ncParseFromString| |constring|)) + ('T + (CONS (INTERN |name|) + (CDR (|ncParseFromString| + (STRCONC (|char| '|d|) |args|))))))) + (SPADLET |pakname| (|opOf| |conform|)) + (SPADLET |domList| + (|getDependentsOfConstructor| |pakname|)) + (SPADLET |cAlist| + (PROG (G166636) + (SPADLET G166636 NIL) + (RETURN + (DO ((G166641 |domList| (CDR G166641)) + (|x| NIL)) + ((OR (ATOM G166641) + (PROGN + (SETQ |x| (CAR G166641)) + NIL)) + (NREVERSE0 G166636)) + (SEQ (EXIT (SETQ G166636 + (CONS + (CONS + (|getConstructorForm| |x|) + 'T) + G166636)))))))) + (|htpSetProperty| |htPage| '|cAlist| |cAlist|) + (|htpSetProperty| |htPage| '|thing| + (MAKESTRING "dependent")) + (|dbShowCons| |htPage| '|names|)))))) + +;kcuPage(htPage,junk) == +; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) +; conname := INTERN name +; constring := STRCONC(name,args) +; conform := +; kind ^= '"default package" => ncParseFromString constring +; [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & +; pakname := +; kind = '"category" => INTERN STRCONC(name,char '_&) +; opOf conform +; domList := getUsersOfConstructor pakname +; cAlist := [[getConstructorForm x,:true] for x in domList] +; htpSetProperty(htPage,'cAlist,cAlist) +; htpSetProperty(htPage,'thing,'"user") +; dbShowCons(htPage,'names) + +(DEFUN |kcuPage| (|htPage| |junk|) + (declare (ignore |junk|)) + (PROG (|LETTMP#1| |kind| |name| |nargs| |xflag| |sig| |args| |abbrev| + |comments| |conname| |constring| |conform| |pakname| + |domList| |cAlist|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) + (SPADLET |kind| (CAR |LETTMP#1|)) + (SPADLET |name| (CADR |LETTMP#1|)) + (SPADLET |nargs| (CADDR |LETTMP#1|)) + (SPADLET |xflag| (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 |conname| (INTERN |name|)) + (SPADLET |constring| (STRCONC |name| |args|)) + (SPADLET |conform| + (COND + ((NEQUAL |kind| (MAKESTRING "default package")) + (|ncParseFromString| |constring|)) + ('T + (CONS (INTERN |name|) + (CDR (|ncParseFromString| + (STRCONC (|char| '|d|) |args|))))))) + (SPADLET |pakname| + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (INTERN (STRCONC |name| (|char| '&)))) + ('T (|opOf| |conform|)))) + (SPADLET |domList| (|getUsersOfConstructor| |pakname|)) + (SPADLET |cAlist| + (PROG (G166692) + (SPADLET G166692 NIL) + (RETURN + (DO ((G166697 |domList| (CDR G166697)) + (|x| NIL)) + ((OR (ATOM G166697) + (PROGN + (SETQ |x| (CAR G166697)) + NIL)) + (NREVERSE0 G166692)) + (SEQ (EXIT (SETQ G166692 + (CONS + (CONS + (|getConstructorForm| |x|) + 'T) + G166692)))))))) + (|htpSetProperty| |htPage| '|cAlist| |cAlist|) + (|htpSetProperty| |htPage| '|thing| (MAKESTRING "user")) + (|dbShowCons| |htPage| '|names|)))))) + +;kcnPage(htPage,junk) == +;--if reached by a category, that category has a default package +; [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) +; pakname := +; kind = '"category" => INTERN STRCONC(PNAME conname,char '_&) +; opOf conform +; domList := getImports pakname +; if domname then +; domList := SUBLISLIS([domname,:rest domname],['$,:rest conform],domList) +; cAlist := [[x,:true] for x in domList] +; htpSetProperty(htPage,'cAlist,cAlist) +; htpSetProperty(htPage,'thing,'"benefactor") +; dbShowCons(htPage,'names) + +(DEFUN |kcnPage| (|htPage| |junk|) + (declare (ignore |junk|)) + (PROG (|LETTMP#1| |kind| |name| |nargs| |xpart| |sig| |args| |abbrev| + |comments| |domname| |heading| |conform| |pakname| + |domList| |cAlist|) + (RETURN + (SEQ (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 (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T + (SPADLET |heading| + (COND + ((NULL |domname|) + (|htpProperty| |htPage| '|heading|)) + ('T + (CONS (MAKESTRING "{\\sf ") + (CONS (|form2HtString| |domname| NIL + 'T) + (CONS (MAKESTRING "}") NIL)))))) + (COND + (|domname| + (|htpSetProperty| |htPage| '|domname| |domname|) + (|htpSetProperty| |htPage| '|heading| |heading|))) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |pakname| + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (INTERN (STRCONC (PNAME |conname|) + (|char| '&)))) + ('T (|opOf| |conform|)))) + (SPADLET |domList| (|getImports| |pakname|)) + (COND + (|domname| + (SPADLET |domList| + (SUBLISLIS + (CONS |domname| (CDR |domname|)) + (CONS '$ (CDR |conform|)) |domList|)))) + (SPADLET |cAlist| + (PROG (G166749) + (SPADLET G166749 NIL) + (RETURN + (DO ((G166754 |domList| (CDR G166754)) + (|x| NIL)) + ((OR (ATOM G166754) + (PROGN + (SETQ |x| (CAR G166754)) + NIL)) + (NREVERSE0 G166749)) + (SEQ (EXIT + (SETQ G166749 + (CONS (CONS |x| 'T) G166749)))))))) + (|htpSetProperty| |htPage| '|cAlist| |cAlist|) + (|htpSetProperty| |htPage| '|thing| + (MAKESTRING "benefactor")) + (|dbShowCons| |htPage| '|names|)))))))) + +;koPageInputAreaUnchanged?(htPage, nargs) == +; [htpLabelInputString(htPage,INTERN STRCONC('"*",STRINGIMAGE i)) for i in 1..nargs] +; = htpProperty(htPage,'inputAreaList) + +(DEFUN |koPageInputAreaUnchanged?| (|htPage| |nargs|) + (PROG () + (RETURN + (SEQ (BOOT-EQUAL + (PROG (G166784) + (SPADLET G166784 NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |nargs|) (NREVERSE0 G166784)) + (SEQ (EXIT (SETQ G166784 + (CONS + (|htpLabelInputString| |htPage| + (INTERN + (STRCONC (MAKESTRING "*") + (STRINGIMAGE |i|)))) + G166784))))))) + (|htpProperty| |htPage| '|inputAreaList|)))))) + +;kDomainName(htPage,kind,name,nargs) == +; htpSetProperty(htPage,'domname,nil) +; inputAreaList := +; [htpLabelInputString(htPage,var) for i in 1..nargs for var in $PatternVariableList] +; htpSetProperty(htPage,'inputAreaList,inputAreaList) +; conname := INTERN name +; args := [kArgumentCheck(domain?,x) or nil for x in inputAreaList +; for domain? in rest GETDATABASE(conname,'COSIG)] +; or/[null x for x in args] => +; (n := +/[1 for x in args | x]) > 0 => +; ['error,nil,'"\centerline{You gave values for only {\em ",n,'" } of the {\em ",#args,'"}}",'"\centerline{parameters of {\sf ",name,'"}}\vspace{1}\centerline{Please enter either {\em all} or {\em none} of the type parameters}"] +; nil +; argString := +; null args => '"()" +; argTailPart := +; "STRCONC"/["STRCONC"/ ['",",:x] for x in KDR args] +; "STRCONC"/['"(",:first args,argTailPart,'")"] +; typeForm := CATCH('SPAD__READER, unabbrev mkConform(kind,name,argString)) or +; ['error,'invalidType,STRCONC(name,argString)] +; null (evaluatedTypeForm := kisValidType typeForm) => +; ['error,'invalidType,STRCONC(name,argString)] +; dbMkEvalable evaluatedTypeForm + +(DEFUN |kDomainName| (|htPage| |kind| |name| |nargs|) + (PROG (|inputAreaList| |conname| |args| |n| |argTailPart| |argString| + |typeForm| |evaluatedTypeForm|) + (RETURN + (SEQ (PROGN + (|htpSetProperty| |htPage| '|domname| NIL) + (SPADLET |inputAreaList| + (PROG (G166806) + (SPADLET G166806 NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|)) + (G166812 |$PatternVariableList| + (CDR G166812)) + (|var| NIL)) + ((OR (QSGREATERP |i| |nargs|) + (ATOM G166812) + (PROGN + (SETQ |var| (CAR G166812)) + NIL)) + (NREVERSE0 G166806)) + (SEQ (EXIT (SETQ G166806 + (CONS + (|htpLabelInputString| + |htPage| |var|) + G166806)))))))) + (|htpSetProperty| |htPage| '|inputAreaList| + |inputAreaList|) + (SPADLET |conname| (INTERN |name|)) + (SPADLET |args| + (PROG (G166824) + (SPADLET G166824 NIL) + (RETURN + (DO ((G166830 |inputAreaList| + (CDR G166830)) + (|x| NIL) + (G166831 + (CDR (GETDATABASE |conname| 'COSIG)) + (CDR G166831)) + (|domain?| NIL)) + ((OR (ATOM G166830) + (PROGN + (SETQ |x| (CAR G166830)) + NIL) + (ATOM G166831) + (PROGN + (SETQ |domain?| (CAR G166831)) + NIL)) + (NREVERSE0 G166824)) + (SEQ (EXIT (SETQ G166824 + (CONS + (OR + (|kArgumentCheck| |domain?| + |x|) + NIL) + G166824)))))))) + (COND + ((PROG (G166840) + (SPADLET G166840 NIL) + (RETURN + (DO ((G166846 NIL G166840) + (G166847 |args| (CDR G166847)) (|x| NIL)) + ((OR G166846 (ATOM G166847) + (PROGN (SETQ |x| (CAR G166847)) NIL)) + G166840) + (SEQ (EXIT (SETQ G166840 + (OR G166840 (NULL |x|)))))))) + (COND + ((> (SPADLET |n| + (PROG (G166854) + (SPADLET G166854 0) + (RETURN + (DO + ((G166860 |args| (CDR G166860)) + (|x| NIL)) + ((OR (ATOM G166860) + (PROGN + (SETQ |x| (CAR G166860)) + NIL)) + G166854) + (SEQ + (EXIT + (COND + (|x| + (SETQ G166854 + (PLUS G166854 1)))))))))) + 0) + (CONS '|error| + (CONS NIL + (CONS (MAKESTRING + "\\centerline{You gave values for only {\\em ") + (CONS |n| + (CONS + (MAKESTRING " } of the {\\em ") + (CONS (|#| |args|) + (CONS (MAKESTRING "}}") + (CONS + (MAKESTRING + "\\centerline{parameters of {\\sf ") + (CONS |name| + (CONS + (MAKESTRING + "}}\\vspace{1}\\centerline{Please enter either {\\em all} or {\\em none} of the type parameters}") + NIL))))))))))) + ('T NIL))) + ('T + (SPADLET |argString| + (COND + ((NULL |args|) (MAKESTRING "()")) + ('T + (SPADLET |argTailPart| + (PROG (G166866) + (SPADLET G166866 "") + (RETURN + (DO + ((G166871 (KDR |args|) + (CDR G166871)) + (|x| NIL)) + ((OR (ATOM G166871) + (PROGN + (SETQ |x| + (CAR G166871)) + NIL)) + G166866) + (SEQ + (EXIT + (SETQ G166866 + (STRCONC G166866 + (PROG (G166877) + (SPADLET G166877 "") + (RETURN + (DO + ((G166882 + (CONS + (MAKESTRING ",") + |x|) + (CDR G166882)) + (G166796 NIL)) + ((OR + (ATOM G166882) + (PROGN + (SETQ G166796 + (CAR + G166882)) + NIL)) + G166877) + (SEQ + (EXIT + (SETQ G166877 + (STRCONC + G166877 + G166796))))))))))))))) + (PROG (G166888) + (SPADLET G166888 "") + (RETURN + (DO ((G166893 + (CONS (MAKESTRING "(") + (APPEND (CAR |args|) + (CONS |argTailPart| + (CONS (MAKESTRING ")") NIL)))) + (CDR G166893)) + (G166797 NIL)) + ((OR (ATOM G166893) + (PROGN + (SETQ G166797 + (CAR G166893)) + NIL)) + G166888) + (SEQ (EXIT + (SETQ G166888 + (STRCONC G166888 G166797)))))))))) + (SPADLET |typeForm| + (OR (CATCH 'SPAD_READER + (|unabbrev| + (|mkConform| |kind| |name| + |argString|))) + (CONS '|error| + (CONS '|invalidType| + (CONS (STRCONC |name| |argString|) + NIL))))) + (COND + ((NULL (SPADLET |evaluatedTypeForm| + (|kisValidType| |typeForm|))) + (CONS '|error| + (CONS '|invalidType| + (CONS (STRCONC |name| |argString|) NIL)))) + ('T (|dbMkEvalable| |evaluatedTypeForm|)))))))))) + +;kArgumentCheck(domain?,s) == +; s = '"" => nil +; domain? and (form := conSpecialString? s) => +; null KDR form => [STRINGIMAGE opOf form] +; form2String form +; [s] + +(DEFUN |kArgumentCheck| (|domain?| |s|) + (PROG (|form|) + (RETURN + (COND + ((BOOT-EQUAL |s| (MAKESTRING "")) NIL) + ((AND |domain?| (SPADLET |form| (|conSpecialString?| |s|))) + (COND + ((NULL (KDR |form|)) + (CONS (STRINGIMAGE (|opOf| |form|)) NIL)) + ('T (|form2String| |form|)))) + ('T (CONS |s| NIL)))))) + +;dbMkEvalable form == +;--like mkEvalable except that it does NOT quote domains +;--does not do "loadIfNecessary" +; [op,:.] := form +; kind := GETDATABASE(op,'CONSTRUCTORKIND) +; kind = 'category => form +; mkEvalable form + +(DEFUN |dbMkEvalable| (|form|) + (PROG (|op| |kind|) + (RETURN + (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |kind| (GETDATABASE |op| 'CONSTRUCTORKIND)) + (COND + ((BOOT-EQUAL |kind| '|category|) |form|) + ('T (|mkEvalable| |form|))))))) + +;topLevelInterpEval x == +; $ProcessInteractiveValue: fluid := true +; $noEvalTypeMsg: fluid := true +; processInteractive(x,nil) + +(DEFUN |topLevelInterpEval| (|x|) + (PROG (|$ProcessInteractiveValue| |$noEvalTypeMsg|) + (DECLARE (SPECIAL |$ProcessInteractiveValue| |$noEvalTypeMsg|)) + (RETURN + (PROGN + (SPADLET |$ProcessInteractiveValue| 'T) + (SPADLET |$noEvalTypeMsg| 'T) + (|processInteractive| |x| NIL))))) + +;kisValidType typeForm == +; $ProcessInteractiveValue: fluid := true +; $noEvalTypeMsg: fluid := true +; CATCH('SPAD__READER, processInteractive(typeForm,nil)) +; is [[h,:.],:t] and MEMBER(h,'(Domain SubDomain)) => +; kCheckArgumentNumbers t and t +; false + +(DEFUN |kisValidType| (|typeForm|) + (PROG (|$ProcessInteractiveValue| |$noEvalTypeMsg| |ISTMP#1| + |ISTMP#2| |h| |t|) + (DECLARE (SPECIAL |$ProcessInteractiveValue| |$noEvalTypeMsg|)) + (RETURN + (PROGN + (SPADLET |$ProcessInteractiveValue| 'T) + (SPADLET |$noEvalTypeMsg| 'T) + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| + (CATCH 'SPAD_READER + (|processInteractive| |typeForm| NIL))) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |h| (QCAR |ISTMP#2|)) + 'T))) + (PROGN (SPADLET |t| (QCDR |ISTMP#1|)) 'T))) + (|member| |h| '(|Domain| |SubDomain|))) + (AND (|kCheckArgumentNumbers| |t|) |t|)) + ('T NIL)))))) + +;kCheckArgumentNumbers t == +; [conname,:args] := t +; cosig := KDR GETDATABASE(conname,'COSIG) +; #cosig ^= #args => false +; and/[foo for domain? in cosig for x in args] where foo == +; domain? => kCheckArgumentNumbers x +; true + +(DEFUN |kCheckArgumentNumbers| (|t|) + (PROG (|conname| |args| |cosig|) + (RETURN + (SEQ (PROGN + (SPADLET |conname| (CAR |t|)) + (SPADLET |args| (CDR |t|)) + (SPADLET |cosig| (KDR (GETDATABASE |conname| 'COSIG))) + (COND + ((NEQUAL (|#| |cosig|) (|#| |args|)) NIL) + ('T + (PROG (G166973) + (SPADLET G166973 'T) + (RETURN + (DO ((G166980 NIL (NULL G166973)) + (G166981 |cosig| (CDR G166981)) + (|domain?| NIL) + (G166982 |args| (CDR G166982)) (|x| NIL)) + ((OR G166980 (ATOM G166981) + (PROGN + (SETQ |domain?| (CAR G166981)) + NIL) + (ATOM G166982) + (PROGN (SETQ |x| (CAR G166982)) NIL)) + G166973) + (SEQ (EXIT (SETQ G166973 + (AND G166973 + (COND + (|domain?| + (|kCheckArgumentNumbers| + |x|)) + ('T 'T)))))))))))))))) + +;parseNoMacroFromString(s) == +; s := next(function ncloopParse, +; next(function lineoftoks,incString s)) +; StreamNull s => nil +; pf2Sex first rest first s + +(DEFUN |parseNoMacroFromString| (|s|) + (PROGN + (SPADLET |s| + (|next| (|function| |ncloopParse|) + (|next| (|function| |lineoftoks|) + (|incString| |s|)))) + (COND + ((|StreamNull| |s|) NIL) + ('T (|pf2Sex| (CAR (CDR (CAR |s|)))))))) + +; +;mkConform(kind,name,argString) == +; kind ^= '"default package" => +; form := STRCONC(name,argString) +; parse := parseNoMacroFromString form +; null parse => +; sayBrightlyNT '"Won't parse: " +; pp form +; systemError '"Keywords in argument list?" +; ATOM parse => [parse] +; parse +; [INTERN name,:rest ncParseFromString STRCONC(char 'd,argString)] --& case + +(DEFUN |mkConform| (|kind| |name| |argString|) + (PROG (|form| |parse|) + (RETURN + (COND + ((NEQUAL |kind| (MAKESTRING "default package")) + (SPADLET |form| (STRCONC |name| |argString|)) + (SPADLET |parse| (|parseNoMacroFromString| |form|)) + (COND + ((NULL |parse|) + (|sayBrightlyNT| (MAKESTRING "Won't parse: ")) + (|pp| |form|) + (|systemError| (MAKESTRING "Keywords in argument list?"))) + ((ATOM |parse|) (CONS |parse| NIL)) + ('T |parse|))) + ('T + (CONS (INTERN |name|) + (CDR (|ncParseFromString| + (STRCONC (|char| '|d|) |argString|))))))))) + +;--======================================================================= +;-- Operation Page for a Domain Form from Scratch +;--======================================================================= +;conOpPage(htPage,conform) == +; updown := dbCompositeWithMap htPage +; updown = '"DOWN" => +; domname := htpProperty(htPage,'domname) +; conOpPage1(dbExtractUnderlyingDomain domname,[['updomain,:domname]]) +; domname := htpProperty(htPage,'updomain) +; conOpPage1(domname,nil) + +(DEFUN |conOpPage| (|htPage| |conform|) + (declare (ignore |conform|)) + (PROG (|updown| |domname|) + (RETURN + (PROGN + (SPADLET |updown| (|dbCompositeWithMap| |htPage|)) + (COND + ((BOOT-EQUAL |updown| (MAKESTRING "DOWN")) + (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) + (|conOpPage1| (|dbExtractUnderlyingDomain| |domname|) + (CONS (CONS '|updomain| |domname|) NIL))) + ('T (SPADLET |domname| (|htpProperty| |htPage| '|updomain|)) + (|conOpPage1| |domname| NIL))))))) + +;dbCompositeWithMap htPage == +; htpProperty(htPage,'updomain) => '"UP" +; domain := htpProperty(htPage,'domname) +; null domain => false +; opAlist := htpProperty(htPage,'opAlist) +;--not LASSOC('map,opAlist) => false +; dbExtractUnderlyingDomain htpProperty(htPage,'domname) => '"DOWN" +; false + +(DEFUN |dbCompositeWithMap| (|htPage|) + (PROG (|domain| |opAlist|) + (RETURN + (COND + ((|htpProperty| |htPage| '|updomain|) (MAKESTRING "UP")) + ('T (SPADLET |domain| (|htpProperty| |htPage| '|domname|)) + (COND + ((NULL |domain|) NIL) + ('T (SPADLET |opAlist| (|htpProperty| |htPage| '|opAlist|)) + (COND + ((|dbExtractUnderlyingDomain| + (|htpProperty| |htPage| '|domname|)) + (MAKESTRING "DOWN")) + ('T NIL))))))))) + +;dbExtractUnderlyingDomain domain == or/[x for x in KDR domain | isValidType x] + +(DEFUN |dbExtractUnderlyingDomain| (|domain|) + (PROG () + (RETURN + (SEQ (PROG (G167026) + (SPADLET G167026 NIL) + (RETURN + (DO ((G167033 NIL G167026) + (G167034 (KDR |domain|) (CDR G167034)) + (|x| NIL)) + ((OR G167033 (ATOM G167034) + (PROGN (SETQ |x| (CAR G167034)) NIL)) + G167026) + (SEQ (EXIT (COND + ((|isValidType| |x|) + (SETQ G167026 (OR G167026 |x|))))))))))))) + +;--conform is atomic if no parameters, otherwise must be valid domain form +;conOpPage1(conform,:options) == +;--constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) +; bindingsAlist := IFCAR options +; conname := opOf conform +; MEMQ(conname,$Primitives) => +; dbSpecialOperations conname +; domname := --> !!note!! <-- +; null atom conform => conform +; nil +; line := conPageFastPath conname +; [kind,name,nargs,xflag,sig,args,abbrev,comments]:=parts:= dbXParts(line,7,1) +; isFile := null kind +; kind := kind or '"package" +; RPLACA(parts,kind) +; constring := STRCONC(name,args) +; conform := mkConform(kind,name,args) +; capitalKind := capitalize kind +; signature := ncParseFromString sig +; sourceFileName := dbSourceFile INTERN name +; emString := ['"{\sf ",constring,'"}"] +; heading := [capitalKind,'" ",:emString] +; if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] +; page := htInitPage(heading,nil) +; htpSetProperty(page,'isFile,true) +; htpSetProperty(page,'fromConOpPage1,true) +; htpSetProperty(page,'parts,parts) +; htpSetProperty(page,'heading,heading) +; htpSetProperty(page,'kind,kind) +; htpSetProperty(page,'domname,domname) --> !!note!! <-- +; htpSetProperty(page,'conform,conform) +; htpSetProperty(page,'signature,signature) +; if selectedOperation := LASSOC('selectedOperation,IFCDR options) then +; htpSetProperty(page,'selectedOperation,selectedOperation) +; for [a,:b] in bindingsAlist repeat htpSetProperty(page,a,b) +; koPage(page,'"operation") + +(DEFUN |conOpPage1| (&REST G167111 &AUX |options| |conform|) + (DSETQ (|conform| . |options|) G167111) + (PROG (|bindingsAlist| |conname| |domname| |line| |parts| |name| + |nargs| |xflag| |sig| |args| |abbrev| |comments| |isFile| + |kind| |constring| |capitalKind| |signature| + |sourceFileName| |emString| |heading| |page| + |selectedOperation| |a| |b|) + (declare (special |$Primitives|)) + (RETURN + (SEQ (PROGN + (SPADLET |bindingsAlist| (IFCAR |options|)) + (SPADLET |conname| (|opOf| |conform|)) + (COND + ((MEMQ |conname| |$Primitives|) + (|dbSpecialOperations| |conname|)) + ('T + (SPADLET |domname| + (COND + ((NULL (ATOM |conform|)) |conform|) + ('T NIL))) + (SPADLET |line| (|conPageFastPath| |conname|)) + (SPADLET |parts| (|dbXParts| |line| 7 1)) + (SPADLET |kind| (CAR |parts|)) + (SPADLET |name| (CADR |parts|)) + (SPADLET |nargs| (CADDR |parts|)) + (SPADLET |xflag| (CADDDR |parts|)) + (SPADLET |sig| (CAR (CDDDDR |parts|))) + (SPADLET |args| (CADR (CDDDDR |parts|))) + (SPADLET |abbrev| (CADDR (CDDDDR |parts|))) + (SPADLET |comments| (CADDDR (CDDDDR |parts|))) + (SPADLET |isFile| (NULL |kind|)) + (SPADLET |kind| (OR |kind| (MAKESTRING "package"))) + (RPLACA |parts| |kind|) + (SPADLET |constring| (STRCONC |name| |args|)) + (SPADLET |conform| (|mkConform| |kind| |name| |args|)) + (SPADLET |capitalKind| (|capitalize| |kind|)) + (SPADLET |signature| (|ncParseFromString| |sig|)) + (SPADLET |sourceFileName| + (|dbSourceFile| (INTERN |name|))) + (SPADLET |emString| + (CONS (MAKESTRING "{\\sf ") + (CONS |constring| + (CONS (MAKESTRING "}") NIL)))) + (SPADLET |heading| + (CONS |capitalKind| + (CONS (MAKESTRING " ") |emString|))) + (COND + ((NULL (|isExposedConstructor| |conname|)) + (SPADLET |heading| + (CONS (MAKESTRING "Unexposed ") |heading|)))) + (SPADLET |page| (|htInitPage| |heading| NIL)) + (|htpSetProperty| |page| '|isFile| 'T) + (|htpSetProperty| |page| '|fromConOpPage1| 'T) + (|htpSetProperty| |page| '|parts| |parts|) + (|htpSetProperty| |page| '|heading| |heading|) + (|htpSetProperty| |page| '|kind| |kind|) + (|htpSetProperty| |page| '|domname| |domname|) + (|htpSetProperty| |page| '|conform| |conform|) + (|htpSetProperty| |page| '|signature| |signature|) + (COND + ((SPADLET |selectedOperation| + (LASSOC '|selectedOperation| + (IFCDR |options|))) + (|htpSetProperty| |page| '|selectedOperation| + |selectedOperation|))) + (DO ((G167074 |bindingsAlist| (CDR G167074)) + (G167065 NIL)) + ((OR (ATOM G167074) + (PROGN (SETQ G167065 (CAR G167074)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G167065)) + (SPADLET |b| (CDR G167065)) + G167065) + NIL)) + NIL) + (SEQ (EXIT (|htpSetProperty| |page| |a| |b|)))) + (|koPage| |page| (MAKESTRING "operation"))))))))) + +;--======================================================================= +;-- Operation Page from Main Page +;--======================================================================= +;koPage(htPage,which) == +; [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) +; constring := STRCONC(name,args) +; conname := INTERN name +; domname := +; (u := htpProperty(htPage,'domname)) is [=conname,:.] +; and (htpProperty(htPage,'fromConOpPage1) = true or +; koPageInputAreaUnchanged?(htPage,nargs)) => u +; kDomainName(htPage,kind,name,nargs) +; domname is ['error,:.] => errorPage(htPage,domname) +; htpSetProperty(htPage,'domname,domname) +; headingString := +; domname => form2HtString(domname,nil,true) +; constring +; heading := [capitalize kind,'" {\sf ",headingString,'"}"] +; htpSetProperty(htPage,'which,which) +; htpSetProperty(htPage,'heading,heading) +; koPageAux(htPage,which,domname,heading) + +(DEFUN |koPage| (|htPage| |which|) + (PROG (|LETTMP#1| |kind| |name| |nargs| |xflag| |sig| |args| |abbrev| + |comments| |constring| |conname| |u| |ISTMP#1| |domname| + |headingString| |heading|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|parts|)) + (SPADLET |kind| (CAR |LETTMP#1|)) + (SPADLET |name| (CADR |LETTMP#1|)) + (SPADLET |nargs| (CADDR |LETTMP#1|)) + (SPADLET |xflag| (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 |constring| (STRCONC |name| |args|)) + (SPADLET |conname| (INTERN |name|)) + (SPADLET |domname| + (COND + ((AND (PROGN + (SPADLET |ISTMP#1| + (SPADLET |u| + (|htpProperty| |htPage| + '|domname|))) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |conname|))) + (OR (BOOT-EQUAL + (|htpProperty| |htPage| + '|fromConOpPage1|) + 'T) + (|koPageInputAreaUnchanged?| |htPage| + |nargs|))) + |u|) + ('T (|kDomainName| |htPage| |kind| |name| |nargs|)))) + (COND + ((AND (PAIRP |domname|) (EQ (QCAR |domname|) '|error|)) + (|errorPage| |htPage| |domname|)) + ('T (|htpSetProperty| |htPage| '|domname| |domname|) + (SPADLET |headingString| + (COND + (|domname| (|form2HtString| |domname| NIL 'T)) + ('T |constring|))) + (SPADLET |heading| + (CONS (|capitalize| |kind|) + (CONS (MAKESTRING " {\\sf ") + (CONS |headingString| + (CONS (MAKESTRING "}") NIL))))) + (|htpSetProperty| |htPage| '|which| |which|) + (|htpSetProperty| |htPage| '|heading| |heading|) + (|koPageAux| |htPage| |which| |domname| |heading|))))))) + +;koPageFromKKPage(htPage,ao) == +; koPageAux(htPage,ao,htpProperty(htPage,'domname),htpProperty(htPage,'heading)) + +(DEFUN |koPageFromKKPage| (|htPage| |ao|) + (|koPageAux| |htPage| |ao| (|htpProperty| |htPage| '|domname|) + (|htpProperty| |htPage| '|heading|))) + +;koPageAux(htPage,which,domname,heading) == --from koPage, koPageFromKKPage +; htpSetProperty(htPage,'which,which) +; domname := htpProperty(htPage,'domname) +; conform := htpProperty(htPage,'conform) +; heading := htpProperty(htPage,'heading) +; opAlist := +; which = '"attribute" => koAttrs(conform,domname) +; which = '"general operation" => koOps(conform,domname,true) +; koOps(conform,domname) +; if selectedOperation := htpProperty(htPage,'selectedOperation) then +; opAlist := [ASSOC(selectedOperation,opAlist) or systemError()] +; dbShowOperationsFromConform(htPage,which,opAlist) + +(DEFUN |koPageAux| (|htPage| |which| |domname| |heading|) + (PROG (|conform| |selectedOperation| |opAlist|) + (RETURN + (PROGN + (|htpSetProperty| |htPage| '|which| |which|) + (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |heading| (|htpProperty| |htPage| '|heading|)) + (SPADLET |opAlist| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "attribute")) + (|koAttrs| |conform| |domname|)) + ((BOOT-EQUAL |which| + (MAKESTRING "general operation")) + (|koOps| |conform| |domname| 'T)) + ('T (|koOps| |conform| |domname|)))) + (COND + ((SPADLET |selectedOperation| + (|htpProperty| |htPage| '|selectedOperation|)) + (SPADLET |opAlist| + (CONS (OR (|assoc| |selectedOperation| |opAlist|) + (|systemError|)) + NIL)))) + (|dbShowOperationsFromConform| |htPage| |which| |opAlist|))))) + +;koPageAux1(htPage,opAlist) == +; which := htpProperty(htPage,'which) +; dbShowOperationsFromConform(htPage,which,opAlist) + +(DEFUN |koPageAux1| (|htPage| |opAlist|) + (PROG (|which|) + (RETURN + (PROGN + (SPADLET |which| (|htpProperty| |htPage| '|which|)) + (|dbShowOperationsFromConform| |htPage| |which| |opAlist|))))) + +;koaPageFilterByName(htPage,functionToCall) == +; htpLabelInputString(htPage,'filter) = '"" => +; koaPageFilterByCategory(htPage,functionToCall) +; filter := pmTransFilter(dbGetInputString htPage) +;--WARNING: this call should check for ['error,:.] returned +; which := htpProperty(htPage,'which) +; opAlist := +; [x for x in htpProperty(htPage,'opAlist) | superMatch?(filter,DOWNCASE STRINGIMAGE first x)] +; htpSetProperty(htPage,'opAlist,opAlist) +; FUNCALL(functionToCall,htPage,nil) + +(DEFUN |koaPageFilterByName| (|htPage| |functionToCall|) + (PROG (|filter| |which| |opAlist|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL (|htpLabelInputString| |htPage| '|filter|) + (MAKESTRING "")) + (|koaPageFilterByCategory| |htPage| |functionToCall|)) + ('T + (SPADLET |filter| + (|pmTransFilter| (|dbGetInputString| |htPage|))) + (SPADLET |which| (|htpProperty| |htPage| '|which|)) + (SPADLET |opAlist| + (PROG (G167180) + (SPADLET G167180 NIL) + (RETURN + (DO ((G167186 + (|htpProperty| |htPage| '|opAlist|) + (CDR G167186)) + (|x| NIL)) + ((OR (ATOM G167186) + (PROGN + (SETQ |x| (CAR G167186)) + NIL)) + (NREVERSE0 G167180)) + (SEQ (EXIT (COND + ((|superMatch?| |filter| + (DOWNCASE + (STRINGIMAGE (CAR |x|)))) + (SETQ G167180 + (CONS |x| G167180)))))))))) + (|htpSetProperty| |htPage| '|opAlist| |opAlist|) + (FUNCALL |functionToCall| |htPage| NIL))))))) + +;--======================================================================= +;-- Get Constructor Documentation +;--======================================================================= +;dbConstructorDoc(conform,$op,$sig) == fn conform where +; fn (conform := [conname,:$args]) == +; or/[gn y for y in GETDATABASE(conname,'DOCUMENTATION)] +; gn([op,:alist]) == +; op = $op and or/[doc or '("") for [sig,:doc] in alist | hn sig] +; hn sig == +; #$sig = #sig and $sig = SUBLISLIS($args,$FormalMapVariableList,sig) + +(DEFUN |dbConstructorDoc,hn| (|sig|) + (declare (special |$sig| |$args|)) + (AND (BOOT-EQUAL (|#| |$sig|) (|#| |sig|)) + (BOOT-EQUAL |$sig| + (SUBLISLIS |$args| |$FormalMapVariableList| |sig|)))) + +(DEFUN |dbConstructorDoc,gn| (G167206) + (PROG (|op| |alist| |sig| |doc|) + (declare (special |$op|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G167206)) + (SPADLET |alist| (CDR G167206)) + G167206 + (AND (BOOT-EQUAL |op| |$op|) + (PROG (G167218) + (SPADLET G167218 NIL) + (RETURN + (DO ((G167226 NIL G167218) + (G167227 |alist| (CDR G167227)) + (G167199 NIL)) + ((OR G167226 (ATOM G167227) + (PROGN + (SETQ G167199 (CAR G167227)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR G167199)) + (SPADLET |doc| (CDR G167199)) + G167199) + NIL)) + G167218) + (SEQ (EXIT (COND + ((|dbConstructorDoc,hn| |sig|) + (SETQ G167218 + (OR G167218 (OR |doc| '("")) + ))))))))))))))) + +(DEFUN |dbConstructorDoc,fn| (|conform|) + (PROG (|conname|) + (declare (special |$args|)) + (RETURN + (SEQ (PROGN + (SPADLET |conname| (CAR |conform|)) + (SPADLET |$args| (CDR |conform|)) + |conform| + (PROG (G167251) + (SPADLET G167251 NIL) + (RETURN + (DO ((G167257 NIL G167251) + (G167258 (GETDATABASE |conname| 'DOCUMENTATION) + (CDR G167258)) + (|y| NIL)) + ((OR G167257 (ATOM G167258) + (PROGN (SETQ |y| (CAR G167258)) NIL)) + G167251) + (SEQ (EXIT (SETQ G167251 + (OR G167251 + (|dbConstructorDoc,gn| |y|))))))))))))) + +(DEFUN |dbConstructorDoc| (|conform| |$op| |$sig|) + (DECLARE (SPECIAL |$op| |$sig|)) + (|dbConstructorDoc,fn| |conform|)) + +;dbDocTable conform == +;--assumes $docTableHash bound --see dbExpandOpAlistIfNecessary +; table := HGET($docTableHash,conform) => table +; $docTable : local := MAKE_-HASHTABLE 'ID +; --process in reverse order so that closest cover up farthest +; for x in originsInOrder conform repeat dbAddDocTable x +; dbAddDocTable conform +; HPUT($docTableHash,conform,$docTable) +; $docTable + +(DEFUN |dbDocTable| (|conform|) + (PROG (|$docTable| |table|) + (DECLARE (SPECIAL |$docTable| |$docTableHash|)) + (RETURN + (SEQ (COND + ((SPADLET |table| (HGET |$docTableHash| |conform|)) + |table|) + ('T (SPADLET |$docTable| (MAKE-HASHTABLE 'ID)) + (DO ((G167280 (|originsInOrder| |conform|) + (CDR G167280)) + (|x| NIL)) + ((OR (ATOM G167280) + (PROGN (SETQ |x| (CAR G167280)) NIL)) + NIL) + (SEQ (EXIT (|dbAddDocTable| |x|)))) + (|dbAddDocTable| |conform|) + (HPUT |$docTableHash| |conform| |$docTable|) |$docTable|)))))) + +;originsInOrder conform == --domain = nil or set to live domain +;--from dcCats +; [con,:argl] := conform +; GETDATABASE(con,'CONSTRUCTORKIND) = 'category => +; ASSOCLEFT ancestorsOf(conform,nil) +; acc := ASSOCLEFT parentsOf con +; for x in acc repeat +; for y in originsInOrder x repeat acc := insert(y,acc) +; acc + +(DEFUN |originsInOrder| (|conform|) + (PROG (|con| |argl| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |con| (CAR |conform|)) + (SPADLET |argl| (CDR |conform|)) + (COND + ((BOOT-EQUAL (GETDATABASE |con| 'CONSTRUCTORKIND) + '|category|) + (ASSOCLEFT (|ancestorsOf| |conform| NIL))) + ('T (SPADLET |acc| (ASSOCLEFT (|parentsOf| |con|))) + (DO ((G167300 |acc| (CDR G167300)) (|x| NIL)) + ((OR (ATOM G167300) + (PROGN (SETQ |x| (CAR G167300)) NIL)) + NIL) + (SEQ (EXIT (DO ((G167309 (|originsInOrder| |x|) + (CDR G167309)) + (|y| NIL)) + ((OR (ATOM G167309) + (PROGN + (SETQ |y| (CAR G167309)) + NIL)) + NIL) + (SEQ (EXIT + (SPADLET |acc| + (|insert| |y| |acc|)))))))) + |acc|))))))) + +;dbAddDocTable conform == +; conname := opOf conform +; storedArgs := rest getConstructorForm conname +; for [op,:alist] in SUBLISLIS(["$",:rest conform], +; ["%",:storedArgs],GETDATABASE(opOf conform,'DOCUMENTATION)) +; repeat +; op1 := +; op = '(Zero) => 0 +; op = '(One) => 1 +; op +; for [sig,doc] in alist repeat +; HPUT($docTable,op1,[[conform,:alist],:HGET($docTable,op1)]) + +(DEFUN |dbAddDocTable| (|conform|) + (PROG (|conname| |storedArgs| |op| |alist| |op1| |sig| |doc|) + (declare (special |$docTable|)) + (RETURN + (SEQ (PROGN + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |storedArgs| + (CDR (|getConstructorForm| |conname|))) + (DO ((G167342 + (SUBLISLIS (CONS '$ (CDR |conform|)) + (CONS '% |storedArgs|) + (GETDATABASE (|opOf| |conform|) + 'DOCUMENTATION)) + (CDR G167342)) + (G167328 NIL)) + ((OR (ATOM G167342) + (PROGN (SETQ G167328 (CAR G167342)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167328)) + (SPADLET |alist| (CDR G167328)) + G167328) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |op1| + (COND + ((BOOT-EQUAL |op| '(|Zero|)) 0) + ((BOOT-EQUAL |op| '(|One|)) 1) + ('T |op|))) + (DO ((G167353 |alist| (CDR G167353)) + (G167323 NIL)) + ((OR (ATOM G167353) + (PROGN + (SETQ G167323 (CAR G167353)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR G167323)) + (SPADLET |doc| + (CADR G167323)) + G167323) + NIL)) + NIL) + (SEQ (EXIT + (HPUT |$docTable| |op1| + (CONS (CONS |conform| |alist|) + (HGET |$docTable| |op1|))))))))))))))) + +; --note opOf is needed!!! for some reason, One and Zero appear within prens +;dbGetDocTable(op,$sig,docTable,$which,aux) == main where +;--docTable is [[origin,entry1,...,:code] ...] where +;-- each entry is [sig,doc] and code is NIL or else a topic code for op +; main == +; if null FIXP op and +; DIGITP (s := STRINGIMAGE op).0 then op := string2Integer s +; -- the above hack should be removed after 3/94 when 0 is not |0| +; aux is [[packageName,:.],:pred] => +; doc := dbConstructorDoc(first aux,$op,$sig) +; origin := +; pred => ['ifp,:aux] +; first aux +; [origin,:doc] +; or/[gn x for x in HGET(docTable,op)] +; gn u == --u is [origin,entry1,...,:code] +; $conform := CAR u --origin +; if ATOM $conform then $conform := [$conform] +; code := LASTATOM u --optional topic code +; comments := or/[p for entry in CDR u | p := hn entry] or return nil +; [$conform,first comments,:code] +; hn [sig,:doc] == +; $which = '"attribute" => sig is ['attribute,: =$sig] and doc +; pred := #$sig = #sig and +; alteredSig := SUBLISLIS(KDR $conform,$FormalMapVariableList,sig) +; alteredSig = $sig +; pred => +; doc => +; doc is ['constant,:r] => r +; doc +; '("") +; false + +(DEFUN |dbGetDocTable,hn| (G167382) + (PROG (|sig| |doc| |alteredSig| |pred| |r|) + (declare (special |$which| |$conform| |$sig| |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |sig| (CAR G167382)) + (SPADLET |doc| (CDR G167382)) + G167382 + (SEQ (IF (BOOT-EQUAL |$which| (MAKESTRING "attribute")) + (EXIT (AND (AND (PAIRP |sig|) + (EQ (QCAR |sig|) '|attribute|) + (EQUAL (QCDR |sig|) |$sig|)) + |doc|))) + (SPADLET |pred| + (AND (BOOT-EQUAL (|#| |$sig|) (|#| |sig|)) + (SEQ (SPADLET |alteredSig| + (SUBLISLIS (KDR |$conform|) + |$FormalMapVariableList| |sig|)) + (EXIT + (BOOT-EQUAL |alteredSig| |$sig|))))) + (IF |pred| + (EXIT (SEQ (IF |doc| + (EXIT + (SEQ + (IF + (AND (PAIRP |doc|) + (EQ (QCAR |doc|) '|constant|) + (PROGN + (SPADLET |r| (QCDR |doc|)) + 'T)) + (EXIT |r|)) + (EXIT |doc|)))) + (EXIT '(""))))) + (EXIT NIL))))))) + +(DEFUN |dbGetDocTable,gn| (|u|) + (PROG (|code| |p| |comments|) + (declare (special |$conform|)) + (RETURN + (SEQ (SPADLET |$conform| (CAR |u|)) + (IF (ATOM |$conform|) + (SPADLET |$conform| (CONS |$conform| NIL)) NIL) + (SPADLET |code| (LASTATOM |u|)) + (SPADLET |comments| + (OR (PROG (G167401) + (SPADLET G167401 NIL) + (RETURN + (DO ((G167408 NIL G167401) + (G167409 (CDR |u|) (CDR G167409)) + (|entry| NIL)) + ((OR G167408 (ATOM G167409) + (PROGN + (SETQ |entry| (CAR G167409)) + NIL)) + G167401) + (SEQ (EXIT + (COND + ((SPADLET |p| + (|dbGetDocTable,hn| |entry|)) + (SETQ G167401 + (OR G167401 |p|))))))))) + (RETURN NIL))) + (EXIT (CONS |$conform| (CONS (CAR |comments|) |code|))))))) + +(DEFUN |dbGetDocTable| (|op| |$sig| |docTable| |$which| |aux|) + (DECLARE (SPECIAL |$sig| |$which|)) + (PROG (|s| |ISTMP#1| |packageName| |pred| |doc| |origin|) + (declare (special |$conform| |$op|)) + (RETURN + (SEQ (PROGN + (COND + ((AND (NULL (FIXP |op|)) + (DIGITP (ELT (SPADLET |s| (STRINGIMAGE |op|)) 0))) + (SPADLET |op| (|string2Integer| |s|)))) + (COND + ((AND (PAIRP |aux|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |aux|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |packageName| (QCAR |ISTMP#1|)) + 'T))) + (PROGN (SPADLET |pred| (QCDR |aux|)) 'T)) + (SPADLET |doc| + (|dbConstructorDoc| (CAR |aux|) |$op| |$sig|)) + (SPADLET |origin| + (COND + (|pred| (CONS '|ifp| |aux|)) + ('T (CAR |aux|)))) + (CONS |origin| |doc|)) + ('T + (PROG (G167432) + (SPADLET G167432 NIL) + (RETURN + (DO ((G167438 NIL G167432) + (G167439 (HGET |docTable| |op|) + (CDR G167439)) + (|x| NIL)) + ((OR G167438 (ATOM G167439) + (PROGN (SETQ |x| (CAR G167439)) NIL)) + G167432) + (SEQ (EXIT (SETQ G167432 + (OR G167432 + (|dbGetDocTable,gn| |x|))))))))))))))) + +;kTestPred n == +; n = 0 => true +; $domain => testBitVector($predvec,n) +; simpHasPred $predvec.(n - 1) + +(DEFUN |kTestPred| (|n|) + (declare (special |$predvec| |$domain|)) + (COND + ((EQL |n| 0) 'T) + (|$domain| (|testBitVector| |$predvec| |n|)) + ('T (|simpHasPred| (ELT |$predvec| (SPADDIFFERENCE |n| 1)))))) + +;dbAddChainDomain conform == +; [name,:args] := conform +; $infovec := dbInfovec name or return nil --exit for categories +; template := $infovec . 0 +; null (form := template . 5) => nil +; dbSubConform(args,kFormatSlotDomain devaluate form) + +(DEFUN |dbAddChainDomain| (|conform|) + (PROG (|name| |args| |template| |form|) + (declare (special |$infovec|)) + (RETURN + (PROGN + (SPADLET |name| (CAR |conform|)) + (SPADLET |args| (CDR |conform|)) + (SPADLET |$infovec| (OR (|dbInfovec| |name|) (RETURN NIL))) + (SPADLET |template| (ELT |$infovec| 0)) + (COND + ((NULL (SPADLET |form| (ELT |template| 5))) NIL) + ('T + (|dbSubConform| |args| + (|kFormatSlotDomain| (|devaluate| |form|))))))))) + +;dbSubConform(args,u) == +; atom u => +; (n := position(u,$FormalMapVariableList)) >= 0 => args . n +; u +; u is ['local,y] => dbSubConform(args,y) +; [dbSubConform(args,x) for x in u] + +(DEFUN |dbSubConform| (|args| |u|) + (PROG (|n| |ISTMP#1| |y|) + (RETURN + (SEQ (COND + ((ATOM |u|) + (COND + ((>= (SPADLET |n| + (|position| |u| |$FormalMapVariableList|)) + 0) + (ELT |args| |n|)) + ('T |u|))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|local|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + (|dbSubConform| |args| |y|)) + ('T + (PROG (G167484) + (SPADLET G167484 NIL) + (RETURN + (DO ((G167489 |u| (CDR G167489)) (|x| NIL)) + ((OR (ATOM G167489) + (PROGN (SETQ |x| (CAR G167489)) NIL)) + (NREVERSE0 G167484)) + (SEQ (EXIT (SETQ G167484 + (CONS (|dbSubConform| |args| |x|) + G167484))))))))))))) + +;dbAddChain conform == +; u := dbAddChainDomain conform => +; atom u => nil +; [[u,:true],:dbAddChain u] +; nil + +(DEFUN |dbAddChain| (|conform|) + (PROG (|u|) + (RETURN + (COND + ((SPADLET |u| (|dbAddChainDomain| |conform|)) + (COND + ((ATOM |u|) NIL) + ('T (CONS (CONS |u| 'T) (|dbAddChain| |u|))))) + ('T NIL))))) + +;--======================================================================= +;-- Constructor Page Menu +;--======================================================================= +;dbShowCons(htPage,key,:options) == +; cAlist := htpProperty(htPage,'cAlist) +; key = 'filter => +; --if $saturn, IFCAR options is the filter string +; filter := pmTransFilter(IFCAR options or dbGetInputString htPage) +; filter is ['error,:.] => bcErrorPage filter +; abbrev? := htpProperty(htPage,'exclusion) = 'abbrs +; u := [x for x in cAlist | test] where test == +; conname := CAAR x +; subject := (abbrev? => constructor? conname; conname) +; superMatch?(filter,DOWNCASE STRINGIMAGE subject) +; null u => emptySearchPage('"constructor",filter) +; htPage := htInitPageNoScroll(htCopyProplist htPage) +; htpSetProperty(htPage,'cAlist,u) +; dbShowCons(htPage,htpProperty(htPage,'exclusion)) +; if MEMQ(key,'(exposureOn exposureOff)) then +; $exposedOnlyIfTrue := +; key = 'exposureOn => 'T +; NIL +; key := htpProperty(htPage,'exclusion) +; dbShowCons1(htPage,cAlist,key) + +(DEFUN |dbShowCons| (&REST G167545 &AUX |options| |key| |htPage|) + (DSETQ (|htPage| |key| . |options|) G167545) + (PROG (|cAlist| |filter| |abbrev?| |conname| |subject| |u|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |cAlist| (|htpProperty| |htPage| '|cAlist|)) + (COND + ((BOOT-EQUAL |key| '|filter|) + (SPADLET |filter| + (|pmTransFilter| + (OR (IFCAR |options|) + (|dbGetInputString| |htPage|)))) + (COND + ((AND (PAIRP |filter|) (EQ (QCAR |filter|) '|error|)) + (|bcErrorPage| |filter|)) + ('T + (SPADLET |abbrev?| + (BOOT-EQUAL + (|htpProperty| |htPage| '|exclusion|) + '|abbrs|)) + (SPADLET |u| + (PROG (G167520) + (SPADLET G167520 NIL) + (RETURN + (DO ((G167526 |cAlist| + (CDR G167526)) + (|x| NIL)) + ((OR (ATOM G167526) + (PROGN + (SETQ |x| (CAR G167526)) + NIL)) + (NREVERSE0 G167520)) + (SEQ (EXIT + (COND + ((PROGN + (SPADLET |conname| + (CAAR |x|)) + (SPADLET |subject| + (COND + (|abbrev?| + (|constructor?| + |conname|)) + ('T |conname|))) + (|superMatch?| |filter| + (DOWNCASE + (STRINGIMAGE |subject|)))) + (SETQ G167520 + (CONS |x| G167520)))))))))) + (COND + ((NULL |u|) + (|emptySearchPage| (MAKESTRING "constructor") + |filter|)) + ('T + (SPADLET |htPage| + (|htInitPageNoScroll| + (|htCopyProplist| |htPage|))) + (|htpSetProperty| |htPage| '|cAlist| |u|) + (|dbShowCons| |htPage| + (|htpProperty| |htPage| '|exclusion|))))))) + ('T + (COND + ((MEMQ |key| '(|exposureOn| |exposureOff|)) + (SPADLET |$exposedOnlyIfTrue| + (COND + ((BOOT-EQUAL |key| '|exposureOn|) 'T) + ('T NIL))) + (SPADLET |key| + (|htpProperty| |htPage| '|exclusion|)))) + (|dbShowCons1| |htPage| |cAlist| |key|)))))))) + +;conPageChoose conname == +; cAlist := [[getConstructorForm conname,:true]] +; dbShowCons1(nil,cAlist,'names) + +(DEFUN |conPageChoose| (|conname|) + (PROG (|cAlist|) + (RETURN + (PROGN + (SPADLET |cAlist| + (CONS (CONS (|getConstructorForm| |conname|) 'T) NIL)) + (|dbShowCons1| NIL |cAlist| '|names|))))) + +;dbShowCons1(htPage,cAlist,key) == +; conlist := REMDUP [item for x in cAlist | pred] where +; pred == +; item := CAR x +; $exposedOnlyIfTrue => isExposedConstructor opOf item +; item +;--$searchFirstTime and (conlist is [.]) => conPage first conlist +;--$searchFirstTime := false +; conlist is [.] => conPage +; htPage and htpProperty(htPage,'domname) => first conlist +; opOf first conlist +; conlist := [opOf x for x in conlist] +; kinds := "UNION"/[dbConstructorKind x for x in conlist] +; kind := +; kinds is [a] => a +; 'constructor +; proplist := +; htPage => htCopyProplist htPage +; nil +; page := htInitPageNoScroll(proplist,dbConsHeading(htPage,conlist,key,kind)) +; if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) +; htSayStandard('"\beginscroll ") +; htpSetProperty(page,'cAlist,cAlist) +; $conformsAreDomains: local := htpProperty(page,'domname) +; do +; --key = 'catfilter => dbShowCatFilter(page,key) +; key = 'names => bcNameConTable conlist +; key = 'abbrs => +; bcAbbTable [getCDTEntry(con,true) for con in conlist] +; key = 'files => +; flist := +; [y for con in conlist | +; y := (fn := GETDATABASE(con,'SOURCEFILE))] +; bcUnixTable(listSort(function GLESSEQP,REMDUP flist)) +; key = 'documentation => dbShowConsDoc(page,conlist) +; if $exposedOnlyIfTrue then +; cAlist := [x for x in cAlist | isExposedConstructor opOf CAR x] +; key = 'conditions => dbShowConditions(page,cAlist,kind) +; key = 'parameters => bcConTable REMDUP ASSOCLEFT cAlist +; key = 'kinds => dbShowConsKinds cAlist +; dbConsExposureMessage() +; htSayStandard("\endscroll ") +; dbPresentCons(page,kind,key) +; htShowPageNoScroll() + +(DEFUN |dbShowCons1| (|htPage| |cAlist| |key|) + (PROG (|$conformsAreDomains| |item| |conlist| |kinds| |a| |kind| + |proplist| |page| |u| |fn| |y| |flist|) + (DECLARE (SPECIAL |$conformsAreDomains| |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |conlist| + (REMDUP (PROG (G167564) + (SPADLET G167564 NIL) + (RETURN + (DO ((G167570 |cAlist| + (CDR G167570)) + (|x| NIL)) + ((OR (ATOM G167570) + (PROGN + (SETQ |x| (CAR G167570)) + NIL)) + (NREVERSE0 G167564)) + (SEQ + (EXIT + (COND + ((PROGN + (SPADLET |item| (CAR |x|)) + (COND + (|$exposedOnlyIfTrue| + (|isExposedConstructor| + (|opOf| |item|))) + ('T |item|))) + (SETQ G167564 + (CONS |item| G167564))))))))))) + (COND + ((AND (PAIRP |conlist|) (EQ (QCDR |conlist|) NIL)) + (|conPage| + (COND + ((AND |htPage| + (|htpProperty| |htPage| '|domname|)) + (CAR |conlist|)) + ('T (|opOf| (CAR |conlist|)))))) + ('T + (SPADLET |conlist| + (PROG (G167580) + (SPADLET G167580 NIL) + (RETURN + (DO ((G167585 |conlist| (CDR G167585)) + (|x| NIL)) + ((OR (ATOM G167585) + (PROGN + (SETQ |x| (CAR G167585)) + NIL)) + (NREVERSE0 G167580)) + (SEQ (EXIT + (SETQ G167580 + (CONS (|opOf| |x|) G167580)))))))) + (SPADLET |kinds| + (PROG (G167591) + (SPADLET G167591 NIL) + (RETURN + (DO ((G167596 |conlist| (CDR G167596)) + (|x| NIL)) + ((OR (ATOM G167596) + (PROGN + (SETQ |x| (CAR G167596)) + NIL)) + G167591) + (SEQ (EXIT + (SETQ G167591 + (|union| G167591 + (|dbConstructorKind| |x|))))))))) + (SPADLET |kind| + (COND + ((AND (PAIRP |kinds|) + (EQ (QCDR |kinds|) NIL) + (PROGN + (SPADLET |a| (QCAR |kinds|)) + 'T)) + |a|) + ('T '|constructor|))) + (SPADLET |proplist| + (COND + (|htPage| (|htCopyProplist| |htPage|)) + ('T NIL))) + (SPADLET |page| + (|htInitPageNoScroll| |proplist| + (|dbConsHeading| |htPage| |conlist| |key| + |kind|))) + (COND + ((SPADLET |u| + (|htpProperty| |page| '|specialMessage|)) + (APPLY (CAR |u|) (CDR |u|)))) + (|htSayStandard| (MAKESTRING "\\beginscroll ")) + (|htpSetProperty| |page| '|cAlist| |cAlist|) + (SPADLET |$conformsAreDomains| + (|htpProperty| |page| '|domname|)) + (|do| (COND + ((BOOT-EQUAL |key| '|names|) + (|bcNameConTable| |conlist|)) + ((BOOT-EQUAL |key| '|abbrs|) + (|bcAbbTable| + (PROG (G167606) + (SPADLET G167606 NIL) + (RETURN + (DO ((G167611 |conlist| + (CDR G167611)) + (|con| NIL)) + ((OR (ATOM G167611) + (PROGN + (SETQ |con| (CAR G167611)) + NIL)) + (NREVERSE0 G167606)) + (SEQ + (EXIT + (SETQ G167606 + (CONS (|getCDTEntry| |con| 'T) + G167606))))))))) + ((BOOT-EQUAL |key| '|files|) + (SPADLET |flist| + (PROG (G167622) + (SPADLET G167622 NIL) + (RETURN + (DO + ((G167628 |conlist| + (CDR G167628)) + (|con| NIL)) + ((OR (ATOM G167628) + (PROGN + (SETQ |con| (CAR G167628)) + NIL)) + (NREVERSE0 G167622)) + (SEQ + (EXIT + (COND + ((SPADLET |y| + (SPADLET |fn| + (GETDATABASE |con| + 'SOURCEFILE))) + (SETQ G167622 + (CONS |y| G167622)))))))))) + (|bcUnixTable| + (|listSort| (|function| GLESSEQP) + (REMDUP |flist|)))) + ((BOOT-EQUAL |key| '|documentation|) + (|dbShowConsDoc| |page| |conlist|)) + ('T + (COND + (|$exposedOnlyIfTrue| + (SPADLET |cAlist| + (PROG (G167639) + (SPADLET G167639 NIL) + (RETURN + (DO + ((G167645 |cAlist| + (CDR G167645)) + (|x| NIL)) + ((OR (ATOM G167645) + (PROGN + (SETQ |x| + (CAR G167645)) + NIL)) + (NREVERSE0 G167639)) + (SEQ + (EXIT + (COND + ((|isExposedConstructor| + (|opOf| (CAR |x|))) + (SETQ G167639 + (CONS |x| + G167639)))))))))))) + (COND + ((BOOT-EQUAL |key| '|conditions|) + (|dbShowConditions| |page| |cAlist| |kind|)) + ((BOOT-EQUAL |key| '|parameters|) + (|bcConTable| + (REMDUP (ASSOCLEFT |cAlist|)))) + ((BOOT-EQUAL |key| '|kinds|) + (|dbShowConsKinds| |cAlist|)))))) + (|dbConsExposureMessage|) + (|htSayStandard| '|\\endscroll |) + (|dbPresentCons| |page| |kind| |key|) + (|htShowPageNoScroll|)))))))) + +;dbConsExposureMessage() == +; $atLeastOneUnexposed => +; htSay '"\newline{}-------------\newline{}{\em *} = unexposed" + +(DEFUN |dbConsExposureMessage| () + (declare (special |$atLeastOneUnexposed|)) + (SEQ (COND + (|$atLeastOneUnexposed| + (EXIT (|htSay| (MAKESTRING + "\\newline{}-------------\\newline{}{\\em *} = unexposed"))))))) + +;-- DUPLICATE DEF - ALSO in br-saturn.boot +;-- dbShowConsKinds cAlist == +;-- ---------> !OBSELETE! <------------- +;-- cats := doms := paks := defs := nil +;-- for x in cAlist repeat +;-- op := CAAR x +;-- kind := dbConstructorKind op +;-- kind = 'category => cats := [x,:cats] +;-- kind = 'domain => doms := [x,:doms] +;-- kind = 'package => paks:= [x,:paks] +;-- defs := [x,:defs] +;-- lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] +;-- htBeginMenu(2) +;-- htSayStandard '"\indent{1}" +;-- kinds := +/[1 for x in lists | #x > 0] +;-- for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat +;-- htSay('"\item") +;-- if kinds = 1 then htSay menuButton() else +;-- htMakePage [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] +;-- htSayStandard '"\tab{1}" +;-- htSay '"{\em " +;-- htSay (c := #x) +;-- htSay '" " +;-- htSay (c > 1 => pluralize kind; kind) +;-- htSay '":}" +;-- bcConTable REMDUP [CAAR y for y in x] +;-- htEndMenu(2) +;-- htSay '"\indent{0}" +;dbShowConsKindsFilter(htPage,[kind,cAlist]) == +; htpSetProperty(htPage,'cAlist,cAlist) +; dbShowCons(htPage,htpProperty(htPage,'exclusion)) + +(DEFUN |dbShowConsKindsFilter| (|htPage| G167680) + (PROG (|kind| |cAlist|) + (RETURN + (PROGN + (SPADLET |kind| (CAR G167680)) + (SPADLET |cAlist| (CADR G167680)) + (|htpSetProperty| |htPage| '|cAlist| |cAlist|) + (|dbShowCons| |htPage| (|htpProperty| |htPage| '|exclusion|)))))) + +;dbShowConsDoc(htPage,conlist) == +; null rest conlist => dbShowConsDoc1(htPage,getConstructorForm opOf first conlist,nil) +; cAlist := htpProperty(htPage,'cAlist) +; --the following code is necessary to skip over duplicates on cAlist +; index := 0 +; for x in REMDUP conlist repeat +; -- for x in conlist repeat +; dbShowConsDoc1(htPage,getConstructorForm x,i) where i == +; while CAAAR cAlist ^= x repeat +; index := index + 1 +; cAlist := rest cAlist +; null cAlist => systemError () +; index + +(DEFUN |dbShowConsDoc| (|htPage| |conlist|) + (PROG (|index| |cAlist|) + (RETURN + (SEQ (COND + ((NULL (CDR |conlist|)) + (|dbShowConsDoc1| |htPage| + (|getConstructorForm| (|opOf| (CAR |conlist|))) NIL)) + ('T (SPADLET |cAlist| (|htpProperty| |htPage| '|cAlist|)) + (SPADLET |index| 0) + (DO ((G167706 (REMDUP |conlist|) (CDR G167706)) + (|x| NIL)) + ((OR (ATOM G167706) + (PROGN (SETQ |x| (CAR G167706)) NIL)) + NIL) + (SEQ (EXIT (|dbShowConsDoc1| |htPage| + (|getConstructorForm| |x|) + (PROGN + (DO () + ((NULL + (NEQUAL (CAAAR |cAlist|) |x|)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |index| + (PLUS |index| 1)) + (SPADLET |cAlist| + (CDR |cAlist|)) + (COND + ((NULL |cAlist|) + (|systemError|))))))) + |index|))))))))))) + +;dbShowConsDoc1(htPage,conform,indexOrNil) == +; [conname,:conargs] := conform +; MEMQ(conname,$Primitives) => +; conname := htpProperty(htPage,'conname) +; [["constructor",["NIL",doc]],:.] := GET(conname,'documentation) +; sig := '((CATEGORY domain) (SetCategory) (SetCategory)) +; displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,nil,nil) +; exposeFlag := isExposedConstructor conname +; doc := [getConstructorDocumentation conname] +; signature := getConstructorSignature conname +; sig := +; GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => +; SUBLISLIS(conargs,$TriangleVariableList,signature) +; sublisFormal(conargs,signature) +; htSaySaturn '"\begin{description}" +; displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,null exposeFlag,nil) +; htSaySaturn '"\end{description}" + +(DEFUN |dbShowConsDoc1| (|htPage| |conform| |indexOrNil|) + (PROG (|conargs| |conname| |LETTMP#1| |exposeFlag| |doc| |signature| + |sig|) + (declare (special |$TriangleVariableList| |$Primitives|)) + (RETURN + (PROGN + (SPADLET |conname| (CAR |conform|)) + (SPADLET |conargs| (CDR |conform|)) + (COND + ((MEMQ |conname| |$Primitives|) + (SPADLET |conname| (|htpProperty| |htPage| '|conname|)) + (SPADLET |LETTMP#1| (GETL |conname| '|documentation|)) + (COND + ((EQ (CAAR |LETTMP#1|) '|constructor|) (CAAR |LETTMP#1|))) + (COND ((EQ (CAADAR |LETTMP#1|) 'NIL) (CAADAR |LETTMP#1|))) + (SPADLET |doc| (CAR (CDADAR |LETTMP#1|))) + (SPADLET |sig| + '((CATEGORY |domain|) (|SetCategory|) + (|SetCategory|))) + (|displayDomainOp| |htPage| (MAKESTRING "constructor") + |conform| |conname| |sig| 'T |doc| |indexOrNil| + '|dbSelectCon| NIL NIL)) + ('T (SPADLET |exposeFlag| (|isExposedConstructor| |conname|)) + (SPADLET |doc| + (CONS (|getConstructorDocumentation| |conname|) + NIL)) + (SPADLET |signature| (|getConstructorSignature| |conname|)) + (SPADLET |sig| + (COND + ((BOOT-EQUAL + (GETDATABASE |conname| 'CONSTRUCTORKIND) + '|category|) + (SUBLISLIS |conargs| |$TriangleVariableList| + |signature|)) + ('T (|sublisFormal| |conargs| |signature|)))) + (|htSaySaturn| (MAKESTRING "\\begin{description}")) + (|displayDomainOp| |htPage| (MAKESTRING "constructor") + |conform| |conname| |sig| 'T |doc| |indexOrNil| + '|dbSelectCon| (NULL |exposeFlag|) NIL) + (|htSaySaturn| (MAKESTRING "\\end{description}")))))))) + +; --NOTE that we pass conform is as "origin" +;getConstructorDocumentation conname == +; LASSOC('constructor,GETDATABASE(conname,'DOCUMENTATION)) +; is [[nil,line,:.],:.] and line or '"" + +(DEFUN |getConstructorDocumentation| (|conname|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |line|) + (RETURN + (OR (AND (PROGN + (SPADLET |ISTMP#1| + (LASSOC '|constructor| + (GETDATABASE |conname| + 'DOCUMENTATION))) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (NULL (QCAR |ISTMP#2|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |line| (QCAR |ISTMP#3|)) + 'T))))))) + |line|) + (MAKESTRING ""))))) + +;dbSelectCon(htPage,which,index) == +; conPage opOf first htpProperty(htPage,'cAlist) . index + +(DEFUN |dbSelectCon| (|htPage| |which| |index|) + (declare (ignore |which|)) + (|conPage| + (|opOf| (CAR (ELT (|htpProperty| |htPage| '|cAlist|) |index|))))) + +;dbShowConditions(htPage,cAlist,kind) == +; conform := htpProperty(htPage,'conform) +; conname := opOf conform +; article := htpProperty(htPage,'article) +; whichever := htpProperty(htPage,'whichever) +; [consNoPred,:consPred] := splitConTable cAlist +; singular := [kind,'" is"] +; plural := [pluralize STRINGIMAGE kind,'" are"] +; dbSayItems(#consNoPred,singular,plural,'" unconditional") +; htSaySaturn '"\\" +; bcConPredTable(consNoPred,conname) +; htSayHrule() +; dbSayItems(#consPred,singular,plural,'" conditional") +; htSaySaturn '"\\" +; bcConPredTable(consPred,conname) + +(DEFUN |dbShowConditions| (|htPage| |cAlist| |kind|) + (PROG (|conform| |conname| |article| |whichever| |LETTMP#1| + |consNoPred| |consPred| |singular| |plural|) + (RETURN + (PROGN + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |article| (|htpProperty| |htPage| '|article|)) + (SPADLET |whichever| (|htpProperty| |htPage| '|whichever|)) + (SPADLET |LETTMP#1| (|splitConTable| |cAlist|)) + (SPADLET |consNoPred| (CAR |LETTMP#1|)) + (SPADLET |consPred| (CDR |LETTMP#1|)) + (SPADLET |singular| + (CONS |kind| (CONS (MAKESTRING " is") NIL))) + (SPADLET |plural| + (CONS (|pluralize| (STRINGIMAGE |kind|)) + (CONS (MAKESTRING " are") NIL))) + (|dbSayItems| (|#| |consNoPred|) |singular| |plural| + (MAKESTRING " unconditional")) + (|htSaySaturn| (MAKESTRING "\\\\")) + (|bcConPredTable| |consNoPred| |conname|) + (|htSayHrule|) + (|dbSayItems| (|#| |consPred|) |singular| |plural| + (MAKESTRING " conditional")) + (|htSaySaturn| (MAKESTRING "\\\\")) + (|bcConPredTable| |consPred| |conname|))))) + +;dbConsHeading(htPage,conlist,view,kind) == +; thing := htPage and htpProperty(htPage,'thing) or '"constructor" +; place := +; htPage => htpProperty(htPage,'domname) or htpProperty(htPage,'conform) +; nil +; count := #(REMDUP conlist) +; -- count := #conlist +; thing = '"benefactor" => +; [STRINGIMAGE count,'" Constructors Used by ",form2HtString(place,nil,true)] +; modifier := +; thing = '"argument" => +; rank := htPage and htpProperty(htPage,'rank) +; ['" Possible ",rank,'" "] +; kind = 'constructor => ['" "] +; ['" ",capitalize STRINGIMAGE kind,'" "] +;-- count = 1 => +;-- ['"Select name or a {\em view} at the bottom"] +; exposureWord := +; $exposedOnlyIfTrue => '(" Exposed ") +; nil +; prefix := +; count = 1 => [STRINGIMAGE count,:modifier,capitalize thing] +; firstWord := (count = 0 => '"No "; STRINGIMAGE count) +; [firstWord,:exposureWord, :modifier,capitalize pluralize thing] +; placepart := +; place => ['" of {\em ",form2HtString(place,nil,true),"}"] +; nil +; heading := [:prefix,:placepart] +; connective := +; MEMBER(view,'(abbrs files kinds)) => '" as " +; '" with " +; if count ^= 0 and MEMBER(view,'(abbrs files parameters conditions)) then heading:= [:heading,'" viewed",connective,'"{\em ",STRINGIMAGE view,'"}"] +; heading + +(DEFUN |dbConsHeading| (|htPage| |conlist| |view| |kind|) + (PROG (|thing| |place| |count| |rank| |modifier| |exposureWord| + |firstWord| |prefix| |placepart| |connective| + |heading|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (PROGN + (SPADLET |thing| + (OR (AND |htPage| (|htpProperty| |htPage| '|thing|)) + (MAKESTRING "constructor"))) + (SPADLET |place| + (COND + (|htPage| + (OR (|htpProperty| |htPage| '|domname|) + (|htpProperty| |htPage| '|conform|))) + ('T NIL))) + (SPADLET |count| (|#| (REMDUP |conlist|))) + (COND + ((BOOT-EQUAL |thing| (MAKESTRING "benefactor")) + (CONS (STRINGIMAGE |count|) + (CONS (MAKESTRING " Constructors Used by ") + (CONS (|form2HtString| |place| NIL 'T) NIL)))) + ('T + (SPADLET |modifier| + (COND + ((BOOT-EQUAL |thing| (MAKESTRING "argument")) + (SPADLET |rank| + (AND |htPage| + (|htpProperty| |htPage| '|rank|))) + (CONS (MAKESTRING " Possible ") + (CONS |rank| (CONS (MAKESTRING " ") NIL)))) + ((BOOT-EQUAL |kind| '|constructor|) + (CONS (MAKESTRING " ") NIL)) + ('T + (CONS (MAKESTRING " ") + (CONS (|capitalize| (STRINGIMAGE |kind|)) + (CONS (MAKESTRING " ") NIL)))))) + (SPADLET |exposureWord| + (COND + (|$exposedOnlyIfTrue| '(" Exposed ")) + ('T NIL))) + (SPADLET |prefix| + (COND + ((EQL |count| 1) + (CONS (STRINGIMAGE |count|) + (APPEND |modifier| + (CONS (|capitalize| |thing|) NIL)))) + ('T + (SPADLET |firstWord| + (COND + ((EQL |count| 0) (MAKESTRING "No ")) + ('T (STRINGIMAGE |count|)))) + (CONS |firstWord| + (APPEND |exposureWord| + (APPEND |modifier| + (CONS + (|capitalize| + (|pluralize| |thing|)) + NIL))))))) + (SPADLET |placepart| + (COND + (|place| (CONS (MAKESTRING " of {\\em ") + (CONS + (|form2HtString| |place| NIL 'T) + (CONS '} NIL)))) + ('T NIL))) + (SPADLET |heading| (APPEND |prefix| |placepart|)) + (SPADLET |connective| + (COND + ((|member| |view| '(|abbrs| |files| |kinds|)) + (MAKESTRING " as ")) + ('T (MAKESTRING " with ")))) + (COND + ((AND (NEQUAL |count| 0) + (|member| |view| + '(|abbrs| |files| |parameters| |conditions|))) + (SPADLET |heading| + (APPEND |heading| + (CONS (MAKESTRING " viewed") + (CONS |connective| + (CONS (MAKESTRING "{\\em ") + (CONS (STRINGIMAGE |view|) + (CONS (MAKESTRING "}") NIL))))))))) + |heading|)))))) + +;dbShowConstructorLines lines == +; cAlist := [[getConstructorForm intern dbName line,:true] for line in lines] +; dbShowCons1(nil,listSort(function GLESSEQP,cAlist),'names) + +(DEFUN |dbShowConstructorLines| (|lines|) + (PROG (|cAlist|) + (RETURN + (SEQ (PROGN + (SPADLET |cAlist| + (PROG (G167833) + (SPADLET G167833 NIL) + (RETURN + (DO ((G167838 |lines| (CDR G167838)) + (|line| NIL)) + ((OR (ATOM G167838) + (PROGN + (SETQ |line| (CAR G167838)) + NIL)) + (NREVERSE0 G167833)) + (SEQ (EXIT (SETQ G167833 + (CONS + (CONS + (|getConstructorForm| + (|intern| (|dbName| |line|))) + 'T) + G167833)))))))) + (|dbShowCons1| NIL + (|listSort| (|function| GLESSEQP) |cAlist|) '|names|)))))) + +;bcUnixTable(u) == +; htSay '"\newline" +; htBeginTable() +; firstTime := true +; for x in u repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; htSay '"{" +; ft := +; isAsharpFileName? x => '("AS") +; '("SPAD") +; filename := NAMESTRING $FINDFILE(STRINGIMAGE x, ft) +; htMakePage [['text, '"\unixcommand{",PATHNAME_-NAME x, '"}{$AXIOM/lib/SPADEDIT ", filename, '"} "]] +; htSay '"}" +; htEndTable() + +(DEFUN |bcUnixTable| (|u|) + (PROG (|firstTime| |ft| |filename|) + (RETURN + (SEQ (PROGN + (|htSay| (MAKESTRING "\\newline")) + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G167861 |u| (CDR G167861)) (|x| NIL)) + ((OR (ATOM G167861) + (PROGN (SETQ |x| (CAR G167861)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (|htSay| (MAKESTRING "{")) + (SPADLET |ft| + (COND + ((|isAsharpFileName?| |x|) + '("AS")) + ('T '("SPAD")))) + (SPADLET |filename| + (NAMESTRING + ($FINDFILE (STRINGIMAGE |x|) + |ft|))) + (|htMakePage| + (CONS (CONS '|text| + (CONS + (MAKESTRING "\\unixcommand{") + (CONS (PATHNAME-NAME |x|) + (CONS + (MAKESTRING + "}{$AXIOM/lib/SPADEDIT ") + (CONS |filename| + (CONS (MAKESTRING "} ") NIL)))))) + NIL)) + (|htSay| (MAKESTRING "}")))))) + (|htEndTable|)))))) + +;isAsharpFileName? con == false + +(DEFUN |isAsharpFileName?| (|con|) + (declare (ignore |con|)) + NIL) + +;--======================================================================= +;-- Special Code for Union, Mapping, and Record +;--======================================================================= +;dbSpecialDescription(conname) == +; conform := getConstructorForm conname +; heading := ['"Description of Domain {\sf ",form2HtString conform,'"}"] +; page := htInitPage(heading,nil) +; htpSetProperty(page,'conname,conname) +; $conformsAreDomains := nil +; dbShowConsDoc1(page,conform,nil) +; htShowPage() + +(DEFUN |dbSpecialDescription| (|conname|) + (PROG (|conform| |heading| |page|) + (declare (special |$conformsAreDomains|)) + (RETURN + (PROGN + (SPADLET |conform| (|getConstructorForm| |conname|)) + (SPADLET |heading| + (CONS (MAKESTRING "Description of Domain {\\sf ") + (CONS (|form2HtString| |conform|) + (CONS (MAKESTRING "}") NIL)))) + (SPADLET |page| (|htInitPage| |heading| NIL)) + (|htpSetProperty| |page| '|conname| |conname|) + (SPADLET |$conformsAreDomains| NIL) + (|dbShowConsDoc1| |page| |conform| NIL) + (|htShowPage|))))) + +;dbSpecialOperations(conname) == +; page := htInitPage(nil,nil) +; conform := getConstructorForm conname +; opAlist := dbSpecialExpandIfNecessary(conform,rest GET(conname,'documentation)) +; fromHeading := ['" from domain {\sf ",form2HtString conform,'"}"] +; htpSetProperty(page,'fromHeading,fromHeading) +; htpSetProperty(page,'conform,conform) +; htpSetProperty(page,'opAlist,opAlist) +; htpSetProperty(page,'noUsage,true) +; htpSetProperty(page,'condition?,'no) +; dbShowOp1(page,opAlist,'"operation",'names) + +(DEFUN |dbSpecialOperations| (|conname|) + (PROG (|page| |conform| |opAlist| |fromHeading|) + (RETURN + (PROGN + (SPADLET |page| (|htInitPage| NIL NIL)) + (SPADLET |conform| (|getConstructorForm| |conname|)) + (SPADLET |opAlist| + (|dbSpecialExpandIfNecessary| |conform| + (CDR (GETL |conname| '|documentation|)))) + (SPADLET |fromHeading| + (CONS (MAKESTRING " from domain {\\sf ") + (CONS (|form2HtString| |conform|) + (CONS (MAKESTRING "}") NIL)))) + (|htpSetProperty| |page| '|fromHeading| |fromHeading|) + (|htpSetProperty| |page| '|conform| |conform|) + (|htpSetProperty| |page| '|opAlist| |opAlist|) + (|htpSetProperty| |page| '|noUsage| 'T) + (|htpSetProperty| |page| '|condition?| '|no|) + (|dbShowOp1| |page| |opAlist| (MAKESTRING "operation") + '|names|))))) + +;dbSpecialExports(conname) == +; conform := getConstructorForm conname +; page := htInitPage(['"Exports of {\sf ",form2HtString conform,'"}"],nil) +; opAlist := dbSpecialExpandIfNecessary(conform,rest GET(conname,'documentation)) +; kePageDisplay(page,'"operation",opAlist) +; htShowPage() + +(DEFUN |dbSpecialExports| (|conname|) + (PROG (|conform| |page| |opAlist|) + (RETURN + (PROGN + (SPADLET |conform| (|getConstructorForm| |conname|)) + (SPADLET |page| + (|htInitPage| + (CONS (MAKESTRING "Exports of {\\sf ") + (CONS (|form2HtString| |conform|) + (CONS (MAKESTRING "}") NIL))) + NIL)) + (SPADLET |opAlist| + (|dbSpecialExpandIfNecessary| |conform| + (CDR (GETL |conname| '|documentation|)))) + (|kePageDisplay| |page| (MAKESTRING "operation") |opAlist|) + (|htShowPage|))))) + +;dbSpecialExpandIfNecessary(conform,opAlist) == +; opAlist is [[op,[sig,:r],:.],:.] and rest r => opAlist +; for [op,:u] in opAlist repeat +; for pair in u repeat +; [sig,comments] := pair +; RPLACD(pair,['T,conform,'T,comments]) --[sig,pred,origin,exposeFg,doc] +; opAlist + +(DEFUN |dbSpecialExpandIfNecessary| (|conform| |opAlist|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |r| |op| |u| |sig| |comments|) + (RETURN + (SEQ (COND + ((AND (PAIRP |opAlist|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |opAlist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#3|)) + (SPADLET |r| (QCDR |ISTMP#3|)) + 'T))))))) + (CDR |r|)) + |opAlist|) + ('T + (DO ((G167949 |opAlist| (CDR G167949)) + (G167937 NIL)) + ((OR (ATOM G167949) + (PROGN (SETQ G167937 (CAR G167949)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G167937)) + (SPADLET |u| (CDR G167937)) + G167937) + NIL)) + NIL) + (SEQ (EXIT (DO ((G167962 |u| (CDR G167962)) + (|pair| NIL)) + ((OR (ATOM G167962) + (PROGN + (SETQ |pair| (CAR G167962)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |sig| (CAR |pair|)) + (SPADLET |comments| + (CADR |pair|)) + (RPLACD |pair| + (CONS 'T + (CONS |conform| + (CONS 'T + (CONS |comments| NIL)))))))))))) + |opAlist|)))))) + +;X := '"{\sf Record(a:A,b:B)} is used to create the class of pairs of objects made up of a value of type {\em A} selected by the symbol {\em a} and a value of type {\em B} selected by the symbol {\em b}. " + +(SPADLET X + (MAKESTRING + "{\\sf Record(a:A,b:B)} is used to create the class of pairs of objects made up of a value of type {\\em A} selected by the symbol {\\em a} and a value of type {\\em B} selected by the symbol {\\em b}. ")) + +;Y := '"In general, the {\sf Record} constructor can take any number of arguments and thus can be used to create aggregates of heterogeneous components of arbitrary size selectable by name. " + +(SPADLET Y + (MAKESTRING + "In general, the {\\sf Record} constructor can take any number of arguments and thus can be used to create aggregates of heterogeneous components of arbitrary size selectable by name. ")) + +;Z := '"{\sf Record} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +(SPADLET Z + (MAKESTRING + "{\\sf Record} is a primitive domain of \\Language{} which cannot be defined in the \\Language{} language.")) + +;MESSAGE := STRCONC(X,Y,Z) + +(SPADLET MESSAGE (STRCONC X Y Z)) + +;PUT('Record,'documentation,SUBST(MESSAGE,'MESSAGE,'( +; (constructor (NIL MESSAGE)) +; (_= (((Boolean) _$ _$) +; "\spad{r = s} tests for equality of two records \spad{r} and \spad{s}")) +; (coerce (((OutputForm) _$) +; "\spad{coerce(r)} returns an representation of \spad{r} as an output form") +; ((_$ (List (Any))) +; "\spad{coerce(u)}, where \spad{u} is the list \spad{[x,y]} for \spad{x} of type \spad{A} and \spad{y} of type \spad{B}, returns the record \spad{[a:x,b:y]}")) +; (elt ((A $ "a") +; "\spad{r . a} returns the value stored in record \spad{r} under selector \spad{a}.") +; ((B $ "b") +; "\spad{r . b} returns the value stored in record \spad{r} under selector \spad{b}.")) +; (setelt ((A $ "a" A) +; "\spad{r . a := x} destructively replaces the value stored in record \spad{r} under selector \spad{a} by the value of \spad{x}. Error: if \spad{r} has not been previously assigned a value.") +; ((B $ "b" B) +; "\spad{r . b := y} destructively replaces the value stored in record \spad{r} under selector \spad{b} by the value of \spad{y}. Error: if \spad{r} has not been previously assigned a value.")) +; ))) + +(PUT '|Record| '|documentation| + (MSUBST MESSAGE 'MESSAGE + '((|constructor| (NIL MESSAGE)) + (= (((|Boolean|) $ $) + "\\spad{r = s} tests for equality of two records \\spad{r} and \\spad{s}")) + (|coerce| + (((|OutputForm|) $) + "\\spad{coerce(r)} returns an representation of \\spad{r} as an output form") + (($ (|List| (|Any|))) + "\\spad{coerce(u)}, where \\spad{u} is the list \\spad{[x,y]} for \\spad{x} of type \\spad{A} and \\spad{y} of type \\spad{B}, returns the record \\spad{[a:x,b:y]}")) + (|elt| ((A $ "a") + "\\spad{r . a} returns the value stored in record \\spad{r} under selector \\spad{a}.") + ((B $ "b") + "\\spad{r . b} returns the value stored in record \\spad{r} under selector \\spad{b}.")) + (|setelt| + ((A $ "a" A) + "\\spad{r . a := x} destructively replaces the value stored in record \\spad{r} under selector \\spad{a} by the value of \\spad{x}. Error: if \\spad{r} has not been previously assigned a value.") + ((B $ "b" B) + "\\spad{r . b := y} destructively replaces the value stored in record \\spad{r} under selector \\spad{b} by the value of \\spad{y}. Error: if \\spad{r} has not been previously assigned a value."))))) + +;X := '"{\sf Union(A,B)} denotes the class of objects which are which are either members of domain {\em A} or of domain {\em B}. The {\sf Union} constructor can take any number of arguments. " + +(SPADLET X + (MAKESTRING + "{\\sf Union(A,B)} denotes the class of objects which are which are either members of domain {\\em A} or of domain {\\em B}. The {\\sf Union} constructor can take any number of arguments. ")) + +;Y := '"For an alternate form of {\sf Union} with _"tags_", see \downlink{Union(a:A,b:B)}{DomainUnion}. {\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +(SPADLET Y + (MAKESTRING + "For an alternate form of {\\sf Union} with \"tags\", see \\downlink{Union(a:A,b:B)}{DomainUnion}. {\\sf Union} is a primitive domain of \\Language{} which cannot be defined in the \\Language{} language.")) + +;MESSAGE := STRCONC(X,Y) + +(SPADLET MESSAGE (STRCONC X Y)) + +;PUT('UntaggedUnion,'documentation,SUBST(MESSAGE,'MESSAGE,'( +; (constructor (NIL MESSAGE)) +; (_= (((Boolean) $ $) +; "\spad{u = v} tests if two objects of the union are equal, that is, u and v are hold objects of same branch which are equal.")) +; (case (((Boolean) $ "A") +; "\spad{u case A} tests if \spad{u} is of the type \spad{A} branch of the union.") +; (((Boolean) $ "B") +; "\spad{u case B} tests if \spad{u} is of the \spad{B} branch of the union.")) +; (coerce ((A $) +; "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of the \spad{A} branch of the union. Error: if \spad{u} is of the \spad{B} branch of the union.") +; ((B $) +; "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of the \spad{B} branch of the union. Error: if \spad{u} is of the \spad{A} branch of the union.") +; (($ A) +; "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") +; (($ B) +; "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) +; ))) + +(PUT '|UntaggedUnion| '|documentation| + (MSUBST MESSAGE 'MESSAGE + '((|constructor| (NIL MESSAGE)) + (= (((|Boolean|) $ $) + "\\spad{u = v} tests if two objects of the union are equal, that is, u and v are hold objects of same branch which are equal.")) + (|case| (((|Boolean|) $ "A") + "\\spad{u case A} tests if \\spad{u} is of the type \\spad{A} branch of the union.") + (((|Boolean|) $ "B") + "\\spad{u case B} tests if \\spad{u} is of the \\spad{B} branch of the union.")) + (|coerce| + ((A $) + "\\spad{coerce(u)} returns \\spad{x} of type \\spad{A} if \\spad{x} is of the \\spad{A} branch of the union. Error: if \\spad{u} is of the \\spad{B} branch of the union.") + ((B $) + "\\spad{coerce(u)} returns \\spad{x} of type \\spad{B} if \\spad{x} is of the \\spad{B} branch of the union. Error: if \\spad{u} is of the \\spad{A} branch of the union.") + (($ A) + "\\spad{coerce(x)}, where \\spad{x} has type \\spad{A}, returns \\spad{x} as a union type.") + (($ B) + "\\spad{coerce(y)}, where \\spad{y} has type \\spad{B}, returns \\spad{y} as a union type."))))) + +;X := '"{\sf Union(a:A,b:B)} denotes the class of objects which are either members of domain {\em A} or of domain {\em B}. " + +(SPADLET X + (MAKESTRING + "{\\sf Union(a:A,b:B)} denotes the class of objects which are either members of domain {\\em A} or of domain {\\em B}. ")) + +;Y := '"The symbols {\em a} and {\em b} are called _"tags_" and are used to identify the two _"branches_" of the union. " + +(SPADLET Y + (MAKESTRING + "The symbols {\\em a} and {\\em b} are called \"tags\" and are used to identify the two \"branches\" of the union. ")) + +;Z := '"The {\sf Union} constructor can take any number of arguments and has an alternate form without {\em tags} (see \downlink{Union(A,B)}{UntaggedUnion}). " + +(SPADLET Z + (MAKESTRING + "The {\\sf Union} constructor can take any number of arguments and has an alternate form without {\\em tags} (see \\downlink{Union(A,B)}{UntaggedUnion}). ")) + +;W := '"This tagged {\sf Union} type is necessary, for example, to disambiguate two branches of a union where {\em A} and {\em B} denote the same type. " + +(SPADLET W + (MAKESTRING + "This tagged {\\sf Union} type is necessary, for example, to disambiguate two branches of a union where {\\em A} and {\\em B} denote the same type. ")) + +;A := '"{\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +(SPADLET A + (MAKESTRING + "{\\sf Union} is a primitive domain of \\Language{} which cannot be defined in the \\Language{} language.")) + +;MESSAGE := STRCONC(X,Y,Z,W,A) + +(SPADLET MESSAGE (STRCONC X Y Z W A)) + +;PUT('Union,'documentation,SUBST(MESSAGE,'MESSAGE,'( +; (constructor (NIL MESSAGE)) +; (_= (((Boolean) $ $) +; "\spad{u = v} tests if two objects of the union are equal, that is, \spad{u} and \spad{v} are objects of same branch which are equal.")) +; (case (((Boolean) $ "A") +; "\spad{u case a} tests if \spad{u} is of branch \spad{a} of the union.") +; (((Boolean) $ "B") +; "\spad{u case b} tests if \spad{u} is of branch \spad{b} of the union.")) +; (coerce ((A $) +; "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of branch \spad{a} of the union. Error: if \spad{u} is of branch \spad{b} of the union.") +; ((B $) +; "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of branch \spad{b} branch of the union. Error: if \spad{u} is of the \spad{a} branch of the union.") +; (($ A) +; "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") +; (($ B) +; "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) +; ))) + +(PUT '|Union| '|documentation| + (MSUBST MESSAGE 'MESSAGE + '((|constructor| (NIL MESSAGE)) + (= (((|Boolean|) $ $) + "\\spad{u = v} tests if two objects of the union are equal, that is, \\spad{u} and \\spad{v} are objects of same branch which are equal.")) + (|case| (((|Boolean|) $ "A") + "\\spad{u case a} tests if \\spad{u} is of branch \\spad{a} of the union.") + (((|Boolean|) $ "B") + "\\spad{u case b} tests if \\spad{u} is of branch \\spad{b} of the union.")) + (|coerce| + ((A $) + "\\spad{coerce(u)} returns \\spad{x} of type \\spad{A} if \\spad{x} is of branch \\spad{a} of the union. Error: if \\spad{u} is of branch \\spad{b} of the union.") + ((B $) + "\\spad{coerce(u)} returns \\spad{x} of type \\spad{B} if \\spad{x} is of branch \\spad{b} branch of the union. Error: if \\spad{u} is of the \\spad{a} branch of the union.") + (($ A) + "\\spad{coerce(x)}, where \\spad{x} has type \\spad{A}, returns \\spad{x} as a union type.") + (($ B) + "\\spad{coerce(y)}, where \\spad{y} has type \\spad{B}, returns \\spad{y} as a union type."))))) + +;X := '"{\sf Mapping(T,S,...)} denotes the class of objects which are mappings from a source domain ({\em S,...}) into a target domain {\em T}. The {\sf Mapping} constructor can take any number of arguments." + +(SPADLET X + (MAKESTRING + "{\\sf Mapping(T,S,...)} denotes the class of objects which are mappings from a source domain ({\\em S,...}) into a target domain {\\em T}. The {\\sf Mapping} constructor can take any number of arguments.")) + +;Y := '" All but the first argument is regarded as part of a source tuple for the mapping. For example, {\sf Mapping(T,A,B)} denotes the class of mappings from {\em (A,B)} into {\em T}. " + +(SPADLET Y + (MAKESTRING + " All but the first argument is regarded as part of a source tuple for the mapping. For example, {\\sf Mapping(T,A,B)} denotes the class of mappings from {\\em (A,B)} into {\\em T}. ")) + +;Z := '"{\sf Mapping} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +(SPADLET Z + (MAKESTRING + "{\\sf Mapping} is a primitive domain of \\Language{} which cannot be defined in the \\Language{} language.")) + +;MESSAGE := STRCONC(X,Y,Z) + +(SPADLET MESSAGE (STRCONC X Y Z)) + +;PUT('Mapping,'documentation, SUBST(MESSAGE,'MESSAGE,'( +; (constructor (NIL MESSAGE)) +; (_= (((Boolean) $ $) +; "\spad{u = v} tests if mapping objects are equal.")) +; ))) + +(PUT '|Mapping| '|documentation| + (MSUBST MESSAGE 'MESSAGE + '((|constructor| (NIL MESSAGE)) + (= (((|Boolean|) $ $) + "\\spad{u = v} tests if mapping objects are equal."))))) + +;X := '"{\em Enumeration(a1, a2 ,..., aN)} creates an object which is exactly one of the N symbols {\em a1}, {\em a2}, ..., or {\em aN}, N > 0. " + +(SPADLET X + (MAKESTRING + "{\\em Enumeration(a1, a2 ,..., aN)} creates an object which is exactly one of the N symbols {\\em a1}, {\\em a2}, ..., or {\\em aN}, N > 0. ")) + +;Y := '" The {\em Enumeration} can constructor can take any number of symbols as arguments." + +(SPADLET Y + (MAKESTRING + " The {\\em Enumeration} can constructor can take any number of symbols as arguments.")) + +;MESSAGE := STRCONC(X, Y) + +(SPADLET MESSAGE (STRCONC X Y)) + +;PUT('Enumeration, 'documentation, SUBST(MESSAGE, 'MESSAGE, '( +; (constructor (NIL MESSAGE)) +; (_= (((Boolean) _$ _$) +; "\spad{e = f} tests for equality of two enumerations \spad{e} and \spad{f}")) +; (_^_= (((Boolean) _$ _$) +; "\spad{e ^= f} tests that two enumerations \spad{e} and \spad{f} are nont equal")) +; (coerce (((OutputForm) _$) +; "\spad{coerce(e)} returns a representation of enumeration \spad{r} as an output form") +; ((_$ (Symbol)) +; "\spad{coerce(s)} converts a symbol \spad{s} into an enumeration which has \spad{s} as a member symbol")) +; ))) + +(PUT '|Enumeration| '|documentation| + (MSUBST MESSAGE 'MESSAGE + '((|constructor| (NIL MESSAGE)) + (= (((|Boolean|) $ $) + "\\spad{e = f} tests for equality of two enumerations \\spad{e} and \\spad{f}")) + (^= (((|Boolean|) $ $) + "\\spad{e ^= f} tests that two enumerations \\spad{e} and \\spad{f} are nont equal")) + (|coerce| + (((|OutputForm|) $) + "\\spad{coerce(e)} returns a representation of enumeration \\spad{r} as an output form") + (($ (|Symbol|)) + "\\spad{coerce(s)} converts a symbol \\spad{s} into an enumeration which has \\spad{s} as a member symbol"))))) + +;mkConArgSublis args == +; [[arg,:INTERN digits2Names PNAME arg] for arg in args +; | (s := PNAME arg) and or/[DIGITP ELT(s,i) for i in 0..MAXINDEX s]] + +(DEFUN |mkConArgSublis| (|args|) + (PROG (|s|) + (RETURN + (SEQ (PROG (G167986) + (SPADLET G167986 NIL) + (RETURN + (DO ((G167992 |args| (CDR G167992)) (|arg| NIL)) + ((OR (ATOM G167992) + (PROGN (SETQ |arg| (CAR G167992)) NIL)) + (NREVERSE0 G167986)) + (SEQ (EXIT (COND + ((AND (SPADLET |s| (PNAME |arg|)) + (PROG (G167998) + (SPADLET G167998 NIL) + (RETURN + (DO + ((G168004 NIL G167998) + (G168005 (MAXINDEX |s|)) + (|i| 0 (QSADD1 |i|))) + ((OR G168004 + (QSGREATERP |i| G168005)) + G167998) + (SEQ + (EXIT + (SETQ G167998 + (OR G167998 + (DIGITP (ELT |s| |i|)))))))))) + (SETQ G167986 + (CONS + (CONS |arg| + (INTERN + (|digits2Names| (PNAME |arg|)))) + G167986))))))))))))) + +;digits2Names s == +;--This is necessary since arguments of conforms CANNOT have digits in TechExplorer +; str := '"" +; for i in 0..MAXINDEX s repeat +; c := s.i +; segment := +; n := DIGIT_-CHAR_-P c => +; ('("Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine")).n +; c +; CONCAT(str, segment) +; str + +(DEFUN |digits2Names| (|s|) + (PROG (|str| |c| |n| |segment|) + (RETURN + (SEQ (PROGN + (SPADLET |str| (MAKESTRING "")) + (DO ((G168025 (MAXINDEX |s|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G168025) NIL) + (SEQ (EXIT (PROGN + (SPADLET |c| (ELT |s| |i|)) + (SPADLET |segment| + (COND + ((SPADLET |n| + (DIGIT-CHAR-P |c|)) + (ELT + '("Zero" "One" "Two" "Three" + "Four" "Five" "Six" "Seven" + "Eight" "Nine") + |n|)) + ('T |c|))) + (CONCAT |str| |segment|))))) + |str|))))) + +;lefts u == +; [x for x in HKEYS _*HASCATEGORY_-HASH_* | CDR x = u] + +(DEFUN |lefts| (|u|) + (PROG () + (declare (special *HASCATEGORY-HASH*)) + (RETURN + (SEQ (PROG (G168041) + (SPADLET G168041 NIL) + (RETURN + (DO ((G168047 (HKEYS *HASCATEGORY-HASH*) + (CDR G168047)) + (|x| NIL)) + ((OR (ATOM G168047) + (PROGN (SETQ |x| (CAR G168047)) NIL)) + (NREVERSE0 G168041)) + (SEQ (EXIT (COND + ((BOOT-EQUAL (CDR |x|) |u|) + (SETQ G168041 (CONS |x| G168041))))))))))))) + +;--====================> WAS b-data.boot <================================ +;--============================================================================ +;-- Build Library Database (libdb.text,...) +;--============================================================================ +;--Formal for libdb.text: +;-- 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 = +;buildLibdb(:options) == --called by make-databases (daase.lisp.pamphlet) +; domainList := IFCAR options --build local libdb if list of domains is given +; $OpLst: local := nil +; $AttrLst: local := nil +; $DomLst : local := nil +; $CatLst : local := nil +; $PakLst : local := nil +; $DefLst : local := nil +; deleteFile '"temp.text" +; $outStream: local := MAKE_-OUTSTREAM '"temp.text" +; if null domainList then +; comments := +; '"\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 ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'UNION,comments] +; comments := +; '"\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 ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] +; comments := +; '"\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 ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] +; comments := +; '"\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 ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] +; $conname: local := nil +; $conform: local := nil +; $exposed?:local := nil +; $doc: local := nil +; $kind: local := nil +; constructorList := domainList or allConstructors() +; for con in constructorList repeat +; writedb buildLibdbConEntry con +; [attrlist,:oplist] := getConstructorExports $conform +; buildLibOps oplist +; buildLibAttrs attrlist +; SHUT $outStream +; domainList => 'done --leave new database in temp.text +; OBEY +; $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_" > _"libdb.text_"" +; $machineType = 'SPARC => '"sort -f _"temp.text_" > _"libdb.text_"" +; '"sort _"temp.text_" > _"libdb.text_"" +; --OBEY '"mv libdb.text olibdb.text" +; RENAME_-FILE('"libdb.text", '"olibdb.text") +; deleteFile '"temp.text" + +(DEFUN |buildLibdb| (&REST G168131 &AUX |options|) + (DSETQ |options| G168131) + (PROG (|$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| |$DefLst| + |$outStream| |$conname| |$conform| |$exposed?| |$doc| + |$kind| |domainList| |comments| |constructorList| + |LETTMP#1| |attrlist| |oplist|) + (DECLARE (SPECIAL |$OpLst| |$AttrLst| |$DomLst| |$CatLst| |$PakLst| + |$DefLst| |$outStream| |$conname| |$conform| + |$exposed?| |$doc| |$kind| |$machineType|)) + (RETURN + (SEQ (PROGN + (SPADLET |domainList| (IFCAR |options|)) + (SPADLET |$OpLst| NIL) + (SPADLET |$AttrLst| NIL) + (SPADLET |$DomLst| NIL) + (SPADLET |$CatLst| NIL) + (SPADLET |$PakLst| NIL) + (SPADLET |$DefLst| NIL) + (|deleteFile| (MAKESTRING "temp.text")) + (SPADLET |$outStream| + (MAKE-OUTSTREAM (MAKESTRING "temp.text"))) + (COND + ((NULL |domainList|) + (SPADLET |comments| + (MAKESTRING + "\\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| + (CONS (MAKESTRING "dUnion") + (CONS 1 + (CONS (MAKESTRING "x") + (CONS (MAKESTRING "special") + (CONS (MAKESTRING "(A,B,...,C)") + (CONS 'UNION + (CONS |comments| NIL))))))))) + (SPADLET |comments| + (MAKESTRING + "\\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| + (CONS (MAKESTRING "dRecord") + (CONS 1 + (CONS (MAKESTRING "x") + (CONS (MAKESTRING "special") + (CONS + (MAKESTRING "(a:A,b:B,...,c:C)") + (CONS 'RECORD + (CONS |comments| NIL))))))))) + (SPADLET |comments| + (MAKESTRING "\\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| + (CONS (MAKESTRING "dMapping") + (CONS 1 + (CONS (MAKESTRING "x") + (CONS (MAKESTRING "special") + (CONS (MAKESTRING "(T,S)") + (CONS 'MAPPING + (CONS |comments| NIL))))))))) + (SPADLET |comments| + (MAKESTRING + "\\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| + (CONS (MAKESTRING "dEnumeration") + (CONS 1 + (CONS (MAKESTRING "x") + (CONS (MAKESTRING "special") + (CONS (MAKESTRING "(a,b,...,c)") + (CONS 'ENUM + (CONS |comments| NIL))))))))))) + (SPADLET |$conname| NIL) + (SPADLET |$conform| NIL) + (SPADLET |$exposed?| NIL) + (SPADLET |$doc| NIL) + (SPADLET |$kind| NIL) + (SPADLET |constructorList| + (OR |domainList| (|allConstructors|))) + (DO ((G168077 |constructorList| (CDR G168077)) + (|con| NIL)) + ((OR (ATOM G168077) + (PROGN (SETQ |con| (CAR G168077)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|writedb| (|buildLibdbConEntry| |con|)) + (SPADLET |LETTMP#1| + (|getConstructorExports| + |$conform|)) + (SPADLET |attrlist| (CAR |LETTMP#1|)) + (SPADLET |oplist| (CDR |LETTMP#1|)) + (|buildLibOps| |oplist|) + (|buildLibAttrs| |attrlist|))))) + (SHUT |$outStream|) + (COND + (|domainList| '|done|) + ('T + (OBEY (COND + ((BOOT-EQUAL |$machineType| 'RIOS) + (MAKESTRING + "sort -f -T /tmp -y200 \"temp.text\" > \"libdb.text\"")) + ((BOOT-EQUAL |$machineType| 'SPARC) + (MAKESTRING + "sort -f \"temp.text\" > \"libdb.text\"")) + ('T + (MAKESTRING + "sort \"temp.text\" > \"libdb.text\"")))) + (RENAME-FILE (MAKESTRING "libdb.text") + (MAKESTRING "olibdb.text")) + (|deleteFile| (MAKESTRING "temp.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|) + (MAKESTRING "x")) + ('T (MAKESTRING "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 (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |t| (QCAR |ISTMP#3|)) + 'T))))))) + (PAIRP |t|) (EQ (QCAR |t|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |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 (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQUAL (QCAR |ISTMP#2|) NIL) + (PROGN + (SPADLET |r| (QCDR |ISTMP#2|)) + 'T))))) + (|libdbTrim| (|concatWithBlanks| |r|))) + ('T (MAKESTRING "")))) + (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 (MAKESTRING "`") + (STRINGIMAGE |y|))))))))))))))) + +;libConstructorSig [conname,:argl] == +; [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) +; formals := TAKE(#argl,$FormalMapVariableList) +; sig := SUBLISLIS(formals,$TriangleVariableList,sig) +; keys := [g(f,sig,i) for f in formals for i in 1..] where +; g(x,u,i) == --does x appear in any but i-th element of u? +; or/[CONTAINED(x,y) for y in u for j in 1.. | j ^= i] +; sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where +; fn x == +; atom x => x +; x is ['Join,a,:r] => ['Join,fn a,'etc] +; x is ['CATEGORY,:.] => 'etc +; [fn y for y in x] +; sig := [first sig,:[(k => [":",a,s]; s) +; for a in argl for s in rest sig for k in keys]] +; sigpart:= form2LispString ['Mapping,:sig] +; if null ncParseFromString sigpart then +; sayBrightly ['"Won't parse: ",sigpart] +; sigpart + +(DEFUN |libConstructorSig,g| (|x| |u| |i|) + (PROG () + (RETURN + (SEQ (PROG (G168226) + (SPADLET G168226 NIL) + (RETURN + (DO ((G168234 NIL G168226) + (G168235 |u| (CDR G168235)) (|y| NIL) + (|j| 1 (QSADD1 |j|))) + ((OR G168234 (ATOM G168235) + (PROGN (SETQ |y| (CAR G168235)) NIL)) + G168226) + (SEQ (EXIT (COND + ((NEQUAL |j| |i|) + (SETQ G168226 + (OR G168226 (CONTAINED |x| |y|)))))))))))))) + +(DEFUN |libConstructorSig,fn| (|x|) + (PROG (|ISTMP#1| |a| |r|) + (RETURN + (SEQ (IF (ATOM |x|) (EXIT |x|)) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|Join|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (EXIT (CONS '|Join| + (CONS (|libConstructorSig,fn| |a|) + (CONS '|etc| NIL))))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'CATEGORY)) + (EXIT '|etc|)) + (EXIT (PROG (G168260) + (SPADLET G168260 NIL) + (RETURN + (DO ((G168265 |x| (CDR G168265)) (|y| NIL)) + ((OR (ATOM G168265) + (PROGN (SETQ |y| (CAR G168265)) NIL)) + (NREVERSE0 G168260)) + (SEQ (EXIT (SETQ G168260 + (CONS + (|libConstructorSig,fn| |y|) + G168260)))))))))))) + +(DEFUN |libConstructorSig| (G168281) + (PROG (|conname| |argl| |LETTMP#1| |formals| |keys| |sig| |sigpart|) + (declare (special |$TriangleVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |conname| (CAR G168281)) + (SPADLET |argl| (CDR G168281)) + (SPADLET |LETTMP#1| + (GETDATABASE |conname| 'CONSTRUCTORMODEMAP)) + (SPADLET |sig| (CDAR |LETTMP#1|)) + (SPADLET |formals| + (TAKE (|#| |argl|) |$FormalMapVariableList|)) + (SPADLET |sig| + (SUBLISLIS |formals| |$TriangleVariableList| + |sig|)) + (SPADLET |keys| + (PROG (G168298) + (SPADLET G168298 NIL) + (RETURN + (DO ((G168304 |formals| (CDR G168304)) + (|f| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G168304) + (PROGN + (SETQ |f| (CAR G168304)) + NIL)) + (NREVERSE0 G168298)) + (SEQ (EXIT (SETQ G168298 + (CONS + (|libConstructorSig,g| |f| + |sig| |i|) + G168298)))))))) + (SPADLET |sig| + (|libConstructorSig,fn| + (SUBLISLIS |argl| |$FormalMapVariableList| + |sig|))) + (SPADLET |sig| + (CONS (CAR |sig|) + (PROG (G168316) + (SPADLET G168316 NIL) + (RETURN + (DO ((G168323 |argl| (CDR G168323)) + (|a| NIL) + (G168324 (CDR |sig|) + (CDR G168324)) + (|s| NIL) + (G168325 |keys| (CDR G168325)) + (|k| NIL)) + ((OR (ATOM G168323) + (PROGN + (SETQ |a| (CAR G168323)) + NIL) + (ATOM G168324) + (PROGN + (SETQ |s| (CAR G168324)) + NIL) + (ATOM G168325) + (PROGN + (SETQ |k| (CAR G168325)) + NIL)) + (NREVERSE0 G168316)) + (SEQ (EXIT + (SETQ G168316 + (CONS + (COND + (|k| + (CONS '|:| + (CONS |a| (CONS |s| NIL)))) + ('T |s|)) + G168316))))))))) + (SPADLET |sigpart| + (|form2LispString| (CONS '|Mapping| |sig|))) + (COND + ((NULL (|ncParseFromString| |sigpart|)) + (|sayBrightly| + (CONS (MAKESTRING "Won't parse: ") + (CONS |sigpart| NIL))))) + |sigpart|))))) + +;concatWithBlanks r == +; r is [head,:tail] => +; tail => STRCONC(head,'" ",concatWithBlanks tail) +; head +; '"" + +(DEFUN |concatWithBlanks| (|r|) + (PROG (|head| |tail|) + (RETURN + (COND + ((AND (PAIRP |r|) + (PROGN + (SPADLET |head| (QCAR |r|)) + (SPADLET |tail| (QCDR |r|)) + 'T)) + (COND + (|tail| (STRCONC |head| (MAKESTRING " ") + (|concatWithBlanks| |tail|))) + ('T |head|))) + ('T (MAKESTRING "")))))) + +;writedb(u) == +; not STRINGP u => nil --skip if not a string +; PRINTEXP(addPatchesToLongLines(u,500),$outStream) +; --positions for tick(1), dashes(2), and address(9), i.e. 12 +; TERPRI $outStream + +(DEFUN |writedb| (|u|) + (declare (special |$outStream|)) + (COND + ((NULL (STRINGP |u|)) NIL) + ('T (PRINTEXP (|addPatchesToLongLines| |u| 500) |$outStream|) + (TERPRI |$outStream|)))) + +;addPatchesToLongLines(s,n) == +; #s > n => STRCONC(SUBSTRING(s,0,n), +; addPatchesToLongLines(STRCONC('"--",SUBSTRING(s,n,nil)),n)) +; s + +(DEFUN |addPatchesToLongLines| (|s| |n|) + (COND + ((> (|#| |s|) |n|) + (STRCONC (SUBSTRING |s| 0 |n|) + (|addPatchesToLongLines| + (STRCONC (MAKESTRING "--") (SUBSTRING |s| |n| NIL)) + |n|))) + ('T |s|))) + +;buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred) + +(DEFUN |buildLibOps| (|oplist|) + (PROG (|op| |sig| |pred|) + (declare (special |$kind| |$doc| |$exposed?|)) + (RETURN + (SEQ (DO ((G168379 |oplist| (CDR G168379)) (G168370 NIL)) + ((OR (ATOM G168379) + (PROGN (SETQ G168370 (CAR G168379)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G168370)) + (SPADLET |sig| (CADR G168370)) + (SPADLET |pred| (CDDR G168370)) + G168370) + NIL)) + NIL) + (SEQ (EXIT (|buildLibOp| |op| |sig| |pred|)))))))) + +;buildLibOp(op,sig,pred) == +;--operations OKop \#\sig \conname\pred\comments (K is U or C) +; nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig) +; pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) +; nsig := SUBST('T,"T$",nsig) --this ancient artifact causes troubles! +; pred := SUBST('T,"T$",pred) +; sigpart:= form2LispString ['Mapping,:nsig] +; predString := (pred = 'T => '""; form2LispString pred) +; sop := +; (s := STRINGIMAGE op) = '"One" => '"1" +; s = '"Zero" => '"0" +; s +; header := STRCONC('"o",sop) +; conform:= STRCONC($kind,form2LispString $conform) +; comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc)) +; checkCommentsForBraces('operation,sop,sigpart,comments) +; writedb +; buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments] + +(DEFUN |buildLibOp| (|op| |sig| |pred|) + (PROG (|nsig| |sigpart| |predString| |s| |sop| |header| |conform| + |comments|) + (declare (special |$kind| |$doc| |$exposed?| |$conform|)) + (RETURN + (PROGN + (SPADLET |nsig| + (SUBLISLIS (CDR |$conform|) |$FormalMapVariableList| + |sig|)) + (SPADLET |pred| + (SUBLISLIS (CDR |$conform|) |$FormalMapVariableList| + |pred|)) + (SPADLET |nsig| (MSUBST 'T 'T$ |nsig|)) + (SPADLET |pred| (MSUBST 'T 'T$ |pred|)) + (SPADLET |sigpart| + (|form2LispString| (CONS '|Mapping| |nsig|))) + (SPADLET |predString| + (COND + ((BOOT-EQUAL |pred| 'T) (MAKESTRING "")) + ('T (|form2LispString| |pred|)))) + (SPADLET |sop| + (COND + ((BOOT-EQUAL (SPADLET |s| (STRINGIMAGE |op|)) + (MAKESTRING "One")) + (MAKESTRING "1")) + ((BOOT-EQUAL |s| (MAKESTRING "Zero")) + (MAKESTRING "0")) + ('T |s|))) + (SPADLET |header| (STRCONC (MAKESTRING "o") |sop|)) + (SPADLET |conform| + (STRCONC |$kind| (|form2LispString| |$conform|))) + (SPADLET |comments| + (|libdbTrim| + (|concatWithBlanks| + (LASSOC |sig| (LASSOC |op| |$doc|))))) + (|checkCommentsForBraces| '|operation| |sop| |sigpart| + |comments|) + (|writedb| + (|buildLibdbString| + (CONS |header| + (CONS (|#| (CDR |sig|)) + (CONS |$exposed?| + (CONS |sigpart| + (CONS |conform| + (CONS |predString| + (CONS |comments| NIL))))))))))))) + +;libdbTrim s == +; k := MAXINDEX s +; k < 0 => s +; for i in 0..k repeat +; s.i = $Newline => SETELT(s,i,char '_ ) +; trimString s + +(DEFUN |libdbTrim| (|s|) + (PROG (|k|) + (declare (special |$Newline|)) + (RETURN + (SEQ (PROGN + (SPADLET |k| (MAXINDEX |s|)) + (COND + ((MINUSP |k|) |s|) + ('T + (SEQ (DO ((|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| |k|) NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL (ELT |s| |i|) + |$Newline|) + (EXIT + (SETELT |s| |i| (|char| '| |)))))))) + (|trimString| |s|))))))))) + +;checkCommentsForBraces(kind,sop,sigpart,comments) == +; count := 0 +; for i in 0..MAXINDEX comments repeat +; c := comments.i +; c = char '_{ => count := count + 1 +; c = char '_} => +; count := count - 1 +; count < 0 => missingLeft := true +; if count < 0 or missingLeft then +; tail := +; kind = 'attribute => [sop,'"(",sigpart,'")"] +; [sop,'": ",sigpart] +; sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail] +; if count > 0 then +; sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail] +; if count ^= 0 or missingLeft then pp comments + +(DEFUN |checkCommentsForBraces| (|kind| |sop| |sigpart| |comments|) + (PROG (|c| |count| |missingLeft| |tail|) + (declare (special |$conname|)) + (RETURN + (SEQ (PROGN + (SPADLET |count| 0) + (DO ((G168430 (MAXINDEX |comments|)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G168430) NIL) + (SEQ (EXIT (PROGN + (SPADLET |c| (ELT |comments| |i|)) + (COND + ((BOOT-EQUAL |c| (|char| '{)) + (SPADLET |count| (PLUS |count| 1))) + ((BOOT-EQUAL |c| (|char| '})) + (SPADLET |count| + (SPADDIFFERENCE |count| 1)) + (COND + ((MINUSP |count|) + (SPADLET |missingLeft| 'T))))))))) + (COND + ((OR (MINUSP |count|) |missingLeft|) + (SPADLET |tail| + (COND + ((BOOT-EQUAL |kind| '|attribute|) + (CONS |sop| + (CONS (MAKESTRING "(") + (CONS |sigpart| + (CONS (MAKESTRING ")") NIL))))) + ('T + (CONS |sop| + (CONS (MAKESTRING ": ") + (CONS |sigpart| NIL)))))) + (|sayBrightly| + (CONS (MAKESTRING "(") + (CONS |$conname| + (CONS (MAKESTRING + " documentation) missing left brace--> ") + |tail|)))))) + (COND + ((> |count| 0) + (|sayBrightly| + (CONS (MAKESTRING "(") + (CONS |$conname| + (CONS (MAKESTRING + " documentation) missing right brace--> ") + |tail|)))))) + (COND + ((OR (NEQUAL |count| 0) |missingLeft|) + (|pp| |comments|)) + ('T NIL))))))) + +;buildLibAttrs attrlist == +; for [name,argl,:pred] in attrlist repeat buildLibAttr(name,argl,pred) + +(DEFUN |buildLibAttrs| (|attrlist|) + (PROG (|name| |argl| |pred|) + (RETURN + (SEQ (DO ((G168452 |attrlist| (CDR G168452)) (G168443 NIL)) + ((OR (ATOM G168452) + (PROGN (SETQ G168443 (CAR G168452)) NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR G168443)) + (SPADLET |argl| (CADR G168443)) + (SPADLET |pred| (CDDR G168443)) + G168443) + NIL)) + NIL) + (SEQ (EXIT (|buildLibAttr| |name| |argl| |pred|)))))))) + +;buildLibAttr(name,argl,pred) == +;--attributes AKname\#\args\conname\pred\comments (K is U or C) +; header := STRCONC('"a",STRINGIMAGE name) +; argPart:= SUBSTRING(form2LispString ['f,:argl],1,nil) +; pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) +; predString := (pred = 'T => '""; form2LispString pred) +; header := STRCONC('"a",STRINGIMAGE name) +; conname := STRCONC($kind,form2LispString $conname) +; comments:= concatWithBlanks LASSOC(['attribute,:argl],LASSOC(name,$doc)) +; checkCommentsForBraces('attribute,STRINGIMAGE name,argl,comments) +; writedb +; buildLibdbString [header,# argl,$exposed?,argPart,conname,predString,comments] + +(DEFUN |buildLibAttr| (|name| |argl| |pred|) + (PROG (|argPart| |predString| |header| |conname| |comments|) + (declare (special |$kind| |$conname| |$doc| |$conform| + |$FormalMapVariableList| |$exposed?|)) + (RETURN + (PROGN + (SPADLET |header| + (STRCONC (MAKESTRING "a") (STRINGIMAGE |name|))) + (SPADLET |argPart| + (SUBSTRING (|form2LispString| (CONS '|f| |argl|)) 1 + NIL)) + (SPADLET |pred| + (SUBLISLIS (CDR |$conform|) |$FormalMapVariableList| + |pred|)) + (SPADLET |predString| + (COND + ((BOOT-EQUAL |pred| 'T) (MAKESTRING "")) + ('T (|form2LispString| |pred|)))) + (SPADLET |header| + (STRCONC (MAKESTRING "a") (STRINGIMAGE |name|))) + (SPADLET |conname| + (STRCONC |$kind| (|form2LispString| |$conname|))) + (SPADLET |comments| + (|concatWithBlanks| + (LASSOC (CONS '|attribute| |argl|) + (LASSOC |name| |$doc|)))) + (|checkCommentsForBraces| '|attribute| (STRINGIMAGE |name|) + |argl| |comments|) + (|writedb| + (|buildLibdbString| + (CONS |header| + (CONS (|#| |argl|) + (CONS |$exposed?| + (CONS |argPart| + (CONS |conname| + (CONS |predString| + (CONS |comments| NIL))))))))))))) + +;dbAugmentConstructorDataTable() == +; instream := MAKE_-INSTREAM '"libdb.text" +; while not EOFP instream repeat +; fp := FILE_-POSITION instream +; line := READLINE instream +; cname := INTERN dbName line +; entry := getCDTEntry(cname,true) => --skip over Mapping, Union, Record +; [name,abb,:.] := entry +; RPLACD(CDR entry,PUTALIST(CDDR entry,'dbLineNumber,fp)) +;-- if xname := constructorHasExamplePage entry then +;-- RPLACD(CDR entry,PUTALIST(CDDR entry,'dbExampleFile,xname)) +; args := IFCDR GETDATABASE(name,'CONSTRUCTORFORM) +; if args then RPLACD(CDR entry,PUTALIST(CDDR entry,'constructorArgs,args)) +; 'done + +(DEFUN |dbAugmentConstructorDataTable| () + (PROG (|instream| |fp| |line| |cname| |entry| |name| |abb| |args|) + (RETURN + (SEQ (PROGN + (SPADLET |instream| + (MAKE-INSTREAM (MAKESTRING "libdb.text"))) + (DO () ((NULL (NULL (EOFP |instream|))) NIL) + (SEQ (EXIT (PROGN + (SPADLET |fp| (FILE-POSITION |instream|)) + (SPADLET |line| (READLINE |instream|)) + (SPADLET |cname| + (INTERN (|dbName| |line|))) + (COND + ((SPADLET |entry| + (|getCDTEntry| |cname| 'T)) + (PROGN + (SPADLET |name| (CAR |entry|)) + (SPADLET |abb| (CADR |entry|)) + (RPLACD (CDR |entry|) + (PUTALIST (CDDR |entry|) + '|dbLineNumber| |fp|)) + (SPADLET |args| + (IFCDR + (GETDATABASE |name| + 'CONSTRUCTORFORM))) + (COND + (|args| + (RPLACD (CDR |entry|) + (PUTALIST (CDDR |entry|) + '|constructorArgs| |args|))) + ('T NIL))))))))) + '|done|))))) + +;dbHasExamplePage conname == +; sname := STRINGIMAGE conname +; abb := constructor? conname +; ucname := UPCASE STRINGIMAGE abb +; pathname :=STRCONC(getEnv '"AXIOM",'"/doc/hypertex/pages/",ucname,'".ht") +; isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage") +; nil + +(DEFUN |dbHasExamplePage| (|conname|) + (PROG (|sname| |abb| |ucname| |pathname|) + (RETURN + (PROGN + (SPADLET |sname| (STRINGIMAGE |conname|)) + (SPADLET |abb| (|constructor?| |conname|)) + (SPADLET |ucname| (UPCASE (STRINGIMAGE |abb|))) + (SPADLET |pathname| + (STRCONC (|getEnv| (MAKESTRING "AXIOM")) + (MAKESTRING "/doc/hypertex/pages/") |ucname| + (MAKESTRING ".ht"))) + (COND + ((|isExistingFile| |pathname|) + (INTERN (STRCONC |sname| (MAKESTRING "XmpPage")))) + ('T NIL)))))) + +;dbRead(n) == +; instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"), '"/algebra/libdb.text") +; FILE_-POSITION(instream,n) +; line := READLINE instream +; SHUT instream +; line + +(DEFUN |dbRead| (|n|) + (PROG (|instream| |line|) + (RETURN + (PROGN + (SPADLET |instream| + (MAKE-INSTREAM + (STRCONC (|getEnv| (MAKESTRING "AXIOM")) + (MAKESTRING "/algebra/libdb.text")))) + (FILE-POSITION |instream| |n|) + (SPADLET |line| (READLINE |instream|)) + (SHUT |instream|) + |line|)))) + +;dbReadComments(n) == +; n = 0 => '"" +; instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"),'"/algebra/comdb.text") +; FILE_-POSITION(instream,n) +; line := READLINE instream +; k := dbTickIndex(line,1,1) +; line := SUBSTRING(line,k + 1,nil) +; while not EOFP instream and (x := READLINE instream) and +; (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and +; x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat +; xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] +; SHUT instream +; STRCONC(line, "STRCONC"/NREVERSE xtralines) + +(DEFUN |dbReadComments| (|n|) + (PROG (|instream| |line| |x| |k| |j| |xtralines|) + (RETURN + (SEQ (COND + ((EQL |n| 0) (MAKESTRING "")) + ('T + (SPADLET |instream| + (MAKE-INSTREAM + (STRCONC (|getEnv| (MAKESTRING "AXIOM")) + (MAKESTRING "/algebra/comdb.text")))) + (FILE-POSITION |instream| |n|) + (SPADLET |line| (READLINE |instream|)) + (SPADLET |k| (|dbTickIndex| |line| 1 1)) + (SPADLET |line| (SUBSTRING |line| (PLUS |k| 1) NIL)) + (DO () + ((NULL (AND (NULL (EOFP |instream|)) + (SPADLET |x| (READLINE |instream|)) + (SPADLET |k| (MAXINDEX |x|)) + (SPADLET |j| (|dbTickIndex| |x| 1 1)) + (> |k| |j|) + (BOOT-EQUAL + (ELT |x| (SPADLET |j| (PLUS |j| 1))) + (|char| '-)) + (BOOT-EQUAL (ELT |x| + (SPADLET |j| (PLUS |j| 1))) + (|char| '-)))) + NIL) + (SEQ (EXIT (SPADLET |xtralines| + (CONS + (SUBSTRING |x| (PLUS |j| 1) NIL) + |xtralines|))))) + (SHUT |instream|) + (STRCONC |line| + (PROG (G168531) + (SPADLET G168531 "") + (RETURN + (DO ((G168536 (NREVERSE |xtralines|) + (CDR G168536)) + (G168523 NIL)) + ((OR (ATOM G168536) + (PROGN + (SETQ G168523 (CAR G168536)) + NIL)) + G168531) + (SEQ (EXIT (SETQ G168531 + (STRCONC G168531 G168523)))))))))))))) + +;dbSplitLibdb() == +; instream := MAKE_-INSTREAM '"olibdb.text" +; outstream:= MAKE_-OUTSTREAM '"libdb.text" +; comstream:= MAKE_-OUTSTREAM '"comdb.text" +; PRINTEXP(0, comstream) +; PRINTEXP($tick,comstream) +; PRINTEXP('"", comstream) +; TERPRI(comstream) +; while not EOFP instream repeat +; line := READLINE instream +; outP := FILE_-POSITION outstream +; comP := FILE_-POSITION comstream +; [prefix,:comments] := dbSplit(line,6,1) +; PRINTEXP(prefix,outstream) +; PRINTEXP($tick ,outstream) +; null comments => +; PRINTEXP(0,outstream) +; TERPRI(outstream) +; PRINTEXP(comP,outstream) +; TERPRI(outstream) +; PRINTEXP(outP ,comstream) +; PRINTEXP($tick ,comstream) +; PRINTEXP(first comments,comstream) +; TERPRI(comstream) +; for c in rest comments repeat +; PRINTEXP(outP ,comstream) +; PRINTEXP($tick ,comstream) +; PRINTEXP(c, comstream) +; TERPRI(comstream) +; SHUT instream +; SHUT outstream +; SHUT comstream +; OBEY '"rm olibdb.text" + +(DEFUN |dbSplitLibdb| () + (PROG (|instream| |outstream| |comstream| |line| |outP| |comP| + |LETTMP#1| |prefix| |comments|) + (declare (special |$tick|)) + (RETURN + (SEQ (PROGN + (SPADLET |instream| + (MAKE-INSTREAM (MAKESTRING "olibdb.text"))) + (SPADLET |outstream| + (MAKE-OUTSTREAM (MAKESTRING "libdb.text"))) + (SPADLET |comstream| + (MAKE-OUTSTREAM (MAKESTRING "comdb.text"))) + (PRINTEXP 0 |comstream|) + (PRINTEXP |$tick| |comstream|) + (PRINTEXP (MAKESTRING "") |comstream|) + (TERPRI |comstream|) + (DO () ((NULL (NULL (EOFP |instream|))) NIL) + (SEQ (EXIT (PROGN + (SPADLET |line| (READLINE |instream|)) + (SPADLET |outP| + (FILE-POSITION |outstream|)) + (SPADLET |comP| + (FILE-POSITION |comstream|)) + (SPADLET |LETTMP#1| (|dbSplit| |line| 6 1)) + (SPADLET |prefix| (CAR |LETTMP#1|)) + (SPADLET |comments| (CDR |LETTMP#1|)) + (PRINTEXP |prefix| |outstream|) + (PRINTEXP |$tick| |outstream|) + (COND + ((NULL |comments|) + (PRINTEXP 0 |outstream|) + (TERPRI |outstream|)) + ('T (PRINTEXP |comP| |outstream|) + (TERPRI |outstream|) + (PRINTEXP |outP| |comstream|) + (PRINTEXP |$tick| |comstream|) + (PRINTEXP (CAR |comments|) |comstream|) + (TERPRI |comstream|) + (DO ((G168593 (CDR |comments|) + (CDR G168593)) + (|c| NIL)) + ((OR (ATOM G168593) + (PROGN + (SETQ |c| (CAR G168593)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (PRINTEXP |outP| |comstream|) + (PRINTEXP |$tick| |comstream|) + (PRINTEXP |c| |comstream|) + (TERPRI |comstream|))))))))))) + (SHUT |instream|) + (SHUT |outstream|) + (SHUT |comstream|) + (OBEY (MAKESTRING "rm olibdb.text"))))))) + +;dbSplit(line,n,k) == +; k := charPosition($tick,line,k + 1) +; n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)] +; dbSplit(line,n - 1,k) + +(DEFUN |dbSplit| (|line| |n| |k|) + (declare (special |$tick|)) + (PROGN + (SPADLET |k| (|charPosition| |$tick| |line| (PLUS |k| 1))) + (COND + ((EQL |n| 1) + (CONS (SUBSTRING |line| 0 |k|) + (|dbSpreadComments| (SUBSTRING |line| (PLUS |k| 1) NIL) 0))) + ('T (|dbSplit| |line| (SPADDIFFERENCE |n| 1) |k|))))) + +;dbSpreadComments(line,n) == +; line = '"" => nil +; k := charPosition(char '_-,line,n + 2) +; k >= MAXINDEX line => [SUBSTRING(line,n,nil)] +; line.(k + 1) ^= char '_- => +; u := dbSpreadComments(line,k) +; [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u] +; [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)] + +(DEFUN |dbSpreadComments| (|line| |n|) + (PROG (|k| |u|) + (RETURN + (COND + ((BOOT-EQUAL |line| (MAKESTRING "")) NIL) + ('T + (SPADLET |k| (|charPosition| (|char| '-) |line| (PLUS |n| 2))) + (COND + ((>= |k| (MAXINDEX |line|)) + (CONS (SUBSTRING |line| |n| NIL) NIL)) + ((NEQUAL (ELT |line| (PLUS |k| 1)) (|char| '-)) + (SPADLET |u| (|dbSpreadComments| |line| |k|)) + (CONS (STRCONC (SUBSTRING |line| |n| + (SPADDIFFERENCE |k| |n|)) + (CAR |u|)) + (CDR |u|))) + ('T + (CONS (SUBSTRING |line| |n| (SPADDIFFERENCE |k| |n|)) + (|dbSpreadComments| (SUBSTRING |line| |k| NIL) 0))))))))) + +;--============================================================================ +;-- Build Glossary +;--============================================================================ +;buildGloss() == --called by buildDatabase (database.boot) +;--starting with gloss.text, build glosskey.text and glossdef.text +; $constructorName : local := nil +; $exposeFlag : local := true +; $outStream: local := MAKE_-OUTSTREAM '"temp.text" +; $x : local := nil +; $attribute? : local := true --do not surround first word +; pathname := STRCONC(getEnv '"AXIOM",'"/algebra/gloss.text") +; instream := MAKE_-INSTREAM pathname +; keypath := '"glosskey.text" +; OBEY STRCONC('"rm -f ",keypath) +; outstream:= MAKE_-OUTSTREAM keypath +; htpath := '"gloss.ht" +; OBEY STRCONC('"rm -f ",htpath) +; htstream:= MAKE_-OUTSTREAM htpath +; defpath := '"glossdef.text" +; defstream:= MAKE_-OUTSTREAM defpath +; pairs := getGlossLines instream +; PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream) +; for [name,:line] in pairs repeat +; outP := FILE_-POSITION outstream +; defP := FILE_-POSITION defstream +; lines := spreadGlossText transformAndRecheckComments(name,[line]) +; PRINTEXP(name, outstream) +; PRINTEXP($tick,outstream) +; PRINTEXP(defP, outstream) +; TERPRI(outstream) +;-- PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream) +; PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream) +; PRINTEXP(name, htstream) +; PRINTEXP('"}\space{}",htstream) +; TERPRI(htstream) +; for x in lines repeat +; PRINTEXP(outP, defstream) +; PRINTEXP($tick,defstream) +; PRINTEXP(x, defstream) +; TERPRI defstream +; PRINTEXP("STRCONC"/lines,htstream) +; TERPRI htstream +; PRINTEXP('"\endmenu\endscroll",htstream) +; PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream) +; PRINTEXP('"\end{page}",htstream) +; SHUT instream +; SHUT outstream +; SHUT defstream +; SHUT htstream +; SHUT $outStream + +(DEFUN |buildGloss| () + (PROG (|$constructorName| |$exposeFlag| |$outStream| |$x| + |$attribute?| |pathname| |instream| |keypath| |outstream| + |htpath| |htstream| |defpath| |defstream| |pairs| |name| + |line| |outP| |defP| |lines|) + (DECLARE (SPECIAL |$constructorName| |$exposeFlag| |$outStream| + |$x| |$attribute?| |$tick|)) + (RETURN + (SEQ (PROGN + (SPADLET |$constructorName| NIL) + (SPADLET |$exposeFlag| 'T) + (SPADLET |$outStream| + (MAKE-OUTSTREAM (MAKESTRING "temp.text"))) + (SPADLET |$x| NIL) + (SPADLET |$attribute?| 'T) + (SPADLET |pathname| + (STRCONC (|getEnv| (MAKESTRING "AXIOM")) + (MAKESTRING "/algebra/gloss.text"))) + (SPADLET |instream| (MAKE-INSTREAM |pathname|)) + (SPADLET |keypath| (MAKESTRING "glosskey.text")) + (OBEY (STRCONC (MAKESTRING "rm -f ") |keypath|)) + (SPADLET |outstream| (MAKE-OUTSTREAM |keypath|)) + (SPADLET |htpath| (MAKESTRING "gloss.ht")) + (OBEY (STRCONC (MAKESTRING "rm -f ") |htpath|)) + (SPADLET |htstream| (MAKE-OUTSTREAM |htpath|)) + (SPADLET |defpath| (MAKESTRING "glossdef.text")) + (SPADLET |defstream| (MAKE-OUTSTREAM |defpath|)) + (SPADLET |pairs| (|getGlossLines| |instream|)) + (PRINTEXP + (MAKESTRING + "\\begin{page}{GlossaryPage}{G l o s s a r y}\\beginscroll\\beginmenu") + |htstream|) + (DO ((G168653 |pairs| (CDR G168653)) (G168626 NIL)) + ((OR (ATOM G168653) + (PROGN (SETQ G168626 (CAR G168653)) NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR G168626)) + (SPADLET |line| (CDR G168626)) + G168626) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |outP| + (FILE-POSITION |outstream|)) + (SPADLET |defP| + (FILE-POSITION |defstream|)) + (SPADLET |lines| + (|spreadGlossText| + (|transformAndRecheckComments| + |name| (CONS |line| NIL)))) + (PRINTEXP |name| |outstream|) + (PRINTEXP |$tick| |outstream|) + (PRINTEXP |defP| |outstream|) + (TERPRI |outstream|) + (PRINTEXP + (MAKESTRING + "\\item\\newline{\\em \\menuitemstyle{}}{\\em ") + |htstream|) + (PRINTEXP |name| |htstream|) + (PRINTEXP (MAKESTRING "}\\space{}") + |htstream|) + (TERPRI |htstream|) + (DO ((G168667 |lines| (CDR G168667)) + (|x| NIL)) + ((OR (ATOM G168667) + (PROGN + (SETQ |x| (CAR G168667)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (PRINTEXP |outP| |defstream|) + (PRINTEXP |$tick| |defstream|) + (PRINTEXP |x| |defstream|) + (TERPRI |defstream|))))) + (PRINTEXP + (PROG (G168673) + (SPADLET G168673 "") + (RETURN + (DO + ((G168678 |lines| + (CDR G168678)) + (G168623 NIL)) + ((OR (ATOM G168678) + (PROGN + (SETQ G168623 + (CAR G168678)) + NIL)) + G168673) + (SEQ + (EXIT + (SETQ G168673 + (STRCONC G168673 G168623))))))) + |htstream|) + (TERPRI |htstream|))))) + (PRINTEXP (MAKESTRING "\\endmenu\\endscroll") |htstream|) + (PRINTEXP + (MAKESTRING + "\\lispdownlink{Search}{(|htGloss| \"\\stringvalue{pattern}\")} for glossary entry matching \\inputstring{pattern}{24}{*}") + |htstream|) + (PRINTEXP (MAKESTRING "\\end{page}") |htstream|) + (SHUT |instream|) + (SHUT |outstream|) + (SHUT |defstream|) + (SHUT |htstream|) + (SHUT |$outStream|)))))) + +;spreadGlossText(line) == +;--this function breaks up a line into chunks +;--eventually long line is put into gloss.text as several chunks as follows: +;----- key1`this is the first chunk +;----- XXX`and this is the second +;----- XXX`and this is the third +;----- key2`and this is the fourth +;--where XXX is the file position of key1 +;--this is because grepping will only pick up the first 512 characters +; line = '"" => nil +; MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))] +; [line] + +(DEFUN |spreadGlossText| (|line|) + (COND + ((BOOT-EQUAL |line| (MAKESTRING "")) NIL) + ((> (MAXINDEX |line|) 500) + (CONS (SUBSTRING |line| 0 500) + (|spreadGlossText| (SUBSTRING |line| 500 NIL)))) + ('T (CONS |line| NIL)))) + +;getGlossLines instream == +;--instream has text of the form: +;----- key1`this is the first line +;----- and this is the second +;----- key2'and this is the third +;--result is +;----- key1'this is the first line and this is the second +;----- key2'and this is the third +; keys := nil +; text := nil +; lastLineHadTick := false +; while not EOFP instream repeat +; line := READLINE instream +; #line = 0 => 'skip +; n := charPosition($tick,line,0) +; last := IFCAR text +; n > MAXINDEX line => --this line is continuation of previous line; concat it +; fill := +; #last = 0 => +; lastLineHadTick => '"" +; '"\blankline " +; #last > 0 and last.(MAXINDEX last) ^= $charBlank => $charBlank +; '"" +; lastLineHadTick := false +; text := [STRCONC(last,fill,line),:rest text] +; lastLineHadTick := true +; keys := [SUBSTRING(line,0,n),:keys] +; text := [SUBSTRING(line,n + 1,nil),:text] +; ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text]) + +(DEFUN |getGlossLines| (|instream|) + (PROG (|line| |n| |last| |fill| |lastLineHadTick| |keys| |text|) + (declare (special |$charBlank| |$tick|)) + (RETURN + (SEQ (PROGN + (SPADLET |keys| NIL) + (SPADLET |text| NIL) + (SPADLET |lastLineHadTick| NIL) + (DO () ((NULL (NULL (EOFP |instream|))) NIL) + (SEQ (EXIT (PROGN + (SPADLET |line| (READLINE |instream|)) + (COND + ((EQL (|#| |line|) 0) '|skip|) + ('T + (SPADLET |n| + (|charPosition| |$tick| |line| + 0)) + (SPADLET |last| (IFCAR |text|)) + (COND + ((> |n| (MAXINDEX |line|)) + (SPADLET |fill| + (COND + ((EQL (|#| |last|) 0) + (COND + (|lastLineHadTick| + (MAKESTRING "")) + ('T + (MAKESTRING + "\\blankline ")))) + ((AND (> (|#| |last|) 0) + (NEQUAL + (ELT |last| + (MAXINDEX |last|)) + |$charBlank|)) + |$charBlank|) + ('T (MAKESTRING "")))) + (SPADLET |lastLineHadTick| NIL) + (SPADLET |text| + (CONS + (STRCONC |last| |fill| + |line|) + (CDR |text|)))) + ('T (SPADLET |lastLineHadTick| 'T) + (SPADLET |keys| + (CONS + (SUBSTRING |line| 0 |n|) + |keys|)) + (SPADLET |text| + (CONS + (SUBSTRING |line| + (PLUS |n| 1) NIL) + |text|)))))))))) + (ASSOCRIGHT + (|listSort| (|function| GLESSEQP) + (PROG (G168739) + (SPADLET G168739 NIL) + (RETURN + (DO ((G168745 |keys| (CDR G168745)) + (|key| NIL) + (G168746 |text| (CDR G168746)) + (|def| NIL)) + ((OR (ATOM G168745) + (PROGN + (SETQ |key| (CAR G168745)) + NIL) + (ATOM G168746) + (PROGN + (SETQ |def| (CAR G168746)) + NIL)) + (NREVERSE0 G168739)) + (SEQ (EXIT (SETQ G168739 + (CONS + (CONS (DOWNCASE |key|) + (CONS |key| |def|)) + G168739)))))))))))))) + +; --this complication sorts them after lower casing the keys +;--============================================================================ +;-- Build Users HashTable +;-- This database is written out as users.database (database.boot) +;-- and read using function getUsersOfConstructor. See functions +;-- whoUses and kcuPage in browser. +;--============================================================================ +;mkUsersHashTable() == --called by make-databases (daase.lisp.pamphlet) +; $usersTb := MAKE_-HASH_-TABLE() +; for x in allConstructors() repeat +; for conform in getImports x repeat +; name := opOf conform +; if not MEMQ(name,'(QUOTE)) then +; HPUT($usersTb,name,insert(x,HGET($usersTb,name))) +; for k in HKEYS $usersTb repeat +; HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k))) +; for x in allConstructors() | isDefaultPackageName x repeat +; HPUT($usersTb,x,getDefaultPackageClients x) +; $usersTb +(DEFUN |mkUsersHashTable| () + (PROG (|name|) + (declare (special |$usersTb|)) + (RETURN + (SEQ (PROGN + (SPADLET |$usersTb| (MAKE-HASH-TABLE)) + (DO ((G168778 (|allConstructors|) (CDR G168778)) + (|x| NIL)) + ((OR (ATOM G168778) + (PROGN (SETQ |x| (CAR G168778)) NIL)) + NIL) + (SEQ (EXIT (DO ((G168789 (|getImports| |x|) + (CDR G168789)) + (|conform| NIL)) + ((OR (ATOM G168789) + (PROGN + (SETQ |conform| (CAR G168789)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |name| + (|opOf| |conform|)) + (COND + ((NULL + (MEMQ |name| '(QUOTE))) + (HPUT |$usersTb| |name| + (|insert| |x| + (HGET |$usersTb| |name|)))) + ('T NIL))))))))) + (DO ((G168798 (HKEYS |$usersTb|) (CDR G168798)) + (|k| NIL)) + ((OR (ATOM G168798) + (PROGN (SETQ |k| (CAR G168798)) NIL)) + NIL) + (SEQ (EXIT (HPUT |$usersTb| |k| + (|listSort| (|function| GLESSEQP) + (HGET |$usersTb| |k|)))))) + (DO ((G168808 (|allConstructors|) (CDR G168808)) + (|x| NIL)) + ((OR (ATOM G168808) + (PROGN (SETQ |x| (CAR G168808)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|isDefaultPackageName| |x|) + (HPUT |$usersTb| |x| + (|getDefaultPackageClients| |x|))))))) + |$usersTb|))))) + +;getDefaultPackageClients con == --called by mkUsersHashTable +; catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) +; for [catAncestor,:.] in childrenOf([catname]) repeat +; pakname := INTERN STRCONC(PNAME catAncestor,'"&") +; if getCDTEntry(pakname,true) then acc := [pakname,:acc] +; acc := UNION([CAAR x for x in domainsOf([catAncestor],nil)],acc) +; listSort(function GLESSEQP,acc) + +(DEFUN |getDefaultPackageClients| (|con|) + (PROG (|s| |catname| |catAncestor| |pakname| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |catname| + (INTERN (SUBSTRING (SPADLET |s| (PNAME |con|)) 0 + (MAXINDEX |s|)))) + (DO ((G168831 (|childrenOf| (CONS |catname| NIL)) + (CDR G168831)) + (G168820 NIL)) + ((OR (ATOM G168831) + (PROGN (SETQ G168820 (CAR G168831)) NIL) + (PROGN + (PROGN + (SPADLET |catAncestor| (CAR G168820)) + G168820) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |pakname| + (INTERN + (STRCONC (PNAME |catAncestor|) + (MAKESTRING "&")))) + (COND + ((|getCDTEntry| |pakname| 'T) + (SPADLET |acc| (CONS |pakname| |acc|)))) + (SPADLET |acc| + (|union| + (PROG (G168842) + (SPADLET G168842 NIL) + (RETURN + (DO + ((G168847 + (|domainsOf| + (CONS |catAncestor| NIL) + NIL) + (CDR G168847)) + (|x| NIL)) + ((OR (ATOM G168847) + (PROGN + (SETQ |x| + (CAR G168847)) + NIL)) + (NREVERSE0 G168842)) + (SEQ + (EXIT + (SETQ G168842 + (CONS (CAAR |x|) + G168842))))))) + |acc|)))))) + (|listSort| (|function| GLESSEQP) |acc|)))))) + +;--============================================================================ +;-- Build Dependents Hashtable +;-- This hashtable is written out by database.boot as dependents.DATABASE +;-- and read back in by getDependentsOfConstructor (see daase.lisp) +;-- This information is used by function kcdePage when a user asks for the +;-- dependents of a constructor. +;--============================================================================ +;mkDependentsHashTable() == --called by make-databases (daase.lisp.pamphlet) +; $depTb := MAKE_-HASH_-TABLE() +; for nam in allConstructors() repeat +; for con in getArgumentConstructors nam repeat +; HPUT($depTb,con,[nam,:HGET($depTb,con)]) +; for k in HKEYS $depTb repeat +; HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k))) +; $depTb + +(DEFUN |mkDependentsHashTable| () + (declare (special |$depTb|)) + (SEQ (PROGN + (SPADLET |$depTb| (MAKE-HASH-TABLE)) + (DO ((G168867 (|allConstructors|) (CDR G168867)) + (|nam| NIL)) + ((OR (ATOM G168867) + (PROGN (SETQ |nam| (CAR G168867)) NIL)) + NIL) + (SEQ (EXIT (DO ((G168876 (|getArgumentConstructors| |nam|) + (CDR G168876)) + (|con| NIL)) + ((OR (ATOM G168876) + (PROGN + (SETQ |con| (CAR G168876)) + NIL)) + NIL) + (SEQ (EXIT (HPUT |$depTb| |con| + (CONS |nam| (HGET |$depTb| |con|))))))))) + (DO ((G168885 (HKEYS |$depTb|) (CDR G168885)) (|k| NIL)) + ((OR (ATOM G168885) + (PROGN (SETQ |k| (CAR G168885)) NIL)) + NIL) + (SEQ (EXIT (HPUT |$depTb| |k| + (|listSort| (|function| GLESSEQP) + (HGET |$depTb| |k|)))))) + |$depTb|))) + +;getArgumentConstructors con == --called by mkDependentsHashTable +; argtypes := IFCDR IFCAR getConstructorModemap con or return nil +; fn argtypes where +; fn(u) == "UNION"/[gn x for x in u] +; gn(x) == +; atom x => nil +; x is ['Join,:r] => fn(r) +; x is ['CATEGORY,:.] => nil +; constructor? first x => [first x,:fn rest x] +; fn rest x + +(DEFUN |getArgumentConstructors,gn| (|x|) + (PROG (|r|) + (RETURN + (SEQ (IF (ATOM |x|) (EXIT NIL)) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|Join|) + (PROGN (SPADLET |r| (QCDR |x|)) 'T)) + (EXIT (|getArgumentConstructors,fn| |r|))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'CATEGORY)) (EXIT NIL)) + (IF (|constructor?| (CAR |x|)) + (EXIT (CONS (CAR |x|) + (|getArgumentConstructors,fn| (CDR |x|))))) + (EXIT (|getArgumentConstructors,fn| (CDR |x|))))))) + +(DEFUN |getArgumentConstructors,fn| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G168900) + (SPADLET G168900 NIL) + (RETURN + (DO ((G168905 |u| (CDR G168905)) (|x| NIL)) + ((OR (ATOM G168905) + (PROGN (SETQ |x| (CAR G168905)) NIL)) + G168900) + (SEQ (EXIT (SETQ G168900 + (|union| G168900 + (|getArgumentConstructors,gn| + |x|)))))))))))) + +(DEFUN |getArgumentConstructors| (|con|) + (PROG (|argtypes|) + (RETURN + (PROGN + (SPADLET |argtypes| + (OR (IFCDR (IFCAR (|getConstructorModemap| |con|))) + (RETURN NIL))) + (|getArgumentConstructors,fn| |argtypes|))))) + +;getImports conname == --called by mkUsersHashTable +; conform := GETDATABASE(conname,'CONSTRUCTORFORM) +; infovec := dbInfovec conname or return nil +; template := infovec.0 +; u := [import(i,template) +; for i in 5..(MAXINDEX template) | test] where +; test == template.i is [op,:.] and IDENTP op +; and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local)) +; import(x,template) == +; x is [op,:args] => +; op = 'QUOTE or op = 'NRTEVAL => CAR args +; op = 'local => first args +; op = 'Record => +; ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]] +;--TTT next three lines: handles some tagged/untagged Union case. +; op = 'Union=> +; args is [['_:,:x1],:x2] => +;-- CAAR args = '_: => -- tagged! +; ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]] +; [op,:[import(y,template) for y in args]] +; [op,:[import(y,template) for y in args]] +; INTEGERP x => import(template.x,template) +; x = '$ => '$ +; x = "$$" => "$$" +; STRINGP x => x +; systemError '"bad argument in template" +; listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u)) + +(DEFUN |getImports,import| (|x| |template|) + (PROG (|op| |args| |ISTMP#1| |x1| |x2|) + (RETURN + (SEQ (IF (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |args| (QCDR |x|)) + 'T)) + (EXIT (SEQ (IF (OR (BOOT-EQUAL |op| 'QUOTE) + (BOOT-EQUAL |op| 'NRTEVAL)) + (EXIT (CAR |args|))) + (IF (BOOT-EQUAL |op| '|local|) + (EXIT (CAR |args|))) + (IF (BOOT-EQUAL |op| '|Record|) + (EXIT (CONS '|Record| + (PROG (G168939) + (SPADLET G168939 NIL) + (RETURN + (DO + ((G168944 |args| + (CDR G168944)) + (|y| NIL)) + ((OR (ATOM G168944) + (PROGN + (SETQ |y| + (CAR G168944)) + NIL)) + (NREVERSE0 G168939)) + (SEQ + (EXIT + (SETQ G168939 + (CONS + (CONS '|:| + (CONS (CADR |y|) + (CONS + (|getImports,import| + (CADDR |y|) + |template|) + NIL))) + G168939)))))))))) + (IF (BOOT-EQUAL |op| '|Union|) + (EXIT (SEQ + (IF + (AND (PAIRP |args|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |args|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|:|) + (PROGN + (SPADLET |x1| + (QCDR |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |x2| (QCDR |args|)) + 'T)) + (EXIT + (CONS '|Union| + (PROG (G168954) + (SPADLET G168954 NIL) + (RETURN + (DO + ((G168959 |args| + (CDR G168959)) + (|y| NIL)) + ((OR (ATOM G168959) + (PROGN + (SETQ |y| + (CAR G168959)) + NIL)) + (NREVERSE0 G168954)) + (SEQ + (EXIT + (SETQ G168954 + (CONS + (CONS '|:| + (CONS (CADR |y|) + (CONS + (|getImports,import| + (CADDR |y|) + |template|) + NIL))) + G168954)))))))))) + (EXIT + (CONS |op| + (PROG (G168969) + (SPADLET G168969 NIL) + (RETURN + (DO + ((G168974 |args| + (CDR G168974)) + (|y| NIL)) + ((OR (ATOM G168974) + (PROGN + (SETQ |y| + (CAR G168974)) + NIL)) + (NREVERSE0 G168969)) + (SEQ + (EXIT + (SETQ G168969 + (CONS + (|getImports,import| + |y| |template|) + G168969)))))))))))) + (EXIT (CONS |op| + (PROG (G168984) + (SPADLET G168984 NIL) + (RETURN + (DO + ((G168989 |args| + (CDR G168989)) + (|y| NIL)) + ((OR (ATOM G168989) + (PROGN + (SETQ |y| + (CAR G168989)) + NIL)) + (NREVERSE0 G168984)) + (SEQ + (EXIT + (SETQ G168984 + (CONS + (|getImports,import| + |y| |template|) + G168984)))))))))))) + (IF (INTEGERP |x|) + (EXIT (|getImports,import| (ELT |template| |x|) + |template|))) + (IF (BOOT-EQUAL |x| '$) (EXIT '$)) + (IF (BOOT-EQUAL |x| '$$) (EXIT '$$)) + (IF (STRINGP |x|) (EXIT |x|)) + (EXIT (|systemError| + (MAKESTRING "bad argument in template"))))))) + +(DEFUN |getImports| (|conname|) + (PROG (|conform| |infovec| |template| |ISTMP#1| |op| |u|) + (RETURN + (SEQ (PROGN + (SPADLET |conform| + (GETDATABASE |conname| 'CONSTRUCTORFORM)) + (SPADLET |infovec| + (OR (|dbInfovec| |conname|) (RETURN NIL))) + (SPADLET |template| (ELT |infovec| 0)) + (SPADLET |u| + (PROG (G169018) + (SPADLET G169018 NIL) + (RETURN + (DO ((G169024 (MAXINDEX |template|)) + (|i| 5 (+ |i| 1))) + ((> |i| G169024) (NREVERSE0 G169018)) + (SEQ (EXIT (COND + ((AND + (PROGN + (SPADLET |ISTMP#1| + (ELT |template| |i|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| + (QCAR |ISTMP#1|)) + 'T))) + (IDENTP |op|) + (NULL + (MEMQ |op| + '(|Mapping| |Union| + |Record| |Enumeration| + CONS QUOTE |local|)))) + (SETQ G169018 + (CONS + (|getImports,import| |i| + |template|) + G169018)))))))))) + (|listSort| (|function| GLESSEQP) + (SUBLISLIS (CDR |conform|) |$FormalMapVariableList| + |u|))))))) + +;--============================================================================ +;-- Get Hierarchical Information +;--============================================================================ +;getParentsFor(cname,formalParams,constructorCategory) == +;--called by compDefineFunctor1 +; acc := nil +; formals := TAKE(#formalParams,$TriangleVariableList) +; constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM) +; for x in folks constructorCategory repeat +; x := SUBLISLIS(formalParams,formals,x) +; x := SUBLISLIS(IFCDR constructorForm,formalParams,x) +; x := SUBST('Type,'Object,x) +; acc := [:explodeIfs x,:acc] +; NREVERSE acc + +(DEFUN |getParentsFor| (|cname| |formalParams| |constructorCategory|) + (PROG (|formals| |constructorForm| |acc|) + (declare (special |$TriangleVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SPADLET |formals| + (TAKE (|#| |formalParams|) + |$TriangleVariableList|)) + (SPADLET |constructorForm| + (GETDATABASE |cname| 'CONSTRUCTORFORM)) + (DO ((G169047 (|folks| |constructorCategory|) + (CDR G169047)) + (|x| NIL)) + ((OR (ATOM G169047) + (PROGN (SETQ |x| (CAR G169047)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| + (SUBLISLIS |formalParams| + |formals| |x|)) + (SPADLET |x| + (SUBLISLIS + (IFCDR |constructorForm|) + |formalParams| |x|)) + (SPADLET |x| + (MSUBST '|Type| '|Object| |x|)) + (SPADLET |acc| + (APPEND (|explodeIfs| |x|) |acc|)))))) + (NREVERSE |acc|)))))) + +;parentsOf con == --called by kcpPage, ancestorsRecur +; if null BOUNDP '$parentsCache then SETQ($parentsCache,MAKE_-HASHTABLE 'ID) +; HGET($parentsCache,con) or +; parents := getParentsForDomain con +; HPUT($parentsCache,con,parents) +; parents + +(DEFUN |parentsOf| (|con|) + (PROG (|parents|) + (declare (special |$parentsCache|)) + (RETURN + (PROGN + (COND + ((NULL (BOUNDP '|$parentsCache|)) + (SETQ |$parentsCache| (MAKE-HASHTABLE 'ID)))) + (OR (HGET |$parentsCache| |con|) + (PROGN + (SPADLET |parents| (|getParentsForDomain| |con|)) + (HPUT |$parentsCache| |con| |parents|) + |parents|)))))) + +;parentsOfForm [op,:argl] == +; parents := parentsOf op +; null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) => +; parents +; SUBLISLIS(argl, newArgl, parents) + +(DEFUN |parentsOfForm| (G169070) + (PROG (|op| |argl| |parents| |newArgl|) + (RETURN + (PROGN + (SPADLET |op| (CAR G169070)) + (SPADLET |argl| (CDR G169070)) + (SPADLET |parents| (|parentsOf| |op|)) + (COND + ((OR (NULL |argl|) + (BOOT-EQUAL |argl| + (SPADLET |newArgl| + (CDR (GETDATABASE |op| 'CONSTRUCTORFORM))))) + |parents|) + ('T (SUBLISLIS |argl| |newArgl| |parents|))))))) + +;getParentsForDomain domname == --called by parentsOf +; acc := nil +; for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat +; x := +; GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => +; sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) +; sublisFormal(IFCDR getConstructorForm domname,x) +; acc := [:explodeIfs x,:acc] +; NREVERSE acc + +(DEFUN |getParentsForDomain| (|domname|) + (PROG (|acc|) + (declare (special |$TriangleVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (DO ((G169094 + (|folks| (GETDATABASE |domname| + 'CONSTRUCTORCATEGORY)) + (CDR G169094)) + (|x| NIL)) + ((OR (ATOM G169094) + (PROGN (SETQ |x| (CAR G169094)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| + (COND + ((BOOT-EQUAL + (GETDATABASE |domname| + 'CONSTRUCTORKIND) + '|category|) + (|sublisFormal| + (IFCDR + (|getConstructorForm| + |domname|)) + |x| |$TriangleVariableList|)) + ('T + (|sublisFormal| + (IFCDR + (|getConstructorForm| + |domname|)) + |x|)))) + (SPADLET |acc| + (APPEND (|explodeIfs| |x|) |acc|)))))) + (NREVERSE |acc|)))))) + +;explodeIfs x == main where --called by getParents, getParentsForDomain +; main == +; x is ['IF,p,a,b] => fn(p,a,b) +; [[x,:true]] +; fn(p,a,b) == +; [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]] +; gn(p,a) == +; a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil) +; [[a,:p]] + +(DEFUN |explodeIfs,gn| (|p| |a|) + (PROG (|ISTMP#1| |q| |ISTMP#2| |b|) + (RETURN + (SEQ (IF (AND (PAIRP |a|) (EQ (QCAR |a|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |q| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (|explodeIfs,fn| + (MKPF (CONS |p| (CONS |q| NIL)) 'AND) |b| NIL))) + (EXIT (CONS (CONS |a| |p|) NIL)))))) + +(DEFUN |explodeIfs,fn| (|p| |a| |b|) + (PROG () + (RETURN + (SEQ (APPEND (PROG (G169165) + (SPADLET G169165 NIL) + (RETURN + (DO ((G169170 |a| (CDR G169170)) (|y| NIL)) + ((OR (ATOM G169170) + (PROGN (SETQ |y| (CAR G169170)) NIL)) + G169165) + (SEQ (EXIT (SETQ G169165 + (APPEND G169165 + (|explodeIfs,gn| |p| |y|)))))))) + (PROG (G169176) + (SPADLET G169176 NIL) + (RETURN + (DO ((G169181 |b| (CDR G169181)) (|y| NIL)) + ((OR (ATOM G169181) + (PROGN (SETQ |y| (CAR G169181)) NIL)) + G169176) + (SEQ (EXIT (SETQ G169176 + (APPEND G169176 + (|explodeIfs,gn| + (CONS 'NOT (CONS |p| NIL)) |y|))))))))))))) + +(DEFUN |explodeIfs| (|x|) + (PROG (|ISTMP#1| |p| |ISTMP#2| |a| |ISTMP#3| |b|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#3|)) + 'T)))))))) + (|explodeIfs,fn| |p| |a| |b|)) + ('T (CONS (CONS |x| 'T) NIL)))))) + +;folks u == --called by getParents and getParentsForDomain +; atom u => nil +; u is [op,:v] and MEMQ(op,'(Join PROGN)) +; or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v] +; u is ['SIGNATURE,:.] => nil +; u is ['TYPE,:.] => nil +; u is ['ATTRIBUTE,a] => +; PAIRP a and constructor? opOf a => folks a +; nil +; u is ['IF,p,q,r] => +; q1 := folks q +; r1 := folks r +; q1 or r1 => [['IF,p,q1,r1]] +; nil +; [u] + +(DEFUN |folks| (|u|) + (PROG (|op| |v| |a| |ISTMP#1| |p| |ISTMP#2| |q| |ISTMP#3| |r| |q1| + |r1|) + (RETURN + (SEQ (COND + ((ATOM |u|) NIL) + ((OR (AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |v| (QCDR |u|)) + 'T) + (MEMQ |op| '(|Join| PROGN))) + (AND (PAIRP |u|) (EQ (QCAR |u|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |v| (QCDR |ISTMP#1|)) + 'T))))) + (PROG (G169264) + (SPADLET G169264 NIL) + (RETURN + (DO ((G169269 |v| (CDR G169269)) (|x| NIL)) + ((OR (ATOM G169269) + (PROGN (SETQ |x| (CAR G169269)) NIL)) + G169264) + (SEQ (EXIT (SETQ G169264 + (APPEND G169264 (|folks| |x|))))))))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'SIGNATURE)) NIL) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'TYPE)) NIL) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((AND (PAIRP |a|) (|constructor?| (|opOf| |a|))) + (|folks| |a|)) + ('T NIL))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |q| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |r| (QCAR |ISTMP#3|)) + 'T)))))))) + (SPADLET |q1| (|folks| |q|)) (SPADLET |r1| (|folks| |r|)) + (COND + ((OR |q1| |r1|) + (CONS (CONS 'IF + (CONS |p| (CONS |q1| (CONS |r1| NIL)))) + NIL)) + ('T NIL))) + ('T (CONS |u| NIL))))))) + +;descendantsOf(conform,domform) == --called by kcdPage +; 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => +; cats := catsOf(conform,domform) +; [op,:argl] := conform +; null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) +; => cats +; SUBLISLIS(argl, newArgl, cats) +; 'notAvailable + +(DEFUN |descendantsOf| (|conform| |domform|) + (PROG (|conname| |cats| |op| |argl| |newArgl|) + (RETURN + (COND + ((BOOT-EQUAL '|category| + (GETDATABASE (SPADLET |conname| (|opOf| |conform|)) + 'CONSTRUCTORKIND)) + (SPADLET |cats| (|catsOf| |conform| |domform|)) + (SPADLET |op| (CAR |conform|)) + (SPADLET |argl| (CDR |conform|)) + (COND + ((OR (NULL |argl|) + (BOOT-EQUAL |argl| + (SPADLET |newArgl| + (CDR (GETDATABASE |op| 'CONSTRUCTORFORM))))) + |cats|) + ('T (SUBLISLIS |argl| |newArgl| |cats|)))) + ('T '|notAvailable|))))) + +;childrenOf conform == +; [pair for pair in descendantsOf(conform,nil) | +; childAssoc(conform,parentsOfForm first pair)] + +(DEFUN |childrenOf| (|conform|) + (PROG () + (RETURN + (SEQ (PROG (G169312) + (SPADLET G169312 NIL) + (RETURN + (DO ((G169318 (|descendantsOf| |conform| NIL) + (CDR G169318)) + (|pair| NIL)) + ((OR (ATOM G169318) + (PROGN (SETQ |pair| (CAR G169318)) NIL)) + (NREVERSE0 G169312)) + (SEQ (EXIT (COND + ((|childAssoc| |conform| + (|parentsOfForm| (CAR |pair|))) + (SETQ G169312 (CONS |pair| G169312))))))))))))) + +;childAssoc(form,alist) == +; null (argl := CDR form) => ASSOC(form,alist) +; u := assocCar(opOf form, alist) => childArgCheck(argl,rest CAR u) and u +; nil + +(DEFUN |childAssoc| (|form| |alist|) + (PROG (|argl| |u|) + (RETURN + (COND + ((NULL (SPADLET |argl| (CDR |form|))) (|assoc| |form| |alist|)) + ((SPADLET |u| (|assocCar| (|opOf| |form|) |alist|)) + (AND (|childArgCheck| |argl| (CDR (CAR |u|))) |u|)) + ('T NIL))))) + +;assocCar(x, al) == or/[pair for pair in al | x = CAAR pair] + +(DEFUN |assocCar| (|x| |al|) + (PROG () + (RETURN + (SEQ (PROG (G169334) + (SPADLET G169334 NIL) + (RETURN + (DO ((G169341 NIL G169334) + (G169342 |al| (CDR G169342)) (|pair| NIL)) + ((OR G169341 (ATOM G169342) + (PROGN (SETQ |pair| (CAR G169342)) NIL)) + G169334) + (SEQ (EXIT (COND + ((BOOT-EQUAL |x| (CAAR |pair|)) + (SETQ G169334 (OR G169334 |pair|))))))))))))) + +;childArgCheck(argl, nargl) == +; and/[fn for x in argl for y in nargl for i in 0..] where +; fn == +; x = y or constructor? opOf y => true +; isSharpVar y => i = POSN1(y, $FormalMapVariableList) +; false + +(DEFUN |childArgCheck| (|argl| |nargl|) + (PROG () + (RETURN + (SEQ (PROG (G169355) + (SPADLET G169355 'T) + (RETURN + (DO ((G169363 NIL (NULL G169355)) + (G169364 |argl| (CDR G169364)) (|x| NIL) + (G169365 |nargl| (CDR G169365)) (|y| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR G169363 (ATOM G169364) + (PROGN (SETQ |x| (CAR G169364)) NIL) + (ATOM G169365) + (PROGN (SETQ |y| (CAR G169365)) NIL)) + G169355) + (SEQ (EXIT (SETQ G169355 + (AND G169355 + (COND + ((OR (BOOT-EQUAL |x| |y|) + (|constructor?| + (|opOf| |y|))) + 'T) + ((|isSharpVar| |y|) + (BOOT-EQUAL |i| + (POSN1 |y| + |$FormalMapVariableList|))) + ('T NIL))))))))))))) + +;--computeDescendantsOf cat == +;--dynamically generates descendants +;-- hash := MAKE_-HASHTABLE 'UEQUAL +;-- for [child,:pred] in childrenOf cat repeat +;-- childForm := getConstructorForm child +;-- HPUT(hash,childForm,pred) +;-- for [form,:pred] in descendantsOf(childForm,nil) repeat +;-- newPred := +;-- oldPred := HGET(hash,form) => quickOr(oldPred,pred) +;-- pred +;-- HPUT(hash,form,newPred) +;-- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] +;ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... +; 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => +; alist := GETDATABASE(conname,'ANCESTORS) +; argl := IFCDR domform or IFCDR conform +; [pair for [a,:b] in alist | pair] where pair == +; left := sublisFormal(argl,a) +; right := sublisFormal(argl,b) +; if domform then right := simpHasPred right +; null right => false +; [left,:right] +; computeAncestorsOf(conform,domform) + +(DEFUN |ancestorsOf| (|conform| |domform|) + (PROG (|conname| |alist| |argl| |a| |b| |left| |right|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL '|category| + (GETDATABASE (SPADLET |conname| (|opOf| |conform|)) + 'CONSTRUCTORKIND)) + (SPADLET |alist| (GETDATABASE |conname| 'ANCESTORS)) + (SPADLET |argl| (OR (IFCDR |domform|) (IFCDR |conform|))) + (PROG (G169400) + (SPADLET G169400 NIL) + (RETURN + (DO ((G169411 |alist| (CDR G169411)) + (G169380 NIL)) + ((OR (ATOM G169411) + (PROGN + (SETQ G169380 (CAR G169411)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G169380)) + (SPADLET |b| (CDR G169380)) + G169380) + NIL)) + (NREVERSE0 G169400)) + (SEQ (EXIT (COND + ((PROGN + (SPADLET |left| + (|sublisFormal| |argl| |a|)) + (SPADLET |right| + (|sublisFormal| |argl| |b|)) + (COND + (|domform| + (SPADLET |right| + (|simpHasPred| |right|)))) + (COND + ((NULL |right|) NIL) + ('T (CONS |left| |right|)))) + (SETQ G169400 + (CONS + (PROGN + (SPADLET |left| + (|sublisFormal| |argl| |a|)) + (SPADLET |right| + (|sublisFormal| |argl| |b|)) + (COND + (|domform| + (SPADLET |right| + (|simpHasPred| |right|)))) + (COND + ((NULL |right|) NIL) + ('T (CONS |left| |right|)))) + G169400)))))))))) + ('T (|computeAncestorsOf| |conform| |domform|))))))) + +;computeAncestorsOf(conform,domform) == +; $done: local := MAKE_-HASHTABLE 'UEQUAL +; $if: local := MAKE_-HASHTABLE 'ID +; ancestorsRecur(conform,domform,true,true) +; acc := nil +; for op in listSort(function GLESSEQP,HKEYS $if) repeat +; for pair in HGET($if,op) repeat acc := [pair,:acc] +; NREVERSE acc + +(DEFUN |computeAncestorsOf| (|conform| |domform|) + (PROG (|$done| |$if| |acc|) + (DECLARE (SPECIAL |$done| |$if|)) + (RETURN + (SEQ (PROGN + (SPADLET |$done| (MAKE-HASHTABLE 'UEQUAL)) + (SPADLET |$if| (MAKE-HASHTABLE 'ID)) + (|ancestorsRecur| |conform| |domform| 'T 'T) + (SPADLET |acc| NIL) + (DO ((G169437 + (|listSort| (|function| GLESSEQP) (HKEYS |$if|)) + (CDR G169437)) + (|op| NIL)) + ((OR (ATOM G169437) + (PROGN (SETQ |op| (CAR G169437)) NIL)) + NIL) + (SEQ (EXIT (DO ((G169446 (HGET |$if| |op|) + (CDR G169446)) + (|pair| NIL)) + ((OR (ATOM G169446) + (PROGN + (SETQ |pair| (CAR G169446)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |acc| + (CONS |pair| |acc|)))))))) + (NREVERSE |acc|)))))) + +;ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf +; op := opOf conform +; pred = HGET($done,conform) => nil --skip if already processed +; parents := +; firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => +; $lisplibParents +; parentsOf op +; originalConform := +; firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => $form +; getConstructorForm op +; if conform ^= originalConform then +; parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents) +; for [newform,:p] in parents repeat +; if domform and rest domform then +; newdomform := SUBLISLIS(rest domform,rest conform,newform) +; p := SUBLISLIS(rest domform,rest conform,p) +; newPred := quickAnd(pred,p) +; ancestorsAdd(simpHasPred newPred,newdomform or newform) +; ancestorsRecur(newform,newdomform,newPred,false) +; HPUT($done,conform,pred) --mark as already processed + +(DEFUN |ancestorsRecur| (|conform| |domform| |pred| |firstTime?|) + (PROG (|op| |originalConform| |parents| |newform| |newdomform| |p| + |newPred|) + (declare (special |$done| |$lisplibParents|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (|opOf| |conform|)) + (COND + ((BOOT-EQUAL |pred| (HGET |$done| |conform|)) NIL) + ('T + (SPADLET |parents| + (COND + ((AND |firstTime?| + (OR |$insideCategoryIfTrue| + |$insideFunctorIfTrue|)) + |$lisplibParents|) + ('T (|parentsOf| |op|)))) + (SPADLET |originalConform| + (COND + ((AND |firstTime?| + (OR |$insideCategoryIfTrue| + |$insideFunctorIfTrue|)) + |$form|) + ('T (|getConstructorForm| |op|)))) + (COND + ((NEQUAL |conform| |originalConform|) + (SPADLET |parents| + (SUBLISLIS (IFCDR |conform|) + (IFCDR |originalConform|) + |parents|)))) + (DO ((G169480 |parents| (CDR G169480)) + (G169467 NIL)) + ((OR (ATOM G169480) + (PROGN (SETQ G169467 (CAR G169480)) NIL) + (PROGN + (PROGN + (SPADLET |newform| (CAR G169467)) + (SPADLET |p| (CDR G169467)) + G169467) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((AND |domform| (CDR |domform|)) + (SPADLET |newdomform| + (SUBLISLIS (CDR |domform|) + (CDR |conform|) |newform|)) + (SPADLET |p| + (SUBLISLIS (CDR |domform|) + (CDR |conform|) |p|)))) + (SPADLET |newPred| + (|quickAnd| |pred| |p|)) + (|ancestorsAdd| + (|simpHasPred| |newPred|) + (OR |newdomform| |newform|)) + (|ancestorsRecur| |newform| |newdomform| + |newPred| NIL))))) + (HPUT |$done| |conform| |pred|)))))))) + +;ancestorsAdd(pred,form) == --called by ancestorsRecur +; null pred => nil +; op := IFCAR form or form +; alist := HGET($if,op) +; existingNode := ASSOC(form,alist) => +; RPLACD(existingNode,quickOr(CDR existingNode,pred)) +; HPUT($if,op,[[form,:pred],:alist]) + +(DEFUN |ancestorsAdd| (|pred| |form|) + (PROG (|op| |alist| |existingNode|) + (declare (special |$if|)) + (RETURN + (COND + ((NULL |pred|) NIL) + ('T (SPADLET |op| (OR (IFCAR |form|) |form|)) + (SPADLET |alist| (HGET |$if| |op|)) + (COND + ((SPADLET |existingNode| (|assoc| |form| |alist|)) + (RPLACD |existingNode| + (|quickOr| (CDR |existingNode|) |pred|))) + ('T (HPUT |$if| |op| (CONS (CONS |form| |pred|) |alist|))))))))) + +;domainsOf(conform,domname,:options) == +; $hasArgList := IFCAR options +; conname := opOf conform +; u := [key for key in HKEYS _*HASCATEGORY_-HASH_* +; | key is [anc,: =conname]] +; --u is list of pairs (a . b) where b = conname +; --we sort u then replace each b by the predicate for which this is true +; s := listSort(function GLESSEQP,COPY u) +; s := [[CAR pair,:GETDATABASE(pair,'HASCATEGORY)] for pair in s] +; transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) + +(DEFUN |domainsOf| (&REST G169550 &AUX |options| |domname| |conform|) + (DSETQ (|conform| |domname| . |options|) G169550) + (PROG (|conname| |anc| |u| |s|) + (declare (special |$hasArgList| *hascategory-hash*)) + (RETURN + (SEQ (PROGN + (SPADLET |$hasArgList| (IFCAR |options|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |u| + (PROG (G169512) + (SPADLET G169512 NIL) + (RETURN + (DO ((G169518 (HKEYS *HASCATEGORY-HASH*) + (CDR G169518)) + (|key| NIL)) + ((OR (ATOM G169518) + (PROGN + (SETQ |key| (CAR G169518)) + NIL)) + (NREVERSE0 G169512)) + (SEQ (EXIT (COND + ((AND (PAIRP |key|) + (PROGN + (SPADLET |anc| + (QCAR |key|)) + 'T) + (EQUAL (QCDR |key|) + |conname|)) + (SETQ G169512 + (CONS |key| G169512)))))))))) + (SPADLET |s| + (|listSort| (|function| GLESSEQP) (COPY |u|))) + (SPADLET |s| + (PROG (G169528) + (SPADLET G169528 NIL) + (RETURN + (DO ((G169533 |s| (CDR G169533)) + (|pair| NIL)) + ((OR (ATOM G169533) + (PROGN + (SETQ |pair| (CAR G169533)) + NIL)) + (NREVERSE0 G169528)) + (SEQ (EXIT (SETQ G169528 + (CONS + (CONS (CAR |pair|) + (GETDATABASE |pair| + 'HASCATEGORY)) + G169528)))))))) + (|transKCatAlist| |conform| |domname| + (|listSort| (|function| GLESSEQP) |s|))))))) + +;catsOf(conform,domname,:options) == +; $hasArgList := IFCAR options +; conname := opOf conform +; alist := nil +; for key in allConstructors() repeat +; for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat +; [[op,:args],:pred] := item +; newItem := +; args => [[args,:pred],:LASSOC(key,alist)] +; pred +; alist := insertShortAlist(key,newItem,alist) +; transKCatAlist(conform,domname,listSort(function GLESSEQP,alist)) + +(DEFUN |catsOf| (&REST G169598 &AUX |options| |domname| |conform|) + (DSETQ (|conform| |domname| . |options|) G169598) + (PROG (|conname| |op| |args| |pred| |newItem| |alist|) + (declare (special |$hasArgList|)) + (RETURN + (SEQ (PROGN + (SPADLET |$hasArgList| (IFCAR |options|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |alist| NIL) + (DO ((G169566 (|allConstructors|) (CDR G169566)) + (|key| NIL)) + ((OR (ATOM G169566) + (PROGN (SETQ |key| (CAR G169566)) NIL)) + NIL) + (SEQ (EXIT (DO ((G169581 + (GETDATABASE |key| 'ANCESTORS) + (CDR G169581)) + (|item| NIL)) + ((OR (ATOM G169581) + (PROGN + (SETQ |item| (CAR G169581)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |conname| + (CAAR |item|)) + (PROGN + (SPADLET |op| + (CAAR |item|)) + (SPADLET |args| + (CDAR |item|)) + (SPADLET |pred| + (CDR |item|)) + (SPADLET |newItem| + (COND + (|args| + (CONS + (CONS |args| |pred|) + (LASSOC |key| |alist|))) + ('T |pred|))) + (SPADLET |alist| + (|insertShortAlist| |key| + |newItem| |alist|))))))))))) + (|transKCatAlist| |conform| |domname| + (|listSort| (|function| GLESSEQP) |alist|))))))) + +;transKCatAlist(conform,domname,s) == main where +; main == +; domname => --accept only exact matches after substitution +; domargs := rest domname +; acc := nil +; rest conform => +; for pair in s repeat --pair has form [con,[conargs,:pred],...]] +; leftForm := getConstructorForm CAR pair +; for (ap := [args,:pred]) in CDR pair repeat +; match? := +; domargs = args => true +; HAS__SHARP__VAR args => domargs = sublisFormal(KDR domname,args) +; nil +; null match? => 'skip +; npred := sublisFormal(KDR leftForm,pred) +; acc := [[leftForm,:npred],:acc] +; NREVERSE acc +; --conform has no arguments so each pair has form [con,:pred] +; for pair in s repeat +; leftForm := getConstructorForm CAR pair or systemError nil +; RPLACA(pair,leftForm) +; RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) +; s +; --no domname, so look for special argument combinations +; acc := nil +; KDR conform => +; farglist := TAKE(#rest conform,$FormalMapVariableList) +; for pair in s repeat --pair has form [con,[conargs,:pred],...]] +; leftForm := getConstructorForm CAR pair +; for (ap := [args,:pred]) in CDR pair repeat +; hasArgsForm? := args ^= farglist +; npred := sublisFormal(KDR leftForm,pred) +; if hasArgsForm? then +; subargs := sublisFormal(KDR leftForm,args) +; hpred := +;-- $hasArgsList => mkHasArgsPred subargs +; ['hasArgs,:subargs] +; npred := quickAnd(hpred,npred) +; acc := [[leftForm,:npred],:acc] +; NREVERSE acc +; for pair in s repeat --pair has form [con,:pred] +; leftForm := getConstructorForm CAR pair +; RPLACA(pair,leftForm) +; RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) +; s + +(DEFUN |transKCatAlist| (|conform| |domname| |s|) + (PROG (|domargs| |match?| |farglist| |args| |pred| |hasArgsForm?| + |subargs| |hpred| |npred| |acc| |leftForm|) + (RETURN + (SEQ (COND + (|domname| (SPADLET |domargs| (CDR |domname|)) + (SPADLET |acc| NIL) + (COND + ((CDR |conform|) + (DO ((G169634 |s| (CDR G169634)) (|pair| NIL)) + ((OR (ATOM G169634) + (PROGN (SETQ |pair| (CAR G169634)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |leftForm| + (|getConstructorForm| (CAR |pair|))) + (DO + ((G169646 (CDR |pair|) + (CDR G169646)) + (|ap| NIL)) + ((OR (ATOM G169646) + (PROGN + (SETQ |ap| (CAR G169646)) + NIL) + (PROGN + (PROGN + (SPADLET |args| (CAR |ap|)) + (SPADLET |pred| (CDR |ap|)) + |ap|) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |match?| + (COND + ((BOOT-EQUAL |domargs| + |args|) + 'T) + ((HAS_SHARP_VAR |args|) + (BOOT-EQUAL |domargs| + (|sublisFormal| + (KDR |domname|) |args|))) + ('T NIL))) + (COND + ((NULL |match?|) '|skip|) + ('T + (SPADLET |npred| + (|sublisFormal| + (KDR |leftForm|) |pred|)) + (SPADLET |acc| + (CONS + (CONS |leftForm| |npred|) + |acc|)))))))))))) + (NREVERSE |acc|)) + ('T + (DO ((G169659 |s| (CDR G169659)) (|pair| NIL)) + ((OR (ATOM G169659) + (PROGN (SETQ |pair| (CAR G169659)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |leftForm| + (OR + (|getConstructorForm| + (CAR |pair|)) + (|systemError| NIL))) + (RPLACA |pair| |leftForm|) + (RPLACD |pair| + (|sublisFormal| (KDR |leftForm|) + (CDR |pair|))))))) + |s|))) + ('T (SPADLET |acc| NIL) + (COND + ((KDR |conform|) + (SPADLET |farglist| + (TAKE (|#| (CDR |conform|)) + |$FormalMapVariableList|)) + (DO ((G169677 |s| (CDR G169677)) (|pair| NIL)) + ((OR (ATOM G169677) + (PROGN (SETQ |pair| (CAR G169677)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |leftForm| + (|getConstructorForm| + (CAR |pair|))) + (DO ((G169691 (CDR |pair|) + (CDR G169691)) + (|ap| NIL)) + ((OR (ATOM G169691) + (PROGN + (SETQ |ap| (CAR G169691)) + NIL) + (PROGN + (PROGN + (SPADLET |args| (CAR |ap|)) + (SPADLET |pred| (CDR |ap|)) + |ap|) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |hasArgsForm?| + (NEQUAL |args| |farglist|)) + (SPADLET |npred| + (|sublisFormal| + (KDR |leftForm|) |pred|)) + (COND + (|hasArgsForm?| + (SPADLET |subargs| + (|sublisFormal| + (KDR |leftForm|) |args|)) + (SPADLET |hpred| + (CONS '|hasArgs| + |subargs|)) + (SPADLET |npred| + (|quickAnd| |hpred| + |npred|)))) + (SPADLET |acc| + (CONS + (CONS |leftForm| |npred|) + |acc|)))))))))) + (NREVERSE |acc|)) + ('T + (DO ((G169704 |s| (CDR G169704)) (|pair| NIL)) + ((OR (ATOM G169704) + (PROGN (SETQ |pair| (CAR G169704)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |leftForm| + (|getConstructorForm| + (CAR |pair|))) + (RPLACA |pair| |leftForm|) + (RPLACD |pair| + (|sublisFormal| + (KDR |leftForm|) (CDR |pair|))))))) + |s|)))))))) + +;mkHasArgsPred subargs == +;--$hasArgsList gives arguments of original constructor,e.g. LODO(A,M) +;--M is required to be Join(B,...); in looking for the domains of B +;-- we can find that if B has special value C, it can +; systemError subargs + +(DEFUN |mkHasArgsPred| (|subargs|) (|systemError| |subargs|)) + +;sublisFormal(args,exp,:options) == main where +; main == --use only on LIST structures; see also sublisFormalAlist +; $formals: local := IFCAR options or $FormalMapVariableList +; null args => exp +; sublisFormal1(args,exp,#args - 1) +; sublisFormal1(args,x,n) == --[sublisFormal1(args,y) for y in x] +; x is [.,:.] => +; acc := nil +; y := x +; while null atom y repeat +; acc := [sublisFormal1(args,QCAR y,n),:acc] +; y := QCDR y +; r := NREVERSE acc +; if y then +; nd := LASTNODE r +; RPLACD(nd,sublisFormal1(args,y,n)) +; r +; IDENTP x => +; j := or/[i for f in $formals for i in 0..n | EQ(f,x)] => +; args.j +; x +; x + +(DEFUN |sublisFormal,sublisFormal1| (|args| |x| |n|) + (PROG (|.| |acc| |y| |r| |nd| |j|) + (declare (special |$formals|)) + (RETURN + (SEQ (IF (AND (PAIRP |x|) (PROGN (SPADLET |.| (QCDR |x|)) 'T)) + (EXIT (SEQ (SPADLET |acc| NIL) (SPADLET |y| |x|) + (DO () ((NULL (NULL (ATOM |y|))) NIL) + (SEQ (SPADLET |acc| + (CONS + (|sublisFormal,sublisFormal1| + |args| (QCAR |y|) |n|) + |acc|)) + (EXIT (SPADLET |y| (QCDR |y|))))) + (SPADLET |r| (NREVERSE |acc|)) + (IF |y| + (SEQ (SPADLET |nd| (LASTNODE |r|)) + (EXIT + (RPLACD |nd| + (|sublisFormal,sublisFormal1| + |args| |y| |n|)))) + NIL) + (EXIT |r|)))) + (IF (IDENTP |x|) + (EXIT (SEQ (IF (SPADLET |j| + (PROG (G169749) + (SPADLET G169749 NIL) + (RETURN + (DO + ((G169757 NIL G169749) + (G169758 |$formals| + (CDR G169758)) + (|f| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR G169757 + (ATOM G169758) + (PROGN + (SETQ |f| + (CAR G169758)) + NIL) + (QSGREATERP |i| |n|)) + G169749) + (SEQ + (EXIT + (COND + ((EQ |f| |x|) + (SETQ G169749 + (OR G169749 |i|)))))))))) + (EXIT (ELT |args| |j|))) + (EXIT |x|)))) + (EXIT |x|))))) + +(DEFUN |sublisFormal| (&REST G169785 &AUX |options| |exp| |args|) + (DSETQ (|args| |exp| . |options|) G169785) + (PROG (|$formals|) + (DECLARE (SPECIAL |$formals|)) + (RETURN + (PROGN + (SPADLET |$formals| + (OR (IFCAR |options|) |$FormalMapVariableList|)) + (COND + ((NULL |args|) |exp|) + ('T + (|sublisFormal,sublisFormal1| |args| |exp| + (SPADDIFFERENCE (|#| |args|) 1)))))))) + +;--======================================================================= +;-- Build Table of Lower Case Constructor Names +;--======================================================================= +;buildDefaultPackageNamesHT() == +; $defaultPackageNamesHT := MAKE_-HASH_-TABLE() +; for nam in allConstructors() | isDefaultPackageName nam repeat +; HPUT($defaultPackageNamesHT,nam,true) +; $defaultPackageNamesHT + +(DEFUN |buildDefaultPackageNamesHT| () + (declare (special |$defaultPackageNamesHT|)) + (SEQ (PROGN + (SPADLET |$defaultPackageNamesHT| (MAKE-HASH-TABLE)) + (DO ((G169791 (|allConstructors|) (CDR G169791)) + (|nam| NIL)) + ((OR (ATOM G169791) + (PROGN (SETQ |nam| (CAR G169791)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|isDefaultPackageName| |nam|) + (HPUT |$defaultPackageNamesHT| |nam| 'T)))))) + |$defaultPackageNamesHT|))) + +;$defaultPackageNamesHT := buildDefaultPackageNamesHT() + +(SPADLET |$defaultPackageNamesHT| (|buildDefaultPackageNamesHT|)) + +;--======================================================================= +;-- Code for Private Libdbs +;--======================================================================= +;-- $createLocalLibDb := false +;extendLocalLibdb conlist == -- called by astran +; not $createLocalLibDb => nil +; null conlist => nil +; buildLibdb conlist --> puts datafile into temp.text +; $newConstructorList := UNION(conlist, $newConstructorList) +; localLibdb := '"libdb.text" +; not PROBE_-FILE '"libdb.text" => +; RENAME_-FILE('"temp.text",'"libdb.text") +; oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) +; newlines := dbReadLines '"temp.text" +; dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") +; deleteFile '"temp.text" + +(DEFUN |extendLocalLibdb| (|conlist|) + (PROG (|localLibdb| |oldlines| |newlines|) + (declare (special |$createLocalLibDb| |$newConstructorList|)) + (RETURN + (COND + ((NULL |$createLocalLibDb|) NIL) + ((NULL |conlist|) NIL) + ('T (|buildLibdb| |conlist|) + (SPADLET |$newConstructorList| + (|union| |conlist| |$newConstructorList|)) + (SPADLET |localLibdb| (MAKESTRING "libdb.text")) + (COND + ((NULL (PROBE-FILE (MAKESTRING "libdb.text"))) + (RENAME-FILE (MAKESTRING "temp.text") + (MAKESTRING "libdb.text"))) + ('T + (SPADLET |oldlines| + (|purgeNewConstructorLines| + (|dbReadLines| |localLibdb|) |conlist|)) + (SPADLET |newlines| + (|dbReadLines| (MAKESTRING "temp.text"))) + (|dbWriteLines| (MSORT (|union| |oldlines| |newlines|)) + (MAKESTRING "libdb.text")) + (|deleteFile| (MAKESTRING "temp.text"))))))))) + +;$returnNowhereFromGoGet := false + +(SPADLET |$returnNowhereFromGoGet| NIL) + +;showSummary dom == +; showPredicates dom +; showAttributes dom +; showFrom dom +; showImp dom + +(DEFUN |showSummary| (|dom|) + (PROGN + (|showPredicates| |dom|) + (|showAttributes| |dom|) + (|showFrom| |dom|) + (|showImp| |dom|))) + +;--======================================================================= +;-- Show Where Functions in Domain are Implemented +;--======================================================================= +;showImp(dom,:options) == +; sayBrightly '"-------------Operation summary-----------------" +; missingOnlyFlag := KAR options +; domainForm := devaluate dom +; [nam,:$domainArgs] := domainForm +; $predicateList: local := GETDATABASE(nam,'PREDICATES) +; predVector := dom.3 +; u := getDomainOpTable(dom,true) +; --sort into 4 groups: domain exports, unexports, default exports, others +; for (x := [.,.,:key]) in u repeat +; key = domainForm => domexports := [x,:domexports] +; FIXP key => unexports := [x,:unexports] +; isDefaultPackageForm? key => defexports := [x,:defexports] +; key = 'nowhere => nowheres := [x,:nowheres] +; key = 'constant => constants := [x,:constants] +; others := [x,:others] --add chain domains go here +; sayBrightly +; nowheres => ['"Functions exported but not implemented by", +; :bright form2String domainForm,'":"] +; [:bright form2String domainForm,'"implements all exported operations"] +; showDomainsOp1(nowheres,'nowhere) +; missingOnlyFlag => 'done +; --first display those exported by the domain, then add chain guys +; u := [:domexports,:constants,:SORTBY('CDDR,others)] +; while u repeat +; [.,.,:key] := CAR u +; sayBrightly +; key = 'constant => +; ["Constants implemented by",:bright form2String key,'":"] +; ["Functions implemented by",:bright form2String key,'":"] +; u := showDomainsOp1(u,key) +; u := SORTBY('CDDR,defexports) +; while u repeat +; [.,.,:key] := CAR u +; defop := INTERN(SUBSTRING((s := PNAME CAR key),0,MAXINDEX s)) +; domainForm := [defop,:CDDR key] +; sayBrightly ["Default functions from",:bright form2String domainForm,'":"] +; u := showDomainsOp1(u,key) +; u := SORTBY('CDDR,unexports) +; while u repeat +; [.,.,:key] := CAR u +; sayBrightly ["Not exported: "] +; u := showDomainsOp1(u,key) + +(DEFUN |showImp| (&REST G169917 &AUX |options| |dom|) + (DSETQ (|dom| . |options|) G169917) + (PROG (|$predicateList| |missingOnlyFlag| |nam| |predVector| + |domexports| |unexports| |defexports| |nowheres| + |constants| |others| |s| |defop| |domainForm| |LETTMP#1| + |key| |u|) + (DECLARE (SPECIAL |$predicateList| |$domainArgs|)) + (RETURN + (SEQ (PROGN + (|sayBrightly| + (MAKESTRING + "-------------Operation summary-----------------")) + (SPADLET |missingOnlyFlag| (KAR |options|)) + (SPADLET |domainForm| (|devaluate| |dom|)) + (SPADLET |nam| (CAR |domainForm|)) + (SPADLET |$domainArgs| (CDR |domainForm|)) + (SPADLET |$predicateList| (GETDATABASE |nam| 'PREDICATES)) + (SPADLET |predVector| (ELT |dom| 3)) + (SPADLET |u| (|getDomainOpTable| |dom| 'T)) + (DO ((G169844 |u| (CDR G169844)) (|x| NIL)) + ((OR (ATOM G169844) + (PROGN (SETQ |x| (CAR G169844)) NIL) + (PROGN + (PROGN (SPADLET |key| (CDDR |x|)) |x|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |key| |domainForm|) + (SPADLET |domexports| + (CONS |x| |domexports|))) + ((FIXP |key|) + (SPADLET |unexports| + (CONS |x| |unexports|))) + ((|isDefaultPackageForm?| |key|) + (SPADLET |defexports| + (CONS |x| |defexports|))) + ((BOOT-EQUAL |key| '|nowhere|) + (SPADLET |nowheres| (CONS |x| |nowheres|))) + ((BOOT-EQUAL |key| '|constant|) + (SPADLET |constants| + (CONS |x| |constants|))) + ('T (SPADLET |others| (CONS |x| |others|))))))) + (|sayBrightly| + (COND + (|nowheres| + (CONS (MAKESTRING + "Functions exported but not implemented by") + (APPEND (|bright| + (|form2String| |domainForm|)) + (CONS (MAKESTRING ":") NIL)))) + ('T + (APPEND (|bright| (|form2String| |domainForm|)) + (CONS (MAKESTRING + "implements all exported operations") + NIL))))) + (|showDomainsOp1| |nowheres| '|nowhere|) + (COND + (|missingOnlyFlag| '|done|) + ('T + (SPADLET |u| + (APPEND |domexports| + (APPEND |constants| + (SORTBY 'CDDR |others|)))) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| (CAR |u|)) + (SPADLET |key| (CDDR |LETTMP#1|)) + (|sayBrightly| + (COND + ((BOOT-EQUAL |key| '|constant|) + (CONS '|Constants implemented by| + (APPEND + (|bright| + (|form2String| |key|)) + (CONS (MAKESTRING ":") NIL)))) + ('T + (CONS '|Functions implemented by| + (APPEND + (|bright| + (|form2String| |key|)) + (CONS (MAKESTRING ":") NIL)))))) + (SPADLET |u| + (|showDomainsOp1| |u| |key|)))))) + (SPADLET |u| (SORTBY 'CDDR |defexports|)) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| (CAR |u|)) + (SPADLET |key| (CDDR |LETTMP#1|)) + (SPADLET |defop| + (INTERN + (SUBSTRING + (SPADLET |s| + (PNAME (CAR |key|))) + 0 (MAXINDEX |s|)))) + (SPADLET |domainForm| + (CONS |defop| (CDDR |key|))) + (|sayBrightly| + (CONS + (MAKESTRING + "Default functions from") + (APPEND + (|bright| + (|form2String| |domainForm|)) + (CONS (MAKESTRING ":") NIL)))) + (SPADLET |u| + (|showDomainsOp1| |u| |key|)))))) + (SPADLET |u| (SORTBY 'CDDR |unexports|)) + (DO () ((NULL |u|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| (CAR |u|)) + (SPADLET |key| (CDDR |LETTMP#1|)) + (|sayBrightly| + (CONS (MAKESTRING "Not exported: ") + NIL)) + (SPADLET |u| + (|showDomainsOp1| |u| |key|))))))))))))) + +;--======================================================================= +;-- Show Information Directly From Domains +;--======================================================================= +;showFrom(D,:option) == +; ops := KAR option +; alist := nil +; domainForm := devaluate D +; [nam,:.] := domainForm +; $predicateList: local := GETDATABASE(nam,'PREDICATES) +; for (opSig := [op,sig]) in getDomainSigs1(D,ops) repeat +; u := from?(D,op,sig) +; x := ASSOC(u,alist) => RPLACD(x,[opSig,:rest x]) +; alist := [[u,opSig],:alist] +; for [conform,:l] in alist repeat +; sayBrightly concat('"From ",form2String conform,'":") +; for [op,sig] in l repeat sayBrightly ['" ",:formatOpSignature(op,sig)] + +(DEFUN |showFrom| (&REST G169993 &AUX |option| D) + (DSETQ (D . |option|) G169993) + (PROG (|$predicateList| |ops| |domainForm| |nam| |u| |x| |alist| + |conform| |l| |op| |sig|) + (DECLARE (SPECIAL |$predicateList|)) + (RETURN + (SEQ (PROGN + (SPADLET |ops| (KAR |option|)) + (SPADLET |alist| NIL) + (SPADLET |domainForm| (|devaluate| D)) + (SPADLET |nam| (CAR |domainForm|)) + (SPADLET |$predicateList| (GETDATABASE |nam| 'PREDICATES)) + (DO ((G169940 (|getDomainSigs1| D |ops|) + (CDR G169940)) + (|opSig| NIL)) + ((OR (ATOM G169940) + (PROGN (SETQ |opSig| (CAR G169940)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR |opSig|)) + (SPADLET |sig| (CADR |opSig|)) + |opSig|) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |u| (|from?| D |op| |sig|)) + (COND + ((SPADLET |x| (|assoc| |u| |alist|)) + (RPLACD |x| (CONS |opSig| (CDR |x|)))) + ('T + (SPADLET |alist| + (CONS + (CONS |u| (CONS |opSig| NIL)) + |alist|)))))))) + (DO ((G169956 |alist| (CDR G169956)) (G169929 NIL)) + ((OR (ATOM G169956) + (PROGN (SETQ G169929 (CAR G169956)) NIL) + (PROGN + (PROGN + (SPADLET |conform| (CAR G169929)) + (SPADLET |l| (CDR G169929)) + G169929) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|sayBrightly| + (|concat| (MAKESTRING "From ") + (|form2String| |conform|) + (MAKESTRING ":"))) + (DO ((G169967 |l| (CDR G169967)) + (G169924 NIL)) + ((OR (ATOM G169967) + (PROGN + (SETQ G169924 (CAR G169967)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G169924)) + (SPADLET |sig| + (CADR G169924)) + G169924) + NIL)) + NIL) + (SEQ (EXIT + (|sayBrightly| + (CONS (MAKESTRING " ") + (|formatOpSignature| |op| |sig|))))))))))))))) + +;--======================================================================= +;-- Functions implementing showFrom +;--======================================================================= +;getDomainOps D == +; domname := D.0 +; conname := CAR domname +; $predicateList: local := GETDATABASE(conname,'PREDICATES) +; REMDUP listSort(function GLESSEQP,ASSOCLEFT getDomainOpTable(D,nil)) + +(DEFUN |getDomainOps| (D) + (PROG (|$predicateList| |domname| |conname|) + (DECLARE (SPECIAL |$predicateList|)) + (RETURN + (PROGN + (SPADLET |domname| (ELT D 0)) + (SPADLET |conname| (CAR |domname|)) + (SPADLET |$predicateList| (GETDATABASE |conname| 'PREDICATES)) + (REMDUP (|listSort| (|function| GLESSEQP) + (ASSOCLEFT (|getDomainOpTable| D NIL)))))))) + +;getDomainSigs(D,:option) == +; domname := D.0 +; conname := CAR domname +; $predicateList: local := GETDATABASE(conname,'PREDICATES) +; getDomainSigs1(D,first option) + +(DEFUN |getDomainSigs| (&REST G170012 &AUX |option| D) + (DSETQ (D . |option|) G170012) + (PROG (|$predicateList| |domname| |conname|) + (DECLARE (SPECIAL |$predicateList|)) + (RETURN + (PROGN + (SPADLET |domname| (ELT D 0)) + (SPADLET |conname| (CAR |domname|)) + (SPADLET |$predicateList| (GETDATABASE |conname| 'PREDICATES)) + (|getDomainSigs1| D (CAR |option|)))))) + +;getDomainSigs1(D,ops) == listSort(function GLESSEQP,u) where +; u == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] + +(DEFUN |getDomainSigs1| (D |ops|) + (PROG () + (RETURN + (SEQ (|listSort| (|function| GLESSEQP) + (PROG (G170019) + (SPADLET G170019 NIL) + (RETURN + (DO ((G170025 (|getDomainOpTable| D NIL) + (CDR G170025)) + (|x| NIL)) + ((OR (ATOM G170025) + (PROGN (SETQ |x| (CAR G170025)) NIL)) + (NREVERSE0 G170019)) + (SEQ (EXIT (COND + ((OR (NULL |ops|) + (MEMQ (CAR |x|) |ops|)) + (SETQ G170019 + (CONS |x| G170019)))))))))))))) + +;getDomainDocs(D,:option) == +; domname := D.0 +; conname := CAR domname +; $predicateList: local := GETDATABASE(conname,'PREDICATES) +; ops := KAR option +; [[op,sig,:getInheritanceByDoc(D,op,sig)] for [op,sig] in getDomainSigs1(D,ops)] + +(DEFUN |getDomainDocs| (&REST G170070 &AUX |option| D) + (DSETQ (D . |option|) G170070) + (PROG (|$predicateList| |domname| |conname| |ops| |op| |sig|) + (DECLARE (SPECIAL |$predicateList|)) + (RETURN + (SEQ (PROGN + (SPADLET |domname| (ELT D 0)) + (SPADLET |conname| (CAR |domname|)) + (SPADLET |$predicateList| + (GETDATABASE |conname| 'PREDICATES)) + (SPADLET |ops| (KAR |option|)) + (PROG (G170045) + (SPADLET G170045 NIL) + (RETURN + (DO ((G170051 (|getDomainSigs1| D |ops|) + (CDR G170051)) + (G170035 NIL)) + ((OR (ATOM G170051) + (PROGN (SETQ G170035 (CAR G170051)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G170035)) + (SPADLET |sig| (CADR G170035)) + G170035) + NIL)) + (NREVERSE0 G170045)) + (SEQ (EXIT (SETQ G170045 + (CONS + (CONS |op| + (CONS |sig| + (|getInheritanceByDoc| D |op| + |sig|))) + G170045)))))))))))) + +;--======================================================================= +;-- Getting Inheritance Info from Documentation in Lisplib +;--======================================================================= +;from?(D,op,sig) == KAR KDR getInheritanceByDoc(D,op,sig) + +(DEFUN |from?| (D |op| |sig|) + (KAR (KDR (|getInheritanceByDoc| D |op| |sig|)))) + +;getExtensionsOfDomain domain == +; u := getDomainExtensionsOfDomain domain +; cats := getCategoriesOfDomain domain +; for x in u repeat +; cats := UNION(cats,getCategoriesOfDomain EVAL x) +; [:u,:cats] + +(DEFUN |getExtensionsOfDomain| (|domain|) + (PROG (|u| |cats|) + (RETURN + (SEQ (PROGN + (SPADLET |u| (|getDomainExtensionsOfDomain| |domain|)) + (SPADLET |cats| (|getCategoriesOfDomain| |domain|)) + (DO ((G170078 |u| (CDR G170078)) (|x| NIL)) + ((OR (ATOM G170078) + (PROGN (SETQ |x| (CAR G170078)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |cats| + (|union| |cats| + (|getCategoriesOfDomain| + (EVAL |x|))))))) + (APPEND |u| |cats|)))))) + +;getDomainExtensionsOfDomain domain == +; acc := nil +; d := domain +; while (u := devaluateSlotDomain(5,d)) repeat +; acc := [u,:acc] +; d := EVAL u +; acc + +(DEFUN |getDomainExtensionsOfDomain| (|domain|) + (PROG (|u| |acc| |d|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SPADLET |d| |domain|) + (DO () + ((NULL (SPADLET |u| (|devaluateSlotDomain| 5 |d|))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |acc| (CONS |u| |acc|)) + (SPADLET |d| (EVAL |u|)))))) + |acc|))))) + +;devaluateSlotDomain(u,dollar) == +; u = '$ => devaluate dollar +; FIXP u and VECP (y := dollar.u) => devaluate y +; u is ['NRTEVAL,y] => MKQ eval y +; u is ['QUOTE,y] => u +; u is [op,:argl] => [op,:[devaluateSlotDomain(x,dollar) for x in argl]] +; devaluate evalSlotDomain(u,dollar) + +(DEFUN |devaluateSlotDomain| (|u| |dollar|) + (PROG (|ISTMP#1| |y| |op| |argl|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |u| '$) (|devaluate| |dollar|)) + ((AND (FIXP |u|) (VECP (SPADLET |y| (ELT |dollar| |u|)))) + (|devaluate| |y|)) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'NRTEVAL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + (MKQ (|eval| |y|))) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + |u|) + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |argl| (QCDR |u|)) + 'T)) + (CONS |op| + (PROG (G170124) + (SPADLET G170124 NIL) + (RETURN + (DO ((G170129 |argl| (CDR G170129)) + (|x| NIL)) + ((OR (ATOM G170129) + (PROGN + (SETQ |x| (CAR G170129)) + NIL)) + (NREVERSE0 G170124)) + (SEQ (EXIT (SETQ G170124 + (CONS + (|devaluateSlotDomain| |x| + |dollar|) + G170124))))))))) + ('T (|devaluate| (|evalSlotDomain| |u| |dollar|)))))))) + +;getCategoriesOfDomain domain == +; predkeyVec := domain.4.0 +; catforms := CADR domain.4 +; [fn for i in 0..MAXINDEX predkeyVec | test] where +; test == predkeyVec.i and +; (x := catforms . i) isnt ['DomainSubstitutionMacro,:.] +; fn == +; VECP x => devaluate x +; devaluateSlotDomain(x,domain) + +(DEFUN |getCategoriesOfDomain| (|domain|) + (PROG (|predkeyVec| |catforms| |x| |ISTMP#1|) + (RETURN + (SEQ (PROGN + (SPADLET |predkeyVec| (ELT (ELT |domain| 4) 0)) + (SPADLET |catforms| (CADR (ELT |domain| 4))) + (PROG (G170158) + (SPADLET G170158 NIL) + (RETURN + (DO ((G170164 (MAXINDEX |predkeyVec|)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G170164) (NREVERSE0 G170158)) + (SEQ (EXIT (COND + ((AND (ELT |predkeyVec| |i|) + (NULL + (PROGN + (SPADLET |ISTMP#1| + (SPADLET |x| + (ELT |catforms| |i|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|DomainSubstitutionMacro|))))) + (SETQ G170158 + (CONS + (COND + ((VECP |x|) + (|devaluate| |x|)) + ('T + (|devaluateSlotDomain| |x| + |domain|))) + G170158)))))))))))))) + +;getInheritanceByDoc(D,op,sig,:options) == +;--gets inheritance and documentation information by looking in the LISPLIB +;--for each ancestor of the domain +; catList := KAR options or getExtensionsOfDomain D +; getDocDomainForOpSig(op,sig,devaluate D,D) or +; or/[fn for x in catList] or '(NIL NIL) +; where fn == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) + +(DEFUN |getInheritanceByDoc| + (&REST G170197 &AUX |options| |sig| |op| D) + (DSETQ (D |op| |sig| . |options|) G170197) + (PROG (|catList|) + (RETURN + (SEQ (PROGN + (SPADLET |catList| + (OR (KAR |options|) (|getExtensionsOfDomain| D))) + (OR (|getDocDomainForOpSig| |op| |sig| (|devaluate| D) D) + (PROG (G170178) + (SPADLET G170178 NIL) + (RETURN + (DO ((G170184 NIL G170178) + (G170185 |catList| (CDR G170185)) + (|x| NIL)) + ((OR G170184 (ATOM G170185) + (PROGN (SETQ |x| (CAR G170185)) NIL)) + G170178) + (SEQ (EXIT (SETQ G170178 + (OR G170178 + (|getDocDomainForOpSig| |op| + |sig| + (|substDomainArgs| D |x|) D)))))))) + '(NIL NIL))))))) + +;getDocDomainForOpSig(op,sig,dollar,D) == +; (u := LASSOC(op,GETDATABASE(CAR dollar,'DOCUMENTATION))) +; and (doc := or/[[d,dollar] for [s,:d] in u | compareSig(sig,s,D,dollar)]) + +(DEFUN |getDocDomainForOpSig| (|op| |sig| |dollar| D) + (PROG (|u| |s| |d| |doc|) + (RETURN + (SEQ (AND (SPADLET |u| + (LASSOC |op| + (GETDATABASE (CAR |dollar|) + 'DOCUMENTATION))) + (SPADLET |doc| + (PROG (G170202) + (SPADLET G170202 NIL) + (RETURN + (DO ((G170210 NIL G170202) + (G170211 |u| (CDR G170211)) + (G170198 NIL)) + ((OR G170210 (ATOM G170211) + (PROGN + (SETQ G170198 + (CAR G170211)) + NIL) + (PROGN + (PROGN + (SPADLET |s| (CAR G170198)) + (SPADLET |d| (CDR G170198)) + G170198) + NIL)) + G170202) + (SEQ (EXIT + (COND + ((|compareSig| |sig| |s| D + |dollar|) + (SETQ G170202 + (OR G170202 + (CONS |d| + (CONS |dollar| NIL))))))))))))))))) + +;--======================================================================= +;-- Functions implementing showImp +;--======================================================================= +;showDomainsOp1(u,key) == +; while u and CAR u is [op,sig,: =key] repeat +; sayBrightly ['" ",:formatOpSignature(op,sig)] +; u := rest u +; u + +(DEFUN |showDomainsOp1| (|u| |key|) + (PROG (|ISTMP#1| |op| |ISTMP#2| |sig|) + (RETURN + (SEQ (PROGN + (DO () + ((NULL (AND |u| + (PROGN + (SPADLET |ISTMP#1| (CAR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |sig| + (QCAR |ISTMP#2|)) + 'T) + (EQUAL (QCDR |ISTMP#2|) |key|))))))) + NIL) + (SEQ (EXIT (PROGN + (|sayBrightly| + (CONS (MAKESTRING " ") + (|formatOpSignature| |op| |sig|))) + (SPADLET |u| (CDR |u|)))))) + |u|))))) + +;getDomainRefName(dom,nam) == +; PAIRP nam => [getDomainRefName(dom,x) for x in nam] +; not FIXP nam => nam +; slot := dom.nam +; VECP slot => slot.0 +; slot is ['SETELT,:.] => getDomainRefName(dom,getDomainSeteltForm slot) +; slot + +(DEFUN |getDomainRefName| (|dom| |nam|) + (PROG (|slot|) + (RETURN + (SEQ (COND + ((PAIRP |nam|) + (PROG (G170266) + (SPADLET G170266 NIL) + (RETURN + (DO ((G170271 |nam| (CDR G170271)) (|x| NIL)) + ((OR (ATOM G170271) + (PROGN (SETQ |x| (CAR G170271)) NIL)) + (NREVERSE0 G170266)) + (SEQ (EXIT (SETQ G170266 + (CONS + (|getDomainRefName| |dom| |x|) + G170266)))))))) + ((NULL (FIXP |nam|)) |nam|) + ('T (SPADLET |slot| (ELT |dom| |nam|)) + (COND + ((VECP |slot|) (ELT |slot| 0)) + ((AND (PAIRP |slot|) (EQ (QCAR |slot|) 'SETELT)) + (|getDomainRefName| |dom| + (|getDomainSeteltForm| |slot|))) + ('T |slot|)))))))) + +;getDomainSeteltForm ['SETELT,.,.,form] == +; form is ['evalSlotDomain,u,d] => devaluateSlotDomain(u,d) +; VECP form => systemError() +; form + +(DEFUN |getDomainSeteltForm| (G170299) + (PROG (|form| |ISTMP#1| |u| |ISTMP#2| |d|) + (RETURN + (PROGN + (SPADLET |form| (CADDDR G170299)) + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|evalSlotDomain|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |u| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |d| (QCAR |ISTMP#2|)) + 'T)))))) + (|devaluateSlotDomain| |u| |d|)) + ((VECP |form|) (|systemError|)) + ('T |form|)))))) + +;showPredicates dom == +; sayBrightly '"--------------------Predicate summary-------------------" +; conname := CAR dom.0 +; predvector := dom.3 +; predicateList := GETDATABASE(conname,'PREDICATES) +; for i in 1.. for p in predicateList repeat +; prefix := +; testBitVector(predvector,i) => '"true : " +; '"false: " +; sayBrightly [prefix,:pred2English p] + +(DEFUN |showPredicates| (|dom|) + (PROG (|conname| |predvector| |predicateList| |prefix|) + (RETURN + (SEQ (PROGN + (|sayBrightly| + (MAKESTRING + "--------------------Predicate summary-------------------")) + (SPADLET |conname| (CAR (ELT |dom| 0))) + (SPADLET |predvector| (ELT |dom| 3)) + (SPADLET |predicateList| + (GETDATABASE |conname| 'PREDICATES)) + (DO ((|i| 1 (QSADD1 |i|)) + (G170330 |predicateList| (CDR G170330)) + (|p| NIL)) + ((OR (ATOM G170330) + (PROGN (SETQ |p| (CAR G170330)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |prefix| + (COND + ((|testBitVector| |predvector| + |i|) + (MAKESTRING "true : ")) + ('T (MAKESTRING "false: ")))) + (|sayBrightly| + (CONS |prefix| (|pred2English| |p|)))))))))))) + +; +;showAttributes dom == +; sayBrightly '"--------------------Attribute summary-------------------" +; conname := CAR dom.0 +; abb := getConstructorAbbreviation conname +; predvector := dom.3 +; for [a,:p] in dom.2 repeat +; prefix := +; testBitVector(predvector,p) => '"true : " +; '"false: " +; sayBrightly concat(prefix,form2String a) + +(DEFUN |showAttributes| (|dom|) + (PROG (|conname| |abb| |predvector| |a| |p| |prefix|) + (RETURN + (SEQ (PROGN + (|sayBrightly| + (MAKESTRING + "--------------------Attribute summary-------------------")) + (SPADLET |conname| (CAR (ELT |dom| 0))) + (SPADLET |abb| (|getConstructorAbbreviation| |conname|)) + (SPADLET |predvector| (ELT |dom| 3)) + (DO ((G170356 (ELT |dom| 2) (CDR G170356)) + (G170345 NIL)) + ((OR (ATOM G170356) + (PROGN (SETQ G170345 (CAR G170356)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G170345)) + (SPADLET |p| (CDR G170345)) + G170345) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |prefix| + (COND + ((|testBitVector| |predvector| + |p|) + (MAKESTRING "true : ")) + ('T (MAKESTRING "false: ")))) + (|sayBrightly| + (|concat| |prefix| (|form2String| |a|)))))))))))) + +;showGoGet dom == +; numvec := CDDR dom.4 +; for i in 6..MAXINDEX dom | (slot := dom.i) is ['newGoGet,dol,index,:op] repeat +; numOfArgs := numvec.index +; whereNumber := numvec.(index := index + 1) +; signumList := +; [formatLazyDomainForm(dom,numvec.(index + i)) for i in 0..numOfArgs] +; index := index + numOfArgs + 1 +; namePart := +; concat(bright "from",form2String formatLazyDomainForm(dom,whereNumber)) +; sayBrightly [i,'": ",:formatOpSignature(op,signumList),:namePart] + +(DEFUN |showGoGet| (|dom|) + (PROG (|numvec| |slot| |ISTMP#1| |ISTMP#2| |dol| |ISTMP#3| |op| + |numOfArgs| |whereNumber| |signumList| |index| |namePart|) + (RETURN + (SEQ (PROGN + (SPADLET |numvec| (CDDR (ELT |dom| 4))) + (DO ((G170416 (MAXINDEX |dom|)) (|i| 6 (+ |i| 1))) + ((> |i| G170416) NIL) + (SEQ (EXIT (COND + ((PROGN + (SPADLET |ISTMP#1| + (SPADLET |slot| + (ELT |dom| |i|))) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|newGoGet|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |dol| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |index| + (QCAR |ISTMP#3|)) + (SPADLET |op| + (QCDR |ISTMP#3|)) + 'T))))))) + (PROGN + (SPADLET |numOfArgs| + (ELT |numvec| |index|)) + (SPADLET |whereNumber| + (ELT |numvec| + (SPADLET |index| + (PLUS |index| 1)))) + (SPADLET |signumList| + (PROG (G170424) + (SPADLET G170424 NIL) + (RETURN + (DO ((|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| + |numOfArgs|) + (NREVERSE0 G170424)) + (SEQ + (EXIT + (SETQ G170424 + (CONS + (|formatLazyDomainForm| + |dom| + (ELT |numvec| + (PLUS |index| |i|))) + G170424)))))))) + (SPADLET |index| + (PLUS + (PLUS |index| |numOfArgs|) 1)) + (SPADLET |namePart| + (|concat| (|bright| '|from|) + (|form2String| + (|formatLazyDomainForm| |dom| + |whereNumber|)))) + (|sayBrightly| + (CONS |i| + (CONS (MAKESTRING ": ") + (APPEND + (|formatOpSignature| |op| + |signumList|) + |namePart|))))))))))))))) + +;formatLazyDomain(dom,x) == +; VECP x => devaluate x +; x is [dollar,slotNumber,:form] => formatLazyDomainForm(dom,form) +; systemError nil + +(DEFUN |formatLazyDomain| (|dom| |x|) + (PROG (|dollar| |ISTMP#1| |slotNumber| |form|) + (RETURN + (COND + ((VECP |x|) (|devaluate| |x|)) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |dollar| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |slotNumber| (QCAR |ISTMP#1|)) + (SPADLET |form| (QCDR |ISTMP#1|)) + 'T)))) + (|formatLazyDomainForm| |dom| |form|)) + ('T (|systemError| NIL)))))) + +;formatLazyDomainForm(dom,x) == +; x = 0 => ["$"] +; FIXP x => formatLazyDomain(dom,dom.x) +; atom x => x +; x is ['NRTEVAL,y] => (atom y => [y]; y) +; [first x,:[formatLazyDomainForm(dom,y) for y in rest x]] + +(DEFUN |formatLazyDomainForm| (|dom| |x|) + (PROG (|ISTMP#1| |y|) + (RETURN + (SEQ (COND + ((EQL |x| 0) (CONS '$ NIL)) + ((FIXP |x|) (|formatLazyDomain| |dom| (ELT |dom| |x|))) + ((ATOM |x|) |x|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'NRTEVAL) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + (COND ((ATOM |y|) (CONS |y| NIL)) ('T |y|))) + ('T + (CONS (CAR |x|) + (PROG (G170482) + (SPADLET G170482 NIL) + (RETURN + (DO ((G170487 (CDR |x|) (CDR G170487)) + (|y| NIL)) + ((OR (ATOM G170487) + (PROGN + (SETQ |y| (CAR G170487)) + NIL)) + (NREVERSE0 G170482)) + (SEQ (EXIT (SETQ G170482 + (CONS + (|formatLazyDomainForm| |dom| + |y|) + G170482)))))))))))))) + +;--====================> WAS b-op1.boot <================================ +;--======================================================================= +;-- Operation Page Menu +;--======================================================================= +;--opAlist has form [[op,:alist],:.] where each alist +;-- has form [sig,pred,origin,exposeFlag,comments] +;dbFromConstructor?(htPage) == htpProperty(htPage,'conform) + +(DEFUN |dbFromConstructor?| (|htPage|) + (|htpProperty| |htPage| '|conform|)) + +;dbDoesOneOpHaveParameters? opAlist == +; or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn == +; STRINGP x => dbPart(x,2,1) ^= '"0" +; KAR x + +(DEFUN |dbDoesOneOpHaveParameters?| (|opAlist|) + (PROG (|op| |items|) + (RETURN + (SEQ (PROG (G170511) + (SPADLET G170511 NIL) + (RETURN + (DO ((G170518 NIL G170511) + (G170519 |opAlist| (CDR G170519)) + (G170503 NIL)) + ((OR G170518 (ATOM G170519) + (PROGN (SETQ G170503 (CAR G170519)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G170503)) + (SPADLET |items| (CDR G170503)) + G170503) + NIL)) + G170511) + (SEQ (EXIT (SETQ G170511 + (OR G170511 + (PROG (G170527) + (SPADLET G170527 NIL) + (RETURN + (DO + ((G170533 NIL G170527) + (G170534 |items| + (CDR G170534)) + (|x| NIL)) + ((OR G170533 + (ATOM G170534) + (PROGN + (SETQ |x| + (CAR G170534)) + NIL)) + G170527) + (SEQ + (EXIT + (SETQ G170527 + (OR G170527 + (COND + ((STRINGP |x|) + (NEQUAL + (|dbPart| |x| 2 1) + (MAKESTRING "0"))) + ('T (KAR |x|))))))))))))))))))))) + +;--============================================================================ +;-- Master Switch Functions for Operation Views +;--============================================================================ +;dbShowOps(htPage,which,key,:options) == +; --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string +; which := STRINGIMAGE which +; if MEMQ(key,'(extended basic all)) then +; $groupChoice := key +; key := htpProperty(htPage,'key) or 'names +; opAlist := +; which = '"operation" => htpProperty(htPage,'opAlist) +;-- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist)) +;-- htpSetProperty(htPage,'opAlist,al) +;-- al +; htpProperty(htPage,'attrAlist) +; key = 'generalise => +; arg := STRINGIMAGE CAAR opAlist +; which = '"attribute" => aPage arg +; oPage arg +; key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which) +; key = 'filter => +; --if $saturn, IFCAR options contains filter string +; filter := IFCAR options or pmTransFilter(dbGetInputString htPage) +; filter is ['error,:.] => bcErrorPage filter +; opAlist:= _ +; [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)] +; null opAlist => emptySearchPage(which,filter) +; htPage := htInitPageNoScroll(htCopyProplist htPage) +; if which = '"operation" +; then htpSetProperty(htPage,'opAlist,opAlist) +; else htpSetProperty(htPage,'attrAlist,opAlist) +; if not htpProperty(htPage,'condition?) = 'no then +; dbResetOpAlistCondition(htPage,which,opAlist) +; dbShowOps(htPage,which,htpProperty(htPage,'exclusion)) +; htpSetProperty(htPage,'key,key) +; if MEMQ(key,'(exposureOn exposureOff)) then +; $exposedOnlyIfTrue := +; key = 'exposureOn => 'T +; nil +; key := htpProperty(htPage,'exclusion) +; dbShowOp1(htPage,opAlist,which,key) + +(DEFUN |dbShowOps| + (&REST G170586 &AUX |options| |key| |which| |htPage|) + (DSETQ (|htPage| |which| |key| . |options|) G170586) + (PROG (|arg| |filter| |opAlist|) + (declare (special |$groupChoice| |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |which| (STRINGIMAGE |which|)) + (COND + ((MEMQ |key| '(|extended| |basic| |all|)) + (SPADLET |$groupChoice| |key|) + (SPADLET |key| + (OR (|htpProperty| |htPage| '|key|) '|names|)))) + (SPADLET |opAlist| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpProperty| |htPage| '|opAlist|)) + ('T (|htpProperty| |htPage| '|attrAlist|)))) + (COND + ((BOOT-EQUAL |key| '|generalise|) + (SPADLET |arg| (STRINGIMAGE (CAAR |opAlist|))) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "attribute")) + (|aPage| |arg|)) + ('T (|oPage| |arg|)))) + ((BOOT-EQUAL |key| '|allDomains|) + (|dbShowOpAllDomains| |htPage| |opAlist| |which|)) + ((BOOT-EQUAL |key| '|filter|) + (SPADLET |filter| + (OR (IFCAR |options|) + (|pmTransFilter| + (|dbGetInputString| |htPage|)))) + (COND + ((AND (PAIRP |filter|) (EQ (QCAR |filter|) '|error|)) + (|bcErrorPage| |filter|)) + ('T + (SPADLET |opAlist| + (PROG (G170560) + (SPADLET G170560 NIL) + (RETURN + (DO ((G170566 |opAlist| + (CDR G170566)) + (|x| NIL)) + ((OR (ATOM G170566) + (PROGN + (SETQ |x| (CAR G170566)) + NIL)) + (NREVERSE0 G170560)) + (SEQ (EXIT + (COND + ((|superMatch?| |filter| + (DOWNCASE + (STRINGIMAGE (|opOf| |x|)))) + (SETQ G170560 + (CONS |x| G170560)))))))))) + (COND + ((NULL |opAlist|) + (|emptySearchPage| |which| |filter|)) + ('T + (SPADLET |htPage| + (|htInitPageNoScroll| + (|htCopyProplist| |htPage|))) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpSetProperty| |htPage| '|opAlist| + |opAlist|)) + ('T + (|htpSetProperty| |htPage| '|attrAlist| + |opAlist|))) + (COND + ((NULL (BOOT-EQUAL (|htpProperty| |htPage| + '|condition?|) + '|no|)) + (|dbResetOpAlistCondition| |htPage| |which| + |opAlist|))) + (|dbShowOps| |htPage| |which| + (|htpProperty| |htPage| '|exclusion|))))))) + ('T (|htpSetProperty| |htPage| '|key| |key|) + (COND + ((MEMQ |key| '(|exposureOn| |exposureOff|)) + (SPADLET |$exposedOnlyIfTrue| + (COND + ((BOOT-EQUAL |key| '|exposureOn|) 'T) + ('T NIL))) + (SPADLET |key| + (|htpProperty| |htPage| '|exclusion|)))) + (|dbShowOp1| |htPage| |opAlist| |which| |key|)))))))) + +;reduceByGroup(htPage,opAlist) == +; not dbFromConstructor?(htPage) or null $groupChoice => opAlist +; dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false) +; bitNumber := HGET($topicHash,$groupChoice) +; res := [[op,:newItems] for [op,:items] in opAlist | newItems] where +; newItems == +; null bitNumber => items +; [x for x in items | FIXP (code := myLastAtom x) _ +; and LOGBITP(bitNumber,code)] +; res + +(DEFUN |reduceByGroup| (|htPage| |opAlist|) + (PROG (|bitNumber| |op| |items| |code| |res|) + (declare (special |$topicHash| |$groupChoice|)) + (RETURN + (SEQ (COND + ((OR (NULL (|dbFromConstructor?| |htPage|)) + (NULL |$groupChoice|)) + |opAlist|) + ('T + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + (MAKESTRING "operation") 'T NIL) + (SPADLET |bitNumber| (HGET |$topicHash| |$groupChoice|)) + (SPADLET |res| + (PROG (G170603) + (SPADLET G170603 NIL) + (RETURN + (DO ((G170610 |opAlist| (CDR G170610)) + (G170588 NIL)) + ((OR (ATOM G170610) + (PROGN + (SETQ G170588 (CAR G170610)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G170588)) + (SPADLET |items| + (CDR G170588)) + G170588) + NIL)) + (NREVERSE0 G170603)) + (SEQ (EXIT (COND + ((COND + ((NULL |bitNumber|) + |items|) + ('T + (PROG (G170622) + (SPADLET G170622 NIL) + (RETURN + (DO + ((G170628 |items| + (CDR G170628)) + (|x| NIL)) + ((OR + (ATOM G170628) + (PROGN + (SETQ |x| + (CAR G170628)) + NIL)) + (NREVERSE0 + G170622)) + (SEQ + (EXIT + (COND + ((AND + (FIXP + (SPADLET + |code| + (|myLastAtom| + |x|))) + (LOGBITP + |bitNumber| + |code|)) + (SETQ + G170622 + (CONS |x| + G170622))))))))))) + (SETQ G170603 + (CONS + (CONS |op| + (COND + ((NULL |bitNumber|) + |items|) + ('T + (PROG (G170639) + (SPADLET G170639 + NIL) + (RETURN + (DO + ((G170645 + |items| + (CDR G170645)) + (|x| NIL)) + ((OR + (ATOM + G170645) + (PROGN + (SETQ |x| + (CAR + G170645)) + NIL)) + (NREVERSE0 + G170639)) + (SEQ + (EXIT + (COND + ((AND + (FIXP + (SPADLET + |code| + (|myLastAtom| + |x|))) + (LOGBITP + |bitNumber| + |code|)) + (SETQ + G170639 + (CONS |x| + G170639)))))))))))) + G170603)))))))))) + |res|)))))) + +;dbShowOp1(htPage,opAlist,which,key) == +; --set up for filtering below in dbGatherData +; $which: local := which +; if INTEGERP key then +; opAlist := dbSelectData(htPage,opAlist,key) +; ------> Jump out for constructor names in file <-------- +; INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile) +; and constructor? con => return conPageChoose con +; if INTEGERP key then +; htPage := htInitPageNoScroll(htCopyProplist htPage) +; if which = '"operation" +; then htpSetProperty(htPage,'opAlist,opAlist) +; else htpSetProperty(htPage,'attrAlist,opAlist) +; if not htpProperty(htPage,'condition?) = 'no then +; dbResetOpAlistCondition(htPage,which,opAlist) +; dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) +; if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then +; --opAlist is expanded to form +; -- [[op,[sig,pred,origin,exposed,comments],...],...] +; opAlist:=[item for [op,:items] in opAlist | item] where +; item == +; acc := nil +; for x in items | x.3 repeat acc:= [x,:acc] +; null acc => nil +; [op,:NREVERSE acc] +; $conformsAreDomains : local := htpProperty(htPage,'domname) +; opCount := opAlistCount(opAlist, which) +; branch := +; INTEGERP key => +; opCount <= $opDescriptionThreshold => 'documentation +; 'names +; key = 'names and null rest opAlist => --means a single op +; opCount <= $opDescriptionThreshold => 'documentation +; 'names +; key +; [what,whats,fn] := LASSOC(branch,$OpViewTable) +; data := dbGatherData(htPage,opAlist,which,branch) +; dataCount := +/[1 for x in data | (what = '"Name" and _ +; $exposedOnlyIfTrue => atom x; true)] +; namedPart := +; null rest opAlist => +; ops := escapeSpecialChars STRINGIMAGE CAAR opAlist +; ['" {\em ",ops,'"}"] +; nil +; if what = '"Condition" and null KAR KAR data then dataCount := dataCount - 1 +; exposurePart := +; $exposedOnlyIfTrue => '(" Exposed ") +; nil +; firstPart := +; opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which] +; dataCount = 1 or dataCount = opCount => +; opCount = 1 => [:exposurePart, capitalize which,:namedPart] +; [STRINGIMAGE opCount,'" ",:exposurePart, +; pluralize capitalize which,:namedPart] +; prefix := pluralSay(dataCount,what,whats) +; [:prefix,'" for ",STRINGIMAGE opCount,'" ",_ +; pluralize capitalize which,:namedPart] +; page := htInitPageNoScroll(htCopyProplist htPage) +; ------------>above line used to call htInitPageHoHeading<---------- +; htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) +; htpSetProperty(page,'data,data) +; htpSetProperty(page,'branch,branch) +; -- only place where specialMessage property is set seems to be commented. out +; if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) +; htSayStandard('"\beginscroll ") +; FUNCALL(fn,page,opAlist,which,data) --apply branch function +; dbOpsExposureMessage() +; htSayStandard("\endscroll ") +; dbPresentOps(page,which,branch) +; htShowPageNoScroll() + +(DEFUN |dbShowOp1| (|htPage| |opAlist| |which| |key|) + (PROG (|$which| |$conformsAreDomains| |ISTMP#1| |con| |op| |items| + |acc| |opCount| |branch| |LETTMP#1| |what| |whats| |fn| + |data| |ops| |namedPart| |dataCount| |exposurePart| + |prefix| |firstPart| |page| |u|) + (DECLARE (SPECIAL |$which| |$conformsAreDomains| |$exposedOnlyIfTrue| + |$opDescriptionThreshold| |$OpViewTable|)) + (RETURN + (SEQ (PROGN + (SPADLET |$which| |which|) + (COND + ((INTEGERP |key|) + (SPADLET |opAlist| + (|dbSelectData| |htPage| |opAlist| |key|)))) + (COND + ((AND (INTEGERP |key|) (PAIRP |opAlist|) + (EQ (QCDR |opAlist|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |opAlist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |con| (QCAR |ISTMP#1|)) + 'T))) + (|htpProperty| |htPage| '|isFile|) + (|constructor?| |con|)) + (RETURN (|conPageChoose| |con|))) + ('T + (COND + ((INTEGERP |key|) + (SPADLET |htPage| + (|htInitPageNoScroll| + (|htCopyProplist| |htPage|))) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpSetProperty| |htPage| '|opAlist| |opAlist|)) + ('T + (|htpSetProperty| |htPage| '|attrAlist| + |opAlist|))) + (COND + ((NULL (BOOT-EQUAL + (|htpProperty| |htPage| '|condition?|) + '|no|)) + (|dbResetOpAlistCondition| |htPage| |which| + |opAlist|)) + ('T NIL)))) + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + |which| 'T NIL) + (COND + ((AND |$exposedOnlyIfTrue| + (NULL (|dbFromConstructor?| |htPage|))) + (SPADLET |opAlist| + (PROG (G170705) + (SPADLET G170705 NIL) + (RETURN + (DO ((G170715 |opAlist| + (CDR G170715)) + (G170669 NIL)) + ((OR (ATOM G170715) + (PROGN + (SETQ G170669 + (CAR G170715)) + NIL) + (PROGN + (PROGN + (SPADLET |op| + (CAR G170669)) + (SPADLET |items| + (CDR G170669)) + G170669) + NIL)) + (NREVERSE0 G170705)) + (SEQ (EXIT + (COND + ((PROGN + (SPADLET |acc| NIL) + (DO + ((G170726 |items| + (CDR G170726)) + (|x| NIL)) + ((OR (ATOM G170726) + (PROGN + (SETQ |x| + (CAR G170726)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((ELT |x| 3) + (SPADLET |acc| + (CONS |x| |acc|))))))) + (COND + ((NULL |acc|) NIL) + ('T + (CONS |op| + (NREVERSE |acc|))))) + (SETQ G170705 + (CONS + (PROGN + (SPADLET |acc| NIL) + (DO + ((G170736 |items| + (CDR G170736)) + (|x| NIL)) + ((OR (ATOM G170736) + (PROGN + (SETQ |x| + (CAR G170736)) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((ELT |x| 3) + (SPADLET |acc| + (CONS |x| |acc|))))))) + (COND + ((NULL |acc|) NIL) + ('T + (CONS |op| + (NREVERSE |acc|))))) + G170705)))))))))))) + (SPADLET |$conformsAreDomains| + (|htpProperty| |htPage| '|domname|)) + (SPADLET |opCount| (|opAlistCount| |opAlist| |which|)) + (SPADLET |branch| + (COND + ((INTEGERP |key|) + (COND + ((<= |opCount| |$opDescriptionThreshold|) + '|documentation|) + ('T '|names|))) + ((AND (BOOT-EQUAL |key| '|names|) + (NULL (CDR |opAlist|))) + (COND + ((<= |opCount| |$opDescriptionThreshold|) + '|documentation|) + ('T '|names|))) + ('T |key|))) + (SPADLET |LETTMP#1| (LASSOC |branch| |$OpViewTable|)) + (SPADLET |what| (CAR |LETTMP#1|)) + (SPADLET |whats| (CADR |LETTMP#1|)) + (SPADLET |fn| (CADDR |LETTMP#1|)) + (SPADLET |data| + (|dbGatherData| |htPage| |opAlist| |which| + |branch|)) + (SPADLET |dataCount| + (PROG (G170742) + (SPADLET G170742 0) + (RETURN + (DO ((G170748 |data| (CDR G170748)) + (|x| NIL)) + ((OR (ATOM G170748) + (PROGN + (SETQ |x| (CAR G170748)) + NIL)) + G170742) + (SEQ (EXIT + (COND + ((COND + ((AND + (BOOT-EQUAL |what| + (MAKESTRING "Name")) + |$exposedOnlyIfTrue|) + (ATOM |x|)) + ('T 'T)) + (SETQ G170742 + (PLUS G170742 1)))))))))) + (SPADLET |namedPart| + (COND + ((NULL (CDR |opAlist|)) + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE (CAAR |opAlist|)))) + (CONS (MAKESTRING " {\\em ") + (CONS |ops| + (CONS (MAKESTRING "}") NIL)))) + ('T NIL))) + (COND + ((AND (BOOT-EQUAL |what| (MAKESTRING "Condition")) + (NULL (KAR (KAR |data|)))) + (SPADLET |dataCount| (SPADDIFFERENCE |dataCount| 1)))) + (SPADLET |exposurePart| + (COND + (|$exposedOnlyIfTrue| '(" Exposed ")) + ('T NIL))) + (SPADLET |firstPart| + (COND + ((EQL |opCount| 0) + (CONS (MAKESTRING "No ") + (APPEND |exposurePart| + (CONS + (|pluralize| + (|capitalize| |which|)) + NIL)))) + ((OR (EQL |dataCount| 1) + (BOOT-EQUAL |dataCount| |opCount|)) + (COND + ((EQL |opCount| 1) + (APPEND |exposurePart| + (CONS (|capitalize| |which|) + |namedPart|))) + ('T + (CONS (STRINGIMAGE |opCount|) + (CONS (MAKESTRING " ") + (APPEND |exposurePart| + (CONS + (|pluralize| + (|capitalize| |which|)) + |namedPart|))))))) + ('T + (SPADLET |prefix| + (|pluralSay| |dataCount| |what| + |whats|)) + (APPEND |prefix| + (CONS (MAKESTRING " for ") + (CONS (STRINGIMAGE |opCount|) + (CONS (MAKESTRING " ") + (CONS + (|pluralize| + (|capitalize| |which|)) + |namedPart|)))))))) + (SPADLET |page| + (|htInitPageNoScroll| + (|htCopyProplist| |htPage|))) + (|htAddHeading| + (|dbShowOpHeading| + (APPEND |firstPart| (|fromHeading| |page|)) + |branch|)) + (|htpSetProperty| |page| '|data| |data|) + (|htpSetProperty| |page| '|branch| |branch|) + (COND + ((SPADLET |u| + (|htpProperty| |page| '|specialMessage|)) + (APPLY (CAR |u|) (CDR |u|)))) + (|htSayStandard| (MAKESTRING "\\beginscroll ")) + (FUNCALL |fn| |page| |opAlist| |which| |data|) + (|dbOpsExposureMessage|) + (|htSayStandard| '|\\endscroll |) + (|dbPresentOps| |page| |which| |branch|) + (|htShowPageNoScroll|)))))))) + +;opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo == +; null $exposedOnlyIfTrue or which = '"attribute" => #items +; --count if unexpanded---CDDR(w) = nil---or if w.3 = true +; +/[1 for w in items | null (p := CDDR w) or p . 1] + +(DEFUN |opAlistCount| (|opAlist| |which|) + (PROG (|op| |items| |p|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROG (G170801) + (SPADLET G170801 0) + (RETURN + (DO ((G170807 |opAlist| (CDR G170807)) + (G170793 NIL)) + ((OR (ATOM G170807) + (PROGN (SETQ G170793 (CAR G170807)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G170793)) + (SPADLET |items| (CDR G170793)) + G170793) + NIL)) + G170801) + (SEQ (EXIT (SETQ G170801 + (PLUS G170801 + (COND + ((OR + (NULL |$exposedOnlyIfTrue|) + (BOOT-EQUAL |which| + (MAKESTRING "attribute"))) + (|#| |items|)) + ('T + (PROG (G170814) + (SPADLET G170814 0) + (RETURN + (DO + ((G170820 |items| + (CDR G170820)) + (|w| NIL)) + ((OR (ATOM G170820) + (PROGN + (SETQ |w| + (CAR G170820)) + NIL)) + G170814) + (SEQ + (EXIT + (COND + ((OR + (NULL + (SPADLET |p| + (CDDR |w|))) + (ELT |p| 1)) + (SETQ G170814 + (PLUS G170814 + 1)))))))))))))))))))))) + +;dbShowOpHeading(heading, branch) == +; suffix := +;-- branch = 'signatures => '" viewed as signatures" +; branch = 'parameters => '" viewed with parameters" +; branch = 'origins => '" organized by origins" +; branch = 'conditions => '" organized by conditions" +; '"" +; [:heading, suffix] + +(DEFUN |dbShowOpHeading| (|heading| |branch|) + (PROG (|suffix|) + (RETURN + (PROGN + (SPADLET |suffix| + (COND + ((BOOT-EQUAL |branch| '|parameters|) + (MAKESTRING " viewed with parameters")) + ((BOOT-EQUAL |branch| '|origins|) + (MAKESTRING " organized by origins")) + ((BOOT-EQUAL |branch| '|conditions|) + (MAKESTRING " organized by conditions")) + ('T (MAKESTRING "")))) + (APPEND |heading| (CONS |suffix| NIL)))))) + +;dbOpsExposureMessage() == +; $atLeastOneUnexposed => htSay '"{\em *} = unexposed" + +(DEFUN |dbOpsExposureMessage| () + (declare (special |$atLeastOneUnexposed|)) + (SEQ (COND + (|$atLeastOneUnexposed| + (EXIT (|htSay| (MAKESTRING "{\\em *} = unexposed"))))))) + +;fromHeading htPage == +; null htPage => '"" +; $pn := [htPage.0,'"}{"] +; updomain := htpProperty(htPage,'updomain) => +; dnForm := dbExtractUnderlyingDomain updomain +; dnString:= form2StringList dnForm +; dnFence := form2Fence dnForm +;-- upString:= form2StringList updomain +; upFence := form2Fence updomain +; upOp := PNAME opOf updomain +; ['" {\em from} ",:dbConformGen dnForm,'" {\em under} _ +; \ops{",upOp,'"}{",:$pn,:upFence,'"}"] +; domname := htpProperty(htPage,'domname) +; numberOfUnderlyingDomains := #[x for x in rest _ +; GETDATABASE(opOf domname,'COSIG) | x] +;-- numberOfUnderlyingDomains = 1 and +;-- KDR domname and (dn := dbExtractUnderlyingDomain domname) => +;-- ['" {\em from} ",:pickitForm(domname,dn)] +; KDR domname => ['" {\em from} ",:dbConformGen domname] +; htpProperty(htPage,'fromHeading) + +(DEFUN |fromHeading| (|htPage|) + (PROG (|updomain| |dnForm| |dnString| |dnFence| |upFence| |upOp| + |domname| |numberOfUnderlyingDomains|) + (declare (special |$pn|)) + (RETURN + (SEQ (COND + ((NULL |htPage|) (MAKESTRING "")) + ('T + (SPADLET |$pn| + (CONS (ELT |htPage| 0) + (CONS (MAKESTRING "}{") NIL))) + (COND + ((SPADLET |updomain| + (|htpProperty| |htPage| '|updomain|)) + (SPADLET |dnForm| + (|dbExtractUnderlyingDomain| |updomain|)) + (SPADLET |dnString| (|form2StringList| |dnForm|)) + (SPADLET |dnFence| (|form2Fence| |dnForm|)) + (SPADLET |upFence| (|form2Fence| |updomain|)) + (SPADLET |upOp| (PNAME (|opOf| |updomain|))) + (CONS (MAKESTRING " {\\em from} ") + (APPEND (|dbConformGen| |dnForm|) + (CONS (MAKESTRING + " {\\em under} \\ops{") + (CONS |upOp| + (CONS (MAKESTRING "}{") + (APPEND |$pn| + (APPEND |upFence| + (CONS (MAKESTRING "}") NIL))))))))) + ('T + (SPADLET |domname| + (|htpProperty| |htPage| '|domname|)) + (SPADLET |numberOfUnderlyingDomains| + (|#| (PROG (G170850) + (SPADLET G170850 NIL) + (RETURN + (DO + ((G170856 + (CDR + (GETDATABASE (|opOf| |domname|) + 'COSIG)) + (CDR G170856)) + (|x| NIL)) + ((OR (ATOM G170856) + (PROGN + (SETQ |x| (CAR G170856)) + NIL)) + (NREVERSE0 G170850)) + (SEQ + (EXIT + (COND + (|x| + (SETQ G170850 + (CONS |x| G170850))))))))))) + (COND + ((KDR |domname|) + (CONS (MAKESTRING " {\\em from} ") + (|dbConformGen| |domname|))) + ('T (|htpProperty| |htPage| '|fromHeading|))))))))))) + +;pickitForm(form,uarg) == +; conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg) + +(DEFUN |pickitForm| (|form| |uarg|) + (|conform2StringList| |form| #'|dbConform| #'|conformString| |uarg|)) + +;conformString(form) == +; KDR form => +; conform2StringList(form,FUNCTION conname2StringList,_ +; FUNCTION conformString,nil) +; form2StringList form + +(DEFUN |conformString| (|form|) + (COND + ((KDR |form|) + (|conform2StringList| |form| #'|conname2StringList| + #'|conformString| NIL)) + ('T (|form2StringList| |form|)))) + +;conform2StringList(form,opFn,argFn,exception) == +; exception := exception or '"%%%nothing%%%" +; [op1,:args] := form +; op := IFCAR HGET($lowerCaseConTb,op1) or op1 +; null args => APPLY(opFn,[op]) +; special := MEMQ(op,'(Union Record Mapping)) +; cosig := +; special => ['T for x in args] +; rest GETDATABASE(op,'COSIG) +; atypes := +; special => cosig +; rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) +; sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == +; keyword := +; x is [":",y,t] => +; x := t +; y +; nil +; res := +; x = exception => dbOpsForm exception +; pred => +; STRINGP x => [x] +; u := APPLY(argFn,[x]) +; atom u and [u] or u +; typ := sublisFormal(args,atype) +; if x is ['QUOTE,a] then x := a +; u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u] +; NUMBERP x or STRINGP x => [x] +; systemError() +; keyword => [keyword,'": ",:res] +; res +; op = 'Mapping => dbMapping2StringList sargl +; head := +; special => [op] +; APPLY(opFn,[form]) +; [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"] + +(DEFUN |conform2StringList| (|form| |opFn| |argFn| |exception|) + (PROG (|op1| |args| |op| |special| |cosig| |atypes| |y| |ISTMP#2| |t| + |keyword| |typ| |ISTMP#1| |a| |u| |res| |sargl| + |head|) + (declare (special |$lowerCaseConTb|)) + (RETURN + (SEQ (PROGN + (SPADLET |exception| + (OR |exception| (MAKESTRING "%%%nothing%%%"))) + (SPADLET |op1| (CAR |form|)) + (SPADLET |args| (CDR |form|)) + (SPADLET |op| + (OR (IFCAR (HGET |$lowerCaseConTb| |op1|)) |op1|)) + (COND + ((NULL |args|) (APPLY |opFn| (CONS |op| NIL))) + ('T + (SPADLET |special| + (MEMQ |op| '(|Union| |Record| |Mapping|))) + (SPADLET |cosig| + (COND + (|special| + (PROG (G170930) + (SPADLET G170930 NIL) + (RETURN + (DO + ((G170935 |args| (CDR G170935)) + (|x| NIL)) + ((OR (ATOM G170935) + (PROGN + (SETQ |x| (CAR G170935)) + NIL)) + (NREVERSE0 G170930)) + (SEQ + (EXIT + (SETQ G170930 + (CONS 'T G170930)))))))) + ('T (CDR (GETDATABASE |op| 'COSIG))))) + (SPADLET |atypes| + (COND + (|special| |cosig|) + ('T + (CDR (CDAR (GETDATABASE |op| + 'CONSTRUCTORMODEMAP)))))) + (SPADLET |sargl| + (PROG (G170961) + (SPADLET G170961 NIL) + (RETURN + (DO ((G170982 |args| (CDR G170982)) + (|x| NIL) + (G170983 |atypes| (CDR G170983)) + (|atype| NIL) + (G170984 |cosig| (CDR G170984)) + (|pred| NIL)) + ((OR (ATOM G170982) + (PROGN + (SETQ |x| (CAR G170982)) + NIL) + (ATOM G170983) + (PROGN + (SETQ |atype| (CAR G170983)) + NIL) + (ATOM G170984) + (PROGN + (SETQ |pred| (CAR G170984)) + NIL)) + (NREVERSE0 G170961)) + (SEQ (EXIT + (SETQ G170961 + (CONS + (PROGN + (SPADLET |keyword| + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ + (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |x| |t|) |y|) + ('T NIL))) + (SPADLET |res| + (COND + ((BOOT-EQUAL |x| + |exception|) + (|dbOpsForm| |exception|)) + (|pred| + (COND + ((STRINGP |x|) + (CONS |x| NIL)) + ('T + (SPADLET |u| + (APPLY |argFn| + (CONS |x| NIL))) + (OR + (AND (ATOM |u|) + (CONS |u| NIL)) + |u|)))) + ('T + (SPADLET |typ| + (|sublisFormal| |args| + |atype|)) + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ + (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |x| |a|))) + (COND + ((SPADLET |u| + (|mathform2HtString| + (|algCoerceInteractive| + |x| |typ| + '(|OutputForm|)))) + (CONS |u| NIL)) + ((OR (NUMBERP |x|) + (STRINGP |x|)) + (CONS |x| NIL)) + ('T (|systemError|)))))) + (COND + (|keyword| + (CONS |keyword| + (CONS (MAKESTRING ": ") + |res|))) + ('T |res|))) + G170961)))))))) + (COND + ((BOOT-EQUAL |op| '|Mapping|) + (|dbMapping2StringList| |sargl|)) + ('T + (SPADLET |head| + (COND + (|special| (CONS |op| NIL)) + ('T (APPLY |opFn| (CONS |form| NIL))))) + (APPEND |head| + (CONS (MAKESTRING "(") + (APPEND (CAR |sargl|) + (APPEND + (PROG (G170996) + (SPADLET G170996 NIL) + (RETURN + (DO + ((G171001 + (CDR |sargl|) + (CDR G171001)) + (|y| NIL)) + ((OR (ATOM G171001) + (PROGN + (SETQ |y| + (CAR G171001)) + NIL)) + G170996) + (SEQ + (EXIT + (SETQ G170996 + (APPEND G170996 + (CONS '|,| |y|)))))))) + (CONS (MAKESTRING ")") NIL)))))))))))))) + +;dbMapping2StringList [target,:sl] == +; null sl => target +; restPart := +; null rest sl => nil +; "append"/[[",",:y] for y in rest sl] +; sourcePart := +; restPart => ['"(",:first sl,:restPart,'")"] +; first sl +; [:sourcePart,'" -> ",:target] + +(DEFUN |dbMapping2StringList| (G171038) + (PROG (|target| |sl| |restPart| |sourcePart|) + (RETURN + (SEQ (PROGN + (SPADLET |target| (CAR G171038)) + (SPADLET |sl| (CDR G171038)) + (COND + ((NULL |sl|) |target|) + ('T + (SPADLET |restPart| + (COND + ((NULL (CDR |sl|)) NIL) + ('T + (PROG (G171047) + (SPADLET G171047 NIL) + (RETURN + (DO ((G171052 (CDR |sl|) + (CDR G171052)) + (|y| NIL)) + ((OR (ATOM G171052) + (PROGN + (SETQ |y| (CAR G171052)) + NIL)) + G171047) + (SEQ (EXIT + (SETQ G171047 + (APPEND G171047 + (CONS '|,| |y|))))))))))) + (SPADLET |sourcePart| + (COND + (|restPart| + (CONS (MAKESTRING "(") + (APPEND (CAR |sl|) + (APPEND |restPart| + (CONS (MAKESTRING ")") NIL))))) + ('T (CAR |sl|)))) + (APPEND |sourcePart| + (CONS (MAKESTRING " -> ") |target|))))))))) + +;dbOuttran form == +; if LISTP form then +; [op,:args] := form +; else +; op := form +; args := nil +; cosig := rest GETDATABASE(op,'COSIG) +; atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) +; argl := [fn for x in args for atype in atypes for pred in cosig] where fn == +; pred => x +; typ := sublisFormal(args,atype) +; arg := +; x is ['QUOTE,a] => a +; x +; res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) +; NUMBERP res or STRINGP res => res +; ['QUOTE,res] +; [op,:argl] + +(DEFUN |dbOuttran| (|form|) + (PROG (|op| |args| |cosig| |atypes| |typ| |ISTMP#1| |a| |arg| |res| + |argl|) + (RETURN + (SEQ (PROGN + (COND + ((LISTP |form|) (SPADLET |op| (CAR |form|)) + (SPADLET |args| (CDR |form|)) |form|) + ('T (SPADLET |op| |form|) (SPADLET |args| NIL))) + (SPADLET |cosig| (CDR (GETDATABASE |op| 'COSIG))) + (SPADLET |atypes| + (CDR (CDAR (GETDATABASE |op| 'CONSTRUCTORMODEMAP)))) + (SPADLET |argl| + (PROG (G171092) + (SPADLET G171092 NIL) + (RETURN + (DO ((G171103 |args| (CDR G171103)) + (|x| NIL) + (G171104 |atypes| (CDR G171104)) + (|atype| NIL) + (G171105 |cosig| (CDR G171105)) + (|pred| NIL)) + ((OR (ATOM G171103) + (PROGN + (SETQ |x| (CAR G171103)) + NIL) + (ATOM G171104) + (PROGN + (SETQ |atype| (CAR G171104)) + NIL) + (ATOM G171105) + (PROGN + (SETQ |pred| (CAR G171105)) + NIL)) + (NREVERSE0 G171092)) + (SEQ (EXIT (SETQ G171092 + (CONS + (COND + (|pred| |x|) + ('T + (SPADLET |typ| + (|sublisFormal| |args| + |atype|)) + (SPADLET |arg| + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ + (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + 'T)))) + |a|) + ('T |x|))) + (SPADLET |res| + (|mathform2HtString| + (|algCoerceInteractive| + |arg| |typ| + '(|OutputForm|)))) + (COND + ((OR (NUMBERP |res|) + (STRINGP |res|)) + |res|) + ('T + (CONS 'QUOTE + (CONS |res| NIL)))))) + G171092)))))))) + (CONS |op| |argl|)))))) + +;dbOpsForm form == +;--one button for the operations of a type +;--1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted +;--2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|)) +; ["\ops{",:conform2StringList(form,FUNCTION conname2StringList,_ +; FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"] + +(DEFUN |dbOpsForm| (|form|) + (declare (special |$pn|)) + (CONS '|\\ops{| + (APPEND (|conform2StringList| |form| #'|conname2StringList| + #'|conformString| NIL) + (CONS (MAKESTRING "}{") + (APPEND |$pn| + (APPEND (|form2Fence| |form|) + (CONS (MAKESTRING "}") NIL))))))) + +;dbConformGen form == dbConformGen1(form,true) + +(DEFUN |dbConformGen| (|form|) (|dbConformGen1| |form| 'T)) + +;--many buttons: one for the type and one for each inner type +;--NOTE: must only be called on types KNOWN to be correct +;dbConformGenUnder form == dbConformGen1(form,false) + +(DEFUN |dbConformGenUnder| (|form|) (|dbConformGen1| |form| NIL)) + +;--same as above, except buttons only for the inner types +;dbConformGen1(form,opButton?) == +; opFunction := +; opButton? => FUNCTION dbConform +; FUNCTION conname2StringList +; originalOp := opOf form +; op := unAbbreviateIfNecessary opOf form +; args := IFCDR form +; form := +; originalOp=op => form +; [op, :args] +; args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil) +; APPLY(opFunction,[form]) + +(DEFUN |dbConformGen1| (|form| |opButton?|) + (PROG (|opFunction| |originalOp| |op| |args|) + (RETURN + (PROGN + (SPADLET |opFunction| + (COND + (|opButton?| #'|dbConform|) + ('T #'|conname2StringList|))) + (SPADLET |originalOp| (|opOf| |form|)) + (SPADLET |op| (|unAbbreviateIfNecessary| (|opOf| |form|))) + (SPADLET |args| (IFCDR |form|)) + (SPADLET |form| + (COND + ((BOOT-EQUAL |originalOp| |op|) |form|) + ('T (CONS |op| |args|)))) + (COND + (|args| (|conform2StringList| |form| |opFunction| + #'|dbConformGen| NIL)) + ('T (APPLY |opFunction| (CONS |form| NIL)))))))) + +;unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op + +(DEFUN |unAbbreviateIfNecessary| (|op|) + (declare (special |$lowerCaseConTb|)) + (OR (IFCAR (HGET |$lowerCaseConTb| |op|)) |op|)) + +;conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form] + +(DEFUN |conname2StringList| (|form|) + (CONS (PNAME (|unAbbreviateIfNecessary| (|opOf| |form|))) NIL)) + +;--=========================================================================== +;-- Data Gathering Code +;--============================================================================ +;dbGatherData(htPage,opAlist,which,key) == +; key = 'implementation => dbGatherDataImplementation(htPage,opAlist) +; dataFunction := LASSOC(key,table) where +; table == +; $dbDataFunctionAlist or +; ($dbDataFunctionAlist := [ +; ['signatures,:function dbMakeSignature], +; ['parameters,:function dbContrivedForm], +; ['origins,:function dbGetOrigin], +; ['domains,:function dbGetOrigin], +; ['conditions,:function dbGetCondition]]) +; null dataFunction => +; --key= names or filter or documentation; do not expand +; if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then +; opAlist := --to get indexing correct +; which = '"operation" => htpProperty(htPage,'opAlist) +; htpProperty(htPage,'attrAlist) +; acc := nil +; initialExposure := +; htPage and htpProperty(htPage,'conform) and which ^= '"package operation" +; => true +; --never star ops from a constructor +; nil +; for [op,:alist] in opAlist repeat +; exposureFlag := initialExposure +; while alist repeat +; item := first alist +; isExposed? := +; STRINGP item => dbExposed?(item,char 'o) --unexpanded case +; null (r := rest rest item) => true --assume true if unexpanded +; r . 1 --expanded case +; if isExposed? then return (exposureFlag := true) +; alist := rest alist +; node := +; exposureFlag => op +; [op,nil] +; acc := [node,:acc] +; NREVERSE acc +; data := nil +; dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in _ +; '(origins documentation),false) +; --create data, a list of the form ((entry,exposeFlag,:entries)...) +; for [op,:alist] in opAlist repeat +; for item in alist repeat +; entry := FUNCALL(dataFunction,op,item)--get key item +; exposeFlag := --is the current op-sig exposed? +; null (r := rest rest item) => true --not given, assume yes +; r . 1 --is given, use value +; tail := +; item is [.,'ASCONST,:.] => 'ASCONST +; nil +; newEntry := +; u := ASSOC(entry,data) => --key seen before? look on DATA +; RPLACA(CDR u,CADR u or exposeFlag)--yes, expose if any 1 is exposed +; u +; data := [y := [entry,exposeFlag,:tail],:data] +; y --no, create new entry in DATA +; if MEMBER(key,'(origins conditions)) then +; r := CDDR newEntry +; if atom r then r := nil --clear out possible 'ASCONST +; RPLACD(CDR newEntry, --store op/sigs under key if needed +; insert([dbMakeSignature(op,item),exposeFlag,:tail],r)) +; if MEMBER(key,'(origins conditions)) then +; for entry in data repeat --sort list of entries (after the 2nd) +; tail := CDDR entry +; tail := +; atom tail => tail +; listSort(function LEXLESSEQP,tail) +; RPLACD(CDR entry,tail) +; data := listSort(function LEXLESSEQP,data) +; data + +(DEFUN |dbGatherData| (|htPage| |opAlist| |which| |key|) + (PROG (|dataFunction| |initialExposure| |item| |isExposed?| + |exposureFlag| |node| |acc| |op| |alist| |entry| + |exposeFlag| |ISTMP#1| |u| |y| |newEntry| |r| |tail| + |data|) + (declare (special |$dbDataFunctionAlist| |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |key| '|implementation|) + (|dbGatherDataImplementation| |htPage| |opAlist|)) + ('T + (SPADLET |dataFunction| + (LASSOC |key| + (OR |$dbDataFunctionAlist| + (SPADLET |$dbDataFunctionAlist| + (CONS + (CONS '|signatures| + (|function| |dbMakeSignature|)) + (CONS + (CONS '|parameters| + (|function| |dbContrivedForm|)) + (CONS + (CONS '|origins| + (|function| |dbGetOrigin|)) + (CONS + (CONS '|domains| + (|function| |dbGetOrigin|)) + (CONS + (CONS '|conditions| + (|function| |dbGetCondition|)) + NIL))))))))) + (COND + ((NULL |dataFunction|) + (COND + ((AND |$exposedOnlyIfTrue| + (NULL (|dbFromConstructor?| |htPage|))) + (SPADLET |opAlist| + (COND + ((BOOT-EQUAL |which| + (MAKESTRING "operation")) + (|htpProperty| |htPage| '|opAlist|)) + ('T + (|htpProperty| |htPage| '|attrAlist|)))))) + (SPADLET |acc| NIL) + (SPADLET |initialExposure| + (COND + ((AND |htPage| + (|htpProperty| |htPage| '|conform|) + (NEQUAL |which| + (MAKESTRING + "package operation"))) + 'T) + ('T NIL))) + (DO ((G171198 |opAlist| (CDR G171198)) + (G171166 NIL)) + ((OR (ATOM G171198) + (PROGN (SETQ G171166 (CAR G171198)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G171166)) + (SPADLET |alist| (CDR G171166)) + G171166) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |exposureFlag| + |initialExposure|) + (DO () ((NULL |alist|) NIL) + (SEQ (EXIT + (PROGN + (SPADLET |item| + (CAR |alist|)) + (SPADLET |isExposed?| + (COND + ((STRINGP |item|) + (|dbExposed?| |item| + (|char| '|o|))) + ((NULL + (SPADLET |r| + (CDR (CDR |item|)))) + 'T) + ('T (ELT |r| 1)))) + (COND + (|isExposed?| + (RETURN + (SPADLET |exposureFlag| + 'T)))) + (SPADLET |alist| + (CDR |alist|)))))) + (SPADLET |node| + (COND + (|exposureFlag| |op|) + ('T + (CONS |op| (CONS NIL NIL))))) + (SPADLET |acc| (CONS |node| |acc|)))))) + (NREVERSE |acc|)) + ('T (SPADLET |data| NIL) + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + |which| + (|member| |key| '(|origins| |documentation|)) NIL) + (DO ((G171226 |opAlist| (CDR G171226)) + (G171179 NIL)) + ((OR (ATOM G171226) + (PROGN (SETQ G171179 (CAR G171226)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G171179)) + (SPADLET |alist| (CDR G171179)) + G171179) + NIL)) + NIL) + (SEQ (EXIT (DO ((G171243 |alist| (CDR G171243)) + (|item| NIL)) + ((OR (ATOM G171243) + (PROGN + (SETQ |item| (CAR G171243)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |entry| + (FUNCALL |dataFunction| |op| + |item|)) + (SPADLET |exposeFlag| + (COND + ((NULL + (SPADLET |r| + (CDR (CDR |item|)))) + 'T) + ('T (ELT |r| 1)))) + (SPADLET |tail| + (COND + ((AND (PAIRP |item|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + 'ASCONST)))) + 'ASCONST) + ('T NIL))) + (SPADLET |newEntry| + (COND + ((SPADLET |u| + (|assoc| |entry| |data|)) + (RPLACA (CDR |u|) + (OR (CADR |u|) + |exposeFlag|)) + |u|) + ('T + (SPADLET |data| + (CONS + (SPADLET |y| + (CONS |entry| + (CONS |exposeFlag| + |tail|))) + |data|)) + |y|))) + (COND + ((|member| |key| + '(|origins| |conditions|)) + (SPADLET |r| + (CDDR |newEntry|)) + (COND + ((ATOM |r|) + (SPADLET |r| NIL))) + (RPLACD (CDR |newEntry|) + (|insert| + (CONS + (|dbMakeSignature| |op| + |item|) + (CONS |exposeFlag| + |tail|)) + |r|))) + ('T NIL))))))))) + (COND + ((|member| |key| '(|origins| |conditions|)) + (DO ((G171255 |data| (CDR G171255)) + (|entry| NIL)) + ((OR (ATOM G171255) + (PROGN + (SETQ |entry| (CAR G171255)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |tail| (CDDR |entry|)) + (SPADLET |tail| + (COND + ((ATOM |tail|) |tail|) + ('T + (|listSort| + (|function| LEXLESSEQP) |tail|)))) + (RPLACD (CDR |entry|) |tail|))))))) + (SPADLET |data| + (|listSort| (|function| LEXLESSEQP) |data|)) + |data|)))))))) + +;dbGatherDataImplementation(htPage,opAlist) == +;--returns data, of form ((implementor exposed? entry entry...)... +;-- where entry has form ((op sig . implementor) . stuff) +; conform := htpProperty(htPage,'conform) +; domainForm := htpProperty(htPage,'domname) +; dom := EVAL domainForm +; which := '"operation" +; [nam,:$domainArgs] := domainForm +; $predicateList: local := GETDATABASE(nam,'PREDICATES) +; predVector := dom.3 +; u := getDomainOpTable(dom,true,ASSOCLEFT opAlist) +; --u has form ((op,sig,:implementor)...) +; --sort into 4 groups: domain exports, unexports, default exports, others +; for (x := [.,.,:key]) in u for i in 0.. repeat +; key = domainForm => domexports := [x,:domexports] +; INTEGERP key => unexports := [x,:unexports] +; isDefaultPackageForm? key => defexports := [x,:defexports] +; key = 'nowhere => nowheres := [x,:nowheres] +; key = 'constant =>constants := [x,:constants] +; others := [x,:others] --add chain domains go here +; fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR, +; NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where +; fn l == +; alist := nil +; for u in l repeat +; while u repeat +; key := CDDAR u --implementor +; entries := +; [[CAR u,true],:[u and [CAR u,true] while key = CDDAR (u := rest u)]] +; alist := [[key,gn key,:entries],:alist] +; NREVERSE alist +; gn key == +; atom key => true +; isExposedConstructor CAR key + +(DEFUN |dbGatherDataImplementation,gn| (|key|) + (SEQ (IF (ATOM |key|) (EXIT 'T)) + (EXIT (|isExposedConstructor| (CAR |key|))))) + +(DEFUN |dbGatherDataImplementation,fn| (|l|) + (PROG (|key| |entries| |alist|) + (RETURN + (SEQ (SPADLET |alist| NIL) + (DO ((G171311 |l| (CDR G171311)) (|u| NIL)) + ((OR (ATOM G171311) + (PROGN (SETQ |u| (CAR G171311)) NIL)) + NIL) + (SEQ (EXIT (DO () ((NULL |u|) NIL) + (SEQ (SPADLET |key| (CDDAR |u|)) + (SPADLET |entries| + (CONS + (CONS (CAR |u|) (CONS 'T NIL)) + (PROG (G171327) + (SPADLET G171327 NIL) + (RETURN + (DO () + ((NULL + (BOOT-EQUAL |key| + (CDDAR + (SPADLET |u| + (CDR |u|))))) + (NREVERSE0 G171327)) + (SEQ + (EXIT + (SETQ G171327 + (CONS + (AND |u| + (CONS (CAR |u|) + (CONS 'T NIL))) + G171327))))))))) + (EXIT (SPADLET |alist| + (CONS + (CONS |key| + (CONS + (|dbGatherDataImplementation,gn| + |key|) + |entries|)) + |alist|)))))))) + (EXIT (NREVERSE |alist|)))))) + +(DEFUN |dbGatherDataImplementation| (|htPage| |opAlist|) + (PROG (|$predicateList| |conform| |domainForm| |dom| |which| |nam| + |predVector| |u| |key| |domexports| |unexports| + |defexports| |nowheres| |constants| |others|) + (DECLARE (SPECIAL |$predicateList| |$domainArgs|)) + (RETURN + (SEQ (PROGN + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |domainForm| (|htpProperty| |htPage| '|domname|)) + (SPADLET |dom| (EVAL |domainForm|)) + (SPADLET |which| (MAKESTRING "operation")) + (SPADLET |nam| (CAR |domainForm|)) + (SPADLET |$domainArgs| (CDR |domainForm|)) + (SPADLET |$predicateList| (GETDATABASE |nam| 'PREDICATES)) + (SPADLET |predVector| (ELT |dom| 3)) + (SPADLET |u| + (|getDomainOpTable| |dom| 'T + (ASSOCLEFT |opAlist|))) + (DO ((G171351 |u| (CDR G171351)) (|x| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G171351) + (PROGN (SETQ |x| (CAR G171351)) NIL) + (PROGN + (PROGN (SPADLET |key| (CDDR |x|)) |x|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |key| |domainForm|) + (SPADLET |domexports| + (CONS |x| |domexports|))) + ((INTEGERP |key|) + (SPADLET |unexports| + (CONS |x| |unexports|))) + ((|isDefaultPackageForm?| |key|) + (SPADLET |defexports| + (CONS |x| |defexports|))) + ((BOOT-EQUAL |key| '|nowhere|) + (SPADLET |nowheres| (CONS |x| |nowheres|))) + ((BOOT-EQUAL |key| '|constant|) + (SPADLET |constants| + (CONS |x| |constants|))) + ('T (SPADLET |others| (CONS |x| |others|))))))) + (|dbGatherDataImplementation,fn| + (CONS |nowheres| + (CONS |constants| + (CONS |domexports| + (CONS + (SORTBY 'CDDR (NREVERSE |others|)) + (CONS + (SORTBY 'CDDR + (NREVERSE |defexports|)) + (CONS + (SORTBY 'CDDR + (NREVERSE |unexports|)) + NIL)))))))))))) + +;dbSelectData(htPage,opAlist,key) == +; branch := htpProperty(htPage,'branch) +; data := htpProperty(htPage,'data) +; MEMQ(branch,'(signatures parameters)) => +; dbReduceOpAlist(opAlist,data.key,branch) +; MEMQ(branch,'(origins conditions implementation)) => +; key < 8192 => dbReduceOpAlist(opAlist,data.key,branch) +; [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large +; innerData := CDDR data.(newkey - 1) +; dbReduceOpAlist(opAlist,innerData.binkey,'signatures) +; [opAlist . key] + +(DEFUN |dbSelectData| (|htPage| |opAlist| |key|) + (PROG (|branch| |data| |LETTMP#1| |newkey| |binkey| |innerData|) + (RETURN + (PROGN + (SPADLET |branch| (|htpProperty| |htPage| '|branch|)) + (SPADLET |data| (|htpProperty| |htPage| '|data|)) + (COND + ((MEMQ |branch| '(|signatures| |parameters|)) + (|dbReduceOpAlist| |opAlist| (ELT |data| |key|) |branch|)) + ((MEMQ |branch| '(|origins| |conditions| |implementation|)) + (COND + ((> 8192 |key|) + (|dbReduceOpAlist| |opAlist| (ELT |data| |key|) |branch|)) + ('T (SPADLET |LETTMP#1| (DIVIDE |key| 8192)) + (SPADLET |newkey| (CAR |LETTMP#1|)) + (SPADLET |binkey| (CADR |LETTMP#1|)) + (SPADLET |innerData| + (CDDR (ELT |data| (SPADDIFFERENCE |newkey| 1)))) + (|dbReduceOpAlist| |opAlist| (ELT |innerData| |binkey|) + '|signatures|)))) + ('T (CONS (ELT |opAlist| |key|) NIL))))))) + +;dbReduceOpAlist(opAlist,data,branch) == +; branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data) +; branch = 'origins => dbReduceBySelection(opAlist,CAR data,function CADDR) +; branch = 'conditions => dbReduceBySelection(opAlist,CAR data,function CADR) +; branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data) +; branch = 'parameters => dbReduceByForm(opAlist,CAR data) +; systemError ['"Unexpected branch: ",branch] + +(DEFUN |dbReduceOpAlist| (|opAlist| |data| |branch|) + (COND + ((BOOT-EQUAL |branch| '|signatures|) + (|dbReduceBySignature| |opAlist| (CAAR |data|) (CADAR |data|))) + ((BOOT-EQUAL |branch| '|origins|) + (|dbReduceBySelection| |opAlist| (CAR |data|) (|function| CADDR))) + ((BOOT-EQUAL |branch| '|conditions|) + (|dbReduceBySelection| |opAlist| (CAR |data|) (|function| CADR))) + ((BOOT-EQUAL |branch| '|implementation|) + (|dbReduceByOpSignature| |opAlist| (CDDR |data|))) + ((BOOT-EQUAL |branch| '|parameters|) + (|dbReduceByForm| |opAlist| (CAR |data|))) + ('T + (|systemError| + (CONS (MAKESTRING "Unexpected branch: ") (CONS |branch| NIL)))))) + +;dbReduceByOpSignature(opAlist,datalist) == +;--reduces opAlist by implementation datalist, one of the form +;-- (((op,sig,:implementor),:stuff),...) +; ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.] +; acc := nil +; for [op,:alist] in opAlist | MEMQ(op,ops) repeat +; entryList := [entry for (entry := [sig,:.]) in alist | test] where test == +; or/[x for x in datalist | x is [[=op,=sig,:.],:.]] +; entryList => acc := [[op,:NREVERSE entryList],:acc] +; NREVERSE acc + +(DEFUN |dbReduceByOpSignature| (|opAlist| |datalist|) + (PROG (|ops| |op| |alist| |sig| |ISTMP#1| |ISTMP#2| |entryList| + |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |ops| + (PROG (G171426) + (SPADLET G171426 NIL) + (RETURN + (DO ((G171431 |datalist| (CDR G171431)) + (|x| NIL)) + ((OR (ATOM G171431) + (PROGN + (SETQ |x| (CAR G171431)) + NIL)) + (NREVERSE0 G171426)) + (SEQ (EXIT (SETQ G171426 + (CONS (CAAR |x|) G171426)))))))) + (SPADLET |acc| NIL) + (DO ((G171450 |opAlist| (CDR G171450)) + (G171417 NIL)) + ((OR (ATOM G171450) + (PROGN (SETQ G171417 (CAR G171450)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G171417)) + (SPADLET |alist| (CDR G171417)) + G171417) + NIL)) + NIL) + (SEQ (EXIT (COND + ((MEMQ |op| |ops|) + (PROGN + (SPADLET |entryList| + (PROG (G171463) + (SPADLET G171463 NIL) + (RETURN + (DO + ((G171470 |alist| + (CDR G171470)) + (|entry| NIL)) + ((OR (ATOM G171470) + (PROGN + (SETQ |entry| + (CAR G171470)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR |entry|)) + |entry|) + NIL)) + (NREVERSE0 G171463)) + (SEQ + (EXIT + (COND + ((PROG (G171477) + (SPADLET G171477 + NIL) + (RETURN + (DO + ((G171484 NIL + G171477) + (G171485 + |datalist| + (CDR + G171485)) + (|x| NIL)) + ((OR G171484 + (ATOM + G171485) + (PROGN + (SETQ |x| + (CAR + G171485)) + NIL)) + G171477) + (SEQ + (EXIT + (COND + ((AND + (PAIRP + |x|) + (PROGN + (SPADLET + |ISTMP#1| + (QCAR + |x|)) + (AND + (PAIRP + |ISTMP#1|) + (EQUAL + (QCAR + |ISTMP#1|) + |op|) + (PROGN + (SPADLET + |ISTMP#2| + (QCDR + |ISTMP#1|)) + (AND + (PAIRP + |ISTMP#2|) + (EQUAL + (QCAR + |ISTMP#2|) + |sig|)))))) + (SETQ + G171477 + (OR + G171477 + |x|))))))))) + (SETQ G171463 + (CONS |entry| + G171463)))))))))) + (COND + (|entryList| + (SPADLET |acc| + (CONS + (CONS |op| + (NREVERSE |entryList|)) + |acc|)))))))))) + (NREVERSE |acc|)))))) + +;dbReduceBySignature(opAlist,op,sig) == +;--reduces opAlist to one with a fixed op and sig +; [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]] + +(DEFUN |dbReduceBySignature| (|opAlist| |op| |sig|) + (PROG () + (RETURN + (SEQ (CONS (CONS |op| + (PROG (G171512) + (SPADLET G171512 NIL) + (RETURN + (DO ((G171518 (LASSOC |op| |opAlist|) + (CDR G171518)) + (|x| NIL)) + ((OR (ATOM G171518) + (PROGN + (SETQ |x| (CAR G171518)) + NIL)) + (NREVERSE0 G171512)) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (EQUAL (QCAR |x|) |sig|)) + (SETQ G171512 + (CONS |x| G171512)))))))))) + NIL))))) + +;dbReduceByForm(opAlist,form) == +; acc := nil +; for [op,:alist] in opAlist repeat +; items := [x for x in alist | dbContrivedForm(op,x) = form] => +; acc := [[op,:items],:acc] +; NREVERSE acc + +(DEFUN |dbReduceByForm| (|opAlist| |form|) + (PROG (|op| |alist| |items| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SEQ (DO ((G171537 |opAlist| (CDR G171537)) + (G171528 NIL)) + ((OR (ATOM G171537) + (PROGN + (SETQ G171528 (CAR G171537)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G171528)) + (SPADLET |alist| (CDR G171528)) + G171528) + NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |items| + (PROG (G171549) + (SPADLET G171549 NIL) + (RETURN + (DO + ((G171555 |alist| + (CDR G171555)) + (|x| NIL)) + ((OR (ATOM G171555) + (PROGN + (SETQ |x| + (CAR G171555)) + NIL)) + (NREVERSE0 G171549)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL + (|dbContrivedForm| + |op| |x|) + |form|) + (SETQ G171549 + (CONS |x| + G171549)))))))))) + (EXIT (SPADLET |acc| + (CONS (CONS |op| |items|) + |acc|)))))))) + (NREVERSE |acc|))))))) + +;dbReduceBySelection(opAlist,key,fn) == +; acc := nil +; for [op,:alist] in opAlist repeat +; items := [x for x in alist | FUNCALL(fn,x) = key] => +; acc := [[op,:items],:acc] +; NREVERSE acc + +(DEFUN |dbReduceBySelection| (|opAlist| |key| |fn|) + (PROG (|op| |alist| |items| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SEQ (DO ((G171579 |opAlist| (CDR G171579)) + (G171570 NIL)) + ((OR (ATOM G171579) + (PROGN + (SETQ G171570 (CAR G171579)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G171570)) + (SPADLET |alist| (CDR G171570)) + G171570) + NIL)) + NIL) + (SEQ (EXIT (COND + ((SPADLET |items| + (PROG (G171591) + (SPADLET G171591 NIL) + (RETURN + (DO + ((G171597 |alist| + (CDR G171597)) + (|x| NIL)) + ((OR (ATOM G171597) + (PROGN + (SETQ |x| + (CAR G171597)) + NIL)) + (NREVERSE0 G171591)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL + (FUNCALL |fn| + |x|) + |key|) + (SETQ G171591 + (CONS |x| + G171591)))))))))) + (EXIT (SPADLET |acc| + (CONS (CONS |op| |items|) + |acc|)))))))) + (NREVERSE |acc|))))))) + +;dbContrivedForm(op,[sig,:.]) == +; $which = '"attribute" => [op,sig] +; dbMakeContrivedForm(op,sig) + +(DEFUN |dbContrivedForm| (|op| G171613) + (PROG (|sig|) + (declare (special |$which|)) + (RETURN + (PROGN + (SPADLET |sig| (CAR G171613)) + (COND + ((BOOT-EQUAL |$which| (MAKESTRING "attribute")) + (CONS |op| (CONS |sig| NIL))) + ('T (|dbMakeContrivedForm| |op| |sig|))))))) + +;dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format + +(DEFUN |dbMakeSignature| (|op| G171624) + (PROG (|sig|) + (RETURN + (PROGN + (SPADLET |sig| (CAR G171624)) + (CONS |op| (CONS |sig| NIL)))))) + +;dbGetOrigin(op,[.,.,origin,:.]) == origin + +(DEFUN |dbGetOrigin| (|op| G171635) + (declare (ignore |op|)) + (PROG (|origin|) + (RETURN (PROGN (SPADLET |origin| (CADDR G171635)) |origin|)))) + +;dbGetCondition(op,[.,pred,:.]) == pred + +(DEFUN |dbGetCondition| (|op| G171646) + (declare (ignore |op|)) + (PROG (|pred|) + (RETURN (PROGN (SPADLET |pred| (CADR G171646)) |pred|)))) + +;--dbInsertOpAlist(op,item,opAlist) == +;-- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist) +;--dbSortOpAlist opAlist == +;-- [[op,:listSort(function LEXLESSEQP,alist)] +;-- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)] +;--============================================================================ +;-- Branches of Views +;--============================================================================ +;dbShowOpNames(htPage,opAlist,which,data) == +; single? := opAlist and null rest data +; single? => +; ops := escapeSpecialChars STRINGIMAGE CAAR opAlist +; htSayStandard('"Select a view below") +; htSaySaturn '"Select a view with the right mouse button" +; exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage) +; dbShowOpItems(which,data,exposedOnly?) + +(DEFUN |dbShowOpNames| (|htPage| |opAlist| |which| |data|) + (PROG (|single?| |ops| |exposedOnly?|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (PROGN + (SPADLET |single?| (AND |opAlist| (NULL (CDR |data|)))) + (COND + (|single?| + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE (CAAR |opAlist|)))) + (|htSayStandard| (MAKESTRING "Select a view below")) + (|htSaySaturn| + (MAKESTRING + "Select a view with the right mouse button"))) + ('T + (SPADLET |exposedOnly?| + (AND |$exposedOnlyIfTrue| + (NULL (|dbFromConstructor?| |htPage|)))) + (|dbShowOpItems| |which| |data| |exposedOnly?|))))))) + +;dbShowOpItems(which,data,exposedOnly?) == +; htBeginTable() +; firstTime := true +; for i in 0.. for item in data repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; if atom item then +; op := item +; exposeFlag := true +; else +; [op,exposeFlag] := item +; ops := escapeSpecialChars STRINGIMAGE op +; exposeFlag or not exposedOnly? => +; htSay('"{") +; bcStarSpaceOp(ops,exposeFlag) +; htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]] +; htSay('"}") +; htEndTable() + +(DEFUN |dbShowOpItems| (|which| |data| |exposedOnly?|) + (PROG (|firstTime| |op| |exposeFlag| |ops|) + (RETURN + (SEQ (PROGN + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((|i| 0 (QSADD1 |i|)) + (G171684 |data| (CDR G171684)) (|item| NIL)) + ((OR (ATOM G171684) + (PROGN (SETQ |item| (CAR G171684)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (COND + ((ATOM |item|) (SPADLET |op| |item|) + (SPADLET |exposeFlag| 'T)) + ('T (SPADLET |op| (CAR |item|)) + (SPADLET |exposeFlag| (CADR |item|)) + |item|)) + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE |op|))) + (COND + ((OR |exposeFlag| (NULL |exposedOnly?|)) + (PROGN + (|htSay| (MAKESTRING "{")) + (|bcStarSpaceOp| |ops| |exposeFlag|) + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |ops| + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS |i| NIL))))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}"))))))))) + (|htEndTable|)))))) + +;dbShowOpAllDomains(htPage,opAlist,which) == +; dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) +; catOriginAlist := nil --list of category origins +; domOriginAlist := nil --list of domain origins +; for [op,:items] in opAlist repeat +; for [.,predicate,origin,:.] in items repeat +; conname := CAR origin +; GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => +; pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true) +; catOriginAlist := insertAlist(conname,pred,catOriginAlist) +; pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true) +; domOriginAlist := insertAlist(conname,pred,domOriginAlist) +; --the following is similar to "domainsOf" but do not sort immediately +; u := [COPY key for key in HKEYS _*HASCATEGORY_-HASH_* +; | LASSQ(CDR key,catOriginAlist)] +; for pair in u repeat +; [dom,:cat] := pair +; LASSQ(cat,catOriginAlist) = 'etc => RPLACD(pair,'etc) +; RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true)) +; --now add all of the domains +; for [dom,:pred] in domOriginAlist repeat +; u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u) +; cAlist := listSort(function GLESSEQP,u) +; for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair) +; htpSetProperty(htPage,'cAlist,cAlist) +; htpSetProperty(htPage,'thing,'"constructor") +; htpSetProperty(htPage,'specialHeading,'"hoho") +; dbShowCons(htPage,'names) + +(DEFUN |dbShowOpAllDomains| (|htPage| |opAlist| |which|) + (PROG (|op| |items| |predicate| |origin| |conname| |catOriginAlist| + |domOriginAlist| |cat| |dom| |pred| |u| |cAlist|) + (declare (special *hascategory-hash*)) + (RETURN + (SEQ (PROGN + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| |which| + 'T NIL) + (SPADLET |catOriginAlist| NIL) + (SPADLET |domOriginAlist| NIL) + (DO ((G171728 |opAlist| (CDR G171728)) + (G171706 NIL)) + ((OR (ATOM G171728) + (PROGN (SETQ G171706 (CAR G171728)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G171706)) + (SPADLET |items| (CDR G171706)) + G171706) + NIL)) + NIL) + (SEQ (EXIT (DO ((G171741 |items| (CDR G171741)) + (G171702 NIL)) + ((OR (ATOM G171741) + (PROGN + (SETQ G171702 (CAR G171741)) + NIL) + (PROGN + (PROGN + (SPADLET |predicate| + (CADR G171702)) + (SPADLET |origin| + (CADDR G171702)) + G171702) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |conname| + (CAR |origin|)) + (COND + ((BOOT-EQUAL + (GETDATABASE |conname| + 'CONSTRUCTORKIND) + '|category|) + (SPADLET |pred| + (|simpOrDumb| |predicate| + (OR + (LASSQ |conname| + |catOriginAlist|) + 'T))) + (SPADLET |catOriginAlist| + (|insertAlist| |conname| + |pred| |catOriginAlist|))) + ('T + (SPADLET |pred| + (|simpOrDumb| |predicate| + (OR + (LASSQ |conname| + |domOriginAlist|) + 'T))) + (SPADLET |domOriginAlist| + (|insertAlist| |conname| + |pred| |domOriginAlist|))))))))))) + (SPADLET |u| + (PROG (G171753) + (SPADLET G171753 NIL) + (RETURN + (DO ((G171759 (HKEYS *HASCATEGORY-HASH*) + (CDR G171759)) + (|key| NIL)) + ((OR (ATOM G171759) + (PROGN + (SETQ |key| (CAR G171759)) + NIL)) + (NREVERSE0 G171753)) + (SEQ (EXIT (COND + ((LASSQ (CDR |key|) + |catOriginAlist|) + (SETQ G171753 + (CONS (COPY |key|) + G171753)))))))))) + (DO ((G171771 |u| (CDR G171771)) (|pair| NIL)) + ((OR (ATOM G171771) + (PROGN (SETQ |pair| (CAR G171771)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |dom| (CAR |pair|)) + (SPADLET |cat| (CDR |pair|)) + (COND + ((BOOT-EQUAL + (LASSQ |cat| |catOriginAlist|) + '|etc|) + (RPLACD |pair| '|etc|)) + ('T + (RPLACD |pair| + (|simpOrDumb| + (GETDATABASE |pair| + 'HASCATEGORY) + 'T)))))))) + (DO ((G171781 |domOriginAlist| (CDR G171781)) + (G171714 NIL)) + ((OR (ATOM G171781) + (PROGN (SETQ G171714 (CAR G171781)) NIL) + (PROGN + (PROGN + (SPADLET |dom| (CAR G171714)) + (SPADLET |pred| (CDR G171714)) + G171714) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |u| + (|insertAlist| |dom| + (|simpOrDumb| |pred| + (OR (LASSQ |dom| |u|) 'T)) + |u|))))) + (SPADLET |cAlist| (|listSort| (|function| GLESSEQP) |u|)) + (DO ((G171791 |cAlist| (CDR G171791)) (|pair| NIL)) + ((OR (ATOM G171791) + (PROGN (SETQ |pair| (CAR G171791)) NIL)) + NIL) + (SEQ (EXIT (RPLACA |pair| + (|getConstructorForm| (CAR |pair|)))))) + (|htpSetProperty| |htPage| '|cAlist| |cAlist|) + (|htpSetProperty| |htPage| '|thing| + (MAKESTRING "constructor")) + (|htpSetProperty| |htPage| '|specialHeading| + (MAKESTRING "hoho")) + (|dbShowCons| |htPage| '|names|)))))) + +;simpOrDumb(new,old) == +; new = 'etc => 'etc +; atom new => old +; 'etc + +(DEFUN |simpOrDumb| (|new| |old|) + (COND + ((BOOT-EQUAL |new| '|etc|) '|etc|) + ((ATOM |new|) |old|) + ('T '|etc|))) + +;dbShowOpOrigins(htPage,opAlist,which,data) == +; dbGatherThenShow(htPage,opAlist,which,data,true,_ +; '"from",function bcStarConform) + +(DEFUN |dbShowOpOrigins| (|htPage| |opAlist| |which| |data|) + (|dbGatherThenShow| |htPage| |opAlist| |which| |data| 'T + (MAKESTRING "from") (|function| |bcStarConform|))) + +;dbShowOpImplementations(htPage,opAlist,which,data) == +; dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform) + +(DEFUN |dbShowOpImplementations| (|htPage| |opAlist| |which| |data|) + (|dbGatherThenShow| |htPage| |opAlist| |which| |data| 'T + (MAKESTRING "by") (|function| |bcStarConform|))) + +;dbShowOpConditions(htPage,opAlist,which,data) == +; dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred) + +(DEFUN |dbShowOpConditions| (|htPage| |opAlist| |which| |data|) + (|dbGatherThenShow| |htPage| |opAlist| |which| |data| NIL NIL + (|function| |bcPred|))) + +;dbShowKind conform == +; conname := CAR conform +; kind := GETDATABASE(conname,'CONSTRUCTORKIND) +; kind = 'domain => +; (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" +; '"domain" +; PNAME kind + +(DEFUN |dbShowKind| (|conform|) + (PROG (|conname| |kind| |s|) + (RETURN + (PROGN + (SPADLET |conname| (CAR |conform|)) + (SPADLET |kind| (GETDATABASE |conname| 'CONSTRUCTORKIND)) + (COND + ((BOOT-EQUAL |kind| '|domain|) + (COND + ((BOOT-EQUAL + (ELT (SPADLET |s| (PNAME |conname|)) (MAXINDEX |s|)) + '&) + (MAKESTRING "default package")) + ('T (MAKESTRING "domain")))) + ('T (PNAME |kind|))))))) + +;dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0) + +(DEFUN |dbShowOpSignatures| (|htPage| |opAlist| |which| |data|) + (declare (ignore |htPage| |opAlist|)) + (|dbShowOpSigList| |which| |data| 0)) + +;dbShowOpSigList(which,dataItems,count) == +;--dataItems is (((op,sig,:.),exposureFlag,...) +; single? := null rest dataItems +; htBeginTable() +; firstTime := true +; for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&"; +; ops := escapeSpecialChars STRINGIMAGE op +; htSay '"{" +;-- if single? then htSay('"{\em ",ops,'"}") else..... +; htSayExpose(ops,exposureFlag) +; htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] +; if which = '"attribute" then htSay args2HtString (sig and [sig]) else +; htSay '": " +; tail = 'ASCONST => bcConform first sig +; bcConform ['Mapping,:sig] +; htSay '"}" +; count := count + 1 +; htEndTable() +; count + +(DEFUN |dbShowOpSigList| (|which| |dataItems| |count|) + (PROG (|single?| |op| |sig| |exposureFlag| |tail| |firstTime| |ops|) + (RETURN + (SEQ (PROGN + (SPADLET |single?| (NULL (CDR |dataItems|))) + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G171864 |dataItems| (CDR G171864)) + (G171845 NIL)) + ((OR (ATOM G171864) + (PROGN (SETQ G171845 (CAR G171864)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAAR G171845)) + (SPADLET |sig| (CADAR G171845)) + (SPADLET |exposureFlag| (CADR G171845)) + (SPADLET |tail| (CDDR G171845)) + G171845) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE |op|))) + (|htSay| (MAKESTRING "{")) + (|htSayExpose| |ops| |exposureFlag|) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS |ops| + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS |count| NIL))))) + NIL)) + NIL)) + (COND + ((BOOT-EQUAL |which| + (MAKESTRING "attribute")) + (|htSay| (|args2HtString| + (AND |sig| (CONS |sig| NIL))))) + ('T (|htSay| (MAKESTRING ": ")) + (COND + ((BOOT-EQUAL |tail| 'ASCONST) + (|bcConform| (CAR |sig|))) + ('T + (|bcConform| (CONS '|Mapping| |sig|)))))) + (|htSay| (MAKESTRING "}")) + (SPADLET |count| (PLUS |count| 1)))))) + (|htEndTable|) + |count|))))) + +;dbShowOpParameters(htPage,opAlist,which,data) == +; single? := null rest data +; count := 0 +; htBeginTable() +; firstTime := true +; for item in data repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; [opform,exposeFlag,:tail] := item +; op := intern IFCAR opform +; args := IFCDR opform +; ops := escapeSpecialChars STRINGIMAGE op +; htSay '"{" +; htSayExpose(ops,exposeFlag) +; n := #opform +; do +; n = 2 and LASSOC('Nud,PROPLIST op) => +; dbShowOpParameterJump(ops,which,count,single?) +; htSay('" {\em ",KAR args,'"}") +; n = 3 and LASSOC('Led,PROPLIST op) => +; htSay('"{\em ",KAR args,'"} ") +; dbShowOpParameterJump(ops,which,count,single?) +; htSay('" {\em ",KAR KDR args,'"}") +; dbShowOpParameterJump(ops,which,count,single?) +; tail = 'ASCONST or MEMBER(op,'(0 1)) or _ +; which = '"attribute" and null IFCAR args => 'skip +; htSay('"(") +; if IFCAR args then htSay('"{\em ",IFCAR args,'"}") +; for x in IFCDR args repeat +; htSay('",{\em ",x,'"}") +; htSay('")") +; htSay '"}" +; count := count + 1 +; htEndTable() + +(DEFUN |dbShowOpParameters| (|htPage| |opAlist| |which| |data|) + (declare (ignore |htPage| |opAlist|)) + (PROG (|single?| |firstTime| |opform| |exposeFlag| |tail| |op| |args| + |ops| |n| |count|) + (RETURN + (SEQ (PROGN + (SPADLET |single?| (NULL (CDR |data|))) + (SPADLET |count| 0) + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G171908 |data| (CDR G171908)) (|item| NIL)) + ((OR (ATOM G171908) + (PROGN (SETQ |item| (CAR G171908)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (SPADLET |opform| (CAR |item|)) + (SPADLET |exposeFlag| (CADR |item|)) + (SPADLET |tail| (CDDR |item|)) + (SPADLET |op| (|intern| (IFCAR |opform|))) + (SPADLET |args| (IFCDR |opform|)) + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE |op|))) + (|htSay| (MAKESTRING "{")) + (|htSayExpose| |ops| |exposeFlag|) + (SPADLET |n| (|#| |opform|)) + (|do| (COND + ((AND (EQL |n| 2) + (LASSOC '|Nud| (PROPLIST |op|))) + (|dbShowOpParameterJump| |ops| + |which| |count| |single?|) + (|htSay| (MAKESTRING " {\\em ") + (KAR |args|) (MAKESTRING "}"))) + ((AND (EQL |n| 3) + (LASSOC '|Led| (PROPLIST |op|))) + (|htSay| (MAKESTRING "{\\em ") + (KAR |args|) (MAKESTRING "} ")) + (|dbShowOpParameterJump| |ops| + |which| |count| |single?|) + (|htSay| (MAKESTRING " {\\em ") + (KAR (KDR |args|)) + (MAKESTRING "}"))) + ('T + (|dbShowOpParameterJump| |ops| + |which| |count| |single?|) + (COND + ((OR + (BOOT-EQUAL |tail| 'ASCONST) + (|member| |op| '(0 1)) + (AND + (BOOT-EQUAL |which| + (MAKESTRING "attribute")) + (NULL (IFCAR |args|)))) + '|skip|) + ('T (|htSay| (MAKESTRING "(")) + (COND + ((IFCAR |args|) + (|htSay| + (MAKESTRING "{\\em ") + (IFCAR |args|) + (MAKESTRING "}")))) + (DO + ((G171917 (IFCDR |args|) + (CDR G171917)) + (|x| NIL)) + ((OR (ATOM G171917) + (PROGN + (SETQ |x| (CAR G171917)) + NIL)) + NIL) + (SEQ + (EXIT + (|htSay| + (MAKESTRING ",{\\em ") |x| + (MAKESTRING "}"))))) + (|htSay| (MAKESTRING ")"))))))) + (|htSay| (MAKESTRING "}")) + (SPADLET |count| (PLUS |count| 1)))))) + (|htEndTable|)))))) + +;dbShowOpParameterJump(ops,which,count,single?) == +; single? => htSay('"{\em ",ops,'"}") +; htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] + +(DEFUN |dbShowOpParameterJump| (|ops| |which| |count| |single?|) + (COND + (|single?| (|htSay| (MAKESTRING "{\\em ") |ops| (MAKESTRING "}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS |ops| + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS |count| NIL))))) + NIL)) + NIL))))) + +;dbShowOpDocumentation(htPage,opAlist,which,data) == +; if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then +; opAlist := +; which = '"operation" => htpProperty(htPage,'opAlist) +; htpProperty(htPage,'attrAlist) +; --NOTE: this line is necessary to get indexing right. +; --The test below for $exposedOnlyIfTrue causes unexposed items +; --to be skipped. +; newWhich := +; conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) +; which = '"package operation" => '"operation" +; which +; expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) +; if expand then +; condata := dbGatherData(htPage,opAlist,which,'conditions) +; htpSetProperty(htPage,'conditionData,condata) +; base := -8192 +; exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp +; htSaySaturn '"\begin{description}" +; for [op,:alist] in opAlist repeat +; base := 8192 + base +; for item in alist for j in 0.. repeat +; [sig,predicate,origin,exposeFlag,comments] := item +; exposeFlag or not $exposedOnlyIfTrue => +; if comments ^= '"" and STRINGP comments _ +; and (k := string2Integer comments) then +; comments := +; MEMQ(k,'(0 1)) => '"" +; dbReadComments k +; tail := CDDDDR item +; RPLACA(tail,comments) +; doc := (STRINGP comments and comments ^= '"" => comments; nil) +; pred := predicate or true +; index := (exactlyOneOpSig => nil; base + j) +; if which = '"package operation" then +; sig := SUBST(conform,'_$,sig) +; origin := SUBST(conform,'_$,origin) +; displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,_ +; index,'dbChooseDomainOp,null exposeFlag,true) +; htSaySaturn '"\end{description}" + +(DEFUN |dbShowOpDocumentation| (|htPage| |opAlist| |which| |data|) + (declare (ignore |data|)) + (PROG (|conform| |newWhich| |expand| |condata| |ISTMP#1| |ISTMP#2| + |exactlyOneOpSig| |op| |alist| |base| |predicate| + |exposeFlag| |k| |comments| |tail| |doc| |pred| |index| + |sig| |origin|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROGN + (COND + ((AND |$exposedOnlyIfTrue| + (NULL (|dbFromConstructor?| |htPage|))) + (SPADLET |opAlist| + (COND + ((BOOT-EQUAL |which| + (MAKESTRING "operation")) + (|htpProperty| |htPage| '|opAlist|)) + ('T (|htpProperty| |htPage| '|attrAlist|)))))) + (SPADLET |newWhich| + (PROGN + (SPADLET |conform| + (OR (|htpProperty| |htPage| + '|domname|) + (|htpProperty| |htPage| + '|conform|))) + (COND + ((BOOT-EQUAL |which| + (MAKESTRING "package operation")) + (MAKESTRING "operation")) + ('T |which|)))) + (SPADLET |expand| + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + |which| 'T NIL)) + (COND + (|expand| + (SPADLET |condata| + (|dbGatherData| |htPage| |opAlist| |which| + '|conditions|)) + (|htpSetProperty| |htPage| '|conditionData| + |condata|))) + (SPADLET |base| (SPADDIFFERENCE 8192)) + (SPADLET |exactlyOneOpSig| + (AND (PAIRP |opAlist|) (EQ (QCDR |opAlist|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |opAlist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL))))))) + (|htSaySaturn| (MAKESTRING "\\begin{description}")) + (DO ((G171988 |opAlist| (CDR G171988)) + (G171965 NIL)) + ((OR (ATOM G171988) + (PROGN (SETQ G171965 (CAR G171988)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G171965)) + (SPADLET |alist| (CDR G171965)) + G171965) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |base| (PLUS 8192 |base|)) + (DO ((G172011 |alist| (CDR G172011)) + (|item| NIL) (|j| 0 (QSADD1 |j|))) + ((OR (ATOM G172011) + (PROGN + (SETQ |item| (CAR G172011)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |sig| (CAR |item|)) + (SPADLET |predicate| + (CADR |item|)) + (SPADLET |origin| (CADDR |item|)) + (SPADLET |exposeFlag| + (CADDDR |item|)) + (SPADLET |comments| + (CAR (CDDDDR |item|))) + (COND + ((OR |exposeFlag| + (NULL |$exposedOnlyIfTrue|)) + (PROGN + (COND + ((AND + (NEQUAL |comments| + (MAKESTRING "")) + (STRINGP |comments|) + (SPADLET |k| + (|string2Integer| + |comments|))) + (SPADLET |comments| + (COND + ((MEMQ |k| '(0 1)) + (MAKESTRING "")) + ('T + (|dbReadComments| + |k|)))) + (SPADLET |tail| + (CDDDDR |item|)) + (RPLACA |tail| + |comments|))) + (SPADLET |doc| + (COND + ((AND + (STRINGP |comments|) + (NEQUAL |comments| + (MAKESTRING ""))) + |comments|) + ('T NIL))) + (SPADLET |pred| + (OR |predicate| 'T)) + (SPADLET |index| + (COND + (|exactlyOneOpSig| NIL) + ('T (PLUS |base| |j|)))) + (COND + ((BOOT-EQUAL |which| + (MAKESTRING + "package operation")) + (SPADLET |sig| + (MSUBST |conform| '$ + |sig|)) + (SPADLET |origin| + (MSUBST |conform| '$ + |origin|)))) + (|displayDomainOp| |htPage| + |newWhich| |origin| |op| + |sig| |pred| |doc| |index| + '|dbChooseDomainOp| + (NULL |exposeFlag|) 'T)))))))))))) + (|htSaySaturn| (MAKESTRING "\\end{description}"))))))) + +;dbChooseDomainOp(htPage,which,index) == +; [opKey,entryKey] := DIVIDE(index,8192) +; opAlist := +; which = '"operation" => htpProperty(htPage,'opAlist) +; htpProperty(htPage,'attrAlist) +; [op,:entries] := opAlist . opKey +; entry := entries . entryKey +; htPage := htInitPageNoScroll(htCopyProplist htPage) +; if which = '"operation" +; then htpSetProperty(htPage,'opAlist,[[op,entry]]) +; else htpSetProperty(htPage,'attrAlist,[[op,entry]]) +; if not htpProperty(htPage,'condition?) = 'no then +; dbResetOpAlistCondition(htPage,which,opAlist) +; dbShowOps(htPage,which,'documentation) + +(DEFUN |dbChooseDomainOp| (|htPage| |which| |index|) + (PROG (|opKey| |entryKey| |opAlist| |LETTMP#1| |op| |entries| + |entry|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (DIVIDE |index| 8192)) + (SPADLET |opKey| (CAR |LETTMP#1|)) + (SPADLET |entryKey| (CADR |LETTMP#1|)) + (SPADLET |opAlist| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpProperty| |htPage| '|opAlist|)) + ('T (|htpProperty| |htPage| '|attrAlist|)))) + (SPADLET |LETTMP#1| (ELT |opAlist| |opKey|)) + (SPADLET |op| (CAR |LETTMP#1|)) + (SPADLET |entries| (CDR |LETTMP#1|)) + (SPADLET |entry| (ELT |entries| |entryKey|)) + (SPADLET |htPage| + (|htInitPageNoScroll| (|htCopyProplist| |htPage|))) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpSetProperty| |htPage| '|opAlist| + (CONS (CONS |op| (CONS |entry| NIL)) NIL))) + ('T + (|htpSetProperty| |htPage| '|attrAlist| + (CONS (CONS |op| (CONS |entry| NIL)) NIL)))) + (COND + ((NULL (BOOT-EQUAL (|htpProperty| |htPage| '|condition?|) + '|no|)) + (|dbResetOpAlistCondition| |htPage| |which| |opAlist|))) + (|dbShowOps| |htPage| |which| '|documentation|))))) + +;htSayExpose(op,flag) == +; $includeUnexposed? => +; flag => htBlank() +; op.0 = char '_* => htSay '"{\em *} " +; htSayUnexposed() +; htSay '"" + +(DEFUN |htSayExpose| (|op| |flag|) + (declare (special |$includeUnexposed?|)) + (COND + (|$includeUnexposed?| + (COND + (|flag| (|htBlank|)) + ((BOOT-EQUAL (ELT |op| 0) (|char| '*)) + (|htSay| (MAKESTRING "{\\em *} "))) + ('T (|htSayUnexposed|)))) + ('T (|htSay| (MAKESTRING ""))))) + +;--============================================================================ +;-- Branch-in From Other Places +;--============================================================================ +;dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists +; $groupChoice := nil +; conform := htpProperty(htPage,'conform) +; --prepare opAlist for possible filtering of groups +; if null BOUNDP '$topicHash then +; $topicHash := MAKE_-HASHTABLE 'ID +; for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat +; HPUT($topicHash,x,c) +; if domform := htpProperty(htPage,'domname) then +; $conformsAreDomains : local := true +; reduceOpAlistForDomain(opAlist,domform,conform) +; conform := domform or conform +; kind := capitalize htpProperty(htPage,'kind) +; exposePart := +; isExposedConstructor opOf conform => '"" +; '" Unexposed " +; fromPart := +; domform => evalableConstructor2HtString domform +; form2HtString conform +; heading := +; ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"] +; expandProperty := +; which = '"operation" => 'expandOperations +; 'expandAttributes +; htpSetProperty(htPage,expandProperty,'lists) +; htpSetProperty(htPage,'fromHeading,heading) +; reducedOpAlist := +; which = '"operation" => reduceByGroup(htPage,opAlist) +; opAlist +; if which = '"operation" +; then +; htpSetProperty(htPage,'principalOpAlist,opAlist) +; htpSetProperty(htPage,'opAlist,reducedOpAlist) +; else htpSetProperty(htPage,'attrAlist,opAlist) +; if domform +; then htpSetProperty(htPage,'condition?,'no) +; else dbResetOpAlistCondition(htPage,which,opAlist) +; dbShowOp1(htPage,reducedOpAlist,which,'names) + +(DEFUN |dbShowOperationsFromConform| (|htPage| |which| |opAlist|) + (PROG (|$conformsAreDomains| |x| |c| |domform| |conform| |kind| + |exposePart| |fromPart| |heading| |expandProperty| + |reducedOpAlist|) + (DECLARE (SPECIAL |$conformsAreDomains| |$topicHash| |$groupChoice|)) + (RETURN + (SEQ (PROGN + (SPADLET |$groupChoice| NIL) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (COND + ((NULL (BOUNDP '|$topicHash|)) + (SPADLET |$topicHash| (MAKE-HASHTABLE 'ID)) + (DO ((G172094 + '((|extended| . 0) (|basic| . 1) + (|hidden| . 2)) + (CDR G172094)) + (G172078 NIL)) + ((OR (ATOM G172094) + (PROGN (SETQ G172078 (CAR G172094)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G172078)) + (SPADLET |c| (CDR G172078)) + G172078) + NIL)) + NIL) + (SEQ (EXIT (HPUT |$topicHash| |x| |c|)))))) + (COND + ((SPADLET |domform| (|htpProperty| |htPage| '|domname|)) + (SPADLET |$conformsAreDomains| 'T) + (|reduceOpAlistForDomain| |opAlist| |domform| + |conform|))) + (SPADLET |conform| (OR |domform| |conform|)) + (SPADLET |kind| + (|capitalize| (|htpProperty| |htPage| '|kind|))) + (SPADLET |exposePart| + (COND + ((|isExposedConstructor| (|opOf| |conform|)) + (MAKESTRING "")) + ('T (MAKESTRING " Unexposed ")))) + (SPADLET |fromPart| + (COND + (|domform| + (|evalableConstructor2HtString| |domform|)) + ('T (|form2HtString| |conform|)))) + (SPADLET |heading| + (CONS (MAKESTRING " from ") + (CONS |exposePart| + (CONS |kind| + (CONS (MAKESTRING " {\\em ") + (CONS |fromPart| + (CONS (MAKESTRING "}") NIL))))))) + (SPADLET |expandProperty| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + '|expandOperations|) + ('T '|expandAttributes|))) + (|htpSetProperty| |htPage| |expandProperty| '|lists|) + (|htpSetProperty| |htPage| '|fromHeading| |heading|) + (SPADLET |reducedOpAlist| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|reduceByGroup| |htPage| |opAlist|)) + ('T |opAlist|))) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpSetProperty| |htPage| '|principalOpAlist| + |opAlist|) + (|htpSetProperty| |htPage| '|opAlist| |reducedOpAlist|)) + ('T (|htpSetProperty| |htPage| '|attrAlist| |opAlist|))) + (COND + (|domform| + (|htpSetProperty| |htPage| '|condition?| '|no|)) + ('T + (|dbResetOpAlistCondition| |htPage| |which| |opAlist|))) + (|dbShowOp1| |htPage| |reducedOpAlist| |which| '|names|)))))) + +;reduceOpAlistForDomain(opAlist,domform,conform) == +;--destructively simplify all predicates; filter out any that fail +; form1 := [domform,:rest domform] +; form2 := ['$,:rest conform] +; for pair in opAlist repeat +; RPLACD(pair,[test for item in rest pair | test]) where test == +; [head,:tail] := item +; CAR tail = true => item +; pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail) +; null pred => false +; RPLACD(item,[pred]) +; item +; opAlist + +(DEFUN |reduceOpAlistForDomain| (|opAlist| |domform| |conform|) + (PROG (|form1| |form2| |head| |tail| |pred|) + (RETURN + (SEQ (PROGN + (SPADLET |form1| (CONS |domform| (CDR |domform|))) + (SPADLET |form2| (CONS '$ (CDR |conform|))) + (DO ((G172141 |opAlist| (CDR G172141)) (|pair| NIL)) + ((OR (ATOM G172141) + (PROGN (SETQ |pair| (CAR G172141)) NIL)) + NIL) + (SEQ (EXIT (RPLACD |pair| + (PROG (G172155) + (SPADLET G172155 NIL) + (RETURN + (DO + ((G172164 (CDR |pair|) + (CDR G172164)) + (|item| NIL)) + ((OR (ATOM G172164) + (PROGN + (SETQ |item| + (CAR G172164)) + NIL)) + (NREVERSE0 G172155)) + (SEQ + (EXIT + (COND + ((PROGN + (SPADLET |head| + (CAR |item|)) + (SPADLET |tail| + (CDR |item|)) + (COND + ((BOOT-EQUAL + (CAR |tail|) 'T) + |item|) + ('T + (SPADLET |pred| + (|simpHasPred| + (SUBLISLIS |form1| + |form2| + (QCAR |tail|)))) + (COND + ((NULL |pred|) NIL) + ('T + (RPLACD |item| + (CONS |pred| NIL)) + |item|))))) + (SETQ G172155 + (CONS + (PROGN + (SPADLET |head| + (CAR |item|)) + (SPADLET |tail| + (CDR |item|)) + (COND + ((BOOT-EQUAL + (CAR |tail|) 'T) + |item|) + ('T + (SPADLET |pred| + (|simpHasPred| + (SUBLISLIS + |form1| |form2| + (QCAR |tail|)))) + (COND + ((NULL |pred|) + NIL) + ('T + (RPLACD |item| + (CONS |pred| + NIL)) + |item|))))) + G172155))))))))))))) + |opAlist|))))) + +;dbShowOperationLines(which,linelist) == --branch in with lines +; htPage := htInitPage(nil,nil) --create empty page +; opAlist := nil +; lines := linelist +; while lines repeat +; name := dbName (x := first lines) +; pile := [x] +; while (lines := rest lines) and name = dbName (x := first lines) repeat +; pile := [x,:pile] +; opAlist := [[name,:NREVERSE pile],:opAlist] +; opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist) +; if which = '"operation" +; then htpSetProperty(htPage,'opAlist,opAlist) +; else htpSetProperty(htPage,'attrAlist,opAlist) +; expandProperty := +; which = '"operation" => 'expandOperations +; 'expandAttributes +; htpSetProperty(htPage,expandProperty,'strings) +; dbResetOpAlistCondition(htPage,which,opAlist) +; if which = '"attribute" and BOUNDP '$attributeArgs and $attributeArgs then +; --code needed to handle commutative("*"); called from aPage +; --must completely expand the opAlist then check for those with +; --arguments equal to $attributeArgs +; --here: opAlist is [[op,:itemlist]] +; dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false) +; opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | _ +; first item = $attributeArgs]]] +; dbShowOp1(htPage,opAlist,which,'names) + +(DEFUN |dbShowOperationLines| (|which| |linelist|) + (PROG (|htPage| |name| |lines| |x| |pile| |expandProperty| |opAlist|) + (declare (special |$includeUnexposed?| |$attributeArgs|)) + (RETURN + (SEQ (PROGN + (SPADLET |htPage| (|htInitPage| NIL NIL)) + (SPADLET |opAlist| NIL) + (SPADLET |lines| |linelist|) + (DO () ((NULL |lines|) NIL) + (SEQ (EXIT (PROGN + (SPADLET |name| + (|dbName| + (SPADLET |x| (CAR |lines|)))) + (SPADLET |pile| (CONS |x| NIL)) + (DO () + ((NULL (AND + (SPADLET |lines| (CDR |lines|)) + (BOOT-EQUAL |name| + (|dbName| + (SPADLET |x| (CAR |lines|)))))) + NIL) + (SEQ (EXIT + (SPADLET |pile| (CONS |x| |pile|))))) + (SPADLET |opAlist| + (CONS + (CONS |name| (NREVERSE |pile|)) + |opAlist|)))))) + (SPADLET |opAlist| + (|listSort| (|function| LEXLESSEQP) + (NREVERSE |opAlist|))) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpSetProperty| |htPage| '|opAlist| |opAlist|)) + ('T (|htpSetProperty| |htPage| '|attrAlist| |opAlist|))) + (SPADLET |expandProperty| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + '|expandOperations|) + ('T '|expandAttributes|))) + (|htpSetProperty| |htPage| |expandProperty| '|strings|) + (|dbResetOpAlistCondition| |htPage| |which| |opAlist|) + (COND + ((AND (BOOT-EQUAL |which| (MAKESTRING "attribute")) + (BOUNDP '|$attributeArgs|) |$attributeArgs|) + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + |which| NIL NIL) + (SPADLET |opAlist| + (CONS (CONS (CAAR |opAlist|) + (PROG (G172207) + (SPADLET G172207 NIL) + (RETURN + (DO + ((G172213 (CDAR |opAlist|) + (CDR G172213)) + (|item| NIL)) + ((OR (ATOM G172213) + (PROGN + (SETQ |item| + (CAR G172213)) + NIL)) + (NREVERSE0 G172207)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL + (CAR |item|) + |$attributeArgs|) + (SETQ G172207 + (CONS |item| + G172207)))))))))) + NIL)))) + (|dbShowOp1| |htPage| |opAlist| |which| '|names|)))))) + +;--============================================================================ +;-- Code to Expand opAlist +;--============================================================================ +;dbResetOpAlistCondition(htPage,which,opAlist) == +; value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) +; htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) +; value + +(DEFUN |dbResetOpAlistCondition| (|htPage| |which| |opAlist|) + (PROG (|value|) + (RETURN + (PROGN + (SPADLET |value| + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + |which| NIL 'T)) + (|htpSetProperty| |htPage| '|condition?| + (COND (|value| '|yes|) ('T '|no|))) + |value|)))) + +;dbSetOpAlistCondition(htPage,opAlist,which) == +;--called whenever a new opAlist is needed +;--property can only be inherited if 'no (a subset says NO if whole says NO) +; condition := htpProperty(htPage,'condition?) +; MEMQ(condition,'(yes no)) => condition = 'yes +; value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) +; htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) +; value + +(DEFUN |dbSetOpAlistCondition| (|htPage| |opAlist| |which|) + (PROG (|condition| |value|) + (RETURN + (PROGN + (SPADLET |condition| (|htpProperty| |htPage| '|condition?|)) + (COND + ((MEMQ |condition| '(|yes| |no|)) + (BOOT-EQUAL |condition| '|yes|)) + ('T + (SPADLET |value| + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + |which| NIL 'T)) + (|htpSetProperty| |htPage| '|condition?| + (COND (|value| '|yes|) ('T '|no|))) + |value|)))))) + +;dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) == +;--if condition? = true, stop when you find a non-trivial predicate +;--otherwise, expand in full +;--RETURNS: +;-- non-trivial predicate, if condition? = true and it finds one +;-- nil, otherwise +;--SIDE-EFFECT: this function references the "expand" property (set elsewhere): +;-- 'strings, if not fully expanded and it contains strings +;-- i.e. opAlist is ((op . (string ...))...) if unexpanded +;-- 'lists, if not fully expanded and it contains lists +;-- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded +; condition? := condition? and not $exposedOnlyIfTrue +; value := nil --return value +; expandProperty := +; which = '"operation" => 'expandOperations +; 'expandAttributes +; expandFlag := htpProperty(htPage,expandProperty) +; expandFlag = 'fullyExpanded => nil +; expandFlag = 'strings => --strings are partially expanded +; for pair in opAlist repeat +; [op,:lines] := pair +; acc := nil +; for line in lines repeat +; --NOTE: we must expand all lines here for a given op +; -- since below we will change opAlist +; --Case 1: Already expanded; just cons it onto ACC +; null STRINGP line => --already expanded +; if condition? then --this could have been expanded at a lower level +; if null atom (pred := CADR line) then value := pred +; acc := [line,:acc] --this one is already expanded; record it anyway +; --Case 2: unexpanded; expand it then cons it onto ACC +; [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1) +; predicate := ncParseFromString pred +; if condition? and null atom predicate then value := predicate +; sig := ncParseFromString sigs --is (Mapping,:.) +; if which = '"operation" then +; if sig isnt ['Mapping,:.] +; then sayBrightly ['"Unexpected signature for ",name,'": ",sigs] +; else sig := rest sig +; conname := intern dbNewConname line +; origin := [conname,:getConstructorArgs conname] +; exposeFlag := dbExposed?(line,char 'o) +; acc := [[sig,predicate,origin,exposeFlag,comments],:acc] +; --always store the fruits of our labor: +; RPLACD(pair,NREVERSE acc) --at least partially expand it +; condition? and value => return value --early exit +; value => value +; condition? => nil +; htpSetProperty(htPage,expandProperty,'fullyExpanded) +; expandFlag = 'lists => --lists are partially expanded +; -- entry is [sig, predicate, origin, exposeFlag, comments] +; $value: local := nil +; $docTableHash := MAKE_-HASHTABLE 'EQUAL +; packageSymbol := false +; domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) +; if isDefaultPackageName opOf domform then +; catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s) +; packageSymbol := first rest domform +; domform := [catname,:rest rest domform] --skip first argument ($) +; docTable:= dbDocTable domform +; for [op,:alist] in opAlist repeat +; for [sig,:tail] in alist repeat +; condition? => --the only purpose here is to find a non-trivial pred +; null atom (pred := CAR tail) => return ($value := pred) +; 'skip +; u := +; tail is [.,origin,:.] and origin => +;-- must change any % into $ otherwise we will not pick up comments properly +;-- delete the SUBLISLIS when we fix on % or $ +; dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,_ +; which,nil) +; if packageSymbol then sig := SUBST('_$,packageSymbol,sig) +; dbGetDocTable(op,sig,docTable,which,nil) +; origin := IFCAR u or origin +; docCode := IFCDR u --> (doc . code) +;-- if null FIXP CDR docCode then harhar(op) --> +; if null doc and which = '"attribute" then doc := getRegistry(op,sig) +; RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode]) +; $value => return $value +; $value => $value +; condition? => nil +; htpSetProperty(htPage,expandProperty,'fullyExpanded) +; 'done + +(DEFUN |dbExpandOpAlistIfNecessary| + (|htPage| |opAlist| |which| |needOrigins?| |condition?|) + (declare (special |needOrigins?|)) + (PROG (|$value| |expandProperty| |expandFlag| |lines| |LETTMP#1| + |name| |nargs| |xflag| |sigs| |comments| |predicate| + |value| |conname| |exposeFlag| |acc| |s| |catname| + |packageSymbol| |domform| |docTable| |op| |alist| |tail| + |pred| |ISTMP#1| |sig| |u| |origin| |docCode| |doc|) + (DECLARE (SPECIAL |$value| |$docTableHash| |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |condition?| + (AND |condition?| (NULL |$exposedOnlyIfTrue|))) + (SPADLET |value| NIL) + (SPADLET |expandProperty| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + '|expandOperations|) + ('T '|expandAttributes|))) + (SPADLET |expandFlag| + (|htpProperty| |htPage| |expandProperty|)) + (COND + ((BOOT-EQUAL |expandFlag| '|fullyExpanded|) NIL) + ((BOOT-EQUAL |expandFlag| '|strings|) + (DO ((G172302 |opAlist| (CDR G172302)) + (|pair| NIL)) + ((OR (ATOM G172302) + (PROGN (SETQ |pair| (CAR G172302)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |op| (CAR |pair|)) + (SPADLET |lines| (CDR |pair|)) + (SPADLET |acc| NIL) + (DO ((G172311 |lines| (CDR G172311)) + (|line| NIL)) + ((OR (ATOM G172311) + (PROGN + (SETQ |line| (CAR G172311)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((NULL (STRINGP |line|)) + (COND + (|condition?| + (COND + ((NULL + (ATOM + (SPADLET |pred| + (CADR |line|)))) + (SPADLET |value| + |pred|)) + ('T NIL)))) + (SPADLET |acc| + (CONS |line| |acc|))) + ('T + (SPADLET |LETTMP#1| + (|dbParts| |line| 7 1)) + (SPADLET |name| + (CAR |LETTMP#1|)) + (SPADLET |nargs| + (CADR |LETTMP#1|)) + (SPADLET |xflag| + (CADDR |LETTMP#1|)) + (SPADLET |sigs| + (CADDDR |LETTMP#1|)) + (SPADLET |conname| + (CAR (CDDDDR |LETTMP#1|))) + (SPADLET |pred| + (CADR (CDDDDR |LETTMP#1|))) + (SPADLET |comments| + (CADDR (CDDDDR |LETTMP#1|))) + (SPADLET |predicate| + (|ncParseFromString| |pred|)) + (COND + ((AND |condition?| + (NULL (ATOM |predicate|))) + (SPADLET |value| + |predicate|))) + (SPADLET |sig| + (|ncParseFromString| |sigs|)) + (COND + ((BOOT-EQUAL |which| + (MAKESTRING "operation")) + (COND + ((NULL + (AND (PAIRP |sig|) + (EQ (QCAR |sig|) + '|Mapping|))) + (|sayBrightly| + (CONS + (MAKESTRING + "Unexpected signature for ") + (CONS |name| + (CONS + (MAKESTRING ": ") + (CONS |sigs| NIL)))))) + ('T + (SPADLET |sig| + (CDR |sig|)))))) + (SPADLET |conname| + (|intern| + (|dbNewConname| |line|))) + (SPADLET |origin| + (CONS |conname| + (|getConstructorArgs| + |conname|))) + (SPADLET |exposeFlag| + (|dbExposed?| |line| + (|char| '|o|))) + (SPADLET |acc| + (CONS + (CONS |sig| + (CONS |predicate| + (CONS |origin| + (CONS |exposeFlag| + (CONS |comments| NIL))))) + |acc|))))))) + (RPLACD |pair| (NREVERSE |acc|)) + (COND + ((AND |condition?| |value|) + (RETURN |value|))))))) + (COND + (|value| |value|) + (|condition?| NIL) + ('T + (|htpSetProperty| |htPage| |expandProperty| + '|fullyExpanded|)))) + ((BOOT-EQUAL |expandFlag| '|lists|) + (SPADLET |$value| NIL) + (SPADLET |$docTableHash| (MAKE-HASHTABLE 'EQUAL)) + (SPADLET |packageSymbol| NIL) + (SPADLET |domform| + (OR (|htpProperty| |htPage| '|domname|) + (|htpProperty| |htPage| '|conform|))) + (COND + ((|isDefaultPackageName| (|opOf| |domform|)) + (SPADLET |catname| + (|intern| + (SUBSTRING + (SPADLET |s| + (PNAME (|opOf| |domform|))) + 0 (MAXINDEX |s|)))) + (SPADLET |packageSymbol| (CAR (CDR |domform|))) + (SPADLET |domform| + (CONS |catname| (CDR (CDR |domform|)))))) + (SPADLET |docTable| (|dbDocTable| |domform|)) + (DO ((G172330 |opAlist| (CDR G172330)) + (G172287 NIL)) + ((OR (ATOM G172330) + (PROGN (SETQ G172287 (CAR G172330)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G172287)) + (SPADLET |alist| (CDR G172287)) + G172287) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (DO ((G172345 |alist| (CDR G172345)) + (G172282 NIL)) + ((OR (ATOM G172345) + (PROGN + (SETQ G172282 (CAR G172345)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR G172282)) + (SPADLET |tail| + (CDR G172282)) + G172282) + NIL)) + NIL) + (SEQ (EXIT + (COND + (|condition?| + (COND + ((NULL + (ATOM + (SPADLET |pred| + (CAR |tail|)))) + (RETURN + (SPADLET |$value| + |pred|))) + ('T '|skip|))) + ('T + (SPADLET |u| + (COND + ((AND (PAIRP |tail|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |tail|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |origin| + (QCAR |ISTMP#1|)) + 'T))) + |origin|) + (|dbGetDocTable| |op| + (SUBLISLIS (CONS '$ NIL) + (CONS '% NIL) |sig|) + (|dbDocTable| |origin|) + |which| NIL)) + ('T + (COND + (|packageSymbol| + (SPADLET |sig| + (MSUBST '$ + |packageSymbol| + |sig|)))) + (|dbGetDocTable| |op| + |sig| |docTable| |which| + NIL)))) + (SPADLET |origin| + (OR (IFCAR |u|) |origin|)) + (SPADLET |docCode| + (IFCDR |u|)) + (COND + ((AND (NULL |doc|) + (BOOT-EQUAL |which| + (MAKESTRING "attribute"))) + (SPADLET |doc| + (|getRegistry| |op| + |sig|)))) + (RPLACD |tail| + (CONS |origin| + (CONS + (|isExposedConstructor| + (|opOf| |origin|)) + |docCode|)))))))) + (COND (|$value| (RETURN |$value|))))))) + (COND + (|$value| |$value|) + (|condition?| NIL) + ('T + (|htpSetProperty| |htPage| |expandProperty| + '|fullyExpanded|)))) + ('T '|done|))))))) + +;getRegistry(op,sig) == +; u := GETDATABASE('AttributeRegistry,'DOCUMENTATION) +; v := LASSOC(op,u) +; match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match +; '"" + +(DEFUN |getRegistry| (|op| |sig|) + (PROG (|u| |v| |ISTMP#1| |match|) + (RETURN + (SEQ (PROGN + (SPADLET |u| + (GETDATABASE '|AttributeRegistry| 'DOCUMENTATION)) + (SPADLET |v| (LASSOC |op| |u|)) + (COND + ((SPADLET |match| + (PROG (G172408) + (SPADLET G172408 NIL) + (RETURN + (DO ((G172415 NIL G172408) + (G172416 |v| (CDR G172416)) + (|y| NIL)) + ((OR G172415 (ATOM G172416) + (PROGN + (SETQ |y| (CAR G172416)) + NIL)) + G172408) + (SEQ (EXIT + (COND + ((AND (PAIRP |y|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|attribute|) + (EQUAL (QCDR |ISTMP#1|) + |sig|)))) + (SETQ G172408 + (OR G172408 |y|)))))))))) + (CADR |match|)) + ('T (MAKESTRING "")))))))) + +;evalableConstructor2HtString domform == +; if VECP domform then domform := devaluate domform +; conname := first domform +; coSig := rest GETDATABASE(conname,'COSIG) +; --entries are T for args which are domains; NIL for computational objects +; and/[x for x in coSig] => form2HtString(domform,nil,true) +; arglist := [unquote x for x in rest domform] where +; unquote arg == +; arg is [f,:args] => +; f = 'QUOTE => first args +; [f,:[unquote x for x in args]] +; arg +; fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) +;--argtypes:= sublisFormal(arglist,fargtypes) +; form2HtString([conname,:[fn for arg in arglist for x in coSig +; for ftype in fargtypes]],nil,true) where +; fn == +; x => arg +; typ := sublisFormal(arglist,ftype) +; mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) + +(DEFUN |evalableConstructor2HtString,unquote| (|arg|) + (PROG (|f| |args|) + (RETURN + (SEQ (IF (AND (PAIRP |arg|) + (PROGN + (SPADLET |f| (QCAR |arg|)) + (SPADLET |args| (QCDR |arg|)) + 'T)) + (EXIT (SEQ (IF (BOOT-EQUAL |f| 'QUOTE) + (EXIT (CAR |args|))) + (EXIT (CONS |f| + (PROG (G172440) + (SPADLET G172440 NIL) + (RETURN + (DO + ((G172445 |args| + (CDR G172445)) + (|x| NIL)) + ((OR (ATOM G172445) + (PROGN + (SETQ |x| + (CAR G172445)) + NIL)) + (NREVERSE0 G172440)) + (SEQ + (EXIT + (SETQ G172440 + (CONS + (|evalableConstructor2HtString,unquote| + |x|) + G172440)))))))))))) + (EXIT |arg|))))) + +(DEFUN |evalableConstructor2HtString| (|domform|) + (PROG (|conname| |coSig| |arglist| |fargtypes| |typ|) + (RETURN + (SEQ (PROGN + (COND + ((VECP |domform|) + (SPADLET |domform| (|devaluate| |domform|)))) + (SPADLET |conname| (CAR |domform|)) + (SPADLET |coSig| (CDR (GETDATABASE |conname| 'COSIG))) + (COND + ((PROG (G172461) + (SPADLET G172461 'T) + (RETURN + (DO ((G172467 NIL (NULL G172461)) + (G172468 |coSig| (CDR G172468)) (|x| NIL)) + ((OR G172467 (ATOM G172468) + (PROGN (SETQ |x| (CAR G172468)) NIL)) + G172461) + (SEQ (EXIT (SETQ G172461 (AND G172461 |x|))))))) + (|form2HtString| |domform| NIL 'T)) + ('T + (SPADLET |arglist| + (PROG (G172479) + (SPADLET G172479 NIL) + (RETURN + (DO ((G172484 (CDR |domform|) + (CDR G172484)) + (|x| NIL)) + ((OR (ATOM G172484) + (PROGN + (SETQ |x| (CAR G172484)) + NIL)) + (NREVERSE0 G172479)) + (SEQ (EXIT + (SETQ G172479 + (CONS + (|evalableConstructor2HtString,unquote| + |x|) + G172479)))))))) + (SPADLET |fargtypes| + (CDDAR (GETDATABASE |conname| + 'CONSTRUCTORMODEMAP))) + (|form2HtString| + (CONS |conname| + (PROG (G172496) + (SPADLET G172496 NIL) + (RETURN + (DO ((G172503 |arglist| + (CDR G172503)) + (|arg| NIL) + (G172504 |coSig| (CDR G172504)) + (|x| NIL) + (G172505 |fargtypes| + (CDR G172505)) + (|ftype| NIL)) + ((OR (ATOM G172503) + (PROGN + (SETQ |arg| (CAR G172503)) + NIL) + (ATOM G172504) + (PROGN + (SETQ |x| (CAR G172504)) + NIL) + (ATOM G172505) + (PROGN + (SETQ |ftype| (CAR G172505)) + NIL)) + (NREVERSE0 G172496)) + (SEQ (EXIT + (SETQ G172496 + (CONS + (COND + (|x| |arg|) + ('T + (SPADLET |typ| + (|sublisFormal| |arglist| + |ftype|)) + (|mathform2HtString| + (|algCoerceInteractive| + |arg| |typ| + '(|OutputForm|))))) + G172496)))))))) + NIL 'T)))))))) + +;mathform2HtString form == escapeString +; $fortInts2Floats: local := false +; form := niladicHack form +; form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a) +; form is ['BRACKET,['AGGLST,:arg]] => +; if arg is ['construct,:r] then arg := r +; arg := +; atom arg => [arg] +; [y for x in arg | y := (x is ['QUOTE,a] => a; x)] +; tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg] +; STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]") +; form is ['BRACKET,['AGGLST,'QUOTE,arg]] => +; if atom arg then arg := [arg] +; tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] +; STRCONC('"[",first arg,tailPart,'"]") +; atom form => form +; "STRCONC"/fortexp0 form + +(DEFUN |mathform2HtString| (|form|) + (PROG (|$fortInts2Floats| |r| |a| |y| |ISTMP#1| |ISTMP#2| |ISTMP#3| + |ISTMP#4| |arg| |tailPart|) + (DECLARE (SPECIAL |$fortInts2Floats|)) + (RETURN + (SEQ (|escapeString| + (PROGN + (SPADLET |$fortInts2Floats| NIL) + (SPADLET |form| (|niladicHack| |form|)) + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + 'T)))) + (STRCONC (MAKESTRING "'") + (PROG (G172582) + (SPADLET G172582 "") + (RETURN + (DO ((G172587 (|fortexp0| |a|) + (CDR G172587)) + (G172529 NIL)) + ((OR (ATOM G172587) + (PROGN + (SETQ G172529 + (CAR G172587)) + NIL)) + G172582) + (SEQ + (EXIT + (SETQ G172582 + (STRCONC G172582 G172529))))))))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) 'BRACKET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'AGGLST) + (PROGN + (SPADLET |arg| + (QCDR |ISTMP#2|)) + 'T)))))) + (COND + ((AND (PAIRP |arg|) + (EQ (QCAR |arg|) '|construct|) + (PROGN (SPADLET |r| (QCDR |arg|)) 'T)) + (SPADLET |arg| |r|))) + (SPADLET |arg| + (COND + ((ATOM |arg|) (CONS |arg| NIL)) + ('T + (PROG (G172598) + (SPADLET G172598 NIL) + (RETURN + (DO + ((G172604 |arg| (CDR G172604)) + (|x| NIL)) + ((OR (ATOM G172604) + (PROGN + (SETQ |x| (CAR G172604)) + NIL)) + (NREVERSE0 G172598)) + (SEQ + (EXIT + (COND + ((SPADLET |y| + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + 'T)))) + |a|) + ('T |x|))) + (SETQ G172598 + (CONS |y| G172598)))))))))))) + (SPADLET |tailPart| + (PROG (G172610) + (SPADLET G172610 "") + (RETURN + (DO ((G172615 (CDR |arg|) + (CDR G172615)) + (|x| NIL)) + ((OR (ATOM G172615) + (PROGN + (SETQ |x| (CAR G172615)) + NIL)) + G172610) + (SEQ + (EXIT + (SETQ G172610 + (STRCONC G172610 + (STRCONC (MAKESTRING ",") + (STRINGIMAGE |x|)))))))))) + (STRCONC (MAKESTRING "[") (STRINGIMAGE (CAR |arg|)) + |tailPart| (MAKESTRING "]"))) + ((AND (PAIRP |form|) (EQ (QCAR |form|) 'BRACKET) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) 'AGGLST) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |arg| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (COND + ((ATOM |arg|) (SPADLET |arg| (CONS |arg| NIL)))) + (SPADLET |tailPart| + (PROG (G172621) + (SPADLET G172621 "") + (RETURN + (DO ((G172626 (CDR |arg|) + (CDR G172626)) + (|x| NIL)) + ((OR (ATOM G172626) + (PROGN + (SETQ |x| (CAR G172626)) + NIL)) + G172621) + (SEQ + (EXIT + (SETQ G172621 + (STRCONC G172621 + (STRCONC (MAKESTRING ",") |x|))))))))) + (STRCONC (MAKESTRING "[") (CAR |arg|) |tailPart| + (MAKESTRING "]"))) + ((ATOM |form|) |form|) + ('T + (PROG (G172632) + (SPADLET G172632 "") + (RETURN + (DO ((G172637 (|fortexp0| |form|) + (CDR G172637)) + (G172530 NIL)) + ((OR (ATOM G172637) + (PROGN + (SETQ G172530 (CAR G172637)) + NIL)) + G172632) + (SEQ (EXIT (SETQ G172632 + (STRCONC G172632 G172530))))))))))))))) + +;niladicHack form == +; atom form => form +; form is [x] and GET(x,'NILADIC) => x +; [niladicHack x for x in form] + +(DEFUN |niladicHack| (|form|) + (PROG (|x|) + (RETURN + (SEQ (COND + ((ATOM |form|) |form|) + ((AND (PAIRP |form|) (EQ (QCDR |form|) NIL) + (PROGN (SPADLET |x| (QCAR |form|)) 'T) + (GETL |x| 'NILADIC)) + |x|) + ('T + (PROG (G172679) + (SPADLET G172679 NIL) + (RETURN + (DO ((G172684 |form| (CDR G172684)) (|x| NIL)) + ((OR (ATOM G172684) + (PROGN (SETQ |x| (CAR G172684)) NIL)) + (NREVERSE0 G172679)) + (SEQ (EXIT (SETQ G172679 + (CONS (|niladicHack| |x|) + G172679))))))))))))) + +;--============================================================================ +;-- Getting Operations from Domain +;--============================================================================ +;getDomainOpTable(dom,fromIfTrue,:options) == +; ops := KAR options +; $predEvalAlist : local := nil +; $returnNowhereFromGoGet: local := true +; domname := dom.0 +; conname := CAR domname +; abb := getConstructorAbbreviation conname +; opAlist := getOperationAlistFromLisplib conname +; "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u +; | key ^= 'Subsumed and ((null ops and (op1 := op)) _ +; or (op1 := memq(op,ops)))] +; for [op,:u] in opAlist] where +; memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One +; MEMQ(op,ops) => op +; EQ(op,'One) => MEMQ(1,ops) and 1 +; EQ(op,'Zero) => MEMQ(0,ops) and 0 +; false +; fn == +; sig1 := sublisFormal(rest domname,sig) +; predValue := evalDomainOpPred(dom,pred) +; info := +; null predValue => +; 1 -- signifies not exported +; null fromIfTrue => nil +; cell := compiledLookup(op,sig1,dom) => +; [f,:r] := cell +; f = 'nowhere => 'nowhere --see replaceGoGetSlot +; f = 'makeSpadConstant => 'constant +; f = function IDENTITY => 'constant +; f = 'newGoGet => SUBST('_$,domname,devaluate CAR r) +; null VECP r => systemError devaluateList r +; SUBST('_$,domname,devaluate r) +; 'nowhere +; [sig1,:info] + +(DEFUN |getDomainOpTable,memq| (|op| |ops|) + (SEQ (IF (MEMQ |op| |ops|) (EXIT |op|)) + (IF (EQ |op| '|One|) (EXIT (AND (MEMQ 1 |ops|) 1))) + (IF (EQ |op| '|Zero|) (EXIT (AND (MEMQ 0 |ops|) 0))) (EXIT NIL))) + +(DEFUN |getDomainOpTable| + (&REST G172808 &AUX |options| |fromIfTrue| |dom|) + (DSETQ (|dom| |fromIfTrue| . |options|) G172808) + (PROG (|$predEvalAlist| |$returnNowhereFromGoGet| |ops| |domname| + |conname| |abb| |opAlist| |op| |u| |sig| |slot| |pred| + |key| |op1| |sig1| |predValue| |cell| |f| |r| |info|) + (DECLARE (SPECIAL |$predEvalAlist| |$returnNowhereFromGoGet|)) + (RETURN + (SEQ (PROGN + (SPADLET |ops| (KAR |options|)) + (SPADLET |$predEvalAlist| NIL) + (SPADLET |$returnNowhereFromGoGet| 'T) + (SPADLET |domname| (ELT |dom| 0)) + (SPADLET |conname| (CAR |domname|)) + (SPADLET |abb| (|getConstructorAbbreviation| |conname|)) + (SPADLET |opAlist| + (|getOperationAlistFromLisplib| |conname|)) + (PROG (G172728) + (SPADLET G172728 NIL) + (RETURN + (DO ((G172743 |opAlist| (CDR G172743)) + (G172711 NIL)) + ((OR (ATOM G172743) + (PROGN (SETQ G172711 (CAR G172743)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G172711)) + (SPADLET |u| (CDR G172711)) + G172711) + NIL)) + G172728) + (SEQ (EXIT (SETQ G172728 + (APPEND G172728 + (REMDUP + (PROG (G172760) + (SPADLET G172760 NIL) + (RETURN + (DO + ((G172771 |u| + (CDR G172771)) + (G172705 NIL)) + ((OR (ATOM G172771) + (PROGN + (SETQ G172705 + (CAR G172771)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR G172705)) + (SPADLET |slot| + (CADR G172705)) + (SPADLET |pred| + (CADDR G172705)) + (SPADLET |key| + (CADDDR G172705)) + G172705) + NIL)) + (NREVERSE0 G172760)) + (SEQ + (EXIT + (COND + ((AND + (NEQUAL |key| + '|Subsumed|) + (OR + (AND (NULL |ops|) + (SPADLET |op1| + |op|)) + (SPADLET |op1| + (|getDomainOpTable,memq| + |op| |ops|)))) + (SETQ G172760 + (CONS + (CONS |op1| + (PROGN + (SPADLET |sig1| + (|sublisFormal| + (CDR |domname|) + |sig|)) + (SPADLET + |predValue| + (|evalDomainOpPred| + |dom| |pred|)) + (SPADLET |info| + (COND + ((NULL + |predValue|) + 1) + ((NULL + |fromIfTrue|) + NIL) + ((SPADLET + |cell| + (|compiledLookup| + |op| |sig1| + |dom|)) + (SPADLET |f| + (CAR |cell|)) + (SPADLET |r| + (CDR |cell|)) + (COND + ((BOOT-EQUAL + |f| + '|nowhere|) + '|nowhere|) + ((BOOT-EQUAL + |f| + '|makeSpadConstant|) + '|constant|) + ((BOOT-EQUAL + |f| + (|function| + IDENTITY)) + '|constant|) + ((BOOT-EQUAL + |f| + '|newGoGet|) + (MSUBST '$ + |domname| + (|devaluate| + (CAR + |r|)))) + ((NULL + (VECP + |r|)) + (|systemError| + (|devaluateList| + |r|))) + ('T + (MSUBST '$ + |domname| + (|devaluate| + |r|))))) + ('T + '|nowhere|))) + (CONS |sig1| + |info|))) + G172760)))))))))))))))))))))) + +;evalDomainOpPred(dom,pred) == process(dom,pred) where +; process(dom,pred) == +; u := convert(dom,pred) +; u = 'T => true +; evpred(dom,u) +; convert(dom,pred) == +; pred is [op,:argl] => +; MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]] +; MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]] +; MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)] +; op = 'has => +; [arg,p] := argl +; p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a] +; ['HasCategory,arg,convertCatArg p] +; systemError '"unknown predicate form" +; pred = 'T => true +; systemError nil +; convertCatArg p == +; atom p or #p = 1 => MKQ p +; ['LIST,MKQ first p,:[convertCatArg x for x in rest p]] +; evpred(dom,pred) == +; k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) +; evpred1(dom,pred) +; evpred1(dom,pred) == +; pred is [op,:argl] => +; MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl] +; MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl] +; op = 'NOT => not evpred1(dom,first argl) +; k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) +; op = 'HasAttribute => +; [arg,[.,a]] := argl +; attPredIndex := LASSOC(a,dom.2) +; null attPredIndex => nil +; attPredIndex = 0 => true +; testBitVector(dom.3,attPredIndex) +; nil +; pred = 'T => true +; systemError '"unknown atomic predicate form" + +(DEFUN |evalDomainOpPred,evpred1| (|dom| |pred|) + (PROG (|op| |argl| |k| |arg| |a| |attPredIndex|) + (declare (special |$predicateList|)) + (RETURN + (SEQ (IF (AND (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |argl| (QCDR |pred|)) + 'T)) + (EXIT (SEQ (IF (MEMQ |op| '(AND |and|)) + (EXIT (PROG (G172834) + (SPADLET G172834 'T) + (RETURN + (DO + ((G172840 NIL + (NULL G172834)) + (G172841 |argl| + (CDR G172841)) + (|x| NIL)) + ((OR G172840 + (ATOM G172841) + (PROGN + (SETQ |x| (CAR G172841)) + NIL)) + G172834) + (SEQ + (EXIT + (SETQ G172834 + (AND G172834 + (|evalDomainOpPred,evpred1| + |dom| |x|)))))))))) + (IF (MEMQ |op| '(OR |or|)) + (EXIT (PROG (G172848) + (SPADLET G172848 NIL) + (RETURN + (DO + ((G172854 NIL G172848) + (G172855 |argl| + (CDR G172855)) + (|x| NIL)) + ((OR G172854 + (ATOM G172855) + (PROGN + (SETQ |x| (CAR G172855)) + NIL)) + G172848) + (SEQ + (EXIT + (SETQ G172848 + (OR G172848 + (|evalDomainOpPred,evpred1| + |dom| |x|)))))))))) + (IF (BOOT-EQUAL |op| 'NOT) + (EXIT (NULL + (|evalDomainOpPred,evpred1| |dom| + (CAR |argl|))))) + (IF (SPADLET |k| + (POSN1 |pred| |$predicateList|)) + (EXIT (|testBitVector| (ELT |dom| 3) + (PLUS |k| 1)))) + (IF (BOOT-EQUAL |op| '|HasAttribute|) + (EXIT (SEQ + (PROGN + (SPADLET |arg| (CAR |argl|)) + (SPADLET |a| (CADADR |argl|)) + |argl|) + (SPADLET |attPredIndex| + (LASSOC |a| (ELT |dom| 2))) + (IF (NULL |attPredIndex|) + (EXIT NIL)) + (IF (EQL |attPredIndex| 0) + (EXIT 'T)) + (EXIT + (|testBitVector| (ELT |dom| 3) + |attPredIndex|))))) + (EXIT NIL)))) + (IF (BOOT-EQUAL |pred| 'T) (EXIT 'T)) + (EXIT (|systemError| + (MAKESTRING "unknown atomic predicate form"))))))) + +(DEFUN |evalDomainOpPred,evpred| (|dom| |pred|) + (PROG (|k|) + (declare (special |$predicateList|)) + (RETURN + (SEQ (IF (SPADLET |k| (POSN1 |pred| |$predicateList|)) + (EXIT (|testBitVector| (ELT |dom| 3) (PLUS |k| 1)))) + (EXIT (|evalDomainOpPred,evpred1| |dom| |pred|)))))) + +(DEFUN |evalDomainOpPred,convertCatArg| (|p|) + (PROG () + (RETURN + (SEQ (IF (OR (ATOM |p|) (EQL (|#| |p|) 1)) (EXIT (MKQ |p|))) + (EXIT (CONS 'LIST + (CONS (MKQ (CAR |p|)) + (PROG (G172881) + (SPADLET G172881 NIL) + (RETURN + (DO ((G172886 (CDR |p|) + (CDR G172886)) + (|x| NIL)) + ((OR (ATOM G172886) + (PROGN + (SETQ |x| (CAR G172886)) + NIL)) + (NREVERSE0 G172881)) + (SEQ + (EXIT + (SETQ G172881 + (CONS + (|evalDomainOpPred,convertCatArg| + |x|) + G172881)))))))))))))) + +(DEFUN |evalDomainOpPred,convert| (|dom| |pred|) + (PROG (|op| |argl| |arg| |p| |ISTMP#1| |a|) + (RETURN + (SEQ (IF (AND (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |argl| (QCDR |pred|)) + 'T)) + (EXIT (SEQ (IF (MEMQ |op| '(AND |and|)) + (EXIT (CONS 'AND + (PROG (G172900) + (SPADLET G172900 NIL) + (RETURN + (DO + ((G172905 |argl| + (CDR G172905)) + (|x| NIL)) + ((OR (ATOM G172905) + (PROGN + (SETQ |x| + (CAR G172905)) + NIL)) + (NREVERSE0 G172900)) + (SEQ + (EXIT + (SETQ G172900 + (CONS + (|evalDomainOpPred,convert| + |dom| |x|) + G172900)))))))))) + (IF (MEMQ |op| '(OR |or|)) + (EXIT (CONS 'OR + (PROG (G172915) + (SPADLET G172915 NIL) + (RETURN + (DO + ((G172920 |argl| + (CDR G172920)) + (|x| NIL)) + ((OR (ATOM G172920) + (PROGN + (SETQ |x| + (CAR G172920)) + NIL)) + (NREVERSE0 G172915)) + (SEQ + (EXIT + (SETQ G172915 + (CONS + (|evalDomainOpPred,convert| + |dom| |x|) + G172915)))))))))) + (IF (MEMQ |op| '(NOT |not|)) + (EXIT (CONS 'NOT + (CONS + (|evalDomainOpPred,convert| |dom| + (CAR |argl|)) + NIL)))) + (IF (BOOT-EQUAL |op| '|has|) + (EXIT (SEQ + (PROGN + (SPADLET |arg| (CAR |argl|)) + (SPADLET |p| (CADR |argl|)) + |argl|) + (IF + (AND (PAIRP |p|) + (EQ (QCAR |p|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + 'T)))) + (EXIT + (CONS '|HasAttribute| + (CONS |arg| + (CONS (MKQ |a|) NIL))))) + (EXIT + (CONS '|HasCategory| + (CONS |arg| + (CONS + (|evalDomainOpPred,convertCatArg| + |p|) + NIL))))))) + (EXIT (|systemError| + (MAKESTRING + "unknown predicate form")))))) + (IF (BOOT-EQUAL |pred| 'T) (EXIT 'T)) + (EXIT (|systemError| NIL)))))) + +(DEFUN |evalDomainOpPred,process| (|dom| |pred|) + (PROG (|u|) + (RETURN + (SEQ (SPADLET |u| (|evalDomainOpPred,convert| |dom| |pred|)) + (IF (BOOT-EQUAL |u| 'T) (EXIT 'T)) + (EXIT (|evalDomainOpPred,evpred| |dom| |u|)))))) + +(DEFUN |evalDomainOpPred| (|dom| |pred|) + (|evalDomainOpPred,process| |dom| |pred|)) + +;--====================> WAS br-op2.boot <================================ +;--======================================================================= +;-- Operation Description +;--======================================================================= +;htSayConstructor(key,u) == +; u is ['CATEGORY,kind,:r] => +; htSay('"a ",kind,'" ") +; htSayExplicitExports(r) +; key = 'is => +; htSay '"the domain " +; bcConform(u,true) +; htSay +; key = 'is => '"the domain " +; kind := GETDATABASE(opOf u,'CONSTRUCTORKIND) +; kind = 'domain => '"an element of " +; '"a domain of " +; u is ['Join,:middle,r] => +; rest middle => +; htSay '"categories " +; bcConform(first middle,true) +; for x in rest middle repeat +; htSay '", " +; bcConform(x,true) +; r is ['CATEGORY,.,:r] => +; htSay '" and " +; htSayExplicitExports(r) +; htSay '" and " +; bcConform(r,true) +; htSay '"category " +; bcConform(first middle,true) +; r is ['CATEGORY,.,:r] => +; htSay '" " +; htSayExplicitExports(r) +; htSay '" and " +; bcConform(r,true) +; htSay(kind,'" ") +; bcConform(u,true) + +(DEFUN |htSayConstructor| (|key| |u|) + (PROG (|kind| |ISTMP#2| |middle| |ISTMP#1| |r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |kind| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (|htSay| (MAKESTRING "a ") |kind| (MAKESTRING " ")) + (|htSayExplicitExports| |r|)) + ((BOOT-EQUAL |key| '|is|) + (|htSay| (MAKESTRING "the domain ")) + (|bcConform| |u| 'T)) + ('T + (|htSay| (COND + ((BOOT-EQUAL |key| '|is|) + (MAKESTRING "the domain ")) + ('T + (SPADLET |kind| + (GETDATABASE (|opOf| |u|) + 'CONSTRUCTORKIND)) + (COND + ((BOOT-EQUAL |kind| '|domain|) + (MAKESTRING "an element of ")) + ('T (MAKESTRING "a domain of ")))))) + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |r| (QCAR |ISTMP#2|)) + (SPADLET |middle| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |middle| (NREVERSE |middle|)) + 'T)))) + (COND + ((CDR |middle|) (|htSay| (MAKESTRING "categories ")) + (|bcConform| (CAR |middle|) 'T) + (DO ((G172987 (CDR |middle|) (CDR G172987)) + (|x| NIL)) + ((OR (ATOM G172987) + (PROGN (SETQ |x| (CAR G172987)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING ", ")) + (|bcConform| |x| 'T))))) + (COND + ((AND (PAIRP |r|) (EQ (QCAR |r|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (|htSay| (MAKESTRING " and ")) + (|htSayExplicitExports| |r|)) + ('T (|htSay| (MAKESTRING " and ")) + (|bcConform| |r| 'T)))) + ('T (|htSay| (MAKESTRING "category ")) + (|bcConform| (CAR |middle|) 'T) + (COND + ((AND (PAIRP |r|) (EQ (QCAR |r|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (|htSay| (MAKESTRING " ")) + (|htSayExplicitExports| |r|)) + ('T (|htSay| (MAKESTRING " and ")) + (|bcConform| |r| 'T)))))) + ('T (|htSay| |kind| (MAKESTRING " ")) + (|bcConform| |u| 'T))))))))) + +;htSayExplicitExports r == +; htSay '"with explicit exports" +; $displayReturnValue => nil +; htSay '":" +; for x in r repeat +; htSay '"\newline " +; x is ['SIGNATURE,op,sig] => +; ops := escapeSpecialChars STRINGIMAGE op +; htMakePage [['bcLinks,[ops,'"",'oPage,ops]]] +; htSay '": " +; bcConform ['Mapping,:sig] +; x is ['ATTRIBUTE,a] => +; s := form2HtString a +; htMakePage [['bcLinks,[ops,'"",'aPage,s]]] +; x is ['IF,:.] => +; htSay('"{\em if ...}") +; systemError() + +(DEFUN |htSayExplicitExports| (|r|) + (PROG (|op| |ISTMP#2| |sig| |ops| |ISTMP#1| |a| |s|) + (declare (special |$displayReturnValue|)) + (RETURN + (SEQ (PROGN + (|htSay| (MAKESTRING "with explicit exports")) + (COND + (|$displayReturnValue| NIL) + ('T (|htSay| (MAKESTRING ":")) + (DO ((G173049 |r| (CDR G173049)) (|x| NIL)) + ((OR (ATOM G173049) + (PROGN (SETQ |x| (CAR G173049)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING "\\newline ")) + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |sig| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE |op|))) + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |ops| + (CONS (MAKESTRING "") + (CONS '|oPage| + (CONS |ops| NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING ": ")) + (|bcConform| (CONS '|Mapping| |sig|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |s| (|form2HtString| |a|)) + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |ops| + (CONS (MAKESTRING "") + (CONS '|aPage| + (CONS |s| NIL)))) + NIL)) + NIL))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF)) + (|htSay| (MAKESTRING "{\\em if ...}"))) + ('T (|systemError|)))))))))))))) + +;displayBreakIntoAnds pred == +; pred is [op,:u] and MEMBER(op,'(and AND)) => u +; [pred] + +(DEFUN |displayBreakIntoAnds| (|pred|) + (PROG (|op| |u|) + (RETURN + (COND + ((AND (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |u| (QCDR |pred|)) + 'T) + (|member| |op| '(|and| AND))) + |u|) + ('T (CONS |pred| NIL)))))) + +;htSayValue t == +; t is ['Mapping,target,:source] => +; htSay('"a function from ") +; htSayTuple source +; htSay '" to " +; htSayArgument target +; t = '(Category) => htSay('"a category") +; t is [op,:.] and MEMQ(op,'(Join CATEGORY)) or constructor? opOf t => +; htSayConstructor(nil,t) +; htSay('"an element of domain ") +; htSayArgument t --continue for operations + +(DEFUN |htSayValue| (|t|) + (PROG (|ISTMP#1| |target| |source| |op|) + (RETURN + (COND + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#1|)) + (SPADLET |source| (QCDR |ISTMP#1|)) + 'T)))) + (|htSay| (MAKESTRING "a function from ")) + (|htSayTuple| |source|) (|htSay| (MAKESTRING " to ")) + (|htSayArgument| |target|)) + ((BOOT-EQUAL |t| '(|Category|)) + (|htSay| (MAKESTRING "a category"))) + ((OR (AND (PAIRP |t|) (PROGN (SPADLET |op| (QCAR |t|)) 'T) + (MEMQ |op| '(|Join| CATEGORY))) + (|constructor?| (|opOf| |t|))) + (|htSayConstructor| NIL |t|)) + ('T (|htSay| (MAKESTRING "an element of domain ")) + (|htSayArgument| |t|)))))) + +;htSayArgument t == --called only for operations not for constructors +; null $signature => htSay ['"{\em ",t,'"}"] +; MEMQ(t, '(_$ _%)) => +; $conkind = '"category" and $conlength > 20 => +; $generalSearch? => htSay '"{\em D} of the origin category" +; addWhereList("$",'is,nil) +; htSayStandard '"{\em $}" +; htSaySaturn '"{\em \%}" +; htSayStandard '"{\em $}" +; htSaySaturn '"{\em \%}" +; not IDENTP t => bcConform(t,true) +; k := position(t,$conargs) +; if k > -1 then +; typeOfArg := (rest $signature).k +; addWhereList(t,'member,typeOfArg) +; htSay('"{\em ",t,'"}") + +(DEFUN |htSayArgument| (|t|) + (PROG (|k| |typeOfArg|) + (declare + (special |$signature| |$conkind| |$conlength| |$generalSearch?| |$conargs|)) + (RETURN + (COND + ((NULL |$signature|) + (|htSay| (CONS (MAKESTRING "{\\em ") + (CONS |t| (CONS (MAKESTRING "}") NIL))))) + ((MEMQ |t| '($ %)) + (COND + ((AND (BOOT-EQUAL |$conkind| (MAKESTRING "category")) + (> |$conlength| 20)) + (COND + (|$generalSearch?| + (|htSay| (MAKESTRING + "{\\em D} of the origin category"))) + ('T (|addWhereList| '$ '|is| NIL) + (|htSayStandard| (MAKESTRING "{\\em $}")) + (|htSaySaturn| (MAKESTRING "{\\em \\%}"))))) + ('T (|htSayStandard| (MAKESTRING "{\\em $}")) + (|htSaySaturn| (MAKESTRING "{\\em \\%}"))))) + ((NULL (IDENTP |t|)) (|bcConform| |t| 'T)) + ('T (SPADLET |k| (|position| |t| |$conargs|)) + (COND + ((> |k| (SPADDIFFERENCE 1)) + (SPADLET |typeOfArg| (ELT (CDR |$signature|) |k|)) + (|addWhereList| |t| '|member| |typeOfArg|))) + (|htSay| (MAKESTRING "{\\em ") |t| (MAKESTRING "}"))))))) + +;addWhereList(id,kind,typ) == +; $whereList := insert([id,kind,:typ],$whereList) + +(DEFUN |addWhereList| (|id| |kind| |typ|) + (SPADLET |$whereList| + (|insert| (CONS |id| (CONS |kind| |typ|)) |$whereList|))) + +;htSayTuple t == +; null t => htSay '"()" +; null rest t => htSayArgument first t +; htSay '"(" +; htSayArgument first t +; for d in rest t repeat +; htSay '"," +; htSayArgument d +; htSay '")" + +(DEFUN |htSayTuple| (|t|) + (SEQ (COND + ((NULL |t|) (|htSay| (MAKESTRING "()"))) + ((NULL (CDR |t|)) (|htSayArgument| (CAR |t|))) + ('T (|htSay| (MAKESTRING "(")) (|htSayArgument| (CAR |t|)) + (DO ((G173112 (CDR |t|) (CDR G173112)) (|d| NIL)) + ((OR (ATOM G173112) + (PROGN (SETQ |d| (CAR G173112)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING ",")) + (|htSayArgument| |d|))))) + (|htSay| (MAKESTRING ")")))))) + +;dbGetDisplayFormForOp(op,sig,doc) == +; dbGetFormFromDocumentation(op,sig,doc) or dbGetContrivedForm(op,sig) + +(DEFUN |dbGetDisplayFormForOp| (|op| |sig| |doc|) + (OR (|dbGetFormFromDocumentation| |op| |sig| |doc|) + (|dbGetContrivedForm| |op| |sig|))) + +;dbGetFormFromDocumentation(op,sig,x) == +; doc := (STRINGP x => x; first x) +; STRINGP doc and +; (stringPrefix?('"\spad{",doc) and (k := 6) or +; stringPrefix?('"\s{",doc) and (k := 3)) => +; n := charPosition($charRbrace,doc,k) +; s := SUBSTRING(doc,k,n - k) +; parse := ncParseFromString s +; parse is [=op,:.] and #parse = #sig => parse +; nil + +(DEFUN |dbGetFormFromDocumentation| (|op| |sig| |x|) + (PROG (|doc| |k| |n| |s| |parse|) + (declare (special |$charRbrace|)) + (RETURN + (PROGN + (SPADLET |doc| (COND ((STRINGP |x|) |x|) ('T (CAR |x|)))) + (COND + ((AND (STRINGP |doc|) + (OR (AND (|stringPrefix?| (MAKESTRING "\\spad{") |doc|) + (SPADLET |k| 6)) + (AND (|stringPrefix?| (MAKESTRING "\\s{") |doc|) + (SPADLET |k| 3)))) + (SPADLET |n| (|charPosition| |$charRbrace| |doc| |k|)) + (SPADLET |s| (SUBSTRING |doc| |k| (SPADDIFFERENCE |n| |k|))) + (SPADLET |parse| (|ncParseFromString| |s|)) + (COND + ((AND (PAIRP |parse|) (EQUAL (QCAR |parse|) |op|) + (BOOT-EQUAL (|#| |parse|) (|#| |sig|))) + |parse|))) + ('T NIL)))))) + +;dbMakeContrivedForm(op,sig,:options) == +; $chooseDownCaseOfType : local := IFCAR options +; $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 _ +; i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) +; $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 _ +; x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) +; $FunctionList:local := '(f g h d e F G H) +; $DomainList: local := '(R S D E T A B C M N P Q U V W) +; dbGetContrivedForm(op,sig) + +(DEFUN |dbMakeContrivedForm| + (&REST G173155 &AUX |options| |sig| |op|) + (DSETQ (|op| |sig| . |options|) G173155) + (PROG (|$chooseDownCaseOfType| |$NumberList| |$ElementList| + |$FunctionList| |$DomainList|) + (DECLARE (SPECIAL |$chooseDownCaseOfType| |$NumberList| + |$ElementList| |$FunctionList| |$DomainList|)) + (RETURN + (PROGN + (SPADLET |$chooseDownCaseOfType| (IFCAR |options|)) + (SPADLET |$NumberList| + '(|i| |j| |k| |l| |m| |n| |i1| |j1| |k1| |l1| |m1| + |n1| |i2| |j2| |k2| |l2| |m2| |n2| |i3| |j3| + |k3| |l3| |m3| |n3| |i4| |j4| |k4| |l4| |m4| + |n4|)) + (SPADLET |$ElementList| + '(|x| |y| |z| |u| |v| |w| |x1| |y1| |z1| |u1| |v1| + |w1| |x2| |y2| |z2| |u2| |v2| |w2| |x3| |y3| + |z3| |u3| |v3| |w3| |x4| |y4| |z4| |u4| |v4| + |w4|)) + (SPADLET |$FunctionList| '(|f| |g| |h| |d| |e| F G H)) + (SPADLET |$DomainList| '(R S D E T A B C M N P Q U V W)) + (|dbGetContrivedForm| |op| |sig|))))) + +;dbGetContrivedForm(op,sig) == +; op = '"0" => [0] +; op = '"1" => [1] +; [op,:[dbChooseOperandName s for s in rest sig]] + +(DEFUN |dbGetContrivedForm| (|op| |sig|) + (PROG () + (RETURN + (SEQ (COND + ((BOOT-EQUAL |op| (MAKESTRING "0")) (CONS 0 NIL)) + ((BOOT-EQUAL |op| (MAKESTRING "1")) (CONS 1 NIL)) + ('T + (CONS |op| + (PROG (G173161) + (SPADLET G173161 NIL) + (RETURN + (DO ((G173166 (CDR |sig|) (CDR G173166)) + (|s| NIL)) + ((OR (ATOM G173166) + (PROGN + (SETQ |s| (CAR G173166)) + NIL)) + (NREVERSE0 G173161)) + (SEQ (EXIT (SETQ G173161 + (CONS (|dbChooseOperandName| |s|) + G173161)))))))))))))) + +;dbChooseOperandName(typ) == +; typ is ['Mapping,:.] => +; x := first $FunctionList +; $FunctionList := rest $FunctionList +; x +; name := opOf typ +; kind := +; name = "$" => 'domain +; GETDATABASE(name,'CONSTRUCTORKIND) +; s := PNAME opOf typ +; kind ^= 'category => +; anySubstring?('"Integer",s,0) or anySubstring?('"Number",s,0) => +; x := first $NumberList +; $NumberList := rest $NumberList +; x +; x := +; $chooseDownCaseOfType => +; y := DOWNCASE typ +; x := +; MEMBER(y,$ElementList) => y +; first $ElementList +; first $ElementList +; $ElementList := DELETE(x,$ElementList) +; x +; x := first $DomainList +; $DomainList := rest $DomainList +; x + +(DEFUN |dbChooseOperandName| (|typ|) + (PROG (|name| |kind| |s| |y| |x|) + (declare (special |$FunctionList| |$NumberList| |$chooseDownCaseOfType| + |$ElementList| |$DomainList|)) + (RETURN + (COND + ((AND (PAIRP |typ|) (EQ (QCAR |typ|) '|Mapping|)) + (SPADLET |x| (CAR |$FunctionList|)) + (SPADLET |$FunctionList| (CDR |$FunctionList|)) |x|) + ('T (SPADLET |name| (|opOf| |typ|)) + (SPADLET |kind| + (COND + ((BOOT-EQUAL |name| '$) '|domain|) + ('T (GETDATABASE |name| 'CONSTRUCTORKIND)))) + (SPADLET |s| (PNAME (|opOf| |typ|))) + (COND + ((NEQUAL |kind| '|category|) + (COND + ((OR (|anySubstring?| (MAKESTRING "Integer") |s| 0) + (|anySubstring?| (MAKESTRING "Number") |s| 0)) + (SPADLET |x| (CAR |$NumberList|)) + (SPADLET |$NumberList| (CDR |$NumberList|)) |x|) + ('T + (SPADLET |x| + (COND + (|$chooseDownCaseOfType| + (SPADLET |y| (DOWNCASE |typ|)) + (SPADLET |x| + (COND + ((|member| |y| |$ElementList|) + |y|) + ('T (CAR |$ElementList|))))) + ('T (CAR |$ElementList|)))) + (SPADLET |$ElementList| (|delete| |x| |$ElementList|)) + |x|))) + ('T (SPADLET |x| (CAR |$DomainList|)) + (SPADLET |$DomainList| (CDR |$DomainList|)) |x|))))))) + +;getSubstSigIfPossible sig == +; getSubstSignature sig or sig + +(DEFUN |getSubstSigIfPossible| (|sig|) + (OR (|getSubstSignature| |sig|) |sig|)) + +;-- +;-- while (u := getSubstSignature sig) repeat +;-- sig := u +;-- sig +;fullSubstitute(x,y,z) == --substitutes deeply: x for y in list z +; z = y => x +; atom z => z +; [fullSubstitute(x,y,u) for u in z] + +(DEFUN |fullSubstitute| (|x| |y| |z|) + (PROG () + (RETURN + (SEQ (COND + ((BOOT-EQUAL |z| |y|) |x|) + ((ATOM |z|) |z|) + ('T + (PROG (G173208) + (SPADLET G173208 NIL) + (RETURN + (DO ((G173213 |z| (CDR G173213)) (|u| NIL)) + ((OR (ATOM G173213) + (PROGN (SETQ |u| (CAR G173213)) NIL)) + (NREVERSE0 G173208)) + (SEQ (EXIT (SETQ G173208 + (CONS + (|fullSubstitute| |x| |y| |u|) + G173208))))))))))))) + +;getSubstCandidates sig == +; candidates := nil +; for x in sig for i in 1.. | x is [.,.,:.] repeat +; getSubstQualify(x,i,sig) => candidates := getSubstInsert(x,candidates) +; y := or/[getSubstQualify(y,i,sig) for y in rest x | y is [.,.,:.]] => +; candidates := insert(y,candidates) +; candidates + +(DEFUN |getSubstCandidates| (|sig|) + (PROG (|ISTMP#1| |.| |y| |candidates|) + (RETURN + (SEQ (PROGN + (SPADLET |candidates| NIL) + (DO ((G173242 |sig| (CDR G173242)) (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G173242) + (PROGN (SETQ |x| (CAR G173242)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |.| (QCDR |ISTMP#1|)) + 'T)))) + (COND + ((|getSubstQualify| |x| |i| |sig|) + (SPADLET |candidates| + (|getSubstInsert| |x| + |candidates|))) + ((SPADLET |y| + (PROG (G173248) + (SPADLET G173248 NIL) + (RETURN + (DO + ((G173255 NIL + G173248) + (G173256 (CDR |x|) + (CDR G173256)) + (|y| NIL)) + ((OR G173255 + (ATOM G173256) + (PROGN + (SETQ |y| + (CAR G173256)) + NIL)) + G173248) + (SEQ + (EXIT + (COND + ((AND (PAIRP |y|) + (PROGN + (SPADLET + |ISTMP#1| + (QCDR |y|)) + (AND + (PAIRP + |ISTMP#1|) + (PROGN + (SPADLET |.| + (QCDR + |ISTMP#1|)) + 'T)))) + (SETQ G173248 + (OR G173248 + (|getSubstQualify| + |y| |i| |sig|))))))))))) + (SPADLET |candidates| + (|insert| |y| |candidates|))))))))) + |candidates|))))) + +;getSubstSignature sig == +; candidates := getSubstCandidates sig +; null candidates => nil +; D := first $DomainList +; $DomainList := rest $DomainList +; winner := first candidates +; newsig := fullSubstitute(D,winner,sig) +; sig := +; null rest candidates => newsig +; count := NUMOFNODES newsig +; for x in rest candidates repeat +; trial := fullSubstitute(D,x,sig) +; trialCount := NUMOFNODES trial +; trialCount < count => +; newsig := trial +; count := trialCount +; winner := x +; newsig +; addWhereList(D,'is,winner) +; newsig + +(DEFUN |getSubstSignature| (|sig|) + (PROG (|candidates| D |trial| |trialCount| |newsig| |count| |winner|) + (declare (special |$DomainList|)) + (RETURN + (SEQ (PROGN + (SPADLET |candidates| (|getSubstCandidates| |sig|)) + (COND + ((NULL |candidates|) NIL) + ('T (SPADLET D (CAR |$DomainList|)) + (SPADLET |$DomainList| (CDR |$DomainList|)) + (SPADLET |winner| (CAR |candidates|)) + (SPADLET |newsig| (|fullSubstitute| D |winner| |sig|)) + (SPADLET |sig| + (COND + ((NULL (CDR |candidates|)) |newsig|) + ('T (SPADLET |count| (NUMOFNODES |newsig|)) + (DO ((G173288 (CDR |candidates|) + (CDR G173288)) + (|x| NIL)) + ((OR (ATOM G173288) + (PROGN + (SETQ |x| (CAR G173288)) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |trial| + (|fullSubstitute| D |x| |sig|)) + (SPADLET |trialCount| + (NUMOFNODES |trial|)) + (COND + ((> |count| |trialCount|) + (PROGN + (SPADLET |newsig| |trial|) + (SPADLET |count| + |trialCount|) + (SPADLET |winner| |x|)))))))) + |newsig|))) + (|addWhereList| D '|is| |winner|) |newsig|))))))) + +;getSubstQualify(x,i,sig) == +; or/[CONTAINED(x,y) for y in sig for j in 1.. | j ^= i] => x +; false + +(DEFUN |getSubstQualify| (|x| |i| |sig|) + (PROG () + (RETURN + (SEQ (COND + ((PROG (G173310) + (SPADLET G173310 NIL) + (RETURN + (DO ((G173318 NIL G173310) + (G173319 |sig| (CDR G173319)) (|y| NIL) + (|j| 1 (QSADD1 |j|))) + ((OR G173318 (ATOM G173319) + (PROGN (SETQ |y| (CAR G173319)) NIL)) + G173310) + (SEQ (EXIT (COND + ((NEQUAL |j| |i|) + (SETQ G173310 + (OR G173310 + (CONTAINED |x| |y|)))))))))) + |x|) + ('T NIL)))))) + +;getSubstInsert(x,candidates) == +; return insert(x,candidates) +; null candidates => [x] +; or/[CONTAINED(x,y) for y in candidates] => candidates +; y := or/[CONTAINED(y,x) for y in candidates] => SUBST(x,y,candidates) +; candidates + +(DEFUN |getSubstInsert| (|x| |candidates|) + (PROG (|y|) + (RETURN + (SEQ (PROGN + (RETURN (|insert| |x| |candidates|)) + (COND + ((NULL |candidates|) (CONS |x| NIL)) + ((PROG (G173331) + (SPADLET G173331 NIL) + (RETURN + (DO ((G173337 NIL G173331) + (G173338 |candidates| (CDR G173338)) + (|y| NIL)) + ((OR G173337 (ATOM G173338) + (PROGN (SETQ |y| (CAR G173338)) NIL)) + G173331) + (SEQ (EXIT (SETQ G173331 + (OR G173331 + (CONTAINED |x| |y|)))))))) + |candidates|) + ((SPADLET |y| + (PROG (G173345) + (SPADLET G173345 NIL) + (RETURN + (DO ((G173351 NIL G173345) + (G173352 |candidates| + (CDR G173352)) + (|y| NIL)) + ((OR G173351 (ATOM G173352) + (PROGN + (SETQ |y| (CAR G173352)) + NIL)) + G173345) + (SEQ (EXIT + (SETQ G173345 + (OR G173345 + (CONTAINED |y| |x|))))))))) + (MSUBST |x| |y| |candidates|)) + ('T |candidates|))))))) + +;--======================================================================= +;-- Who Uses +;--======================================================================= +;whoUsesOperation(htPage,which,key) == --see dbPresentOps +; key = 'filter => koaPageFilterByName(htPage,'whoUsesOperation) +; opAlist := htpProperty(htPage,'opAlist) +; conform := htpProperty(htPage,'conform) +; conargs := rest conform +; opl := nil +; for [op,:alist] in opAlist repeat +; for [sig,:.] in alist repeat +; opl := [[op,:SUBLISLIS($FormalMapVariableList,rest conform,sig)],:opl] +; opl := NREVERSE opl +; u := whoUses(opl,conform) +; prefix := pluralSay(#u,'"constructor uses",'"constructors use") +; suffix := +; opAlist is [[op1,.]] => +; ['" operation {\em ",escapeSpecialChars STRINGIMAGE op1,_ +; '":",form2HtString ['Mapping,:sig],'"}"] +; ['" these operations"] +; page := htInitPage([:prefix,:suffix],htCopyProplist htPage) +; nopAlist := nil +; for [name,:opsigList] in u repeat +; for opsig in opsigList repeat +; sofar := LASSOC(opsig,nopAlist) +; nopAlist := insertAlist(opsig,[name,:LASSOC(opsig,nopAlist)],nopAlist) +; usedList := nil +; for [(pair := [op,:sig]),:namelist] in nopAlist repeat +; ops := escapeSpecialChars STRINGIMAGE op +; usedList := [pair,:usedList] +; htSay('"Users of {\em ",ops,'": ") +; bcConform ['Mapping,:sublisFormal(conargs,sig)] +; htSay('"}\newline") +; bcConTable listSort(function GLESSEQP,REMDUP namelist) +; noOneUses := SETDIFFERENCE(opl,usedList) +; if #noOneUses > 0 then +; htSay('"No constructor uses the ") +; htSay +; #noOneUses = 1 => '"operation: " +; [#noOneUses,'" operations:"] +; htSay '"\newline " +; for [op,:sig] in noOneUses repeat +; htSay('"\tab{2}{\em ",escapeSpecialChars STRINGIMAGE op,'": ") +; bcConform ['Mapping,:sublisFormal(conargs,sig)] +; htSay('"}\newline") +; htSayStandard '"\endscroll " +; dbPresentOps(page,which,'usage) +; htShowPageNoScroll() + +(DEFUN |whoUsesOperation| (|htPage| |which| |key|) + (PROG (|opAlist| |conform| |conargs| |alist| |opl| |u| |prefix| + |ISTMP#1| |op1| |ISTMP#2| |suffix| |page| |name| + |opsigList| |sofar| |nopAlist| |pair| |namelist| |ops| + |usedList| |noOneUses| |op| |sig|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |key| '|filter|) + (|koaPageFilterByName| |htPage| '|whoUsesOperation|)) + ('T + (SPADLET |opAlist| (|htpProperty| |htPage| '|opAlist|)) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |conargs| (CDR |conform|)) (SPADLET |opl| NIL) + (DO ((G173409 |opAlist| (CDR G173409)) + (G173368 NIL)) + ((OR (ATOM G173409) + (PROGN (SETQ G173368 (CAR G173409)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G173368)) + (SPADLET |alist| (CDR G173368)) + G173368) + NIL)) + NIL) + (SEQ (EXIT (DO ((G173420 |alist| (CDR G173420)) + (G173365 NIL)) + ((OR (ATOM G173420) + (PROGN + (SETQ G173365 (CAR G173420)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR G173365)) + G173365) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |opl| + (CONS + (CONS |op| + (SUBLISLIS + |$FormalMapVariableList| + (CDR |conform|) |sig|)) + |opl|)))))))) + (SPADLET |opl| (NREVERSE |opl|)) + (SPADLET |u| (|whoUses| |opl| |conform|)) + (SPADLET |prefix| + (|pluralSay| (|#| |u|) + (MAKESTRING "constructor uses") + (MAKESTRING "constructors use"))) + (SPADLET |suffix| + (COND + ((AND (PAIRP |opAlist|) + (EQ (QCDR |opAlist|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |opAlist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op1| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (CONS (MAKESTRING " operation {\\em ") + (CONS (|escapeSpecialChars| + (STRINGIMAGE |op1|)) + (CONS (MAKESTRING ":") + (CONS + (|form2HtString| + (CONS '|Mapping| |sig|)) + (CONS (MAKESTRING "}") NIL)))))) + ('T + (CONS (MAKESTRING " these operations") NIL)))) + (SPADLET |page| + (|htInitPage| (APPEND |prefix| |suffix|) + (|htCopyProplist| |htPage|))) + (SPADLET |nopAlist| NIL) + (DO ((G173433 |u| (CDR G173433)) (G173384 NIL)) + ((OR (ATOM G173433) + (PROGN (SETQ G173384 (CAR G173433)) NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR G173384)) + (SPADLET |opsigList| (CDR G173384)) + G173384) + NIL)) + NIL) + (SEQ (EXIT (DO ((G173445 |opsigList| (CDR G173445)) + (|opsig| NIL)) + ((OR (ATOM G173445) + (PROGN + (SETQ |opsig| (CAR G173445)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |sofar| + (LASSOC |opsig| |nopAlist|)) + (SPADLET |nopAlist| + (|insertAlist| |opsig| + (CONS |name| + (LASSOC |opsig| + |nopAlist|)) + |nopAlist|))))))))) + (SPADLET |usedList| NIL) + (DO ((G173461 |nopAlist| (CDR G173461)) + (G173389 NIL)) + ((OR (ATOM G173461) + (PROGN (SETQ G173389 (CAR G173461)) NIL) + (PROGN + (PROGN + (SPADLET |pair| (CAR G173389)) + (SPADLET |op| (CAAR G173389)) + (SPADLET |sig| (CDAR G173389)) + (SPADLET |namelist| (CDR G173389)) + G173389) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE |op|))) + (SPADLET |usedList| + (CONS |pair| |usedList|)) + (|htSay| (MAKESTRING "Users of {\\em ") + |ops| (MAKESTRING ": ")) + (|bcConform| + (CONS '|Mapping| + (|sublisFormal| |conargs| |sig|))) + (|htSay| (MAKESTRING "}\\newline")) + (|bcConTable| + (|listSort| (|function| GLESSEQP) + (REMDUP |namelist|))))))) + (SPADLET |noOneUses| (SETDIFFERENCE |opl| |usedList|)) + (COND + ((> (|#| |noOneUses|) 0) + (|htSay| (MAKESTRING "No constructor uses the ")) + (|htSay| (COND + ((EQL (|#| |noOneUses|) 1) + (MAKESTRING "operation: ")) + ('T + (CONS (|#| |noOneUses|) + (CONS (MAKESTRING " operations:") + NIL))))) + (|htSay| (MAKESTRING "\\newline ")) + (DO ((G173475 |noOneUses| (CDR G173475)) + (G173397 NIL)) + ((OR (ATOM G173475) + (PROGN (SETQ G173397 (CAR G173475)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G173397)) + (SPADLET |sig| (CDR G173397)) + G173397) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING "\\tab{2}{\\em ") + (|escapeSpecialChars| + (STRINGIMAGE |op|)) + (MAKESTRING ": ")) + (|bcConform| + (CONS '|Mapping| + (|sublisFormal| |conargs| |sig|))) + (|htSay| (MAKESTRING "}\\newline")))))))) + (|htSayStandard| (MAKESTRING "\\endscroll ")) + (|dbPresentOps| |page| |which| '|usage|) + (|htShowPageNoScroll|))))))) + +;whoUses(opSigList,conform) == +; opList := REMDUP ASSOCLEFT opSigList +; numOfArgsList := REMDUP [-1 + #sig for [.,:sig] in opSigList] +; acc := nil +; $conname : local := first conform +; domList := getUsersOfConstructor $conname +; hash := MAKE_-HASH_-TABLE() +; for name in allConstructors() | MEMQ(name,domList) repeat +; $infovec : local := dbInfovec name +; null $infovec => 'skip --category +; template := $infovec . 0 +; found := false +; opacc := nil +; for i in 7..MAXINDEX template repeat +; item := template . i +; item isnt [n,:op] or not MEMQ(op,opList) => 'skip +; index := n +; numvec := getCodeVector() +; numOfArgs := numvec . index +; null MEMBER(numOfArgs,numOfArgsList) => 'skip +; whereNumber := numvec.(index := index + 1) +; template . whereNumber isnt [= $conname,:.] => 'skip +; signumList := dcSig(numvec,index + 1,numOfArgs) +; opsig := or/[pair for (pair := [op1,:sig]) in opSigList _ +; | op1 = op and whoUsesMatch?(signumList,sig,nil)] +; => opacc := [opsig,:opacc] +; if opacc then acc := [[name,:opacc],:acc] +; acc + +(DEFUN |whoUses| (|opSigList| |conform|) + (PROG (|$conname| |$infovec| |opList| |numOfArgsList| |domList| + |hash| |template| |found| |item| |n| |op| |numvec| + |numOfArgs| |index| |whereNumber| |ISTMP#1| |signumList| + |op1| |sig| |opsig| |opacc| |acc|) + (DECLARE (SPECIAL |$conname| |$infovec|)) + (RETURN + (SEQ (PROGN + (SPADLET |opList| (REMDUP (ASSOCLEFT |opSigList|))) + (SPADLET |numOfArgsList| + (REMDUP (PROG (G173535) + (SPADLET G173535 NIL) + (RETURN + (DO ((G173541 |opSigList| + (CDR G173541)) + (G173516 NIL)) + ((OR (ATOM G173541) + (PROGN + (SETQ G173516 + (CAR G173541)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CDR G173516)) + G173516) + NIL)) + (NREVERSE0 G173535)) + (SEQ + (EXIT + (SETQ G173535 + (CONS + (PLUS (SPADDIFFERENCE 1) + (|#| |sig|)) + G173535))))))))) + (SPADLET |acc| NIL) + (SPADLET |$conname| (CAR |conform|)) + (SPADLET |domList| (|getUsersOfConstructor| |$conname|)) + (SPADLET |hash| (MAKE-HASH-TABLE)) + (DO ((G173564 (|allConstructors|) (CDR G173564)) + (|name| NIL)) + ((OR (ATOM G173564) + (PROGN (SETQ |name| (CAR G173564)) NIL)) + NIL) + (SEQ (EXIT (COND + ((MEMQ |name| |domList|) + (PROGN + (SPADLET |$infovec| + (|dbInfovec| |name|)) + (COND + ((NULL |$infovec|) '|skip|) + ('T + (SPADLET |template| + (ELT |$infovec| 0)) + (SPADLET |found| NIL) + (SPADLET |opacc| NIL) + (DO ((G173583 + (MAXINDEX |template|)) + (|i| 7 (+ |i| 1))) + ((> |i| G173583) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |item| + (ELT |template| |i|)) + (COND + ((OR + (NULL + (AND (PAIRP |item|) + (PROGN + (SPADLET |n| + (QCAR |item|)) + (SPADLET |op| + (QCDR |item|)) + 'T))) + (NULL (MEMQ |op| |opList|))) + '|skip|) + ('T (SPADLET |index| |n|) + (SPADLET |numvec| + (|getCodeVector|)) + (SPADLET |numOfArgs| + (ELT |numvec| |index|)) + (COND + ((NULL + (|member| |numOfArgs| + |numOfArgsList|)) + '|skip|) + ('T + (SPADLET |whereNumber| + (ELT |numvec| + (SPADLET |index| + (PLUS |index| 1)))) + (COND + ((NULL + (PROGN + (SPADLET |ISTMP#1| + (ELT |template| + |whereNumber|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL + (QCAR |ISTMP#1|) + |$conname|)))) + '|skip|) + ('T + (SPADLET |signumList| + (|dcSig| |numvec| + (PLUS |index| 1) + |numOfArgs|)) + (COND + ((SPADLET |opsig| + (PROG (G173587) + (SPADLET + G173587 NIL) + (RETURN + (DO + ((G173595 + NIL + G173587) + (G173596 + |opSigList| + (CDR + G173596)) + (|pair| NIL)) + ((OR + G173595 + (ATOM + G173596) + (PROGN + (SETQ + |pair| + (CAR + G173596)) + NIL) + (PROGN + (PROGN + (SPADLET + |op1| + (CAR + |pair|)) + (SPADLET + |sig| + (CDR + |pair|)) + |pair|) + NIL)) + G173587) + (SEQ + (EXIT + (COND + ((AND + (BOOT-EQUAL + |op1| + |op|) + (|whoUsesMatch?| + |signumList| + |sig| + NIL)) + (SETQ + G173587 + (OR + G173587 + |pair|)))))))))) + (SPADLET |opacc| + (CONS |opsig| + |opacc|)))))))))))))) + (COND + (|opacc| + (SPADLET |acc| + (CONS (CONS |name| |opacc|) + |acc|))) + ('T NIL)))))))))) + |acc|))))) + +;whoUsesMatch?(signumList,sig,al) == +; #signumList = #sig and whoUsesMatch1?(signumList,sig,al) + +(DEFUN |whoUsesMatch?| (|signumList| |sig| |al|) + (AND (BOOT-EQUAL (|#| |signumList|) (|#| |sig|)) + (|whoUsesMatch1?| |signumList| |sig| |al|))) + +;whoUsesMatch1?(signumList,sig,al) == +; signumList is [subject,:r] and sig is [pattern,:s] => +; x := LASSOC(pattern,al) => +; x = subject => whoUsesMatch1?(r,s,al) +; false +; pattern = '_$ => +; subject is [= $conname,:.] => whoUsesMatch1?(r,s,[['_$,:subject],:al]) +; false +; whoUsesMatch1?(r,s,[[pattern,:subject],:al]) +; true + +(DEFUN |whoUsesMatch1?| (|signumList| |sig| |al|) + (PROG (|subject| |r| |pattern| |s| |x|) + (declare (special |$conname|)) + (RETURN + (COND + ((AND (PAIRP |signumList|) + (PROGN + (SPADLET |subject| (QCAR |signumList|)) + (SPADLET |r| (QCDR |signumList|)) + 'T) + (PAIRP |sig|) + (PROGN + (SPADLET |pattern| (QCAR |sig|)) + (SPADLET |s| (QCDR |sig|)) + 'T)) + (COND + ((SPADLET |x| (LASSOC |pattern| |al|)) + (COND + ((BOOT-EQUAL |x| |subject|) + (|whoUsesMatch1?| |r| |s| |al|)) + ('T NIL))) + ((BOOT-EQUAL |pattern| '$) + (COND + ((AND (PAIRP |subject|) + (EQUAL (QCAR |subject|) |$conname|)) + (|whoUsesMatch1?| |r| |s| + (CONS (CONS '$ |subject|) |al|))) + ('T NIL))) + ('T + (|whoUsesMatch1?| |r| |s| + (CONS (CONS |pattern| |subject|) |al|))))) + ('T 'T))))) + +;--======================================================================= +;-- Get Attribute/Operation Alist +;--======================================================================= +;koAttrs(conform,domname) == +; [conname,:args] := conform +;--asharpConstructorName? conname => nil --assumed +; 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => +; koCatAttrs(conform,domname) +; $infovec: local := dbInfovec conname or return nil +; $predvec: local := +; $domain => $domain . 3 +; GETDATABASE(conname,'PREDICATES) +; u := [[a,:pred] for [a,:i] in $infovec . 2 _ +; | a ^= 'nil and (pred := sublisFormal(args,kTestPred i))] +; --------- CHECK for a = nil +; listSort(function GLESSEQP,fn u) where fn u == +; alist := nil +; for [a,:pred] in u repeat +; op := opOf a +; args := IFCDR a +; alist := insertAlist(op,insertAlist(args,[pred],LASSOC(op,alist)),alist) +; alist + +(DEFUN |koAttrs,fn| (|u|) + (PROG (|a| |pred| |op| |args| |alist|) + (declare (special |$domain|)) + (RETURN + (SEQ (SPADLET |alist| NIL) + (DO ((G173678 |u| (CDR G173678)) (G173669 NIL)) + ((OR (ATOM G173678) + (PROGN (SETQ G173669 (CAR G173678)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G173669)) + (SPADLET |pred| (CDR G173669)) + G173669) + NIL)) + NIL) + (SEQ (SPADLET |op| (|opOf| |a|)) + (SPADLET |args| (IFCDR |a|)) + (EXIT (SPADLET |alist| + (|insertAlist| |op| + (|insertAlist| |args| + (CONS |pred| NIL) + (LASSOC |op| |alist|)) + |alist|))))) + (EXIT |alist|))))) + +(DEFUN |koAttrs| (|conform| |domname|) + (PROG (|$infovec| |$predvec| |conname| |args| |a| |i| |pred| |u|) + (DECLARE (SPECIAL |$infovec| |$predvec| |$domain|)) + (RETURN + (SEQ (PROGN + (SPADLET |conname| (CAR |conform|)) + (SPADLET |args| (CDR |conform|)) + (COND + ((BOOT-EQUAL '|category| + (GETDATABASE |conname| 'CONSTRUCTORKIND)) + (|koCatAttrs| |conform| |domname|)) + ('T + (SPADLET |$infovec| + (OR (|dbInfovec| |conname|) (RETURN NIL))) + (SPADLET |$predvec| + (COND + (|$domain| (ELT |$domain| 3)) + ('T (GETDATABASE |conname| 'PREDICATES)))) + (SPADLET |u| + (PROG (G173702) + (SPADLET G173702 NIL) + (RETURN + (DO ((G173709 (ELT |$infovec| 2) + (CDR G173709)) + (G173664 NIL)) + ((OR (ATOM G173709) + (PROGN + (SETQ G173664 + (CAR G173709)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G173664)) + (SPADLET |i| (CDR G173664)) + G173664) + NIL)) + (NREVERSE0 G173702)) + (SEQ (EXIT + (COND + ((AND (NEQUAL |a| '|nil|) + (SPADLET |pred| + (|sublisFormal| |args| + (|kTestPred| |i|)))) + (SETQ G173702 + (CONS (CONS |a| |pred|) + G173702)))))))))) + (|listSort| (|function| GLESSEQP) (|koAttrs,fn| |u|))))))))) + +;koOps(conform,domname,:options) == main where +;--returns alist of form ((op (sig . pred) ...) ...) +; main == +; $packageItem: local := nil +;-- relatives? := IFCAR options +; ours := +;-- relatives? = 'onlyRelatives => nil +; fn(conform,domname) +;-- if relatives? then +;-- relatives := relativesOf(conform,domname) +;-- if domname then relatives := +;-- SUBLISLIS([domname,:rest domname],['_$,:rest conform],relatives) +;-- --kill all relatives that have a sharp variable remaining in them +;-- for x in relatives repeat +;-- or/[y for y in CDAR x | isSharpVar y] => 'skip +;-- acc := [x,:acc] +;-- relatives := NREVERSE acc +;-- for (pair := [pakform,:.]) in relatives repeat +;-- $packageItem := sublisFormal(rest conform,pair) +;-- ours := merge(fn(pakform,nil),ours) +; listSort(function GLESSEQP,trim ours) +; trim u == [pair for pair in u | IFCDR pair] +; fn(conform,domname) == +; conform := domname or conform +; [conname,:args] := conform +; subargs: local := args +; ----------> new <------------------ +; u := koCatOps(conform,domname) => u +;-- 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => +;-- koCatOps(conform,domname) +; asharpConstructorName? opOf conform => nil +; ----------> new <------------------ +; $infovec: local := dbInfovec conname--------> removed 94/10/24 +; exposureTail := +; null $packageItem => '(NIL NIL) +; isExposedConstructor opOf conform => [conform,:'(T)] +; [conform,:'(NIL)] +; for [op,:u] in getOperationAlistFromLisplib conname repeat +; op1 := zeroOneConvert op +; acc := +; [[op1,:[[sig,npred,:exposureTail] _ +; for [sig,slot,pred,key,:.] in sublisFormal(subargs,u) | +; (key ^= 'Subsumed) and (npred := simpHasPred pred)]],:acc] +; acc +; merge(alist,alist1) == --alist1 takes precedence +; for [op,:al] in alist1 repeat +; u := LASSOC(op,alist) => +; for [sig,:item] in al | not LASSOC(sig,u) repeat +; u := insertAlist(sig,item,u) +; alist := insertAlist(op,u,DELASC(op,alist)) --add merge of two alists +; alist := insertAlist(op,al,alist) --add the whole inner alist +; alist + +(DEFUN |koOps,merge| (|alist| |alist1|) + (PROG (|op| |al| |sig| |item| |u|) + (RETURN + (SEQ (DO ((G173767 |alist1| (CDR G173767)) (G173755 NIL)) + ((OR (ATOM G173767) + (PROGN (SETQ G173755 (CAR G173767)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G173755)) + (SPADLET |al| (CDR G173755)) + G173755) + NIL)) + NIL) + (SEQ (IF (SPADLET |u| (LASSOC |op| |alist|)) + (EXIT (SEQ (DO ((G173779 |al| (CDR G173779)) + (G173749 NIL)) + ((OR (ATOM G173779) + (PROGN + (SETQ G173749 + (CAR G173779)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR G173749)) + (SPADLET |item| + (CDR G173749)) + G173749) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (LASSOC |sig| |u|)) + (SPADLET |u| + (|insertAlist| |sig| |item| + |u|))))))) + (EXIT (SPADLET |alist| + (|insertAlist| |op| |u| + (DELASC |op| |alist|))))))) + (EXIT (SPADLET |alist| + (|insertAlist| |op| |al| |alist|))))) + (EXIT |alist|))))) + +(DEFUN |koOps,fn| (|conform| |domname|) + (PROG (|$infovec| |conname| |args| |subargs| |exposureTail| |op| |u| + |op1| |sig| |slot| |pred| |key| |npred| |acc|) + (DECLARE (SPECIAL |$infovec| |$packageItem|)) + (RETURN + (SEQ (SPADLET |conform| (OR |domname| |conform|)) + (PROGN + (SPADLET |conname| (CAR |conform|)) + (SPADLET |args| (CDR |conform|)) + |conform|) + (SPADLET |subargs| |args|) + (IF (SPADLET |u| (|koCatOps| |conform| |domname|)) + (EXIT |u|)) + (IF (|asharpConstructorName?| (|opOf| |conform|)) + (EXIT NIL)) + (SPADLET |$infovec| (|dbInfovec| |conname|)) + (SPADLET |exposureTail| + (SEQ (IF (NULL |$packageItem|) (EXIT '(NIL NIL))) + (IF (|isExposedConstructor| + (|opOf| |conform|)) + (EXIT (CONS |conform| '(T)))) + (EXIT (CONS |conform| '(NIL))))) + (DO ((G173806 (|getOperationAlistFromLisplib| |conname|) + (CDR G173806)) + (G173744 NIL)) + ((OR (ATOM G173806) + (PROGN (SETQ G173744 (CAR G173806)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G173744)) + (SPADLET |u| (CDR G173744)) + G173744) + NIL)) + NIL) + (SEQ (SPADLET |op1| (|zeroOneConvert| |op|)) + (EXIT (SPADLET |acc| + (CONS (CONS |op1| + (PROG (G173819) + (SPADLET G173819 NIL) + (RETURN + (DO + ((G173826 + (|sublisFormal| + |subargs| |u|) + (CDR G173826)) + (G173737 NIL)) + ((OR (ATOM G173826) + (PROGN + (SETQ G173737 + (CAR G173826)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| + (CAR G173737)) + (SPADLET |slot| + (CADR G173737)) + (SPADLET |pred| + (CADDR G173737)) + (SPADLET |key| + (CADDDR G173737)) + G173737) + NIL)) + (NREVERSE0 G173819)) + (SEQ + (EXIT + (COND + ((AND + (NEQUAL |key| + '|Subsumed|) + (SPADLET |npred| + (|simpHasPred| + |pred|))) + (SETQ G173819 + (CONS + (CONS |sig| + (CONS |npred| + |exposureTail|)) + G173819)))))))))) + |acc|))))) + (EXIT |acc|))))) + +(DEFUN |koOps,trim| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G173860) + (SPADLET G173860 NIL) + (RETURN + (DO ((G173866 |u| (CDR G173866)) (|pair| NIL)) + ((OR (ATOM G173866) + (PROGN (SETQ |pair| (CAR G173866)) NIL)) + (NREVERSE0 G173860)) + (SEQ (EXIT (COND + ((IFCDR |pair|) + (SETQ G173860 (CONS |pair| G173860))))))))))))) + + +(DEFUN |koOps| (&REST G173884 &AUX |options| |domname| |conform|) + (DSETQ (|conform| |domname| . |options|) G173884) + (PROG (|$packageItem| |ours|) + (DECLARE (SPECIAL |$packageItem|)) + (RETURN + (PROGN + (SPADLET |$packageItem| NIL) + (SPADLET |ours| (|koOps,fn| |conform| |domname|)) + (|listSort| (|function| GLESSEQP) (|koOps,trim| |ours|)))))) + +;zeroOneConvert x == +; x = 'Zero => 0 +; x = 'One => 1 +; x + +(DEFUN |zeroOneConvert| (|x|) + (COND + ((BOOT-EQUAL |x| '|Zero|) 0) + ((BOOT-EQUAL |x| '|One|) 1) + ('T |x|))) + +;kFormatSlotDomain x == fn formatSlotDomain x where fn x == +; atom x => x +; (op := CAR x) = '_$ => '_$ +; op = 'local => CADR x +; op = ":" => [":",CADR x,fn CADDR x] +; MEMQ(op,$Primitives) or constructor? op => +; [fn y for y in x] +; INTEGERP op => op +; op = 'QUOTE and atom CADR x => CADR x +; x + +(DEFUN |kFormatSlotDomain,fn| (|x|) + (PROG (|op|) + (declare (special |$Primitives|)) + (RETURN + (SEQ (IF (ATOM |x|) (EXIT |x|)) + (IF (BOOT-EQUAL (SPADLET |op| (CAR |x|)) '$) (EXIT '$)) + (IF (BOOT-EQUAL |op| '|local|) (EXIT (CADR |x|))) + (IF (BOOT-EQUAL |op| '|:|) + (EXIT (CONS '|:| + (CONS (CADR |x|) + (CONS (|kFormatSlotDomain,fn| + (CADDR |x|)) + NIL))))) + (IF (OR (MEMQ |op| |$Primitives|) (|constructor?| |op|)) + (EXIT (PROG (G173894) + (SPADLET G173894 NIL) + (RETURN + (DO ((G173899 |x| (CDR G173899)) + (|y| NIL)) + ((OR (ATOM G173899) + (PROGN + (SETQ |y| (CAR G173899)) + NIL)) + (NREVERSE0 G173894)) + (SEQ (EXIT (SETQ G173894 + (CONS + (|kFormatSlotDomain,fn| |y|) + G173894))))))))) + (IF (INTEGERP |op|) (EXIT |op|)) + (IF (AND (BOOT-EQUAL |op| 'QUOTE) (ATOM (CADR |x|))) + (EXIT (CADR |x|))) + (EXIT |x|))))) + +(DEFUN |kFormatSlotDomain| (|x|) + (|kFormatSlotDomain,fn| (|formatSlotDomain| |x|))) + +;koCatOps(conform,domname) == +; conname := opOf conform +; oplist := REVERSE GETDATABASE(conname,'OPERATIONALIST) +; oplist := sublisFormal(IFCDR domname or IFCDR conform ,oplist) +; --check below for INTEGERP key to avoid subsumed signatures +; [[zeroOneConvert op,:nalist] for [op,:alist] in oplist _ +; | nalist := koCatOps1(alist)] + +(DEFUN |koCatOps| (|conform| |domname|) + (PROG (|conname| |oplist| |op| |alist| |nalist|) + (RETURN + (SEQ (PROGN + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |oplist| + (REVERSE (GETDATABASE |conname| 'OPERATIONALIST))) + (SPADLET |oplist| + (|sublisFormal| + (OR (IFCDR |domname|) (IFCDR |conform|)) + |oplist|)) + (PROG (G173925) + (SPADLET G173925 NIL) + (RETURN + (DO ((G173932 |oplist| (CDR G173932)) + (G173914 NIL)) + ((OR (ATOM G173932) + (PROGN (SETQ G173914 (CAR G173932)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G173914)) + (SPADLET |alist| (CDR G173914)) + G173914) + NIL)) + (NREVERSE0 G173925)) + (SEQ (EXIT (COND + ((SPADLET |nalist| + (|koCatOps1| |alist|)) + (SETQ G173925 + (CONS + (CONS (|zeroOneConvert| |op|) + |nalist|) + G173925)))))))))))))) + +;koCatOps1 alist == [x for item in alist | x := pair] where +; pair == +; [sig,:r] := item +; null r => [sig,true] +; [key,:options] := r +; null (pred := IFCAR options) => +; IFCAR IFCDR options = 'ASCONST => [sig,'ASCONST] +; [sig,true] +; npred := simpHasPred pred => [sig,npred] +; false + +(DEFUN |koCatOps1| (|alist|) + (PROG (|sig| |r| |key| |options| |pred| |npred| |x|) + (RETURN + (SEQ (PROG (G173969) + (SPADLET G173969 NIL) + (RETURN + (DO ((G173975 |alist| (CDR G173975)) (|item| NIL)) + ((OR (ATOM G173975) + (PROGN (SETQ |item| (CAR G173975)) NIL)) + (NREVERSE0 G173969)) + (SEQ (EXIT (COND + ((SPADLET |x| + (PROGN + (SPADLET |sig| (CAR |item|)) + (SPADLET |r| (CDR |item|)) + (COND + ((NULL |r|) + (CONS |sig| (CONS 'T NIL))) + ('T + (SPADLET |key| (CAR |r|)) + (SPADLET |options| + (CDR |r|)) + (COND + ((NULL + (SPADLET |pred| + (IFCAR |options|))) + (COND + ((BOOT-EQUAL + (IFCAR + (IFCDR |options|)) + 'ASCONST) + (CONS |sig| + (CONS 'ASCONST NIL))) + ('T + (CONS |sig| + (CONS 'T NIL))))) + ((SPADLET |npred| + (|simpHasPred| |pred|)) + (CONS |sig| + (CONS |npred| NIL))) + ('T NIL)))))) + (SETQ G173969 (CONS |x| G173969))))))))))))) + +;koCatAttrs(catform,domname) == +; $if: local := MAKE_-HASHTABLE 'ID +; catname := opOf catform +; koCatAttrsAdd(domname or catform,true) +; ancestors := ancestorsOf(catform,domname) +; for [conform,:pred] in ancestors repeat koCatAttrsAdd(conform,pred) +; hashTable2Alist $if + +(DEFUN |koCatAttrs| (|catform| |domname|) + (PROG (|$if| |catname| |ancestors| |conform| |pred|) + (DECLARE (SPECIAL |$if|)) + (RETURN + (SEQ (PROGN + (SPADLET |$if| (MAKE-HASHTABLE 'ID)) + (SPADLET |catname| (|opOf| |catform|)) + (|koCatAttrsAdd| (OR |domname| |catform|) 'T) + (SPADLET |ancestors| (|ancestorsOf| |catform| |domname|)) + (DO ((G174001 |ancestors| (CDR G174001)) + (G173992 NIL)) + ((OR (ATOM G174001) + (PROGN (SETQ G173992 (CAR G174001)) NIL) + (PROGN + (PROGN + (SPADLET |conform| (CAR G173992)) + (SPADLET |pred| (CDR G173992)) + G173992) + NIL)) + NIL) + (SEQ (EXIT (|koCatAttrsAdd| |conform| |pred|)))) + (|hashTable2Alist| |$if|)))))) + +;hashTable2Alist tb == +; [[op,:HGET(tb,op)] for op in listSort(function GLESSEQP,HKEYS $if)] + +(DEFUN |hashTable2Alist| (|tb|) + (PROG () + (declare (special |$if|)) + (RETURN + (SEQ (PROG (G174022) + (SPADLET G174022 NIL) + (RETURN + (DO ((G174027 + (|listSort| (|function| GLESSEQP) + (HKEYS |$if|)) + (CDR G174027)) + (|op| NIL)) + ((OR (ATOM G174027) + (PROGN (SETQ |op| (CAR G174027)) NIL)) + (NREVERSE0 G174022)) + (SEQ (EXIT (SETQ G174022 + (CONS (CONS |op| (HGET |tb| |op|)) + G174022))))))))))) + +;koCatAttrsAdd(catform,pred) == +; for [name,argl,:p] in CAR getConstructorExports catform repeat +; npred := quickAnd(pred,p) +; exists := HGET($if,name) +; if existingPred := LASSOC(argl,exists)_ +; then npred := quickOr(npred,existingPred) +; if not MEMQ(name,'(nil nothing)) _ +; then HPUT($if,name,[[argl,simpHasPred npred],:exists]) + +(DEFUN |koCatAttrsAdd| (|catform| |pred|) + (PROG (|name| |argl| |p| |exists| |existingPred| |npred|) + (declare (special |$if|)) + (RETURN + (SEQ (DO ((G174051 (CAR (|getConstructorExports| |catform|)) + (CDR G174051)) + (G174038 NIL)) + ((OR (ATOM G174051) + (PROGN (SETQ G174038 (CAR G174051)) NIL) + (PROGN + (PROGN + (SPADLET |name| (CAR G174038)) + (SPADLET |argl| (CADR G174038)) + (SPADLET |p| (CDDR G174038)) + G174038) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |npred| (|quickAnd| |pred| |p|)) + (SPADLET |exists| (HGET |$if| |name|)) + (COND + ((SPADLET |existingPred| + (LASSOC |argl| |exists|)) + (SPADLET |npred| + (|quickOr| |npred| + |existingPred|)))) + (COND + ((NULL (MEMQ |name| '(|nil| |nothing|))) + (HPUT |$if| |name| + (CONS + (CONS |argl| + (CONS (|simpHasPred| |npred|) NIL)) + |exists|))) + ('T NIL)))))))))) + +;--======================================================================= +;-- Filter by Category +;--======================================================================= +;koaPageFilterByCategory(htPage,calledFrom) == +; opAlist := htpProperty(htPage,'opAlist) +; which := htpProperty(htPage,'which) +; page := htInitPageNoScroll(htCopyProplist htPage, +; dbHeading(opAlist,which,htpProperty(htPage,'heading))) +; htSay('"Select a category ancestor below or ") +; htMakePage [['bcLispLinks,['"filter",'"on:",calledFrom,'filter]]] +; htMakePage [['bcStrings, [13,'"",'filter,'EM]]] +; htSay('"\beginscroll ") +; conform := htpProperty(htPage,'conform) +; domname := htpProperty(htPage,'domname) +; ancestors := ASSOCLEFT ancestorsOf(conform,domname) +; htpSetProperty(page,'ancestors,listSort(function GLESSEQP,ancestors)) +; bcNameCountTable(ancestors,'form2HtString,'koaPageFilterByCategory1,true) +; htShowPage() + +(DEFUN |koaPageFilterByCategory| (|htPage| |calledFrom|) + (PROG (|opAlist| |which| |page| |conform| |domname| |ancestors|) + (RETURN + (PROGN + (SPADLET |opAlist| (|htpProperty| |htPage| '|opAlist|)) + (SPADLET |which| (|htpProperty| |htPage| '|which|)) + (SPADLET |page| + (|htInitPageNoScroll| (|htCopyProplist| |htPage|) + (|dbHeading| |opAlist| |which| + (|htpProperty| |htPage| '|heading|)))) + (|htSay| (MAKESTRING "Select a category ancestor below or ")) + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "filter") + (CONS (MAKESTRING "on:") + (CONS |calledFrom| + (CONS '|filter| NIL)))) + NIL)) + NIL)) + (|htMakePage| + (CONS (CONS '|bcStrings| + (CONS (CONS 13 + (CONS (MAKESTRING "") + (CONS '|filter| (CONS 'EM NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "\\beginscroll ")) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) + (SPADLET |ancestors| + (ASSOCLEFT (|ancestorsOf| |conform| |domname|))) + (|htpSetProperty| |page| '|ancestors| + (|listSort| (|function| GLESSEQP) |ancestors|)) + (|bcNameCountTable| |ancestors| '|form2HtString| + '|koaPageFilterByCategory1| 'T) + (|htShowPage|))))) + +;dbHeading(items,which,heading,:options) == +; names? := IFCAR options +; count := +; names? => #items +; +/[#(rest x) for x in items] +; capwhich := capitalize which +; prefix := +; count < 2 => +; names? => pluralSay(count,STRCONC(capwhich," Name"),nil) +; pluralSay(count,capwhich,nil) +; names? => pluralSay(count,nil,STRCONC(capwhich," Names")) +; pluralSay(count,nil,pluralize capwhich) +; [:prefix,'" for ",:heading] + +(DEFUN |dbHeading| + (&REST G174101 &AUX |options| |heading| |which| |items|) + (DSETQ (|items| |which| |heading| . |options|) G174101) + (PROG (|names?| |count| |capwhich| |prefix|) + (RETURN + (SEQ (PROGN + (SPADLET |names?| (IFCAR |options|)) + (SPADLET |count| + (COND + (|names?| (|#| |items|)) + ('T + (PROG (G174082) + (SPADLET G174082 0) + (RETURN + (DO ((G174087 |items| (CDR G174087)) + (|x| NIL)) + ((OR (ATOM G174087) + (PROGN + (SETQ |x| (CAR G174087)) + NIL)) + G174082) + (SEQ (EXIT + (SETQ G174082 + (PLUS G174082 (|#| (CDR |x|)))))))))))) + (SPADLET |capwhich| (|capitalize| |which|)) + (SPADLET |prefix| + (COND + ((> 2 |count|) + (COND + (|names?| + (|pluralSay| |count| + (STRCONC |capwhich| '| Name|) NIL)) + ('T (|pluralSay| |count| |capwhich| NIL)))) + (|names?| + (|pluralSay| |count| NIL + (STRCONC |capwhich| '| Names|))) + ('T + (|pluralSay| |count| NIL + (|pluralize| |capwhich|))))) + (APPEND |prefix| (CONS (MAKESTRING " for ") |heading|))))))) + +;koaPageFilterByCategory1(htPage,i) == +; ancestor := htpProperty(htPage,'ancestors) . i +; ancestorList := [ancestor,:ASSOCLEFT ancestorsOf(ancestor,nil)] +; newOpAlist := nil +; which := htpProperty(htPage,'which) +; opAlist := htpProperty(htPage,'opAlist) +; domname := htpProperty(htPage,'domname) +; conform := htpProperty(htPage,'conform) +; heading := htpProperty(htPage,'heading) +; docTable := dbDocTable(domname or conform) +; for [op,:alist] in opAlist repeat +; nalist := [[origin,:item] for item in alist | split] +; where split == +; [sig,pred,:aux] := item +; u := dbGetDocTable(op,sig,docTable,which,aux) +; origin := IFCAR u +; doc := IFCDR u +; true +; for [origin,:item] in nalist | origin repeat +; MEMBER(origin,ancestorList) => +; newEntry := [item,:LASSOC(op,newOpAlist)] +; newOpAlist := insertAlist(op,newEntry,newOpAlist) +; falist := nil +; for [op,:alist] in newOpAlist repeat +; falist := [[op,:NREVERSE alist],:falist] +; htpSetProperty(htPage,'fromcat,[_ +; '" from category {\sf ",form2HtString ancestor,'"}"]) +; dbShowOperationsFromConform(htPage,which,falist) + +(DEFUN |koaPageFilterByCategory1| (|htPage| |i|) + (PROG (|ancestor| |ancestorList| |which| |opAlist| |domname| + |conform| |heading| |docTable| |sig| |pred| |aux| + |u| |doc| |nalist| |origin| |item| |newEntry| + |newOpAlist| |op| |alist| |falist|) + (RETURN + (SEQ (PROGN + (SPADLET |ancestor| + (ELT (|htpProperty| |htPage| '|ancestors|) |i|)) + (SPADLET |ancestorList| + (CONS |ancestor| + (ASSOCLEFT (|ancestorsOf| |ancestor| NIL)))) + (SPADLET |newOpAlist| NIL) + (SPADLET |which| (|htpProperty| |htPage| '|which|)) + (SPADLET |opAlist| (|htpProperty| |htPage| '|opAlist|)) + (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |heading| (|htpProperty| |htPage| '|heading|)) + (SPADLET |docTable| + (|dbDocTable| (OR |domname| |conform|))) + (DO ((G174145 |opAlist| (CDR G174145)) + (G174118 NIL)) + ((OR (ATOM G174145) + (PROGN (SETQ G174118 (CAR G174145)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G174118)) + (SPADLET |alist| (CDR G174118)) + G174118) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |nalist| + (PROG (G174157) + (SPADLET G174157 NIL) + (RETURN + (DO + ((G174163 |alist| + (CDR G174163)) + (|item| NIL)) + ((OR (ATOM G174163) + (PROGN + (SETQ |item| + (CAR G174163)) + NIL)) + (NREVERSE0 G174157)) + (SEQ + (EXIT + (COND + ((PROGN + (SPADLET |sig| + (CAR |item|)) + (SPADLET |pred| + (CADR |item|)) + (SPADLET |aux| + (CDDR |item|)) + (SPADLET |u| + (|dbGetDocTable| + |op| |sig| + |docTable| |which| + |aux|)) + (SPADLET |origin| + (IFCAR |u|)) + (SPADLET |doc| + (IFCDR |u|)) + 'T) + (SETQ G174157 + (CONS + (CONS |origin| + |item|) + G174157)))))))))) + (SEQ (DO ((G174176 |nalist| + (CDR G174176)) + (G174113 NIL)) + ((OR (ATOM G174176) + (PROGN + (SETQ G174113 + (CAR G174176)) + NIL) + (PROGN + (PROGN + (SPADLET |origin| + (CAR G174113)) + (SPADLET |item| + (CDR G174113)) + G174113) + NIL)) + NIL) + (SEQ + (EXIT + (COND + (|origin| + (COND + ((|member| |origin| + |ancestorList|) + (EXIT + (PROGN + (SPADLET |newEntry| + (CONS |item| + (LASSOC |op| + |newOpAlist|))) + (SPADLET |newOpAlist| + (|insertAlist| |op| + |newEntry| + |newOpAlist|)))))))))))))))) + (SPADLET |falist| NIL) + (DO ((G174187 |newOpAlist| (CDR G174187)) + (G174122 NIL)) + ((OR (ATOM G174187) + (PROGN (SETQ G174122 (CAR G174187)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G174122)) + (SPADLET |alist| (CDR G174122)) + G174122) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |falist| + (CONS (CONS |op| (NREVERSE |alist|)) + |falist|))))) + (|htpSetProperty| |htPage| '|fromcat| + (CONS (MAKESTRING " from category {\\sf ") + (CONS (|form2HtString| |ancestor|) + (CONS (MAKESTRING "}") NIL)))) + (|dbShowOperationsFromConform| |htPage| |which| |falist|)))))) + +;--======================================================================= +;-- New code for search operation alist for exact matches +;--======================================================================= +;opPageFast opAlist == --called by oSearch +; htPage := htInitPage(nil,nil) +; htpSetProperty(htPage,'opAlist,opAlist) +; htpSetProperty(htPage,'expandOperations,'lists) +; which := '"operation" +;--dbResetOpAlistCondition(htPage,which,opAlist) +; dbShowOp1(htPage,opAlist,which,'names) + +(DEFUN |opPageFast| (|opAlist|) + (PROG (|htPage| |which|) + (RETURN + (PROGN + (SPADLET |htPage| (|htInitPage| NIL NIL)) + (|htpSetProperty| |htPage| '|opAlist| |opAlist|) + (|htpSetProperty| |htPage| '|expandOperations| '|lists|) + (SPADLET |which| (MAKESTRING "operation")) + (|dbShowOp1| |htPage| |opAlist| |which| '|names|))))) + +;opPageFastPath opstring == +;--return nil +; x := STRINGIMAGE opstring +; charPosition(char '_*,x,0) < #x => nil --quit if name has * in it +; op := (STRINGP x => INTERN x; x) +; mmList := getAllModemapsFromDatabase(op,nil) or return nil +; opAlist := [[op,:[item for mm in mmList]]] where item == +; [predList, origin, sig] := modemap2Sig(op, mm) +; predicate := predList and MKPF(predList,'AND) +; exposed? := isExposedConstructor opOf origin +; [sig, predicate, origin, exposed?] +; opAlist + +(DEFUN |opPageFastPath| (|opstring|) + (PROG (|x| |op| |mmList| |LETTMP#1| |predList| |origin| |sig| + |predicate| |exposed?| |opAlist|) + (RETURN + (SEQ (PROGN + (SPADLET |x| (STRINGIMAGE |opstring|)) + (COND + ((> (|#| |x|) (|charPosition| (|char| '*) |x| 0)) NIL) + ('T + (SPADLET |op| + (COND ((STRINGP |x|) (INTERN |x|)) ('T |x|))) + (SPADLET |mmList| + (OR (|getAllModemapsFromDatabase| |op| NIL) + (RETURN NIL))) + (SPADLET |opAlist| + (CONS (CONS |op| + (PROG (G174259) + (SPADLET G174259 NIL) + (RETURN + (DO + ((G174271 |mmList| + (CDR G174271)) + (|mm| NIL)) + ((OR (ATOM G174271) + (PROGN + (SETQ |mm| + (CAR G174271)) + NIL)) + (NREVERSE0 G174259)) + (SEQ + (EXIT + (SETQ G174259 + (CONS + (PROGN + (SPADLET |LETTMP#1| + (|modemap2Sig| |op| + |mm|)) + (SPADLET |predList| + (CAR |LETTMP#1|)) + (SPADLET |origin| + (CADR |LETTMP#1|)) + (SPADLET |sig| + (CADDR |LETTMP#1|)) + (SPADLET |predicate| + (AND |predList| + (MKPF |predList| + 'AND))) + (SPADLET |exposed?| + (|isExposedConstructor| + (|opOf| |origin|))) + (CONS |sig| + (CONS |predicate| + (CONS |origin| + (CONS |exposed?| + NIL))))) + G174259)))))))) + NIL)) + |opAlist|))))))) + +;modemap2Sig(op,mm) == +; [dcSig, conds] := mm +; [dc, :sig] := dcSig +; partial? := +; conds is ['partial,:r] => conds := r +; false +; condlist := modemap2SigConds conds +; [origin, vlist, flist] := getDcForm(dc, condlist) or return nil +; subcondlist := SUBLISLIS(flist, vlist, condlist) +; [predList,vlist, flist] := getSigSubst(subcondlist, nil, vlist, flist) +; if partial? then +; target := dcSig . 1 +; ntarget := ['Union, target, '"failed"] +; dcSig := SUBST(ntarget, target, dcSig) +; alist := findSubstitutionOrder? pairlis(vlist, flist) or systemError() +; predList := substInOrder(alist, predList) +; nsig := substInOrder(alist, sig) +; if hasPatternVar nsig or hasPatternVar predList then +; pp '"--------------" +; pp op +; pp predList +; pp nsig +; pp mm +; $badStack := [[op, mm], :$badStack] +;--pause nsig +; [predList, origin, SUBST("%", origin, nsig)] + +(DEFUN |modemap2Sig| (|op| |mm|) + (PROG (|dc| |sig| |r| |conds| |partial?| |condlist| |origin| + |subcondlist| |LETTMP#1| |vlist| |flist| |target| + |ntarget| |dcSig| |alist| |predList| |nsig|) + (declare (special |$badStack|)) + (RETURN + (PROGN + (SPADLET |dcSig| (CAR |mm|)) + (SPADLET |conds| (CADR |mm|)) + (SPADLET |dc| (CAR |dcSig|)) + (SPADLET |sig| (CDR |dcSig|)) + (SPADLET |partial?| + (COND + ((AND (PAIRP |conds|) (EQ (QCAR |conds|) '|partial|) + (PROGN (SPADLET |r| (QCDR |conds|)) 'T)) + (SPADLET |conds| |r|)) + ('T NIL))) + (SPADLET |condlist| (|modemap2SigConds| |conds|)) + (SPADLET |LETTMP#1| + (OR (|getDcForm| |dc| |condlist|) (RETURN NIL))) + (SPADLET |origin| (CAR |LETTMP#1|)) + (SPADLET |vlist| (CADR |LETTMP#1|)) + (SPADLET |flist| (CADDR |LETTMP#1|)) + (SPADLET |subcondlist| (SUBLISLIS |flist| |vlist| |condlist|)) + (SPADLET |LETTMP#1| + (|getSigSubst| |subcondlist| NIL |vlist| |flist|)) + (SPADLET |predList| (CAR |LETTMP#1|)) + (SPADLET |vlist| (CADR |LETTMP#1|)) + (SPADLET |flist| (CADDR |LETTMP#1|)) + (COND + (|partial?| (SPADLET |target| (ELT |dcSig| 1)) + (SPADLET |ntarget| + (CONS '|Union| + (CONS |target| + (CONS (MAKESTRING "failed") NIL)))) + (SPADLET |dcSig| (MSUBST |ntarget| |target| |dcSig|)))) + (SPADLET |alist| + (OR (|findSubstitutionOrder?| + (|pairlis| |vlist| |flist|)) + (|systemError|))) + (SPADLET |predList| (|substInOrder| |alist| |predList|)) + (SPADLET |nsig| (|substInOrder| |alist| |sig|)) + (COND + ((OR (|hasPatternVar| |nsig|) (|hasPatternVar| |predList|)) + (|pp| (MAKESTRING "--------------")) (|pp| |op|) + (|pp| |predList|) (|pp| |nsig|) (|pp| |mm|) + (SPADLET |$badStack| + (CONS (CONS |op| (CONS |mm| NIL)) |$badStack|)))) + (CONS |predList| + (CONS |origin| (CONS (MSUBST '% |origin| |nsig|) NIL))))))) + +;modemap2SigConds conds == +; conds is ['OR,:r] => modemap2SigConds first r +; conds is ['AND,:r] => r +; [conds] + +(DEFUN |modemap2SigConds| (|conds|) + (PROG (|r|) + (RETURN + (COND + ((AND (PAIRP |conds|) (EQ (QCAR |conds|) 'OR) + (PROGN (SPADLET |r| (QCDR |conds|)) 'T)) + (|modemap2SigConds| (CAR |r|))) + ((AND (PAIRP |conds|) (EQ (QCAR |conds|) 'AND) + (PROGN (SPADLET |r| (QCDR |conds|)) 'T)) + |r|) + ('T (CONS |conds| NIL)))))) + +;hasPatternVar x == +; IDENTP x and (x ^= "**") => isPatternVar x +; atom x => false +; or/[hasPatternVar y for y in x] + +(DEFUN |hasPatternVar| (|x|) + (PROG () + (RETURN + (SEQ (COND + ((AND (IDENTP |x|) (NEQUAL |x| '**)) (|isPatternVar| |x|)) + ((ATOM |x|) NIL) + ('T + (PROG (G174353) + (SPADLET G174353 NIL) + (RETURN + (DO ((G174359 NIL G174353) + (G174360 |x| (CDR G174360)) (|y| NIL)) + ((OR G174359 (ATOM G174360) + (PROGN (SETQ |y| (CAR G174360)) NIL)) + G174353) + (SEQ (EXIT (SETQ G174353 + (OR G174353 + (|hasPatternVar| |y|)))))))))))))) + +;getDcForm(dc, condlist) == +; [ofWord,id,cform] := or/[x for x in condlist | x is [k,=dc,:.] +; and MEMQ(k, '(ofCategory isDomain))] or return nil +; conform := getConstructorForm opOf cform +; ofWord = 'ofCategory => +; [conform, ["*1", :rest cform], ["%", :rest conform]] +; ofWord = 'isDomain => +; [conform, ["*1", :rest cform], ["%", :rest conform]] +; systemError() + +(DEFUN |getDcForm| (|dc| |condlist|) + (PROG (|k| |ISTMP#1| |LETTMP#1| |ofWord| |id| |cform| |conform|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| + (OR (PROG (G174389) + (SPADLET G174389 NIL) + (RETURN + (DO ((G174396 NIL G174389) + (G174397 |condlist| + (CDR G174397)) + (|x| NIL)) + ((OR G174396 (ATOM G174397) + (PROGN + (SETQ |x| (CAR G174397)) + NIL)) + G174389) + (SEQ (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |k| (QCAR |x|)) + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) + |dc|))) + (MEMQ |k| + '(|ofCategory| |isDomain|))) + (SETQ G174389 + (OR G174389 |x|))))))))) + (RETURN NIL))) + (SPADLET |ofWord| (CAR |LETTMP#1|)) + (SPADLET |id| (CADR |LETTMP#1|)) + (SPADLET |cform| (CADDR |LETTMP#1|)) + (SPADLET |conform| + (|getConstructorForm| (|opOf| |cform|))) + (COND + ((BOOT-EQUAL |ofWord| '|ofCategory|) + (CONS |conform| + (CONS (CONS '*1 (CDR |cform|)) + (CONS (CONS '% (CDR |conform|)) NIL)))) + ((BOOT-EQUAL |ofWord| '|isDomain|) + (CONS |conform| + (CONS (CONS '*1 (CDR |cform|)) + (CONS (CONS '% (CDR |conform|)) NIL)))) + ('T (|systemError|)))))))) + +;getSigSubst(u, pl, vl, fl) == +; u is [item, :r] => +; item is ['AND,:s] => +; [pl, vl, fl] := getSigSubst(s, pl, vl, fl) +; getSigSubst(r, pl, vl, fl) +; [key, v, f] := item +; key = 'isDomain => getSigSubst(r, pl, [v, :vl], [f, :fl]) +; key = 'ofCategory => getSigSubst(r, pl, ['D, :vl], [f, :fl]) +; key = 'ofType => getSigSubst(r, pl, vl, fl) +; key = 'has => getSigSubst(r, [item, :pl], vl, fl) +; key = 'not => getSigSubst(r, [item, :pl], vl, fl) +; systemError() +; [pl, vl, fl] + +(DEFUN |getSigSubst| (|u| |pl| |vl| |fl|) + (PROG (|item| |r| |s| |LETTMP#1| |key| |v| |f|) + (RETURN + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |item| (QCAR |u|)) + (SPADLET |r| (QCDR |u|)) + 'T)) + (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'AND) + (PROGN (SPADLET |s| (QCDR |item|)) 'T)) + (SPADLET |LETTMP#1| (|getSigSubst| |s| |pl| |vl| |fl|)) + (SPADLET |pl| (CAR |LETTMP#1|)) + (SPADLET |vl| (CADR |LETTMP#1|)) + (SPADLET |fl| (CADDR |LETTMP#1|)) + (|getSigSubst| |r| |pl| |vl| |fl|)) + ('T (SPADLET |key| (CAR |item|)) (SPADLET |v| (CADR |item|)) + (SPADLET |f| (CADDR |item|)) + (COND + ((BOOT-EQUAL |key| '|isDomain|) + (|getSigSubst| |r| |pl| (CONS |v| |vl|) (CONS |f| |fl|))) + ((BOOT-EQUAL |key| '|ofCategory|) + (|getSigSubst| |r| |pl| (CONS 'D |vl|) (CONS |f| |fl|))) + ((BOOT-EQUAL |key| '|ofType|) + (|getSigSubst| |r| |pl| |vl| |fl|)) + ((BOOT-EQUAL |key| '|has|) + (|getSigSubst| |r| (CONS |item| |pl|) |vl| |fl|)) + ((BOOT-EQUAL |key| '|not|) + (|getSigSubst| |r| (CONS |item| |pl|) |vl| |fl|)) + ('T (|systemError|)))))) + ('T (CONS |pl| (CONS |vl| (CONS |fl| NIL)))))))) + +;pairlis(u,v) == +; null u or null v => nil +; [[first u,:first v],:pairlis(rest u, rest v)] + +(DEFUN |pairlis| (|u| |v|) + (COND + ((OR (NULL |u|) (NULL |v|)) NIL) + ('T + (CONS (CONS (CAR |u|) (CAR |v|)) (|pairlis| (CDR |u|) (CDR |v|)))))) + +;--====================> WAS b-search.boot <================================ +;--======================================================================= +;-- Grepping Database libdb.text +;-- Redone 12/95 for Saturn; previous function grep renamed as grepFile +;-- This function now either returns a filename or a list of strings +;--======================================================================= +;grepConstruct(s,key,:options) == --key = a o c d p x k (all) . (aok) w (doc) +;--Called from genSearch with key = "." and "w" +;--key = "." means a o c d p x +;--option1 = true means return the result as a file +;--All searches of the database call this function to get relevant lines +;--from libdb.text. Returns either a list of lines (usual case) or else +;--an alist of the form ((kind . ) ...) +; $localLibdb : local := fnameExists? '"libdb.text" and '"libdb.text" +; lines := grepConstruct1(s,key) +; IFCAR options => grepSplit(lines,key = 'w) --leave now if a constructor +; MEMQ(key,'(o a)) => dbScreenForDefaultFunctions lines --kill default lines if a/o +; lines + +(DEFUN |grepConstruct| (&REST G174459 &AUX |options| |key| |s|) + (DSETQ (|s| |key| . |options|) G174459) + (PROG (|$localLibdb| |lines|) + (DECLARE (SPECIAL |$localLibdb|)) + (RETURN + (PROGN + (SPADLET |$localLibdb| + (AND (|fnameExists?| (MAKESTRING "libdb.text")) + (MAKESTRING "libdb.text"))) + (SPADLET |lines| (|grepConstruct1| |s| |key|)) + (COND + ((IFCAR |options|) + (|grepSplit| |lines| (BOOT-EQUAL |key| '|w|))) + ((MEMQ |key| '(|o| |a|)) + (|dbScreenForDefaultFunctions| |lines|)) + ('T |lines|)))))) + +;grepConstruct1(s,key) == +;--returns the name of file (WITHOUT .text.$SPADNUM on the end) +; $key : local := key +; if key = 'k and --convert 'k to 'y if name contains an "&" +; or/[s . i = char '_& for i in 0..MAXINDEX s] then key := 'y +; filter := pmTransFilter STRINGIMAGE s --parses and-or-not form +; filter is ['error,:.] => filter --exit on parser error +; pattern := mkGrepPattern(filter,key) --create string to pass to "grep" +; grepConstructDo(pattern, key) --do the "grep"---see b-saturn.boot + +(DEFUN |grepConstruct1| (|s| |key|) + (PROG (|$key| |filter| |pattern|) + (DECLARE (SPECIAL |$key|)) + (RETURN + (SEQ (PROGN + (SPADLET |$key| |key|) + (COND + ((AND (BOOT-EQUAL |key| '|k|) + (PROG (G174461) + (SPADLET G174461 NIL) + (RETURN + (DO ((G174467 NIL G174461) + (G174468 (MAXINDEX |s|)) + (|i| 0 (QSADD1 |i|))) + ((OR G174467 (QSGREATERP |i| G174468)) + G174461) + (SEQ (EXIT (SETQ G174461 + (OR G174461 + (BOOT-EQUAL (ELT |s| |i|) + (|char| '&)))))))))) + (SPADLET |key| '|y|))) + (SPADLET |filter| (|pmTransFilter| (STRINGIMAGE |s|))) + (COND + ((AND (PAIRP |filter|) (EQ (QCAR |filter|) '|error|)) + |filter|) + ('T (SPADLET |pattern| (|mkGrepPattern| |filter| |key|)) + (|grepConstructDo| |pattern| |key|)))))))) + +;grepConstructDo(x, key) == +; $orCount := 0 +;--atom x => grepFile(x, key,'i) +; $localLibdb => +; oldLines := purgeNewConstructorLines(grepf(x,key,false),$newConstructorList) +; newLines := grepf(x,$localLibdb,false) +; UNION(oldLines, newLines) +; grepf(x,key,false) + +(DEFUN |grepConstructDo| (|x| |key|) + (PROG (|oldLines| |newLines|) + (declare (special |$orCount| |$localLibdb| |$newConstructorList|)) + (RETURN + (PROGN + (SPADLET |$orCount| 0) + (COND + (|$localLibdb| + (SPADLET |oldLines| + (|purgeNewConstructorLines| + (|grepf| |x| |key| NIL) + |$newConstructorList|)) + (SPADLET |newLines| (|grepf| |x| |$localLibdb| NIL)) + (|union| |oldLines| |newLines|)) + ('T (|grepf| |x| |key| NIL))))))) + +;dbExposed?(line,kind) == -- does line come from an unexposed constructor? +; conname := INTERN +; kind = char 'a or kind = char 'o => dbNewConname line --get conname from middle +; dbName line +; isExposedConstructor conname + +(DEFUN |dbExposed?| (|line| |kind|) + (PROG (|conname|) + (RETURN + (PROGN + (SPADLET |conname| + (INTERN (COND + ((OR (BOOT-EQUAL |kind| (|char| '|a|)) + (BOOT-EQUAL |kind| (|char| '|o|))) + (|dbNewConname| |line|)) + ('T (|dbName| |line|))))) + (|isExposedConstructor| |conname|))))) + +;dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x] + +(DEFUN |dbScreenForDefaultFunctions| (|lines|) + (PROG () + (RETURN + (SEQ (PROG (G174502) + (SPADLET G174502 NIL) + (RETURN + (DO ((G174508 |lines| (CDR G174508)) (|x| NIL)) + ((OR (ATOM G174508) + (PROGN (SETQ |x| (CAR G174508)) NIL)) + (NREVERSE0 G174502)) + (SEQ (EXIT (COND + ((NULL (|isDefaultOpAtt| |x|)) + (SETQ G174502 (CONS |x| G174502))))))))))))) + +;isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char 'x + +(DEFUN |isDefaultOpAtt| (|x|) + (BOOT-EQUAL (ELT |x| (PLUS 1 (|dbTickIndex| |x| 4 0))) (|char| '|x|))) + +;grepForAbbrev(s,key) == +;--checks that filter s is not * and is all uppercase; if so, look for abbrevs +; u := HGET($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first +; s := STRINGIMAGE s +; someLowerCaseChar := false +; someUpperCaseChar := false +; for i in 0..MAXINDEX s repeat +; c := s . i +; LOWER_-CASE_-P c => return (someLowerCaseChar := true) +; UPPER_-CASE_-P c => someUpperCaseChar := true +; someLowerCaseChar or not someUpperCaseChar => false +; pattern := DOWNCASE s +; ['Abbreviations ,:[GETDATABASE(x,'CONSTRUCTORFORM) +; for x in allConstructors() | test]] where test == +; not $includeUnexposed? and not isExposedConstructor x => false +; a := GETDATABASE(x,'ABBREVIATION) +; match?(pattern,PNAME a) and not HGET($defaultPackageNamesHT,x) + +(DEFUN |grepForAbbrev| (|s| |key|) + (declare (ignore |key|)) + (PROG (|u| |c| |someLowerCaseChar| |someUpperCaseChar| |pattern| |a|) + (declare (special |$includeUnexposed?| |$defaultPackageNamesHT| + |$lowerCaseConTb|)) + (RETURN + (SEQ (COND + ((SPADLET |u| (HGET |$lowerCaseConTb| |s|)) + (CONS '|Abbreviations| (CONS |u| NIL))) + ('T (SPADLET |s| (STRINGIMAGE |s|)) + (SPADLET |someLowerCaseChar| NIL) + (SPADLET |someUpperCaseChar| NIL) + (DO ((G174530 (MAXINDEX |s|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G174530) NIL) + (SEQ (EXIT (PROGN + (SPADLET |c| (ELT |s| |i|)) + (COND + ((LOWER-CASE-P |c|) + (RETURN + (SPADLET |someLowerCaseChar| 'T))) + ((UPPER-CASE-P |c|) + (SPADLET |someUpperCaseChar| 'T))))))) + (COND + ((OR |someLowerCaseChar| (NULL |someUpperCaseChar|)) + NIL) + ('T (SPADLET |pattern| (DOWNCASE |s|)) + (CONS '|Abbreviations| + (PROG (G174539) + (SPADLET G174539 NIL) + (RETURN + (DO ((G174545 (|allConstructors|) + (CDR G174545)) + (|x| NIL)) + ((OR (ATOM G174545) + (PROGN + (SETQ |x| (CAR G174545)) + NIL)) + (NREVERSE0 G174539)) + (SEQ (EXIT (COND + ((COND + ((AND + (NULL + |$includeUnexposed?|) + (NULL + (|isExposedConstructor| + |x|))) + NIL) + ('T + (SPADLET |a| + (GETDATABASE |x| + 'ABBREVIATION)) + (AND + (|match?| |pattern| + (PNAME |a|)) + (NULL + (HGET + |$defaultPackageNamesHT| + |x|))))) + (SETQ G174539 + (CONS + (GETDATABASE |x| + 'CONSTRUCTORFORM) + G174539)))))))))))))))))) + +;applyGrep(x,filename) == --OBSELETE with $saturn--> see applyGrepSaturn +; atom x => grepFile(x,filename,'i) +; $localLibdb => +; a := purgeNewConstructorLines(grepf(x,filename,false),$newConstructorList) +; b := grepf(x,$localLibdb,false) +; grepCombine(a,b) +; grepf(x,filename,false) + +(DEFUN |applyGrep| (|x| |filename|) + (PROG (|a| |b|) + (declare (special |$localLibdb| |$newConstructorList|)) + (RETURN + (COND + ((ATOM |x|) (|grepFile| |x| |filename| '|i|)) + (|$localLibdb| + (SPADLET |a| + (|purgeNewConstructorLines| + (|grepf| |x| |filename| NIL) + |$newConstructorList|)) + (SPADLET |b| (|grepf| |x| |$localLibdb| NIL)) + (|grepCombine| |a| |b|)) + ('T (|grepf| |x| |filename| NIL)))))) + +;grepCombine(a,b) == MSORT UNION(a,b) + +(DEFUN |grepCombine| (|a| |b|) (MSORT (|union| |a| |b|))) + +;grepf(pattern,s,not?) == --s=sourceFile or list of strings +; pattern is [op,:argl] => +; op = "and" => +; while argl is [arg,:argl] repeat +; s := grepf(arg,s,not?) -- filter by successive greps +; s +; op = "or" => +; targetStack := nil +; "UNION"/[grepf(arg,s,not?) for arg in argl] +; op = "not" => +; not? => grepf(first argl,s,false) +; --could be the first time so have to get all of same $key +; lines := grepf(mkGrepPattern('"*",$key),s,false) +; grepf(first argl,lines,true) +; systemError nil +; option := +; not? => 'iv +; 'i +; source := +; LISTP s => dbWriteLines s +; s +; grepFile(pattern,source,option) + +(DEFUN |grepf| (|pattern| |s| |not?|) + (PROG (|op| |arg| |argl| |targetStack| |lines| |option| |source|) + (declare (special |$key|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |pattern|) + (PROGN + (SPADLET |op| (QCAR |pattern|)) + (SPADLET |argl| (QCDR |pattern|)) + 'T)) + (COND + ((BOOT-EQUAL |op| '|and|) + (DO () + ((NULL (AND (PAIRP |argl|) + (PROGN + (SPADLET |arg| (QCAR |argl|)) + (SPADLET |argl| (QCDR |argl|)) + 'T))) + NIL) + (SEQ (EXIT (SPADLET |s| (|grepf| |arg| |s| |not?|))))) + |s|) + ((BOOT-EQUAL |op| '|or|) (SPADLET |targetStack| NIL) + (PROG (G174593) + (SPADLET G174593 NIL) + (RETURN + (DO ((G174598 |argl| (CDR G174598)) + (|arg| NIL)) + ((OR (ATOM G174598) + (PROGN (SETQ |arg| (CAR G174598)) NIL)) + G174593) + (SEQ (EXIT (SETQ G174593 + (|union| G174593 + (|grepf| |arg| |s| |not?|))))))))) + ((BOOT-EQUAL |op| '|not|) + (COND + (|not?| (|grepf| (CAR |argl|) |s| NIL)) + ('T + (SPADLET |lines| + (|grepf| (|mkGrepPattern| (MAKESTRING "*") + |$key|) + |s| NIL)) + (|grepf| (CAR |argl|) |lines| 'T)))) + ('T (|systemError| NIL)))) + ('T (SPADLET |option| (COND (|not?| '|iv|) ('T '|i|))) + (SPADLET |source| + (COND + ((LISTP |s|) (|dbWriteLines| |s|)) + ('T |s|))) + (|grepFile| |pattern| |source| |option|))))))) + +;pmTransFilter s == +;--result is either a string or (op ..) where op= and,or,not and arg are results +; if $browseMixedCase = true then s := DOWNCASE s +; or/[isFilterDelimiter? s.i or s.i = $charUnderscore for i in 0..MAXINDEX s] +; => (parse := pmParseFromString s) and checkPmParse parse or +; ['error,'"Illegal search string",'"\vspace{3}\center{{\em Your search string} ",escapeSpecialChars s,'" {\em has incorrect syntax}}"] +; or/[s . i = char '_* and s.(i + 1) = char '_* +; and (i=0 or s . (i - 1) ^= char $charUnderscore) for i in 0..(MAXINDEX s - 1)] +; => ['error,'"Illegal search string",'"\vspace{3}\center{Consecutive {\em *}'s are not allowed in search patterns}"] +; s + +(DEFUN |pmTransFilter| (|s|) + (PROG (|parse|) + (declare (special |$browseMixedCase| |$charUnderscore|)) + (RETURN + (SEQ (PROGN + (COND + ((BOOT-EQUAL |$browseMixedCase| 'T) + (SPADLET |s| (DOWNCASE |s|)))) + (COND + ((PROG (G174618) + (SPADLET G174618 NIL) + (RETURN + (DO ((G174624 NIL G174618) + (G174625 (MAXINDEX |s|)) + (|i| 0 (QSADD1 |i|))) + ((OR G174624 (QSGREATERP |i| G174625)) + G174618) + (SEQ (EXIT (SETQ G174618 + (OR G174618 + (OR + (|isFilterDelimiter?| + (ELT |s| |i|)) + (BOOT-EQUAL (ELT |s| |i|) + |$charUnderscore|))))))))) + (OR (AND (SPADLET |parse| (|pmParseFromString| |s|)) + (|checkPmParse| |parse|)) + (CONS '|error| + (CONS (MAKESTRING "Illegal search string") + (CONS (MAKESTRING + "\\vspace{3}\\center{{\\em Your search string} ") + (CONS (|escapeSpecialChars| |s|) + (CONS + (MAKESTRING + " {\\em has incorrect syntax}}") + NIL))))))) + ((PROG (G174630) + (SPADLET G174630 NIL) + (RETURN + (DO ((G174636 NIL G174630) + (G174637 (SPADDIFFERENCE (MAXINDEX |s|) 1)) + (|i| 0 (QSADD1 |i|))) + ((OR G174636 (QSGREATERP |i| G174637)) + G174630) + (SEQ (EXIT (SETQ G174630 + (OR G174630 + (AND + (BOOT-EQUAL (ELT |s| |i|) + (|char| '*)) + (BOOT-EQUAL + (ELT |s| (PLUS |i| 1)) + (|char| '*)) + (OR (EQL |i| 0) + (NEQUAL + (ELT |s| + (SPADDIFFERENCE |i| 1)) + (|char| |$charUnderscore|))))))))))) + (CONS '|error| + (CONS (MAKESTRING "Illegal search string") + (CONS (MAKESTRING + "\\vspace{3}\\center{Consecutive {\\em *}'s are not allowed in search patterns}") + NIL)))) + ('T |s|))))))) + +;checkPmParse parse == +; STRINGP parse => parse +; fn parse => parse where fn(u) == +; u is [op,:args] => +; MEMQ(op,'(and or not)) and and/[checkPmParse x for x in args] +; STRINGP u => true +; false +; nil + +(DEFUN |checkPmParse,fn| (|u|) + (PROG (|op| |args|) + (RETURN + (SEQ (IF (AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |args| (QCDR |u|)) + 'T)) + (EXIT (AND (MEMQ |op| '(|and| |or| |not|)) + (PROG (G174653) + (SPADLET G174653 'T) + (RETURN + (DO ((G174659 NIL (NULL G174653)) + (G174660 |args| (CDR G174660)) + (|x| NIL)) + ((OR G174659 (ATOM G174660) + (PROGN + (SETQ |x| (CAR G174660)) + NIL)) + G174653) + (SEQ (EXIT + (SETQ G174653 + (AND G174653 + (|checkPmParse| |x|))))))))))) + (IF (STRINGP |u|) (EXIT 'T)) (EXIT NIL))))) + +(DEFUN |checkPmParse| (|parse|) + (COND + ((STRINGP |parse|) |parse|) + ((|checkPmParse,fn| |parse|) |parse|) + ('T NIL))) + +;dnForm x == +; STRINGP x => x +; x is ['not,argl] => +; argl is ['or,:orargs]=> +; ['and, :[dnForm negate u for u in orargs]] where negate s == +; s is ['not,argx] => argx +; ['not,s] +; argl is ['and,:andargs]=> +; ['or,:[dnForm negate u for u in andargs]] +; argl is ['not,notargl]=> +; dnForm notargl +; x +; x is ['or,:argl1] => ['or,:[dnForm u for u in argl1]] +; x is ['and,:argl2] => ['and,:[dnForm u for u in argl2]] +; x + +(DEFUN |dnForm,negate| (|s|) + (PROG (|ISTMP#1| |argx|) + (RETURN + (SEQ (IF (AND (PAIRP |s|) (EQ (QCAR |s|) '|not|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |s|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |argx| (QCAR |ISTMP#1|)) + 'T)))) + (EXIT |argx|)) + (EXIT (CONS '|not| (CONS |s| NIL))))))) + +(DEFUN |dnForm| (|x|) + (PROG (|argl| |orargs| |andargs| |ISTMP#1| |notargl| |argl1| |argl2|) + (RETURN + (SEQ (COND + ((STRINGP |x|) |x|) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|not|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |argl| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((AND (PAIRP |argl|) (EQ (QCAR |argl|) '|or|) + (PROGN (SPADLET |orargs| (QCDR |argl|)) 'T)) + (CONS '|and| + (PROG (G174703) + (SPADLET G174703 NIL) + (RETURN + (DO ((G174708 |orargs| (CDR G174708)) + (|u| NIL)) + ((OR (ATOM G174708) + (PROGN + (SETQ |u| (CAR G174708)) + NIL)) + (NREVERSE0 G174703)) + (SEQ (EXIT (SETQ G174703 + (CONS + (|dnForm| + (|dnForm,negate| |u|)) + G174703))))))))) + ((AND (PAIRP |argl|) (EQ (QCAR |argl|) '|and|) + (PROGN (SPADLET |andargs| (QCDR |argl|)) 'T)) + (CONS '|or| + (PROG (G174718) + (SPADLET G174718 NIL) + (RETURN + (DO ((G174723 |andargs| (CDR G174723)) + (|u| NIL)) + ((OR (ATOM G174723) + (PROGN + (SETQ |u| (CAR G174723)) + NIL)) + (NREVERSE0 G174718)) + (SEQ (EXIT (SETQ G174718 + (CONS + (|dnForm| + (|dnForm,negate| |u|)) + G174718))))))))) + ((AND (PAIRP |argl|) (EQ (QCAR |argl|) '|not|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |argl|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |notargl| (QCAR |ISTMP#1|)) + 'T)))) + (|dnForm| |notargl|)) + ('T |x|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|or|) + (PROGN (SPADLET |argl1| (QCDR |x|)) 'T)) + (CONS '|or| + (PROG (G174733) + (SPADLET G174733 NIL) + (RETURN + (DO ((G174738 |argl1| (CDR G174738)) + (|u| NIL)) + ((OR (ATOM G174738) + (PROGN + (SETQ |u| (CAR G174738)) + NIL)) + (NREVERSE0 G174733)) + (SEQ (EXIT (SETQ G174733 + (CONS (|dnForm| |u|) G174733))))))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|and|) + (PROGN (SPADLET |argl2| (QCDR |x|)) 'T)) + (CONS '|and| + (PROG (G174748) + (SPADLET G174748 NIL) + (RETURN + (DO ((G174753 |argl2| (CDR G174753)) + (|u| NIL)) + ((OR (ATOM G174753) + (PROGN + (SETQ |u| (CAR G174753)) + NIL)) + (NREVERSE0 G174748)) + (SEQ (EXIT (SETQ G174748 + (CONS (|dnForm| |u|) G174748))))))))) + ('T |x|)))))) + +;pmParseFromString s == +; u := ncParseFromString pmPreparse s +; dnForm flatten u where flatten s == +; s is [op,:argl] => +; STRINGP op => STRCONC(op,"STRCONC"/[STRCONC('" ",x) for x in argl]) +; [op,:[flatten x for x in argl]] +; s + +(DEFUN |pmParseFromString,flatten| (|s|) + (PROG (|op| |argl|) + (RETURN + (SEQ (IF (AND (PAIRP |s|) + (PROGN + (SPADLET |op| (QCAR |s|)) + (SPADLET |argl| (QCDR |s|)) + 'T)) + (EXIT (SEQ (IF (STRINGP |op|) + (EXIT (STRCONC |op| + (PROG (G174779) + (SPADLET G174779 "") + (RETURN + (DO + ((G174784 |argl| + (CDR G174784)) + (|x| NIL)) + ((OR (ATOM G174784) + (PROGN + (SETQ |x| + (CAR G174784)) + NIL)) + G174779) + (SEQ + (EXIT + (SETQ G174779 + (STRCONC G174779 + (STRCONC + (MAKESTRING " ") |x|))))))))))) + (EXIT (CONS |op| + (PROG (G174794) + (SPADLET G174794 NIL) + (RETURN + (DO + ((G174799 |argl| + (CDR G174799)) + (|x| NIL)) + ((OR (ATOM G174799) + (PROGN + (SETQ |x| + (CAR G174799)) + NIL)) + (NREVERSE0 G174794)) + (SEQ + (EXIT + (SETQ G174794 + (CONS + (|pmParseFromString,flatten| + |x|) + G174794)))))))))))) + (EXIT |s|))))) + +(DEFUN |pmParseFromString| (|s|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (|ncParseFromString| (|pmPreparse| |s|))) + (|dnForm| (|pmParseFromString,flatten| |u|)))))) + +;pmPreparse s == hn fn(s,0,#s) where--stupid insertion of chars to get correct parse +; hn x == SUBLISLIS('(and or not),'("and" "or" "not"),x) +; fn(s,n,siz) == --main function: s is string, n is origin +; n = siz => '"" +; i := firstNonDelim(s,n) or return SUBSTRING(s,n,nil) +; j := firstDelim(s,i + 1) or siz +; t := gn(s,i,j - 1) +; middle := +; MEMBER(t,'("and" "or" "not")) => t +; --the following 2 lines make commutative("*") parse correctly!!!! +; t.0 = char '_" => t +; j < siz - 1 and s.j = char '_( => t +; STRCONC(char '_",t,char '_") +; STRCONC(SUBSTRING(s,n,i - n),middle,fn(s,j,siz)) +; gn(s,i,j) == --replace each underscore by 4 underscores! +; n := or/[k for k in i..j | s.k = $charUnderscore] => +; STRCONC(SUBSTRING(s,i,n - i + 1),$charUnderscore,gn(s,n + 1,j)) +; SUBSTRING(s,i,j - i + 1) + +(DEFUN |pmPreparse,gn| (|s| |i| |j|) + (PROG (|n|) + (declare (special |$charUnderscore|)) + (RETURN + (SEQ (IF (SPADLET |n| + (PROG (G174821) + (SPADLET G174821 NIL) + (RETURN + (DO ((G174828 NIL G174821) + (|k| |i| (+ |k| 1))) + ((OR G174828 (> |k| |j|)) G174821) + (SEQ (EXIT + (COND + ((BOOT-EQUAL (ELT |s| |k|) + |$charUnderscore|) + (SETQ G174821 + (OR G174821 |k|)))))))))) + (EXIT (STRCONC (SUBSTRING |s| |i| + (PLUS (SPADDIFFERENCE |n| |i|) 1)) + |$charUnderscore| + (|pmPreparse,gn| |s| (PLUS |n| 1) |j|)))) + (EXIT (SUBSTRING |s| |i| (PLUS (SPADDIFFERENCE |j| |i|) 1))))))) + +(DEFUN |pmPreparse,fn| (|s| |n| |siz|) + (PROG (|i| |j| |t| |middle|) + (RETURN + (SEQ (IF (BOOT-EQUAL |n| |siz|) (EXIT (MAKESTRING ""))) + (SPADLET |i| + (OR (|firstNonDelim| |s| |n|) + (RETURN (SUBSTRING |s| |n| NIL)))) + (SPADLET |j| (OR (|firstDelim| |s| (PLUS |i| 1)) |siz|)) + (SPADLET |t| + (|pmPreparse,gn| |s| |i| (SPADDIFFERENCE |j| 1))) + (SPADLET |middle| + (SEQ (IF (|member| |t| '("and" "or" "not")) + (EXIT |t|)) + (IF (BOOT-EQUAL (ELT |t| 0) (|char| '|"|)) + (EXIT |t|)) + (IF (AND (> (SPADDIFFERENCE |siz| 1) |j|) + (BOOT-EQUAL (ELT |s| |j|) + (|char| '|(|))) + (EXIT |t|)) + (EXIT (STRCONC (|char| '|"|) |t| + (|char| '|"|))))) + (EXIT (STRCONC (SUBSTRING |s| |n| (SPADDIFFERENCE |i| |n|)) + |middle| (|pmPreparse,fn| |s| |j| |siz|))))))) + + +(DEFUN |pmPreparse,hn| (|x|) + (SUBLISLIS '(|and| |or| |not|) '("and" "or" "not") |x|)) + +(DEFUN |pmPreparse| (|s|) + (|pmPreparse,hn| (|pmPreparse,fn| |s| 0 (|#| |s|)))) + +;firstNonDelim(s,n) == or/[k for k in n..MAXINDEX s | not isFilterDelimiter? s.k] + +(DEFUN |firstNonDelim| (|s| |n|) + (PROG () + (RETURN + (SEQ (PROG (G174852) + (SPADLET G174852 NIL) + (RETURN + (DO ((G174859 NIL G174852) + (G174860 (MAXINDEX |s|)) (|k| |n| (+ |k| 1))) + ((OR G174859 (> |k| G174860)) G174852) + (SEQ (EXIT (COND + ((NULL (|isFilterDelimiter?| + (ELT |s| |k|))) + (SETQ G174852 (OR G174852 |k|))))))))))))) + +;firstDelim(s,n) == or/[k for k in n..MAXINDEX s | isFilterDelimiter? s.k] + +(DEFUN |firstDelim| (|s| |n|) + (PROG () + (RETURN + (SEQ (PROG (G174869) + (SPADLET G174869 NIL) + (RETURN + (DO ((G174876 NIL G174869) + (G174877 (MAXINDEX |s|)) (|k| |n| (+ |k| 1))) + ((OR G174876 (> |k| G174877)) G174869) + (SEQ (EXIT (COND + ((|isFilterDelimiter?| (ELT |s| |k|)) + (SETQ G174869 (OR G174869 |k|))))))))))))) + +;isFilterDelimiter? c == MEMQ(c,$pmFilterDelimiters) + +(DEFUN |isFilterDelimiter?| (|c|) + (declare (special |$pmFilterDelimiters|)) + (MEMQ |c| |$pmFilterDelimiters|)) + +;grepSplit(lines,doc?) == +; if doc? then +; instream2 := OPEN STRCONC(getEnv '"AXIOM",'"/algebra/libdb.text") +; cons := atts := doms := nil +; while lines is [line, :lines] repeat +; if doc? then +; N:=PARSE_-INTEGER dbPart(line,1,-1) +; if NUMBERP N then +; FILE_-POSITION(instream2,N) +; line := READLINE instream2 +; kind := dbKind line +; not $includeUnexposed? and not dbExposed?(line,kind) => 'skip +; (kind = char 'a or kind = char 'o) and isDefaultOpAtt line => 'skip +; PROGN +; kind = char 'c => cats := insert(line,cats) +; kind = char 'd => doms := insert(line,doms) +; kind = char 'x => defs := insert(line,defs) +; kind = char 'p => paks := insert(line,paks) +; kind = char 'a => atts := insert(line,atts) +; kind = char 'o => ops := insert(line,ops) +; kind = char '_- => 'skip --for now +; systemError 'kind +; if doc? then CLOSE instream2 +; [['"attribute",:NREVERSE atts], +; ['"operation",:NREVERSE ops], +; ['"category",:NREVERSE cats], +; ['"domain",:NREVERSE doms], +; ['"package",:NREVERSE paks] +;-- ['"default_ package",:NREVERSE defs] -- drop defaults +; ] + +(DEFUN |grepSplit| (|lines| |doc?|) + (PROG (|instream2| CONS N |line| |kind| |cats| |doms| |defs| |paks| + |atts| |ops|) + (declare (special |$includeUnexposed?|)) + (RETURN + (SEQ (PROGN + (COND + (|doc?| (SPADLET |instream2| + (OPEN (STRCONC + (|getEnv| (MAKESTRING "AXIOM")) + (MAKESTRING + "/algebra/libdb.text")))))) + (SPADLET CONS (SPADLET |atts| (SPADLET |doms| NIL))) + (DO () + ((NULL (AND (PAIRP |lines|) + (PROGN + (SPADLET |line| (QCAR |lines|)) + (SPADLET |lines| (QCDR |lines|)) + 'T))) + NIL) + (SEQ (EXIT (PROGN + (COND + (|doc?| (SPADLET N + (PARSE-INTEGER + (|dbPart| |line| 1 + (SPADDIFFERENCE 1)))) + (COND + ((NUMBERP N) + (FILE-POSITION |instream2| N) + (SPADLET |line| + (READLINE |instream2|))) + ('T NIL)))) + (SPADLET |kind| (|dbKind| |line|)) + (COND + ((AND (NULL |$includeUnexposed?|) + (NULL (|dbExposed?| |line| |kind|))) + '|skip|) + ((AND (OR + (BOOT-EQUAL |kind| (|char| '|a|)) + (BOOT-EQUAL |kind| (|char| '|o|))) + (|isDefaultOpAtt| |line|)) + '|skip|) + ((BOOT-EQUAL |kind| (|char| '|c|)) + (SPADLET |cats| + (|insert| |line| |cats|))) + ((BOOT-EQUAL |kind| (|char| '|d|)) + (SPADLET |doms| + (|insert| |line| |doms|))) + ((BOOT-EQUAL |kind| (|char| '|x|)) + (SPADLET |defs| + (|insert| |line| |defs|))) + ((BOOT-EQUAL |kind| (|char| '|p|)) + (SPADLET |paks| + (|insert| |line| |paks|))) + ((BOOT-EQUAL |kind| (|char| '|a|)) + (SPADLET |atts| + (|insert| |line| |atts|))) + ((BOOT-EQUAL |kind| (|char| '|o|)) + (SPADLET |ops| (|insert| |line| |ops|))) + ((BOOT-EQUAL |kind| (|char| '-)) '|skip|) + ('T (|systemError| '|kind|))))))) + (COND (|doc?| (CLOSE |instream2|))) + (CONS (CONS (MAKESTRING "attribute") (NREVERSE |atts|)) + (CONS (CONS (MAKESTRING "operation") + (NREVERSE |ops|)) + (CONS (CONS (MAKESTRING "category") + (NREVERSE |cats|)) + (CONS (CONS (MAKESTRING "domain") + (NREVERSE |doms|)) + (CONS + (CONS (MAKESTRING "package") + (NREVERSE |paks|)) + NIL)))))))))) + +;mkUpDownPattern s == recurse(s,0,#s) where +; recurse(s,i,n) == +; i = n => '"" +; STRCONC(fixchar(s.i),recurse(s,i + 1,n)) +; fixchar(c) == +; ALPHA_-CHAR_-P c => +; STRCONC(char '_[,CHAR_-UPCASE c,CHAR_-DOWNCASE c,char '_]) +; c + +(DEFUN |mkUpDownPattern,fixchar| (|c|) + (SEQ (IF (ALPHA-CHAR-P |c|) + (EXIT (STRCONC (|char| '[) (CHAR-UPCASE |c|) + (CHAR-DOWNCASE |c|) (|char| '])))) + (EXIT |c|))) + +(DEFUN |mkUpDownPattern,recurse| (|s| |i| |n|) + (SEQ (IF (BOOT-EQUAL |i| |n|) (EXIT (MAKESTRING ""))) + (EXIT (STRCONC (|mkUpDownPattern,fixchar| (ELT |s| |i|)) + (|mkUpDownPattern,recurse| |s| (PLUS |i| 1) |n|))))) + +(DEFUN |mkUpDownPattern| (|s|) + (|mkUpDownPattern,recurse| |s| 0 (|#| |s|))) + +;mkGrepPattern(s,key) == +; --called by grepConstruct1 and grepf +; atom s => mkGrepPattern1(s,key) +; [first s,:[mkGrepPattern(x,key) for x in rest s]] + +(DEFUN |mkGrepPattern| (|s| |key|) + (PROG () + (RETURN + (SEQ (COND + ((ATOM |s|) (|mkGrepPattern1| |s| |key|)) + ('T + (CONS (CAR |s|) + (PROG (G174941) + (SPADLET G174941 NIL) + (RETURN + (DO ((G174946 (CDR |s|) (CDR G174946)) + (|x| NIL)) + ((OR (ATOM G174946) + (PROGN + (SETQ |x| (CAR G174946)) + NIL)) + (NREVERSE0 G174941)) + (SEQ (EXIT (SETQ G174941 + (CONS (|mkGrepPattern| |x| |key|) + G174941)))))))))))))) + +;mkGrepPattern1(x,:options) == --called by mkGrepPattern (and grepConstructName?) +; $options : local := options +; s := STRINGIMAGE x +;--s := DOWNCASE STRINGIMAGE x +; addOptions remUnderscores addWilds split(g s,char '_*) where +; addWilds sl == --add wild cards (sl is list of parts between *'s) +; IFCAR sl = '"" => h(IFCDR sl,[$wild1]) +; h(sl,nil) +; g s == --remove "*"s around pattern for text match +; not MEMQ('w,$options) => s +; if s.0 = char '_* then s := SUBSTRING(s,1,nil) +; if s.(k := MAXINDEX s) = char '_* then s := SUBSTRING(s,0,k) +; s +; h(sl,res) == --helper for wild cards +; sl is [s,:r] => h(r,[$wild1,s,:res]) +; res := rest res +; if not MEMQ('w,$options) then +; if first res ^= '"" then res := ['"`",:res] +; else if res is [.,p,:r] and p = $wild1 then res := r +; "STRCONC"/NREVERSE res +; remUnderscores s == +; (k := charPosition(char $charUnderscore,s,0)) < MAXINDEX s => +; STRCONC(SUBSTRING(s,0,k),'"[",s.(k + 1),'"]", +; remUnderscores(SUBSTRING(s,k + 2,nil))) +; s +; split(s,char) == +; max := MAXINDEX s + 1 +; f := -1 +; [SUBSTRING(s,i,f-i) +; while ((i := f + 1) <= max) and (f := charPosition(char,s,i))] +; charPosition(c,t,startpos) == --honors underscores +; n := SIZE t +; if startpos < 0 or startpos > n then error "index out of range" +; k:= startpos +; for i in startpos .. n-1 while c ^= ELT(t,i) +; or i > startpos and ELT(t,i-1) = '__ repeat (k := k+1) +; k +; addOptions s == --add front anchor +; --options a o c d p x denote standard items +; --options w means comments +; --option t means text +; --option s means signature +; --option n means number of arguments +; --option i means predicate +; --option none means NO PREFIX +; one := ($options is [x,:$options] and x => x; '"[^x]") +; tick := '"[^`]*`" +; one = 'w => s +; one = 'none => (s = '"`" => '"^."; STRCONC('"^",s)) +; prefix := +; one = 't => STRCONC(tick,tick,tick,tick,tick,".*") +; one = 'n => tick +; one = 'i => STRCONC(tick,tick,tick,tick) +; one = 's => STRCONC(tick,tick,tick) +;-- true => '"" ----> never put on following prefixes +; one = 'k => '"[cdp]" +; one = 'y => '"[cdpx]" +; STRINGIMAGE one +; s = $wild1 => STRCONC('"^",prefix) +; STRCONC('"^",prefix,s) + +(DEFUN |mkGrepPattern1,addOptions| (|s|) + (PROG (|x| |one| |tick| |prefix|) + (declare (special |$options| |$wild1|)) + (RETURN + (SEQ (SPADLET |one| + (SEQ (IF (AND (AND (PAIRP |$options|) + (PROGN + (SPADLET |x| + (QCAR |$options|)) + (SPADLET |$options| + (QCDR |$options|)) + 'T)) + |x|) + (EXIT |x|)) + (EXIT (MAKESTRING "[^x]")))) + (SPADLET |tick| (MAKESTRING "[^`]*`")) + (IF (BOOT-EQUAL |one| '|w|) (EXIT |s|)) + (IF (BOOT-EQUAL |one| '|none|) + (EXIT (SEQ (IF (BOOT-EQUAL |s| (MAKESTRING "`")) + (EXIT (MAKESTRING "^."))) + (EXIT (STRCONC (MAKESTRING "^") |s|))))) + (SPADLET |prefix| + (SEQ (IF (BOOT-EQUAL |one| '|t|) + (EXIT (STRCONC |tick| |tick| |tick| |tick| + |tick| (INTERN ".*" "BOOT")))) + (IF (BOOT-EQUAL |one| '|n|) (EXIT |tick|)) + (IF (BOOT-EQUAL |one| '|i|) + (EXIT (STRCONC |tick| |tick| |tick| + |tick|))) + (IF (BOOT-EQUAL |one| '|s|) + (EXIT (STRCONC |tick| |tick| |tick|))) + (IF (BOOT-EQUAL |one| '|k|) + (EXIT (MAKESTRING "[cdp]"))) + (IF (BOOT-EQUAL |one| '|y|) + (EXIT (MAKESTRING "[cdpx]"))) + (EXIT (STRINGIMAGE |one|)))) + (IF (BOOT-EQUAL |s| |$wild1|) + (EXIT (STRCONC (MAKESTRING "^") |prefix|))) + (EXIT (STRCONC (MAKESTRING "^") |prefix| |s|)))))) + +(DEFUN |mkGrepPattern1,charPosition| (|c| |t| |startpos|) + (PROG (|n| |k|) + (RETURN + (SEQ (SPADLET |n| (SIZE |t|)) + (IF (OR (MINUSP |startpos|) (> |startpos| |n|)) + (|error| '|index out of range|) NIL) + (SPADLET |k| |startpos|) + (DO ((G174993 (SPADDIFFERENCE |n| 1)) + (|i| |startpos| (+ |i| 1))) + ((OR (> |i| G174993) + (NULL (OR (NEQUAL |c| (ELT |t| |i|)) + (AND (> |i| |startpos|) + (BOOT-EQUAL + (ELT |t| (SPADDIFFERENCE |i| 1)) + '_))))) + NIL) + (SEQ (EXIT (SPADLET |k| (PLUS |k| 1))))) + (EXIT |k|))))) + +(DEFUN |mkGrepPattern1,split| (|s| |char|) + (PROG (|max| |i| |f|) + (RETURN + (SEQ (SPADLET |max| (PLUS (MAXINDEX |s|) 1)) + (SPADLET |f| (SPADDIFFERENCE 1)) + (EXIT (PROG (G175010) + (SPADLET G175010 NIL) + (RETURN + (DO () + ((NULL (AND (<= (SPADLET |i| (PLUS |f| 1)) + |max|) + (SPADLET |f| + (|mkGrepPattern1,charPosition| + |char| |s| |i|)))) + (NREVERSE0 G175010)) + (SEQ (EXIT (SETQ G175010 + (CONS + (SUBSTRING |s| |i| + (SPADDIFFERENCE |f| |i|)) + G175010)))))))))))) + +(DEFUN |mkGrepPattern1,remUnderscores| (|s|) + (PROG (|k|) + (declare (special |$charUnderscore|)) + (RETURN + (SEQ (IF (> (MAXINDEX |s|) + (SPADLET |k| + (|mkGrepPattern1,charPosition| + (|char| |$charUnderscore|) |s| 0))) + (EXIT (STRCONC (SUBSTRING |s| 0 |k|) (MAKESTRING "[") + (ELT |s| (PLUS |k| 1)) (MAKESTRING "]") + (|mkGrepPattern1,remUnderscores| + (SUBSTRING |s| (PLUS |k| 2) NIL))))) + (EXIT |s|))))) + +(DEFUN |mkGrepPattern1,h| (|sl| |res|) + (PROG (|s| |ISTMP#1| |p| |r|) + (declare (special |$wild1| |$options|)) + (RETURN + (SEQ (IF (AND (PAIRP |sl|) + (PROGN + (SPADLET |s| (QCAR |sl|)) + (SPADLET |r| (QCDR |sl|)) + 'T)) + (EXIT (|mkGrepPattern1,h| |r| + (CONS |$wild1| (CONS |s| |res|))))) + (SPADLET |res| (CDR |res|)) + (IF (NULL (MEMQ '|w| |$options|)) + (IF (NEQUAL (CAR |res|) (MAKESTRING "")) + (SPADLET |res| (CONS (MAKESTRING "`") |res|)) + (IF (AND (AND (PAIRP |res|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |res|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (BOOT-EQUAL |p| |$wild1|)) + (SPADLET |res| |r|) NIL)) + NIL) + (EXIT (PROG (G175030) + (SPADLET G175030 "") + (RETURN + (DO ((G175035 (NREVERSE |res|) (CDR G175035)) + (G174956 NIL)) + ((OR (ATOM G175035) + (PROGN + (SETQ G174956 (CAR G175035)) + NIL)) + G175030) + (SEQ (EXIT (SETQ G175030 + (STRCONC G175030 G174956)))))))))))) + +(DEFUN |mkGrepPattern1,g| (|s|) + (PROG (|k|) + (declare (special |$options|)) + (RETURN + (SEQ (IF (NULL (MEMQ '|w| |$options|)) (EXIT |s|)) + (IF (BOOT-EQUAL (ELT |s| 0) (|char| '*)) + (SPADLET |s| (SUBSTRING |s| 1 NIL)) NIL) + (IF (BOOT-EQUAL (ELT |s| (SPADLET |k| (MAXINDEX |s|))) + (|char| '*)) + (SPADLET |s| (SUBSTRING |s| 0 |k|)) NIL) + (EXIT |s|))))) + +(DEFUN |mkGrepPattern1,addWilds| (|sl|) + (declare (special |$wild1|)) + (SEQ (IF (BOOT-EQUAL (IFCAR |sl|) (MAKESTRING "")) + (EXIT (|mkGrepPattern1,h| (IFCDR |sl|) (CONS |$wild1| NIL)))) + (EXIT (|mkGrepPattern1,h| |sl| NIL)))) + +(DEFUN |mkGrepPattern1| (&REST G175071 &AUX |options| |x|) + (DSETQ (|x| . |options|) G175071) + (PROG (|$options| |s|) + (DECLARE (SPECIAL |$options|)) + (RETURN + (PROGN + (SPADLET |$options| |options|) + (SPADLET |s| (STRINGIMAGE |x|)) + (|mkGrepPattern1,addOptions| + (|mkGrepPattern1,remUnderscores| + (|mkGrepPattern1,addWilds| + (|mkGrepPattern1,split| (|mkGrepPattern1,g| |s|) + (|char| '*))))))))) + +;conform2OutputForm(form) == +; [op,:args] := form +; null args => form +; cosig := rest GETDATABASE(op,'COSIG) +; atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) +; sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == +; pp [x,atype,pred] +; pred => conform2OutputForm x +; typ := sublisFormal(args,atype) +; if x is ['QUOTE,a] then x := a +; algCoerceInteractive(x,typ,'(OutputForm)) +; [op,:sargl] + +(DEFUN |conform2OutputForm| (|form|) + (PROG (|op| |args| |cosig| |atypes| |typ| |ISTMP#1| |a| |sargl|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |args| (CDR |form|)) + (COND + ((NULL |args|) |form|) + ('T (SPADLET |cosig| (CDR (GETDATABASE |op| 'COSIG))) + (SPADLET |atypes| + (CDR (CDAR (GETDATABASE |op| + 'CONSTRUCTORMODEMAP)))) + (SPADLET |sargl| + (PROG (G175098) + (SPADLET G175098 NIL) + (RETURN + (DO ((G175111 |args| (CDR G175111)) + (|x| NIL) + (G175112 |atypes| (CDR G175112)) + (|atype| NIL) + (G175113 |cosig| (CDR G175113)) + (|pred| NIL)) + ((OR (ATOM G175111) + (PROGN + (SETQ |x| (CAR G175111)) + NIL) + (ATOM G175112) + (PROGN + (SETQ |atype| (CAR G175112)) + NIL) + (ATOM G175113) + (PROGN + (SETQ |pred| (CAR G175113)) + NIL)) + (NREVERSE0 G175098)) + (SEQ (EXIT + (SETQ G175098 + (CONS + (PROGN + (|pp| + (CONS |x| + (CONS |atype| + (CONS |pred| NIL)))) + (COND + (|pred| + (|conform2OutputForm| |x|)) + ('T + (SPADLET |typ| + (|sublisFormal| |args| + |atype|)) + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |x| |a|))) + (|algCoerceInteractive| |x| + |typ| '(|OutputForm|))))) + G175098)))))))) + (CONS |op| |sargl|)))))))) + +;oPage(a,:b) == --called by \spadfun{opname} +; oSearch (IFCAR b or a) --always take slow path + +(DEFUN |oPage| (&REST G175141 &AUX |b| |a|) + (DSETQ (|a| . |b|) G175141) + (|oSearch| (OR (IFCAR |b|) |a|))) + +;oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname} +; htPage := htInitPage(nil,nil) --create empty page and fill in needed properties +; htpSetProperty(htPage,'conform,conform := getConstructorForm conname) +; htpSetProperty(htPage,'kind,STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)) +; itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname" +; null itemlist => systemError [conform,'" has no operation named ",opname] +; opAlist := [itemlist] +; dbShowOperationsFromConform(htPage,'"operation",opAlist) + +(DEFUN |oPageFrom| (|opname| |conname|) + (PROG (|htPage| |conform| |itemlist| |opAlist|) + (RETURN + (PROGN + (SPADLET |htPage| (|htInitPage| NIL NIL)) + (|htpSetProperty| |htPage| '|conform| + (SPADLET |conform| (|getConstructorForm| |conname|))) + (|htpSetProperty| |htPage| '|kind| + (STRINGIMAGE (GETDATABASE |conname| 'CONSTRUCTORKIND))) + (SPADLET |itemlist| (|assoc| |opname| (|koOps| |conform| NIL))) + (COND + ((NULL |itemlist|) + (|systemError| + (CONS |conform| + (CONS (MAKESTRING " has no operation named ") + (CONS |opname| NIL))))) + ('T (SPADLET |opAlist| (CONS |itemlist| NIL)) + (|dbShowOperationsFromConform| |htPage| + (MAKESTRING "operation") |opAlist|))))))) + +;aPage(a,:b) == --called by \spadatt{a} +; $attributeArgs : local := nil +; arg := IFCAR b or a +; s := pmParseFromString STRINGIMAGE arg +; searchOn := +; ATOM s => s +; IFCAR s +; $attributeArgs : local := IFCAR IFCDR s +; aSearch searchOn + +(DEFUN |aPage| (&REST G175164 &AUX |b| |a|) + (DSETQ (|a| . |b|) G175164) + (PROG (|$attributeArgs| |arg| |s| |searchOn|) + (DECLARE (SPECIAL |$attributeArgs|)) + (RETURN + (PROGN + (SPADLET |$attributeArgs| NIL) + (SPADLET |arg| (OR (IFCAR |b|) |a|)) + (SPADLET |s| (|pmParseFromString| (STRINGIMAGE |arg|))) + (SPADLET |searchOn| (COND ((ATOM |s|) |s|) ('T (IFCAR |s|)))) + (SPADLET |$attributeArgs| (IFCAR (IFCDR |s|))) + (|aSearch| |searchOn|))))) + +;--must recognize that not all attributes can be found in database +;--e.g. constant(deriv) is not but appears in a conditional in LODO +;spadType(x) == --called by \spadtype{x} from HyperDoc +; s := PNAME x +; form := ncParseFromString s or +; systemError ['"Argument: ",s,'" to spadType won't parse"] +; if atom form then form := [form] +; op := opOf form +; looksLikeDomainForm form => APPLY(function conPage,form) +; conPage(op) + +(DEFUN |spadType| (|x|) + (PROG (|s| |form| |op|) + (RETURN + (PROGN + (SPADLET |s| (PNAME |x|)) + (SPADLET |form| + (OR (|ncParseFromString| |s|) + (|systemError| + (CONS (MAKESTRING "Argument: ") + (CONS |s| + (CONS + (MAKESTRING + " to spadType won't parse") + NIL)))))) + (COND ((ATOM |form|) (SPADLET |form| (CONS |form| NIL)))) + (SPADLET |op| (|opOf| |form|)) + (COND + ((|looksLikeDomainForm| |form|) + (APPLY (|function| |conPage|) |form|)) + ('T (|conPage| |op|))))))) + +;looksLikeDomainForm x == +; entry := getCDTEntry(opOf x,true) or return false +; coSig := LASSOC('coSig,CDDR entry) +; k := #coSig +; atom x => k = 1 +; k ^= #x => false +; and/[p for key in rest coSig for arg in rest x] where +; p == +; key => looksLikeDomainForm arg +; not IDENTP arg + +(DEFUN |looksLikeDomainForm| (|x|) + (PROG (|entry| |coSig| |k|) + (RETURN + (SEQ (PROGN + (SPADLET |entry| + (OR (|getCDTEntry| (|opOf| |x|) 'T) (RETURN NIL))) + (SPADLET |coSig| (LASSOC '|coSig| (CDDR |entry|))) + (SPADLET |k| (|#| |coSig|)) + (COND + ((ATOM |x|) (EQL |k| 1)) + ((NEQUAL |k| (|#| |x|)) NIL) + ('T + (PROG (G175176) + (SPADLET G175176 'T) + (RETURN + (DO ((G175183 NIL (NULL G175176)) + (G175184 (CDR |coSig|) (CDR G175184)) + (|key| NIL) + (G175185 (CDR |x|) (CDR G175185)) + (|arg| NIL)) + ((OR G175183 (ATOM G175184) + (PROGN (SETQ |key| (CAR G175184)) NIL) + (ATOM G175185) + (PROGN (SETQ |arg| (CAR G175185)) NIL)) + G175176) + (SEQ (EXIT (SETQ G175176 + (AND G175176 + (COND + (|key| + (|looksLikeDomainForm| + |arg|)) + ('T (NULL (IDENTP |arg|)))))))))))))))))) + +;spadSys(x) == --called by \spadsyscom{x} +; s := PNAME x +; if s.0 = char '_) then s := SUBSTRING(s,1,nil) +; form := ncParseFromString s or +; systemError ['"Argument: ",s,'" to spadType won't parse"] +; htSystemCommands PNAME opOf form + +(DEFUN |spadSys| (|x|) + (PROG (|s| |form|) + (RETURN + (PROGN + (SPADLET |s| (PNAME |x|)) + (COND + ((BOOT-EQUAL (ELT |s| 0) (|char| '|)|)) + (SPADLET |s| (SUBSTRING |s| 1 NIL)))) + (SPADLET |form| + (OR (|ncParseFromString| |s|) + (|systemError| + (CONS (MAKESTRING "Argument: ") + (CONS |s| + (CONS + (MAKESTRING + " to spadType won't parse") + NIL)))))) + (|htSystemCommands| (PNAME (|opOf| |form|))))))) + +;--======================================================================= +;-- Name and General Search +;--======================================================================= +;aokSearch filter == genSearch(filter,true) --"General" from HD (see man0.ht) + +(DEFUN |aokSearch| (|filter|) (|genSearch| |filter| 'T)) + +;--General search for constructs but NOT documentation +;genSearch(filter,:options) == --"Complete" from HD (see man0.ht) and aokSearch +;--General + documentation search +; null (filter := checkFilter filter) => nil --in case of filter error +; filter = '"*" => htErrorStar() +; includeDoc? := not IFCAR options +;--give summaries for how many a o c d p x match filter +; regSearchAlist := grepConstruct(STRINGIMAGE filter,".",true) +; regSearchAlist is ['error,:.] => bcErrorPage regSearchAlist +; key := removeSurroundingStars filter +; if includeDoc? then +; docSearchAlist := grepConstruct(key,'w,true) +; docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist +; docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x]--drop defaults +; genSearch1(filter,genSearchTran regSearchAlist,genSearchTran docSearchAlist) + +(DEFUN |genSearch| (&REST G175241 &AUX |options| |filter|) + (DSETQ (|filter| . |options|) G175241) + (PROG (|includeDoc?| |regSearchAlist| |key| |docSearchAlist|) + (RETURN + (SEQ (COND + ((NULL (SPADLET |filter| (|checkFilter| |filter|))) NIL) + ((BOOT-EQUAL |filter| (MAKESTRING "*")) (|htErrorStar|)) + ('T (SPADLET |includeDoc?| (NULL (IFCAR |options|))) + (SPADLET |regSearchAlist| + (|grepConstruct| (STRINGIMAGE |filter|) + (INTERN "." "BOOT") 'T)) + (COND + ((AND (PAIRP |regSearchAlist|) + (EQ (QCAR |regSearchAlist|) '|error|)) + (|bcErrorPage| |regSearchAlist|)) + ('T (SPADLET |key| (|removeSurroundingStars| |filter|)) + (COND + (|includeDoc?| + (SPADLET |docSearchAlist| + (|grepConstruct| |key| '|w| 'T)) + (COND + ((AND (PAIRP |docSearchAlist|) + (EQ (QCAR |docSearchAlist|) '|error|)) + (|bcErrorPage| |docSearchAlist|)) + ('T + (SPADLET |docSearchAlist| + (PROG (G175219) + (SPADLET G175219 NIL) + (RETURN + (DO + ((G175225 |docSearchAlist| + (CDR G175225)) + (|x| NIL)) + ((OR (ATOM G175225) + (PROGN + (SETQ |x| (CAR G175225)) + NIL)) + (NREVERSE0 G175219)) + (SEQ + (EXIT + (COND + ((NEQUAL (ELT |x| 0) + (|char| '|x|)) + (SETQ G175219 + (CONS |x| G175219)))))))))))))) + (|genSearch1| |filter| + (|genSearchTran| |regSearchAlist|) + (|genSearchTran| |docSearchAlist|)))))))))) + +;genSearchTran alist == [[x,y,:y] for [x,:y] in alist] + +(DEFUN |genSearchTran| (|alist|) + (PROG (|x| |y|) + (RETURN + (SEQ (PROG (G175251) + (SPADLET G175251 NIL) + (RETURN + (DO ((G175257 |alist| (CDR G175257)) + (G175242 NIL)) + ((OR (ATOM G175257) + (PROGN (SETQ G175242 (CAR G175257)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G175242)) + (SPADLET |y| (CDR G175242)) + G175242) + NIL)) + (NREVERSE0 G175251)) + (SEQ (EXIT (SETQ G175251 + (CONS (CONS |x| (CONS |y| |y|)) + G175251))))))))))) + +;genSearch1(filter,reg,doc) == +; regSearchAlist := searchDropUnexposedLines reg +; docSearchAlist := searchDropUnexposedLines doc +; key := removeSurroundingStars filter +; regCount := searchCount regSearchAlist +; docCount := searchCount docSearchAlist +; count := regCount + docCount +; count = 0 => emptySearchPage('"entry",filter,true) +; count = 1 => +; alist := (regCount = 1 => regSearchAlist; docSearchAlist) +; showNamedConstruct(or/[x for x in alist | CADR x]) +; summarize? := +; docSearchAlist => true +; nonEmpties := [pair for pair in regSearchAlist | #(CADR pair) > 0] +; not(nonEmpties is [pair]) +; not summarize? => showNamedConstruct pair +; -----------generate a summary page--------------------------- +; plural := +; $exposedOnlyIfTrue => '"exposed entries match" +; '"entries match" +; prefix := pluralSay(count,'"", plural) +; emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] +; header := [:prefix,'" ",:emfilter] +; page := htInitPage(header,nil) +; htpSetProperty(page,'regSearchAlist,regSearchAlist) +; htpSetProperty(page,'docSearchAlist,docSearchAlist) +; htpSetProperty(page,'filter,filter) +; if docSearchAlist then +; dbSayItems(['"{\bf Construct Summary:} ",regCount],'"name matches",'"names match") +; for [kind,:pair] in regSearchAlist for i in 0.. | #(first pair) > 0 repeat +; bcHt '"\newline{}" +; htSayStandard '"\tab{2}" +; genSearchSay(pair,summarize?,kind,i,'showConstruct) +; if docSearchAlist then +; htSaySaturn '"\bigskip{}" +; dbSayItems(['"\newline{\bf Documentation Summary:} ",docCount],'"mention",'"mentions",'" of {\em ",key,'"}") +; for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat +; bcHt "\newline{}" +; htSayStandard '"\tab{2}" +; genSearchSay(pair,true,kind,i,'showDoc) +; htShowPageStar() + +(DEFUN |genSearch1| (|filter| |reg| |doc|) + (PROG (|regSearchAlist| |docSearchAlist| |key| |regCount| |docCount| + |count| |alist| |nonEmpties| |summarize?| |plural| |prefix| + |emfilter| |header| |page| |kind| |pair|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |regSearchAlist| + (|searchDropUnexposedLines| |reg|)) + (SPADLET |docSearchAlist| + (|searchDropUnexposedLines| |doc|)) + (SPADLET |key| (|removeSurroundingStars| |filter|)) + (SPADLET |regCount| (|searchCount| |regSearchAlist|)) + (SPADLET |docCount| (|searchCount| |docSearchAlist|)) + (SPADLET |count| (PLUS |regCount| |docCount|)) + (COND + ((EQL |count| 0) + (|emptySearchPage| (MAKESTRING "entry") |filter| 'T)) + ((EQL |count| 1) + (SPADLET |alist| + (COND + ((EQL |regCount| 1) |regSearchAlist|) + ('T |docSearchAlist|))) + (|showNamedConstruct| + (PROG (G175286) + (SPADLET G175286 NIL) + (RETURN + (DO ((G175293 NIL G175286) + (G175294 |alist| (CDR G175294)) + (|x| NIL)) + ((OR G175293 (ATOM G175294) + (PROGN + (SETQ |x| (CAR G175294)) + NIL)) + G175286) + (SEQ (EXIT (COND + ((CADR |x|) + (SETQ G175286 + (OR G175286 |x|))))))))))) + ('T + (SPADLET |summarize?| + (COND + (|docSearchAlist| 'T) + ('T + (SPADLET |nonEmpties| + (PROG (G175306) + (SPADLET G175306 NIL) + (RETURN + (DO + ((G175312 |regSearchAlist| + (CDR G175312)) + (|pair| NIL)) + ((OR (ATOM G175312) + (PROGN + (SETQ |pair| + (CAR G175312)) + NIL)) + (NREVERSE0 G175306)) + (SEQ + (EXIT + (COND + ((> (|#| (CADR |pair|)) + 0) + (SETQ G175306 + (CONS |pair| + G175306)))))))))) + (NULL (AND (PAIRP |nonEmpties|) + (EQ (QCDR |nonEmpties|) NIL) + (PROGN + (SPADLET |pair| + (QCAR |nonEmpties|)) + 'T)))))) + (COND + ((NULL |summarize?|) (|showNamedConstruct| |pair|)) + ('T + (SPADLET |plural| + (COND + (|$exposedOnlyIfTrue| + (MAKESTRING "exposed entries match")) + ('T (MAKESTRING "entries match")))) + (SPADLET |prefix| + (|pluralSay| |count| (MAKESTRING "") + |plural|)) + (SPADLET |emfilter| + (CONS (MAKESTRING "{\\em ") + (CONS (|escapeSpecialChars| + (STRINGIMAGE |filter|)) + (CONS (MAKESTRING "}") NIL)))) + (SPADLET |header| + (APPEND |prefix| + (CONS (MAKESTRING " ") |emfilter|))) + (SPADLET |page| (|htInitPage| |header| NIL)) + (|htpSetProperty| |page| '|regSearchAlist| + |regSearchAlist|) + (|htpSetProperty| |page| '|docSearchAlist| + |docSearchAlist|) + (|htpSetProperty| |page| '|filter| |filter|) + (COND + (|docSearchAlist| + (|dbSayItems| + (CONS (MAKESTRING + "{\\bf Construct Summary:} ") + (CONS |regCount| NIL)) + (MAKESTRING "name matches") + (MAKESTRING "names match")))) + (DO ((G175327 |regSearchAlist| (CDR G175327)) + (G175275 NIL) (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G175327) + (PROGN + (SETQ G175275 (CAR G175327)) + NIL) + (PROGN + (PROGN + (SPADLET |kind| (CAR G175275)) + (SPADLET |pair| (CDR G175275)) + G175275) + NIL)) + NIL) + (SEQ (EXIT (COND + ((> (|#| (CAR |pair|)) 0) + (PROGN + (|bcHt| + (MAKESTRING "\\newline{}")) + (|htSayStandard| + (MAKESTRING "\\tab{2}")) + (|genSearchSay| |pair| + |summarize?| |kind| |i| + '|showConstruct|))))))) + (COND + (|docSearchAlist| + (|htSaySaturn| (MAKESTRING "\\bigskip{}")) + (|dbSayItems| + (CONS (MAKESTRING + "\\newline{\\bf Documentation Summary:} ") + (CONS |docCount| NIL)) + (MAKESTRING "mention") + (MAKESTRING "mentions") + (MAKESTRING " of {\\em ") |key| + (MAKESTRING "}")) + (DO ((G175343 |docSearchAlist| + (CDR G175343)) + (G175280 NIL) (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G175343) + (PROGN + (SETQ G175280 (CAR G175343)) + NIL) + (PROGN + (PROGN + (SPADLET |kind| (CAR G175280)) + (SPADLET |pair| (CDR G175280)) + G175280) + NIL)) + NIL) + (SEQ (EXIT (COND + ((> (|#| (CAR |pair|)) 0) + (PROGN + (|bcHt| '|\\newline{}|) + (|htSayStandard| + (MAKESTRING "\\tab{2}")) + (|genSearchSay| |pair| 'T + |kind| |i| '|showDoc|))))))))) + (|htShowPageStar|)))))))))) + +;searchDropUnexposedLines alist == +; [[op,[pred for line in lines | pred],:lines] for [op,.,:lines] in alist] where +; pred == +; not $exposedOnlyIfTrue or dbExposed?(line,dbKind line) => line +; nil + +(DEFUN |searchDropUnexposedLines| (|alist|) + (PROG (|op| |lines|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (SEQ (PROG (G175388) + (SPADLET G175388 NIL) + (RETURN + (DO ((G175394 |alist| (CDR G175394)) + (G175375 NIL)) + ((OR (ATOM G175394) + (PROGN (SETQ G175375 (CAR G175394)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G175375)) + (SPADLET |lines| (CDDR G175375)) + G175375) + NIL)) + (NREVERSE0 G175388)) + (SEQ (EXIT (SETQ G175388 + (CONS (CONS |op| + (CONS + (PROG (G175406) + (SPADLET G175406 NIL) + (RETURN + (DO + ((G175412 |lines| + (CDR G175412)) + (|line| NIL)) + ((OR (ATOM G175412) + (PROGN + (SETQ |line| + (CAR G175412)) + NIL)) + (NREVERSE0 G175406)) + (SEQ + (EXIT + (COND + ((COND + ((OR + (NULL + |$exposedOnlyIfTrue|) + (|dbExposed?| + |line| + (|dbKind| + |line|))) + |line|) + ('T NIL)) + (SETQ G175406 + (CONS + (COND + ((OR + (NULL + |$exposedOnlyIfTrue|) + (|dbExposed?| + |line| + (|dbKind| + |line|))) + |line|) + ('T NIL)) + G175406))))))))) + |lines|)) + G175388))))))))))) + +;repeatSearch(htPage,newValue) == +; $exposedOnlyIfTrue := newValue +; filter := htpProperty(htPage,'filter) +; reg := htpProperty(htPage,'regSearchAlist) +; doc := htpProperty(htPage,'docSearchAlist) +; reg => genSearch1(filter,reg,doc) +; docSearch1(filter,doc) + +(DEFUN |repeatSearch| (|htPage| |newValue|) + (PROG (|filter| |reg| |doc|) + (declare (special |$exposedOnlyIfTrue|)) + (RETURN + (PROGN + (SPADLET |$exposedOnlyIfTrue| |newValue|) + (SPADLET |filter| (|htpProperty| |htPage| '|filter|)) + (SPADLET |reg| (|htpProperty| |htPage| '|regSearchAlist|)) + (SPADLET |doc| (|htpProperty| |htPage| '|docSearchAlist|)) + (COND + (|reg| (|genSearch1| |filter| |reg| |doc|)) + ('T (|docSearch1| |filter| |doc|))))))) + +;searchCount u == +/[# y for [x,y,:.] in u] + +(DEFUN |searchCount| (|u|) + (PROG (|x| |y|) + (RETURN + (SEQ (PROG (G175437) + (SPADLET G175437 0) + (RETURN + (DO ((G175443 |u| (CDR G175443)) (G175433 NIL)) + ((OR (ATOM G175443) + (PROGN (SETQ G175433 (CAR G175443)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G175433)) + (SPADLET |y| (CADR G175433)) + G175433) + NIL)) + G175437) + (SEQ (EXIT (SETQ G175437 (PLUS G175437 (|#| |y|)))))))))))) + +;showDoc(htPage,count) == +; showIt(htPage,count,htpProperty(htPage,'docSearchAlist)) + +(DEFUN |showDoc| (|htPage| |count|) + (|showIt| |htPage| |count| + (|htpProperty| |htPage| '|docSearchAlist|))) + +;showConstruct(htPage,count) == +; showIt(htPage,count,htpProperty(htPage,'regSearchAlist)) + +(DEFUN |showConstruct| (|htPage| |count|) + (|showIt| |htPage| |count| + (|htpProperty| |htPage| '|regSearchAlist|))) + +;showIt(htPage,index,searchAlist) == +; filter := htpProperty(htPage,'filter) +; [relativeIndex,n] := DIVIDE(index,8) +; relativeIndex = 0 => showNamedConstruct(searchAlist.n) +; [kind,items,:.] := searchAlist . n +; for j in 1.. while j < relativeIndex repeat items := rest items +; firstName := dbName first items --select name then gather all of same name +; lines := [line for line in items while dbName line = firstName] +; showNamedConstruct [kind,nil,:lines] + +(DEFUN |showIt| (|htPage| |index| |searchAlist|) + (PROG (|filter| |relativeIndex| |n| |LETTMP#1| |kind| |items| + |firstName| |lines|) + (RETURN + (SEQ (PROGN + (SPADLET |filter| (|htpProperty| |htPage| '|filter|)) + (SPADLET |LETTMP#1| (DIVIDE |index| 8)) + (SPADLET |relativeIndex| (CAR |LETTMP#1|)) + (SPADLET |n| (CADR |LETTMP#1|)) + (COND + ((EQL |relativeIndex| 0) + (|showNamedConstruct| (ELT |searchAlist| |n|))) + ('T (SPADLET |LETTMP#1| (ELT |searchAlist| |n|)) + (SPADLET |kind| (CAR |LETTMP#1|)) + (SPADLET |items| (CADR |LETTMP#1|)) + (DO ((|j| 1 (QSADD1 |j|))) + ((NULL (> |relativeIndex| |j|)) NIL) + (SEQ (EXIT (SPADLET |items| (CDR |items|))))) + (SPADLET |firstName| (|dbName| (CAR |items|))) + (SPADLET |lines| + (PROG (G175489) + (SPADLET G175489 NIL) + (RETURN + (DO ((G175495 |items| (CDR G175495)) + (|line| NIL)) + ((OR (ATOM G175495) + (PROGN + (SETQ |line| (CAR G175495)) + NIL) + (NULL + (BOOT-EQUAL (|dbName| |line|) + |firstName|))) + (NREVERSE0 G175489)) + (SEQ (EXIT + (SETQ G175489 + (CONS |line| G175489)))))))) + (|showNamedConstruct| (CONS |kind| (CONS NIL |lines|)))))))))) + +;showNamedConstruct([kind,.,:lines]) == dbSearch(lines,kind,'"") + +(DEFUN |showNamedConstruct| (G175516) + (PROG (|kind| |lines|) + (RETURN + (PROGN + (SPADLET |kind| (CAR G175516)) + (SPADLET |lines| (CDDR G175516)) + (|dbSearch| |lines| |kind| (MAKESTRING "")))))) + +;genSearchSay(pair,summarize,kind,who,fn) == +; [u,:fullLineList] := pair +; count := #u +; uniqueCount := genSearchUniqueCount u +; short := summarize and uniqueCount >= $browseCountThreshold +; htMakePage +; [['bcLinks,[menuButton(),'"",'genSearchSayJump,[fullLineList,kind]]]] +; if count = 0 then htSay('"{\em No ",kind,'"} ") +; else if count = 1 then +; htSay('"{\em 1 ",kind,'"} ") +; else +; htSay('"{\em ",count,'" ",pluralize kind,'"} ") +; short => 'done +; if uniqueCount ^= 1 then +; htSayStandard '"\indent{4}" +; htSay '"\newline " +; htBeginTable() +; lastid := nil +; groups := organizeByName u +; i := 1 +; for group in groups repeat +; id := dbGetName first group +; if $includeUnexposed? then +; exposed? := or/[dbExposed?(item,dbKind item) for item in group] +; bcHt '"{" +; if $includeUnexposed? then +; exposed? => htBlank() +; htSayUnexposed() +; htMakePage [['bcLinks, [id,'"",fn,who + 8*i]]] +; i := i + #group +; bcHt '"}" +; if uniqueCount ^= 1 then +; htEndTable() +; htSayStandard '"\indent{0}" + +(DEFUN |genSearchSay| (|pair| |summarize| |kind| |who| |fn|) + (PROG (|u| |fullLineList| |count| |uniqueCount| |short| |lastid| + |groups| |id| |exposed?| |i|) + (declare (special |$browseCountThreshold| |$includeUnexposed?|)) + (RETURN + (SEQ (PROGN + (SPADLET |u| (CAR |pair|)) + (SPADLET |fullLineList| (CDR |pair|)) + (SPADLET |count| (|#| |u|)) + (SPADLET |uniqueCount| (|genSearchUniqueCount| |u|)) + (SPADLET |short| + (AND |summarize| + (>= |uniqueCount| |$browseCountThreshold|))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (|menuButton|) + (CONS (MAKESTRING "") + (CONS '|genSearchSayJump| + (CONS + (CONS |fullLineList| + (CONS |kind| NIL)) + NIL)))) + NIL)) + NIL)) + (COND + ((EQL |count| 0) + (|htSay| (MAKESTRING "{\\em No ") |kind| + (MAKESTRING "} "))) + ((EQL |count| 1) + (|htSay| (MAKESTRING "{\\em 1 ") |kind| + (MAKESTRING "} "))) + ('T + (|htSay| (MAKESTRING "{\\em ") |count| (MAKESTRING " ") + (|pluralize| |kind|) (MAKESTRING "} ")))) + (COND + (|short| '|done|) + ('T + (COND + ((NEQUAL |uniqueCount| 1) + (|htSayStandard| (MAKESTRING "\\indent{4}")) + (|htSay| (MAKESTRING "\\newline ")) + (|htBeginTable|))) + (SPADLET |lastid| NIL) + (SPADLET |groups| (|organizeByName| |u|)) + (SPADLET |i| 1) + (DO ((G175548 |groups| (CDR G175548)) + (|group| NIL)) + ((OR (ATOM G175548) + (PROGN (SETQ |group| (CAR G175548)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |id| + (|dbGetName| (CAR |group|))) + (COND + (|$includeUnexposed?| + (SPADLET |exposed?| + (PROG (G175554) + (SPADLET G175554 NIL) + (RETURN + (DO + ((G175560 NIL G175554) + (G175561 |group| + (CDR G175561)) + (|item| NIL)) + ((OR G175560 + (ATOM G175561) + (PROGN + (SETQ |item| + (CAR G175561)) + NIL)) + G175554) + (SEQ + (EXIT + (SETQ G175554 + (OR G175554 + (|dbExposed?| |item| + (|dbKind| |item|)))))))))))) + (|bcHt| (MAKESTRING "{")) + (COND + (|$includeUnexposed?| + (COND + (|exposed?| (|htBlank|)) + ('T (|htSayUnexposed|))))) + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |id| + (CONS (MAKESTRING "") + (CONS |fn| + (CONS + (PLUS |who| (TIMES 8 |i|)) + NIL)))) + NIL)) + NIL)) + (SPADLET |i| (PLUS |i| (|#| |group|))) + (|bcHt| (MAKESTRING "}")))))) + (COND + ((NEQUAL |uniqueCount| 1) (|htEndTable|) + (|htSayStandard| (MAKESTRING "\\indent{0}"))) + ('T NIL))))))))) + +;organizeByName u == +; [[(u := rest u; x) while u and head = dbName (x := first u)] +; while u and (head := dbName first u)] + +(DEFUN |organizeByName| (|u|) + (PROG (|head| |x|) + (RETURN + (SEQ (PROG (G175590) + (SPADLET G175590 NIL) + (RETURN + (DO () + ((NULL (AND |u| + (SPADLET |head| (|dbName| (CAR |u|))))) + (NREVERSE0 G175590)) + (SEQ (EXIT (SETQ G175590 + (CONS (PROG (G175606) + (SPADLET G175606 NIL) + (RETURN + (DO () + ((NULL + (AND |u| + (BOOT-EQUAL |head| + (|dbName| + (SPADLET |x| + (CAR |u|)))))) + (NREVERSE0 G175606)) + (SEQ + (EXIT + (SETQ G175606 + (CONS + (PROGN + (SPADLET |u| + (CDR |u|)) + |x|) + G175606))))))) + G175590))))))))))) + +;genSearchSayJump(htPage,[lines,kind]) == +; filter := htpProperty(htPage,'filter) +; dbSearch(lines,kind,filter) + +(DEFUN |genSearchSayJump| (|htPage| G175625) + (PROG (|lines| |kind| |filter|) + (RETURN + (PROGN + (SPADLET |lines| (CAR G175625)) + (SPADLET |kind| (CADR G175625)) + (SPADLET |filter| (|htpProperty| |htPage| '|filter|)) + (|dbSearch| |lines| |kind| |filter|))))) + +;genSearchUniqueCount(u) == +;--count the unique number of items (if less than $browseCountThreshold) +; count := 0 +; lastid := nil +; for item in u while count < $browseCountThreshold repeat +; id := dbGetName item +; if id ^= lastid then +; count := count + 1 +; lastid := id +; count + +(DEFUN |genSearchUniqueCount| (|u|) + (PROG (|id| |count| |lastid|) + (declare (special |$browseCountThreshold|)) + (RETURN + (SEQ (PROGN + (SPADLET |count| 0) + (SPADLET |lastid| NIL) + (DO ((G175649 |u| (CDR G175649)) (|item| NIL)) + ((OR (ATOM G175649) + (PROGN (SETQ |item| (CAR G175649)) NIL) + (NULL (> |$browseCountThreshold| |count|))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |id| (|dbGetName| |item|)) + (COND + ((NEQUAL |id| |lastid|) + (SPADLET |count| (PLUS |count| 1)) + (SPADLET |lastid| |id|)) + ('T NIL)))))) + |count|))))) + +;dbGetName line == SUBSTRING(line,1,charPosition($tick,line,1) - 1) + +(DEFUN |dbGetName| (|line|) + (declare (special |$tick|)) + (SUBSTRING |line| 1 + (SPADDIFFERENCE (|charPosition| |$tick| |line| 1) 1))) + +;pluralSay(count,singular,plural,:options) == +; item := (options is [x,:options] => x; '"") +; colon := (IFCAR options => '":"; '"") +; count = 0 => concat('"No ",singular,item) +; count = 1 => concat('"1 ",singular,item,colon) +; concat(count,'" ",plural,item,colon) + +(DEFUN |pluralSay| + (&REST G175680 &AUX |options| |plural| |singular| |count|) + (DSETQ (|count| |singular| |plural| . |options|) G175680) + (PROG (|x| |item| |colon|) + (RETURN + (PROGN + (SPADLET |item| + (COND + ((AND (PAIRP |options|) + (PROGN + (SPADLET |x| (QCAR |options|)) + (SPADLET |options| (QCDR |options|)) + 'T)) + |x|) + ('T (MAKESTRING "")))) + (SPADLET |colon| + (COND + ((IFCAR |options|) (MAKESTRING ":")) + ('T (MAKESTRING "")))) + (COND + ((EQL |count| 0) + (|concat| (MAKESTRING "No ") |singular| |item|)) + ((EQL |count| 1) + (|concat| (MAKESTRING "1 ") |singular| |item| |colon|)) + ('T + (|concat| |count| (MAKESTRING " ") |plural| |item| |colon|))))))) + +;--======================================================================= +;-- Documentation Search +;--======================================================================= +;docSearch filter == --"Documentation" from HD (see man0.ht) +; null (filter := checkFilter filter) => nil --in case of filter error +; filter = '"*" => htErrorStar() +; key := removeSurroundingStars filter +; docSearchAlist := grepConstruct(filter,'w,true) +; docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist +; docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x] --drop defaults +; docSearch1(filter,genSearchTran docSearchAlist) + +(DEFUN |docSearch| (|filter|) + (PROG (|key| |docSearchAlist|) + (RETURN + (SEQ (COND + ((NULL (SPADLET |filter| (|checkFilter| |filter|))) NIL) + ((BOOT-EQUAL |filter| (MAKESTRING "*")) (|htErrorStar|)) + ('T (SPADLET |key| (|removeSurroundingStars| |filter|)) + (SPADLET |docSearchAlist| + (|grepConstruct| |filter| '|w| 'T)) + (COND + ((AND (PAIRP |docSearchAlist|) + (EQ (QCAR |docSearchAlist|) '|error|)) + (|bcErrorPage| |docSearchAlist|)) + ('T + (SPADLET |docSearchAlist| + (PROG (G175687) + (SPADLET G175687 NIL) + (RETURN + (DO ((G175693 |docSearchAlist| + (CDR G175693)) + (|x| NIL)) + ((OR (ATOM G175693) + (PROGN + (SETQ |x| (CAR G175693)) + NIL)) + (NREVERSE0 G175687)) + (SEQ (EXIT + (COND + ((NEQUAL (ELT |x| 0) + (|char| '|x|)) + (SETQ G175687 + (CONS |x| G175687)))))))))) + (|docSearch1| |filter| + (|genSearchTran| |docSearchAlist|)))))))))) + +;docSearch1(filter,doc) == +; docSearchAlist := searchDropUnexposedLines doc +; count := searchCount docSearchAlist +; count = 0 => emptySearchPage('"entry",filter,true) +; count = 1 => showNamedConstruct(or/[x for x in docSearchAlist | CADR x],1) +; prefix := pluralSay(count,'"entry matches",'"entries match") +; emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] +; header := [:prefix,'" ",:emfilter] +; page := htInitPage(header,nil) +; htpSetProperty(page,'docSearchAlist,docSearchAlist) +; htpSetProperty(page,'regSearchAlist,nil) +; htpSetProperty(page,'filter,filter) +; dbSayItems(['"\newline Documentation Summary: ",count],'"mention",'"mentions",'" of {\em ",filter,'"}") +; for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat +; bcHt '"\newline{}" +; htSayStandard '"\tab{2}" +; genSearchSay(pair,true,kind,i,'showDoc) +; htShowPageStar() + +(DEFUN |docSearch1| (|filter| |doc|) + (PROG (|docSearchAlist| |count| |prefix| |emfilter| |header| |page| + |kind| |pair|) + (RETURN + (SEQ (PROGN + (SPADLET |docSearchAlist| + (|searchDropUnexposedLines| |doc|)) + (SPADLET |count| (|searchCount| |docSearchAlist|)) + (COND + ((EQL |count| 0) + (|emptySearchPage| (MAKESTRING "entry") |filter| 'T)) + ((EQL |count| 1) + (|showNamedConstruct| + (PROG (G175713) + (SPADLET G175713 NIL) + (RETURN + (DO ((G175720 NIL G175713) + (G175721 |docSearchAlist| + (CDR G175721)) + (|x| NIL)) + ((OR G175720 (ATOM G175721) + (PROGN + (SETQ |x| (CAR G175721)) + NIL)) + G175713) + (SEQ (EXIT (COND + ((CADR |x|) + (SETQ G175713 + (OR G175713 |x|))))))))) + 1)) + ('T + (SPADLET |prefix| + (|pluralSay| |count| + (MAKESTRING "entry matches") + (MAKESTRING "entries match"))) + (SPADLET |emfilter| + (CONS (MAKESTRING "{\\em ") + (CONS (|escapeSpecialChars| + (STRINGIMAGE |filter|)) + (CONS (MAKESTRING "}") NIL)))) + (SPADLET |header| + (APPEND |prefix| + (CONS (MAKESTRING " ") |emfilter|))) + (SPADLET |page| (|htInitPage| |header| NIL)) + (|htpSetProperty| |page| '|docSearchAlist| + |docSearchAlist|) + (|htpSetProperty| |page| '|regSearchAlist| NIL) + (|htpSetProperty| |page| '|filter| |filter|) + (|dbSayItems| + (CONS (MAKESTRING + "\\newline Documentation Summary: ") + (CONS |count| NIL)) + (MAKESTRING "mention") (MAKESTRING "mentions") + (MAKESTRING " of {\\em ") |filter| + (MAKESTRING "}")) + (DO ((G175737 |docSearchAlist| (CDR G175737)) + (G175708 NIL) (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G175737) + (PROGN (SETQ G175708 (CAR G175737)) NIL) + (PROGN + (PROGN + (SPADLET |kind| (CAR G175708)) + (SPADLET |pair| (CDR G175708)) + G175708) + NIL)) + NIL) + (SEQ (EXIT (COND + ((> (|#| (CAR |pair|)) 0) + (PROGN + (|bcHt| (MAKESTRING "\\newline{}")) + (|htSayStandard| + (MAKESTRING "\\tab{2}")) + (|genSearchSay| |pair| 'T |kind| |i| + '|showDoc|))))))) + (|htShowPageStar|)))))))) + +;removeSurroundingStars filter == +; key := STRINGIMAGE filter +; if key.0 = char '_* then key := SUBSTRING(key,1,nil) +; if key.(max := MAXINDEX key) = char '_* then key := SUBSTRING(key,0,max) +; key + +(DEFUN |removeSurroundingStars| (|filter|) + (PROG (|max| |key|) + (RETURN + (PROGN + (SPADLET |key| (STRINGIMAGE |filter|)) + (COND + ((BOOT-EQUAL (ELT |key| 0) (|char| '*)) + (SPADLET |key| (SUBSTRING |key| 1 NIL)))) + (COND + ((BOOT-EQUAL (ELT |key| (SPADLET |max| (MAXINDEX |key|))) + (|char| '*)) + (SPADLET |key| (SUBSTRING |key| 0 |max|)))) + |key|)))) + +;showNamedDoc([kind,:lines],index) == +; dbGather(kind,lines,index - 1,true) + +(DEFUN |showNamedDoc| (G175764 |index|) + (PROG (|kind| |lines|) + (RETURN + (PROGN + (SPADLET |kind| (CAR G175764)) + (SPADLET |lines| (CDR G175764)) + (|dbGather| |kind| |lines| (SPADDIFFERENCE |index| 1) 'T))))) + +;sayDocMessage message == +; htSay('"{\em ") +; if message is [leftEnd,left,middle,right,rightEnd] then +; htSay(leftEnd,left,'"}") +; if left ^= '"" and left.(MAXINDEX left) = $blank then htBlank() +; htSay middle +; if right ^= '"" and right.0 = $blank then htBlank() +; htSay('"{\em ",right,rightEnd) +; else +; htSay message +; htSay ('"}") + +(DEFUN |sayDocMessage| (|message|) + (PROG (|leftEnd| |ISTMP#1| |left| |ISTMP#2| |middle| |ISTMP#3| + |right| |ISTMP#4| |rightEnd|) + (declare (special |$blank|)) + (RETURN + (PROGN + (|htSay| (MAKESTRING "{\\em ")) + (COND + ((AND (PAIRP |message|) + (PROGN + (SPADLET |leftEnd| (QCAR |message|)) + (SPADLET |ISTMP#1| (QCDR |message|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |left| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |middle| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |right| + (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |rightEnd| + (QCAR |ISTMP#4|)) + 'T)))))))))) + (|htSay| |leftEnd| |left| (MAKESTRING "}")) + (COND + ((AND (NEQUAL |left| (MAKESTRING "")) + (BOOT-EQUAL (ELT |left| (MAXINDEX |left|)) |$blank|)) + (|htBlank|))) + (|htSay| |middle|) + (COND + ((AND (NEQUAL |right| (MAKESTRING "")) + (BOOT-EQUAL (ELT |right| 0) |$blank|)) + (|htBlank|))) + (|htSay| (MAKESTRING "{\\em ") |right| |rightEnd|)) + ('T (|htSay| |message|))) + (|htSay| (MAKESTRING "}")))))) + +;stripOffSegments(s,n) == +; progress := true +; while n > 0 and progress = true repeat +; n := n - 1 +; k := charPosition(char '_`,s,0) +; new := SUBSTRING(s,k + 1,nil) +; #new < #s => s := new +; progress := false +; n = 0 => s +; nil + +(DEFUN |stripOffSegments| (|s| |n|) + (PROG (|k| |new| |progress|) + (RETURN + (SEQ (PROGN + (SPADLET |progress| 'T) + (DO () + ((NULL (AND (> |n| 0) (BOOT-EQUAL |progress| 'T))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |n| (SPADDIFFERENCE |n| 1)) + (SPADLET |k| + (|charPosition| (|char| '|`|) |s| + 0)) + (SPADLET |new| + (SUBSTRING |s| (PLUS |k| 1) NIL)) + (COND + ((QSLESSP (|#| |new|) (|#| |s|)) + (SPADLET |s| |new|)) + ('T (SPADLET |progress| NIL))))))) + (COND ((EQL |n| 0) |s|) ('T NIL))))))) + +;replaceTicksBySpaces s == +; n := -1 +; max := MAXINDEX s +; while (n := charPosition(char '_`,s,n + 1)) <= max repeat SETELT(s,n,char '_ ) +; s + +(DEFUN |replaceTicksBySpaces| (|s|) + (PROG (|max| |n|) + (RETURN + (SEQ (PROGN + (SPADLET |n| (SPADDIFFERENCE 1)) + (SPADLET |max| (MAXINDEX |s|)) + (DO () + ((NULL (<= (SPADLET |n| + (|charPosition| (|char| '|`|) |s| + (PLUS |n| 1))) + |max|)) + NIL) + (SEQ (EXIT (SETELT |s| |n| (|char| '| |))))) + |s|))))) + +;checkFilter filter == +; filter := STRINGIMAGE filter +; filter = '"" => '"*" +; trimString filter + +(DEFUN |checkFilter| (|filter|) + (PROGN + (SPADLET |filter| (STRINGIMAGE |filter|)) + (COND + ((BOOT-EQUAL |filter| (MAKESTRING "")) (MAKESTRING "*")) + ('T (|trimString| |filter|))))) + +;aSearch filter == --called from HD (man0.ht): general attribute search +; null (filter := checkFilter filter) => nil --in case of filter error +; dbSearch(grepConstruct(filter,'a),'"attribute",filter) + +(DEFUN |aSearch| (|filter|) + (COND + ((NULL (SPADLET |filter| (|checkFilter| |filter|))) NIL) + ('T + (|dbSearch| (|grepConstruct| |filter| '|a|) + (MAKESTRING "attribute") |filter|)))) + +;oSearch filter == -- called from HD (man0.ht): operation search +; opAlist := opPageFastPath filter => opPageFast opAlist +; key := 'o +; null (filter := checkFilter filter) => nil --in case of filter error +; filter = '"*" => grepSearchQuery('"operation",[filter,key,'"operation",'oSearchGrep]) +; oSearchGrep(filter,key,'"operation") + +(DEFUN |oSearch| (|filter|) + (PROG (|opAlist| |key|) + (RETURN + (COND + ((SPADLET |opAlist| (|opPageFastPath| |filter|)) + (|opPageFast| |opAlist|)) + ('T (SPADLET |key| '|o|) + (COND + ((NULL (SPADLET |filter| (|checkFilter| |filter|))) NIL) + ((BOOT-EQUAL |filter| (MAKESTRING "*")) + (|grepSearchQuery| (MAKESTRING "operation") + (CONS |filter| + (CONS |key| + (CONS (MAKESTRING "operation") + (CONS '|oSearchGrep| NIL)))))) + ('T (|oSearchGrep| |filter| |key| (MAKESTRING "operation"))))))))) + +;oSearchGrep(filter,key,kind) == --called from grepSearchQuery/oSearch +; dbSearch(grepConstruct(filter,'o),kind,filter) + +(DEFUN |oSearchGrep| (|filter| |key| |kind|) + (declare (ignore |key|)) + (|dbSearch| (|grepConstruct| |filter| '|o|) |kind| |filter|)) + +;grepSearchQuery(kind,items) == +; page := htInitPage('"Query Page",nil) +; htpSetProperty(page,'items,items) +; htQuery(['"{\em Do you want a list of {\em all} ",pluralize kind,'"?\vspace{1}}"],'grepSearchJump,true) +; htShowPage() + +(DEFUN |grepSearchQuery| (|kind| |items|) + (PROG (|page|) + (RETURN + (PROGN + (SPADLET |page| (|htInitPage| (MAKESTRING "Query Page") NIL)) + (|htpSetProperty| |page| '|items| |items|) + (|htQuery| + (CONS (MAKESTRING + "{\\em Do you want a list of {\\em all} ") + (CONS (|pluralize| |kind|) + (CONS (MAKESTRING "?\\vspace{1}}") NIL))) + '|grepSearchJump| 'T) + (|htShowPage|))))) + +;cSearch filter == --called from HD (man0.ht): category search +; constructorSearch(checkFilter filter,'c,'"category") + +(DEFUN |cSearch| (|filter|) + (|constructorSearch| (|checkFilter| |filter|) '|c| + (MAKESTRING "category"))) + +;dSearch filter == --called from HD (man0.ht): domain search +; constructorSearch(checkFilter filter,'d,'"domain") + +(DEFUN |dSearch| (|filter|) + (|constructorSearch| (|checkFilter| |filter|) '|d| + (MAKESTRING "domain"))) + +;pSearch filter == --called from HD (man0.ht): package search +; constructorSearch(checkFilter filter,'p,'"package") + +(DEFUN |pSearch| (|filter|) + (|constructorSearch| (|checkFilter| |filter|) '|p| + (MAKESTRING "package"))) + +;xSearch filter == --called from HD (man0.ht): default package search +; constructorSearch(checkFilter filter,'x,'"default package") + +(DEFUN |xSearch| (|filter|) + (|constructorSearch| (|checkFilter| |filter|) '|x| + (MAKESTRING "default package"))) + +;kSearch filter == --called from HD (man0.ht): constructor search (no defaults) +; constructorSearch(checkFilter filter,'k,'"constructor") + +(DEFUN |kSearch| (|filter|) + (|constructorSearch| (|checkFilter| |filter|) '|k| + (MAKESTRING "constructor"))) + +;ySearch filter == --called from conPage: like kSearch but defaults included +; constructorSearch(checkFilter filter,'y,'"constructor") + +(DEFUN |ySearch| (|filter|) + (|constructorSearch| (|checkFilter| |filter|) '|y| + (MAKESTRING "constructor"))) + +;constructorSearch(filter,key,kind) == +; null filter => nil --in case of filter error +; (parse := conSpecialString? filter) => conPage parse +; pageName := LASSOC(DOWNCASE filter,'(("union" . DomainUnion)("record" . DomainRecord)("mapping" . DomainMapping) ("enumeration" . DomainEnumeration))) => +; downlink pageName +; name := (STRINGP filter => INTERN filter; filter) +; if u := HGET($lowerCaseConTb,name) then filter := STRINGIMAGE first u +; line := conPageFastPath DOWNCASE filter => +; code := dbKind line +; newkind := +; code = char 'p => '"package" +; code = char 'd => '"domain" +; code = char 'c => '"category" +; nil +; kind = '"constructor" or kind = newkind => kPage line +; page := htInitPage('"Query Page",nil) +; htpSetProperty(page,'line,line) +; message := +; ['"{\em ",dbName line,'"} is not a {\em ",kind,'"} but a {\em ", +; newkind,'"}. Would you like to view it?\vspace{1}"] +; htQuery(message, 'grepConstructorSearch,true) +; htShowPage() +; filter = '"*" => grepSearchQuery(kind,[filter,key,kind,'constructorSearchGrep]) +; constructorSearchGrep(filter,key,kind) + +(DEFUN |constructorSearch| (|filter| |key| |kind|) + (PROG (|parse| |pageName| |name| |u| |line| |code| |newkind| |page| + |message|) + (declare (special |$lowerCaseConTb|)) + (RETURN + (COND + ((NULL |filter|) NIL) + ((SPADLET |parse| (|conSpecialString?| |filter|)) + (|conPage| |parse|)) + ((SPADLET |pageName| + (LASSOC (DOWNCASE |filter|) + '(("union" . |DomainUnion|) + ("record" . |DomainRecord|) + ("mapping" . |DomainMapping|) + ("enumeration" . |DomainEnumeration|)))) + (|downlink| |pageName|)) + ('T + (SPADLET |name| + (COND + ((STRINGP |filter|) (INTERN |filter|)) + ('T |filter|))) + (COND + ((SPADLET |u| (HGET |$lowerCaseConTb| |name|)) + (SPADLET |filter| (STRINGIMAGE (CAR |u|))))) + (COND + ((SPADLET |line| (|conPageFastPath| (DOWNCASE |filter|))) + (SPADLET |code| (|dbKind| |line|)) + (SPADLET |newkind| + (COND + ((BOOT-EQUAL |code| (|char| '|p|)) + (MAKESTRING "package")) + ((BOOT-EQUAL |code| (|char| '|d|)) + (MAKESTRING "domain")) + ((BOOT-EQUAL |code| (|char| '|c|)) + (MAKESTRING "category")) + ('T NIL))) + (COND + ((OR (BOOT-EQUAL |kind| (MAKESTRING "constructor")) + (BOOT-EQUAL |kind| |newkind|)) + (|kPage| |line|)) + ('T + (SPADLET |page| + (|htInitPage| (MAKESTRING "Query Page") NIL)) + (|htpSetProperty| |page| '|line| |line|) + (SPADLET |message| + (CONS (MAKESTRING "{\\em ") + (CONS (|dbName| |line|) + (CONS + (MAKESTRING "} is not a {\\em ") + (CONS |kind| + (CONS + (MAKESTRING "} but a {\\em ") + (CONS |newkind| + (CONS + (MAKESTRING + "}. Would you like to view it?\\vspace{1}") + NIL)))))))) + (|htQuery| |message| '|grepConstructorSearch| 'T) + (|htShowPage|)))) + ((BOOT-EQUAL |filter| (MAKESTRING "*")) + (|grepSearchQuery| |kind| + (CONS |filter| + (CONS |key| + (CONS |kind| + (CONS '|constructorSearchGrep| NIL)))))) + ('T (|constructorSearchGrep| |filter| |key| |kind|)))))))) + +;grepConstructorSearch(htPage,yes) == kPage htpProperty(htPage,'line) + +(DEFUN |grepConstructorSearch| (|htPage| |yes|) + (declare (ignore |yes|)) + (|kPage| (|htpProperty| |htPage| '|line|))) + +;conSpecialString?(filter,:options) == +; secondTime := IFCAR options +; parse := +; words := string2Words filter is [s] => ncParseFromString s +; and/[not MEMBER(x,'("and" "or" "not")) for x in words] => ncParseFromString filter +; false +; null parse => nil +; form := conLowerCaseConTran parse +; MEMQ(KAR form,'(and or not)) or CONTAINED("*",form) => nil +; filter = '"Mapping" =>nil +; u := kisValidType form => u +; secondTime => false +; u := "STRCONC"/[string2Constructor x for x in dbString2Words filter] +; conSpecialString?(u, true) + +(DEFUN |conSpecialString?| (&REST G176005 &AUX |options| |filter|) + (DSETQ (|filter| . |options|) G176005) + (PROG (|secondTime| |ISTMP#1| |s| |words| |parse| |form| |u|) + (RETURN + (SEQ (PROGN + (SPADLET |secondTime| (IFCAR |options|)) + (SPADLET |parse| + (COND + ((SPADLET |words| + (PROGN + (SPADLET |ISTMP#1| + (|string2Words| |filter|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |s| (QCAR |ISTMP#1|)) + 'T)))) + (|ncParseFromString| |s|)) + ((PROG (G175967) + (SPADLET G175967 'T) + (RETURN + (DO ((G175973 NIL (NULL G175967)) + (G175974 |words| (CDR G175974)) + (|x| NIL)) + ((OR G175973 (ATOM G175974) + (PROGN + (SETQ |x| (CAR G175974)) + NIL)) + G175967) + (SEQ (EXIT + (SETQ G175967 + (AND G175967 + (NULL + (|member| |x| + '("and" "or" "not")))))))))) + (|ncParseFromString| |filter|)) + ('T NIL))) + (COND + ((NULL |parse|) NIL) + ('T (SPADLET |form| (|conLowerCaseConTran| |parse|)) + (COND + ((OR (MEMQ (KAR |form|) '(|and| |or| |not|)) + (CONTAINED '* |form|)) + NIL) + ((BOOT-EQUAL |filter| (MAKESTRING "Mapping")) NIL) + ((SPADLET |u| (|kisValidType| |form|)) |u|) + (|secondTime| NIL) + ('T + (SPADLET |u| + (PROG (G175981) + (SPADLET G175981 "") + (RETURN + (DO ((G175986 + (|dbString2Words| |filter|) + (CDR G175986)) + (|x| NIL)) + ((OR (ATOM G175986) + (PROGN + (SETQ |x| (CAR G175986)) + NIL)) + G175981) + (SEQ (EXIT + (SETQ G175981 + (STRCONC G175981 + (|string2Constructor| |x|))))))))) + (|conSpecialString?| |u| 'T)))))))))) + +;dbString2Words l == +; i := 0 +; [w while dbWordFrom(l,i) is [w,i]] + +(DEFUN |dbString2Words| (|l|) + (PROG (|ISTMP#1| |w| |ISTMP#2| |i|) + (RETURN + (SEQ (PROGN + (SPADLET |i| 0) + (PROG (G176027) + (SPADLET G176027 NIL) + (RETURN + (DO () + ((NULL (PROGN + (SPADLET |ISTMP#1| + (|dbWordFrom| |l| |i|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |w| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |i| (QCAR |ISTMP#2|)) + 'T)))))) + (NREVERSE0 G176027)) + (SEQ (EXIT (SETQ G176027 (CONS |w| G176027)))))))))))) + +;$dbDelimiters := [char " " , char "(", char ")"] + +(SPADLET |$dbDelimiters| + (CONS (|char| '| |) + (CONS (|char| '|(|) (CONS (|char| '|)|) NIL)))) + +;dbWordFrom(l,i) == +; maxIndex := MAXINDEX l +; while maxIndex >= i and l.i = char " " repeat i := i + 1 +; if maxIndex >= i and MEMBER(l.i, $dbDelimiters) then return [l.i, i + 1] +; k := or/[j for j in i..maxIndex | not MEMBER(l.j, $dbDelimiters)] or return nil +; buf := '"" +; while k <= maxIndex and not MEMBER(c := l.k, $dbDelimiters) repeat +; ch := +; c = char '__ => l.(k := 1+k) --this may exceed bounds +; c +; buf := STRCONC(buf,ch) +; k := k + 1 +; [buf,k] + +(DEFUN |dbWordFrom| (|l| |i|) + (PROG (|maxIndex| |c| |ch| |buf| |k|) + (declare (special |$dbDelimiters|)) + (RETURN + (SEQ (PROGN + (SPADLET |maxIndex| (MAXINDEX |l|)) + (DO () + ((NULL (AND (>= |maxIndex| |i|) + (BOOT-EQUAL (ELT |l| |i|) (|char| '| |)))) + NIL) + (SEQ (EXIT (SPADLET |i| (PLUS |i| 1))))) + (COND + ((AND (>= |maxIndex| |i|) + (|member| (ELT |l| |i|) |$dbDelimiters|)) + (RETURN (CONS (ELT |l| |i|) (CONS (PLUS |i| 1) NIL))))) + (SPADLET |k| + (OR (PROG (G176053) + (SPADLET G176053 NIL) + (RETURN + (DO ((G176060 NIL G176053) + (|j| |i| (+ |j| 1))) + ((OR G176060 (> |j| |maxIndex|)) + G176053) + (SEQ (EXIT + (COND + ((NULL + (|member| (ELT |l| |j|) + |$dbDelimiters|)) + (SETQ G176053 + (OR G176053 |j|))))))))) + (RETURN NIL))) + (SPADLET |buf| (MAKESTRING "")) + (DO () + ((NULL (AND (<= |k| |maxIndex|) + (NULL (|member| + (SPADLET |c| (ELT |l| |k|)) + |$dbDelimiters|)))) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |ch| + (COND + ((BOOT-EQUAL |c| (|char| '_)) + (ELT |l| + (SPADLET |k| (PLUS 1 |k|)))) + ('T |c|))) + (SPADLET |buf| (STRCONC |buf| |ch|)) + (SPADLET |k| (PLUS |k| 1)))))) + (CONS |buf| (CONS |k| NIL))))))) + +;conLowerCaseConTran x == +; IDENTP x => IFCAR HGET($lowerCaseConTb, x) or x +; atom x => x +; [conLowerCaseConTran y for y in x] + +(DEFUN |conLowerCaseConTran| (|x|) + (PROG () + (declare (special |$lowerCaseConTb|)) + (RETURN + (SEQ (COND + ((IDENTP |x|) + (OR (IFCAR (HGET |$lowerCaseConTb| |x|)) |x|)) + ((ATOM |x|) |x|) + ('T + (PROG (G176092) + (SPADLET G176092 NIL) + (RETURN + (DO ((G176097 |x| (CDR G176097)) (|y| NIL)) + ((OR (ATOM G176097) + (PROGN (SETQ |y| (CAR G176097)) NIL)) + (NREVERSE0 G176092)) + (SEQ (EXIT (SETQ G176092 + (CONS (|conLowerCaseConTran| |y|) + G176092))))))))))))) + +;string2Constructor x == +; not STRINGP x => x +; IFCAR HGET($lowerCaseConTb, INTERN DOWNCASE x) or x + +(DEFUN |string2Constructor| (|x|) + (declare (special |$lowerCaseConTb|)) + (COND + ((NULL (STRINGP |x|)) |x|) + ('T + (OR (IFCAR (HGET |$lowerCaseConTb| (INTERN (DOWNCASE |x|)))) |x|)))) + +;conLowerCaseConTranTryHarder x == +; IDENTP x => IFCAR HGET($lowerCaseConTb,DOWNCASE x) or x +; atom x => x +; [conLowerCaseConTranTryHarder y for y in x] + +(DEFUN |conLowerCaseConTranTryHarder| (|x|) + (PROG () + (declare (special |$lowerCaseConTb|)) + (RETURN + (SEQ (COND + ((IDENTP |x|) + (OR (IFCAR (HGET |$lowerCaseConTb| (DOWNCASE |x|))) |x|)) + ((ATOM |x|) |x|) + ('T + (PROG (G176116) + (SPADLET G176116 NIL) + (RETURN + (DO ((G176121 |x| (CDR G176121)) (|y| NIL)) + ((OR (ATOM G176121) + (PROGN (SETQ |y| (CAR G176121)) NIL)) + (NREVERSE0 G176116)) + (SEQ (EXIT (SETQ G176116 + (CONS + (|conLowerCaseConTranTryHarder| + |y|) + G176116))))))))))))) + +;constructorSearchGrep(filter,key,kind) == +; dbSearch(grepConstruct(filter,key),kind,filter) + +(DEFUN |constructorSearchGrep| (|filter| |key| |kind|) + (|dbSearch| (|grepConstruct| |filter| |key|) |kind| |filter|)) + +;grepSearchJump(htPage,yes) == +; [filter,key,kind,fn] := htpProperty(htPage,'items) +; FUNCALL(fn,filter,key,kind) + +(DEFUN |grepSearchJump| (|htPage| |yes|) + (declare (special |yes|)) + (PROG (|LETTMP#1| |filter| |key| |kind| |fn|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (|htpProperty| |htPage| '|items|)) + (SPADLET |filter| (CAR |LETTMP#1|)) + (SPADLET |key| (CADR |LETTMP#1|)) + (SPADLET |kind| (CADDR |LETTMP#1|)) + (SPADLET |fn| (CADDDR |LETTMP#1|)) + (FUNCALL |fn| |filter| |key| |kind|))))) + +;--======================================================================= +;-- Branch Functions After Database Search +;--======================================================================= +;dbSearch(lines,kind,filter) == --called by attribute, operation, constructor search +; lines is ['error,:.] => bcErrorPage lines +; null filter => nil --means filter error +; lines is ['Abbreviations,:r] => dbSearchAbbrev(lines,kind,filter) +; if MEMBER(kind,'("attribute" "operation")) then --should not be necessary!! +; lines := dbScreenForDefaultFunctions lines +; count := #lines +; count = 0 => emptySearchPage(kind,filter) +; MEMBER(kind,'("attribute" "operation")) => dbShowOperationLines(kind,lines) +; dbShowConstructorLines lines + +(DEFUN |dbSearch| (|lines| |kind| |filter|) + (PROG (|r| |count|) + (RETURN + (COND + ((AND (PAIRP |lines|) (EQ (QCAR |lines|) '|error|)) + (|bcErrorPage| |lines|)) + ((NULL |filter|) NIL) + ((AND (PAIRP |lines|) (EQ (QCAR |lines|) '|Abbreviations|) + (PROGN (SPADLET |r| (QCDR |lines|)) 'T)) + (|dbSearchAbbrev| |lines| |kind| |filter|)) + ('T + (COND + ((|member| |kind| '("attribute" "operation")) + (SPADLET |lines| (|dbScreenForDefaultFunctions| |lines|)))) + (SPADLET |count| (|#| |lines|)) + (COND + ((EQL |count| 0) (|emptySearchPage| |kind| |filter|)) + ((|member| |kind| '("attribute" "operation")) + (|dbShowOperationLines| |kind| |lines|)) + ('T (|dbShowConstructorLines| |lines|)))))))) + +;dbSearchAbbrev([.,:conlist],kind,filter) == +; null conlist => emptySearchPage('"abbreviation",filter) +; kind := intern kind +; if kind ^= 'constructor then +; conlist := [x for x in conlist | LASSOC('kind,IFCDR IFCDR x) = kind] +; conlist is [[nam,:.]] => conPage DOWNCASE nam +; cAlist := [[con,:true] for con in conlist] +; htPage := htInitPage('"",nil) +; htpSetProperty(htPage,'cAlist,cAlist) +; htpSetProperty(htPage,'thing,nil) +; return dbShowCons(htPage,'names) +; page := htInitPage([#conlist, +; '" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil) +; for [nam,abbr,:r] in conlist repeat +; kind := LASSOC('kind,r) +; htSay('"\newline{\em ",s := STRINGIMAGE abbr) +; htSayStandard '"\tab{10}" +; htSay '"}" +; htSay kind +; htSayStandard '"\tab{19}" +; bcCon nam +; htShowPage() + +(DEFUN |dbSearchAbbrev| (G176172 |kind| |filter|) + (PROG (|conlist| |ISTMP#1| |cAlist| |htPage| |page| |nam| |abbr| |r| + |s|) + (RETURN + (SEQ (PROGN + (SPADLET |conlist| (CDR G176172)) + (COND + ((NULL |conlist|) + (|emptySearchPage| (MAKESTRING "abbreviation") + |filter|)) + ('T (SPADLET |kind| (|intern| |kind|)) + (COND + ((NEQUAL |kind| '|constructor|) + (SPADLET |conlist| + (PROG (G176192) + (SPADLET G176192 NIL) + (RETURN + (DO ((G176198 |conlist| + (CDR G176198)) + (|x| NIL)) + ((OR (ATOM G176198) + (PROGN + (SETQ |x| (CAR G176198)) + NIL)) + (NREVERSE0 G176192)) + (SEQ (EXIT + (COND + ((BOOT-EQUAL + (LASSOC '|kind| + (IFCDR (IFCDR |x|))) + |kind|) + (SETQ G176192 + (CONS |x| G176192)))))))))))) + (COND + ((AND (PAIRP |conlist|) (EQ (QCDR |conlist|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |conlist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |nam| (QCAR |ISTMP#1|)) + 'T)))) + (|conPage| (DOWNCASE |nam|))) + ('T + (SPADLET |cAlist| + (PROG (G176208) + (SPADLET G176208 NIL) + (RETURN + (DO ((G176213 |conlist| + (CDR G176213)) + (|con| NIL)) + ((OR (ATOM G176213) + (PROGN + (SETQ |con| (CAR G176213)) + NIL)) + (NREVERSE0 G176208)) + (SEQ (EXIT + (SETQ G176208 + (CONS (CONS |con| 'T) + G176208)))))))) + (SPADLET |htPage| + (|htInitPage| (MAKESTRING "") NIL)) + (|htpSetProperty| |htPage| '|cAlist| |cAlist|) + (|htpSetProperty| |htPage| '|thing| NIL) + (RETURN (|dbShowCons| |htPage| '|names|)) + (SPADLET |page| + (|htInitPage| + (CONS (|#| |conlist|) + (CONS + (MAKESTRING + " Abbreviations Match {\\em ") + (CONS (STRINGIMAGE |filter|) + (CONS (MAKESTRING "}") NIL)))) + NIL)) + (DO ((G176230 |conlist| (CDR G176230)) + (G176166 NIL)) + ((OR (ATOM G176230) + (PROGN + (SETQ G176166 (CAR G176230)) + NIL) + (PROGN + (PROGN + (SPADLET |nam| (CAR G176166)) + (SPADLET |abbr| (CADR G176166)) + (SPADLET |r| (CDDR G176166)) + G176166) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |kind| (LASSOC '|kind| |r|)) + (|htSay| (MAKESTRING + "\\newline{\\em ") + (SPADLET |s| + (STRINGIMAGE |abbr|))) + (|htSayStandard| + (MAKESTRING "\\tab{10}")) + (|htSay| (MAKESTRING "}")) + (|htSay| |kind|) + (|htSayStandard| + (MAKESTRING "\\tab{19}")) + (|bcCon| |nam|))))) + (|htShowPage|)))))))))) + +;--======================================================================= +;-- Selectable Search +;--======================================================================= +;detailedSearch(filter) == +; page := htInitPage('"Detailed Search with Options",nil) +; filter := escapeSpecialChars PNAME filter +; bcHt '"Select what you want to search for, then click on {\em Search} below" +; bcHt '"\newline{\it Note:} Logical searches using {\em and}, {\em or}, and {\em not} are not permitted here." +; htSayHrule() +; htMakePage '( +; (text . "\newline") +; (bcRadioButtons which +; ( "\tab{3}{\em Operations}" +; ((text . "\newline\space{3}") +; (text . "name") (bcStrings (14 "*" opname EM)) +; (text . " \#args") (bcStrings (1 "*" opnargs EM)) +; (text . " signature") (bcStrings (14 "*" opsig EM)) +; (text . "\vspace{1}\newline ")) +; ops) +; ( "\tab{3}{\em Attributes}" +; ((text . "\newline\space{3}") +; (text . "name") (bcStrings (14 "*" attrname EM)) +; (text . " \#args ") (bcStrings (1 "*" attrnargs EM)) +; (text . " arguments ")(bcStrings (14 "*" attrargs EM)) +; (text . "\vspace{1}\newline ")) +; attrs) +; ( "\tab{3}{\em Constructors}" +; ((text . "\tab{17}") +; (bcButtons (1 cats)) (text . " {\em categories} ") +; (bcButtons (1 doms)) (text . " {\em domains} ") +; (bcButtons (1 paks)) (text . " {\em packages} ") +; (bcButtons (1 defs)) (text . " {\em defaults} ") +; (text . "\newline\tab{3}") +; (text . "name") (bcStrings (14 "*" conname EM)) +; (text . " \#args") (bcStrings (1 "*" connargs EM)) +; (text . "signature") (bcStrings (14 "*" consig EM)) +; (text . "\vspace{1}\newline ")) +; cons) +;-- ( "\tab{3}{\em Documentation}" +;-- ((text . "\tab{26}key") +;-- (bcStrings (28 "*" docfilter EM))) +;-- doc) +; ) +; (text . "\vspace{1}\newline\center{ ") +; (bcLinks ("\box{Search}" "" generalSearchDo NIL)) +; (text . "}")) +; htShowPage() + +(DEFUN |detailedSearch| (|filter|) + (PROG (|page|) + (RETURN + (PROGN + (SPADLET |page| + (|htInitPage| + (MAKESTRING "Detailed Search with Options") NIL)) + (SPADLET |filter| (|escapeSpecialChars| (PNAME |filter|))) + (|bcHt| (MAKESTRING + "Select what you want to search for, then click on {\\em Search} below")) + (|bcHt| (MAKESTRING + "\\newline{\\it Note:} Logical searches using {\\em and}, {\\em or}, and {\\em not} are not permitted here.")) + (|htSayHrule|) + (|htMakePage| + '((|text| . "\\newline") + (|bcRadioButtons| |which| + ("\\tab{3}{\\em Operations}" + ((|text| . "\\newline\\space{3}") (|text| . "name") + (|bcStrings| (14 "*" |opname| EM)) + (|text| . " \\#args") + (|bcStrings| (1 "*" |opnargs| EM)) + (|text| . " signature") + (|bcStrings| (14 "*" |opsig| EM)) + (|text| . "\\vspace{1}\\newline ")) + |ops|) + ("\\tab{3}{\\em Attributes}" + ((|text| . "\\newline\\space{3}") (|text| . "name") + (|bcStrings| (14 "*" |attrname| EM)) + (|text| . " \\#args ") + (|bcStrings| (1 "*" |attrnargs| EM)) + (|text| . " arguments ") + (|bcStrings| (14 "*" |attrargs| EM)) + (|text| . "\\vspace{1}\\newline ")) + |attrs|) + ("\\tab{3}{\\em Constructors}" + ((|text| . "\\tab{17}") (|bcButtons| (1 |cats|)) + (|text| . " {\\em categories} ") + (|bcButtons| (1 |doms|)) + (|text| . " {\\em domains} ") + (|bcButtons| (1 |paks|)) + (|text| . " {\\em packages} ") + (|bcButtons| (1 |defs|)) + (|text| . " {\\em defaults} ") + (|text| . "\\newline\\tab{3}") (|text| . "name") + (|bcStrings| (14 "*" |conname| EM)) + (|text| . " \\#args") + (|bcStrings| (1 "*" |connargs| EM)) + (|text| . "signature") + (|bcStrings| (14 "*" |consig| EM)) + (|text| . "\\vspace{1}\\newline ")) + |cons|)) + (|text| . "\\vspace{1}\\newline\\center{ ") + (|bcLinks| ("\\box{Search}" "" |generalSearchDo| NIL)) + (|text| . "}"))) + (|htShowPage|))))) + +;generalSearchDo(htPage,flag) == +;--$exposedOnlyIfTrue := (flag => 'T; nil) +; $htPage := htPage +; alist := htpInputAreaAlist htPage +; which := htpButtonValue(htPage,'which) +; selectors := +; which = 'cons => '(conname connargs consig) +; which = 'ops => '(opname opnargs opsig) +; '(attrname attrnargs attrargs) +; name := generalSearchString(htPage,selectors.0) +; nargs:= generalSearchString(htPage,selectors.1) +; npat := standardizeSignature generalSearchString(htPage,selectors.2) +; kindCode := +; which = 'ops => char 'o +; which = 'attrs => char 'a +; acc := '"" +; if htButtonOn?(htPage,'cats) then acc := STRCONC(char 'c,acc) +; if htButtonOn?(htPage,'doms) then acc := STRCONC(char 'd,acc) +; if htButtonOn?(htPage,'paks) then acc := STRCONC(char 'p,acc) +; if htButtonOn?(htPage,'defs) then acc := STRCONC(char 'x,acc) +; n := #acc +; n = 0 or n = 4 => '"[cdpx]" +; n = 1 => acc +; STRCONC(char '_[,acc,char '_]) +; form := mkDetailedGrepPattern(kindCode,name,nargs,npat) +; lines := applyGrep(form,'libdb) +;--lines := dbReadLines resultFile +; if MEMQ(which,'(ops attrs)) then lines := dbScreenForDefaultFunctions lines +; kind := +; which = 'cons => +; n = 1 => +; htButtonOn?(htPage,'cats) => '"category" +; htButtonOn?(htPage,'doms) => '"domain" +; htButtonOn?(htPage,'paks) => '"package" +; '"default package" +; '"constructor" +; which = 'ops => '"operation" +; '"attribute" +; null lines => emptySearchPage(kind,nil) +; dbSearch(lines,kind,'"filter") + +(DEFUN |generalSearchDo| (|htPage| |flag|) + (declare (ignore |flag|)) + (PROG (|alist| |which| |selectors| |name| |nargs| |npat| |acc| |n| + |kindCode| |form| |lines| |kind|) + (declare (special |$htPage|)) + (RETURN + (PROGN + (SPADLET |$htPage| |htPage|) + (SPADLET |alist| (|htpInputAreaAlist| |htPage|)) + (SPADLET |which| (|htpButtonValue| |htPage| '|which|)) + (SPADLET |selectors| + (COND + ((BOOT-EQUAL |which| '|cons|) + '(|conname| |connargs| |consig|)) + ((BOOT-EQUAL |which| '|ops|) + '(|opname| |opnargs| |opsig|)) + ('T '(|attrname| |attrnargs| |attrargs|)))) + (SPADLET |name| + (|generalSearchString| |htPage| (ELT |selectors| 0))) + (SPADLET |nargs| + (|generalSearchString| |htPage| (ELT |selectors| 1))) + (SPADLET |npat| + (|standardizeSignature| + (|generalSearchString| |htPage| + (ELT |selectors| 2)))) + (SPADLET |kindCode| + (COND + ((BOOT-EQUAL |which| '|ops|) (|char| '|o|)) + ((BOOT-EQUAL |which| '|attrs|) (|char| '|a|)) + ('T (SPADLET |acc| (MAKESTRING "")) + (COND + ((|htButtonOn?| |htPage| '|cats|) + (SPADLET |acc| (STRCONC (|char| '|c|) |acc|)))) + (COND + ((|htButtonOn?| |htPage| '|doms|) + (SPADLET |acc| (STRCONC (|char| '|d|) |acc|)))) + (COND + ((|htButtonOn?| |htPage| '|paks|) + (SPADLET |acc| (STRCONC (|char| '|p|) |acc|)))) + (COND + ((|htButtonOn?| |htPage| '|defs|) + (SPADLET |acc| (STRCONC (|char| '|x|) |acc|)))) + (SPADLET |n| (|#| |acc|)) + (COND + ((OR (EQL |n| 0) (EQL |n| 4)) + (MAKESTRING "[cdpx]")) + ((EQL |n| 1) |acc|) + ('T (STRCONC (|char| '[) |acc| (|char| ']))))))) + (SPADLET |form| + (|mkDetailedGrepPattern| |kindCode| |name| |nargs| + |npat|)) + (SPADLET |lines| (|applyGrep| |form| '|libdb|)) + (COND + ((MEMQ |which| '(|ops| |attrs|)) + (SPADLET |lines| (|dbScreenForDefaultFunctions| |lines|)))) + (SPADLET |kind| + (COND + ((BOOT-EQUAL |which| '|cons|) + (COND + ((EQL |n| 1) + (COND + ((|htButtonOn?| |htPage| '|cats|) + (MAKESTRING "category")) + ((|htButtonOn?| |htPage| '|doms|) + (MAKESTRING "domain")) + ((|htButtonOn?| |htPage| '|paks|) + (MAKESTRING "package")) + ('T (MAKESTRING "default package")))) + ('T (MAKESTRING "constructor")))) + ((BOOT-EQUAL |which| '|ops|) + (MAKESTRING "operation")) + ('T (MAKESTRING "attribute")))) + (COND + ((NULL |lines|) (|emptySearchPage| |kind| NIL)) + ('T (|dbSearch| |lines| |kind| (MAKESTRING "filter")))))))) + +;generalSearchString(htPage,sel) == +; string := htpLabelInputString(htPage,sel) +; string = '"" => '"*" +; string + +(DEFUN |generalSearchString| (|htPage| |sel|) + (PROG (|string|) + (RETURN + (PROGN + (SPADLET |string| (|htpLabelInputString| |htPage| |sel|)) + (COND + ((BOOT-EQUAL |string| (MAKESTRING "")) (MAKESTRING "*")) + ('T |string|)))))) + +;htButtonOn?(htPage,key) == +; LASSOC(key,htpInputAreaAlist htPage) is [a,:.] and a = '" t" + +(DEFUN |htButtonOn?| (|htPage| |key|) + (PROG (|ISTMP#1| |a|) + (RETURN + (AND (PROGN + (SPADLET |ISTMP#1| + (LASSOC |key| (|htpInputAreaAlist| |htPage|))) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) + (BOOT-EQUAL |a| (MAKESTRING " t")))))) + +;mkDetailedGrepPattern(kind,name,nargs,argOrSig) == main where +; main == +; nottick := '"[^`]" +; name := replaceGrepStar name +; firstPart := +; $saturn => STRCONC(char '_^,name) +; STRCONC(char '_^,kind,name) +; nargsPart := replaceGrepStar nargs +; exposedPart := char '_. --always get exposed/unexposed +; patPart := replaceGrepStar argOrSig +; simp STRCONC(conc(firstPart,conc(nargsPart,conc(exposedPart, patPart))),$tick) +; conc(a,b) == +; b = '"[^`]*" or b = char '_. => a +; STRCONC(a,$tick,b) +; simp a == +; m := MAXINDEX a +; m > 6 and a.(m-5) = char '_[ and a.(m-4) = char '_^ +; and a.(m-3) = $tick and a.(m-2) = char '_] +; and a.(m-1) = char '_* and a.m = $tick +; => simp SUBSTRING(a,0,m-5) +; a + +(DEFUN |mkDetailedGrepPattern,simp| (|a|) + (PROG (|m|) + (declare (special |$tick|)) + (RETURN + (SEQ (SPADLET |m| (MAXINDEX |a|)) + (IF (AND (AND (AND (AND (AND + (AND (> |m| 6) + (BOOT-EQUAL + (ELT |a| (SPADDIFFERENCE |m| 5)) + (|char| '[))) + (BOOT-EQUAL + (ELT |a| (SPADDIFFERENCE |m| 4)) + (|char| '^))) + (BOOT-EQUAL + (ELT |a| (SPADDIFFERENCE |m| 3)) + |$tick|)) + (BOOT-EQUAL + (ELT |a| (SPADDIFFERENCE |m| 2)) + (|char| ']))) + (BOOT-EQUAL (ELT |a| (SPADDIFFERENCE |m| 1)) + (|char| '*))) + (BOOT-EQUAL (ELT |a| |m|) |$tick|)) + (EXIT (|mkDetailedGrepPattern,simp| + (SUBSTRING |a| 0 (SPADDIFFERENCE |m| 5))))) + (EXIT |a|))))) + +(DEFUN |mkDetailedGrepPattern,conc| (|a| |b|) + (declare (special |$tick|)) + (SEQ (IF (OR (BOOT-EQUAL |b| (MAKESTRING "[^`]*")) + (BOOT-EQUAL |b| (|char| (INTERN "." "BOOT")))) + (EXIT |a|)) + (EXIT (STRCONC |a| |$tick| |b|)))) + +(DEFUN |mkDetailedGrepPattern| (|kind| |name| |nargs| |argOrSig|) + (PROG (|nottick| |firstPart| |nargsPart| |exposedPart| |patPart|) + (declare (special |$saturn| |$tick|)) + (RETURN + (PROGN + (SPADLET |nottick| (MAKESTRING "[^`]")) + (SPADLET |name| (|replaceGrepStar| |name|)) + (SPADLET |firstPart| + (COND + (|$saturn| (STRCONC (|char| '^) |name|)) + ('T (STRCONC (|char| '^) |kind| |name|)))) + (SPADLET |nargsPart| (|replaceGrepStar| |nargs|)) + (SPADLET |exposedPart| (|char| (INTERN "." "BOOT"))) + (SPADLET |patPart| (|replaceGrepStar| |argOrSig|)) + (|mkDetailedGrepPattern,simp| + (STRCONC (|mkDetailedGrepPattern,conc| |firstPart| + (|mkDetailedGrepPattern,conc| |nargsPart| + (|mkDetailedGrepPattern,conc| + |exposedPart| |patPart|))) + |$tick|)))))) + +;replaceGrepStar s == +; s = "" => s +; final := MAXINDEX s +; i := charPosition(char '_*,s,0) +; i > final => s +; STRCONC(SUBSTRING(s,0,i),'"[^`]*",replaceGrepStar SUBSTRING(s,i + 1,nil)) + +(DEFUN |replaceGrepStar| (|s|) + (PROG (|final| |i|) + (RETURN + (COND + ((BOOT-EQUAL |s| '||) |s|) + ('T (SPADLET |final| (MAXINDEX |s|)) + (SPADLET |i| (|charPosition| (|char| '*) |s| 0)) + (COND + ((> |i| |final|) |s|) + ('T + (STRCONC (SUBSTRING |s| 0 |i|) (MAKESTRING "[^`]*") + (|replaceGrepStar| + (SUBSTRING |s| (PLUS |i| 1) NIL)))))))))) + +;standardizeSignature(s) == underscoreDollars +; s.0 = char '_( => s +; k := STRPOS('"->",s,0,nil) or return s --will fail except perhaps on constants +; s.(k - 1) = char '_) => STRCONC(char '_(,s) +; STRCONC(char '_(,SUBSTRING(s,0,k),char '_),SUBSTRING(s,k,nil)) + +(DEFUN |standardizeSignature| (|s|) + (PROG (|k|) + (RETURN + (|underscoreDollars| + (COND + ((BOOT-EQUAL (ELT |s| 0) (|char| '|(|)) |s|) + ('T + (SPADLET |k| + (OR (STRPOS (MAKESTRING "->") |s| 0 NIL) + (RETURN |s|))) + (COND + ((BOOT-EQUAL (ELT |s| (SPADDIFFERENCE |k| 1)) + (|char| '|)|)) + (STRCONC (|char| '|(|) |s|)) + ('T + (STRCONC (|char| '|(|) (SUBSTRING |s| 0 |k|) + (|char| '|)|) (SUBSTRING |s| |k| NIL)))))))))) + +;underscoreDollars(s) == fn(s,0,MAXINDEX s) where +; fn(s,i,n) == +; i > n => '"" +; (m := charPosition(char '_$,s,i)) > n => SUBSTRING(s,i,nil) +; STRCONC(SUBSTRING(s,i,m - i),'"___$",fn(s,m + 1,n)) + +(DEFUN |underscoreDollars,fn| (|s| |i| |n|) + (PROG (|m|) + (RETURN + (SEQ (IF (> |i| |n|) (EXIT (MAKESTRING ""))) + (IF (> (SPADLET |m| (|charPosition| (|char| '$) |s| |i|)) + |n|) + (EXIT (SUBSTRING |s| |i| NIL))) + (EXIT (STRCONC (SUBSTRING |s| |i| (SPADDIFFERENCE |m| |i|)) + (MAKESTRING "_$") + (|underscoreDollars,fn| |s| (PLUS |m| 1) |n|))))))) + +(DEFUN |underscoreDollars| (|s|) + (|underscoreDollars,fn| |s| 0 (MAXINDEX |s|))) + +;--======================================================================= +;-- Code dependent on $saturn +;--======================================================================= +;obey x == +; $saturn and not $aixTestSaturn => nil +; OBEY x + +(DEFUN |obey| (|x|) + (declare (special |$aixTestSaturn| |$saturn|)) + (COND ((AND |$saturn| (NULL |$aixTestSaturn|)) NIL) ('T (OBEY |x|)))) + +;--======================================================================= +;-- I/O Code +;--======================================================================= +;getTempPath kind == +; pathname := mkGrepFile kind +; obey STRCONC('"rm -f ", pathname) +; pathname + +(DEFUN |getTempPath| (|kind|) + (PROG (|pathname|) + (RETURN + (PROGN + (SPADLET |pathname| (|mkGrepFile| |kind|)) + (|obey| (STRCONC (MAKESTRING "rm -f ") |pathname|)) + |pathname|)))) + +;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| (&REST G176369 &AUX |options| |s|) + (DSETQ (|s| . |options|) G176369) + (PROG (|$outStream| |pathname|) + (DECLARE (SPECIAL |$outStream|)) + (RETURN + (SEQ (PROGN + (SPADLET |pathname| + (OR (IFCAR |options|) (|getTempPath| '|source|))) + (SPADLET |$outStream| (MAKE-OUTSTREAM |pathname|)) + (DO ((G176356 |s| (CDR G176356)) (|x| NIL)) + ((OR (ATOM G176356) + (PROGN (SETQ |x| (CAR G176356)) NIL)) + NIL) + (SEQ (EXIT (|writedb| |x|)))) + (SHUT |$outStream|) + |pathname|))))) + +;dbReadLines target == --AIX only--called by grepFile +; instream := OPEN target +; lines := [READLINE instream while not EOFP instream] +; CLOSE instream +; lines + +(DEFUN |dbReadLines| (|target|) + (PROG (|instream| |lines|) + (RETURN + (SEQ (PROGN + (SPADLET |instream| (OPEN |target|)) + (SPADLET |lines| + (PROG (G176375) + (SPADLET G176375 NIL) + (RETURN + (DO () + ((NULL (NULL (EOFP |instream|))) + (NREVERSE0 G176375)) + (SEQ (EXIT (SETQ G176375 + (CONS (READLINE |instream|) + G176375)))))))) + (CLOSE |instream|) + |lines|))))) + +;dbGetCommentOrigin line == +;--Given a comment line in comdb, returns line in libdb pointing to it +;--Comment lines have format [dcpxoa]xxxxxx`ccccc... where +;--x's give pointer into libdb, c's are comments +; firstPart := dbPart(line,1,-1) +; key := INTERN SUBSTRING(firstPart,0,1) --extract this and throw away +; address := SUBSTRING(firstPart, 1, nil) --address in libdb +; instream := OPEN grepSource key --this always returns libdb now +; FILE_-POSITION(instream,PARSE_-INTEGER address) +; line := READLINE instream +; CLOSE instream +; line + +(DEFUN |dbGetCommentOrigin| (|line|) + (PROG (|firstPart| |key| |address| |instream|) + (RETURN + (PROGN + (SPADLET |firstPart| (|dbPart| |line| 1 (SPADDIFFERENCE 1))) + (SPADLET |key| (INTERN (SUBSTRING |firstPart| 0 1))) + (SPADLET |address| (SUBSTRING |firstPart| 1 NIL)) + (SPADLET |instream| (OPEN (|grepSource| |key|))) + (FILE-POSITION |instream| (PARSE-INTEGER |address|)) + (SPADLET |line| (READLINE |instream|)) + (CLOSE |instream|) + |line|)))) + +;grepSource key == +; key = 'libdb => STRCONC($SPADROOT,'"/algebra/libdb.text") +; key = 'gloss => STRCONC($SPADROOT,'"/algebra/glosskey.text") +; key = $localLibdb => $localLibdb +; mkGrepTextfile +; MEMQ(key, '(_. a c d k o p x)) => 'libdb +; 'comdb + +(DEFUN |grepSource| (|key|) + (declare (special $SPADROOT |$localLibdb|)) + (COND + ((BOOT-EQUAL |key| '|libdb|) + (STRCONC $SPADROOT (MAKESTRING "/algebra/libdb.text"))) + ((BOOT-EQUAL |key| '|gloss|) + (STRCONC $SPADROOT (MAKESTRING "/algebra/glosskey.text"))) + ((BOOT-EQUAL |key| |$localLibdb|) |$localLibdb|) + ('T + (|mkGrepTextfile| + (COND + ((MEMQ |key| '(|.| |a| |c| |d| |k| |o| |p| |x|)) '|libdb|) + ('T '|comdb|)))))) + +;mkGrepTextfile s == STRCONC($SPADROOT,"/algebra/", STRINGIMAGE s, '".text") + +(DEFUN |mkGrepTextfile| (|s|) + (declare (special $spadroot)) + (STRCONC $SPADROOT '|/algebra/| (STRINGIMAGE |s|) + (MAKESTRING ".text"))) + +;mkGrepFile s == --called to generate a path name for a temporary grep file +; prefix := +; $standard or $aixTestSaturn => '"/tmp/" +; STRCONC($SPADROOT,'"/algebra/") +; suffix := getEnv '"SPADNUM" +; STRCONC(prefix, PNAME s,'".txt.", suffix) + +(DEFUN |mkGrepFile| (|s|) + (PROG (|prefix| |suffix|) + (declare (special |$standard| |$aixTestSaturn| $spadroot)) + (RETURN + (PROGN + (SPADLET |prefix| + (COND + ((OR |$standard| |$aixTestSaturn|) + (MAKESTRING "/tmp/")) + ('T (STRCONC $SPADROOT (MAKESTRING "/algebra/"))))) + (SPADLET |suffix| (|getEnv| (MAKESTRING "SPADNUM"))) + (STRCONC |prefix| (PNAME |s|) (MAKESTRING ".txt.") |suffix|))))) + +;--======================================================================= +;-- Grepping Code +;--======================================================================= +;grepFile(pattern,:options) == +; key := (x := IFCAR options => (options := rest options; x); nil) +; source := grepSource key +; lines := +; not PROBE_-FILE source => NIL +; $standard or $aixTestSaturn => +; -----AIX Version---------- +; target := getTempPath 'target +; casepart := +; MEMQ('iv,options)=> '"-vi" +; '"-i" +; command := STRCONC('"grep ",casepart,'" _'",pattern,'"_' ",source) +; obey +; MEMBER(key,'(a o c d p x)) => +; STRCONC(command, '" | sed 's/~/", STRINGIMAGE key, '"/' > ", target) +; STRCONC(command, '" > ",target) +; dbReadLines target +; ----Windows Version------ +; invert? := MEMQ('iv, options) +; GREP(source, pattern, false, not invert?) +; dbUnpatchLines lines + +(DEFUN |grepFile| (&REST G176432 &AUX |options| |pattern|) + (DSETQ (|pattern| . |options|) G176432) + (PROG (|x| |key| |source| |target| |casepart| |command| |invert?| + |lines|) + (declare (special |$standard| |$aixTestSaturn|)) + (RETURN + (PROGN + (SPADLET |key| + (COND + ((SPADLET |x| (IFCAR |options|)) + (SPADLET |options| (CDR |options|)) |x|) + ('T NIL))) + (SPADLET |source| (|grepSource| |key|)) + (SPADLET |lines| + (COND + ((NULL (PROBE-FILE |source|)) NIL) + ((OR |$standard| |$aixTestSaturn|) + (SPADLET |target| (|getTempPath| '|target|)) + (SPADLET |casepart| + (COND + ((MEMQ '|iv| |options|) + (MAKESTRING "-vi")) + ('T (MAKESTRING "-i")))) + (SPADLET |command| + (STRCONC (MAKESTRING "grep ") |casepart| + (MAKESTRING " '") |pattern| + (MAKESTRING "' ") |source|)) + (|obey| (COND + ((|member| |key| + '(|a| |o| |c| |d| |p| |x|)) + (STRCONC |command| + (MAKESTRING " | sed 's/~/") + (STRINGIMAGE |key|) + (MAKESTRING "/' > ") |target|)) + ('T + (STRCONC |command| (MAKESTRING " > ") + |target|)))) + (|dbReadLines| |target|)) + ('T (SPADLET |invert?| (MEMQ '|iv| |options|)) + (GREP |source| |pattern| NIL (NULL |invert?|))))) + (|dbUnpatchLines| |lines|))))) + +;dbUnpatchLines lines == --concatenate long lines together, skip blank lines +; dash := char '_- +; acc := nil +; while lines is [line, :lines] repeat +; #line = 0 => 'skip --skip blank lines +; acc := +; line.0 = dash and line.1 = dash => +; [STRCONC(first acc,SUBSTRING(line,2,nil)),:rest acc] +; [line,:acc] +; -- following call to NREVERSE needed to keep lines properly sorted +; NREVERSE acc ------> added by BMT 12/95 + +(DEFUN |dbUnpatchLines| (|lines|) + (PROG (|dash| |line| |acc|) + (RETURN + (SEQ (PROGN + (SPADLET |dash| (|char| '-)) + (SPADLET |acc| NIL) + (DO () + ((NULL (AND (PAIRP |lines|) + (PROGN + (SPADLET |line| (QCAR |lines|)) + (SPADLET |lines| (QCDR |lines|)) + 'T))) + NIL) + (SEQ (EXIT (COND + ((EQL (|#| |line|) 0) '|skip|) + ('T + (SPADLET |acc| + (COND + ((AND + (BOOT-EQUAL (ELT |line| 0) + |dash|) + (BOOT-EQUAL (ELT |line| 1) + |dash|)) + (CONS + (STRCONC (CAR |acc|) + (SUBSTRING |line| 2 NIL)) + (CDR |acc|))) + ('T (CONS |line| |acc|))))))))) + (NREVERSE |acc|)))))) + +;--====================> WAS b-util.boot <================================ +;--======================================================================= +;-- AXIOM Browser +;-- Initial entry is from man0.ht page to one of these functions: +;-- kSearch (cSearch, dSearch, or pSearch), for constructors +;-- oSearch, for operations +;-- aSearch, for attributes +;-- aokSearch, for general search +;-- docSearch, for documentation search +;-- genSearch, for complete search +;--======================================================================= +;browserAutoloadOnceTrigger() == nil + +(DEFUN |browserAutoloadOnceTrigger| () NIL) + +;----------------------> Global Variables <----------------------- +;$includeUnexposed? := true --default setting + +(SPADLET |$includeUnexposed?| 'T) + +;$tick := char '_` --field separator for database files + +(SPADLET |$tick| (|char| '|`|)) + +;$charUnderscore := ('__) --needed because of parser bug + +(SPADLET |$charUnderscore| '_) + +;$wild1 := '"[^`]*" --phrase used to convert keys to grep strings + +(SPADLET |$wild1| (MAKESTRING "[^`]*")) + +;$browseCountThreshold := 10 --the maximum number of names that will display + +(SPADLET |$browseCountThreshold| 10) + +; --on a general search +;$opDescriptionThreshold := 4 --if <= 4 operations with unique name, give desc + +(SPADLET |$opDescriptionThreshold| 4) + +; --otherwise, give signatures +;$browseMixedCase := true --distinquish case in the browser? + +(SPADLET |$browseMixedCase| 'T) + +;$docTable := nil --cache for documentation table + +(SPADLET |$docTable| NIL) + +;$conArgstrings := nil --bound by conPage so that kPage + +(SPADLET |$conArgstrings| NIL) + +; --will display arguments if given +;$conformsAreDomains := false --are all arguments of a constructor given? + +(SPADLET |$conformsAreDomains| NIL) + +;$returnNowhereFromGoGet := false --special branch out for goget for browser + +(SPADLET |$returnNowhereFromGoGet| NIL) + +;$dbDataFunctionAlist := nil --set by dbGatherData + +(SPADLET |$dbDataFunctionAlist| NIL) + +;$domain := nil --bound in koOps + +(SPADLET |$domain| NIL) + +;$infovec := nil --bound in koOps + +(SPADLET |$infovec| NIL) + +;$predvec := nil --bound in koOps + +(SPADLET |$predvec| NIL) + +;$exposedOnlyIfTrue := nil --see repeatSearch, dbShowOps, dbShowCon + +(SPADLET |$exposedOnlyIfTrue| NIL) + +;$bcMultipleNames := nil --see bcNameConTable + +(SPADLET |$bcMultipleNames| NIL) + +;$bcConformBincount := nil --see bcConform1 + +(SPADLET |$bcConformBincount| NIL) + +;$docTableHash := MAKE_-HASHTABLE 'EQUAL --see dbExpandOpAlistIfNecessary + +(SPADLET |$docTableHash| (MAKE-HASHTABLE 'EQUAL)) + +;$groupChoice := nil --see dbShowOperationsFromConform + +(SPADLET |$groupChoice| NIL) + +;------------------> Initial Settings <--------------------- +;$pmFilterDelimiters := [char '_(,char '_),char '_ ] + +(SPADLET |$pmFilterDelimiters| + (CONS (|char| '|(|) + (CONS (|char| '|)|) (CONS (|char| '| |) NIL)))) + +$dbKindAlist := +; [[char 'a,:'"attribute"],[char 'o,:'"operation"], +; [char 'd,:'"domain"],[char 'p,:'"package"], +; [char 'c,:'"category"],[char 'x,:'"default_ package"]] + +(SPADLET |$dbKindAlist| + (CONS (CONS (|char| '|a|) (MAKESTRING "attribute")) + (CONS (CONS (|char| '|o|) (MAKESTRING "operation")) + (CONS (CONS (|char| '|d|) (MAKESTRING "domain")) + (CONS (CONS (|char| '|p|) + (MAKESTRING "package")) + (CONS (CONS (|char| '|c|) + (MAKESTRING "category")) + (CONS + (CONS (|char| '|x|) + (MAKESTRING "default package")) + NIL))))))) + +;$OpViewTable := '( +; (names "Name" "Names" dbShowOpNames) +; (documentation "Name" "Names" dbShowOpDocumentation) +; (domains "Domain" "Domains" dbShowOpDomains) +; (signatures "Signature" "Signatures" dbShowOpSignatures) +; (parameters "Form" "Forms" dbShowOpParameters) +; (origins "Origin" "Origins" dbShowOpOrigins) +; (implementation nil "Implementation Domains" dbShowOpImplementations) +; (conditions "Condition" "Conditions" dbShowOpConditions)) + +(SPADLET |$OpViewTable| + '((|names| "Name" "Names" |dbShowOpNames|) + (|documentation| "Name" "Names" |dbShowOpDocumentation|) + (|domains| "Domain" "Domains" |dbShowOpDomains|) + (|signatures| "Signature" "Signatures" |dbShowOpSignatures|) + (|parameters| "Form" "Forms" |dbShowOpParameters|) + (|origins| "Origin" "Origins" |dbShowOpOrigins|) + (|implementation| |nil| "Implementation Domains" + |dbShowOpImplementations|) + (|conditions| "Condition" "Conditions" |dbShowOpConditions|))) + +;bcBlankLine() == bcHt '"\vspace{1}\newline " + +(DEFUN |bcBlankLine| () (|bcHt| (MAKESTRING "\\vspace{1}\\newline "))) + +;pluralize k == +; k = '"child" => '"children" +; k = '"category" => '"categories" +; k = '"entry" => '"entries" +; STRCONC(k,'"s") + +(DEFUN |pluralize| (|k|) + (COND + ((BOOT-EQUAL |k| (MAKESTRING "child")) (MAKESTRING "children")) + ((BOOT-EQUAL |k| (MAKESTRING "category")) + (MAKESTRING "categories")) + ((BOOT-EQUAL |k| (MAKESTRING "entry")) (MAKESTRING "entries")) + ('T (STRCONC |k| (MAKESTRING "s"))))) + +;capitalize s == +; LASSOC(s,'( +; ("domain" . "Domain") +; ("category" . "Category") +; ("package" . "Package") +; ("default package" . "Default Package"))) or +; res := COPY_-SEQ s +; SETELT(res,0,UPCASE res.0) +; res + +(DEFUN |capitalize| (|s|) + (PROG (|res|) + (RETURN + (OR (LASSOC |s| + '(("domain" . "Domain") ("category" . "Category") + ("package" . "Package") + ("default package" . "Default Package"))) + (PROGN + (SPADLET |res| (COPY-SEQ |s|)) + (SETELT |res| 0 (UPCASE (ELT |res| 0))) + |res|))))) + +;escapeSpecialIds u == --very expensive function +; x := LASSOC(u,$htCharAlist) => [x] +; #u = 1 => +; member(u, $htSpecialChars) => [CONCAT('"_\", u)] +; [u] +; c := char u.0 +; or/[c = char y for y in $htSpecialChars] => +; [CONCAT('"_\",u)] +; [u] + +(DEFUN |escapeSpecialIds| (|u|) + (PROG (|x| |c|) + (declare (special |$htCharAlist| |$htSpecialChars|)) + (RETURN + (SEQ (COND + ((SPADLET |x| (LASSOC |u| |$htCharAlist|)) (CONS |x| NIL)) + ((EQL (|#| |u|) 1) + (COND + ((|member| |u| |$htSpecialChars|) + (CONS (CONCAT (MAKESTRING "\\") |u|) NIL)) + ('T (CONS |u| NIL)))) + ('T (SPADLET |c| (|char| (ELT |u| 0))) + (COND + ((PROG (G176470) + (SPADLET G176470 NIL) + (RETURN + (DO ((G176476 NIL G176470) + (G176477 |$htSpecialChars| (CDR G176477)) + (|y| NIL)) + ((OR G176476 (ATOM G176477) + (PROGN (SETQ |y| (CAR G176477)) NIL)) + G176470) + (SEQ (EXIT (SETQ G176470 + (OR G176470 + (BOOT-EQUAL |c| (|char| |y|))))))))) + (CONS (CONCAT (MAKESTRING "\\") |u|) NIL)) + ('T (CONS |u| NIL))))))))) + +;escapeString com == --this makes changes on single comment lines +;-- was htexCom +; look := 0 +; while look repeat +; look >= SIZE com => look := [] +; look := STRPOSL ('"${}#%", com, look, []) +; if look then +; com := RPLACSTR (com,look,0,'"\") --note RPLACSTR copies!!! +; look := look + 2 +; com + +(DEFUN |escapeString| (|com|) + (PROG (|look|) + (RETURN + (SEQ (PROGN + (SPADLET |look| 0) + (DO () ((NULL |look|) NIL) + (SEQ (EXIT (COND + ((>= |look| (SIZE |com|)) + (SPADLET |look| NIL)) + ('T + (SPADLET |look| + (STRPOSL (MAKESTRING "${}#%") + |com| |look| NIL)) + (COND + (|look| (SPADLET |com| + (RPLACSTR |com| |look| 0 + (MAKESTRING "\\"))) + (SPADLET |look| (PLUS |look| 2))) + ('T NIL))))))) + |com|))))) + +;htPred2English(x,:options) == +; $emList :local := IFCAR options --list of identifiers to be emphasised +; $precList: local := '((OR 10 . "or") (AND 9 . "and") +; (_< 5) (_<_= 5) (_> 5) (_>_= 5) (_= 5) (_^_= 5) (or 10) (and 9)) +; fn(x,100) where +; fn(x,prec) == +; x is [op,:l] => +; LASSOC(op,$precList) is [iprec,:rename] => +; if iprec > prec then htSay '"(" +; fn(first l,iprec) +; for y in rest l repeat +; htSay('" ",rename or op,'" ") +; fn(y,iprec) +; if iprec > prec then htSay '")" +; if prec < 5 then htSay '"(" +; gn(x,op,l,prec) +; if prec < 5 then htSay '")" +; x = 'etc => htSay '"..." +; IDENTP x and not MEMQ(x,$emList) => htSay escapeSpecialIds PNAME x +; htSay form2HtString(x,$emList) +; gn(x,op,l,prec) == +; MEMQ(op,'(NOT not)) => +; htSay('"not ") +; fn(first l,0) +; op = 'HasCategory => +; bcConform(first l,$emList) +; htSay('" has ") +; bcConform(CADADR l,$emList) +; op = 'HasAttribute => +; bcConform(first l,$emList) +; htSay('" has ") +; fnAttr CADADR l +; MEMQ(op,'(has ofCategory)) => +; bcConform(first l,$emList) +; htSay('" has ") +; [a,b] := l +; b is ['ATTRIBUTE,c] and not constructor? c => fnAttr c +; bcConform(b, $emList) +; bcConform(x,$emList) +; fnAttr c == +; s := form2HtString c +; MEMBER(s,$emList) => htSay('"{\em ",s,'"}") +; satDownLink(s, ['"(|aPage| '|",s,'"|)"]) + +(DEFUN |htPred2English,fnAttr| (|c|) + (PROG (|s|) + (declare (special |$emList|)) + (RETURN + (SEQ (SPADLET |s| (|form2HtString| |c|)) + (IF (|member| |s| |$emList|) + (EXIT (|htSay| (MAKESTRING "{\\em ") |s| + (MAKESTRING "}")))) + (EXIT (|satDownLink| |s| + (CONS (MAKESTRING "(|aPage| '|") + (CONS |s| (CONS (MAKESTRING "|)") NIL))))))))) + +(DEFUN |htPred2English,gn| (|x| |op| |l| |prec|) + (declare (ignore |prec|)) + (PROG (|a| |b| |ISTMP#1| |c|) + (declare (special |$emList|)) + (RETURN + (SEQ (IF (MEMQ |op| '(NOT |not|)) + (EXIT (SEQ (|htSay| (MAKESTRING "not ")) + (EXIT (|htPred2English,fn| (CAR |l|) 0))))) + (IF (BOOT-EQUAL |op| '|HasCategory|) + (EXIT (SEQ (|bcConform| (CAR |l|) |$emList|) + (|htSay| (MAKESTRING " has ")) + (EXIT (|bcConform| (CADADR |l|) |$emList|))))) + (IF (BOOT-EQUAL |op| '|HasAttribute|) + (EXIT (SEQ (|bcConform| (CAR |l|) |$emList|) + (|htSay| (MAKESTRING " has ")) + (EXIT (|htPred2English,fnAttr| (CADADR |l|)))))) + (IF (MEMQ |op| '(|has| |ofCategory|)) + (EXIT (SEQ (|bcConform| (CAR |l|) |$emList|) + (|htSay| (MAKESTRING " has ")) + (PROGN + (SPADLET |a| (CAR |l|)) + (SPADLET |b| (CADR |l|)) + |l|) + (IF (AND (AND (PAIRP |b|) + (EQ (QCAR |b|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#1|)) + 'T)))) + (NULL (|constructor?| |c|))) + (EXIT (|htPred2English,fnAttr| |c|))) + (EXIT (|bcConform| |b| |$emList|))))) + (EXIT (|bcConform| |x| |$emList|)))))) + +(DEFUN |htPred2English,fn| (|x| |prec|) + (PROG (|op| |l| |ISTMP#1| |iprec| |rename|) + (declare (special |$precList| |$emList|)) + (RETURN + (SEQ (IF (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |l| (QCDR |x|)) + 'T)) + (EXIT (SEQ (IF (PROGN + (SPADLET |ISTMP#1| + (LASSOC |op| |$precList|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |iprec| + (QCAR |ISTMP#1|)) + (SPADLET |rename| + (QCDR |ISTMP#1|)) + 'T))) + (EXIT (SEQ + (IF (> |iprec| |prec|) + (|htSay| (MAKESTRING "(")) NIL) + (|htPred2English,fn| (CAR |l|) + |iprec|) + (DO + ((G176549 (CDR |l|) + (CDR G176549)) + (|y| NIL)) + ((OR (ATOM G176549) + (PROGN + (SETQ |y| (CAR G176549)) + NIL)) + NIL) + (SEQ + (|htSay| (MAKESTRING " ") + (OR |rename| |op|) + (MAKESTRING " ")) + (EXIT + (|htPred2English,fn| |y| + |iprec|)))) + (EXIT + (IF (> |iprec| |prec|) + (|htSay| (MAKESTRING ")")) NIL))))) + (IF (> 5 |prec|) (|htSay| (MAKESTRING "(")) + NIL) + (|htPred2English,gn| |x| |op| |l| |prec|) + (EXIT (IF (> 5 |prec|) + (|htSay| (MAKESTRING ")")) NIL))))) + (IF (BOOT-EQUAL |x| '|etc|) + (EXIT (|htSay| (MAKESTRING "...")))) + (IF (AND (IDENTP |x|) (NULL (MEMQ |x| |$emList|))) + (EXIT (|htSay| (|escapeSpecialIds| (PNAME |x|))))) + (EXIT (|htSay| (|form2HtString| |x| |$emList|))))))) + +(DEFUN |htPred2English| (&REST G176574 &AUX |options| |x|) + (DSETQ (|x| . |options|) G176574) + (PROG (|$emList| |$precList|) + (DECLARE (SPECIAL |$emList| |$precList|)) + (RETURN + (PROGN + (SPADLET |$emList| (IFCAR |options|)) + (SPADLET |$precList| + '((OR 10 . "or") (AND 9 . "and") (< 5) (<= 5) (> 5) + (>= 5) (= 5) (^= 5) (|or| 10) (|and| 9))) + (|htPred2English,fn| |x| 100))))) + +;unMkEvalable u == +; u is ['QUOTE,a] => a +; u is ['LIST,:r] => [unMkEvalable x for x in r] +; u + +(DEFUN |unMkEvalable| (|u|) + (PROG (|ISTMP#1| |a| |r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + |a|) + ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LIST) + (PROGN (SPADLET |r| (QCDR |u|)) 'T)) + (PROG (G176584) + (SPADLET G176584 NIL) + (RETURN + (DO ((G176589 |r| (CDR G176589)) (|x| NIL)) + ((OR (ATOM G176589) + (PROGN (SETQ |x| (CAR G176589)) NIL)) + (NREVERSE0 G176584)) + (SEQ (EXIT (SETQ G176584 + (CONS (|unMkEvalable| |x|) + G176584)))))))) + ('T |u|)))))) + +;lisp2HT u == ['"_'",:fn u] where fn u == +; IDENTP u => escapeSpecialIds PNAME u +; STRINGP u => escapeString u +; ATOM u => systemError() +; ['"_(",:"append"/[fn x for x in u],'")"] + +(DEFUN |lisp2HT,fn| (|u|) + (PROG () + (RETURN + (SEQ (IF (IDENTP |u|) (EXIT (|escapeSpecialIds| (PNAME |u|)))) + (IF (STRINGP |u|) (EXIT (|escapeString| |u|))) + (IF (ATOM |u|) (EXIT (|systemError|))) + (EXIT (CONS (MAKESTRING "(") + (APPEND (PROG (G176603) + (SPADLET G176603 NIL) + (RETURN + (DO + ((G176608 |u| (CDR G176608)) + (|x| NIL)) + ((OR (ATOM G176608) + (PROGN + (SETQ |x| (CAR G176608)) + NIL)) + G176603) + (SEQ + (EXIT + (SETQ G176603 + (APPEND G176603 + (|lisp2HT,fn| |x|)))))))) + (CONS (MAKESTRING ")") NIL)))))))) + + +(DEFUN |lisp2HT| (|u|) (CONS (MAKESTRING "'") (|lisp2HT,fn| |u|))) + +;args2HtString(x,:options) == +; null x => '"" +; emList := IFCAR options +; SUBSTRING(form2HtString(['f,:x],emList),1,nil) + +(DEFUN |args2HtString| (&REST G176627 &AUX |options| |x|) + (DSETQ (|x| . |options|) G176627) + (PROG (|emList|) + (RETURN + (COND + ((NULL |x|) (MAKESTRING "")) + ('T (SPADLET |emList| (IFCAR |options|)) + (SUBSTRING (|form2HtString| (CONS '|f| |x|) |emList|) 1 NIL)))))) + +;quickForm2HtString(x) == +; atom x => STRINGIMAGE x +; form2HtString x + +(DEFUN |quickForm2HtString| (|x|) + (COND ((ATOM |x|) (STRINGIMAGE |x|)) ('T (|form2HtString| |x|)))) + +;form2HtString(x,:options) == +; $emList:local := IFCAR options --list of atoms to be emphasized +; $brief: local := IFCAR IFCDR options --see dbShowOperationsFromConform (lib11) +; fn(x) where +; fn x == +; atom x => +; MEMQ(x,$FormalMapVariableList) => STRCONC('"\",STRINGIMAGE x) +; u := escapeSpecialChars STRINGIMAGE x +; MEMQ(x,$emList) => STRCONC('"{\em ",u,'"}") +; STRINGP x => STRCONC('"_"",u,'"_"") +; u +; first x = 'QUOTE => STRCONC('"'",sexpr2HtString first rest x) +; first x = ":" => STRCONC(fn first rest x,'": ",fn first rest rest x) +; first x = 'Mapping => +; STRCONC(fnTail(rest rest x,'"()"),'"->",fn first rest x) +; first x = 'construct => fnTail(rest x,'"[]") +; tail := fnTail(rest x,'"()") +; head := fn first x +;-- $brief and #head + #tail > 35 => STRCONC(head,'"(...)") +; STRCONC(head,tail) +; fnTail(x,str) == +; null x => '"" +; STRCONC(str . 0,fn first x,fnTailTail rest x,str . 1) +; fnTailTail x == +; null x => '"" +; STRCONC('",",fn first x,fnTailTail rest x) + +(DEFUN |form2HtString,fnTailTail| (|x|) + (SEQ (IF (NULL |x|) (EXIT (MAKESTRING ""))) + (EXIT (STRCONC (MAKESTRING ",") (|form2HtString,fn| (CAR |x|)) + (|form2HtString,fnTailTail| (CDR |x|)))))) + +(DEFUN |form2HtString,fnTail| (|x| |str|) + (SEQ (IF (NULL |x|) (EXIT (MAKESTRING ""))) + (EXIT (STRCONC (ELT |str| 0) (|form2HtString,fn| (CAR |x|)) + (|form2HtString,fnTailTail| (CDR |x|)) + (ELT |str| 1))))) + +(DEFUN |form2HtString,fn| (|x|) + (PROG (|u| |tail| |head|) + (declare (special |$emList|)) + (RETURN + (SEQ (IF (ATOM |x|) + (EXIT (SEQ (IF (MEMQ |x| |$FormalMapVariableList|) + (EXIT (STRCONC (MAKESTRING "\\") + (STRINGIMAGE |x|)))) + (SPADLET |u| + (|escapeSpecialChars| + (STRINGIMAGE |x|))) + (IF (MEMQ |x| |$emList|) + (EXIT (STRCONC (MAKESTRING "{\\em ") |u| + (MAKESTRING "}")))) + (IF (STRINGP |x|) + (EXIT (STRCONC (MAKESTRING "\"") |u| + (MAKESTRING "\"")))) + (EXIT |u|)))) + (IF (BOOT-EQUAL (CAR |x|) 'QUOTE) + (EXIT (STRCONC (MAKESTRING "'") + (|sexpr2HtString| (CAR (CDR |x|)))))) + (IF (BOOT-EQUAL (CAR |x|) '|:|) + (EXIT (STRCONC (|form2HtString,fn| (CAR (CDR |x|))) + (MAKESTRING ": ") + (|form2HtString,fn| + (CAR (CDR (CDR |x|))))))) + (IF (BOOT-EQUAL (CAR |x|) '|Mapping|) + (EXIT (STRCONC (|form2HtString,fnTail| (CDR (CDR |x|)) + (MAKESTRING "()")) + (MAKESTRING "->") + (|form2HtString,fn| (CAR (CDR |x|)))))) + (IF (BOOT-EQUAL (CAR |x|) '|construct|) + (EXIT (|form2HtString,fnTail| (CDR |x|) + (MAKESTRING "[]")))) + (SPADLET |tail| + (|form2HtString,fnTail| (CDR |x|) + (MAKESTRING "()"))) + (SPADLET |head| (|form2HtString,fn| (CAR |x|))) + (EXIT (STRCONC |head| |tail|)))))) + +(DEFUN |form2HtString| (&REST G176659 &AUX |options| |x|) + (DSETQ (|x| . |options|) G176659) + (PROG (|$emList| |$brief|) + (DECLARE (SPECIAL |$emList| |$brief|)) + (RETURN + (PROGN + (SPADLET |$emList| (IFCAR |options|)) + (SPADLET |$brief| (IFCAR (IFCDR |options|))) + (|form2HtString,fn| |x|))))) + +;sexpr2HtString x == +; atom x => form2HtString x +; STRCONC('"(",fn x,'")") where fn x == +; r := rest x +; suffix := +; null r => '"" +; atom r => STRCONC('" . ",form2HtString rest x) +; STRCONC('" ",fn r) +; STRCONC(sexpr2HtString first x,suffix) + +(DEFUN |sexpr2HtString,fn| (|x|) + (PROG (|r| |suffix|) + (RETURN + (SEQ (SPADLET |r| (CDR |x|)) + (SPADLET |suffix| + (SEQ (IF (NULL |r|) (EXIT (MAKESTRING ""))) + (IF (ATOM |r|) + (EXIT (STRCONC (MAKESTRING " . ") + (|form2HtString| (CDR |x|))))) + (EXIT (STRCONC (MAKESTRING " ") + (|sexpr2HtString,fn| |r|))))) + (EXIT (STRCONC (|sexpr2HtString| (CAR |x|)) |suffix|)))))) + +(DEFUN |sexpr2HtString| (|x|) + (COND + ((ATOM |x|) (|form2HtString| |x|)) + ('T + (STRCONC (MAKESTRING "(") (|sexpr2HtString,fn| |x|) + (MAKESTRING ")"))))) + +;form2LispString(x) == +; atom x => +; x = '_$ => '"__$" +; MEMQ(x,$FormalMapVariableList) => STRCONC(STRINGIMAGE '__, STRINGIMAGE x) +; STRINGP x => STRCONC('"_"",STRINGIMAGE x,'"_"") +; STRINGIMAGE x +; x is ['QUOTE,a] => STRCONC('"'",sexpr2LispString a) +; x is [":",a,b] => STRCONC(form2LispString a,'":",form2LispString b) +; first x = 'Mapping => +; null rest (r := rest x) => STRCONC('"()->",form2LispString first r) +; STRCONC(args2LispString rest r,'"->",form2LispString first r) +; STRCONC(form2LispString first x,args2LispString rest x) + +(DEFUN |form2LispString| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |r|) + (RETURN + (COND + ((ATOM |x|) + (COND + ((BOOT-EQUAL |x| '$) (MAKESTRING "_$")) + ((MEMQ |x| |$FormalMapVariableList|) + (STRCONC (STRINGIMAGE '_) (STRINGIMAGE |x|))) + ((STRINGP |x|) + (STRCONC (MAKESTRING "\"") (STRINGIMAGE |x|) + (MAKESTRING "\""))) + ('T (STRINGIMAGE |x|)))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'QUOTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) + (STRCONC (MAKESTRING "'") (|sexpr2LispString| |a|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T)))))) + (STRCONC (|form2LispString| |a|) (MAKESTRING ":") + (|form2LispString| |b|))) + ((BOOT-EQUAL (CAR |x|) '|Mapping|) + (COND + ((NULL (CDR (SPADLET |r| (CDR |x|)))) + (STRCONC (MAKESTRING "()->") (|form2LispString| (CAR |r|)))) + ('T + (STRCONC (|args2LispString| (CDR |r|)) (MAKESTRING "->") + (|form2LispString| (CAR |r|)))))) + ('T + (STRCONC (|form2LispString| (CAR |x|)) + (|args2LispString| (CDR |x|)))))))) + +;sexpr2LispString x == +; atom x => form2LispString x +; STRCONC('"(",fn x,'")") where fn x == +; r := rest x +; suffix := +; null r => '"" +; atom r => STRCONC('" . ",form2LispString rest x) +; STRCONC('" ",fn r) +; STRCONC(sexpr2HtString first x,suffix) + +(DEFUN |sexpr2LispString,fn| (|x|) + (PROG (|r| |suffix|) + (RETURN + (SEQ (SPADLET |r| (CDR |x|)) + (SPADLET |suffix| + (SEQ (IF (NULL |r|) (EXIT (MAKESTRING ""))) + (IF (ATOM |r|) + (EXIT (STRCONC (MAKESTRING " . ") + (|form2LispString| (CDR |x|))))) + (EXIT (STRCONC (MAKESTRING " ") + (|sexpr2LispString,fn| |r|))))) + (EXIT (STRCONC (|sexpr2HtString| (CAR |x|)) |suffix|)))))) + +(DEFUN |sexpr2LispString| (|x|) + (COND + ((ATOM |x|) (|form2LispString| |x|)) + ('T + (STRCONC (MAKESTRING "(") (|sexpr2LispString,fn| |x|) + (MAKESTRING ")"))))) + +;args2LispString x == +; null x => '"" +; STRCONC('"(",form2LispString first x,fnTailTail rest x,'")") where +; fnTailTail x == +; null x => '"" +; STRCONC('",",form2LispString first x,fnTailTail rest x) + +(DEFUN |args2LispString,fnTailTail| (|x|) + (SEQ (IF (NULL |x|) (EXIT (MAKESTRING ""))) + (EXIT (STRCONC (MAKESTRING ",") (|form2LispString| (CAR |x|)) + (|args2LispString,fnTailTail| (CDR |x|)))))) + +(DEFUN |args2LispString| (|x|) + (COND + ((NULL |x|) (MAKESTRING "")) + ('T + (STRCONC (MAKESTRING "(") (|form2LispString| (CAR |x|)) + (|args2LispString,fnTailTail| (CDR |x|)) + (MAKESTRING ")"))))) + +;dbConstructorKind x == +; target := CADAR GETDATABASE(x,'CONSTRUCTORMODEMAP) +; target = '(Category) => 'category +; target is ['CATEGORY,'package,:.] => 'package +; HGET($defaultPackageNamesHT,x) => 'default_ package +; 'domain + +(DEFUN |dbConstructorKind| (|x|) + (PROG (|target| |ISTMP#1|) + (declare (special |$defaultPackageNamesHT|)) + (RETURN + (PROGN + (SPADLET |target| + (CADAR (GETDATABASE |x| 'CONSTRUCTORMODEMAP))) + (COND + ((BOOT-EQUAL |target| '(|Category|)) '|category|) + ((AND (PAIRP |target|) (EQ (QCAR |target|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|package|)))) + '|package|) + ((HGET |$defaultPackageNamesHT| |x|) '|default package|) + ('T '|domain|)))))) + +;getConstructorForm name == +; name = 'Union => '(Union (_: a A) (_: b B)) +; name = 'UntaggedUnion => '(Union A B) +; name = 'Record => '(Record (_: a A) (_: b B)) +; name = 'Mapping => '(Mapping T S) +; name = 'Enumeration => '(Enumeration a b) +; GETDATABASE(name,'CONSTRUCTORFORM) + +(DEFUN |getConstructorForm| (|name|) + (COND + ((BOOT-EQUAL |name| '|Union|) '(|Union| (|:| |a| A) (|:| |b| B))) + ((BOOT-EQUAL |name| '|UntaggedUnion|) '(|Union| A B)) + ((BOOT-EQUAL |name| '|Record|) '(|Record| (|:| |a| A) (|:| |b| B))) + ((BOOT-EQUAL |name| '|Mapping|) '(|Mapping| T S)) + ((BOOT-EQUAL |name| '|Enumeration|) '(|Enumeration| |a| |b|)) + ('T (GETDATABASE |name| 'CONSTRUCTORFORM)))) + +;getConstructorArgs conname == CDR getConstructorForm conname + +(DEFUN |getConstructorArgs| (|conname|) + (CDR (|getConstructorForm| |conname|))) + +;htSay(x,:options) == +;--if x = $charEscape then x := $charNewline else +;--if x = $stringEscape then x := $stringNewline +; bcHt x +; for y in options repeat bcHt y + +(DEFUN |htSay| (&REST G176754 &AUX |options| |x|) + (DSETQ (|x| . |options|) G176754) + (SEQ (PROGN + (|bcHt| |x|) + (DO ((G176745 |options| (CDR G176745)) (|y| NIL)) + ((OR (ATOM G176745) + (PROGN (SETQ |y| (CAR G176745)) NIL)) + NIL) + (SEQ (EXIT (|bcHt| |y|))))))) + +;bcComments(comments,:options) == +; italics? := not IFCAR options +; STRINGP comments => +; comments = '"" => nil +; htSay('"\newline ") +; if italics? then htSay '"{\em " +; htSay comments +; if italics? then htSay '"}" +; null comments => nil +; htSay('"\newline ") +; if italics? then htSay "{\em " +; htSay first comments +; for x in rest comments repeat htSay('" ",x) +; if italics? then htSay '"}" + +(DEFUN |bcComments| (&REST G176770 &AUX |options| |comments|) + (DSETQ (|comments| . |options|) G176770) + (PROG (|italics?|) + (RETURN + (SEQ (PROGN + (SPADLET |italics?| (NULL (IFCAR |options|))) + (COND + ((STRINGP |comments|) + (COND + ((BOOT-EQUAL |comments| (MAKESTRING "")) NIL) + ('T (|htSay| (MAKESTRING "\\newline ")) + (COND (|italics?| (|htSay| (MAKESTRING "{\\em ")))) + (|htSay| |comments|) + (COND + (|italics?| (|htSay| (MAKESTRING "}"))) + ('T NIL))))) + ((NULL |comments|) NIL) + ('T (|htSay| (MAKESTRING "\\newline ")) + (COND (|italics?| (|htSay| '|{\\em |))) + (|htSay| (CAR |comments|)) + (DO ((G176760 (CDR |comments|) (CDR G176760)) + (|x| NIL)) + ((OR (ATOM G176760) + (PROGN (SETQ |x| (CAR G176760)) NIL)) + NIL) + (SEQ (EXIT (|htSay| (MAKESTRING " ") |x|)))) + (COND + (|italics?| (|htSay| (MAKESTRING "}"))) + ('T NIL))))))))) + +;bcConform(form,:options) == +; $italics? : local := IFCAR options +; $italicHead? : local := IFCAR IFCDR options +; bcConform1 form + +(DEFUN |bcConform| (&REST G176781 &AUX |options| |form|) + (DSETQ (|form| . |options|) G176781) + (PROG (|$italics?| |$italicHead?|) + (DECLARE (SPECIAL |$italics?| |$italicHead?|)) + (RETURN + (PROGN + (SPADLET |$italics?| (IFCAR |options|)) + (SPADLET |$italicHead?| (IFCAR (IFCDR |options|))) + (|bcConform1| |form|))))) + +;bcConstructor(form is [op,:arglist],cname) == --called only when $conformsAreDomains +; htSayList dbConformGen form + +(DEFUN |bcConstructor| (|form| |cname|) + (declare (ignore |cname|)) + (PROG (|op| |arglist|) + (RETURN + (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |arglist| (CDR |form|)) + (|htSayList| (|dbConformGen| |form|)))))) + +;htSayList u == +; for x in u repeat htSay x + +(DEFUN |htSayList| (|u|) + (SEQ (DO ((G176798 |u| (CDR G176798)) (|x| NIL)) + ((OR (ATOM G176798) + (PROGN (SETQ |x| (CAR G176798)) NIL)) + NIL) + (SEQ (EXIT (|htSay| |x|)))))) + +;conform2HtString form == +; for u in form2String form repeat +; htSay u + +(DEFUN |conform2HtString| (|form|) + (SEQ (DO ((G176810 (|form2String| |form|) (CDR G176810)) + (|u| NIL)) + ((OR (ATOM G176810) + (PROGN (SETQ |u| (CAR G176810)) NIL)) + NIL) + (SEQ (EXIT (|htSay| |u|)))))) + +;dbEvalableConstructor? form == +;--form is constructor form; either +;--(a) all arguments are specified or (b) none are specified +; form is [op,:argl] => +; null argl => true +; op = 'QUOTE => 'T --is a domain valued object +; and/[dbEvalableConstructor? x for x in argl] +; INTEGERP form => true +; false + +(DEFUN |dbEvalableConstructor?| (|form|) + (PROG (|op| |argl|) + (RETURN + (SEQ (COND + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |argl| (QCDR |form|)) + 'T)) + (COND + ((NULL |argl|) 'T) + ((BOOT-EQUAL |op| 'QUOTE) 'T) + ('T + (PROG (G176824) + (SPADLET G176824 'T) + (RETURN + (DO ((G176830 NIL (NULL G176824)) + (G176831 |argl| (CDR G176831)) (|x| NIL)) + ((OR G176830 (ATOM G176831) + (PROGN (SETQ |x| (CAR G176831)) NIL)) + G176824) + (SEQ (EXIT (SETQ G176824 + (AND G176824 + (|dbEvalableConstructor?| |x|))))))))))) + ((INTEGERP |form|) 'T) + ('T NIL)))))) + +;htSayItalics s == htSay('"{\em ",s,'"}") + +(DEFUN |htSayItalics| (|s|) + (|htSay| (MAKESTRING "{\\em ") |s| (MAKESTRING "}"))) + +;bcCon(name,:options) == +; argString := IFCAR options or '"" +; s := STRINGIMAGE name +; bcStar name +; htSayConstructorName(s,s) +; htSay argString + +(DEFUN |bcCon| (&REST G176853 &AUX |options| |name|) + (DSETQ (|name| . |options|) G176853) + (PROG (|argString| |s|) + (RETURN + (PROGN + (SPADLET |argString| (OR (IFCAR |options|) (MAKESTRING ""))) + (SPADLET |s| (STRINGIMAGE |name|)) + (|bcStar| |name|) + (|htSayConstructorName| |s| |s|) + (|htSay| |argString|))))) + +;bcAbb(name,abb) == +; s := STRINGIMAGE name +; a := STRINGIMAGE abb +; bcStar name +; htSayConstructorName(a,s) + +(DEFUN |bcAbb| (|name| |abb|) + (PROG (|s| |a|) + (RETURN + (PROGN + (SPADLET |s| (STRINGIMAGE |name|)) + (SPADLET |a| (STRINGIMAGE |abb|)) + (|bcStar| |name|) + (|htSayConstructorName| |a| |s|))))) + +;bcStar name == +; if $includeUnexposed? and not isExposedConstructor name then htSayUnexposed() + +(DEFUN |bcStar| (|name|) + (declare (special |$includeUnexposed?|)) + (COND + ((AND |$includeUnexposed?| (NULL (|isExposedConstructor| |name|))) + (|htSayUnexposed|)) + ('T NIL))) + +;bcStarSpace name == +; null $includeUnexposed? => nil +; not isExposedConstructor name => htSayUnexposed() +; htBlank() + +(DEFUN |bcStarSpace| (|name|) + (declare (special |$includeUnexposed?|)) + (COND + ((NULL |$includeUnexposed?|) NIL) + ((NULL (|isExposedConstructor| |name|)) (|htSayUnexposed|)) + ('T (|htBlank|)))) + +;bcStarSpaceOp(op,exposed?) == +; null $includeUnexposed? => nil +; not exposed? => +; htSayUnexposed() +; if op.0 = char '_* then htSay '" " +; htBlank() + +(DEFUN |bcStarSpaceOp| (|op| |exposed?|) + (declare (special |$includeUnexposed?|)) + (COND + ((NULL |$includeUnexposed?|) NIL) + ((NULL |exposed?|) (|htSayUnexposed|) + (COND + ((BOOT-EQUAL (ELT |op| 0) (|char| '*)) + (|htSay| (MAKESTRING " "))) + ('T NIL))) + ('T (|htBlank|)))) + +;bcStarConform form == +; bcStar opOf form +; bcConform form + +(DEFUN |bcStarConform| (|form|) + (PROGN (|bcStar| (|opOf| |form|)) (|bcConform| |form|))) + +;dbSourceFile name == +; u:= GETDATABASE(name,'SOURCEFILE) +; null u => '"" +; n := PATHNAME_-NAME u +; t := PATHNAME_-TYPE u +; STRCONC(n,'".",t) + +(DEFUN |dbSourceFile| (|name|) + (PROG (|u| |n| |t|) + (RETURN + (PROGN + (SPADLET |u| (GETDATABASE |name| 'SOURCEFILE)) + (COND + ((NULL |u|) (MAKESTRING "")) + ('T (SPADLET |n| (PATHNAME-NAME |u|)) + (SPADLET |t| (PATHNAME-TYPE |u|)) + (STRCONC |n| (MAKESTRING ".") |t|))))))) + +;asharpConstructorName? name == +; u:= GETDATABASE(name,'SOURCEFILE) +; u and PATHNAME_-TYPE u = '"as" + +(DEFUN |asharpConstructorName?| (|name|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (GETDATABASE |name| 'SOURCEFILE)) + (AND |u| (BOOT-EQUAL (PATHNAME-TYPE |u|) (MAKESTRING "as"))))))) + +;asharpConstructors() == +; [x for x in allConstructors() | not asharpConstructorName? x] + +(DEFUN |asharpConstructors| () + (PROG () + (RETURN + (SEQ (PROG (G176893) + (SPADLET G176893 NIL) + (RETURN + (DO ((G176899 (|allConstructors|) (CDR G176899)) + (|x| NIL)) + ((OR (ATOM G176899) + (PROGN (SETQ |x| (CAR G176899)) NIL)) + (NREVERSE0 G176893)) + (SEQ (EXIT (COND + ((NULL (|asharpConstructorName?| |x|)) + (SETQ G176893 (CONS |x| G176893))))))))))))) + +;extractFileNameFromPath s == fn(s,0,#s) where +; fn(s,i,m) == +; k := charPosition(char '_/,s,i) +; k = m => SUBSTRING(s,i,nil) +; fn(s,k + 1,m) + +(DEFUN |extractFileNameFromPath,fn| (|s| |i| |m|) + (PROG (|k|) + (RETURN + (SEQ (SPADLET |k| (|charPosition| (|char| '/) |s| |i|)) + (IF (BOOT-EQUAL |k| |m|) (EXIT (SUBSTRING |s| |i| NIL))) + (EXIT (|extractFileNameFromPath,fn| |s| (PLUS |k| 1) |m|)))))) + +(DEFUN |extractFileNameFromPath| (|s|) + (|extractFileNameFromPath,fn| |s| 0 (|#| |s|))) + +;bcOpTable(u,fn) == +; htBeginTable() +; firstTime := true +; for op in u for i in 0.. repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; htSay '"{" +; htMakePage [['bcLinks,[escapeSpecialChars STRINGIMAGE opOf op,'"",fn,i]]] +; htSay '"}" +; htEndTable() + +(DEFUN |bcOpTable| (|u| |fn|) + (PROG (|firstTime|) + (RETURN + (SEQ (PROGN + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G176928 |u| (CDR G176928)) (|op| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR (ATOM G176928) + (PROGN (SETQ |op| (CAR G176928)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (|htSay| (MAKESTRING "{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (|escapeSpecialChars| + (STRINGIMAGE (|opOf| |op|))) + (CONS (MAKESTRING "") + (CONS |fn| (CONS |i| NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}")))))) + (|htEndTable|)))))) + +;bcNameConTable u == +; $bcMultipleNames: local := (#u ^= 1) +; bcConTable REMDUP u + +(DEFUN |bcNameConTable| (|u|) + (PROG (|$bcMultipleNames|) + (DECLARE (SPECIAL |$bcMultipleNames|)) + (RETURN + (PROGN + (SPADLET |$bcMultipleNames| (NEQUAL (|#| |u|) 1)) + (|bcConTable| (REMDUP |u|)))))) + +; -- bcConTable u +;bcConTable u == +; htBeginTable() +; firstTime := true +; for con in u repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; htSay '"{" +; bcStarSpace opOf con +; bcConform con +; htSay '"}" +; htEndTable() + +(DEFUN |bcConTable| (|u|) + (PROG (|firstTime|) + (RETURN + (SEQ (PROGN + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G176956 |u| (CDR G176956)) (|con| NIL)) + ((OR (ATOM G176956) + (PROGN (SETQ |con| (CAR G176956)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (|htSay| (MAKESTRING "{")) + (|bcStarSpace| (|opOf| |con|)) + (|bcConform| |con|) + (|htSay| (MAKESTRING "}")))))) + (|htEndTable|)))))) + +;bcAbbTable u == +; htBeginTable() +; firstTime := true +; for x in REMDUP u repeat --allow x to be NIL meaning "no abbreviation" +; -- for x in u repeat --allow x to be NIL meaning "no abbreviation" +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; if x is [con,abb,:.] then +; htSay '"{" +; bcAbb(con,abb) +; htSay '"}" +; htEndTable() + +(DEFUN |bcAbbTable| (|u|) + (PROG (|firstTime| |con| |ISTMP#1| |abb|) + (RETURN + (SEQ (PROGN + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G176989 (REMDUP |u|) (CDR G176989)) (|x| NIL)) + ((OR (ATOM G176989) + (PROGN (SETQ |x| (CAR G176989)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |con| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |abb| + (QCAR |ISTMP#1|)) + 'T)))) + (|htSay| (MAKESTRING "{")) + (|bcAbb| |con| |abb|) + (|htSay| (MAKESTRING "}"))) + ('T NIL)))))) + (|htEndTable|)))))) + +;bcConPredTable(u,conname,:options) == +; italicList := IFCAR options +; htBeginTable() +; firstTime := true +; for [conform,:pred] in u repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; htSay '"{" +; bcStarSpace opOf conform +; form := +; atom conform => getConstructorForm conform +; conform +; bcConform(form,italicList) +; if extractHasArgs pred is [arglist,:pred] then +; htSay('" {\em of} ") +; bcConform([conname,:arglist],italicList,true) +; if pred ^= 'etc then bcPred(pred,italicList) +; htSay '"}" +; htEndTable() + +(DEFUN |bcConPredTable| (&REST G177055 &AUX |options| |conname| |u|) + (DSETQ (|u| |conname| . |options|) G177055) + (PROG (|italicList| |conform| |firstTime| |form| |ISTMP#1| |arglist| + |pred|) + (RETURN + (SEQ (PROGN + (SPADLET |italicList| (IFCAR |options|)) + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G177036 |u| (CDR G177036)) (G177014 NIL)) + ((OR (ATOM G177036) + (PROGN (SETQ G177014 (CAR G177036)) NIL) + (PROGN + (PROGN + (SPADLET |conform| (CAR G177014)) + (SPADLET |pred| (CDR G177014)) + G177014) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (|htSay| (MAKESTRING "{")) + (|bcStarSpace| (|opOf| |conform|)) + (SPADLET |form| + (COND + ((ATOM |conform|) + (|getConstructorForm| + |conform|)) + ('T |conform|))) + (|bcConform| |form| |italicList|) + (COND + ((PROGN + (SPADLET |ISTMP#1| + (|extractHasArgs| |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |arglist| + (QCAR |ISTMP#1|)) + (SPADLET |pred| + (QCDR |ISTMP#1|)) + 'T))) + (|htSay| (MAKESTRING " {\\em of} ")) + (|bcConform| (CONS |conname| |arglist|) + |italicList| 'T))) + (COND + ((NEQUAL |pred| '|etc|) + (|bcPred| |pred| |italicList|))) + (|htSay| (MAKESTRING "}")))))) + (|htEndTable|)))))) + +;bcPred(pred,:options) == +; pred = '"" or pred = true or null pred => 'skip +; italicList := IFCAR options +; if not IFCAR IFCDR options then htSay '" {\em if} " +; htPred2English(pred,italicList) + +(DEFUN |bcPred| (&REST G177061 &AUX |options| |pred|) + (DSETQ (|pred| . |options|) G177061) + (PROG (|italicList|) + (RETURN + (COND + ((OR (BOOT-EQUAL |pred| (MAKESTRING "")) (BOOT-EQUAL |pred| 'T) + (NULL |pred|)) + '|skip|) + ('T (SPADLET |italicList| (IFCAR |options|)) + (COND + ((NULL (IFCAR (IFCDR |options|))) + (|htSay| (MAKESTRING " {\\em if} ")))) + (|htPred2English| |pred| |italicList|)))))) + +;extractHasArgs pred == +; x := find pred or return nil where find x == +; x is [op,:argl] => +; op = 'hasArgs => x +; MEMQ(op,'(AND OR NOT)) => or/[find y for y in argl] +; nil +; nil +; [rest x,:simpBool SUBST('T,x,pred)] + +(DEFUN |extractHasArgs,find| (|x|) + (PROG (|op| |argl|) + (RETURN + (SEQ (IF (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T)) + (EXIT (SEQ (IF (BOOT-EQUAL |op| '|hasArgs|) (EXIT |x|)) + (IF (MEMQ |op| '(AND OR NOT)) + (EXIT (PROG (G177067) + (SPADLET G177067 NIL) + (RETURN + (DO + ((G177073 NIL G177067) + (G177074 |argl| + (CDR G177074)) + (|y| NIL)) + ((OR G177073 + (ATOM G177074) + (PROGN + (SETQ |y| (CAR G177074)) + NIL)) + G177067) + (SEQ + (EXIT + (SETQ G177067 + (OR G177067 + (|extractHasArgs,find| + |y|)))))))))) + (EXIT NIL)))) + (EXIT NIL))))) + +(DEFUN |extractHasArgs| (|pred|) + (PROG (|x|) + (RETURN + (PROGN + (SPADLET |x| (OR (|extractHasArgs,find| |pred|) (RETURN NIL))) + (CONS (CDR |x|) (|simpBool| (MSUBST 'T |x| |pred|))))))) + +;splitConTable cons == +; uncond := cond := nil +; for (pair := [con,:pred]) in cons repeat +; null pred => 'skip +; pred = 'T or pred is ['hasArgs,:.] => uncond := [pair,:uncond] +; cond := [pair,:cond] +; [NREVERSE uncond,:NREVERSE cond] + +(DEFUN |splitConTable| (CONS) + (PROG (|con| |pred| |uncond| |cond|) + (RETURN + (SEQ (PROGN + (SPADLET |uncond| (SPADLET |cond| NIL)) + (DO ((G177102 CONS (CDR G177102)) (|pair| NIL)) + ((OR (ATOM G177102) + (PROGN (SETQ |pair| (CAR G177102)) NIL) + (PROGN + (PROGN + (SPADLET |con| (CAR |pair|)) + (SPADLET |pred| (CDR |pair|)) + |pair|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL |pred|) '|skip|) + ((OR (BOOT-EQUAL |pred| 'T) + (AND (PAIRP |pred|) + (EQ (QCAR |pred|) '|hasArgs|))) + (SPADLET |uncond| (CONS |pair| |uncond|))) + ('T (SPADLET |cond| (CONS |pair| |cond|))))))) + (CONS (NREVERSE |uncond|) (NREVERSE |cond|))))))) + +;bcNameTable(u,fn,:option) == --option if * prefix +; htSay '"\newline" +; htBeginTable() +; firstTime := true +; for x in u repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; htSay '"{" +; if IFCAR option then bcStar x +; htMakePage [['bcLinks,[s := escapeSpecialChars STRINGIMAGE x,'"",fn,s]]] +; htSay '"}" +; htEndTable() + +(DEFUN |bcNameTable| (&REST G177140 &AUX |option| |fn| |u|) + (DSETQ (|u| |fn| . |option|) G177140) + (PROG (|firstTime| |s|) + (RETURN + (SEQ (PROGN + (|htSay| (MAKESTRING "\\newline")) + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((G177128 |u| (CDR G177128)) (|x| NIL)) + ((OR (ATOM G177128) + (PROGN (SETQ |x| (CAR G177128)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (|htSay| (MAKESTRING "{")) + (COND ((IFCAR |option|) (|bcStar| |x|))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (SPADLET |s| + (|escapeSpecialChars| + (STRINGIMAGE |x|))) + (CONS (MAKESTRING "") + (CONS |fn| (CONS |s| NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}")))))) + (|htEndTable|)))))) + +;bcNameCountTable(u,fn,gn,:options) == +; linkFunction := +; IFCAR options => 'bcLispLinks +; 'bcLinks +; htSay '"\newline" +; htBeginTable() +; firstTime := true +; for i in 0.. for x in u repeat +; if firstTime then firstTime := false +; else htSaySaturn '"&" +; htSay '"{" +; htMakePage [[linkFunction,[FUNCALL(fn,x),'"",gn,i]]] +; htSay '"}" +; htEndTable() + +(DEFUN |bcNameCountTable| + (&REST G177164 &AUX |options| |gn| |fn| |u|) + (DSETQ (|u| |fn| |gn| . |options|) G177164) + (PROG (|linkFunction| |firstTime|) + (RETURN + (SEQ (PROGN + (SPADLET |linkFunction| + (COND + ((IFCAR |options|) '|bcLispLinks|) + ('T '|bcLinks|))) + (|htSay| (MAKESTRING "\\newline")) + (|htBeginTable|) + (SPADLET |firstTime| 'T) + (DO ((|i| 0 (QSADD1 |i|)) (G177152 |u| (CDR G177152)) + (|x| NIL)) + ((OR (ATOM G177152) + (PROGN (SETQ |x| (CAR G177152)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "&")))) + (|htSay| (MAKESTRING "{")) + (|htMakePage| + (CONS (CONS |linkFunction| + (CONS + (CONS (FUNCALL |fn| |x|) + (CONS (MAKESTRING "") + (CONS |gn| (CONS |i| NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}")))))) + (|htEndTable|)))))) + +;dbSayItemsItalics(:u) == +; htSay '"{\em " +; APPLY(function dbSayItems,u) +; htSay '"}" + +(DEFUN |dbSayItemsItalics| (&REST G177169 &AUX |u|) + (DSETQ |u| G177169) + (PROGN + (|htSay| (MAKESTRING "{\\em ")) + (APPLY (|function| |dbSayItems|) |u|) + (|htSay| (MAKESTRING "}")))) + +;dbSayItems(countOrPrefix,singular,plural,:options) == +; bcHt '"\newline " +; count := +; countOrPrefix is [:prefix,c] => +; htSay prefix +; c +; countOrPrefix +; if count = 0 then htSay('"No ",singular) +; else if count = 1 then htSay('"1 ",singular) +; else htSay(count,'" ",plural) +; for x in options repeat bcHt x +; if count ^= 0 then bcHt '":" + +(DEFUN |dbSayItems| + (&REST G177193 &AUX |options| |plural| |singular| + |countOrPrefix|) + (DSETQ (|countOrPrefix| |singular| |plural| . |options|) G177193) + (PROG (|ISTMP#1| |c| |prefix| |count|) + (RETURN + (SEQ (PROGN + (|bcHt| (MAKESTRING "\\newline ")) + (SPADLET |count| + (COND + ((AND (PAIRP |countOrPrefix|) + (PROGN + (SPADLET |ISTMP#1| + (REVERSE |countOrPrefix|)) + 'T) + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |c| (QCAR |ISTMP#1|)) + (SPADLET |prefix| (QCDR |ISTMP#1|)) + 'T) + (PROGN + (SPADLET |prefix| (NREVERSE |prefix|)) + 'T)) + (|htSay| |prefix|) |c|) + ('T |countOrPrefix|))) + (COND + ((EQL |count| 0) + (|htSay| (MAKESTRING "No ") |singular|)) + ((EQL |count| 1) (|htSay| (MAKESTRING "1 ") |singular|)) + ('T (|htSay| |count| (MAKESTRING " ") |plural|))) + (DO ((G177179 |options| (CDR G177179)) (|x| NIL)) + ((OR (ATOM G177179) + (PROGN (SETQ |x| (CAR G177179)) NIL)) + NIL) + (SEQ (EXIT (|bcHt| |x|)))) + (COND + ((NEQUAL |count| 0) (|bcHt| (MAKESTRING ":"))) + ('T NIL))))))) + +;dbBasicConstructor? conname == MEMBER(dbSourceFile conname,'("catdef" "coerce")) + +(DEFUN |dbBasicConstructor?| (|conname|) + (|member| (|dbSourceFile| |conname|) '("catdef" "coerce"))) + +;nothingFoundPage(:options) == +; htInitPage('"Sorry, no match found",nil) +; htShowPage() + +;htCopyProplist htPage == [[x,:y] for [x,:y] in htpPropertyList htPage] + +(DEFUN |htCopyProplist| (|htPage|) + (PROG (|x| |y|) + (RETURN + (SEQ (PROG (G177211) + (SPADLET G177211 NIL) + (RETURN + (DO ((G177217 (|htpPropertyList| |htPage|) + (CDR G177217)) + (G177202 NIL)) + ((OR (ATOM G177217) + (PROGN (SETQ G177202 (CAR G177217)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G177202)) + (SPADLET |y| (CDR G177202)) + G177202) + NIL)) + (NREVERSE0 G177211)) + (SEQ (EXIT (SETQ G177211 + (CONS (CONS |x| |y|) G177211))))))))))) + +;dbInfovec name == +; 'category = GETDATABASE(name,'CONSTRUCTORKIND) => nil +; GETDATABASE(name, 'ASHARP?) => nil +; loadLibIfNotLoaded(name) +; u := GET(name,'infovec) => u + +(DEFUN |dbInfovec| (|name|) + (PROG (|u|) + (RETURN + (COND + ((BOOT-EQUAL '|category| (GETDATABASE |name| 'CONSTRUCTORKIND)) + NIL) + ((GETDATABASE |name| 'ASHARP?) NIL) + ('T (|loadLibIfNotLoaded| |name|) + (COND ((SPADLET |u| (GETL |name| '|infovec|)) |u|))))))) + +;emptySearchPage(kind,filter,:options) == +; skipNamePart := IFCAR options +; heading := ['"No ",capitalize kind,'" Found"] +; htInitPage(heading,nil) +; exposePart := +; null $includeUnexposed? => '"{\em exposed} " +; '"" +; htSay('"\vspace{1}\newline\centerline{There is no ",exposePart,kind,'" matching pattern}\newline\centerline{{\em ") +; if filter then htPred2English filter +; htSay '"}}" +; htShowPage() + +(DEFUN |emptySearchPage| + (&REST G177243 &AUX |options| |filter| |kind|) + (DSETQ (|kind| |filter| . |options|) G177243) + (PROG (|skipNamePart| |heading| |exposePart|) + (declare (special |$includeUnexposed?|)) + (RETURN + (PROGN + (SPADLET |skipNamePart| (IFCAR |options|)) + (SPADLET |heading| + (CONS (MAKESTRING "No ") + (CONS (|capitalize| |kind|) + (CONS (MAKESTRING " Found") NIL)))) + (|htInitPage| |heading| NIL) + (SPADLET |exposePart| + (COND + ((NULL |$includeUnexposed?|) + (MAKESTRING "{\\em exposed} ")) + ('T (MAKESTRING "")))) + (|htSay| (MAKESTRING + "\\vspace{1}\\newline\\centerline{There is no ") + |exposePart| |kind| + (MAKESTRING + " matching pattern}\\newline\\centerline{{\\em ")) + (COND (|filter| (|htPred2English| |filter|))) + (|htSay| (MAKESTRING "}}")) + (|htShowPage|))))) + +;isLoaded? conform == GET(constructor? opOf conform,'LOADED) + +(DEFUN |isLoaded?| (|conform|) + (GETL (|constructor?| (|opOf| |conform|)) 'LOADED)) + +;string2Integer s == +; and/[DIGIT_-CHAR_-P (s.i) for i in 0..MAXINDEX s] => PARSE_-INTEGER s +; nil + +(DEFUN |string2Integer| (|s|) + (PROG () + (RETURN + (SEQ (COND + ((PROG (G177248) + (SPADLET G177248 'T) + (RETURN + (DO ((G177254 NIL (NULL G177248)) + (G177255 (MAXINDEX |s|)) (|i| 0 (QSADD1 |i|))) + ((OR G177254 (QSGREATERP |i| G177255)) + G177248) + (SEQ (EXIT (SETQ G177248 + (AND G177248 + (DIGIT-CHAR-P (ELT |s| |i|))))))))) + (PARSE-INTEGER |s|)) + ('T NIL)))))) + +;dbGetInputString htPage == +; s := htpLabelInputString(htPage,'filter) +; null s or s = '"" => '"*" +; s + +(DEFUN |dbGetInputString| (|htPage|) + (PROG (|s|) + (RETURN + (PROGN + (SPADLET |s| (|htpLabelInputString| |htPage| '|filter|)) + (COND + ((OR (NULL |s|) (BOOT-EQUAL |s| (MAKESTRING ""))) + (MAKESTRING "*")) + ('T |s|)))))) + +;--======================================================================= +;-- Error Pages +;--======================================================================= +;bcErrorPage u == +; u is ['error,:r] => +; htInitPage(first r,nil) +; bcBlankLine() +; for x in rest r repeat htSay x +; htShowPage() +; systemError '"Unexpected error message" + +(DEFUN |bcErrorPage| (|u|) + (PROG (|r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|error|) + (PROGN (SPADLET |r| (QCDR |u|)) 'T)) + (|htInitPage| (CAR |r|) NIL) (|bcBlankLine|) + (DO ((G177274 (CDR |r|) (CDR G177274)) (|x| NIL)) + ((OR (ATOM G177274) + (PROGN (SETQ |x| (CAR G177274)) NIL)) + NIL) + (SEQ (EXIT (|htSay| |x|)))) + (|htShowPage|)) + ('T + (|systemError| (MAKESTRING "Unexpected error message")))))))) + +;errorPage(htPage,[heading,kind,:info]) == +; kind = 'invalidType => kInvalidTypePage first info +; if heading = 'error then htInitPage('"Error",nil) else +; htInitPage(heading,nil) +; bcBlankLine() +; for x in info repeat htSay x +; htShowPage() + +(DEFUN |errorPage| (|htPage| G177285) + (declare (special |htPage|)) + (PROG (|heading| |kind| |info|) + (RETURN + (SEQ (PROGN + (SPADLET |heading| (CAR G177285)) + (SPADLET |kind| (CADR G177285)) + (SPADLET |info| (CDDR G177285)) + (COND + ((BOOT-EQUAL |kind| '|invalidType|) + (|kInvalidTypePage| (CAR |info|))) + ('T + (COND + ((BOOT-EQUAL |heading| '|error|) + (|htInitPage| (MAKESTRING "Error") NIL)) + ('T (|htInitPage| |heading| NIL))) + (|bcBlankLine|) + (DO ((G177299 |info| (CDR G177299)) (|x| NIL)) + ((OR (ATOM G177299) + (PROGN (SETQ |x| (CAR G177299)) NIL)) + NIL) + (SEQ (EXIT (|htSay| |x|)))) + (|htShowPage|)))))))) + +;htErrorStar() == +; errorPage(nil,['"{\em *} not a valid search string",nil,'"\vspace{3}\centerline{{\em *} is not a valid search string for a general search}\centerline{\em {it would match everything!}}"]) + +(DEFUN |htErrorStar| () + (|errorPage| NIL + (CONS (MAKESTRING "{\\em *} not a valid search string") + (CONS NIL + (CONS (MAKESTRING + "\\vspace{3}\\centerline{{\\em *} is not a valid search string for a general search}\\centerline{\\em {it would match everything!}}") + NIL))))) + +;htQueryPage(htPage,heading,message,query,fn) == +; htInitPage(heading,nil) +; htSay message +; htQuery(query,fn) +; htShowPage() + +(DEFUN |htQueryPage| (|htPage| |heading| |message| |query| |fn|) + (declare (special |htPage|)) + (PROGN + (|htInitPage| |heading| NIL) + (|htSay| |message|) + (|htQuery| |query| |fn|) + (|htShowPage|))) + +;htQuery(question,fn,:options) == +; upLink? := IFCAR options +; if question then +; htSay('"\vspace{1}\centerline{") +; htSay question +; htSay('"}") +; htSay('"\centerline{") +; htMakePage [['bcLispLinks,['"\fbox{Yes}",'"",fn,'yes]]] +; htBlank 4 +; if upLink? +; then htSay('"\downlink{\fbox{No}}{UpPage}") +; else htMakePage [['bcLispLinks,['"\fbox{No}",'"",fn,'no]]] +; htSay('"}") + +(DEFUN |htQuery| (&REST G177324 &AUX |options| |fn| |question|) + (DSETQ (|question| |fn| . |options|) G177324) + (PROG (|upLink?|) + (RETURN + (PROGN + (SPADLET |upLink?| (IFCAR |options|)) + (COND + (|question| (|htSay| (MAKESTRING "\\vspace{1}\\centerline{")) + (|htSay| |question|) (|htSay| (MAKESTRING "}")))) + (|htSay| (MAKESTRING "\\centerline{")) + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\fbox{Yes}") + (CONS (MAKESTRING "") + (CONS |fn| (CONS '|yes| NIL)))) + NIL)) + NIL)) + (|htBlank| 4) + (COND + (|upLink?| + (|htSay| (MAKESTRING "\\downlink{\\fbox{No}}{UpPage}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\fbox{No}") + (CONS (MAKESTRING "") + (CONS |fn| (CONS '|no| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}")))))) + +;kInvalidTypePage form == +; htInitPage('"Error",nil) +; bcBlankLine() +; htSay('"\centerline{You gave an invalid type:}\newline\centerline{{\sf ") +; htSay(form2HtString form,'"}}") +; htShowPage() + +(DEFUN |kInvalidTypePage| (|form|) + (PROGN + (|htInitPage| (MAKESTRING "Error") NIL) + (|bcBlankLine|) + (|htSay| (MAKESTRING + "\\centerline{You gave an invalid type:}\\newline\\centerline{{\\sf ")) + (|htSay| (|form2HtString| |form|) (MAKESTRING "}}")) + (|htShowPage|))) + +;dbNotAvailablePage(:options) == +; htInitPage('"Missing Page",nil) +; bcBlankLine() +; htSay(IFCAR options or '"\centerline{This page is not available yet}") +; htShowPage() + +(DEFUN |dbNotAvailablePage| (&REST G177333 &AUX |options|) + (DSETQ |options| G177333) + (PROGN + (|htInitPage| (MAKESTRING "Missing Page") NIL) + (|bcBlankLine|) + (|htSay| (OR (IFCAR |options|) + (MAKESTRING + "\\centerline{This page is not available yet}"))) + (|htShowPage|))) + +;--======================================================================= +;-- Utility Functions for Manipulating Browse Datalines +;--======================================================================= +;dbpHasDefaultCategory? s == #s > 1 and s.1 = char 'x --s is part 3 of line + +(DEFUN |dbpHasDefaultCategory?| (|s|) + (AND (> (|#| |s|) 1) (BOOT-EQUAL (ELT |s| 1) (|char| '|x|)))) + +;dbKind line == line.0 + +(DEFUN |dbKind| (|line|) (ELT |line| 0)) + +;dbKindString kind == LASSOC(kind,$dbKindAlist) + +(DEFUN |dbKindString| (|kind|) + (declare (special |$dbKindAlist|)) + (LASSOC |kind| |$dbKindAlist|)) + +;dbName line == escapeString SUBSTRING(line,1,charPosition($tick,line,1) - 1) + +(DEFUN |dbName| (|line|) + (declare (special |$tick|)) + (|escapeString| + (SUBSTRING |line| 1 + (SPADDIFFERENCE (|charPosition| |$tick| |line| 1) 1)))) + +;dbAttr line == STRCONC(dbName line,escapeString dbPart(line,4,0)) + +(DEFUN |dbAttr| (|line|) + (STRCONC (|dbName| |line|) (|escapeString| (|dbPart| |line| 4 0)))) + +;dbPart(line,n,k) == --returns part n of line (n=1,..) beginning in column k +; n = 1 => SUBSTRING(line,k + 1,charPosition($tick,line,k + 1) - k - 1) +; dbPart(line,n - 1,charPosition($tick,line,k + 1)) + +(DEFUN |dbPart| (|line| |n| |k|) + (declare (special |$tick|)) + (COND + ((EQL |n| 1) + (SUBSTRING |line| (PLUS |k| 1) + (SPADDIFFERENCE + (SPADDIFFERENCE + (|charPosition| |$tick| |line| (PLUS |k| 1)) |k|) + 1))) + ('T + (|dbPart| |line| (SPADDIFFERENCE |n| 1) + (|charPosition| |$tick| |line| (PLUS |k| 1)))))) + +;dbXParts(line,n,m) == +; [.,nargs,:r] := dbParts(line,n,m) +; [dbKindString line.0,dbName line,PARSE_-INTEGER nargs,:r] + +(DEFUN |dbXParts| (|line| |n| |m|) + (PROG (|LETTMP#1| |nargs| |r|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (|dbParts| |line| |n| |m|)) + (SPADLET |nargs| (CADR |LETTMP#1|)) + (SPADLET |r| (CDDR |LETTMP#1|)) + (CONS (|dbKindString| (ELT |line| 0)) + (CONS (|dbName| |line|) + (CONS (PARSE-INTEGER |nargs|) |r|))))))) + +;dbParts(line,n,m) == --split line into n parts beginning in column m +; n = 0 => nil +; [SUBSTRING(line,m,-m + (k := charPosition($tick,line,m))), +; :dbParts(line,n - 1,k + 1)] + +(DEFUN |dbParts| (|line| |n| |m|) + (PROG (|k|) + (declare (special |$tick|)) + (RETURN + (COND + ((EQL |n| 0) NIL) + ('T + (CONS (SUBSTRING |line| |m| + (PLUS (SPADDIFFERENCE |m|) + (SPADLET |k| + (|charPosition| |$tick| |line| |m|)))) + (|dbParts| |line| (SPADDIFFERENCE |n| 1) (PLUS |k| 1)))))))) + +;dbConname(line) == dbPart(line,5,1) + +(DEFUN |dbConname| (|line|) (|dbPart| |line| 5 1)) + +;dbComments line == dbReadComments(string2Integer dbPart(line,7,1)) + +(DEFUN |dbComments| (|line|) + (|dbReadComments| (|string2Integer| (|dbPart| |line| 7 1)))) + +;dbNewConname(line) == --dbName line unless kind is 'a or 'o => name in 5th pos. +; (kind := line.0) = char 'a or kind = char 'o => +; conform := dbPart(line,5,1) +; k := charPosition(char '_(,conform,1) +; SUBSTRING(conform,1,k - 1) +; dbName line + +(DEFUN |dbNewConname| (|line|) + (PROG (|kind| |conform| |k|) + (RETURN + (COND + ((OR (BOOT-EQUAL (SPADLET |kind| (ELT |line| 0)) (|char| '|a|)) + (BOOT-EQUAL |kind| (|char| '|o|))) + (SPADLET |conform| (|dbPart| |line| 5 1)) + (SPADLET |k| (|charPosition| (|char| '|(|) |conform| 1)) + (SUBSTRING |conform| 1 (SPADDIFFERENCE |k| 1))) + ('T (|dbName| |line|)))))) + +;dbTickIndex(line,n,k) == --returns index of nth tick in line starting at k +; n = 1 => charPosition($tick,line,k) +; dbTickIndex(line,n - 1,1 + charPosition($tick,line,k)) + +(DEFUN |dbTickIndex| (|line| |n| |k|) + (declare (special |$tick|)) + (COND + ((EQL |n| 1) (|charPosition| |$tick| |line| |k|)) + ('T + (|dbTickIndex| |line| (SPADDIFFERENCE |n| 1) + (PLUS 1 (|charPosition| |$tick| |line| |k|)))))) + +;mySort u == listSort(function GLESSEQP,u) + +(DEFUN |mySort| (|u|) (|listSort| (|function| GLESSEQP) |u|)) + +;--====================> WAS b-prof.boot <================================ +;--============================================================================ +;-- Browser Code for Profiling +;--============================================================================ +;kciPage(htPage,junk) == +; --info alist must have NEW format with [op,:sig] in its CAARs +; which:= '"operation" +; htpSetProperty(htPage,'which,which) +; domname := htpProperty(htPage,'domname) +; conform := htpProperty(htPage,'conform) +; heading := ['"Capsule Cross Reference for ",:htpProperty(htPage,'heading)] +; page := htInitPage(heading,htCopyProplist htPage) +; conname := opOf conform +; htpSetProperty(page,'infoAlist,infoAlist := getInfoAlist conname) +; dbGetExpandedOpAlist page --expand opAlist "in place" +; opAlist := kciReduceOpAlist(htpProperty(page,'opAlist),infoAlist) +; dbShowOperationsFromConform(page,which,opAlist) + +(DEFUN |kciPage| (|htPage| |junk|) + (declare (ignore |junk|)) + (PROG (|which| |domname| |conform| |heading| |page| |conname| + |infoAlist| |opAlist|) + (RETURN + (PROGN + (SPADLET |which| (MAKESTRING "operation")) + (|htpSetProperty| |htPage| '|which| |which|) + (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |heading| + (CONS (MAKESTRING "Capsule Cross Reference for ") + (|htpProperty| |htPage| '|heading|))) + (SPADLET |page| + (|htInitPage| |heading| (|htCopyProplist| |htPage|))) + (SPADLET |conname| (|opOf| |conform|)) + (|htpSetProperty| |page| '|infoAlist| + (SPADLET |infoAlist| (|getInfoAlist| |conname|))) + (|dbGetExpandedOpAlist| |page|) + (SPADLET |opAlist| + (|kciReduceOpAlist| (|htpProperty| |page| '|opAlist|) + |infoAlist|)) + (|dbShowOperationsFromConform| |page| |which| |opAlist|))))) + +;kciReduceOpAlist(opAlist,infoAlist) == +;--count opAlist +; res := [pair for [op,:items] in opAlist | pair] where pair == +; u := LASSOC(op,infoAlist) => +; y := [x for x in items +; | x is [sig,:.] and or/[sig = sig1 for [sig1,:.] in u]] => [op,:y] +; nil +; nil +; res + +(DEFUN |kciReduceOpAlist| (|opAlist| |infoAlist|) + (PROG (|op| |items| |u| |sig| |sig1| |y| |res|) + (RETURN + (SEQ (PROGN + (SPADLET |res| + (PROG (G177437) + (SPADLET G177437 NIL) + (RETURN + (DO ((G177448 |opAlist| (CDR G177448)) + (G177410 NIL)) + ((OR (ATOM G177448) + (PROGN + (SETQ G177410 (CAR G177448)) + NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G177410)) + (SPADLET |items| + (CDR G177410)) + G177410) + NIL)) + (NREVERSE0 G177437)) + (SEQ (EXIT (COND + ((COND + ((SPADLET |u| + (LASSOC |op| |infoAlist|)) + (COND + ((SPADLET |y| + (PROG (G177460) + (SPADLET G177460 + NIL) + (RETURN + (DO + ((G177466 + |items| + (CDR G177466)) + (|x| NIL)) + ((OR + (ATOM + G177466) + (PROGN + (SETQ |x| + (CAR + G177466)) + NIL)) + (NREVERSE0 + G177460)) + (SEQ + (EXIT + (COND + ((AND + (PAIRP + |x|) + (PROGN + (SPADLET + |sig| + (QCAR + |x|)) + 'T) + (PROG + (G177472) + (SPADLET + G177472 + NIL) + (RETURN + (DO + ((G177479 + NIL + G177472) + (G177480 + |u| + (CDR + G177480)) + (G177405 + NIL)) + ((OR + G177479 + (ATOM + G177480) + (PROGN + (SETQ + G177405 + (CAR + G177480)) + NIL) + (PROGN + (PROGN + (SPADLET + |sig1| + (CAR + G177405)) + G177405) + NIL)) + G177472) + (SEQ + (EXIT + (SETQ + G177472 + (OR + G177472 + (BOOT-EQUAL + |sig| + |sig1|))))))))) + (SETQ + G177460 + (CONS |x| + G177460)))))))))) + (CONS |op| |y|)) + ('T NIL))) + ('T NIL)) + (SETQ G177437 + (CONS + (COND + ((SPADLET |u| + (LASSOC |op| + |infoAlist|)) + (COND + ((SPADLET |y| + (PROG (G177493) + (SPADLET G177493 + NIL) + (RETURN + (DO + ((G177499 + |items| + (CDR + G177499)) + (|x| NIL)) + ((OR + (ATOM + G177499) + (PROGN + (SETQ |x| + (CAR + G177499)) + NIL)) + (NREVERSE0 + G177493)) + (SEQ + (EXIT + (COND + ((AND + (PAIRP + |x|) + (PROGN + (SPADLET + |sig| + (QCAR + |x|)) + 'T) + (PROG + (G177505) + (SPADLET + G177505 + NIL) + (RETURN + (DO + ((G177512 + NIL + G177505) + (G177513 + |u| + (CDR + G177513)) + (G177405 + NIL)) + ((OR + G177512 + (ATOM + G177513) + (PROGN + (SETQ + G177405 + (CAR + G177513)) + NIL) + (PROGN + (PROGN + (SPADLET + |sig1| + (CAR + G177405)) + G177405) + NIL)) + G177505) + (SEQ + (EXIT + (SETQ + G177505 + (OR + G177505 + (BOOT-EQUAL + |sig| + |sig1|))))))))) + (SETQ + G177493 + (CONS + |x| + G177493)))))))))) + (CONS |op| |y|)) + ('T NIL))) + ('T NIL)) + G177437)))))))))) + |res|))))) + +;displayInfoOp(htPage,infoAlist,op,sig) == +; (sigAlist := LASSOC(op,infoAlist)) and (itemlist := LASSOC(sig,sigAlist)) => +; dbShowInfoOp(htPage,op,sig,itemlist) +; nil + +(DEFUN |displayInfoOp| (|htPage| |infoAlist| |op| |sig|) + (PROG (|sigAlist| |itemlist|) + (RETURN + (COND + ((AND (SPADLET |sigAlist| (LASSOC |op| |infoAlist|)) + (SPADLET |itemlist| (LASSOC |sig| |sigAlist|))) + (|dbShowInfoOp| |htPage| |op| |sig| |itemlist|)) + ('T NIL))))) + +;dbShowInfoOp(htPage,op,sig,alist) == +; heading := htpProperty(htPage,'heading) +; domname := htpProperty(htPage,'domname) +; conform := htpProperty(htPage,'conform) +; opAlist := htpProperty(htPage,'opAlist) +; conname := opOf conform +; kind := GETDATABASE(conname,'CONSTRUCTORKIND) +; honestConform := +; kind = 'category => +; [INTERN STRCONC(PNAME conname,'"&"),"$",:CDR conform] +; conform +; faTypes := CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) +; conArgTypes := +; SUBLISLIS(IFCDR conform,TAKE(#faTypes,$FormalMapVariableList),faTypes) +; conform := htpProperty(htPage,'conform) +; conname := opOf conform +;--argTypes := REVERSE ASSOCRIGHT LASSOC('arguments,alist) +;--sig := or/[sig for [sig,:.] in LASSOC(op,opAlist) | rest sig = argTypes] +; ops := escapeSpecialChars STRINGIMAGE zeroOneConvert op +; oppart := ['"{\em ", ops, '"}"] +; head := +; sig => [:oppart,'": ",:dbConformGen dbInfoSig sig] +; oppart +; heading := [:head,'" from {\sf ",form2HtString conform,'"}"] +; for u in alist repeat +; [x,:y] := u +; x = 'locals => locals := y +; x = 'arguments => arguments := y +; fromAlist := [[x,:zeroOneConvertAlist y], :fromAlist] +; fromAlist := +; cons := args := nil +; for (p := [x,:y]) in fromAlist repeat +; x = $ => dollar := [[honestConform,:y]] +; x = 'Rep => rep := [['Rep,:y]] +; IDENTP x => args := [dbInfoFindCat(conform,conArgTypes,p), :args] +; cons := [dbInfoTran(x,y), :cons] +; [:mySort args, :dollar, :rep, :mySort cons] +; sigAlist := LASSOC(op,opAlist) +; item := or/[x for x in sigAlist | x is [sig1,:.] and sig1 = sig] or +; systemError '"cannot find signature" +; --item is [sig,pred,origin,exposeFlag,comments] +; [sig,pred,origin,exposeFlag,doc] := item +; htpSetProperty(htPage,'fromAlist,fromAlist) +; htSayHline() +; htSay('"\center{Cross Reference for definition of {\em ",ops,'"}}\beginmenu ") +;-- if arguments then +;-- htSay '"\item\menuitemstyle{}{\em arguments:}\newline" +;-- dbShowInfoList(arguments,0,false) +; if locals then +; htSay '"\item\menuitemstyle{}{\em local variables:}\newline" +; dbShowInfoList(locals,8192,false) +; bincount := 2 +; for [con,:fns] in fromAlist repeat +; htSay '"\item" +; if IDENTP con then +; htSay '"\menuitemstyle{} {\em calls to} " +; if con ^= 'Rep then htSay '"{\em argument} " +; htSay con +; if and/[fn is ['origin,orig,.] and +; (null origin and (origin := orig) or origin = orig) for fn in fns] then +; htSay '" {\em of type} " +; bcConform orig +; buttonForOp := false +; else +; htMakePage [['bcLinks,['"\menuitemstyle{}",'"",'dbInfoChoose,bincount]]] +; htSay '"{\em calls to} " +; bcConform con +; buttonForOp := true +; htSay('":\newline ") +; dbShowInfoList(fns, bincount * 8192,buttonForOp) +; bincount := bincount + 1 +; htSay '"\endmenu " + +(DEFUN |dbShowInfoOp| (|htPage| |op| |sig| |alist|) + (PROG (|domname| |opAlist| |kind| |honestConform| |faTypes| + |conArgTypes| |conform| |conname| |ops| |oppart| |head| + |heading| |locals| |arguments| |x| |y| |dollar| |rep| + |args| CONS |fromAlist| |sigAlist| |sig1| |item| |pred| + |exposeFlag| |doc| |con| |fns| |ISTMP#1| |orig| |ISTMP#2| + |origin| |buttonForOp| |bincount|) + (declare (special |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |heading| (|htpProperty| |htPage| '|heading|)) + (SPADLET |domname| (|htpProperty| |htPage| '|domname|)) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |opAlist| (|htpProperty| |htPage| '|opAlist|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |kind| (GETDATABASE |conname| 'CONSTRUCTORKIND)) + (SPADLET |honestConform| + (COND + ((BOOT-EQUAL |kind| '|category|) + (CONS (INTERN (STRCONC (PNAME |conname|) + (MAKESTRING "&"))) + (CONS '$ (CDR |conform|)))) + ('T |conform|))) + (SPADLET |faTypes| + (CDDAR (GETDATABASE |conname| + 'CONSTRUCTORMODEMAP))) + (SPADLET |conArgTypes| + (SUBLISLIS (IFCDR |conform|) + (TAKE (|#| |faTypes|) + |$FormalMapVariableList|) + |faTypes|)) + (SPADLET |conform| (|htpProperty| |htPage| '|conform|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE (|zeroOneConvert| |op|)))) + (SPADLET |oppart| + (CONS (MAKESTRING "{\\em ") + (CONS |ops| (CONS (MAKESTRING "}") NIL)))) + (SPADLET |head| + (COND + (|sig| (APPEND |oppart| + (CONS (MAKESTRING ": ") + (|dbConformGen| + (|dbInfoSig| |sig|))))) + ('T |oppart|))) + (SPADLET |heading| + (APPEND |head| + (CONS (MAKESTRING " from {\\sf ") + (CONS (|form2HtString| |conform|) + (CONS (MAKESTRING "}") NIL))))) + (DO ((G177589 |alist| (CDR G177589)) (|u| NIL)) + ((OR (ATOM G177589) + (PROGN (SETQ |u| (CAR G177589)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |x| (CAR |u|)) + (SPADLET |y| (CDR |u|)) + (COND + ((BOOT-EQUAL |x| '|locals|) + (SPADLET |locals| |y|)) + ((BOOT-EQUAL |x| '|arguments|) + (SPADLET |arguments| |y|)) + ('T + (SPADLET |fromAlist| + (CONS + (CONS |x| + (|zeroOneConvertAlist| |y|)) + |fromAlist|)))))))) + (SPADLET |fromAlist| + (PROGN + (SPADLET CONS (SPADLET |args| NIL)) + (DO ((G177599 |fromAlist| (CDR G177599)) + (|p| NIL)) + ((OR (ATOM G177599) + (PROGN + (SETQ |p| (CAR G177599)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR |p|)) + (SPADLET |y| (CDR |p|)) + |p|) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |x| $) + (SPADLET |dollar| + (CONS + (CONS |honestConform| |y|) + NIL))) + ((BOOT-EQUAL |x| '|Rep|) + (SPADLET |rep| + (CONS (CONS '|Rep| |y|) NIL))) + ((IDENTP |x|) + (SPADLET |args| + (CONS + (|dbInfoFindCat| |conform| + |conArgTypes| |p|) + |args|))) + ('T + (SPADLET CONS + (CONS (|dbInfoTran| |x| |y|) + CONS))))))) + (APPEND (|mySort| |args|) + (APPEND |dollar| + (APPEND |rep| (|mySort| CONS)))))) + (SPADLET |sigAlist| (LASSOC |op| |opAlist|)) + (SPADLET |item| + (OR (PROG (G177606) + (SPADLET G177606 NIL) + (RETURN + (DO ((G177613 NIL G177606) + (G177614 |sigAlist| + (CDR G177614)) + (|x| NIL)) + ((OR G177613 (ATOM G177614) + (PROGN + (SETQ |x| (CAR G177614)) + NIL)) + G177606) + (SEQ (EXIT + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |sig1| (QCAR |x|)) + 'T) + (BOOT-EQUAL |sig1| |sig|)) + (SETQ G177606 + (OR G177606 |x|))))))))) + (|systemError| + (MAKESTRING "cannot find signature")))) + (SPADLET |sig| (CAR |item|)) + (SPADLET |pred| (CADR |item|)) + (SPADLET |origin| (CADDR |item|)) + (SPADLET |exposeFlag| (CADDDR |item|)) + (SPADLET |doc| (CAR (CDDDDR |item|))) + (|htpSetProperty| |htPage| '|fromAlist| |fromAlist|) + (|htSayHline|) + (|htSay| (MAKESTRING + "\\center{Cross Reference for definition of {\\em ") + |ops| (MAKESTRING "}}\\beginmenu ")) + (COND + (|locals| + (|htSay| (MAKESTRING + "\\item\\menuitemstyle{}{\\em local variables:}\\newline")) + (|dbShowInfoList| |locals| 8192 NIL))) + (SPADLET |bincount| 2) + (DO ((G177635 |fromAlist| (CDR G177635)) + (G177578 NIL)) + ((OR (ATOM G177635) + (PROGN (SETQ G177578 (CAR G177635)) NIL) + (PROGN + (PROGN + (SPADLET |con| (CAR G177578)) + (SPADLET |fns| (CDR G177578)) + G177578) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING "\\item")) + (COND + ((IDENTP |con|) + (|htSay| (MAKESTRING + "\\menuitemstyle{} {\\em calls to} ")) + (COND + ((NEQUAL |con| '|Rep|) + (|htSay| (MAKESTRING + "{\\em argument} ")))) + (|htSay| |con|) + (COND + ((PROG (G177642) + (SPADLET G177642 'T) + (RETURN + (DO + ((G177653 NIL + (NULL G177642)) + (G177654 |fns| + (CDR G177654)) + (|fn| NIL)) + ((OR G177653 (ATOM G177654) + (PROGN + (SETQ |fn| (CAR G177654)) + NIL)) + G177642) + (SEQ + (EXIT + (SETQ G177642 + (AND G177642 + (AND (PAIRP |fn|) + (EQ (QCAR |fn|) '|origin|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |fn|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |orig| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL))))) + (OR + (AND (NULL |origin|) + (SPADLET |origin| + |orig|)) + (BOOT-EQUAL |origin| + |orig|)))))))))) + (|htSay| (MAKESTRING + " {\\em of type} ")) + (|bcConform| |orig|))) + (SPADLET |buttonForOp| NIL)) + ('T + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS + (MAKESTRING "\\menuitemstyle{}") + (CONS (MAKESTRING "") + (CONS '|dbInfoChoose| + (CONS |bincount| NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "{\\em calls to} ")) + (|bcConform| |con|) + (SPADLET |buttonForOp| 'T))) + (|htSay| (MAKESTRING ":\\newline ")) + (|dbShowInfoList| |fns| + (TIMES |bincount| 8192) |buttonForOp|) + (SPADLET |bincount| (PLUS |bincount| 1)))))) + (|htSay| (MAKESTRING "\\endmenu "))))))) + +;dbShowInfoList(dataItems,count,buttonForOp?) == +;--dataItems are [op,:sig] +; single? := null rest dataItems +; htSay '"\table{" +; for item in dataItems repeat +; [op,:sig] := +; item is ['origin,.,s] => +; buttonForOp? := true +; s +; item +; ops := escapeSpecialChars STRINGIMAGE op +; htSay '"{" +; if count < 16384 or not buttonForOp? then +; htSay [ops,'": "] +; atom sig => bcConform sig +; bcConform dbInfoSig sig +; else +; htMakePage [['bcLinks,[ops,'"",'dbInfoChooseSingle,count]]] +; htSay '": " +; if atom sig then htSay sig else +; bcConform dbInfoSig sig +; htSay '"}" +; count := count + 1 +; htSay '"} " +; count + +(DEFUN |dbShowInfoList| (|dataItems| |count| |buttonForOp?|) + (PROG (|single?| |ISTMP#1| |ISTMP#2| |s| |LETTMP#1| |op| |sig| |ops|) + (RETURN + (SEQ (PROGN + (SPADLET |single?| (NULL (CDR |dataItems|))) + (|htSay| (MAKESTRING "\\table{")) + (DO ((G177759 |dataItems| (CDR G177759)) (|item| NIL)) + ((OR (ATOM G177759) + (PROGN (SETQ |item| (CAR G177759)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |LETTMP#1| + (COND + ((AND (PAIRP |item|) + (EQ (QCAR |item|) '|origin|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |s| + (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |buttonForOp?| 'T) + |s|) + ('T |item|))) + (SPADLET |op| (CAR |LETTMP#1|)) + (SPADLET |sig| (CDR |LETTMP#1|)) + (SPADLET |ops| + (|escapeSpecialChars| + (STRINGIMAGE |op|))) + (|htSay| (MAKESTRING "{")) + (COND + ((OR (> 16384 |count|) + (NULL |buttonForOp?|)) + (|htSay| (CONS |ops| + (CONS (MAKESTRING ": ") NIL))) + (COND + ((ATOM |sig|) (|bcConform| |sig|)) + ('T (|bcConform| (|dbInfoSig| |sig|))))) + ('T + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |ops| + (CONS (MAKESTRING "") + (CONS '|dbInfoChooseSingle| + (CONS |count| NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING ": ")) + (COND + ((ATOM |sig|) (|htSay| |sig|)) + ('T (|bcConform| (|dbInfoSig| |sig|)))))) + (|htSay| (MAKESTRING "}")) + (SPADLET |count| (PLUS |count| 1)))))) + (|htSay| (MAKESTRING "} ")) + |count|))))) + +;dbInfoFindCat(conform,conArgTypes,u) == +; [argName,:opSigList] := u +; n := POSITION(argName,IFCDR conform) or systemError() +; t := conArgTypes . n +; [argName,:[dbInfoWrapOrigin(x,t) for x in opSigList]] + +(DEFUN |dbInfoFindCat| (|conform| |conArgTypes| |u|) + (PROG (|argName| |opSigList| |n| |t|) + (RETURN + (SEQ (PROGN + (SPADLET |argName| (CAR |u|)) + (SPADLET |opSigList| (CDR |u|)) + (SPADLET |n| + (OR (POSITION |argName| (IFCDR |conform|)) + (|systemError|))) + (SPADLET |t| (ELT |conArgTypes| |n|)) + (CONS |argName| + (PROG (G177786) + (SPADLET G177786 NIL) + (RETURN + (DO ((G177791 |opSigList| (CDR G177791)) + (|x| NIL)) + ((OR (ATOM G177791) + (PROGN (SETQ |x| (CAR G177791)) NIL)) + (NREVERSE0 G177786)) + (SEQ (EXIT (SETQ G177786 + (CONS (|dbInfoWrapOrigin| |x| |t|) + G177786))))))))))))) + +;dbInfoWrapOrigin(x, t) == +; [op, :sig] := x +; origin := dbInfoOrigin(op,sig,t) => ['origin, origin, x] +; x + +(DEFUN |dbInfoWrapOrigin| (|x| |t|) + (PROG (|op| |sig| |origin|) + (RETURN + (PROGN + (SPADLET |op| (CAR |x|)) + (SPADLET |sig| (CDR |x|)) + (COND + ((SPADLET |origin| (|dbInfoOrigin| |op| |sig| |t|)) + (CONS '|origin| (CONS |origin| (CONS |x| NIL)))) + ('T |x|)))))) + +;dbInfoOrigin(op,sig,t) == +; t is ['Join, :r] => or/[dbInfoOrigin(op,sig,x) for x in r] +; t is ['CATEGORY,:.] => false +; [sig = sig1 for [sig1,:.] in LASSOC(op, koOps(t,nil))] => t +; false + +(DEFUN |dbInfoOrigin| (|op| |sig| |t|) + (PROG (|r| |sig1|) + (RETURN + (SEQ (COND + ((AND (PAIRP |t|) (EQ (QCAR |t|) '|Join|) + (PROGN (SPADLET |r| (QCDR |t|)) 'T)) + (PROG (G177819) + (SPADLET G177819 NIL) + (RETURN + (DO ((G177825 NIL G177819) + (G177826 |r| (CDR G177826)) (|x| NIL)) + ((OR G177825 (ATOM G177826) + (PROGN (SETQ |x| (CAR G177826)) NIL)) + G177819) + (SEQ (EXIT (SETQ G177819 + (OR G177819 + (|dbInfoOrigin| |op| |sig| |x|))))))))) + ((AND (PAIRP |t|) (EQ (QCAR |t|) 'CATEGORY)) NIL) + ((PROG (G177838) + (SPADLET G177838 NIL) + (RETURN + (DO ((G177844 (LASSOC |op| (|koOps| |t| NIL)) + (CDR G177844)) + (G177815 NIL)) + ((OR (ATOM G177844) + (PROGN + (SETQ G177815 (CAR G177844)) + NIL) + (PROGN + (PROGN + (SPADLET |sig1| (CAR G177815)) + G177815) + NIL)) + (NREVERSE0 G177838)) + (SEQ (EXIT (SETQ G177838 + (CONS (BOOT-EQUAL |sig| |sig1|) + G177838))))))) + |t|) + ('T NIL)))))) + +;dbInfoTran(con,opSigList) == [con,:SUBST("$",con,mySort opSigList)] + +(DEFUN |dbInfoTran| (|con| |opSigList|) + (CONS |con| (MSUBST '$ |con| (|mySort| |opSigList|)))) + +;zeroOneConvertAlist u == [[zeroOneConvert x,:y] for [x,:y] in u] + +(DEFUN |zeroOneConvertAlist| (|u|) + (PROG (|x| |y|) + (RETURN + (SEQ (PROG (G177870) + (SPADLET G177870 NIL) + (RETURN + (DO ((G177876 |u| (CDR G177876)) (G177861 NIL)) + ((OR (ATOM G177876) + (PROGN (SETQ G177861 (CAR G177876)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G177861)) + (SPADLET |y| (CDR G177861)) + G177861) + NIL)) + (NREVERSE0 G177870)) + (SEQ (EXIT (SETQ G177870 + (CONS (CONS (|zeroOneConvert| |x|) + |y|) + G177870))))))))))) + +;dbInfoChoose(htPage,count) == +; fromAlist := htpProperty(htPage,'fromAlist) +; index := count - 2 +; [con, :alist] := fromAlist.index +; dbInfoChoose1(htPage,con,alist) + +(DEFUN |dbInfoChoose| (|htPage| |count|) + (PROG (|fromAlist| |index| |LETTMP#1| |con| |alist|) + (RETURN + (PROGN + (SPADLET |fromAlist| (|htpProperty| |htPage| '|fromAlist|)) + (SPADLET |index| (SPADDIFFERENCE |count| 2)) + (SPADLET |LETTMP#1| (ELT |fromAlist| |index|)) + (SPADLET |con| (CAR |LETTMP#1|)) + (SPADLET |alist| (CDR |LETTMP#1|)) + (|dbInfoChoose1| |htPage| |con| |alist|))))) + +;dbInfoChooseSingle(htPage,count) == +; fromAlist := htpProperty(htPage,'fromAlist) +; [index, binkey] := DIVIDE(count, 8192) +; [con, :alist] := fromAlist.(index - 2) +; item := alist . binkey +; alist := +; item is ['origin,origin,s] => +; con := origin +; [s] +; [item] +; dbInfoChoose1(htPage,con,alist) + +(DEFUN |dbInfoChooseSingle| (|htPage| |count|) + (PROG (|fromAlist| |index| |binkey| |LETTMP#1| |item| |ISTMP#1| + |origin| |ISTMP#2| |s| |con| |alist|) + (RETURN + (PROGN + (SPADLET |fromAlist| (|htpProperty| |htPage| '|fromAlist|)) + (SPADLET |LETTMP#1| (DIVIDE |count| 8192)) + (SPADLET |index| (CAR |LETTMP#1|)) + (SPADLET |binkey| (CADR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (ELT |fromAlist| (SPADDIFFERENCE |index| 2))) + (SPADLET |con| (CAR |LETTMP#1|)) + (SPADLET |alist| (CDR |LETTMP#1|)) + (SPADLET |item| (ELT |alist| |binkey|)) + (SPADLET |alist| + (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) '|origin|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |origin| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |s| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |con| |origin|) (CONS |s| NIL)) + ('T (CONS |item| NIL)))) + (|dbInfoChoose1| |htPage| |con| |alist|))))) + +;dbInfoChoose1(htPage,con,alist) == +; $conform: local := con +; opAlist := [pair for x in koOps(con,nil) | pair:=dbInfoSigMatch(x,alist)] +; page := htInitPage(nil,nil) +; htpSetProperty(page,'conform,con) +; htpSetProperty(page,'kind,PNAME GETDATABASE(opOf con,'CONSTRUCTORKIND)) +; dbShowOperationsFromConform(page,'"operation",opAlist) + +(DEFUN |dbInfoChoose1| (|htPage| |con| |alist|) + (declare (ignore |htPage|)) + (PROG (|$conform| |pair| |opAlist| |page|) + (DECLARE (SPECIAL |$conform|)) + (RETURN + (SEQ (PROGN + (SPADLET |$conform| |con|) + (SPADLET |opAlist| + (PROG (G177961) + (SPADLET G177961 NIL) + (RETURN + (DO ((G177967 (|koOps| |con| NIL) + (CDR G177967)) + (|x| NIL)) + ((OR (ATOM G177967) + (PROGN + (SETQ |x| (CAR G177967)) + NIL)) + (NREVERSE0 G177961)) + (SEQ (EXIT (COND + ((SPADLET |pair| + (|dbInfoSigMatch| |x| + |alist|)) + (SETQ G177961 + (CONS |pair| G177961)))))))))) + (SPADLET |page| (|htInitPage| NIL NIL)) + (|htpSetProperty| |page| '|conform| |con|) + (|htpSetProperty| |page| '|kind| + (PNAME (GETDATABASE (|opOf| |con|) 'CONSTRUCTORKIND))) + (|dbShowOperationsFromConform| |page| + (MAKESTRING "operation") |opAlist|)))))) + +;dbInfoSigMatch(x,alist) == +; [op,:sigAlist] := x +; candidates := [sig for [op1,:sig] in alist | op1 = op] or return nil +; sigs := [s for s in sigAlist | "or"/[first s = s1 for s1 in candidates] or +; (s2 := SUBST($conform,"$",s)) and "or"/[first s2 = s1 for s1 in candidates]] +; sigs and [op,:sigs] + +(DEFUN |dbInfoSigMatch| (|x| |alist|) + (PROG (|op| |sigAlist| |op1| |sig| |candidates| |s2| |sigs|) + (declare (special |$conform|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |x|)) + (SPADLET |sigAlist| (CDR |x|)) + (SPADLET |candidates| + (OR (PROG (G177997) + (SPADLET G177997 NIL) + (RETURN + (DO ((G178004 |alist| (CDR G178004)) + (G177986 NIL)) + ((OR (ATOM G178004) + (PROGN + (SETQ G177986 (CAR G178004)) + NIL) + (PROGN + (PROGN + (SPADLET |op1| (CAR G177986)) + (SPADLET |sig| (CDR G177986)) + G177986) + NIL)) + (NREVERSE0 G177997)) + (SEQ (EXIT + (COND + ((BOOT-EQUAL |op1| |op|) + (SETQ G177997 + (CONS |sig| G177997))))))))) + (RETURN NIL))) + (SPADLET |sigs| + (PROG (G178016) + (SPADLET G178016 NIL) + (RETURN + (DO ((G178022 |sigAlist| (CDR G178022)) + (|s| NIL)) + ((OR (ATOM G178022) + (PROGN + (SETQ |s| (CAR G178022)) + NIL)) + (NREVERSE0 G178016)) + (SEQ (EXIT (COND + ((OR + (PROG (G178028) + (SPADLET G178028 NIL) + (RETURN + (DO + ((G178034 NIL + G178028) + (G178035 + |candidates| + (CDR G178035)) + (|s1| NIL)) + ((OR G178034 + (ATOM G178035) + (PROGN + (SETQ |s1| + (CAR G178035)) + NIL)) + G178028) + (SEQ + (EXIT + (SETQ G178028 + (OR G178028 + (BOOT-EQUAL + (CAR |s|) |s1|)))))))) + (AND + (SPADLET |s2| + (MSUBST |$conform| '$ |s|)) + (PROG (G178042) + (SPADLET G178042 NIL) + (RETURN + (DO + ((G178048 NIL + G178042) + (G178049 + |candidates| + (CDR G178049)) + (|s1| NIL)) + ((OR G178048 + (ATOM G178049) + (PROGN + (SETQ |s1| + (CAR G178049)) + NIL)) + G178042) + (SEQ + (EXIT + (SETQ G178042 + (OR G178042 + (BOOT-EQUAL + (CAR |s2|) |s1|)))))))))) + (SETQ G178016 + (CONS |s| G178016)))))))))) + (AND |sigs| (CONS |op| |sigs|))))))) + +;dbInfoSig sig == +; null rest sig => first sig +; ['Mapping,:sig] + +(DEFUN |dbInfoSig| (|sig|) + (COND ((NULL (CDR |sig|)) (CAR |sig|)) ('T (CONS '|Mapping| |sig|)))) + +;--============================================================================ +;-- Code to Expand opAlist +;--============================================================================ +;dbGetExpandedOpAlist htPage == +; expand := htpProperty(htPage,'expandOperations) +; if expand ^= 'fullyExpanded then +; if null expand then htpSetProperty(htPage,'expandOperations,'lists) +; opAlist := koOps(htpProperty(htPage,'conform),nil) +; htpSetProperty(htPage,'opAlist,opAlist) +; dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",false,false) +; htpProperty(htPage,'opAlist) + +(DEFUN |dbGetExpandedOpAlist| (|htPage|) + (PROG (|expand| |opAlist|) + (RETURN + (PROGN + (SPADLET |expand| (|htpProperty| |htPage| '|expandOperations|)) + (COND + ((NEQUAL |expand| '|fullyExpanded|) + (COND + ((NULL |expand|) + (|htpSetProperty| |htPage| '|expandOperations| '|lists|))) + (SPADLET |opAlist| + (|koOps| (|htpProperty| |htPage| '|conform|) NIL)) + (|htpSetProperty| |htPage| '|opAlist| |opAlist|) + (|dbExpandOpAlistIfNecessary| |htPage| |opAlist| + (MAKESTRING "operation") NIL NIL))) + (|htpProperty| |htPage| '|opAlist|))))) + +;--============================================================================ +;-- Get Info File Alist +;--============================================================================ +;hasNewInfoAlist conname == +; (u := getInfoAlist conname) and hasNewInfoText u + +(DEFUN |hasNewInfoAlist| (|conname|) + (PROG (|u|) + (RETURN + (AND (SPADLET |u| (|getInfoAlist| |conname|)) + (|hasNewInfoText| |u|))))) + +;hasNewInfoText u == +; and/[ATOM op and and/[item is [sig,:alist] and +; null sig or null atom sig and null atom alist for item in items] for [op,:items] in u] + +(DEFUN |hasNewInfoText| (|u|) + (PROG (|op| |items| |sig| |alist|) + (RETURN + (SEQ (PROG (G178092) + (SPADLET G178092 'T) + (RETURN + (DO ((G178102 NIL (NULL G178092)) + (G178103 |u| (CDR G178103)) (G178088 NIL)) + ((OR G178102 (ATOM G178103) + (PROGN (SETQ G178088 (CAR G178103)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G178088)) + (SPADLET |items| (CDR G178088)) + G178088) + NIL)) + G178092) + (SEQ (EXIT (SETQ G178092 + (AND G178092 + (AND (ATOM |op|) + (PROG (G178111) + (SPADLET G178111 'T) + (RETURN + (DO + ((G178120 NIL + (NULL G178111)) + (G178121 |items| + (CDR G178121)) + (|item| NIL)) + ((OR G178120 + (ATOM G178121) + (PROGN + (SETQ |item| + (CAR G178121)) + NIL)) + G178111) + (SEQ + (EXIT + (SETQ G178111 + (AND G178111 + (OR + (AND (PAIRP |item|) + (PROGN + (SPADLET |sig| + (QCAR |item|)) + (SPADLET |alist| + (QCDR |item|)) + 'T) + (NULL |sig|)) + (AND + (NULL (ATOM |sig|)) + (NULL + (ATOM |alist|))))))))))))))))))))))) + +;getInfoAlist conname == +; cat? := GETDATABASE(conname,'CONSTRUCTORKIND) = 'category +; if cat? then conname := INTERN STRCONC(STRINGIMAGE conname,'"&") +; abb := constructor? conname or return '"not a constructor" +; fs := STRCONC(PNAME abb,'".nrlib/info") +; inStream := +; PROBE_-FILE fs => OPEN fs +; filename := STRCONC('"/spad/int/algebra/",PNAME abb,'".nrlib/info") +; PROBE_-FILE filename => OPEN filename +; return nil +; alist := mySort READ inStream +; if cat? then +; [.,dollarName,:.] := GETDATABASE(conname,'CONSTRUCTORFORM) +; alist := SUBST("$",dollarName,alist) +; alist + +(DEFUN |getInfoAlist| (|conname|) + (PROG (|cat?| |abb| |fs| |filename| |inStream| |LETTMP#1| + |dollarName| |alist|) + (RETURN + (PROGN + (SPADLET |cat?| + (BOOT-EQUAL (GETDATABASE |conname| 'CONSTRUCTORKIND) + '|category|)) + (COND + (|cat?| (SPADLET |conname| + (INTERN (STRCONC (STRINGIMAGE |conname|) + (MAKESTRING "&")))))) + (SPADLET |abb| + (OR (|constructor?| |conname|) + (RETURN (MAKESTRING "not a constructor")))) + (SPADLET |fs| + (STRCONC (PNAME |abb|) (MAKESTRING ".nrlib/info"))) + (SPADLET |inStream| + (COND + ((PROBE-FILE |fs|) (OPEN |fs|)) + ('T + (SPADLET |filename| + (STRCONC (MAKESTRING "/spad/int/algebra/") + (PNAME |abb|) + (MAKESTRING ".nrlib/info"))) + (COND + ((PROBE-FILE |filename|) (OPEN |filename|)) + ('T (RETURN NIL)))))) + (SPADLET |alist| (|mySort| (VMREAD |inStream|))) + (COND + (|cat?| (SPADLET |LETTMP#1| + (GETDATABASE |conname| 'CONSTRUCTORFORM)) + (SPADLET |dollarName| (CADR |LETTMP#1|)) + (SPADLET |alist| (MSUBST '$ |dollarName| |alist|)))) + |alist|)))) + +;--====================> WAS b-saturn.boot <================================ +;-- New file as of 6/95 +;$aixTestSaturn := false + +(SPADLET |$aixTestSaturn| NIL) + +;--These will be set in patches.lisp: +;--$saturn := false --true to write SATURN output to $browserOutputStream +;--$standard:= true --true to write browser output on AIX +;$saturnAmpersand := '"\&\&" + +(SPADLET |$saturnAmpersand| (MAKESTRING "\\&\\&")) + +;$saturnFileNumber --true to write DOS files for Thinkpad (testing only) +; := false + +(SPADLET |$saturnFileNumber| NIL) + +;$kPageSaturnArguments := nil --bound by $kPageSaturn + +(SPADLET |$kPageSaturnArguments| NIL) + +;$atLeastOneUnexposed := false + +(SPADLET |$atLeastOneUnexposed| NIL) + +;$saturnContextMenuLines := nil + +(SPADLET |$saturnContextMenuLines| NIL) + +;$saturnContextMenuIndex := 0 + +(SPADLET |$saturnContextMenuIndex| 0) + +;$saturnMacros := '( +; "\def\unixcommand#1#2{{\em #1}}"_ +; "\def\lispFunctionLink#1#2{\lispLink[d]{#1}{{\bf #2}}}"_ +; "\def\lispTypeLink#1#2{\lispLink[d]{#1}{{\sf #2}}}"_ +; "\def\menuitemstyle{\menubutton}"_ +; "\def\browseTitle#1{\windowTitle{#1}\section{#1}}"_ +; "\def\ttrarrow{$\rightarrow$}"_ +; "\def\spadtype#1{\lispLink[d]{\verb!(|spadtype| '|#1|)!}{\sf #1}}"_ +; "\def\spad#1{{\em #1}}"_ +; "\def\spadfun#1{{\em #1}}"_ +;) + +(SPADLET |$saturnMacros| + '("\\def\\unixcommand#1#2{{\\em #1}}" + "\\def\\lispFunctionLink#1#2{\\lispLink[d]{#1}{{\\bf #2}}}" + "\\def\\lispTypeLink#1#2{\\lispLink[d]{#1}{{\\sf #2}}}" + "\\def\\menuitemstyle{\\menubutton}" + "\\def\\browseTitle#1{\\windowTitle{#1}\\section{#1}}" + "\\def\\ttrarrow{$\\rightarrow$}" + "\\def\\spadtype#1{\\lispLink[d]{\\verb!(|spadtype| '|#1|)!}{\\sf #1}}" + "\\def\\spad#1{{\\em #1}}" "\\def\\spadfun#1{{\\em #1}}")) + +;$FormalFunctionParameterList := '(_#_#1 _#_#2 _#_#3 _#_#4 _#_#5 _#_#6 _#_#7 _#_#8 _#_#9 _#_#10 _#_#11 _#_#12 _#_#13 _#_#14 _#_#15) + +(SPADLET |$FormalFunctionParameterList| + '(|##1| |##2| |##3| |##4| |##5| |##6| |##7| |##8| |##9| |##10| + |##11| |##12| |##13| |##14| |##15|)) + +;on() == +; $saturn := true +; $standard := false + +(DEFUN |on| () + (declare (special |$saturn| |$standard|)) + (PROGN (SPADLET |$saturn| 'T) (SPADLET |$standard| NIL))) + +;off()== +; $saturn := false +; $standard := true + +(DEFUN |off| () + (declare (special |$saturn| |$standard|)) + (PROGN (SPADLET |$saturn| NIL) (SPADLET |$standard| 'T))) + +;--======================================================================= +;-- Function for testing SATURN output +;--======================================================================= +;-- protectedEVAL x == +;-- $saturn => +;-- protectedEVAL0(x, true, false) +;-- if $aixTestSaturn then protectedEVAL0(x, false, true) +;-- protectedEVAL1 x +;-- +;--protectedEVAL0(x, $saturn, $standard) == +;-- protectedEVAL1 x +;-- +;--protectedEVAL1 x == +;-- error := true +;-- val := NIL +;-- UNWIND_-PROTECT((val := saturnEVAL x; error := NIL), +;-- error => (resetStackLimits(); sendHTErrorSignal())) +;-- val +;-- +;--saturnEVAL x == +;-- fn := +;-- $aixTestSaturn => '"/tmp/sat.text" +;-- '"/windows/temp/browser.text" +;-- $saturn => +;-- saturnEvalToFile(x, fn) +;-- OBEY '"cat /tmp/sat.text" +;-- EVAL x +;--======================================================================= +;-- Functions to write DOS files to disk +;--======================================================================= +;ts(command) == +; $saturn := true +; $saturnFileNumber := false +; $standard := false +; saturnEvalToFile(command, '"/tmp/sat.text") + +(DEFUN |ts| (|command|) + (declare (special |$saturn| |$saturnFileNumber| |$standard|)) + (PROGN + (SPADLET |$saturn| 'T) + (SPADLET |$saturnFileNumber| NIL) + (SPADLET |$standard| NIL) + (|saturnEvalToFile| |command| (MAKESTRING "/tmp/sat.text")))) + +;ut() == +; $saturn := false +; $standard := true +; 'done + +(DEFUN |ut| () + (declare (special |$saturn| |$standard|)) + (PROGN (SPADLET |$saturn| NIL) (SPADLET |$standard| 'T) '|done|)) + +;onDisk() == +; $saturnFileNumber := 1 +; obey '"dosdir" + +(DEFUN |onDisk| () + (declare (special |$saturnFileNumber|)) + (PROGN + (SPADLET |$saturnFileNumber| 1) + (|obey| (MAKESTRING "dosdir")))) + +;offDisk() == +; $saturnFileNumber := false + +(DEFUN |offDisk| () + (declare (special |$saturnFileNumber|)) + (SPADLET |$saturnFileNumber| NIL)) + +;page() == +; $standard => $curPage +; $saturnPage + +(DEFUN |page| () + (declare (special |$standard| |$curPage| |$saturnPage|)) + (COND (|$standard| |$curPage|) ('T |$saturnPage|))) + +;--======================================================================= +;-- Functions that affect $saturnPage +;--======================================================================= +;htSayCold x == +; htSay '"\lispLink{}{" +; htSay x +; htSay '"}" + +(DEFUN |htSayCold| (|x|) + (PROGN + (|htSay| (MAKESTRING "\\lispLink{}{")) + (|htSay| |x|) + (|htSay| (MAKESTRING "}")))) + +;htSayIfStandard(x, :options) == --do only for $standard +; $standard => htSayBind(x,options) + +(DEFUN |htSayIfStandard| (&REST G178203 &AUX |options| |x|) + (declare (special |$standard|)) + (DSETQ (|x| . |options|) G178203) + (SEQ (COND (|$standard| (EXIT (|htSayBind| |x| |options|)))))) + +;htSayStandard(x, :options) == --do AT MOST for $standard +; $saturn: local := nil +; htSayBind(x, options) + +(DEFUN |htSayStandard| (&REST G178211 &AUX |options| |x|) + (DSETQ (|x| . |options|) G178211) + (PROG (|$saturn|) + (DECLARE (SPECIAL |$saturn|)) + (RETURN + (PROGN (SPADLET |$saturn| NIL) (|htSayBind| |x| |options|))))) + +;htSaySaturn(x, :options) == --do AT MOST for $saturn +; $standard: local := nil +; htSayBind(x, options) + +(DEFUN |htSaySaturn| (&REST G178219 &AUX |options| |x|) + (DSETQ (|x| . |options|) G178219) + (PROG (|$standard|) + (DECLARE (SPECIAL |$standard|)) + (RETURN + (PROGN (SPADLET |$standard| NIL) (|htSayBind| |x| |options|))))) + +;htSayBind(x, options) == +; bcHt x +; for y in options repeat bcHt y + +(DEFUN |htSayBind| (|x| |options|) + (SEQ (PROGN + (|bcHt| |x|) + (DO ((G178224 |options| (CDR G178224)) (|y| NIL)) + ((OR (ATOM G178224) + (PROGN (SETQ |y| (CAR G178224)) NIL)) + NIL) + (SEQ (EXIT (|bcHt| |y|))))))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;bcHt line == +; $newPage => --this path affects both saturn and old lines +; text := +; PAIRP line => [['text, :line]] +; STRINGP line => line +; [['text, line]] +; if $saturn then htpAddToPageDescription($saturnPage, text) +; if $standard then htpAddToPageDescription($curPage, text) +; PAIRP line => +; $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) +; $htLineList := [basicStringize line, :$htLineList] + +(DEFUN |bcHt| (|line|) + (PROG (|text|) + (declare (special |$newPage| |$htLineList| |$saturnPage| |$curPage| + |$standard| |$saturn|)) + (RETURN + (COND + (|$newPage| + (SPADLET |text| + (COND + ((PAIRP |line|) + (CONS (CONS '|text| |line|) NIL)) + ((STRINGP |line|) |line|) + ('T (CONS (CONS '|text| (CONS |line| NIL)) NIL)))) + (COND + (|$saturn| + (|htpAddToPageDescription| |$saturnPage| |text|))) + (COND + (|$standard| + (|htpAddToPageDescription| |$curPage| |text|)) + ('T NIL))) + ((PAIRP |line|) + (SPADLET |$htLineList| + (NCONC (NREVERSE (|mapStringize| (COPY-LIST |line|))) + |$htLineList|))) + ('T + (SPADLET |$htLineList| + (CONS (|basicStringize| |line|) |$htLineList|))))))) + +;--======================================================================= +;-- New issueHT +;--======================================================================= +;--------------------> NEW DEFINITION (see ht-util.boot.pamphlet) +;htShowPage() == +;-- show the page which has been computed +; htSayStandard '"\endscroll" +; htShowPageNoScroll() + +(DEFUN |htShowPage| () + (PROGN + (|htSayStandard| (MAKESTRING "\\endscroll")) + (|htShowPageNoScroll|))) + +;------------------> NEW DEFINITION (see ht-util.boot.pamphlet) +;htShowPageNoScroll() == +;-- show the page which has been computed +; htSayStandard '"\autobuttons" +; if $standard then +; htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) +; if $saturn then +; htpSetPageDescription($saturnPage, nreverse htpPageDescription $saturnPage) +; $newPage := false +; ---------------------- +; if $standard then +; $htLineList := nil +; htMakePage htpPageDescription $curPage +; if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) +; issueHTStandard line +; ---------------------- +; if $saturn then +; $htLineList := nil +; htMakePage htpPageDescription $saturnPage +; if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) +; issueHTSaturn line +; ---------------------- +; endHTPage() + +(DEFUN |htShowPageNoScroll| () + (PROG (|line|) + (declare (special |$newPage| |$curPage| |$saturnPage| |$htLineList| + |$saturn| |$standard|)) + (RETURN + (PROGN + (|htSayStandard| (MAKESTRING "\\autobuttons")) + (COND + (|$standard| + (|htpSetPageDescription| |$curPage| + (NREVERSE (|htpPageDescription| |$curPage|))))) + (COND + (|$saturn| + (|htpSetPageDescription| |$saturnPage| + (NREVERSE (|htpPageDescription| |$saturnPage|))))) + (SPADLET |$newPage| NIL) + (COND + (|$standard| (SPADLET |$htLineList| NIL) + (|htMakePage| (|htpPageDescription| |$curPage|)) + (COND + (|$htLineList| + (SPADLET |line| + (APPLY (|function| CONCAT) + (NREVERSE |$htLineList|))))) + (|issueHTStandard| |line|))) + (COND + (|$saturn| (SPADLET |$htLineList| NIL) + (|htMakePage| (|htpPageDescription| |$saturnPage|)) + (COND + (|$htLineList| + (SPADLET |line| + (APPLY (|function| CONCAT) + (NREVERSE |$htLineList|))))) + (|issueHTSaturn| |line|))) + (|endHTPage|))))) + +;--------------------> NEW DEFINITION <-------------------------- +;issueHTSaturn line == --called by htMakePageNoScroll and htMakeErrorPage +; if $saturn then +; $marg : local := 0 +; $linelength: local := 80 +; writeSaturn '"\inputonce{/doc/browser/browmacs.tex}" +; writeSaturnPrefix() +; writeSaturn(line) +; writeSaturnSuffix() +; if $saturnFileNumber then +; fn := STRCONC('"sat", STRINGIMAGE $saturnFileNumber, '".tex") +; obey STRCONC('"doswrite -a saturn.tex ",fn, '".tex") +; $saturnFileNumber := $saturnFileNumber + 1 + +(DEFUN |issueHTSaturn| (|line|) + (PROG (|$marg| |$linelength| |fn|) + (DECLARE (SPECIAL |$marg| |$linelength| |$saturnFileNumber| |$saturn|)) + (RETURN + (COND + (|$saturn| (SPADLET |$marg| 0) (SPADLET |$linelength| 80) + (|writeSaturn| + (MAKESTRING + "\\inputonce{/doc/browser/browmacs.tex}")) + (|writeSaturnPrefix|) (|writeSaturn| |line|) + (|writeSaturnSuffix|) + (COND + (|$saturnFileNumber| + (SPADLET |fn| + (STRCONC (MAKESTRING "sat") + (STRINGIMAGE |$saturnFileNumber|) + (MAKESTRING ".tex"))) + (|obey| (STRCONC (MAKESTRING + "doswrite -a saturn.tex ") + |fn| (MAKESTRING ".tex"))) + (SPADLET |$saturnFileNumber| + (PLUS |$saturnFileNumber| 1))) + ('T NIL))) + ('T NIL))))) + +;writeSaturnPrefix() == +; $saturnContextMenuLines => +; index := +; STRINGIMAGE ($saturnContextMenuIndex := $saturnContextMenuIndex + 1) +; writeSaturnLines +; ['"\newmenu{BCM", index, +; '"}{",:nreverse $saturnContextMenuLines, +; '"}\usemenu{BCM", index,'"}{\vbox{"] + +(DEFUN |writeSaturnPrefix| () + (PROG (|index|) + (declare (special |$saturnContextMenuLines| |$saturnContextMenuIndex|)) + (RETURN + (SEQ (COND + (|$saturnContextMenuLines| + (EXIT (PROGN + (SPADLET |index| + (STRINGIMAGE + (SPADLET + |$saturnContextMenuIndex| + (PLUS |$saturnContextMenuIndex| + 1)))) + (|writeSaturnLines| + (CONS (MAKESTRING "\\newmenu{BCM") + (CONS |index| + (CONS (MAKESTRING "}{") + (APPEND + (NREVERSE + |$saturnContextMenuLines|) + (CONS + (MAKESTRING "}\\usemenu{BCM") + (CONS |index| + (CONS (MAKESTRING "}{\\vbox{") + NIL)))))))))))))))) + +;writeSaturnSuffix() == +; $saturnContextMenuLines => saturnPRINTEXP '"}}" + +(DEFUN |writeSaturnSuffix| () + (declare (special |$saturnContextMenuLines|)) + (SEQ (COND + (|$saturnContextMenuLines| + (EXIT (|saturnPRINTEXP| (MAKESTRING "}}"))))))) + +;issueHTStandard line == --called by htMakePageNoScroll and htMakeErrorPage +; if $standard then +; --unescapeStringsInForm line +; sockSendInt($MenuServer, $SendLine) +; sockSendString($MenuServer, line) + +(DEFUN |issueHTStandard| (|line|) + (declare (special |$standard| |$MenuServer| |$SendLine|)) + (COND + (|$standard| (|sockSendInt| |$MenuServer| |$SendLine|) + (|sockSendString| |$MenuServer| |line|)) + ('T NIL))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htMakeErrorPage htPage == +; $newPage := false +; $htLineList := nil +; if $standard then $curPage := htPage +; if $saturn then $saturnPage := htPage +; htMakePage htpPageDescription htPage +; line := APPLY(function CONCAT, nreverse $htLineList) +; issueHT line +; endHTPage() + +(DEFUN |htMakeErrorPage| (|htPage|) + (PROG (|line|) + (declare (special |$newPage| |$htLineList| |$curPage| |$saturnPage| + |$standard| |$saturn|)) + (RETURN + (PROGN + (SPADLET |$newPage| NIL) + (SPADLET |$htLineList| NIL) + (COND (|$standard| (SPADLET |$curPage| |htPage|))) + (COND (|$saturn| (SPADLET |$saturnPage| |htPage|))) + (|htMakePage| (|htpPageDescription| |htPage|)) + (SPADLET |line| + (APPLY (|function| CONCAT) (NREVERSE |$htLineList|))) + (|issueHT| |line|) + (|endHTPage|))))) + +;writeSaturnLines lines == +; for line in lines repeat +; if line ^= '"" and line.0 = char '_\ then saturnTERPRI() +; saturnPRINTEXP line + +(DEFUN |writeSaturnLines| (|lines|) + (SEQ (DO ((G178298 |lines| (CDR G178298)) (|line| NIL)) + ((OR (ATOM G178298) + (PROGN (SETQ |line| (CAR G178298)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((AND (NEQUAL |line| (MAKESTRING "")) + (BOOT-EQUAL (ELT |line| 0) + (|char| '|\\|))) + (|saturnTERPRI|))) + (|saturnPRINTEXP| |line|))))))) + +;writeSaturn(line) == +; k := 0 +; n := MAXINDEX line +; while --advance k if true +; k > n => false +; line.k ^= char '_\ => true +; code := isBreakSegment?(line, k + 1,n) => false +; true +; repeat (k := k + 1) +; k > n => writeSaturnPrint(line) +; segment := SUBSTRING(line,0,k) +; writeSaturnPrint(segment) +; code = 1 => +; writeSaturnPrint('"\\") +; writeSaturn SUBSTRING(line,k + 2, nil) +; code = 2 => +; writeSaturnPrint('" &") +; writeSaturn SUBSTRING(line,k + 4, nil) +; code = 3 => +; writeSaturnPrint('"\item") +; writeSaturn SUBSTRING(line,k + 5,nil) +; code = 4 => +; writeSaturnPrint('"\newline") +; writeSaturn SUBSTRING(line,k + 8,nil) +; code = 5 => +; writeSaturnPrint('"\table{") +; $marg := $marg + 3 +; writeSaturnTable SUBSTRING(line,k + 7,nil) +; code = 6 => +; i := charPosition(char '_},line,k + 4) +; tabCode := SUBSTRING(line,k, i - k + 1) +; writeSaturnPrint tabCode +; line := SUBSTRING(line,i + 1, nil) +; writeSaturn line +; code = 7 => +; saturnTERPRI() +; writeSaturn SUBSTRING(line, k + 2,nil) +; code = 8 => +; i := +; substring?('"\beginmenu", line,k) => k + 9 +; substring?('"\beginscroll",line,k) => k + 11 +; charPosition(char '_},line,k) +; if char '_[ = line.(i + 1) then +; i := charPosition(char '_], line, i + 2) +; beginCode := SUBSTRING(line,k, i - k + 1) +; writeSaturnPrint(beginCode) +; line := SUBSTRING(line,i + 1,nil) +; writeSaturn line +; code = 9 => +; i := +; substring?('"\endmenu",line,k) => k + 7 +; substring?('"\endscroll",line,k) => k + 9 +; charPosition(char '_},line,k) +; endCode := SUBSTRING(line,k, i - k + 1) +; writeSaturnPrint(endCode) +; line := SUBSTRING(line,i + 1,nil) +; $marg := $marg - 3 +; writeSaturn line +; systemError code + +(DEFUN |writeSaturn| (|line|) + (PROG (|n| |code| |k| |segment| |tabCode| |beginCode| |i| |endCode|) + (declare (special |$marg|)) + (RETURN + (SEQ (PROGN + (SPADLET |k| 0) + (SPADLET |n| (MAXINDEX |line|)) + (DO () + ((NULL (COND + ((> |k| |n|) NIL) + ((NEQUAL (ELT |line| |k|) (|char| '|\\|)) 'T) + ((SPADLET |code| + (|isBreakSegment?| |line| + (PLUS |k| 1) |n|)) + NIL) + ('T 'T))) + NIL) + (SEQ (EXIT (SPADLET |k| (PLUS |k| 1))))) + (COND + ((> |k| |n|) (|writeSaturnPrint| |line|)) + ('T (SPADLET |segment| (SUBSTRING |line| 0 |k|)) + (|writeSaturnPrint| |segment|) + (COND + ((EQL |code| 1) + (|writeSaturnPrint| (MAKESTRING "\\\\")) + (|writeSaturn| (SUBSTRING |line| (PLUS |k| 2) NIL))) + ((EQL |code| 2) + (|writeSaturnPrint| (MAKESTRING " &")) + (|writeSaturn| (SUBSTRING |line| (PLUS |k| 4) NIL))) + ((EQL |code| 3) + (|writeSaturnPrint| (MAKESTRING "\\item")) + (|writeSaturn| (SUBSTRING |line| (PLUS |k| 5) NIL))) + ((EQL |code| 4) + (|writeSaturnPrint| (MAKESTRING "\\newline")) + (|writeSaturn| (SUBSTRING |line| (PLUS |k| 8) NIL))) + ((EQL |code| 5) + (|writeSaturnPrint| (MAKESTRING "\\table{")) + (SPADLET |$marg| (PLUS |$marg| 3)) + (|writeSaturnTable| + (SUBSTRING |line| (PLUS |k| 7) NIL))) + ((EQL |code| 6) + (SPADLET |i| + (|charPosition| (|char| '}) |line| + (PLUS |k| 4))) + (SPADLET |tabCode| + (SUBSTRING |line| |k| + (PLUS (SPADDIFFERENCE |i| |k|) 1))) + (|writeSaturnPrint| |tabCode|) + (SPADLET |line| (SUBSTRING |line| (PLUS |i| 1) NIL)) + (|writeSaturn| |line|)) + ((EQL |code| 7) (|saturnTERPRI|) + (|writeSaturn| (SUBSTRING |line| (PLUS |k| 2) NIL))) + ((EQL |code| 8) + (SPADLET |i| + (COND + ((|substring?| (MAKESTRING "\\beginmenu") + |line| |k|) + (PLUS |k| 9)) + ((|substring?| + (MAKESTRING "\\beginscroll") |line| + |k|) + (PLUS |k| 11)) + ('T + (|charPosition| (|char| '}) |line| |k|)))) + (COND + ((BOOT-EQUAL (|char| '[) + (ELT |line| (PLUS |i| 1))) + (SPADLET |i| + (|charPosition| (|char| ']) |line| + (PLUS |i| 2))))) + (SPADLET |beginCode| + (SUBSTRING |line| |k| + (PLUS (SPADDIFFERENCE |i| |k|) 1))) + (|writeSaturnPrint| |beginCode|) + (SPADLET |line| (SUBSTRING |line| (PLUS |i| 1) NIL)) + (|writeSaturn| |line|)) + ((EQL |code| 9) + (SPADLET |i| + (COND + ((|substring?| (MAKESTRING "\\endmenu") + |line| |k|) + (PLUS |k| 7)) + ((|substring?| (MAKESTRING "\\endscroll") + |line| |k|) + (PLUS |k| 9)) + ('T + (|charPosition| (|char| '}) |line| |k|)))) + (SPADLET |endCode| + (SUBSTRING |line| |k| + (PLUS (SPADDIFFERENCE |i| |k|) 1))) + (|writeSaturnPrint| |endCode|) + (SPADLET |line| (SUBSTRING |line| (PLUS |i| 1) NIL)) + (SPADLET |$marg| (SPADDIFFERENCE |$marg| 3)) + (|writeSaturn| |line|)) + ('T (|systemError| |code|)))))))))) + +;isBreakSegment?(line, k, n) == +; k > n => nil +; char2 := line . k +; char2 = (char '_\) => 1 +; char2 = (char '_&) => +; substring?('"&\&", line, k) => 2 +; nil +; char2 = char 'i => +; substring?('"item",line,k) => 3 +; nil +; char2 = char 'n => +; substring?('"newline",line,k) => 4 +; nil +; char2 = char 't => +; (k := k + 2) > n => nil +; line.(k - 1) = char 'a and line.k = char 'b => +; (k := k + 1) > n => nil +; line.k = char "{" => 6 +; substring?('"table",line,k - 3) => 5 +; nil +; char2 = (char '_!) => 7 +; char2 = char 'b => +; substring?('"begin",line,k) => 8 +; nil +; char2 = (char 'e) => +; substring?('"end",line,k) => 9 +; nil +; nil + +(DEFUN |isBreakSegment?| (|line| |k| |n|) + (PROG (|char2|) + (RETURN + (COND + ((> |k| |n|) NIL) + ('T (SPADLET |char2| (ELT |line| |k|)) + (COND + ((BOOT-EQUAL |char2| (|char| '|\\|)) 1) + ((BOOT-EQUAL |char2| (|char| '&)) + (COND + ((|substring?| (MAKESTRING "&\\&") |line| |k|) 2) + ('T NIL))) + ((BOOT-EQUAL |char2| (|char| '|i|)) + (COND + ((|substring?| (MAKESTRING "item") |line| |k|) 3) + ('T NIL))) + ((BOOT-EQUAL |char2| (|char| '|n|)) + (COND + ((|substring?| (MAKESTRING "newline") |line| |k|) 4) + ('T NIL))) + ((BOOT-EQUAL |char2| (|char| '|t|)) + (COND + ((> (SPADLET |k| (PLUS |k| 2)) |n|) NIL) + ((AND (BOOT-EQUAL (ELT |line| (SPADDIFFERENCE |k| 1)) + (|char| '|a|)) + (BOOT-EQUAL (ELT |line| |k|) (|char| '|b|))) + (COND + ((> (SPADLET |k| (PLUS |k| 1)) |n|) NIL) + ((BOOT-EQUAL (ELT |line| |k|) (|char| '{)) 6) + ((|substring?| (MAKESTRING "table") |line| + (SPADDIFFERENCE |k| 3)) + 5) + ('T NIL))))) + ((BOOT-EQUAL |char2| (|char| '!)) 7) + ((BOOT-EQUAL |char2| (|char| '|b|)) + (COND + ((|substring?| (MAKESTRING "begin") |line| |k|) 8) + ('T NIL))) + ((BOOT-EQUAL |char2| (|char| '|e|)) + (COND + ((|substring?| (MAKESTRING "end") |line| |k|) 9) + ('T NIL))) + ('T NIL))))))) + +;writeSaturnPrint s == +; for i in 0..($marg - 1) repeat saturnPRINTEXP '" " +; saturnPRINTEXP s +; saturnTERPRI() + +(DEFUN |writeSaturnPrint| (|s|) + (declare (special |$marg|)) + (SEQ (PROGN + (DO ((G178364 (SPADDIFFERENCE |$marg| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G178364) NIL) + (SEQ (EXIT (|saturnPRINTEXP| (MAKESTRING " "))))) + (|saturnPRINTEXP| |s|) + (|saturnTERPRI|)))) + +;saturnPRINTEXP s == +; $browserOutputStream => PRINTEXP(s,$browserOutputStream) +; PRINTEXP s + +(DEFUN |saturnPRINTEXP| (|s|) + (declare (special |$browserOutputStream| |$browserOutputStream|)) + (COND + (|$browserOutputStream| (PRINTEXP |s| |$browserOutputStream|)) + ('T (PRINTEXP |s|)))) + +;saturnTERPRI() == +; $browserOutputStream => TERPRI($browserOutputStream) +; TERPRI() + +(DEFUN |saturnTERPRI| () + (declare (special |$browserOutputStream|)) + (COND + (|$browserOutputStream| (TERPRI |$browserOutputStream|)) + ('T (TERPRI)))) + +;writeSaturnTable line == +; open := charPosition(char '"_{",line,0) +; close:= charPosition(char '"_}",line,0) +; open < close => +; close := findBalancingBrace(line,open + 1,MAXINDEX line,0) or error '"no balancing brace" +; writeSaturnPrint SUBSTRING(line,0,close + 1) +; writeSaturnTable SUBSTRING(line,close + 1,nil) +; $marg := $marg - 3 +; writeSaturnPrint SUBSTRING(line,0,close + 1) +; writeSaturn SUBSTRING(line, close + 1,nil) + +(DEFUN |writeSaturnTable| (|line|) + (PROG (|open| |close|) + (declare (special |$marg|)) + (RETURN + (PROGN + (SPADLET |open| + (|charPosition| (|char| (MAKESTRING "{")) |line| 0)) + (SPADLET |close| + (|charPosition| (|char| (MAKESTRING "}")) |line| 0)) + (COND + ((> |close| |open|) + (SPADLET |close| + (OR (|findBalancingBrace| |line| (PLUS |open| 1) + (MAXINDEX |line|) 0) + (|error| (MAKESTRING "no balancing brace")))) + (|writeSaturnPrint| (SUBSTRING |line| 0 (PLUS |close| 1))) + (|writeSaturnTable| (SUBSTRING |line| (PLUS |close| 1) NIL))) + ('T (SPADLET |$marg| (SPADDIFFERENCE |$marg| 3)) + (|writeSaturnPrint| (SUBSTRING |line| 0 (PLUS |close| 1))) + (|writeSaturn| (SUBSTRING |line| (PLUS |close| 1) NIL)))))))) + +;findBalancingBrace(s,k,n,level) == +; k > n => nil +; c := s . k +; c = char '_{ => findBalancingBrace(s, k + 1, n, level + 1) +; c = char '_} => +; level = 0 => k +; findBalancingBrace(s, k + 1, n, level - 1) +; findBalancingBrace(s, k + 1, n, level) + +(DEFUN |findBalancingBrace| (|s| |k| |n| |level|) + (PROG (|c|) + (RETURN + (COND + ((> |k| |n|) NIL) + ('T (SPADLET |c| (ELT |s| |k|)) + (COND + ((BOOT-EQUAL |c| (|char| '{)) + (|findBalancingBrace| |s| (PLUS |k| 1) |n| + (PLUS |level| 1))) + ((BOOT-EQUAL |c| (|char| '})) + (COND + ((EQL |level| 0) |k|) + ('T + (|findBalancingBrace| |s| (PLUS |k| 1) |n| + (SPADDIFFERENCE |level| 1))))) + ('T (|findBalancingBrace| |s| (PLUS |k| 1) |n| |level|)))))))) + +;--======================================================================= +;-- htMakePage and friends +;--======================================================================= +;htMakePageStandard itemList == +; $saturn => nil +; htMakePage itemList + +(DEFUN |htMakePageStandard| (|itemList|) + (declare (special |$saturn|)) + (COND (|$saturn| NIL) ('T (|htMakePage| |itemList|)))) + +;htMakePageSaturn itemList == +; $standard => nil +; htMakePage itemList + +(DEFUN |htMakePageSaturn| (|itemList|) + (declare (special |$standard|)) + (COND (|$standard| NIL) ('T (|htMakePage| |itemList|)))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htMakePage itemList == +; if $newPage then +; if $saturn then htpAddToPageDescription($saturnPage, saturnTran itemList) +; if $standard then htpAddToPageDescription($curPage, itemList) +; htMakePage1 itemList + +(DEFUN |htMakePage| (|itemList|) + (declare (special |$newPage| |$curPage| |$standard| |$saturn| |$saturnPage|)) + (PROGN + (COND + (|$newPage| + (COND + (|$saturn| + (|htpAddToPageDescription| |$saturnPage| + (|saturnTran| |itemList|)))) + (COND + (|$standard| + (|htpAddToPageDescription| |$curPage| |itemList|)) + ('T NIL)))) + (|htMakePage1| |itemList|))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htMakePage1 itemList == +;-- make a page given the description in itemList +; for u in itemList repeat +; itemType := 'text +; items := +; STRINGP u => u +; ATOM u => STRINGIMAGE u +; STRINGP first u => u +; u is ['text, :s] => s +; itemType := first u +; rest u +; itemType = 'text => iht items +;-- $saturn => bcHt items +;-- $standard => iht items +; itemType = 'lispLinks => htLispLinks items +; itemType = 'lispmemoLinks => htLispMemoLinks items +; itemType = 'bcLinks => htBcLinks items ---> +; itemType = 'bcLinksNS => htBcLinks(items,true) +; itemType = 'bcLispLinks => htBcLispLinks items ---> +; itemType = 'radioButtons => htRadioButtons items +; itemType = 'bcRadioButtons => htBcRadioButtons items +; itemType = 'inputStrings => htInputStrings items +; itemType = 'domainConditions => htProcessDomainConditions items +; itemType = 'bcStrings => htProcessBcStrings items +; itemType = 'toggleButtons => htProcessToggleButtons items +; itemType = 'bcButtons => htProcessBcButtons items +; itemType = 'doneButton => htProcessDoneButton items +; itemType = 'doitButton => htProcessDoitButton items +; systemError '"unexpected branch" + +(DEFUN |htMakePage1| (|itemList|) + (PROG (|s| |itemType| |items|) + (RETURN + (SEQ (DO ((G178417 |itemList| (CDR G178417)) (|u| NIL)) + ((OR (ATOM G178417) + (PROGN (SETQ |u| (CAR G178417)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |itemType| '|text|) + (SPADLET |items| + (COND + ((STRINGP |u|) |u|) + ((ATOM |u|) (STRINGIMAGE |u|)) + ((STRINGP (CAR |u|)) |u|) + ((AND (PAIRP |u|) + (EQ (QCAR |u|) '|text|) + (PROGN + (SPADLET |s| (QCDR |u|)) + 'T)) + |s|) + ('T (SPADLET |itemType| (CAR |u|)) + (CDR |u|)))) + (COND + ((BOOT-EQUAL |itemType| '|text|) + (|iht| |items|)) + ((BOOT-EQUAL |itemType| '|lispLinks|) + (|htLispLinks| |items|)) + ((BOOT-EQUAL |itemType| '|lispmemoLinks|) + (|htLispMemoLinks| |items|)) + ((BOOT-EQUAL |itemType| '|bcLinks|) + (|htBcLinks| |items|)) + ((BOOT-EQUAL |itemType| '|bcLinksNS|) + (|htBcLinks| |items| 'T)) + ((BOOT-EQUAL |itemType| '|bcLispLinks|) + (|htBcLispLinks| |items|)) + ((BOOT-EQUAL |itemType| '|radioButtons|) + (|htRadioButtons| |items|)) + ((BOOT-EQUAL |itemType| '|bcRadioButtons|) + (|htBcRadioButtons| |items|)) + ((BOOT-EQUAL |itemType| '|inputStrings|) + (|htInputStrings| |items|)) + ((BOOT-EQUAL |itemType| + '|domainConditions|) + (|htProcessDomainConditions| |items|)) + ((BOOT-EQUAL |itemType| '|bcStrings|) + (|htProcessBcStrings| |items|)) + ((BOOT-EQUAL |itemType| '|toggleButtons|) + (|htProcessToggleButtons| |items|)) + ((BOOT-EQUAL |itemType| '|bcButtons|) + (|htProcessBcButtons| |items|)) + ((BOOT-EQUAL |itemType| '|doneButton|) + (|htProcessDoneButton| |items|)) + ((BOOT-EQUAL |itemType| '|doitButton|) + (|htProcessDoitButton| |items|)) + ('T + (|systemError| + (MAKESTRING "unexpected branch")))))))))))) + +;saturnTran x == +; x is [[kind, [s1, s2, :callTail]]] and MEMQ(kind,'(bcLinks bcLispLinks)) => +; text := saturnTranText s2 +; fs := getCallBackFn callTail +; y := isMenuItemStyle? s1 => ----> y is text for button in 2nd column +; t1 := mkDocLink(fs, mkMenuButton()) +; y = '"" => +; s2 = '"" => t1 +; mkTabularItem [t1, text] +; t2 := mkDocLink(fs, y) +; mkTabularItem [t1, t2, text] +; t := mkDocLink(fs, s1) +; [:t, :text] +; x is [['text,:r],:.] => r +; error nil + +(DEFUN |saturnTran| (|x|) + (PROG (|kind| |ISTMP#2| |ISTMP#3| |s1| |ISTMP#4| |s2| |callTail| + |text| |fs| |y| |t1| |t2| |t| |ISTMP#1| |r|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCDR |x|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |kind| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |s1| (QCAR |ISTMP#3|)) + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |s2| (QCAR |ISTMP#4|)) + (SPADLET |callTail| + (QCDR |ISTMP#4|)) + 'T))))))))) + (MEMQ |kind| '(|bcLinks| |bcLispLinks|))) + (SPADLET |text| (|saturnTranText| |s2|)) + (SPADLET |fs| (|getCallBackFn| |callTail|)) + (COND + ((SPADLET |y| (|isMenuItemStyle?| |s1|)) + (SPADLET |t1| (|mkDocLink| |fs| (|mkMenuButton|))) + (COND + ((BOOT-EQUAL |y| (MAKESTRING "")) + (COND + ((BOOT-EQUAL |s2| (MAKESTRING "")) |t1|) + ('T (|mkTabularItem| (CONS |t1| (CONS |text| NIL)))))) + ('T (SPADLET |t2| (|mkDocLink| |fs| |y|)) + (|mkTabularItem| + (CONS |t1| (CONS |t2| (CONS |text| NIL))))))) + ('T (SPADLET |t| (|mkDocLink| |fs| |s1|)) + (APPEND |t| |text|)))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|text|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) + |r|) + ('T (|error| NIL)))))) + +;mkBold s == +; secondPart := +; atom s => [s, '"}"] +; [:s, '"}"] +; ['"{\bf ", :secondPart] + +(DEFUN |mkBold| (|s|) + (PROG (|secondPart|) + (RETURN + (PROGN + (SPADLET |secondPart| + (COND + ((ATOM |s|) (CONS |s| (CONS (MAKESTRING "}") NIL))) + ('T (APPEND |s| (CONS (MAKESTRING "}") NIL))))) + (CONS (MAKESTRING "{\\bf ") |secondPart|))))) + +;mkMenuButton() == [menuButton()] + +(DEFUN |mkMenuButton| () (CONS (|menuButton|) NIL)) + +;menuButton() == '"\menuitemstyle{}" + +(DEFUN |menuButton| () (MAKESTRING "\\menuitemstyle{}")) + +;-- Saturn must translate \menuitemstyle ==> {\menuButton} +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;--replaces htMakeButton +;getCallBackFn form == +; func := mkCurryFun(first form, rest form) +; STRCONC('"(|htDoneButton| '|", func, '"| ",htpName page(), '")") + +(DEFUN |getCallBackFn| (|form|) + (PROG (|func|) + (RETURN + (PROGN + (SPADLET |func| (|mkCurryFun| (CAR |form|) (CDR |form|))) + (STRCONC (MAKESTRING "(|htDoneButton| '|") |func| + (MAKESTRING "| ") (|htpName| (|page|)) + (MAKESTRING ")")))))) + +;mkDocLink(code,s) == +; if atom code then code := [code] +; if atom s then s := [s] +; ['"\lispLink[d]{\verb!", :code, '"!}{", :s, '"}"] + +(DEFUN |mkDocLink| (|code| |s|) + (PROGN + (COND ((ATOM |code|) (SPADLET |code| (CONS |code| NIL)))) + (COND ((ATOM |s|) (SPADLET |s| (CONS |s| NIL)))) + (CONS (MAKESTRING "\\lispLink[d]{\\verb!") + (APPEND |code| + (CONS (MAKESTRING "!}{") + (APPEND |s| (CONS (MAKESTRING "}") NIL))))))) + +;saturnTranText x == +; STRINGP x => [unTab x] +; null x => nil +; r is [s,fn,:.] and s = '"\unixcommand{" => ['"{\it ",s,'".spad}"] +; x is [['text, :s],:r] => unTab [:s, :saturnTranText r] +; error nil + +(DEFUN |saturnTranText| (|x|) + (PROG (|fn| |ISTMP#1| |s| |r|) + (RETURN + (COND + ((STRINGP |x|) (CONS (|unTab| |x|) NIL)) + ((NULL |x|) NIL) + ((AND (PAIRP |r|) + (PROGN + (SPADLET |s| (QCAR |r|)) + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |fn| (QCAR |ISTMP#1|)) 'T))) + (BOOT-EQUAL |s| (MAKESTRING "\\unixcommand{"))) + (CONS (MAKESTRING "{\\it ") + (CONS |s| (CONS (MAKESTRING ".spad}") NIL)))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|text|) + (PROGN (SPADLET |s| (QCDR |ISTMP#1|)) 'T))) + (PROGN (SPADLET |r| (QCDR |x|)) 'T)) + (|unTab| (APPEND |s| (|saturnTranText| |r|)))) + ('T (|error| NIL)))))) + +;isMenuItemStyle? s == +; 15 = STRING_<('"\menuitemstyle{", s) => SUBSTRING(s,15,(MAXINDEX s) - 15) +; nil + +(DEFUN |isMenuItemStyle?| (|s|) + (COND + ((EQL 15 (STRING< (MAKESTRING "\\menuitemstyle{") |s|)) + (SUBSTRING |s| 15 (SPADDIFFERENCE (MAXINDEX |s|) 15))) + ('T NIL))) + +;getCallBack callTail == +; LASSOC(callTail, $callTailList) or +; callTail is [fn] => callTail +; error nil + +(DEFUN |getCallBack| (|callTail|) + (PROG (|fn|) + (declare (special |$callTailList|)) + (RETURN + (OR (LASSOC |callTail| |$callTailList|) + (COND + ((AND (PAIRP |callTail|) (EQ (QCDR |callTail|) NIL) + (PROGN (SPADLET |fn| (QCAR |callTail|)) 'T)) + |callTail|) + ('T (|error| NIL))))))) + +;--======================================================================= +;-- Redefinitions from hypertex.boot +;--======================================================================= +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;endHTPage() == +; $standard => sockSendInt($MenuServer, $EndOfPage) +; nil + +(DEFUN |endHTPage| () + (declare (special |$standard| |$MenuServer| |$EndOfPage|)) + (COND + (|$standard| (|sockSendInt| |$MenuServer| |$EndOfPage|)) + ('T NIL))) + +;--======================================================================= +;-- Redefinitions from ht-util.boot +;--======================================================================= +;htSayHrule() == bcHt +; $saturn => '"\hrule{}\newline{}" +; '"\horizontalline{}\newline{}" + +(DEFUN |htSayHrule| () + (declare (special |$saturn|)) + (|bcHt| (COND + (|$saturn| (MAKESTRING "\\hrule{}\\newline{}")) + ('T (MAKESTRING "\\horizontalline{}\\newline{}"))))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htpAddInputAreaProp(htPage, label, prop) == +;------------> Add STRINGIMAGE +; SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) + +(DEFUN |htpAddInputAreaProp| (|htPage| |label| |prop|) + (SETELT |htPage| 5 + (CONS (CONS |label| (CONS NIL (CONS NIL (CONS NIL |prop|)))) + (ELT |htPage| 5)))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htpSetLabelInputString(htPage, label, val) == +;------------> Add STRINGIMAGE +;-- value user typed as input string on page +; props := LASSOC(label, htpInputAreaAlist htPage) +; props => SETELT(props, 0, STRINGIMAGE val) +; nil + +(DEFUN |htpSetLabelInputString| (|htPage| |label| |val|) + (PROG (|props|) + (RETURN + (PROGN + (SPADLET |props| + (LASSOC |label| (|htpInputAreaAlist| |htPage|))) + (COND + (|props| (SETELT |props| 0 (STRINGIMAGE |val|))) + ('T NIL)))))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htDoneButton(func, htPage, :optionalArgs) == +;------> Handle argument values passed from page if present +; if optionalArgs then +; htpSetInputAreaAlist(htPage,CAR optionalArgs) +; typeCheckInputAreas htPage => +; htMakeErrorPage htPage +; NULL FBOUNDP func => +; systemError ['"unknown function", func] +; FUNCALL(SYMBOL_-FUNCTION func, htPage) + +(DEFUN |htDoneButton| + (&REST G178588 &AUX |optionalArgs| |htPage| |func|) + (DSETQ (|func| |htPage| . |optionalArgs|) G178588) + (PROGN + (COND + (|optionalArgs| + (|htpSetInputAreaAlist| |htPage| (CAR |optionalArgs|)))) + (COND + ((|typeCheckInputAreas| |htPage|) (|htMakeErrorPage| |htPage|)) + ((NULL (FBOUNDP |func|)) + (|systemError| + (CONS (MAKESTRING "unknown function") (CONS |func| NIL)))) + ('T (FUNCALL (SYMBOL-FUNCTION |func|) |htPage|))))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htBcLinks(links,:options) == +; skipStateInfo? := IFCAR options +; [links,options] := beforeAfter('options,links) +; for [message, info, func, :value] in links repeat +; link := +; $saturn => '"\lispLink[d]" +; '"\lispdownlink" +; htMakeButton(link,message, +; mkCurryFun(func, value),skipStateInfo?) +; bcIssueHt info + +(DEFUN |htBcLinks| (&REST G178631 &AUX |options| |links|) + (DSETQ (|links| . |options|) G178631) + (PROG (|skipStateInfo?| |LETTMP#1| |message| |info| |func| |value| + |link|) + (declare (special |$saturn|)) + (RETURN + (SEQ (PROGN + (SPADLET |skipStateInfo?| (IFCAR |options|)) + (SPADLET |LETTMP#1| (|beforeAfter| '|options| |links|)) + (SPADLET |links| (CAR |LETTMP#1|)) + (SPADLET |options| (CADR |LETTMP#1|)) + (DO ((G178612 |links| (CDR G178612)) (G178598 NIL)) + ((OR (ATOM G178612) + (PROGN (SETQ G178598 (CAR G178612)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G178598)) + (SPADLET |info| (CADR G178598)) + (SPADLET |func| (CADDR G178598)) + (SPADLET |value| (CDDDR G178598)) + G178598) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |link| + (COND + (|$saturn| + (MAKESTRING "\\lispLink[d]")) + ('T + (MAKESTRING "\\lispdownlink")))) + (|htMakeButton| |link| |message| + (|mkCurryFun| |func| |value|) + |skipStateInfo?|) + (|bcIssueHt| |info|)))))))))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htBcLispLinks links == +; [links,options] := beforeAfter('options,links) +; for [message, info, func, :value] in links repeat +; link := +; $saturn => '"\lispLink[n]" +; '"\lisplink" +; htMakeButton(link ,message, mkCurryFun(func, value)) +; bcIssueHt info + +(DEFUN |htBcLispLinks| (|links|) + (PROG (|LETTMP#1| |options| |message| |info| |func| |value| |link|) + (declare (special |$saturn|)) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (|beforeAfter| '|options| |links|)) + (SPADLET |links| (CAR |LETTMP#1|)) + (SPADLET |options| (CADR |LETTMP#1|)) + (DO ((G178655 |links| (CDR G178655)) (G178641 NIL)) + ((OR (ATOM G178655) + (PROGN (SETQ G178641 (CAR G178655)) NIL) + (PROGN + (PROGN + (SPADLET |message| (CAR G178641)) + (SPADLET |info| (CADR G178641)) + (SPADLET |func| (CADDR G178641)) + (SPADLET |value| (CDDDR G178641)) + G178641) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |link| + (COND + (|$saturn| + (MAKESTRING "\\lispLink[n]")) + ('T (MAKESTRING "\\lisplink")))) + (|htMakeButton| |link| |message| + (|mkCurryFun| |func| |value|)) + (|bcIssueHt| |info|)))))))))) + +;htMakeButton(htCommand, message, func,:options) == +; $saturn => htMakeButtonSaturn(htCommand, message, func, options) +; skipStateInfo? := IFCAR options +; iht [htCommand, '"{"] +; bcIssueHt message +; skipStateInfo? => +; iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] +; iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] +; for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat +; iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] +; if type = 'string then +; iht ['"_"\stringvalue{", id, '"}_""] +; else +; iht ['"_"\boxvalue{", id, '"}_""] +; iht '") " +; iht [htpName $curPage, '"))}"] + +(DEFUN |htMakeButton| + (&REST G178699 &AUX |options| |func| |message| |htCommand|) + (DSETQ (|htCommand| |message| |func| . |options|) G178699) + (PROG (|skipStateInfo?| |id| |type|) + (declare (special |$curPage| |$saturn|)) + (RETURN + (SEQ (COND + (|$saturn| + (|htMakeButtonSaturn| |htCommand| |message| |func| + |options|)) + ('T (SPADLET |skipStateInfo?| (IFCAR |options|)) + (|iht| (CONS |htCommand| (CONS (MAKESTRING "{") NIL))) + (|bcIssueHt| |message|) + (COND + (|skipStateInfo?| + (|iht| (CONS (MAKESTRING "}{(|htDoneButton| '|") + (CONS |func| + (CONS (MAKESTRING "| ") + (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING ")}") NIL))))))) + ('T + (|iht| (CONS (MAKESTRING "}{(|htDoneButton| '|") + (CONS |func| + (CONS (MAKESTRING "| (PROGN ") NIL)))) + (DO ((G178686 (|htpInputAreaAlist| |$curPage|) + (CDR G178686)) + (G178674 NIL)) + ((OR (ATOM G178686) + (PROGN (SETQ G178674 (CAR G178686)) NIL) + (PROGN + (PROGN + (SPADLET |id| (CAR G178674)) + (SPADLET |type| (CAR (CDDDDR G178674))) + G178674) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|iht| (CONS + (MAKESTRING + "(|htpSetLabelInputString| ") + (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING "'|") + (CONS |id| + (CONS (MAKESTRING "| ") NIL)))))) + (COND + ((BOOT-EQUAL |type| '|string|) + (|iht| + (CONS + (MAKESTRING "\"\\stringvalue{") + (CONS |id| + (CONS (MAKESTRING "}\"") NIL))))) + ('T + (|iht| + (CONS (MAKESTRING "\"\\boxvalue{") + (CONS |id| + (CONS (MAKESTRING "}\"") NIL)))))) + (|iht| (MAKESTRING ") ")))))) + (|iht| (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING "))}") NIL))))))))))) + +;htMakeButtonSaturn(htCommand, message, func,options) == +; skipStateInfo? := IFCAR options +; iht htCommand +; skipStateInfo? => +; iht ['"{\verb!(|htDoneButton| '|", func, '"| ",htpName page(), '")!}{"] +; bcIssueHt message +; iht '"}" +; iht ['"{\verb!(|htDoneButton| '|", func, '"| "] +; if $kPageSaturnArguments then +; iht '"(PROGN " +; for id in $kPageSaturnArguments for var in $PatternVariableList repeat +; iht ['"(|htpSetLabelInputString| ", htpName page(), '"'|", var, '"| "] +; iht ["'|!\", id, '"\verb!|"] +; iht '")" +; iht htpName $saturnPage +; iht '")" +; else +; iht htpName $saturnPage +; iht '")!}{" +; bcIssueHt message +; iht '"}" + +(DEFUN |htMakeButtonSaturn| (|htCommand| |message| |func| |options|) + (PROG (|skipStateInfo?|) + (declare (special |$kPageSaturnArguments| |$PatternVariableList| + |$saturnPage|)) + (RETURN + (SEQ (PROGN + (SPADLET |skipStateInfo?| (IFCAR |options|)) + (|iht| |htCommand|) + (COND + (|skipStateInfo?| + (|iht| (CONS (MAKESTRING + "{\\verb!(|htDoneButton| '|") + (CONS |func| + (CONS (MAKESTRING "| ") + (CONS (|htpName| (|page|)) + (CONS (MAKESTRING ")!}{") NIL)))))) + (|bcIssueHt| |message|) (|iht| (MAKESTRING "}"))) + ('T + (|iht| (CONS (MAKESTRING "{\\verb!(|htDoneButton| '|") + (CONS |func| (CONS (MAKESTRING "| ") NIL)))) + (COND + (|$kPageSaturnArguments| + (|iht| (MAKESTRING "(PROGN ")) + (DO ((G178711 |$kPageSaturnArguments| + (CDR G178711)) + (|id| NIL) + (G178712 |$PatternVariableList| + (CDR G178712)) + (|var| NIL)) + ((OR (ATOM G178711) + (PROGN (SETQ |id| (CAR G178711)) NIL) + (ATOM G178712) + (PROGN + (SETQ |var| (CAR G178712)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|iht| + (CONS + (MAKESTRING + "(|htpSetLabelInputString| ") + (CONS (|htpName| (|page|)) + (CONS (MAKESTRING "'|") + (CONS |var| + (CONS (MAKESTRING "| ") NIL)))))) + (|iht| + (CONS '|'\|!\\| + (CONS |id| + (CONS (MAKESTRING "\\verb!|") + NIL)))) + (|iht| (MAKESTRING ")")))))) + (|iht| (|htpName| |$saturnPage|)) + (|iht| (MAKESTRING ")"))) + ('T (|iht| (|htpName| |$saturnPage|)))) + (|iht| (MAKESTRING ")!}{")) (|bcIssueHt| |message|) + (|iht| (MAKESTRING "}"))))))))) + +;htpAddToPageDescription(htPage, pageDescrip) == +; newDescript := +; STRINGP pageDescrip => [pageDescrip, :ELT(htPage, 7)] +; nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7)) +; SETELT(htPage, 7, newDescript) + +(DEFUN |htpAddToPageDescription| (|htPage| |pageDescrip|) + (PROG (|newDescript|) + (RETURN + (PROGN + (SPADLET |newDescript| + (COND + ((STRINGP |pageDescrip|) + (CONS |pageDescrip| (ELT |htPage| 7))) + ('T + (NCONC (NREVERSE (COPY-LIST |pageDescrip|)) + (ELT |htPage| 7))))) + (SETELT |htPage| 7 |newDescript|))))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htProcessBcStrings strings == +; for [numChars, default, stringName, spadType, :filter] in strings repeat +; mess2 := '"" +; if NULL LASSOC(stringName, htpInputAreaAlist page()) then +; setUpDefault(stringName, ['string, default, spadType, filter]) +; if htpLabelErrorMsg(page(), stringName) then +; iht ['"\centerline{{\em ", htpLabelErrorMsg(page(), stringName), '"}}"] +; mess2 := CONCAT(mess2, bcSadFaces()) +; htpSetLabelErrorMsg(page(), stringName, nil) +; iht ['"\inputstring{", stringName, '"}{", +; numChars, '"}{", htpLabelDefault(page(),stringName), '"} ", mess2] + +(DEFUN |htProcessBcStrings| (|strings|) + (PROG (|numChars| |default| |stringName| |spadType| |filter| |mess2|) + (RETURN + (SEQ (DO ((G178748 |strings| (CDR G178748)) (G178733 NIL)) + ((OR (ATOM G178748) + (PROGN (SETQ G178733 (CAR G178748)) NIL) + (PROGN + (PROGN + (SPADLET |numChars| (CAR G178733)) + (SPADLET |default| (CADR G178733)) + (SPADLET |stringName| (CADDR G178733)) + (SPADLET |spadType| (CADDDR G178733)) + (SPADLET |filter| (CDDDDR G178733)) + G178733) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |mess2| (MAKESTRING "")) + (COND + ((NULL (LASSOC |stringName| + (|htpInputAreaAlist| (|page|)))) + (|setUpDefault| |stringName| + (CONS '|string| + (CONS |default| + (CONS |spadType| + (CONS |filter| NIL))))))) + (COND + ((|htpLabelErrorMsg| (|page|) |stringName|) + (|iht| (CONS + (MAKESTRING "\\centerline{{\\em ") + (CONS + (|htpLabelErrorMsg| (|page|) + |stringName|) + (CONS (MAKESTRING "}}") NIL)))) + (SPADLET |mess2| + (CONCAT |mess2| (|bcSadFaces|))) + (|htpSetLabelErrorMsg| (|page|) + |stringName| NIL))) + (|iht| (CONS (MAKESTRING "\\inputstring{") + (CONS |stringName| + (CONS (MAKESTRING "}{") + (CONS |numChars| + (CONS (MAKESTRING "}{") + (CONS + (|htpLabelDefault| (|page|) + |stringName|) + (CONS (MAKESTRING "} ") + (CONS |mess2| NIL))))))))))))))))) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;setUpDefault(name, props) == +; htpAddInputAreaProp(page(), name, props) + +(DEFUN |setUpDefault| (|name| |props|) + (|htpAddInputAreaProp| (|page|) |name| |props|)) + +;--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +;htInitPage(title, propList) == +;-- start defining a hyperTeX page +; htInitPageNoScroll(propList, title) +; htSayStandard '"\beginscroll " +; page() + +(DEFUN |htInitPage| (|title| |propList|) + (PROGN + (|htInitPageNoScroll| |propList| |title|) + (|htSayStandard| (MAKESTRING "\\beginscroll ")) + (|page|))) + +;--------------------> NEW DEFINITION <-------------------------- +;htInitPageNoScroll(propList, :options) == +;--start defining a hyperTeX page +; $atLeastOneUnexposed := nil --reset every time a new page is initialized +; $saturnContextMenuLines := nil +; title := IFCAR options +; $curPage := +; $standard => htpMakeEmptyPage(propList) +; nil +; if $saturn then $saturnPage := htpMakeEmptyPage(propList) +; $newPage := true +; $htLineList := nil +; if title then +; if $standard then htSayStandard ['"\begin{page}{", htpName $curPage, '"}{"] +; htSaySaturn '"\browseTitle{" +; htSay title +; htSaySaturn '"}" +; htSayStandard '"} " +; page() + +(DEFUN |htInitPageNoScroll| (&REST G178785 &AUX |options| |propList|) + (DSETQ (|propList| . |options|) G178785) + (PROG (|title|) + (declare (special |$atLeastOneUnexposed| |$saturnContextMenuLines| + |$curPage| |$standard| |$saturn| |$saturnPage| + |$newPage| |$htLineList|)) + (RETURN + (PROGN + (SPADLET |$atLeastOneUnexposed| NIL) + (SPADLET |$saturnContextMenuLines| NIL) + (SPADLET |title| (IFCAR |options|)) + (SPADLET |$curPage| + (COND + (|$standard| (|htpMakeEmptyPage| |propList|)) + ('T NIL))) + (COND + (|$saturn| + (SPADLET |$saturnPage| (|htpMakeEmptyPage| |propList|)))) + (SPADLET |$newPage| 'T) + (SPADLET |$htLineList| NIL) + (COND + (|title| (COND + (|$standard| + (|htSayStandard| + (CONS (MAKESTRING "\\begin{page}{") + (CONS (|htpName| |$curPage|) + (CONS (MAKESTRING "}{") NIL)))))) + (|htSaySaturn| (MAKESTRING "\\browseTitle{")) + (|htSay| |title|) (|htSaySaturn| (MAKESTRING "}")) + (|htSayStandard| (MAKESTRING "} ")))) + (|page|))))) + +;--------------------> NEW DEFINITION <-------------------------- +;htInitPageNoHeading(propList) == +;--start defining a hyperTeX page +; $curPage := +; $standard => htpMakeEmptyPage(propList) +; if $saturn then $saturnPage := htpMakeEmptyPage(propList) +; $newPage := true +; $htLineList := nil +; page() + +(DEFUN |htInitPageNoHeading| (|propList|) + (declare (special |$curPage| |$standard| |$saturn| |$saturnPage| |$newPage| + |$htLineList|)) + (COND + ((SPADLET |$curPage| |$standard|) (|htpMakeEmptyPage| |propList|)) + ('T + (COND + (|$saturn| + (SPADLET |$saturnPage| (|htpMakeEmptyPage| |propList|)))) + (SPADLET |$newPage| 'T) (SPADLET |$htLineList| NIL) (|page|)))) + +;--------------------> NEW DEFINITION <-------------------------- +;htpMakeEmptyPage(propList,:options) == +; name := IFCAR options or GENTEMP() +; if not $saturn then +; $activePageList := [name, :$activePageList] +; SET(name, val := VECTOR(name, nil, nil, nil, nil, nil, propList, nil)) +; val + +(DEFUN |htpMakeEmptyPage| (&REST G178801 &AUX |options| |propList|) + (DSETQ (|propList| . |options|) G178801) + (PROG (|name| |val|) + (declare (special |$activePageList| |$saturn|)) + (RETURN + (PROGN + (SPADLET |name| (OR (IFCAR |options|) (GENTEMP))) + (COND + ((NULL |$saturn|) + (SPADLET |$activePageList| (CONS |name| |$activePageList|)))) + (SET |name| + (SPADLET |val| + (VECTOR |name| NIL NIL NIL NIL NIL |propList| + NIL))) + |val|)))) + +;--======================================================================= +;-- Redefinitions from br-con.boot +;--======================================================================= +;kPage(line,:options) == --any cat, dom, package, default package +;--constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) +; parts := dbXParts(line,7,1) +; [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts +; form := IFCAR options +; isFile := null kind +; kind := kind or '"package" +; RPLACA(parts,kind) +; conform := mkConform(kind,name,args) +; $kPageSaturnArguments: local := rest conform +; conname := opOf conform +; capitalKind := capitalize kind +; signature := ncParseFromString sig +; sourceFileName := dbSourceFile INTERN name +; constrings := +; KDR form => dbConformGenUnder form +; [STRCONC(name,args)] +; emString := ['"{\sf ",:constrings,'"}"] +; heading := [capitalKind,'" ",:emString] +; if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] +; if name=abbrev then abbrev := asyAbbreviation(conname,nargs) +; page := htInitPageNoScroll nil +; htAddHeading heading +; htSayStandard("\beginscroll ") +; htpSetProperty(page,'argSublis,mkConArgSublis rest conform) +; htpSetProperty(page,'isFile,true) +; htpSetProperty(page,'parts,parts) +; htpSetProperty(page,'heading,heading) +; htpSetProperty(page,'kind,kind) +; if asharpConstructorName? conname then +; htpSetProperty(page,'isAsharpConstructor,true) +; htpSetProperty(page,'conform,conform) +; htpSetProperty(page,'signature,signature) +; ---what follows is stuff from kiPage with domain = nil +; $conformsAreDomains := nil +; dbShowConsDoc1(page,conform,nil) +; if kind ^= 'category and nargs > 0 then addParameterTemplates(page,conform) +; if $atLeastOneUnexposed then htSay '"\newline{}{\em *} = unexposed" +; htSayStandard("\endscroll ") +; kPageContextMenu page +; htShowPageNoScroll() + +(DEFUN |kPage| (&REST G178843 &AUX |options| |line|) + (DSETQ (|line| . |options|) G178843) + (PROG (|$kPageSaturnArguments| |parts| |name| |nargs| |xflag| |sig| + |args| |comments| |form| |isFile| |kind| |conform| + |conname| |capitalKind| |signature| |sourceFileName| + |constrings| |emString| |heading| |abbrev| |page|) + (DECLARE (SPECIAL |$kPageSaturnArguments| |$conformsAreDomains| + |$conformsAreDomains| |$atLeastOneUnexposed|)) + (RETURN + (PROGN + (SPADLET |parts| (|dbXParts| |line| 7 1)) + (SPADLET |kind| (CAR |parts|)) + (SPADLET |name| (CADR |parts|)) + (SPADLET |nargs| (CADDR |parts|)) + (SPADLET |xflag| (CADDDR |parts|)) + (SPADLET |sig| (CAR (CDDDDR |parts|))) + (SPADLET |args| (CADR (CDDDDR |parts|))) + (SPADLET |abbrev| (CADDR (CDDDDR |parts|))) + (SPADLET |comments| (CADDDR (CDDDDR |parts|))) + (SPADLET |form| (IFCAR |options|)) + (SPADLET |isFile| (NULL |kind|)) + (SPADLET |kind| (OR |kind| (MAKESTRING "package"))) + (RPLACA |parts| |kind|) + (SPADLET |conform| (|mkConform| |kind| |name| |args|)) + (SPADLET |$kPageSaturnArguments| (CDR |conform|)) + (SPADLET |conname| (|opOf| |conform|)) + (SPADLET |capitalKind| (|capitalize| |kind|)) + (SPADLET |signature| (|ncParseFromString| |sig|)) + (SPADLET |sourceFileName| (|dbSourceFile| (INTERN |name|))) + (SPADLET |constrings| + (COND + ((KDR |form|) (|dbConformGenUnder| |form|)) + ('T (CONS (STRCONC |name| |args|) NIL)))) + (SPADLET |emString| + (CONS (MAKESTRING "{\\sf ") + (APPEND |constrings| + (CONS (MAKESTRING "}") NIL)))) + (SPADLET |heading| + (CONS |capitalKind| + (CONS (MAKESTRING " ") |emString|))) + (COND + ((NULL (|isExposedConstructor| |conname|)) + (SPADLET |heading| + (CONS (MAKESTRING "Unexposed ") |heading|)))) + (COND + ((BOOT-EQUAL |name| |abbrev|) + (SPADLET |abbrev| (|asyAbbreviation| |conname| |nargs|)))) + (SPADLET |page| (|htInitPageNoScroll| NIL)) + (|htAddHeading| |heading|) + (|htSayStandard| '|\\beginscroll |) + (|htpSetProperty| |page| '|argSublis| + (|mkConArgSublis| (CDR |conform|))) + (|htpSetProperty| |page| '|isFile| 'T) + (|htpSetProperty| |page| '|parts| |parts|) + (|htpSetProperty| |page| '|heading| |heading|) + (|htpSetProperty| |page| '|kind| |kind|) + (COND + ((|asharpConstructorName?| |conname|) + (|htpSetProperty| |page| '|isAsharpConstructor| 'T))) + (|htpSetProperty| |page| '|conform| |conform|) + (|htpSetProperty| |page| '|signature| |signature|) + (SPADLET |$conformsAreDomains| NIL) + (|dbShowConsDoc1| |page| |conform| NIL) + (COND + ((AND (NEQUAL |kind| '|category|) (> |nargs| 0)) + (|addParameterTemplates| |page| |conform|))) + (COND + (|$atLeastOneUnexposed| + (|htSay| (MAKESTRING "\\newline{}{\\em *} = unexposed")))) + (|htSayStandard| '|\\endscroll |) + (|kPageContextMenu| |page|) + (|htShowPageNoScroll|))))) + +;kPageContextMenu page == +; $saturn => kPageContextMenuSaturn page +; [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) +; conform := htpProperty(page,'conform) +; conname := opOf conform +; htBeginTable() +; htSay '"{" +; htMakePage [['bcLinks,['Ancestors,'"",'kcaPage,nil]]] +; htSay '"}{" +; htMakePage [['bcLinks,['Attributes,'"",'koPage,'"attribute"]]] +; if kind = '"category" then +; htSay '"}{" +; htMakePage [['bcLinks,['Children,'"",'kccPage,nil]]] +; if not asharpConstructorName? conname then +; htSay '"}{" +; htMakePage [['bcLinks,['Dependents,'"",'kcdePage,nil]]] +; if kind = '"category" then +; htSay '"}{" +; htMakePage [['bcLinks,['Descendents,'"",'kcdPage,nil]]] +; if kind = '"category" then +; htSay '"}{" +; if not asharpConstructorName? conname then +; htMakePage [['bcLinks,['Domains,'"",'kcdoPage,nil]]] +; else htSay '"{\em Domains}" +; htSay '"}{" +; if kind ^= '"category" and (pathname := dbHasExamplePage conname) +; then htMakePage [['bcLinks,['Examples,'"",'kxPage,pathname]]] +; else htSay '"{\em Examples}" +; htSay '"}{" +; htMakePage [['bcLinks,['Exports,'"",'kePage,nil]]] +; htSay '"}{" +; htMakePage [['bcLinks,['Operations,'"",'koPage,'"operation"]]] +; htSay '"}{" +; htMakePage [['bcLinks,['Parents,'"",'kcpPage,'"operation"]]] +; if kind ^= '"category" then +; htSay '"}{" +; if not asharpConstructorName? conname +; then htMakePage [['bcLinks,["Search Path",'"",'ksPage,nil]]] +; else htSay '"{\em Search Path}" +; if kind ^= '"category" then +; htSay '"}{" +; htMakePage [['bcLinks,['Users,'"",'kcuPage,nil]]] +; htSay '"}{" +; htMakePage [['bcLinks,['Uses,'"",'kcnPage,nil]]] +; htSay '"}" +; if $standard then htEndTable() + +(DEFUN |kPageContextMenu| (|page|) + (PROG (|LETTMP#1| |kind| |name| |nargs| |xpart| |sig| |args| |abbrev| + |comments| |conform| |conname| |pathname|) + (declare (special |$saturn| |$standard|)) + (RETURN + (COND + (|$saturn| (|kPageContextMenuSaturn| |page|)) + ('T (SPADLET |LETTMP#1| (|htpProperty| |page| '|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 |conform| (|htpProperty| |page| '|conform|)) + (SPADLET |conname| (|opOf| |conform|)) (|htBeginTable|) + (|htSay| (MAKESTRING "{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Ancestors| + (CONS (MAKESTRING "") + (CONS '|kcaPage| (CONS NIL NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Attributes| + (CONS (MAKESTRING "") + (CONS '|koPage| + (CONS (MAKESTRING "attribute") + NIL)))) + NIL)) + NIL)) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Children| + (CONS (MAKESTRING "") + (CONS '|kccPage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((NULL (|asharpConstructorName?| |conname|)) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Dependents| + (CONS (MAKESTRING "") + (CONS '|kcdePage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Descendents| + (CONS (MAKESTRING "") + (CONS '|kcdPage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (|htSay| (MAKESTRING "}{")) + (COND + ((NULL (|asharpConstructorName?| |conname|)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Domains| + (CONS (MAKESTRING "") + (CONS '|kcdoPage| + (CONS NIL NIL)))) + NIL)) + NIL))) + ('T (|htSay| (MAKESTRING "{\\em Domains}")))))) + (|htSay| (MAKESTRING "}{")) + (COND + ((AND (NEQUAL |kind| (MAKESTRING "category")) + (SPADLET |pathname| (|dbHasExamplePage| |conname|))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Examples| + (CONS (MAKESTRING "") + (CONS '|kxPage| + (CONS |pathname| NIL)))) + NIL)) + NIL))) + ('T (|htSay| (MAKESTRING "{\\em Examples}")))) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Exports| + (CONS (MAKESTRING "") + (CONS '|kePage| (CONS NIL NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Operations| + (CONS (MAKESTRING "") + (CONS '|koPage| + (CONS (MAKESTRING "operation") + NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Parents| + (CONS (MAKESTRING "") + (CONS '|kcpPage| + (CONS (MAKESTRING "operation") + NIL)))) + NIL)) + NIL)) + (COND + ((NEQUAL |kind| (MAKESTRING "category")) + (|htSay| (MAKESTRING "}{")) + (COND + ((NULL (|asharpConstructorName?| |conname|)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Search Path| + (CONS (MAKESTRING "") + (CONS '|ksPage| (CONS NIL NIL)))) + NIL)) + NIL))) + ('T (|htSay| (MAKESTRING "{\\em Search Path}")))))) + (COND + ((NEQUAL |kind| (MAKESTRING "category")) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Users| + (CONS (MAKESTRING "") + (CONS '|kcuPage| + (CONS NIL NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}{")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS '|Uses| + (CONS (MAKESTRING "") + (CONS '|kcnPage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}")) + (COND (|$standard| (|htEndTable|)) ('T NIL))))))) + +;kPageContextMenuSaturn page == +; $newPage : local := nil +; [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) +; $htLineList : local := nil +; conform := htpProperty(page,'conform) +; conname := opOf conform +; htMakePage [['bcLinks,['"\&Ancestors",'"",'kcaPage,nil]]] +; htMakePage [['bcLinks,['"Attri\&butes",'"",'koPage,'"attribute"]]] +; if kind = '"category" then +; htMakePage [['bcLinks,['"\&Children",'"",'kccPage,nil]]] +; if not asharpConstructorName? conname then +; htMakePage [['bcLinks,['"\&Dependents",'"",'kcdePage,nil]]] +; if kind = '"category" then +; htMakePage [['bcLinks,['"Desce\&ndents",'"",'kcdPage,nil]]] +; if kind = '"category" then +; if not asharpConstructorName? conname then +; htMakePage [['bcLinks,['"Do\&mains",'"",'kcdoPage,nil]]] +; else htSayCold '"Do\&mains" +; if kind ^= '"category" and (name := saturnHasExamplePage conname) +; then saturnExampleLink name +; else htSayCold '"E\&xamples" +; htMakePage [['bcLinks,['"\&Exports",'"",'kePage,nil]]] +; htMakePage [['bcLinks,['"\&Operations",'"",'koPage,'"operation"]]] +; htMakePage [['bcLinks,['"\&Parents",'"",'kcpPage,'"operation"]]] +; if not asharpConstructorName? conname +; then htMakePage [['bcLinks,['"Search O\&rder",'"",'ksPage,nil]]] +; else htSayCold '"Search Order" +; if kind ^= '"category" or dbpHasDefaultCategory? xpart +; then +; htMakePage [['bcLinks,['"\&Users",'"",'kcuPage,nil]]] +; htMakePage [['bcLinks,['"U\&ses",'"",'kcnPage,nil]]] +; else +; htSayCold '"\&Users" +; htSayCold '"U\&ses" +; $saturnContextMenuLines := $htLineList + +(DEFUN |kPageContextMenuSaturn| (|page|) + (PROG (|$newPage| |$htLineList| |LETTMP#1| |kind| |nargs| |xpart| + |sig| |args| |abbrev| |comments| |conform| |conname| + |name|) + (DECLARE (SPECIAL |$newPage| |$htLineList| |$saturnContextMenuLines| + |$htLineList|)) + (RETURN + (PROGN + (SPADLET |$newPage| NIL) + (SPADLET |LETTMP#1| (|htpProperty| |page| '|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 |$htLineList| NIL) + (SPADLET |conform| (|htpProperty| |page| '|conform|)) + (SPADLET |conname| (|opOf| |conform|)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "\\&Ancestors") + (CONS (MAKESTRING "") + (CONS '|kcaPage| (CONS NIL NIL)))) + NIL)) + NIL)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Attri\\&butes") + (CONS (MAKESTRING "") + (CONS '|koPage| + (CONS (MAKESTRING "attribute") + NIL)))) + NIL)) + NIL)) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "\\&Children") + (CONS (MAKESTRING "") + (CONS '|kccPage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((NULL (|asharpConstructorName?| |conname|)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "\\&Dependents") + (CONS (MAKESTRING "") + (CONS '|kcdePage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Desce\\&ndents") + (CONS (MAKESTRING "") + (CONS '|kcdPage| + (CONS NIL NIL)))) + NIL)) + NIL)))) + (COND + ((BOOT-EQUAL |kind| (MAKESTRING "category")) + (COND + ((NULL (|asharpConstructorName?| |conname|)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Do\\&mains") + (CONS (MAKESTRING "") + (CONS '|kcdoPage| (CONS NIL NIL)))) + NIL)) + NIL))) + ('T (|htSayCold| (MAKESTRING "Do\\&mains")))))) + (COND + ((AND (NEQUAL |kind| (MAKESTRING "category")) + (SPADLET |name| (|saturnHasExamplePage| |conname|))) + (|saturnExampleLink| |name|)) + ('T (|htSayCold| (MAKESTRING "E\\&xamples")))) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "\\&Exports") + (CONS (MAKESTRING "") + (CONS '|kePage| (CONS NIL NIL)))) + NIL)) + NIL)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "\\&Operations") + (CONS (MAKESTRING "") + (CONS '|koPage| + (CONS (MAKESTRING "operation") + NIL)))) + NIL)) + NIL)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "\\&Parents") + (CONS (MAKESTRING "") + (CONS '|kcpPage| + (CONS (MAKESTRING "operation") + NIL)))) + NIL)) + NIL)) + (COND + ((NULL (|asharpConstructorName?| |conname|)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Search O\\&rder") + (CONS (MAKESTRING "") + (CONS '|ksPage| (CONS NIL NIL)))) + NIL)) + NIL))) + ('T (|htSayCold| (MAKESTRING "Search Order")))) + (COND + ((OR (NEQUAL |kind| (MAKESTRING "category")) + (|dbpHasDefaultCategory?| |xpart|)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "\\&Users") + (CONS (MAKESTRING "") + (CONS '|kcuPage| + (CONS NIL NIL)))) + NIL)) + NIL)) + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "U\\&ses") + (CONS (MAKESTRING "") + (CONS '|kcnPage| + (CONS NIL NIL)))) + NIL)) + NIL))) + ('T (|htSayCold| (MAKESTRING "\\&Users")) + (|htSayCold| (MAKESTRING "U\\&ses")))) + (SPADLET |$saturnContextMenuLines| |$htLineList|))))) + +;saturnExampleLink lname == +; htSay '"\docLink{\csname " +; htSay STRCONC(CAR(CDR(lname)), '"\endcsname}{E&xamples}") + +(DEFUN |saturnExampleLink| (|lname|) + (PROGN + (|htSay| (MAKESTRING "\\docLink{\\csname ")) + (|htSay| (STRCONC (CAR (CDR |lname|)) + (MAKESTRING "\\endcsname}{E&xamples}"))))) + +;$exampleConstructors := nil + +(SPADLET |$exampleConstructors| NIL) + +;saturnHasExamplePage conname == +; if not $exampleConstructors then +; $exampleConstructors := getSaturnExampleList() +; ASSQ(conname, $exampleConstructors) + +(DEFUN |saturnHasExamplePage| (|conname|) + (declare (special |$exampleConstructors|)) + (PROGN + (COND + ((NULL |$exampleConstructors|) + (SPADLET |$exampleConstructors| (|getSaturnExampleList|)))) + (ASSQ |conname| |$exampleConstructors|))) + +;getSaturnExampleList() == +; file := STRCONC( getEnv('"AXIOM"), "/doc/axug/examples.lsp") +; not PROBE_-FILE file => nil +; fp := MAKE_-INSTREAM file +; lst := READ fp +; SHUT fp +; lst + +(DEFUN |getSaturnExampleList| () + (PROG (|file| |fp| |lst|) + (RETURN + (PROGN + (SPADLET |file| + (STRCONC (|getEnv| (MAKESTRING "AXIOM")) + '|/doc/axug/examples.lsp|)) + (COND + ((NULL (PROBE-FILE |file|)) NIL) + ('T (SPADLET |fp| (MAKE-INSTREAM |file|)) + (SPADLET |lst| (VMREAD |fp|)) (SHUT |fp|) |lst|)))))) + +;--------------------> NEW DEFINITION (see br-con.boot.pamphlet) +;dbPresentCons(htPage,kind,:exclusions) == +; $saturn => dbPresentConsSaturn(htPage,kind,exclusions) +; htpSetProperty(htPage,'exclusion,first exclusions) +; cAlist := htpProperty(htPage,'cAlist) +; empty? := null cAlist +; one? := null CDR cAlist +; one? := empty? or one? +; exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 +; star? := true --always include information on exposed/unexposed 4/92 +; if $standard then htBeginTable() +; htSay '"{" +; if one? or MEMBER('abbrs,exclusions) +; then htSay '"{\em Abbreviations}" +; else htMakePage [['bcLispLinks,['"Abbreviations",'"",'dbShowCons,'abbrs]]] +; htSay '"}{" +; if one? or MEMBER('conditions,exclusions) or and/[CDR x = true for x in cAlist] +; then htSay '"{\em Conditions}" +; else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowCons,'conditions]]] +; htSay '"}{" +; if empty? or MEMBER('documentation,exclusions) +; then htSay '"{\em Descriptions}" +; else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowCons,'documentation]]] +; htSay '"}{" +; if one? or null CDR cAlist +; then htSay '"{\em Filter}" +; else htMakePage +; [['bcLinks,['"Filter",'"",'htFilterPage,['dbShowCons,'filter]]]] +; htSay '"}{" +; if one? or MEMBER('kinds,exclusions) or kind ^= 'constructor +; then htSay '"{\em Kinds}" +; else htMakePage [['bcLispLinks,['"Kinds",'"",'dbShowCons,'kinds]]] +; htSay '"}{" +; if one? or MEMBER('names,exclusions) +; then htSay '"{\em Names}" +; else htMakePage [['bcLispLinks,['"Names",'"",'dbShowCons,'names]]] +; htSay '"}{" +; if one? or MEMBER('parameters,exclusions) or not or/[CDAR x for x in cAlist] +; then htSay '"{\em Parameters}" +; else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowCons,'parameters]]] +; htSay '"}{" +; if $exposedOnlyIfTrue +; then +; if one? +; then htSay '"{\em Unexposed Also}" +; else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowCons,'exposureOff]]] +; else +; if one? +; then htSay '"{\em Exposed Only}" +; else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowCons,'exposureOn]]] +; htSay '"}" +; if $standard then htEndTable() + +(DEFUN |dbPresentCons| + (&REST G178985 &AUX |exclusions| |kind| |htPage|) + (DSETQ (|htPage| |kind| . |exclusions|) G178985) + (PROG (|cAlist| |empty?| |one?| |exposedUnexposedFlag| |star?|) + (declare (special |$saturn| |$standard| |$exposedOnlyIfTrue| + |$includeUnexposed?|)) + (RETURN + (SEQ (COND + (|$saturn| + (|dbPresentConsSaturn| |htPage| |kind| |exclusions|)) + ('T + (|htpSetProperty| |htPage| '|exclusion| + (CAR |exclusions|)) + (SPADLET |cAlist| (|htpProperty| |htPage| '|cAlist|)) + (SPADLET |empty?| (NULL |cAlist|)) + (SPADLET |one?| (NULL (CDR |cAlist|))) + (SPADLET |one?| (OR |empty?| |one?|)) + (SPADLET |exposedUnexposedFlag| |$includeUnexposed?|) + (SPADLET |star?| 'T) + (COND (|$standard| (|htBeginTable|))) + (|htSay| (MAKESTRING "{")) + (COND + ((OR |one?| (|member| '|abbrs| |exclusions|)) + (|htSay| (MAKESTRING "{\\em Abbreviations}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS + (MAKESTRING "Abbreviations") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|abbrs| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (|member| '|conditions| |exclusions|) + (PROG (G178946) + (SPADLET G178946 'T) + (RETURN + (DO ((G178952 NIL (NULL G178946)) + (G178953 |cAlist| (CDR G178953)) + (|x| NIL)) + ((OR G178952 (ATOM G178953) + (PROGN + (SETQ |x| (CAR G178953)) + NIL)) + G178946) + (SEQ (EXIT (SETQ G178946 + (AND G178946 + (BOOT-EQUAL (CDR |x|) 'T))))))))) + (|htSay| (MAKESTRING "{\\em Conditions}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Conditions") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|conditions| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |empty?| (|member| '|documentation| |exclusions|)) + (|htSay| (MAKESTRING "{\\em Descriptions}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS + (MAKESTRING "Descriptions") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|documentation| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (NULL (CDR |cAlist|))) + (|htSay| (MAKESTRING "{\\em Filter}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Filter") + (CONS (MAKESTRING "") + (CONS '|htFilterPage| + (CONS + (CONS '|dbShowCons| + (CONS '|filter| NIL)) + NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (|member| '|kinds| |exclusions|) + (NEQUAL |kind| '|constructor|)) + (|htSay| (MAKESTRING "{\\em Kinds}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Kinds") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|kinds| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (|member| '|names| |exclusions|)) + (|htSay| (MAKESTRING "{\\em Names}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Names") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|names| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (|member| '|parameters| |exclusions|) + (NULL (PROG (G178960) + (SPADLET G178960 NIL) + (RETURN + (DO ((G178966 NIL G178960) + (G178967 |cAlist| + (CDR G178967)) + (|x| NIL)) + ((OR G178966 (ATOM G178967) + (PROGN + (SETQ |x| (CAR G178967)) + NIL)) + G178960) + (SEQ (EXIT + (SETQ G178960 + (OR G178960 (CDAR |x|)))))))))) + (|htSay| (MAKESTRING "{\\em Parameters}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Parameters") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|parameters| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + (|$exposedOnlyIfTrue| + (COND + (|one?| (|htSay| (MAKESTRING + "{\\em Unexposed Also}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (MAKESTRING "Unexposed Also") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|exposureOff| NIL)))) + NIL)) + NIL))))) + (|one?| (|htSay| (MAKESTRING "{\\em Exposed Only}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING "Exposed Only") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|exposureOn| NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}")) + (COND (|$standard| (|htEndTable|)) ('T NIL)))))))) + +;dbPresentConsSaturn(htPage,kind,exclusions) == +; $htLineList : local := nil +; $newPage : local := nil +; htpSetProperty(htPage,'exclusion,first exclusions) +; cAlist := htpProperty(htPage,'cAlist) +; empty? := null cAlist +; one? := null KDR cAlist +; one? := empty? or one? +; exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 +; star? := true --always include information on exposed/unexposed 4/92 +; if $standard then htBeginTable() +; if one? or MEMBER('abbrs,exclusions) +; then htSayCold '"\&Abbreviations" +; else htMakePage [['bcLispLinks,['"\&Abbreviations",'"",'dbShowCons,'abbrs]]] +; if one? or MEMBER('conditions,exclusions) or and/[CDR x = true for x in cAlist] +; then htSayCold '"\&Conditions" +; else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowCons,'conditions]]] +; if empty? or MEMBER('documentation,exclusions) +; then htSayCold '"\&Descriptions" +; else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowCons,'documentation]]] +; if one? or null CDR cAlist +; then htSayCold '"\&Filter" +; else htMakeSaturnFilterPage ['dbShowCons, 'filter] +; if one? or MEMBER('kinds,exclusions) or kind ^= 'constructor +; then htSayCold '"\&Kinds" +; else htMakePage [['bcLispLinks,['"\&Kinds",'"",'dbShowCons,'kinds]]] +; if one? or MEMBER('names,exclusions) +; then htSayCold '"\&Names" +; else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowCons,'names]]] +; if one? or MEMBER('parameters,exclusions) or not or/[CDAR x for x in cAlist] +; then htSayCold '"\&Parameters" +; else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowCons,'parameters]]] +; htSaySaturn '"\hrule" +; if $exposedOnlyIfTrue +; then +; if one? then htSayCold '"\&Unexposed Also" +; else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowCons,'exposureOff]]] +; else +; if one? then htSayCold '"\Exposed Only\&y" +; else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowCons,'exposureOn]]] +; if $standard then htEndTable() +; $saturnContextMenuLines := $htLineList + +(DEFUN |dbPresentConsSaturn| (|htPage| |kind| |exclusions|) + (PROG (|$htLineList| |$newPage| |cAlist| |empty?| |one?| + |exposedUnexposedFlag| |star?|) + (DECLARE (SPECIAL |$htLineList| |$newPage| |$saturnContextMenuLines| + |$htLineList| |$standard| |$exposedOnlyIfTrue| + |$includeUnexposed?|)) + (RETURN + (SEQ (PROGN + (SPADLET |$htLineList| NIL) + (SPADLET |$newPage| NIL) + (|htpSetProperty| |htPage| '|exclusion| + (CAR |exclusions|)) + (SPADLET |cAlist| (|htpProperty| |htPage| '|cAlist|)) + (SPADLET |empty?| (NULL |cAlist|)) + (SPADLET |one?| (NULL (KDR |cAlist|))) + (SPADLET |one?| (OR |empty?| |one?|)) + (SPADLET |exposedUnexposedFlag| |$includeUnexposed?|) + (SPADLET |star?| 'T) + (COND (|$standard| (|htBeginTable|))) + (COND + ((OR |one?| (|member| '|abbrs| |exclusions|)) + (|htSayCold| (MAKESTRING "\\&Abbreviations"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS + (MAKESTRING "\\&Abbreviations") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|abbrs| NIL)))) + NIL)) + NIL)))) + (COND + ((OR |one?| (|member| '|conditions| |exclusions|) + (PROG (G178987) + (SPADLET G178987 'T) + (RETURN + (DO ((G178993 NIL (NULL G178987)) + (G178994 |cAlist| (CDR G178994)) + (|x| NIL)) + ((OR G178993 (ATOM G178994) + (PROGN + (SETQ |x| (CAR G178994)) + NIL)) + G178987) + (SEQ (EXIT (SETQ G178987 + (AND G178987 + (BOOT-EQUAL (CDR |x|) 'T))))))))) + (|htSayCold| (MAKESTRING "\\&Conditions"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS + (MAKESTRING "\\&Conditions") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|conditions| NIL)))) + NIL)) + NIL)))) + (COND + ((OR |empty?| (|member| '|documentation| |exclusions|)) + (|htSayCold| (MAKESTRING "\\&Descriptions"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS + (MAKESTRING "\\&Descriptions") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|documentation| NIL)))) + NIL)) + NIL)))) + (COND + ((OR |one?| (NULL (CDR |cAlist|))) + (|htSayCold| (MAKESTRING "\\&Filter"))) + ('T + (|htMakeSaturnFilterPage| + (CONS '|dbShowCons| (CONS '|filter| NIL))))) + (COND + ((OR |one?| (|member| '|kinds| |exclusions|) + (NEQUAL |kind| '|constructor|)) + (|htSayCold| (MAKESTRING "\\&Kinds"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Kinds") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|kinds| NIL)))) + NIL)) + NIL)))) + (COND + ((OR |one?| (|member| '|names| |exclusions|)) + (|htSayCold| (MAKESTRING "\\&Names"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Names") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|names| NIL)))) + NIL)) + NIL)))) + (COND + ((OR |one?| (|member| '|parameters| |exclusions|) + (NULL (PROG (G179001) + (SPADLET G179001 NIL) + (RETURN + (DO ((G179007 NIL G179001) + (G179008 |cAlist| (CDR G179008)) + (|x| NIL)) + ((OR G179007 (ATOM G179008) + (PROGN + (SETQ |x| (CAR G179008)) + NIL)) + G179001) + (SEQ (EXIT + (SETQ G179001 + (OR G179001 (CDAR |x|)))))))))) + (|htSayCold| (MAKESTRING "\\&Parameters"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS + (MAKESTRING "\\&Parameters") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|parameters| NIL)))) + NIL)) + NIL)))) + (|htSaySaturn| (MAKESTRING "\\hrule")) + (COND + (|$exposedOnlyIfTrue| + (COND + (|one?| (|htSayCold| + (MAKESTRING "\\&Unexposed Also"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (MAKESTRING + "\\&Unexposed Also") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|exposureOff| NIL)))) + NIL)) + NIL))))) + (|one?| (|htSayCold| (MAKESTRING "\\Exposed Only\\&y"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS + (MAKESTRING "Exposed Onl\\&y") + (CONS (MAKESTRING "") + (CONS '|dbShowCons| + (CONS '|exposureOn| NIL)))) + NIL)) + NIL)))) + (COND (|$standard| (|htEndTable|))) + (SPADLET |$saturnContextMenuLines| |$htLineList|)))))) + +;htFilterPage(htPage,args) == +; htInitPage("Filter String",htCopyProplist htPage) +; htSay "\centerline{Enter filter string (use {\em *} for wild card):}" +; htSay '"\centerline{" +; htMakePage [['bcStrings, [50,'"",'filter,'EM]]] +; htSay '"}\vspace{1}\centerline{" +; htMakePage [['bcLispLinks,['"\fbox{Filter}",'"",:args]]] +; htSay '"}" +; htShowPage() + +(DEFUN |htFilterPage| (|htPage| |args|) + (PROGN + (|htInitPage| '|Filter String| (|htCopyProplist| |htPage|)) + (|htSay| '|\\centerline{Enter filter string (use {\\em *} for wild card):}|) + (|htSay| (MAKESTRING "\\centerline{")) + (|htMakePage| + (CONS (CONS '|bcStrings| + (CONS (CONS 50 + (CONS (MAKESTRING "") + (CONS '|filter| (CONS 'EM NIL)))) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}\\vspace{1}\\centerline{")) + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\fbox{Filter}") + (CONS (MAKESTRING "") |args|)) + NIL)) + NIL)) + (|htSay| (MAKESTRING "}")) + (|htShowPage|))) + +;htMakeSaturnFilterPage [fn2Call,:args] == +; htSay '"\inputboxLink[\lispLink[d]{\verb+(|" +; htSay fn2Call +; htSay '"| " +; htSay htpName $saturnPage +; for x in args repeat +; htSay '" '|" +; htSay x +; htSay '"|" +; htSay '" _"+_\FILTERSTRING\verb+_")+}{}]{\FILTERSTRING}{*}" +; htSay '"{\centerline{Enter filter string (use {\em *} for wild card):}}" +; htSay '"{Filter Page}{\&Filter}" + +(DEFUN |htMakeSaturnFilterPage| (G179039) + (PROG (|fn2Call| |args|) + (declare (special |$saturnPage|)) + (RETURN + (SEQ (PROGN + (SPADLET |fn2Call| (CAR G179039)) + (SPADLET |args| (CDR G179039)) + (|htSay| (MAKESTRING + "\\inputboxLink[\\lispLink[d]{\\verb+(|")) + (|htSay| |fn2Call|) + (|htSay| (MAKESTRING "| ")) + (|htSay| (|htpName| |$saturnPage|)) + (DO ((G179054 |args| (CDR G179054)) (|x| NIL)) + ((OR (ATOM G179054) + (PROGN (SETQ |x| (CAR G179054)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSay| (MAKESTRING " '|")) + (|htSay| |x|) + (|htSay| (MAKESTRING "|")))))) + (|htSay| (MAKESTRING + " \"+\\FILTERSTRING\\verb+\")+}{}]{\\FILTERSTRING}{*}")) + (|htSay| (MAKESTRING + "{\\centerline{Enter filter string (use {\\em *} for wild card):}}")) + (|htSay| (MAKESTRING "{Filter Page}{\\&Filter}"))))))) + +;dbShowConsKinds cAlist == +; cats := doms := paks := defs := nil +; for x in cAlist repeat +; op := CAAR x +; kind := dbConstructorKind op +; kind = 'category => cats := [x,:cats] +; kind = 'domain => doms := [x,:doms] +; kind = 'package => paks := [x,:paks] +; defs := [x,:defs] +; lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] +; htBeginMenu 'description +; htSayStandard '"\indent{1}" +; kinds := +/[1 for x in lists | #x > 0] +; firstTime := true +; for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat +; if firstTime then firstTime := false +; else htSaySaturn '"\\" +; htSaySaturn '"\item[" +; htSayStandard '"\item" +; if kinds = 1 +; then htSay menuButton() +; else htMakePage +; [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] +; htSaySaturn '"]" +; htSayStandard '"\tab{1}" +; htSay('"{\em ",c := #x,'" ") +; htSay(c > 1 => pluralize kind; kind) +; htSay '":}" +; htSaySaturn '"\\" +; bcConTable REMDUP [CAAR y for y in x] +; htEndMenu 'description +; htSayStandard '"\indent{0}" + +(DEFUN |dbShowConsKinds| (|cAlist|) + (PROG (|op| |kind| |cats| |doms| |paks| |defs| |lists| |kinds| + |firstTime| |c|) + (RETURN + (SEQ (PROGN + (SPADLET |cats| + (SPADLET |doms| + (SPADLET |paks| (SPADLET |defs| NIL)))) + (DO ((G179075 |cAlist| (CDR G179075)) (|x| NIL)) + ((OR (ATOM G179075) + (PROGN (SETQ |x| (CAR G179075)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |op| (CAAR |x|)) + (SPADLET |kind| (|dbConstructorKind| |op|)) + (COND + ((BOOT-EQUAL |kind| '|category|) + (SPADLET |cats| (CONS |x| |cats|))) + ((BOOT-EQUAL |kind| '|domain|) + (SPADLET |doms| (CONS |x| |doms|))) + ((BOOT-EQUAL |kind| '|package|) + (SPADLET |paks| (CONS |x| |paks|))) + ('T (SPADLET |defs| (CONS |x| |defs|)))))))) + (SPADLET |lists| + (CONS (NREVERSE |cats|) + (CONS (NREVERSE |doms|) + (CONS (NREVERSE |paks|) + (CONS (NREVERSE |defs|) NIL))))) + (|htBeginMenu| '|description|) + (|htSayStandard| (MAKESTRING "\\indent{1}")) + (SPADLET |kinds| + (PROG (G179081) + (SPADLET G179081 0) + (RETURN + (DO ((G179087 |lists| (CDR G179087)) + (|x| NIL)) + ((OR (ATOM G179087) + (PROGN + (SETQ |x| (CAR G179087)) + NIL)) + G179081) + (SEQ (EXIT (COND + ((> (|#| |x|) 0) + (SETQ G179081 + (PLUS G179081 1)))))))))) + (SPADLET |firstTime| 'T) + (DO ((G179109 + '("category" "domain" "package" + "default package") + (CDR G179109)) + (|kind| NIL) (G179110 |lists| (CDR G179110)) + (|x| NIL)) + ((OR (ATOM G179109) + (PROGN (SETQ |kind| (CAR G179109)) NIL) + (ATOM G179110) + (PROGN (SETQ |x| (CAR G179110)) NIL)) + NIL) + (SEQ (EXIT (COND + ((> (|#| |x|) 0) + (PROGN + (COND + (|firstTime| + (SPADLET |firstTime| NIL)) + ('T + (|htSaySaturn| (MAKESTRING "\\\\")))) + (|htSaySaturn| (MAKESTRING "\\item[")) + (|htSayStandard| (MAKESTRING "\\item")) + (COND + ((EQL |kinds| 1) + (|htSay| (|menuButton|))) + ('T + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS (|menuButton|) + (CONS (MAKESTRING "") + (CONS + '|dbShowConsKindsFilter| + (CONS + (CONS |kind| + (CONS |x| NIL)) + NIL)))) + NIL)) + NIL)))) + (|htSaySaturn| (MAKESTRING "]")) + (|htSayStandard| + (MAKESTRING "\\tab{1}")) + (|htSay| (MAKESTRING "{\\em ") + (SPADLET |c| (|#| |x|)) + (MAKESTRING " ")) + (|htSay| (COND + ((> |c| 1) + (|pluralize| |kind|)) + ('T |kind|))) + (|htSay| (MAKESTRING ":}")) + (|htSaySaturn| (MAKESTRING "\\\\")) + (|bcConTable| + (REMDUP + (PROG (G179123) + (SPADLET G179123 NIL) + (RETURN + (DO + ((G179128 |x| + (CDR G179128)) + (|y| NIL)) + ((OR (ATOM G179128) + (PROGN + (SETQ |y| (CAR G179128)) + NIL)) + (NREVERSE0 G179123)) + (SEQ + (EXIT + (SETQ G179123 + (CONS (CAAR |y|) + G179123))))))))))))))) + (|htEndMenu| '|description|) + (|htSayStandard| (MAKESTRING "\\indent{0}"))))))) + +;addParameterTemplates(page, conform) == +;---------------> from kPage <----------------------- +; parlist := [STRINGIMAGE par for par in rest conform] +; manuelsCode? := "MAX"/[#s for s in parlist] > 10 +; w := (manuelsCode? => 55; 23) +; htSaySaturn '"\colorbuttonbox{lightgray}{" +; htSay '"Optional argument value" +; htSay +; CDR parlist => '"s:" +; '":" +; htSaySaturn '"}" +; if CDR conform then htSaySaturn '"\newline{}" +; htSaySaturn '"\begin{tabular}{p{.25in}l}" +; firstTime := true +; odd := false +; argSublis := htpProperty(page,'argSublis) +; for parname in $PatternVariableList for par in rest conform repeat +; htSayStandard (odd or manuelsCode? => "\newline";"\tab{29}") +; if firstTime then firstTime := false +; else htSaySaturn '"\\" +; odd := not odd +; argstring := +; $conArgstrings is [a,:r] => ($conArgstrings := r; a) +; '"" +; htMakePageStandard [['text,'"{\em ",par,'"} = "], +; ['bcStrings,[w - #STRINGIMAGE par,argstring,parname,'EM]]] +; if $saturn then +; setUpDefault(parname, ['string, '"", 'EM, nil]) +; htSaySaturn '"{\em " +; htSaySaturn par +; htSaySaturn '" = }" +; htSaySaturnAmpersand() +; htSaySaturn '"\colorbuttonbox{lightgray}{\inputbox[2.5in]{\" +; htSaySaturn SUBLIS(argSublis,par) +; htSaySaturn '"}{" +; htSaySaturn argstring +; htSaySaturn '"}}" +; htEndTabular() + +(DEFUN |addParameterTemplates| (|page| |conform|) + (PROG (|parlist| |manuelsCode?| |w| |argSublis| |firstTime| |odd| |a| + |r| |argstring|) + (declare (special |$conArgstrings| |$saturn| |$PatternVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |parlist| + (PROG (G179168) + (SPADLET G179168 NIL) + (RETURN + (DO ((G179173 (CDR |conform|) + (CDR G179173)) + (|par| NIL)) + ((OR (ATOM G179173) + (PROGN + (SETQ |par| (CAR G179173)) + NIL)) + (NREVERSE0 G179168)) + (SEQ (EXIT (SETQ G179168 + (CONS (STRINGIMAGE |par|) + G179168)))))))) + (SPADLET |manuelsCode?| + (> (PROG (G179179) + (SPADLET G179179 -999999) + (RETURN + (DO ((G179184 |parlist| (CDR G179184)) + (|s| NIL)) + ((OR (ATOM G179184) + (PROGN + (SETQ |s| (CAR G179184)) + NIL)) + G179179) + (SEQ (EXIT + (SETQ G179179 + (MAX G179179 (|#| |s|)))))))) + 10)) + (SPADLET |w| (COND (|manuelsCode?| 55) ('T 23))) + (|htSaySaturn| + (MAKESTRING "\\colorbuttonbox{lightgray}{")) + (|htSay| (MAKESTRING "Optional argument value")) + (|htSay| (COND + ((CDR |parlist|) (MAKESTRING "s:")) + ('T (MAKESTRING ":")))) + (|htSaySaturn| (MAKESTRING "}")) + (COND + ((CDR |conform|) + (|htSaySaturn| (MAKESTRING "\\newline{}")))) + (|htSaySaturn| (MAKESTRING "\\begin{tabular}{p{.25in}l}")) + (SPADLET |firstTime| 'T) + (SPADLET |odd| NIL) + (SPADLET |argSublis| (|htpProperty| |page| '|argSublis|)) + (DO ((G179212 |$PatternVariableList| (CDR G179212)) + (|parname| NIL) + (G179213 (CDR |conform|) (CDR G179213)) + (|par| NIL)) + ((OR (ATOM G179212) + (PROGN (SETQ |parname| (CAR G179212)) NIL) + (ATOM G179213) + (PROGN (SETQ |par| (CAR G179213)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSayStandard| + (COND + ((OR |odd| |manuelsCode?|) + '|\\newline|) + ('T '|\\tab{29}|))) + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "\\\\")))) + (SPADLET |odd| (NULL |odd|)) + (SPADLET |argstring| + (COND + ((AND (PAIRP |$conArgstrings|) + (PROGN + (SPADLET |a| + (QCAR |$conArgstrings|)) + (SPADLET |r| + (QCDR |$conArgstrings|)) + 'T)) + (SPADLET |$conArgstrings| |r|) + |a|) + ('T (MAKESTRING "")))) + (|htMakePageStandard| + (CONS (CONS '|text| + (CONS (MAKESTRING "{\\em ") + (CONS |par| + (CONS (MAKESTRING "} = ") NIL)))) + (CONS + (CONS '|bcStrings| + (CONS + (CONS + (SPADDIFFERENCE |w| + (|#| (STRINGIMAGE |par|))) + (CONS |argstring| + (CONS |parname| + (CONS 'EM NIL)))) + NIL)) + NIL))) + (COND + (|$saturn| + (|setUpDefault| |parname| + (CONS '|string| + (CONS (MAKESTRING "") + (CONS 'EM (CONS NIL NIL))))))) + (|htSaySaturn| (MAKESTRING "{\\em ")) + (|htSaySaturn| |par|) + (|htSaySaturn| (MAKESTRING " = }")) + (|htSaySaturnAmpersand|) + (|htSaySaturn| + (MAKESTRING + "\\colorbuttonbox{lightgray}{\\inputbox[2.5in]{\\")) + (|htSaySaturn| (SUBLIS |argSublis| |par|)) + (|htSaySaturn| (MAKESTRING "}{")) + (|htSaySaturn| |argstring|) + (|htSaySaturn| (MAKESTRING "}}")))))) + (|htEndTabular|)))))) + +;kPageArgs([op,:args],[.,.,:source]) == +; htSaySaturn '"\begin{tabular}{p{.25in}lp{0in}}" +; firstTime := true +; coSig := rest GETDATABASE(op,'COSIG) +; for x in args for t in source for pred in coSig repeat +; if firstTime then firstTime := false +; else +; htSaySaturn '"\\" +; htSayStandard '", and" +; htSayStandard '"\newline " +; htSaySaturnAmpersand() +; typeForm := (t is [":",.,t1] => t1; t) +; if pred = true +; then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] +; else htSay('"{\em ",x,'"}") +; htSayStandard( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ") +; htSaySaturnAmpersand() +; htSay +; pred => '"a domain of category " +; '"an element of the domain " +; bcConform(typeForm,true) +; htEndTabular() + +(DEFUN |kPageArgs| (G179254 G179269) + (PROG (|source| |op| |args| |coSig| |firstTime| |ISTMP#1| |ISTMP#2| + |t1| |typeForm|) + (RETURN + (SEQ (PROGN + (SPADLET |source| (CDDR G179269)) + (SPADLET |op| (CAR G179254)) + (SPADLET |args| (CDR G179254)) + (|htSaySaturn| + (MAKESTRING "\\begin{tabular}{p{.25in}lp{0in}}")) + (SPADLET |firstTime| 'T) + (SPADLET |coSig| (CDR (GETDATABASE |op| 'COSIG))) + (DO ((G179306 |args| (CDR G179306)) (|x| NIL) + (G179307 |source| (CDR G179307)) (|t| NIL) + (G179308 |coSig| (CDR G179308)) (|pred| NIL)) + ((OR (ATOM G179306) + (PROGN (SETQ |x| (CAR G179306)) NIL) + (ATOM G179307) + (PROGN (SETQ |t| (CAR G179307)) NIL) + (ATOM G179308) + (PROGN (SETQ |pred| (CAR G179308)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + (|firstTime| (SPADLET |firstTime| NIL)) + ('T (|htSaySaturn| (MAKESTRING "\\\\")) + (|htSayStandard| (MAKESTRING ", and")))) + (|htSayStandard| (MAKESTRING "\\newline ")) + (|htSaySaturnAmpersand|) + (SPADLET |typeForm| + (COND + ((AND (PAIRP |t|) + (EQ (QCAR |t|) '|:|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) + NIL) + (PROGN + (SPADLET |t1| + (QCAR |ISTMP#2|)) + 'T)))))) + |t1|) + ('T |t|))) + (COND + ((BOOT-EQUAL |pred| 'T) + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |x| + (CONS (MAKESTRING "") + (CONS '|kArgPage| + (CONS |x| NIL)))) + NIL)) + NIL))) + ('T + (|htSay| (MAKESTRING "{\\em ") |x| + (MAKESTRING "}")))) + (|htSayStandard| (MAKESTRING "\\tab{") + (STRINGIMAGE (|#| (PNAME |x|))) + (MAKESTRING "}, ")) + (|htSaySaturnAmpersand|) + (|htSay| (COND + (|pred| + (MAKESTRING + "a domain of category ")) + ('T + (MAKESTRING + "an element of the domain ")))) + (|bcConform| |typeForm| 'T))))) + (|htEndTabular|)))))) + +;--======================================================================= +;-- Redefinitions from br-op1.boot +;--======================================================================= +;--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +;dbConform form == +;--one button for the main constructor page of a type +; $saturn => ["\lispLink[d]{\verb!(|conPage| '",:form2Fence dbOuttran form,'")!}{", +; :form2StringList opOf form,"}"] +; ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] + +(DEFUN |dbConform| (|form|) + (declare (special |$saturn|)) + (COND + (|$saturn| + (CONS '|\\lispLink[d]{\\verb!(\|conPage\| '| + (APPEND (|form2Fence| (|dbOuttran| |form|)) + (CONS (MAKESTRING ")!}{") + (APPEND (|form2StringList| (|opOf| |form|)) + (CONS '} NIL)))))) + ('T + (CONS '|\\conf{| + (APPEND (|form2StringList| (|opOf| |form|)) + (CONS (MAKESTRING "}{") + (APPEND (|form2Fence| (|dbOuttran| |form|)) + (CONS (MAKESTRING "}") NIL)))))))) + +;--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +;htTab s == if $standard then htSayStandard ('"\tab{",s,'"}") + +(DEFUN |htTab| (|s|) + (declare (special |$standard|)) + (COND + (|$standard| + (|htSayStandard| (MAKESTRING "\\tab{") |s| (MAKESTRING "}"))) + ('T NIL))) + +;--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +;dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == +; single? := null rest data +; htBeginMenu 'description +; bincount := 0 +; for [thing,exposeFlag,:items] in data repeat +; htSaySaturn '"\item[" +; htSayStandard ('"\item") +; if single? then htSay(menuButton()) +; else +; htMakePageStandard +; [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] +; button := mkButtonBox (1 + bincount) +; htMakePageSaturn [['bcLinks,[button,'"",'dbShowOps,which,bincount]]] +; htSaySaturn '"]" +; htSay '"{\em " +; htSay +; thing = 'nowhere => '"implemented nowhere" +; thing = 'constant => '"constant" +; thing = '_$ => '"by the domain" +; INTEGERP thing => '"unexported" +; constructorIfTrue => +; htSay word +; atom thing => '" an unknown constructor" +; '"" +; atom thing => '"unconditional" +; '"" +; htSay '"}" +; if null atom thing then +; if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") +; htSay '" " +; FUNCALL(fn,thing) +; htSay('":\newline ") +; dbShowOpSigList(which,items,(1 + bincount) * 8192) +; bincount := bincount + 1 +; htEndMenu 'description + +(DEFUN |dbGatherThenShow| + (|htPage| |opAlist| |which| |data| |constructorIfTrue| |word| + |fn|) + (declare (ignore |htPage| |opAlist|)) + (PROG (|single?| |thing| |exposeFlag| |items| |button| |bincount|) + (RETURN + (SEQ (PROGN + (SPADLET |single?| (NULL (CDR |data|))) + (|htBeginMenu| '|description|) + (SPADLET |bincount| 0) + (DO ((G179366 |data| (CDR G179366)) (G179345 NIL)) + ((OR (ATOM G179366) + (PROGN (SETQ G179345 (CAR G179366)) NIL) + (PROGN + (PROGN + (SPADLET |thing| (CAR G179345)) + (SPADLET |exposeFlag| (CADR G179345)) + (SPADLET |items| (CDDR G179345)) + G179345) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|htSaySaturn| (MAKESTRING "\\item[")) + (|htSayStandard| (MAKESTRING "\\item")) + (COND + (|single?| (|htSay| (|menuButton|))) + ('T + (|htMakePageStandard| + (CONS + (CONS '|bcLinks| + (CONS + (CONS (|menuButton|) + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS |bincount| NIL))))) + NIL)) + NIL)) + (SPADLET |button| + (|mkButtonBox| + (PLUS 1 |bincount|))) + (|htMakePageSaturn| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |button| + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS |bincount| NIL))))) + NIL)) + NIL)))) + (|htSaySaturn| (MAKESTRING "]")) + (|htSay| (MAKESTRING "{\\em ")) + (|htSay| (COND + ((BOOT-EQUAL |thing| '|nowhere|) + (MAKESTRING + "implemented nowhere")) + ((BOOT-EQUAL |thing| + '|constant|) + (MAKESTRING "constant")) + ((BOOT-EQUAL |thing| '$) + (MAKESTRING "by the domain")) + ((INTEGERP |thing|) + (MAKESTRING "unexported")) + (|constructorIfTrue| + (|htSay| |word|) + (COND + ((ATOM |thing|) + (MAKESTRING + " an unknown constructor")) + ('T (MAKESTRING "")))) + ((ATOM |thing|) + (MAKESTRING "unconditional")) + ('T (MAKESTRING "")))) + (|htSay| (MAKESTRING "}")) + (COND + ((NULL (ATOM |thing|)) + (COND + (|constructorIfTrue| + (|htSay| (MAKESTRING " {\\em ") + (|dbShowKind| |thing|) + (MAKESTRING "}")))) + (|htSay| (MAKESTRING " ")) + (FUNCALL |fn| |thing|))) + (|htSay| (MAKESTRING ":\\newline ")) + (|dbShowOpSigList| |which| |items| + (TIMES (PLUS 1 |bincount|) 8192)) + (SPADLET |bincount| (PLUS |bincount| 1)))))) + (|htEndMenu| '|description|)))))) + +;--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +;dbPresentOps(htPage,which,:exclusions) == +;--Flags: +;-- fromConPage?: came (originally) from a constructor page +;-- usage?: display usage? +;-- star?: display exposed/*=unexposed +;-- implementation?: display implementation? +; $saturn => dbPresentOpsSaturn(htPage,which,exclusions) +; asharp? := htpProperty(htPage,'isAsharpConstructor) +; fromConPage? := (conname := opOf htpProperty(htPage,'conform)) +; usage? := nil +; star? := not fromConPage? or which = '"package operation" +; implementation? := not asharp? and +; $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? +; rightmost? := star? or (implementation? and not $includeUnexposed?) +; if INTEGERP first exclusions then exclusions := ['documentation] +; htpSetProperty(htPage,'exclusion,first exclusions) +; opAlist := +; which = '"operation" => htpProperty(htPage,'opAlist) +; htpProperty(htPage,'attrAlist) +; empty? := null opAlist +; one? := opAlist is [entry] and 2 = #entry +; one? := empty? or one? +; htBeginTable() +; htSay '"{" +; if one? or MEMBER('conditions,exclusions) +; or (htpProperty(htPage,'condition?) = 'no) +; then htSay '"{\em Conditions}" +; else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowOps,which,'conditions]]] +; htSay '"}{" +; if empty? or MEMBER('documentation,exclusions) +; then htSay '"{\em Descriptions}" +; else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowOps,which,'documentation]]] +; htSay '"}{" +; if null IFCDR opAlist +; then htSay '"{\em Filter}" +; else htMakePage [['bcLinks,['"Filter ",'"",'htFilterPage,['dbShowOps,which,'filter]]]] +; htSay '"}{" +; if one? or MEMBER('names,exclusions) or null KDR opAlist +; then htSay '"{\em Names}" +; else htMakePage [['bcLispLinks,['"Names",'"",'dbShowOps,which,'names]]] +; if not star? then +; htSay '"}{" +; if not implementation? or MEMBER('implementation,exclusions) or which = '"attribute" or +; ((conname := opOf htpProperty(htPage,'conform)) +; and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) +; then htSay '"{\em Implementations}" +; else htMakePage +; [['bcLispLinks,['"Implementations",'"",'dbShowOps,which,'implementation]]] +; htSay '"}{" +; if one? or MEMBER('origins,exclusions) +; then htSay '"{\em Origins}" +; else htMakePage [['bcLispLinks,['"Origins",'"",'dbShowOps,which,'origins]]] +; htSay '"}{" +; if one? or MEMBER('parameters,exclusions) --also test for some parameter +; or not dbDoesOneOpHaveParameters? opAlist +; then htSay '"{\em Parameters}" +; else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowOps,which,'parameters]]] +; htSay '"}{" +; if which ^= '"attribute" then +; if one? or MEMBER('signatures,exclusions) +; then htSay '"{\em Signatures}" +; else htMakePage [['bcLispLinks,['"Signatures",'"",'dbShowOps,which,'signatures]]] +; htSay '"}" +; if star? then +; htSay '"{" +; if $exposedOnlyIfTrue +; then if one? +; then htSay '"{\em Unexposed Also}" +; else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] +; else if one? +; then htSay '"{\em Exposed Only}" +; else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowOps, which,'exposureOn]]] +; htSay '"}" +; htEndTable() + +(DEFUN |dbPresentOps| + (&REST G179404 &AUX |exclusions| |which| |htPage|) + (DSETQ (|htPage| |which| . |exclusions|) G179404) + (PROG (|asharp?| |fromConPage?| |usage?| |star?| |implementation?| + |rightmost?| |opAlist| |empty?| |entry| |one?| |conname|) + (declare (special |$saturn| |$UserLevel| |$conformsAreDomains| + |$includeUnexposed?| |$exposedOnlyIfTrue|)) + (RETURN + (COND + (|$saturn| + (|dbPresentOpsSaturn| |htPage| |which| |exclusions|)) + ('T + (SPADLET |asharp?| + (|htpProperty| |htPage| '|isAsharpConstructor|)) + (SPADLET |fromConPage?| + (SPADLET |conname| + (|opOf| (|htpProperty| |htPage| '|conform|)))) + (SPADLET |usage?| NIL) + (SPADLET |star?| + (OR (NULL |fromConPage?|) + (BOOT-EQUAL |which| + (MAKESTRING "package operation")))) + (SPADLET |implementation?| + (AND (NULL |asharp?|) + (BOOT-EQUAL |$UserLevel| '|development|) + |$conformsAreDomains|)) + (SPADLET |rightmost?| + (OR |star?| + (AND |implementation?| + (NULL |$includeUnexposed?|)))) + (COND + ((INTEGERP (CAR |exclusions|)) + (SPADLET |exclusions| (CONS '|documentation| NIL)))) + (|htpSetProperty| |htPage| '|exclusion| (CAR |exclusions|)) + (SPADLET |opAlist| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpProperty| |htPage| '|opAlist|)) + ('T (|htpProperty| |htPage| '|attrAlist|)))) + (SPADLET |empty?| (NULL |opAlist|)) + (SPADLET |one?| + (AND (PAIRP |opAlist|) (EQ (QCDR |opAlist|) NIL) + (PROGN (SPADLET |entry| (QCAR |opAlist|)) 'T) + (EQL 2 (|#| |entry|)))) + (SPADLET |one?| (OR |empty?| |one?|)) (|htBeginTable|) + (|htSay| (MAKESTRING "{")) + (COND + ((OR |one?| (|member| '|conditions| |exclusions|) + (BOOT-EQUAL (|htpProperty| |htPage| '|condition?|) + '|no|)) + (|htSay| (MAKESTRING "{\\em Conditions}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Conditions") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|conditions| NIL))))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |empty?| (|member| '|documentation| |exclusions|)) + (|htSay| (MAKESTRING "{\\em Descriptions}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Descriptions") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|documentation| NIL))))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((NULL (IFCDR |opAlist|)) + (|htSay| (MAKESTRING "{\\em Filter}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Filter ") + (CONS (MAKESTRING "") + (CONS '|htFilterPage| + (CONS + (CONS '|dbShowOps| + (CONS |which| + (CONS '|filter| NIL))) + NIL)))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (|member| '|names| |exclusions|) + (NULL (KDR |opAlist|))) + (|htSay| (MAKESTRING "{\\em Names}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Names") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|names| NIL))))) + NIL)) + NIL)))) + (COND + ((NULL |star?|) (|htSay| (MAKESTRING "}{")) + (COND + ((OR (NULL |implementation?|) + (|member| '|implementation| |exclusions|) + (BOOT-EQUAL |which| (MAKESTRING "attribute")) + (AND (SPADLET |conname| + (|opOf| (|htpProperty| |htPage| + '|conform|))) + (BOOT-EQUAL + (GETDATABASE |conname| 'CONSTRUCTORKIND) + '|category|))) + (|htSay| (MAKESTRING "{\\em Implementations}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS + (MAKESTRING "Implementations") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|implementation| NIL))))) + NIL)) + NIL)))))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (|member| '|origins| |exclusions|)) + (|htSay| (MAKESTRING "{\\em Origins}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Origins") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|origins| NIL))))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((OR |one?| (|member| '|parameters| |exclusions|) + (NULL (|dbDoesOneOpHaveParameters?| |opAlist|))) + (|htSay| (MAKESTRING "{\\em Parameters}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Parameters") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|parameters| NIL))))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}{")) + (COND + ((NEQUAL |which| (MAKESTRING "attribute")) + (COND + ((OR |one?| (|member| '|signatures| |exclusions|)) + (|htSay| (MAKESTRING "{\\em Signatures}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "Signatures") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|signatures| NIL))))) + NIL)) + NIL)))))) + (|htSay| (MAKESTRING "}")) + (COND + (|star?| (|htSay| (MAKESTRING "{")) + (COND + (|$exposedOnlyIfTrue| + (COND + (|one?| (|htSay| + (MAKESTRING + "{\\em Unexposed Also}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (MAKESTRING "Unexposed Also") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|exposureOff| NIL))))) + NIL)) + NIL))))) + (|one?| (|htSay| (MAKESTRING + "{\\em Exposed Only}"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (MAKESTRING "Exposed Only") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|exposureOn| NIL))))) + NIL)) + NIL)))) + (|htSay| (MAKESTRING "}")))) + (|htEndTable|)))))) + +;dbPresentOpsSaturn(htPage,which,exclusions) == +;--Flags: +;-- fromConPage?: came (originally) from a constructor page +;-- usage?: display usage? +;-- star?: display exposed/*=unexposed +;-- implementation?: display implementation? +; $htLineList : local := nil +; $newPage : local := nil +; asharp? := htpProperty(htPage,'isAsharpConstructor) +; fromConPage? := (conname := opOf htpProperty(htPage,'conform)) +; usage? := nil +; star? := not fromConPage? or which = '"package operation" +; implementation? := not asharp? and +; $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? +; rightmost? := star? or (implementation? and not $includeUnexposed?) +; if INTEGERP first exclusions then exclusions := ['documentation] +; htpSetProperty(htPage,'exclusion,first exclusions) +; opAlist := +; which = '"operation" => htpProperty(htPage,'opAlist) +; htpProperty(htPage,'attrAlist) +; empty? := null opAlist +; one? := opAlist is [entry] and 2 = #entry +; one? := empty? or one? +; if one? or MEMBER('conditions,exclusions) +; or (htpProperty(htPage,'condition?) = 'no) +; then htSayCold '"\&Conditions" +; else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowOps,which,'conditions]]] +; if empty? or MEMBER('documentation,exclusions) +; then htSayCold '"\&Descriptions" +; else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowOps,which,'documentation]]] +; if null IFCDR opAlist +; then htSayCold '"\&Filter" +; else htMakeSaturnFilterPage ['dbShowOps, which, 'filter] +; if not implementation? or MEMBER('implementation,exclusions) or which = '"attribute" or +; ((conname := opOf htpProperty(htPage,'conform)) +; and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) +; then htSayCold '"\&Implementations" +; else htMakePage +; [['bcLispLinks,['"\&Implementations",'"",'dbShowOps,which,'implementation]]] +; if one? or MEMBER('names,exclusions) or null KDR opAlist +; then htSayCold '"\&Names" +; else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowOps,which,'names]]] +; if one? or MEMBER('origins,exclusions) +; then htSayCold '"\&Origins" +; else htMakePage [['bcLispLinks,['"\&Origins",'"",'dbShowOps,which,'origins]]] +; if one? or MEMBER('parameters,exclusions) --also test for some parameter +; or not dbDoesOneOpHaveParameters? opAlist +; then htSayCold '"\&Parameters" +; else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowOps,which,'parameters]]] +; if which ^= '"attribute" then +; if one? or MEMBER('signatures,exclusions) +; then htSayCold '"\&Signatures" +; else htMakePage [['bcLispLinks,['"\&Signatures",'"",'dbShowOps,which,'signatures]]] +; if star? then +; htSay '"\hrule" +; if $exposedOnlyIfTrue +; then if one? then htSayCold '"\&Unexposed Also" +; else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] +; else +; if one? then htSayCold '"Exposed Onl\&y" +; else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowOps,which,'exposureOn]]] +; $saturnContextMenuLines := $htLineList + +(DEFUN |dbPresentOpsSaturn| (|htPage| |which| |exclusions|) + (PROG (|$htLineList| |$newPage| |asharp?| |fromConPage?| |usage?| + |star?| |implementation?| |rightmost?| |opAlist| |empty?| + |entry| |one?| |conname|) + (DECLARE (SPECIAL |$htLineList| |$newPage| |$UserLevel| + |$conformsAreDomains| |$includeUnexposed?| + |$exposedOnlyIfTrue| |$saturnContextMenuLines| + |$htLineList|)) + (RETURN + (PROGN + (SPADLET |$htLineList| NIL) + (SPADLET |$newPage| NIL) + (SPADLET |asharp?| + (|htpProperty| |htPage| '|isAsharpConstructor|)) + (SPADLET |fromConPage?| + (SPADLET |conname| + (|opOf| (|htpProperty| |htPage| '|conform|)))) + (SPADLET |usage?| NIL) + (SPADLET |star?| + (OR (NULL |fromConPage?|) + (BOOT-EQUAL |which| + (MAKESTRING "package operation")))) + (SPADLET |implementation?| + (AND (NULL |asharp?|) + (BOOT-EQUAL |$UserLevel| '|development|) + |$conformsAreDomains|)) + (SPADLET |rightmost?| + (OR |star?| + (AND |implementation?| + (NULL |$includeUnexposed?|)))) + (COND + ((INTEGERP (CAR |exclusions|)) + (SPADLET |exclusions| (CONS '|documentation| NIL)))) + (|htpSetProperty| |htPage| '|exclusion| (CAR |exclusions|)) + (SPADLET |opAlist| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (|htpProperty| |htPage| '|opAlist|)) + ('T (|htpProperty| |htPage| '|attrAlist|)))) + (SPADLET |empty?| (NULL |opAlist|)) + (SPADLET |one?| + (AND (PAIRP |opAlist|) (EQ (QCDR |opAlist|) NIL) + (PROGN (SPADLET |entry| (QCAR |opAlist|)) 'T) + (EQL 2 (|#| |entry|)))) + (SPADLET |one?| (OR |empty?| |one?|)) + (COND + ((OR |one?| (|member| '|conditions| |exclusions|) + (BOOT-EQUAL (|htpProperty| |htPage| '|condition?|) + '|no|)) + (|htSayCold| (MAKESTRING "\\&Conditions"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Conditions") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|conditions| NIL))))) + NIL)) + NIL)))) + (COND + ((OR |empty?| (|member| '|documentation| |exclusions|)) + (|htSayCold| (MAKESTRING "\\&Descriptions"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Descriptions") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|documentation| NIL))))) + NIL)) + NIL)))) + (COND + ((NULL (IFCDR |opAlist|)) + (|htSayCold| (MAKESTRING "\\&Filter"))) + ('T + (|htMakeSaturnFilterPage| + (CONS '|dbShowOps| (CONS |which| (CONS '|filter| NIL)))))) + (COND + ((OR (NULL |implementation?|) + (|member| '|implementation| |exclusions|) + (BOOT-EQUAL |which| (MAKESTRING "attribute")) + (AND (SPADLET |conname| + (|opOf| (|htpProperty| |htPage| + '|conform|))) + (BOOT-EQUAL + (GETDATABASE |conname| 'CONSTRUCTORKIND) + '|category|))) + (|htSayCold| (MAKESTRING "\\&Implementations"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING + "\\&Implementations") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|implementation| NIL))))) + NIL)) + NIL)))) + (COND + ((OR |one?| (|member| '|names| |exclusions|) + (NULL (KDR |opAlist|))) + (|htSayCold| (MAKESTRING "\\&Names"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Names") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|names| NIL))))) + NIL)) + NIL)))) + (COND + ((OR |one?| (|member| '|origins| |exclusions|)) + (|htSayCold| (MAKESTRING "\\&Origins"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Origins") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|origins| NIL))))) + NIL)) + NIL)))) + (COND + ((OR |one?| (|member| '|parameters| |exclusions|) + (NULL (|dbDoesOneOpHaveParameters?| |opAlist|))) + (|htSayCold| (MAKESTRING "\\&Parameters"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Parameters") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|parameters| NIL))))) + NIL)) + NIL)))) + (COND + ((NEQUAL |which| (MAKESTRING "attribute")) + (COND + ((OR |one?| (|member| '|signatures| |exclusions|)) + (|htSayCold| (MAKESTRING "\\&Signatures"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLispLinks| + (CONS (CONS (MAKESTRING "\\&Signatures") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|signatures| NIL))))) + NIL)) + NIL)))))) + (COND + (|star?| (|htSay| (MAKESTRING "\\hrule")) + (COND + (|$exposedOnlyIfTrue| + (COND + (|one?| (|htSayCold| + (MAKESTRING "\\&Unexposed Also"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (MAKESTRING + "\\&Unexposed Also") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|exposureOff| NIL))))) + NIL)) + NIL))))) + (|one?| (|htSayCold| + (MAKESTRING "Exposed Onl\\&y"))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS + (CONS + (MAKESTRING "Exposed Onl\\&y") + (CONS (MAKESTRING "") + (CONS '|dbShowOps| + (CONS |which| + (CONS '|exposureOn| NIL))))) + NIL)) + NIL)))))) + (SPADLET |$saturnContextMenuLines| |$htLineList|))))) + +;--======================================================================= +;-- Redefinitions from br-search.boot +;--======================================================================= +;---------------------> OLD DEFINITION (override in br-search.boot.pamphlet) +;htShowPageStar() == +; $saturn => htShowPageStarSaturn() +; htSayStandard '"\endscroll " +; if $exposedOnlyIfTrue then +; htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] +; else +; htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] +; htShowPageNoScroll() + +(DEFUN |htShowPageStar| () + (declare (special |$saturn| |$exposedOnlyIfTrue|)) + (COND + (|$saturn| (|htShowPageStarSaturn|)) + ('T (|htSayStandard| (MAKESTRING "\\endscroll ")) + (COND + (|$exposedOnlyIfTrue| + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Unexposed Also") + (CONS (MAKESTRING "") + (CONS '|repeatSearch| + (CONS NIL NIL)))) + NIL)) + NIL))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Exposed Only") + (CONS (MAKESTRING "") + (CONS '|repeatSearch| + (CONS 'T NIL)))) + NIL)) + NIL)))) + (|htShowPageNoScroll|)))) + +;htShowPageStarSaturn() == +; $newPage : local := nil +; $htLineList : local := nil +; if $exposedOnlyIfTrue then +; htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] +; else +; htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] +; $saturnContextMenuLines := $htLineList +; htShowPageNoScroll() + +(DEFUN |htShowPageStarSaturn| () + (PROG (|$newPage| |$htLineList|) + (DECLARE (SPECIAL |$newPage| |$htLineList| |$saturnContextMenuLines| + |$exposedOnlyIfTrue|)) + (RETURN + (PROGN + (SPADLET |$newPage| NIL) + (SPADLET |$htLineList| NIL) + (COND + (|$exposedOnlyIfTrue| + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Unexposed Also") + (CONS (MAKESTRING "") + (CONS '|repeatSearch| + (CONS NIL NIL)))) + NIL)) + NIL))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (MAKESTRING "Exposed Only") + (CONS (MAKESTRING "") + (CONS '|repeatSearch| + (CONS 'T NIL)))) + NIL)) + NIL)))) + (SPADLET |$saturnContextMenuLines| |$htLineList|) + (|htShowPageNoScroll|))))) + +;--======================================================================= +;-- Redefinitions from br-op2.boot +;--======================================================================= +;--------------> NEW DEFINITION (see br-op2.boot.pamphlet) +;displayDomainOp(htPage,which,origin,op,sig,predicate, +; doc,index,chooseFn,unexposed?,$generalSearch?) == +; $chooseDownCaseOfType : local := true --see dbGetContrivedForm +; $whereList : local := nil +; $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) +; $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) +; $FunctionList:local := '(f g h d e F G H) +; $DomainList: local := '(D R S E T A B C M N P Q U V W) +; exactlyOneOpSig := null index +; conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) +; or origin +; if $generalSearch? then $DomainList := rest $DomainList +; opform := +; which = '"attribute" => +; null sig => [op] +; [op,sig] +; which = '"constructor" => origin +; dbGetDisplayFormForOp(op,sig,doc) +; htSayStandard('"\newline") +; ----------------------------------------------------------- +; htSaySaturn '"\item[" +; if exactlyOneOpSig +; then htSay menuButton() +; else htMakePage +; [['bcLinks,[menuButton(),'"",chooseFn,which,index]]] +; htSaySaturn '"]" +; htSayStandard '"\tab{2}" +; op := IFCAR opform +; args := IFCDR opform +; ops := escapeSpecialChars STRINGIMAGE op +; n := #sig +; do +; n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") +; n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") +; if unexposed? and $includeUnexposed? then +; htSayUnexposed() +; htSay(ops) +; predicate='ASCONST or GETDATABASE(op,'NILADIC) or MEMBER(op,'(0 1)) => 'skip +; which = '"attribute" and null args => 'skip +; htSay('"(") +; if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") +; for x in IFCDR args repeat +; htSay('",{\em ",quickForm2HtString x,'"}") +; htSay('")") +; -----------prepare to print description--------------------- +; constring := form2HtString conform +; conname := first conform +; $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" +; or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) +; $conlength : local := #constring +; $conform : local := conform +; $conargs : local := rest conform +; if which = '"operation" then +; $signature : local := +; MEMQ(conname,$Primitives) => nil +; CDAR getConstructorModemap conname +; --RDJ: this next line is necessary until compiler bug is fixed +; --that forgets to substitute #variables for t#variables; +; --check the signature for SegmentExpansionCategory, e.g. +; tvarlist := TAKE(# $conargs,$TriangleVariableList) +; $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) +; $sig := +; which = '"attribute" or which = '"constructor" => sig +; $conkind ^= '"package" => sig +; symbolsUsed := [x for x in rest conform | IDENTP x] +; $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) +; getSubstSigIfPossible sig +; ----------------------------------------------------------- +; htSaySaturn '"\begin{tabular}{lp{0in}}" +; ----------------------------------------------------------- +; if MEMBER(which,'("operation" "constructor")) then +; $displayReturnValue: local := nil +; if args then +; htSayStandard('"\newline\tab{2}{\em Arguments:}") +; htSaySaturn '"{\em Arguments:}" +; htSaySaturnAmpersand() +; firstTime := true +; coSig := KDR GETDATABASE(op,'COSIG) --check if op is constructor +; for a in args for t in rest $sig repeat +; if not firstTime then +; htSaySaturn '"\\ " +; htSaySaturnAmpersand() +; firstTime := false +; htSayIndentRel(15, true) +; position := KAR relatives +; relatives := KDR relatives +; if KAR coSig and t ^= '(Type) +; then htMakePage [['bcLinks,[a,'"",'kArgPage,a]]] +; else htSay('"{\em ",form2HtString(a),'"}") +; htSay ", " +; coSig := KDR coSig +; htSayValue t +; htSayIndentRel(-15,true) +; htSayStandard('"\newline ") +; htSaySaturn '"\\" +; if first $sig then +; $displayReturnValue := true +; htSayStandard('"\newline\tab{2}") +; htSay '"{\em Returns:}" +; htSaySaturnAmpersand() +; htSayIndentRel(15, true) +; htSayValue first $sig +; htSayIndentRel(-15, true) +; htSaySaturn '"\\" +; ----------------------------------------------------------- +; if origin and ($generalSearch? or origin ^= conform) and op^=opOf origin then +; htSaySaturn '"{\em Origin:}" +; htSaySaturnAmpersand() +; htSayStandard('"\newline\tab{2}{\em Origin:}") +; htSayIndentRel(15) +; if not isExposedConstructor opOf origin and $includeUnexposed? +; then htSayUnexposed() +; bcConform(origin,true) +; htSayIndentRel(-15) +; htSaySaturn '"\\" +; ----------------------------------------------------------- +; if not MEMQ(predicate,'(T ASCONST)) then +; pred := sublisFormal(KDR conform,predicate) +; count := #pred +; htSaySaturn '"{\em Conditions:}" +; htSayStandard('"\newline\tab{2}{\em Conditions:}") +; firstTime := true +; for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat +; if not firstTime then htSaySaturn '"\\" +; htSayIndentRel(15,count > 1) +; firstTime := false +; htSaySaturnAmpersand() +; bcPred(p,$conform,true) +; htSayIndentRel(-15,count > 1) +; htSayStandard('"\newline ") +; htSaySaturn '"\\" +; ----------------------------------------------------------- +; if $whereList then +; count := #$whereList +; htSaySaturn '"{\em Where:}" +; htSayStandard('"\newline\tab{2}{\em Where:}") +; firstTime := true +; if ASSOC("$",$whereList) then +; htSayIndentRel(15,true) +; htSaySaturnAmpersand() +; htSayStandard '"{\em \$} is " +; htSaySaturn '"{\em \%} is " +; htSay +; $conkind = '"category" => '"of category " +; '"the domain " +; bcConform(conform,true,true) +; firstTime := false +; htSayIndentRel(-15,true) +; for [d,key,:t] in $whereList | d ^= "$" repeat +; htSayIndentRel(15,count > 1) +; if not firstTime then htSaySaturn '"\\ " +; htSaySaturnAmpersand() +; firstTime := false +; htSay("{\em ",d,"} is ") +; htSayConstructor(key,sublisFormal(KDR conform,t)) +; htSayIndentRel(-15,count > 1) +; htSaySaturn '"\\" +; ----------------------------------------------------------- +; if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then +; htSaySaturn '"{\em Description:}" +; htSaySaturnAmpersand() +; htSayStandard('"\newline\tab{2}{\em Description:}") +; htSayIndentRel(15) +; if doc = $charFauxNewline then htSay $charNewline +; else +; ndoc:= +; -- we are confused whether doc is a string or a list of strings +; CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] +; SUBSTITUTE($charNewline, $charFauxNewline,doc) +; htSay ndoc +;-- htSaySaturn '"\\" +; htSayIndentRel(-15) +; --------> print abbr and source file for constructors <--------- +; if which = '"constructor" then +; if (abbr := GETDATABASE(conname,'ABBREVIATION)) then +; htSaySaturn '"\\" +; htSaySaturn '"{\em Abbreviation:}" +; htSaySaturnAmpersand() +; htSayStandard('"\tab{2}{\em Abbreviation:}") +; htSayIndentRel(15) +; htSay abbr +; htSayIndentRel(-15) +; htSayStandard('"\newline{}") +; if ( $saturn and (link := saturnHasExamplePage conname)) then +; htSaySaturn '"\\" +; htSaySaturn '"{\em Examples:}" +; htSaySaturnAmpersand() +; htSayIndentRel(15) +; htSay '"\spadref{" +; htSay CAR(CDR(link)) +; htSay '"}" +; htSayIndentRel(-15) +; htSayStandard('"\newline{}") +; htSaySaturn '"\\" +; htSaySaturn '"{\em Source File:}" +; htSaySaturnAmpersand() +; htSayStandard('"\tab{2}{\em Source File:}") +; htSayIndentRel(15) +; htSaySourceFile conname +; htSayIndentRel(-15) +; ------------------> remove profile printouts for now <------------------- +; if $standard and +; exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then +; displayInfoOp(htPage,infoAlist,op,sig) +; ----------------------------------------------------------- +; htSaySaturn '"\end{tabular}" + +(DEFUN |displayDomainOp| + (|htPage| |which| |origin| |op| |sig| |predicate| |doc| |index| + |chooseFn| |unexposed?| |$generalSearch?|) + (DECLARE (SPECIAL |$generalSearch?|)) + (PROG (|$chooseDownCaseOfType| |$whereList| |$NumberList| + |$ElementList| |$FunctionList| |$DomainList| |$conkind| + |$conlength| |$conform| |$conargs| |$signature| + |$displayReturnValue| |exactlyOneOpSig| |conform| |opform| + |args| |ops| |n| |constring| |conname| |tvarlist| + |symbolsUsed| |position| |relatives| |coSig| |pred| |count| + |key| |t| |firstTime| |d| |ndoc| |abbr| |link| |infoAlist|) + (DECLARE (SPECIAL |$chooseDownCaseOfType| |$whereList| |$sig| + |$NumberList| |$ElementList| |$FunctionList| + |$DomainList| |$conkind| |$conlength| |$conform| + |$conargs| |$signature| |$displayReturnValue| + |$charNewline| |$Primitives| |$TriangleVariableList| + |$FormalMapVariableList| |$sig| |$includeUnexposed?| + |$standard| |$saturn| |$charFauxNewline|)) + (RETURN + (SEQ (PROGN + (SPADLET |$chooseDownCaseOfType| 'T) + (SPADLET |$whereList| NIL) + (SPADLET |$NumberList| + '(|i| |j| |k| |l| |m| |n| |i1| |j1| |k1| |l1| + |m1| |n1| |i2| |j2| |k2| |l2| |m2| |n2| + |i3| |j3| |k3| |l3| |m3| |n3| |i4| |j4| + |k4| |l4| |m4| |n4|)) + (SPADLET |$ElementList| + '(|x| |y| |z| |u| |v| |w| |x1| |y1| |z1| |u1| + |v1| |w1| |x2| |y2| |z2| |u2| |v2| |w2| + |x3| |y3| |z3| |u3| |v3| |w3| |x4| |y4| + |z4| |u4| |v4| |w4|)) + (SPADLET |$FunctionList| '(|f| |g| |h| |d| |e| F G H)) + (SPADLET |$DomainList| '(D R S E T A B C M N P Q U V W)) + (SPADLET |exactlyOneOpSig| (NULL |index|)) + (SPADLET |conform| + (OR (|htpProperty| |htPage| '|domname|) + (|htpProperty| |htPage| '|conform|) |origin|)) + (COND + (|$generalSearch?| + (SPADLET |$DomainList| (CDR |$DomainList|)))) + (SPADLET |opform| + (COND + ((BOOT-EQUAL |which| (MAKESTRING "attribute")) + (COND + ((NULL |sig|) (CONS |op| NIL)) + ('T (CONS |op| (CONS |sig| NIL))))) + ((BOOT-EQUAL |which| + (MAKESTRING "constructor")) + |origin|) + ('T (|dbGetDisplayFormForOp| |op| |sig| |doc|)))) + (|htSayStandard| (MAKESTRING "\\newline")) + (|htSaySaturn| (MAKESTRING "\\item[")) + (COND + (|exactlyOneOpSig| (|htSay| (|menuButton|))) + ('T + (|htMakePage| + (CONS (CONS '|bcLinks| + (CONS (CONS (|menuButton|) + (CONS (MAKESTRING "") + (CONS |chooseFn| + (CONS |which| + (CONS |index| NIL))))) + NIL)) + NIL)))) + (|htSaySaturn| (MAKESTRING "]")) + (|htSayStandard| (MAKESTRING "\\tab{2}")) + (SPADLET |op| (IFCAR |opform|)) + (SPADLET |args| (IFCDR |opform|)) + (SPADLET |ops| (|escapeSpecialChars| (STRINGIMAGE |op|))) + (SPADLET |n| (|#| |sig|)) + (|do| (COND + ((AND (EQL |n| 2) (LASSOC '|Nud| (PROPLIST |op|))) + (|htSay| |ops| (MAKESTRING " {\\em ") + (|quickForm2HtString| (KAR |args|)) + (MAKESTRING "}"))) + ((AND (EQL |n| 3) (LASSOC '|Led| (PROPLIST |op|))) + (|htSay| (MAKESTRING "{\\em ") + (|quickForm2HtString| (KAR |args|)) + (MAKESTRING "} ") |ops| + (MAKESTRING " {\\em ") + (|quickForm2HtString| + (KAR (KDR |args|))) + (MAKESTRING "}"))) + ('T + (COND + ((AND |unexposed?| |$includeUnexposed?|) + (|htSayUnexposed|))) + (|htSay| |ops|) + (COND + ((OR (BOOT-EQUAL |predicate| 'ASCONST) + (GETDATABASE |op| 'NILADIC) + (|member| |op| '(0 1))) + '|skip|) + ((AND (BOOT-EQUAL |which| + (MAKESTRING "attribute")) + (NULL |args|)) + '|skip|) + ('T (|htSay| (MAKESTRING "(")) + (COND + ((IFCAR |args|) + (|htSay| (MAKESTRING "{\\em ") + (|quickForm2HtString| + (IFCAR |args|)) + (MAKESTRING "}")))) + (DO ((G179480 (IFCDR |args|) + (CDR G179480)) + (|x| NIL)) + ((OR (ATOM G179480) + (PROGN + (SETQ |x| (CAR G179480)) + NIL)) + NIL) + (SEQ (EXIT (|htSay| (MAKESTRING ",{\\em ") + (|quickForm2HtString| |x|) + (MAKESTRING "}"))))) + (|htSay| (MAKESTRING ")"))))))) + (SPADLET |constring| (|form2HtString| |conform|)) + (SPADLET |conname| (CAR |conform|)) + (SPADLET |$conkind| + (OR (|htpProperty| |htPage| '|kind|) + (STRINGIMAGE + (GETDATABASE |conname| 'CONSTRUCTORKIND)))) + (SPADLET |$conlength| (|#| |constring|)) + (SPADLET |$conform| |conform|) + (SPADLET |$conargs| (CDR |conform|)) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "operation")) + (SPADLET |$signature| + (COND + ((MEMQ |conname| |$Primitives|) NIL) + ('T + (CDAR (|getConstructorModemap| |conname|))))) + (SPADLET |tvarlist| + (TAKE (|#| |$conargs|) + |$TriangleVariableList|)) + (SPADLET |$signature| + (SUBLISLIS |$FormalMapVariableList| |tvarlist| + |$signature|)))) + (SPADLET |$sig| + (COND + ((OR (BOOT-EQUAL |which| + (MAKESTRING "attribute")) + (BOOT-EQUAL |which| + (MAKESTRING "constructor"))) + |sig|) + ((NEQUAL |$conkind| (MAKESTRING "package")) + |sig|) + ('T + (SPADLET |symbolsUsed| + (PROG (G179491) + (SPADLET G179491 NIL) + (RETURN + (DO + ((G179497 (CDR |conform|) + (CDR G179497)) + (|x| NIL)) + ((OR (ATOM G179497) + (PROGN + (SETQ |x| (CAR G179497)) + NIL)) + (NREVERSE0 G179491)) + (SEQ + (EXIT + (COND + ((IDENTP |x|) + (SETQ G179491 + (CONS |x| G179491)))))))))) + (SPADLET |$DomainList| + (SETDIFFERENCE |$DomainList| + |symbolsUsed|)) + (|getSubstSigIfPossible| |sig|)))) + (|htSaySaturn| (MAKESTRING "\\begin{tabular}{lp{0in}}")) + (COND + ((|member| |which| '("operation" "constructor")) + (SPADLET |$displayReturnValue| NIL) + (COND + (|args| (|htSayStandard| + (MAKESTRING + "\\newline\\tab{2}{\\em Arguments:}")) + (|htSaySaturn| + (MAKESTRING "{\\em Arguments:}")) + (|htSaySaturnAmpersand|) + (SPADLET |firstTime| 'T) + (SPADLET |coSig| + (KDR (GETDATABASE |op| 'COSIG))) + (DO ((G179518 |args| (CDR G179518)) + (|a| NIL) + (G179519 (CDR |$sig|) (CDR G179519)) + (|t| NIL)) + ((OR (ATOM G179518) + (PROGN + (SETQ |a| (CAR G179518)) + NIL) + (ATOM G179519) + (PROGN + (SETQ |t| (CAR G179519)) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL |firstTime|) + (|htSaySaturn| + (MAKESTRING "\\\\ ")) + (|htSaySaturnAmpersand|))) + (SPADLET |firstTime| NIL) + (|htSayIndentRel| 15 'T) + (SPADLET |position| + (KAR |relatives|)) + (SPADLET |relatives| + (KDR |relatives|)) + (COND + ((AND (KAR |coSig|) + (NEQUAL |t| '(|Type|))) + (|htMakePage| + (CONS + (CONS '|bcLinks| + (CONS + (CONS |a| + (CONS (MAKESTRING "") + (CONS '|kArgPage| + (CONS |a| NIL)))) + NIL)) + NIL))) + ('T + (|htSay| + (MAKESTRING "{\\em ") + (|form2HtString| |a|) + (MAKESTRING "}")))) + (|htSay| '|, |) + (SPADLET |coSig| + (KDR |coSig|)) + (|htSayValue| |t|) + (|htSayIndentRel| + (SPADDIFFERENCE 15) 'T) + (|htSayStandard| + (MAKESTRING "\\newline ")))))) + (|htSaySaturn| (MAKESTRING "\\\\")))) + (COND + ((CAR |$sig|) (SPADLET |$displayReturnValue| 'T) + (|htSayStandard| (MAKESTRING "\\newline\\tab{2}")) + (|htSay| (MAKESTRING "{\\em Returns:}")) + (|htSaySaturnAmpersand|) (|htSayIndentRel| 15 'T) + (|htSayValue| (CAR |$sig|)) + (|htSayIndentRel| (SPADDIFFERENCE 15) 'T) + (|htSaySaturn| (MAKESTRING "\\\\"))) + ('T NIL)))) + (COND + ((AND |origin| + (OR |$generalSearch?| (NEQUAL |origin| |conform|)) + (NEQUAL |op| (|opOf| |origin|))) + (|htSaySaturn| (MAKESTRING "{\\em Origin:}")) + (|htSaySaturnAmpersand|) + (|htSayStandard| + (MAKESTRING "\\newline\\tab{2}{\\em Origin:}")) + (|htSayIndentRel| 15) + (COND + ((AND (NULL (|isExposedConstructor| + (|opOf| |origin|))) + |$includeUnexposed?|) + (|htSayUnexposed|))) + (|bcConform| |origin| 'T) + (|htSayIndentRel| (SPADDIFFERENCE 15)) + (|htSaySaturn| (MAKESTRING "\\\\")))) + (COND + ((NULL (MEMQ |predicate| '(T ASCONST))) + (SPADLET |pred| + (|sublisFormal| (KDR |conform|) |predicate|)) + (SPADLET |count| (|#| |pred|)) + (|htSaySaturn| (MAKESTRING "{\\em Conditions:}")) + (|htSayStandard| + (MAKESTRING "\\newline\\tab{2}{\\em Conditions:}")) + (SPADLET |firstTime| 'T) + (DO ((G179538 + (|displayBreakIntoAnds| + (MSUBST |$conform| '$ |pred|)) + (CDR G179538)) + (|p| NIL)) + ((OR (ATOM G179538) + (PROGN (SETQ |p| (CAR G179538)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((NULL |firstTime|) + (|htSaySaturn| (MAKESTRING "\\\\")))) + (|htSayIndentRel| 15 (> |count| 1)) + (SPADLET |firstTime| NIL) + (|htSaySaturnAmpersand|) + (|bcPred| |p| |$conform| 'T) + (|htSayIndentRel| (SPADDIFFERENCE 15) + (> |count| 1)) + (|htSayStandard| + (MAKESTRING "\\newline ")))))) + (|htSaySaturn| (MAKESTRING "\\\\")))) + (COND + (|$whereList| (SPADLET |count| (|#| |$whereList|)) + (|htSaySaturn| (MAKESTRING "{\\em Where:}")) + (|htSayStandard| + (MAKESTRING "\\newline\\tab{2}{\\em Where:}")) + (SPADLET |firstTime| 'T) + (COND + ((|assoc| '$ |$whereList|) + (|htSayIndentRel| 15 'T) (|htSaySaturnAmpersand|) + (|htSayStandard| (MAKESTRING "{\\em \\$} is ")) + (|htSaySaturn| (MAKESTRING "{\\em \\%} is ")) + (|htSay| (COND + ((BOOT-EQUAL |$conkind| + (MAKESTRING "category")) + (MAKESTRING "of category ")) + ('T (MAKESTRING "the domain ")))) + (|bcConform| |conform| 'T 'T) + (SPADLET |firstTime| NIL) + (|htSayIndentRel| (SPADDIFFERENCE 15) 'T))) + (DO ((G179556 |$whereList| (CDR G179556)) + (G179464 NIL)) + ((OR (ATOM G179556) + (PROGN + (SETQ G179464 (CAR G179556)) + NIL) + (PROGN + (PROGN + (SPADLET |d| (CAR G179464)) + (SPADLET |key| (CADR G179464)) + (SPADLET |t| (CDDR G179464)) + G179464) + NIL)) + NIL) + (SEQ (EXIT (COND + ((NEQUAL |d| '$) + (PROGN + (|htSayIndentRel| 15 + (> |count| 1)) + (COND + ((NULL |firstTime|) + (|htSaySaturn| + (MAKESTRING "\\\\ ")))) + (|htSaySaturnAmpersand|) + (SPADLET |firstTime| NIL) + (|htSay| '|{\\em | |d| '|} is |) + (|htSayConstructor| |key| + (|sublisFormal| (KDR |conform|) + |t|)) + (|htSayIndentRel| + (SPADDIFFERENCE 15) + (> |count| 1)))))))) + (|htSaySaturn| (MAKESTRING "\\\\")))) + (COND + ((AND |doc| (NEQUAL |doc| (MAKESTRING "")) + (OR (NULL (AND (PAIRP |doc|) (EQ (QCDR |doc|) NIL) + (PROGN + (SPADLET |d| (QCAR |doc|)) + 'T))) + (NEQUAL |d| (MAKESTRING "")))) + (|htSaySaturn| (MAKESTRING "{\\em Description:}")) + (|htSaySaturnAmpersand|) + (|htSayStandard| + (MAKESTRING "\\newline\\tab{2}{\\em Description:}")) + (|htSayIndentRel| 15) + (COND + ((BOOT-EQUAL |doc| |$charFauxNewline|) + (|htSay| |$charNewline|)) + ('T + (SPADLET |ndoc| + (COND + ((CONSP |doc|) + (PROG (G179567) + (SPADLET G179567 NIL) + (RETURN + (DO + ((G179572 |doc| (CDR G179572)) + (|i| NIL)) + ((OR (ATOM G179572) + (PROGN + (SETQ |i| (CAR G179572)) + NIL)) + (NREVERSE0 G179567)) + (SEQ + (EXIT + (SETQ G179567 + (CONS + (SUBSTITUTE |$charNewline| + |$charFauxNewline| |i|) + G179567)))))))) + ('T + (SUBSTITUTE |$charNewline| + |$charFauxNewline| |doc|)))) + (|htSay| |ndoc|))) + (|htSayIndentRel| (SPADDIFFERENCE 15)))) + (COND + ((BOOT-EQUAL |which| (MAKESTRING "constructor")) + (COND + ((SPADLET |abbr| + (GETDATABASE |conname| 'ABBREVIATION)) + (|htSaySaturn| (MAKESTRING "\\\\")) + (|htSaySaturn| (MAKESTRING "{\\em Abbreviation:}")) + (|htSaySaturnAmpersand|) + (|htSayStandard| + (MAKESTRING "\\tab{2}{\\em Abbreviation:}")) + (|htSayIndentRel| 15) (|htSay| |abbr|) + (|htSayIndentRel| (SPADDIFFERENCE 15)) + (|htSayStandard| (MAKESTRING "\\newline{}")))) + (COND + ((AND |$saturn| + (SPADLET |link| + (|saturnHasExamplePage| |conname|))) + (|htSaySaturn| (MAKESTRING "\\\\")) + (|htSaySaturn| (MAKESTRING "{\\em Examples:}")) + (|htSaySaturnAmpersand|) (|htSayIndentRel| 15) + (|htSay| (MAKESTRING "\\spadref{")) + (|htSay| (CAR (CDR |link|))) + (|htSay| (MAKESTRING "}")) + (|htSayIndentRel| (SPADDIFFERENCE 15)) + (|htSayStandard| (MAKESTRING "\\newline{}")))) + (|htSaySaturn| (MAKESTRING "\\\\")) + (|htSaySaturn| (MAKESTRING "{\\em Source File:}")) + (|htSaySaturnAmpersand|) + (|htSayStandard| + (MAKESTRING "\\tab{2}{\\em Source File:}")) + (|htSayIndentRel| 15) (|htSaySourceFile| |conname|) + (|htSayIndentRel| (SPADDIFFERENCE 15)))) + (COND + ((AND |$standard| |exactlyOneOpSig| + (SPADLET |infoAlist| + (|htpProperty| |htPage| '|infoAlist|))) + (|displayInfoOp| |htPage| |infoAlist| |op| |sig|))) + (|htSaySaturn| (MAKESTRING "\\end{tabular}"))))))) + +;htSaySourceFile conname == +; sourceFileName := (GETDATABASE(conname,'SOURCEFILE) or '"none") +; filename := extractFileNameFromPath sourceFileName +; htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", +; sourceFileName, '" ", conname, '"}"]] + +(DEFUN |htSaySourceFile| (|conname|) + (PROG (|sourceFileName| |filename|) + (RETURN + (PROGN + (SPADLET |sourceFileName| + (OR (GETDATABASE |conname| 'SOURCEFILE) + (MAKESTRING "none"))) + (SPADLET |filename| + (|extractFileNameFromPath| |sourceFileName|)) + (|htMakePage| + (CONS (CONS '|text| + (CONS (MAKESTRING "\\unixcommand{") + (CONS |filename| + (CONS + (MAKESTRING + "}{\\$AXIOM/lib/SPADEDIT ") + (CONS |sourceFileName| + (CONS (MAKESTRING " ") + (CONS |conname| + (CONS (MAKESTRING "}") NIL)))))))) + NIL)))))) + +;--------------------> NEW DEFINITION (see br-op2.boot.pamphlet) +;htSayIndentRel(n,:options) == +; flag := IFCAR options +; m := ABSVAL n +; if flag then m := m + 2 +; if $standard then htSayStandard +; n > 0 => +; flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] +; ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] +; n < 0 => ['"\indent{0}\newline "] + +(DEFUN |htSayIndentRel| (&REST G179673 &AUX |options| |n|) + (DSETQ (|n| . |options|) G179673) + (PROG (|flag| |m|) + (declare (special |$standard|)) + (RETURN + (PROGN + (SPADLET |flag| (IFCAR |options|)) + (SPADLET |m| (ABSVAL |n|)) + (COND (|flag| (SPADLET |m| (PLUS |m| 2)))) + (COND + (|$standard| + (|htSayStandard| + (COND + ((> |n| 0) + (COND + (|flag| (CONS (MAKESTRING "\\indent{") + (CONS (STRINGIMAGE |m|) + (CONS (MAKESTRING "}\\tab{-2}") + NIL)))) + ('T + (CONS (MAKESTRING "\\indent{") + (CONS (STRINGIMAGE |m|) + (CONS (MAKESTRING "}\\tab{0}") NIL)))))) + ((MINUSP |n|) + (CONS (MAKESTRING "\\indent{0}\\newline ") NIL))))) + ('T NIL)))))) + +;htSayUnexposed() == +; htSay '"{\em *}" +; $atLeastOneUnexposed := true + +(DEFUN |htSayUnexposed| () + (declare (special |$atLeastOneUnexposed|)) + (PROGN + (|htSay| (MAKESTRING "{\\em *}")) + (SPADLET |$atLeastOneUnexposed| 'T))) + +;--======================================================================= +;-- Page Operations +;--======================================================================= +;htEndTabular() == +; htSaySaturn '"\end{tabular}" + +(DEFUN |htEndTabular| () + (|htSaySaturn| (MAKESTRING "\\end{tabular}"))) + +;htPopSaturn s == +; pageDescription := ELT($saturnPage, 7) +; pageDescription is [=s,:b] => SETELT($saturnPage, 7, CDR pageDescription) +; nil + +(DEFUN |htPopSaturn| (|s|) + (PROG (|pageDescription| |b|) + (declare (special |$saturnPage|)) + (RETURN + (PROGN + (SPADLET |pageDescription| (ELT |$saturnPage| 7)) + (COND + ((AND (PAIRP |pageDescription|) + (EQUAL (QCAR |pageDescription|) |s|) + (PROGN (SPADLET |b| (QCDR |pageDescription|)) 'T)) + (SETELT |$saturnPage| 7 (CDR |pageDescription|))) + ('T NIL)))))) + +;htBeginTable() == +; htSaySaturn '"\begin{dirlist}[lv]" +; htSayStandard '"\table{" + +(DEFUN |htBeginTable| () + (PROGN + (|htSaySaturn| (MAKESTRING "\\begin{dirlist}[lv]")) + (|htSayStandard| (MAKESTRING "\\table{")))) + +;htEndTable() == +; htSaySaturn '"\end{dirlist}" +; htSayStandard '"}" + +(DEFUN |htEndTable| () + (PROGN + (|htSaySaturn| (MAKESTRING "\\end{dirlist}")) + (|htSayStandard| (MAKESTRING "}")))) + +;htBeginMenu(kind,:options) == +; skip := IFCAR options +; if $saturn then +; kind = 'description => htSaySaturn '"\begin{description}" +; htSaySaturn '"\begin{tabular}" +; htSaySaturn +; kind = 3 => '"{llp{0in}}" +; kind = 2 => '"{lp{0in}}" +; error nil +; null skip => htSayStandard '"\beginmenu " +; nil + +(DEFUN |htBeginMenu| (&REST G179703 &AUX |options| |kind|) + (DSETQ (|kind| . |options|) G179703) + (PROG (|skip|) + (declare (special |$saturn|)) + (RETURN + (PROGN + (SPADLET |skip| (IFCAR |options|)) + (COND + (|$saturn| + (COND + ((BOOT-EQUAL |kind| '|description|) + (|htSaySaturn| (MAKESTRING "\\begin{description}"))) + ('T (|htSaySaturn| (MAKESTRING "\\begin{tabular}")) + (|htSaySaturn| + (COND + ((EQL |kind| 3) (MAKESTRING "{llp{0in}}")) + ((EQL |kind| 2) (MAKESTRING "{lp{0in}}")) + ('T (|error| NIL)))))))) + (COND + ((NULL |skip|) (|htSayStandard| (MAKESTRING "\\beginmenu "))) + ('T NIL)))))) + +;htEndMenu(kind) == +; if $saturn then +; kind = 'description => htSaySaturn '"\end{description}" +; htPopSaturn '"\\" +; htSaySaturn '"\end{tabular}" +; htSayStandard '"\endmenu " + +(DEFUN |htEndMenu| (|kind|) + (declare (special |$saturn|)) + (PROGN + (COND + (|$saturn| + (COND + ((BOOT-EQUAL |kind| '|description|) + (|htSaySaturn| (MAKESTRING "\\end{description}"))) + ('T (|htPopSaturn| (MAKESTRING "\\\\")) + (|htSaySaturn| (MAKESTRING "\\end{tabular}")))))) + (|htSayStandard| (MAKESTRING "\\endmenu ")))) + +;htSayConstructorName(nameShown, name) == +; if $saturn then +; code := ['"(|conPage| '|", name, '"|)"] +; htSaySaturn mkDocLink(code,nameShown) +; if $standard then +; htSayStandard ["\lispdownlink{",nameShown,'"}{(|conPage| '|",name,'"|)}"] + +(DEFUN |htSayConstructorName| (|nameShown| |name|) + (PROG (|code|) + (declare (special |$standard| |$saturn|)) + (RETURN + (PROGN + (COND + (|$saturn| + (SPADLET |code| + (CONS (MAKESTRING "(|conPage| '|") + (CONS |name| (CONS (MAKESTRING "|)") NIL)))) + (|htSaySaturn| (|mkDocLink| |code| |nameShown|)))) + (COND + (|$standard| + (|htSayStandard| + (CONS '|\\lispdownlink{| + (CONS |nameShown| + (CONS (MAKESTRING "}{(|conPage| '|") + (CONS |name| + (CONS (MAKESTRING "|)}") NIL))))))) + ('T NIL)))))) + +;--------------------> NEW DEFINITION (see ht-util.boot.pamphlet) +;htAddHeading(title) == +; htNewPage title +; page() + +(DEFUN |htAddHeading| (|title|) + (PROGN (|htNewPage| |title|) (|page|))) + +;------------> called by htAddHeading, htInitPageNoScroll <----------- +;htNewPage title == +; if $saturn then +; htSaySaturn '"\browseTitle{" +; htSaySaturn title +; htSaySaturn '"}" +; if $standard then htSayStandard('"\begin{page}{", htpName $curPage, '"}{") +; htSayStandard title +; htSayStandard '"}" + +(DEFUN |htNewPage| (|title|) + (declare (special |$saturn| |$curPage| |$standard|)) + (PROGN + (COND + (|$saturn| (|htSaySaturn| (MAKESTRING "\\browseTitle{")) + (|htSaySaturn| |title|) (|htSaySaturn| (MAKESTRING "}")))) + (COND + (|$standard| + (|htSayStandard| (MAKESTRING "\\begin{page}{") + (|htpName| |$curPage|) (MAKESTRING "}{")))) + (|htSayStandard| |title|) + (|htSayStandard| (MAKESTRING "}")))) + +;--======================================================================= +;-- Utilities +;--======================================================================= +;mkTabularItem u == [:first u,:fn rest u] where fn x == +; null x => nil +; [$saturnAmpersand, x,:fn rest x] + +(DEFUN |mkTabularItem,fn| (|x|) + (declare (special |$saturnAmpersand|)) + (SEQ (IF (NULL |x|) (EXIT NIL)) + (EXIT (CONS |$saturnAmpersand| + (CONS |x| (|mkTabularItem,fn| (CDR |x|))))))) + +(DEFUN |mkTabularItem| (|u|) + (APPEND (CAR |u|) (|mkTabularItem,fn| (CDR |u|)))) + +;htSaySaturnAmpersand() == htSaySaturn $saturnAmpersand + +(DEFUN |htSaySaturnAmpersand| () + (declare (special |$saturnAmpersand|)) + (|htSaySaturn| |$saturnAmpersand|)) + +;htBlank(:options) == +; options is [n] => +; htSaySaturn("STRCONC"/['"\phantom{*}" for i in 1..n]) +; htSayStandard STRCONC('"\space{",STRINGIMAGE n,'"}") +; htSaySaturn '"\phantom{*}" +; htSayStandard '"\space{1}" + +(DEFUN |htBlank| (&REST G179750 &AUX |options|) + (DSETQ |options| G179750) + (PROG (|n|) + (RETURN + (SEQ (COND + ((AND (PAIRP |options|) (EQ (QCDR |options|) NIL) + (PROGN (SPADLET |n| (QCAR |options|)) 'T)) + (|htSaySaturn| + (PROG (G179737) + (SPADLET G179737 "") + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |n|) G179737) + (SEQ (EXIT (SETQ G179737 + (STRCONC G179737 + (MAKESTRING "\\phantom{*}"))))))))) + (|htSayStandard| + (STRCONC (MAKESTRING "\\space{") (STRINGIMAGE |n|) + (MAKESTRING "}")))) + ('T (|htSaySaturn| (MAKESTRING "\\phantom{*}")) + (|htSayStandard| (MAKESTRING "\\space{1}")))))))) + +;unTab s == +; STRINGP s => unTab1 s +; atom s => s +; [unTab1 first s, :rest s] + +(DEFUN |unTab| (|s|) + (COND + ((STRINGP |s|) (|unTab1| |s|)) + ((ATOM |s|) |s|) + ('T (CONS (|unTab1| (CAR |s|)) (CDR |s|))))) + +;unTab1 s == +; STRING_<('"\tab{", s) = 5 and (k := charPosition(char '_}, s, 4)) => +; SUBSTRING(s, k + 1, nil) +; s + +(DEFUN |unTab1| (|s|) + (PROG (|k|) + (RETURN + (COND + ((AND (EQL (STRING< (MAKESTRING "\\tab{") |s|) 5) + (SPADLET |k| (|charPosition| (|char| '}) |s| 4))) + (SUBSTRING |s| (PLUS |k| 1) NIL)) + ('T |s|))))) + +;satBreak() == +; htSaySaturn '"\\ " +; htSayStandard '"\item " + +(DEFUN |satBreak| () + (PROGN + (|htSaySaturn| (MAKESTRING "\\\\ ")) + (|htSayStandard| (MAKESTRING "\\item ")))) + +;htBigSkip() == +; htSaySaturn '"\bigskip{}" +; htSayStandard '"\vspace{1}\newline " + +(DEFUN |htBigSkip| () + (PROGN + (|htSaySaturn| (MAKESTRING "\\bigskip{}")) + (|htSayStandard| (MAKESTRING "\\vspace{1}\\newline ")))) + +;htSaturnBreak() == htSaySaturn '"\!" + +(DEFUN |htSaturnBreak| () (|htSaySaturn| (MAKESTRING "\\!"))) + +;satDownLink(s,code) == +; htSaySaturn '"\lispFunctionLink{\verb!" +; htSaySaturn code +; htSaySaturn '"!}{" +; htSaySaturn s +; htSaySaturn '"}" +; ------------------ +; htSayStandard '"\lispdownlink{" +; htSayStandard s +; htSayStandard '"}{" +; htSayStandard code +; htSayStandard '"}" + +(DEFUN |satDownLink| (|s| |code|) + (PROGN + (|htSaySaturn| (MAKESTRING "\\lispFunctionLink{\\verb!")) + (|htSaySaturn| |code|) + (|htSaySaturn| (MAKESTRING "!}{")) + (|htSaySaturn| |s|) + (|htSaySaturn| (MAKESTRING "}")) + (|htSayStandard| (MAKESTRING "\\lispdownlink{")) + (|htSayStandard| |s|) + (|htSayStandard| (MAKESTRING "}{")) + (|htSayStandard| |code|) + (|htSayStandard| (MAKESTRING "}")))) + +;satTypeDownLink(s,code) == +; htSaySaturn '"\lispLink[d]{\verb!" +; htSaySaturn code +; htSaySaturn '"!}{" +; htSaySaturn s +; htSaySaturn '"}" +; ------------------ +; htSayStandard '"\lispdownlink{" +; htSayStandard s +; htSayStandard '"}{" +; htSayStandard code +; htSayStandard '"}" + +(DEFUN |satTypeDownLink| (|s| |code|) + (PROGN + (|htSaySaturn| (MAKESTRING "\\lispLink[d]{\\verb!")) + (|htSaySaturn| |code|) + (|htSaySaturn| (MAKESTRING "!}{")) + (|htSaySaturn| |s|) + (|htSaySaturn| (MAKESTRING "}")) + (|htSayStandard| (MAKESTRING "\\lispdownlink{")) + (|htSayStandard| |s|) + (|htSayStandard| (MAKESTRING "}{")) + (|htSayStandard| |code|) + (|htSayStandard| (MAKESTRING "}")))) + +;mkButtonBox n == STRCONC('"\buttonbox{", STRINGIMAGE n, '"}") + +(DEFUN |mkButtonBox| (|n|) + (STRCONC (MAKESTRING "\\buttonbox{") (STRINGIMAGE |n|) + (MAKESTRING "}"))) + +;--======================================================================= +;-- Create separate databases for operations, constructors +;--======================================================================= +;-----------> use br-data.boot definition +;--dbSplitLibdb() == +;--This function splits lidbd.text into files to make searching quicker. +;-- alibdb.text attributes +;-- clibdb.text categories +;-- dlibdb.text domains +;-- plibdb.text packages +;-- olibdb.text operations +;-- xlibdb.text default packages +;--These files have the same format as the single file libdb.text did in old +;-- version: e.g. `````` +;-- for constructors where is a single character, one of acdopx +;-- (identifying it as an attribute, category, domain, operator, package, +;-- or default package), its name, number of arguments, whether exposed or +;-- unexposed, its signature (sometimes abbreviated), its arguments as given +;-- in the original definition, its abbreviation, and documentation. +;-- For example, domain Matrix has line "dMatrix`1`x``(R)`MATRIX`" +;-- where is "(Ring)->Join(MatrixCategory(R,Vector(R),Vector(R)),etc)". +;-- The comment field contains the character address of the comments +;-- for Matrix in file comdb.text. +;--There is thus ONE file comdb.text for documentation of all structures +;-- (to facilitate a general search through all documentation) +;-- into for comments. The format of entries in comdb.text are lines with +;-- two fields of the form d`, where is the character +;-- address of the line "dMatrix`.." in dlibdb.text (the first character +;-- "d" tells which lidbdb file it comes from, the is the +;-- documentation for Matrix. +;--NOTE: In each file, the first character, one of acdpox, is retained +;-- so that lines have the same format as the previous version of the browser +;-- (this minimized the number of lines of code that had to be changed from +;-- previous version of the browser). +;-- key := nil --dummy first key +;-- instream := MAKE_-INSTREAM '"libdb.text" +;-- comstream := MAKE_-OUTSTREAM '"comdb.text" +;-- PRINTEXP(0, comstream) +;-- PRINTEXP($tick,comstream) +;-- PRINTEXP('"", comstream) +;-- TERPRI(comstream) +;-- while not EOFP instream repeat +;-- line := READLINE instream +;-- comP := FILE_-POSITION comstream +;-- if key ^= line.0 then +;-- if outstream then SHUT outstream +;-- key := line . 0 +;-- outstream := MAKE_-OUTSTREAM STRCONC(STRINGIMAGE key,'"libdb.text") +;-- outP := FILE_-POSITION outstream +;-- [prefix,:comments] := dbSplit(line,6,1) +;-- PRINTEXP(prefix,outstream) +;-- PRINTEXP($tick ,outstream) +;-- null comments => +;-- PRINTEXP(0,outstream) +;-- TERPRI(outstream) +;-- PRINTEXP(comP,outstream) +;-- TERPRI(outstream) +;-- PRINTEXP(key, comstream) --identifies file the backpointer is to +;-- PRINTEXP(outP ,comstream) +;-- PRINTEXP($tick ,comstream) +;-- PRINTEXP(first comments,comstream) +;-- TERPRI(comstream) +;-- for c in rest comments repeat +;-- PRINTEXP(key, comstream) --identifies file the backpointer is to +;-- PRINTEXP(outP ,comstream) +;-- PRINTEXP($tick ,comstream) +;-- PRINTEXP(c, comstream) +;-- TERPRI(comstream) +;-- SHUT instream +;-- SHUT outstream +;-- SHUT comstream +;--OBEY '"rm libdb.text" +;dbSort(x,y) == +; sin := STRINGIMAGE x +; sout:= STRINGIMAGE y +; OBEY STRCONC('"sort -f _"",sin,'".text_" > _"", sout, '".text_"") +; OBEY STRCONC('"rm ", sin, '".text") + +(DEFUN |dbSort| (|x| |y|) + (PROG (|sin| |sout|) + (RETURN + (PROGN + (SPADLET |sin| (STRINGIMAGE |x|)) + (SPADLET |sout| (STRINGIMAGE |y|)) + (OBEY (STRCONC (MAKESTRING "sort -f \"") |sin| + (MAKESTRING ".text\" > \"") |sout| + (MAKESTRING ".text\""))) + (OBEY (STRCONC (MAKESTRING "rm ") |sin| (MAKESTRING ".text"))))))) + +;--======================================================================= +;-- from define.boot +;--======================================================================= +;----------------------> (override in define.boot.pamphlet) +;compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], +; m,oldE,$prefix,$formalArgList) == +; [lineNumber,:specialCases] := specialCases +; e := oldE +; --1. bind global variables +; $form: local := nil +; $op: local := nil +; $functionStats: local:= [0,0] +; $argumentConditionList: local := nil +; $finalEnv: local := nil +; --used by ReplaceExitEtc to get a common environment +; $initCapsuleErrorCount: local:= #$semanticErrorStack +; $insideCapsuleFunctionIfTrue: local:= true +; $CapsuleModemapFrame: local:= e +; $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) +; $insideExpressionIfTrue: local:= true +; $returnMode:= m +; [$op,:argl]:= form +; $form:= [$op,:argl] +; argl:= stripOffArgumentConditions argl +; $formalArgList:= [:argl,:$formalArgList] +; --let target and local signatures help determine modes of arguments +; argModeList:= +; identSig:= hasSigInTargetCategory(argl,form,first signature,e) => +; (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) +; [getArgumentModeOrMoan(a,form,e) for a in argl] +; argModeList:= stripOffSubdomainConditions(argModeList,argl) +; signature':= [first signature,:argModeList] +; if null identSig then --make $op a local function +; oldE := put($op,'mode,['Mapping,:signature'],oldE) +; --obtain target type if not given +; if null first signature' then signature':= +; identSig => identSig +; getSignature($op,rest signature',e) or return nil +; --replace ##1,.. in signature by arguments +;-- pp signature' +; signature':= SUBLISLIS(argl,$FormalFunctionParameterList,signature') +;-- pp '"------after----" +;-- pp signature' +; e:= giveFormalParametersValues(argl,e) +; $signatureOfForm:= signature' --this global is bound in compCapsuleItems +; $functionLocations := [[[$op,$signatureOfForm],:lineNumber], +; :$functionLocations] +; e:= addDomain(first signature',e) +; e:= compArgumentConditions e +; if $profileCompiler then +; for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) +; --4. introduce needed domains into extendedEnv +; for domain in signature' repeat e:= addDomain(domain,e) +; --6. compile body in environment with extended environment +; rettype:= resolve(signature'.target,$returnMode) +; localOrExported := +; null MEMBER($op,$formalArgList) and +; getmode($op,e) is ['Mapping,:.] => 'local +; 'exported +; --6a skip if compiling only certain items but not this one +; -- could be moved closer to the top +; formattedSig := formatUnabbreviated ['Mapping,:signature'] +; $compileOnlyCertainItems and _ +; not MEMBER($op, $compileOnlyCertainItems) => +; sayBrightly ['" skipping ", localOrExported,:bright $op] +; [nil,['Mapping,:signature'],oldE] +; sayBrightly ['" compiling ",localOrExported, +; :bright $op,'": ",:formattedSig] +; if $newComp = true then +; wholeBody := ['DEF, form, signature', specialCases, body] +; T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) +; or [" ",rettype,e] +; T := [T.expr.2.2, rettype, T.env] +; if $newCompCompare=true then +; oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) +; or [" ",rettype,e] +; SAY '"The old compiler generates:" +; prTriple oldT +; SAY '"The new compiler generates:" +; prTriple T +; else +; T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) +; or [" ",rettype,e] +;--+ +; NRTassignCapsuleFunctionSlot($op,signature') +; if $newCompCompare=true then +; SAY '"The old compiler generates:" +; prTriple T +;-- A THROW to the above CATCH occurs if too many semantic errors occur +;-- see stackSemanticError +; catchTag:= MKQ GENSYM() +; fun:= +; body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) +; body':= addArgumentConditions(body',$op) +; finalBody:= ["CATCH",catchTag,body'] +; compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) +; $functorStats:= addStats($functorStats,$functionStats) +;-- 7. give operator a 'value property +; val:= [fun,signature',e] +; [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) + +(DEFUN |compDefineCapsuleFunction| + (|df| |m| |oldE| |$prefix| |$formalArgList|) + (DECLARE (SPECIAL |$prefix| |$formalArgList| |$FormalFunctionParameterList| + |$signatureOfForm| |$functionLocations| |$profileCompiler| + |$functorStats|)) + (PROG (|$form| |$op| |$functionStats| |$argumentConditionList| + |$finalEnv| |$initCapsuleErrorCount| + |$insideCapsuleFunctionIfTrue| |$CapsuleModemapFrame| + |$CapsuleDomainsInScope| |$insideExpressionIfTrue| + |form| |signature| |body| |LETTMP#1| |lineNumber| + |specialCases| |argl| |identSig| |argModeList| + |signature'| |e| |rettype| |ISTMP#1| |localOrExported| + |formattedSig| |wholeBody| |oldT| T$ |catchTag| + |body'| |finalBody| |fun| |val|) + (DECLARE (SPECIAL |$form| |$op| |$functionStats| + |$argumentConditionList| |$finalEnv| + |$initCapsuleErrorCount| + |$insideCapsuleFunctionIfTrue| + |$CapsuleModemapFrame| |$CapsuleDomainsInScope| + |$insideExpressionIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CADR |df|)) + (SPADLET |signature| (CADDR |df|)) + (SPADLET |specialCases| (CADDDR |df|)) + (SPADLET |body| (CAR (CDDDDR |df|))) + (SPADLET |LETTMP#1| |specialCases|) + (SPADLET |lineNumber| (CAR |LETTMP#1|)) + (SPADLET |specialCases| (CDR |LETTMP#1|)) + (SPADLET |e| |oldE|) + (SPADLET |$form| NIL) + (SPADLET |$op| NIL) + (SPADLET |$functionStats| (CONS 0 (CONS 0 NIL))) + (SPADLET |$argumentConditionList| NIL) + (SPADLET |$finalEnv| NIL) + (SPADLET |$initCapsuleErrorCount| + (|#| |$semanticErrorStack|)) + (SPADLET |$insideCapsuleFunctionIfTrue| 'T) + (SPADLET |$CapsuleModemapFrame| |e|) + (SPADLET |$CapsuleDomainsInScope| + (|get| '|$DomainsInScope| '|special| |e|)) + (SPADLET |$insideExpressionIfTrue| 'T) + (SPADLET |$returnMode| |m|) + (SPADLET |$op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |$form| (CONS |$op| |argl|)) + (SPADLET |argl| (|stripOffArgumentConditions| |argl|)) + (SPADLET |$formalArgList| + (APPEND |argl| |$formalArgList|)) + (SPADLET |argModeList| + (COND + ((SPADLET |identSig| + (|hasSigInTargetCategory| |argl| + |form| (CAR |signature|) |e|)) + (SPADLET |e| + (|checkAndDeclare| |argl| |form| + |identSig| |e|)) + (CDR |identSig|)) + ('T + (PROG (G179836) + (SPADLET G179836 NIL) + (RETURN + (DO ((G179841 |argl| (CDR G179841)) + (|a| NIL)) + ((OR (ATOM G179841) + (PROGN + (SETQ |a| (CAR G179841)) + NIL)) + (NREVERSE0 G179836)) + (SEQ (EXIT + (SETQ G179836 + (CONS + (|getArgumentModeOrMoan| |a| + |form| |e|) + G179836)))))))))) + (SPADLET |argModeList| + (|stripOffSubdomainConditions| |argModeList| + |argl|)) + (SPADLET |signature'| + (CONS (CAR |signature|) |argModeList|)) + (COND + ((NULL |identSig|) + (SPADLET |oldE| + (|put| |$op| '|mode| + (CONS '|Mapping| |signature'|) |oldE|)))) + (COND + ((NULL (CAR |signature'|)) + (SPADLET |signature'| + (COND + (|identSig| |identSig|) + ('T + (OR (|getSignature| |$op| + (CDR |signature'|) |e|) + (RETURN NIL))))))) + (SPADLET |signature'| + (SUBLISLIS |argl| |$FormalFunctionParameterList| + |signature'|)) + (SPADLET |e| (|giveFormalParametersValues| |argl| |e|)) + (SPADLET |$signatureOfForm| |signature'|) + (SPADLET |$functionLocations| + (CONS (CONS (CONS |$op| + (CONS |$signatureOfForm| NIL)) + |lineNumber|) + |$functionLocations|)) + (SPADLET |e| (|addDomain| (CAR |signature'|) |e|)) + (SPADLET |e| (|compArgumentConditions| |e|)) + (COND + (|$profileCompiler| + (DO ((G179851 |argl| (CDR G179851)) (|x| NIL) + (G179852 (CDR |signature'|) (CDR G179852)) + (|t| NIL)) + ((OR (ATOM G179851) + (PROGN (SETQ |x| (CAR G179851)) NIL) + (ATOM G179852) + (PROGN (SETQ |t| (CAR G179852)) NIL)) + NIL) + (SEQ (EXIT (|profileRecord| '|arguments| |x| |t|)))))) + (DO ((G179864 |signature'| (CDR G179864)) + (|domain| NIL)) + ((OR (ATOM G179864) + (PROGN (SETQ |domain| (CAR G179864)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |e| (|addDomain| |domain| |e|))))) + (SPADLET |rettype| + (|resolve| (CAR |signature'|) |$returnMode|)) + (SPADLET |localOrExported| + (COND + ((AND (NULL (|member| |$op| |$formalArgList|)) + (PROGN + (SPADLET |ISTMP#1| + (|getmode| |$op| |e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Mapping|)))) + '|local|) + ('T '|exported|))) + (SPADLET |formattedSig| + (|formatUnabbreviated| + (CONS '|Mapping| |signature'|))) + (COND + ((AND |$compileOnlyCertainItems| + (NULL (|member| |$op| |$compileOnlyCertainItems|))) + (|sayBrightly| + (CONS (MAKESTRING " skipping ") + (CONS |localOrExported| (|bright| |$op|)))) + (CONS NIL + (CONS (CONS '|Mapping| |signature'|) + (CONS |oldE| NIL)))) + ('T + (|sayBrightly| + (CONS (MAKESTRING " compiling ") + (CONS |localOrExported| + (APPEND (|bright| |$op|) + (CONS (MAKESTRING ": ") + |formattedSig|))))) + (COND + ((BOOT-EQUAL |$newComp| 'T) + (SPADLET |wholeBody| + (CONS 'DEF + (CONS |form| + (CONS |signature'| + (CONS |specialCases| + (CONS |body| NIL)))))) + (SPADLET T$ + (OR (CATCH '|compCapsuleBody| + (|newComp| |wholeBody| |$NoValueMode| + |e|)) + (CONS (INTERN " " "BOOT") + (CONS |rettype| (CONS |e| NIL))))) + (SPADLET T$ + (CONS (ELT (ELT (CAR T$) 2) 2) + (CONS |rettype| + (CONS (CADDR T$) NIL)))) + (COND + ((BOOT-EQUAL |$newCompCompare| 'T) + (SPADLET |oldT| + (OR (CATCH '|compCapsuleBody| + (|compOrCroak| |body| |rettype| + |e|)) + (CONS (INTERN " " "BOOT") + (CONS |rettype| (CONS |e| NIL))))) + (SAY (MAKESTRING "The old compiler generates:")) + (|prTriple| |oldT|) + (SAY (MAKESTRING "The new compiler generates:")) + (|prTriple| T$)) + ('T NIL))) + ('T + (SPADLET T$ + (OR (CATCH '|compCapsuleBody| + (|compOrCroak| |body| |rettype| |e|)) + (CONS (INTERN " " "BOOT") + (CONS |rettype| (CONS |e| NIL))))) + (|NRTassignCapsuleFunctionSlot| |$op| |signature'|) + (COND + ((BOOT-EQUAL |$newCompCompare| 'T) + (SAY (MAKESTRING "The old compiler generates:")) + (|prTriple| T$)) + ('T NIL)))) + (SPADLET |catchTag| (MKQ (GENSYM))) + (SPADLET |fun| + (PROGN + (SPADLET |body'| + (|replaceExitEtc| (CAR T$) + |catchTag| '|TAGGEDreturn| + |$returnMode|)) + (SPADLET |body'| + (|addArgumentConditions| |body'| + |$op|)) + (SPADLET |finalBody| + (CONS 'CATCH + (CONS |catchTag| + (CONS |body'| NIL)))) + (|compileCases| + (CONS |$op| + (CONS + (CONS 'LAM + (CONS + (APPEND |argl| (CONS '$ NIL)) + (CONS |finalBody| NIL))) + NIL)) + |oldE|))) + (SPADLET |$functorStats| + (|addStats| |$functorStats| |$functionStats|)) + (SPADLET |val| + (CONS |fun| + (CONS |signature'| (CONS |e| NIL)))) + (CONS |fun| + (CONS (CONS '|Mapping| |signature'|) + (CONS |oldE| NIL)))))))))) + +;--from postpar +;--------------------> NEW DEFINITION (override in postpar.boot.pamphlet) +;postSignature ['Signature,op,sig] == +; sig is ["->",:.] => +; sig1:= postType sig +; op:= postAtom (STRINGP op => INTERN op; op) +; ["SIGNATURE",op,:removeSuperfluousMapping killColons postDoubleSharp sig1] + +;;; *** |postSignature| REDEFINED + +(DEFUN |postSignature| (G179951) + (PROG (|sig| |sig1| |op|) + (RETURN + (PROGN + (SPADLET |op| (CADR G179951)) + (SPADLET |sig| (CADDR G179951)) + (COND + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '->)) + (PROGN + (SPADLET |sig1| (|postType| |sig|)) + (SPADLET |op| + (|postAtom| + (COND + ((STRINGP |op|) (INTERN |op|)) + ('T |op|)))) + (CONS 'SIGNATURE + (CONS |op| + (|removeSuperfluousMapping| + (|killColons| (|postDoubleSharp| |sig1|)))))))))))) + +;postDoubleSharp sig == +; sig is [['Mapping,target,:r]] => +; -- replace #1,... by ##1,... +; [['Mapping, SUBLISLIS($FormalFunctionParameterList, $FormalMapVariableList, target), +; :r]] +; sig + +(DEFUN |postDoubleSharp| (|sig|) + (PROG (|ISTMP#1| |ISTMP#2| |target| |r|) + (declare (special |$FormalFunctionParameterList|)) + (RETURN + (COND + ((AND (PAIRP |sig|) (EQ (QCDR |sig|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |sig|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|Mapping|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + (SPADLET |r| (QCDR |ISTMP#2|)) + 'T)))))) + (CONS (CONS '|Mapping| + (CONS (SUBLISLIS |$FormalFunctionParameterList| + |$FormalMapVariableList| |target|) + |r|)) + NIL)) + ('T |sig|))))) + +;-- override in br-util.boot.pamphlet +;bcConform1 form == main where +; main == +; form is ['ifp,form1,:pred] => +; hd form1 +; bcPred pred +; hd form +; hd form == +; atom form => +; not MEMQ(form,$Primitives) and null constructor? form => +; s := STRINGIMAGE form +; (s.0 = char '_#) => +; (n := POSN1(form, $FormalFunctionParameterList)) => +; htSay form2HtString ($FormalMapVariableList . n) +; htSay '"\" +; htSay form +; htSay escapeSpecialChars STRINGIMAGE form +; s := STRINGIMAGE form +; $italicHead? => htSayItalics s +; $bcMultipleNames => +; satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"]) +; satTypeDownLink(s, ["(|conPage| '|",s,'"|)"]) +; (head := QCAR form) = 'QUOTE => +; htSay('"'") +; hd CADR form +; head = 'SIGNATURE => +; htSay(CADR form,'": ") +; mapping CADDR form +; head = 'Mapping and rest form => rest form => mapping rest form +; head = ":" => +; hd CADR form +; htSay '": " +; hd CADDR form +; QCDR form and dbEvalableConstructor? form +; => bcConstructor(form,head) +; hd head +; null (r := QCDR form) => nil +; tl QCDR form +; mapping [target,:source] == +; tuple source +; bcHt +; $saturn => '" {\ttrarrow} " +; '" -> " +; hd target +; tuple u == +; null u => bcHt '"()" +; null rest u => hd u +; bcHt '"(" +; hd first u +; for x in rest u repeat +; bcHt '"," +; hd x +; bcHt '")" +; tl u == +; bcHt '"(" +; firstTime := true +; for x in u repeat +; if not firstTime then bcHt '"," +; firstTime := false +; hd x +; bcHt '")" +; say x == +; if $italics? then bcHt '"{\em " +; if x = 'etc then x := '"..." +; bcHt escapeSpecialIds STRINGIMAGE x +; if $italics? then bcHt '"}" + +(DEFUN |bcConform1,say| (|x|) + (declare (special |$italics?|)) + (SEQ (IF |$italics?| (|bcHt| (MAKESTRING "{\\em ")) NIL) + (IF (BOOT-EQUAL |x| '|etc|) (SPADLET |x| (MAKESTRING "...")) + NIL) + (|bcHt| (|escapeSpecialIds| (STRINGIMAGE |x|))) + (EXIT (IF |$italics?| (|bcHt| (MAKESTRING "}")) NIL)))) + +(DEFUN |bcConform1,tl| (|u|) + (PROG (|firstTime|) + (RETURN + (SEQ (|bcHt| (MAKESTRING "(")) (SPADLET |firstTime| 'T) + (DO ((G180021 |u| (CDR G180021)) (|x| NIL)) + ((OR (ATOM G180021) + (PROGN (SETQ |x| (CAR G180021)) NIL)) + NIL) + (SEQ (IF (NULL |firstTime|) (|bcHt| (MAKESTRING ",")) NIL) + (SPADLET |firstTime| NIL) + (EXIT (|bcConform1,hd| |x|)))) + (EXIT (|bcHt| (MAKESTRING ")"))))))) + +(DEFUN |bcConform1,tuple| (|u|) + (SEQ (IF (NULL |u|) (EXIT (|bcHt| (MAKESTRING "()")))) + (IF (NULL (CDR |u|)) (EXIT (|bcConform1,hd| |u|))) + (|bcHt| (MAKESTRING "(")) (|bcConform1,hd| (CAR |u|)) + (DO ((G180035 (CDR |u|) (CDR G180035)) (|x| NIL)) + ((OR (ATOM G180035) + (PROGN (SETQ |x| (CAR G180035)) NIL)) + NIL) + (SEQ (|bcHt| (MAKESTRING ",")) (EXIT (|bcConform1,hd| |x|)))) + (EXIT (|bcHt| (MAKESTRING ")"))))) + +(DEFUN |bcConform1,mapping| (G180044) + (PROG (|target| |source|) + (declare (special |$saturn|)) + (RETURN + (SEQ (PROGN + (SPADLET |target| (CAR G180044)) + (SPADLET |source| (CDR G180044)) + G180044 + (SEQ (|bcConform1,tuple| |source|) + (|bcHt| (SEQ (IF |$saturn| + (EXIT (MAKESTRING " {\\ttrarrow} "))) + (EXIT (MAKESTRING " -> ")))) + (EXIT (|bcConform1,hd| |target|)))))))) + +(DEFUN |bcConform1,hd| (|form|) + (PROG (|n| |s| |head| |r|) + (declare (special |$italicHead?| |$bcMultipleNames| |$Primitives| + |$FormalFunctionParameterList| |$FormalMapVariableList| + |$italicHead?|)) + (RETURN + (SEQ (IF (ATOM |form|) + (EXIT (SEQ (IF (AND (NULL (MEMQ |form| |$Primitives|)) + (NULL (|constructor?| |form|))) + (EXIT (SEQ + (SPADLET |s| (STRINGIMAGE |form|)) + (IF + (BOOT-EQUAL (ELT |s| 0) + (|char| '|#|)) + (EXIT + (SEQ + (IF + (SPADLET |n| + (POSN1 |form| + |$FormalFunctionParameterList|)) + (EXIT + (|htSay| + (|form2HtString| + (ELT + |$FormalMapVariableList| + |n|))))) + (|htSay| (MAKESTRING "\\")) + (EXIT (|htSay| |form|))))) + (EXIT + (|htSay| + (|escapeSpecialChars| + (STRINGIMAGE |form|))))))) + (SPADLET |s| (STRINGIMAGE |form|)) + (IF |$italicHead?| + (EXIT (|htSayItalics| |s|))) + (IF |$bcMultipleNames| + (EXIT (|satTypeDownLink| |s| + (CONS + (MAKESTRING + "(|conPageChoose| '|") + (CONS |s| + (CONS (MAKESTRING "|)") NIL)))))) + (EXIT (|satTypeDownLink| |s| + (CONS '|(\|conPage\| '\|| + (CONS |s| + (CONS (MAKESTRING "|)") NIL)))))))) + (IF (BOOT-EQUAL (SPADLET |head| (QCAR |form|)) 'QUOTE) + (EXIT (SEQ (|htSay| (MAKESTRING "'")) + (EXIT (|bcConform1,hd| (CADR |form|)))))) + (IF (BOOT-EQUAL |head| 'SIGNATURE) + (EXIT (SEQ (|htSay| (CADR |form|) (MAKESTRING ": ")) + (EXIT (|bcConform1,mapping| (CADDR |form|)))))) + (IF (AND (BOOT-EQUAL |head| '|Mapping|) (CDR |form|)) + (EXIT (IF (CDR |form|) + (EXIT (|bcConform1,mapping| (CDR |form|)))))) + (IF (BOOT-EQUAL |head| '|:|) + (EXIT (SEQ (|bcConform1,hd| (CADR |form|)) + (|htSay| (MAKESTRING ": ")) + (EXIT (|bcConform1,hd| (CADDR |form|)))))) + (IF (AND (QCDR |form|) (|dbEvalableConstructor?| |form|)) + (EXIT (|bcConstructor| |form| |head|))) + (|bcConform1,hd| |head|) + (IF (NULL (SPADLET |r| (QCDR |form|))) (EXIT NIL)) + (EXIT (|bcConform1,tl| (QCDR |form|))))))) + + (DEFUN |bcConform1| (|form|) + (PROG (|ISTMP#1| |form1| |pred|) + (RETURN + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|ifp|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |form1| (QCAR |ISTMP#1|)) + (SPADLET |pred| (QCDR |ISTMP#1|)) + 'T)))) + (|bcConform1,hd| |form1|) (|bcPred| |pred|)) + ('T (|bcConform1,hd| |form|)))))) + +;--======================================================================= +;-- Code for Private Libdbs +;--======================================================================= +;--extendLocalLibdb conlist == --called by function "compiler"(see above) +;-- buildLibdb conlist --> puts datafile into temp.text +;-- $newConstructorList := UNION(conlist, $newConstructorList) +;-- localLibdb := '"libdb.text" +;-- not isExistingFile '"libdb.text" => RENAME_-FILE('"temp.text",'"libdb.text") +;-- oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) +;-- newlines := dbReadLines '"temp.text" +;-- dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") +;-- deleteFile '"temp.text" +;purgeNewConstructorLines(lines, conlist) == +; [x for x in lines | not screenLocalLine(x, conlist)] + +(DEFUN |purgeNewConstructorLines| (|lines| |conlist|) + (PROG () + (RETURN + (SEQ (PROG (G180083) + (SPADLET G180083 NIL) + (RETURN + (DO ((G180089 |lines| (CDR G180089)) (|x| NIL)) + ((OR (ATOM G180089) + (PROGN (SETQ |x| (CAR G180089)) NIL)) + (NREVERSE0 G180083)) + (SEQ (EXIT (COND + ((NULL (|screenLocalLine| |x| |conlist|)) + (SETQ G180083 (CONS |x| G180083))))))))))))) + +;-- Got rid of debugging statement and deleted screenLocalLine1, MCD 26/3/96 +;--screenLocalLine(line,conlist) == +;-- u := screenLocalLine1(line,conlist) +;-- if u then +;-- sayBrightly ['"Purging--->", line] +;-- u +;-- screenLocalLine1(line, conlist) == +;screenLocalLine(line, conlist) == +; k := dbKind line +; con := INTERN +; k = char 'o or k = char 'a => +; s := dbPart(line,5,1) +; k := charPosition(char '_(,s,1) +; SUBSTRING(s,1,k - 1) +; dbName line +; MEMQ(con, conlist) + +(DEFUN |screenLocalLine| (|line| |conlist|) + (PROG (|s| |k| |con|) + (RETURN + (PROGN + (SPADLET |k| (|dbKind| |line|)) + (SPADLET |con| + (INTERN (COND + ((OR (BOOT-EQUAL |k| (|char| '|o|)) + (BOOT-EQUAL |k| (|char| '|a|))) + (SPADLET |s| (|dbPart| |line| 5 1)) + (SPADLET |k| + (|charPosition| (|char| '|(|) |s| + 1)) + (SUBSTRING |s| 1 (SPADDIFFERENCE |k| 1))) + ('T (|dbName| |line|))))) + (MEMQ |con| |conlist|))))) + +;--------------> NEW DEFINITION (see br-data.boot.pamphlet) +;purgeLocalLibdb() == --called by the user through a clear command? +; $newConstructorList := nil +; deleteFile '"libdb.text" +;--moveFile(before,after) == +;-- $saturn => MOVE_-FILE(before, after) +;-- RENAME_-FILE(before, after) +;-- --obey STRCONC('"mv ", before, '" ", after) +;-- deleted JHD/MCD, since already one in pathname.boot +;--deleteFile fn == +;-- $saturn => DELETE_-FILE fn +;-- obey STRCONC('"rm ",fn) +;--======================================================================= +;-- from daase.lisp +;--======================================================================= +;--library(args) == +;-- $newConlist: local := nil +;-- LOCALDATABASE(args,$options) +;-- extendLocalLibdb $newConlist +;-- TERSYSCOMMAND() + +(DEFUN |purgeLocalLibdb| () + (declare (special |$newConstructorList|)) + (PROGN + (SPADLET |$newConstructorList| NIL) + (|deleteFile| (MAKESTRING "libdb.text")))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} +