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|))) +