diff options
author | dos-reis <gdr@axiomatics.org> | 2007-08-14 05:14:52 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2007-08-14 05:14:52 +0000 |
commit | ab8cc85adde879fb963c94d15675783f2cf4b183 (patch) | |
tree | c202482327f474583b750b2c45dedfc4e4312b1d /src/interp/br-con.boot.pamphlet | |
download | open-axiom-ab8cc85adde879fb963c94d15675783f2cf4b183.tar.gz |
Initial population.
Diffstat (limited to 'src/interp/br-con.boot.pamphlet')
-rw-r--r-- | src/interp/br-con.boot.pamphlet | 1407 |
1 files changed, 1407 insertions, 0 deletions
diff --git a/src/interp/br-con.boot.pamphlet b/src/interp/br-con.boot.pamphlet new file mode 100644 index 00000000..7c7dec66 --- /dev/null +++ b/src/interp/br-con.boot.pamphlet @@ -0,0 +1,1407 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-con.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<<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. + +@ +<<*>>= +<<license>> + +--====================> 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]],:.] := GETL(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 GETL(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 GETL(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 +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |