open-axiom repository from github
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- 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.
import bc_-util
namespace 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 :=
-- a isnt [.,:.] => b
-- a := conform2OutputForm a
-- [mathform2HtString x for x in rest a]
-- if cons? a then a := first a
-- da := DOWNCASE a
-- pageName := symbolTarget(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 :=
a isnt [.,:.] => [a,:b]
a
$conArgstrings: local := [form2HtString x for x in KDR a]
if cons? a then a := first a
da := DOWNCASE a
pageName := symbolTarget(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 := (string? x => makeSymbol x; x)
entry := tableValue($lowerCaseConTb,name) or return nil
lineNumber := symbolTarget('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
--=======================================================================
conform2String u ==
x := form2String u
x isnt [.,:.] => 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 ",toString nargs," arguments:"]
htSaturnBreak()
htSayStandard '"\indentrel{2}"
if nargs > 0 then kPageArgs(conform,signature)
htSayStandard '"\indentrel{-2}"
if isDefautPackageName makeSymbol name then
name := subSequence(name, 0, #name-1)
sourceFileName := getConstructorSourceFileFromDB makeSymbol name
filename := extractFileNameFromPath sourceFileName
if filename ~= '"" then
htSayStandard '"\newline{}"
htSay('"The source code for the constructor is found in ")
htMakePage [['text,'"\unixcommand{",filename,'"}{",textEditor(), '" ",
sourceFileName, '" ", name, '"}"]]
if nargs ~= 0 then htSay '"."
htSaturnBreak()
kArgPage(htPage,arg) ==
[op,:args] := conform := htpProperty(htPage,'conform)
domname := htpProperty(htPage,'domname)
heading := htpProperty(htPage,'heading)
source := getConstructorModemap(op).mmSource
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 => applySubst(pairList(conform.args,domname.args),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 is 'Join => jfn(remove(r,'Object),remove(IFCDR domform,'Object))
op is '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(rest u,pred)],:keepList]
alist := keepList
for pair in alist repeat
pair.rest := simpHasPred rest pair
listSort(function GLESSEQP, alist)
catScreen(r,alist) ==
for x in r repeat
x isnt [op1,:.] and op1 in '(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 x.rest := simpHasPred rest x
for x in attrlist repeat x.rest.rest := simpHasPred CDDR x
for x in oplist repeat x.rest.rest := 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(toString count,'" names for ")
if total > 1
then htSay(toString 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
getConstructorPredicates name
catpredvec := first u
catinfo := second u
catvec := third u
catforms := [[pakform,:pred] for i in 0..maxIndex catvec | test ] where
test() ==
pred := simpCatPredicate
p := applySubst(pairList($FormalMapVariableList,conform.args),kTestPred catpredvec.i)
$domain => eval p
p
if domname and CONTAINED('$,pred) then
pred := substitute(domname,'$,pred)
-- which = '"attribute" => pred --all categories
(pak := catinfo . i) and pred --only those with default packages
pakform() ==
pak and not ident? 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 := substitute(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(symbolName makeDefaultPackageName name,'"")
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]]]
satBreak()
message := '"Constructors mentioning this as an argument type"
htMakePage [['bcLinks,['"\menuitemstyle{Dependents}",
[['text,'"\tab{12}",message]],'kcdePage,nil]]]
satBreak()
htMakePage [['bcLinks,['"\menuitemstyle{Lineage}",
'"\tab{12}Constructor hierarchy used for operation lookup",'ksPage,nil]]]
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 tableValue($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
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 := getConstructorParentsFromDB conname
if domname then
parents := applySubst(pairList(conform.args,domname.args),parents)
htpSetProperty(htPage,'cAlist,parents)
htpSetProperty(htPage,'thing,'"parent")
choice :=
domname => 'parameters
'names
dbShowCons(htPage,choice)
reduceAlistForDomain(alist,domform,conform) == --called from kccPage
alist := applySubst(pairList(conform.args,domform.args),alist)
for pair in alist repeat
pair.rest := simpHasPred(rest 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 := apply(fn, [conform, domname])
if whichever ~= '"ancestor" then
ancestors := augmentHasArgs(ancestors,conform)
ancestors := listSort(function GLESSEQP,ancestors)
--if domname then ancestors := substitute(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 := makeSymbol name
constring := strconc(name,args)
conform :=
kind ~= '"default package" => ncParseFromString constring
[makeSymbol name,:rest ncParseFromString strconc('"d",args)] --because of &
pakname :=
-- kind = '"category" => makeDefaultPackageName name
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 := makeSymbol name
constring := strconc(name,args)
conform :=
kind ~= '"default package" => ncParseFromString constring
[makeSymbol name,:rest ncParseFromString strconc('"d",args)] --because of &
pakname :=
kind = '"category" => makeDefaultPackageName name
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" => makeDefaultPackageName symbolName name
opOf conform
domList := getImports pakname
if domname then
domList := applySubst(pairList(['$,:conform.args],[domname,:domname.args]),domList)
cAlist := [[x,:true] for x in domList]
htpSetProperty(htPage,'cAlist,cAlist)
htpSetProperty(htPage,'thing,'"benefactor")
dbShowCons(htPage,'names)
koPageInputAreaUnchanged?(htPage, nargs) ==
[htpLabelInputString(htPage,makeSymbol strconc('"*",toString 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 := makeSymbol name
args := [kArgumentCheck(domain?,x) or nil for x in inputAreaList
for domain? in rest getDualSignature conname]
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($SpadReaderTag, 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 := getConstructorKindFromDB op
kind = 'category => form
mkEvalable form
topLevelInterpEval x ==
$ProcessInteractiveValue: local := true
$noEvalTypeMsg: local := true
processInteractive(x,nil)
kisValidType typeForm ==
$ProcessInteractiveValue: local := true
$noEvalTypeMsg: local := true
CATCH($SpadReaderTag, processInteractive(typeForm,nil))
is [m,:t] and member(m,$LangSupportTypes) =>
kCheckArgumentNumbers t and t
false
kCheckArgumentNumbers t ==
[conname,:args] := t
builtinConstructor? conname => true
cosig := KDR getDualSignature conname
#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 second 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?"
parse isnt [.,:.] => [parse]
parse
[makeSymbol name,:rest ncParseFromString strconc('"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
builtinFunctorName? conname =>
dbSpecialOperations conname
domname := --> !!note!! <--
cons? 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"
parts.first := kind
constring := strconc(name,args)
conform := mkConform(kind,name,args)
capitalKind := capitalize kind
signature := ncParseFromString sig
sourceFileName := getConstructorSourceFileFromDB makeSymbol 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 := symbolTarget('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 := makeSymbol 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)
apply(functionToCall,[htPage,nil])
--=======================================================================
-- Get Constructor Documentation
--=======================================================================
dbConstructorDoc(conform,$op,$sig) == fn conform where
fn (conform := [conname,:$args]) ==
or/[gn y for y in getConstructorDocumentationFromDB conname]
gn([op,:alist]) ==
op = $op and "or"/[doc or '("") for [sig,:doc] in alist | hn sig]
hn sig ==
#$sig = #sig and $sig = applySubst(pairList($FormalMapVariableList,$args),sig)
dbDocTable conform ==
--assumes $docTableHash bound --see dbExpandOpAlistIfNecessary
table := tableValue($docTableHash,conform) => table
$docTable : local := hashTable 'EQ
--process in reverse order so that closest cover up farthest
for x in originsInOrder conform repeat dbAddDocTable x
dbAddDocTable conform
tableValue($docTableHash,conform) := $docTable
$docTable
originsInOrder conform == --domain = nil or set to live domain
--from dcCats
[con,:argl] := conform
getConstructorKindFromDB con = "category" =>
ASSOCLEFT ancestorsOf(conform,nil)
acc := ASSOCLEFT parentsOfForm conform
for x in acc repeat
for y in originsInOrder x repeat acc := insert(y,acc)
acc
dbAddDocTable conform ==
conname := opOf conform
storedArgs := getConstructorForm(conname).args
for [op,:alist] in applySubst(pairList(["%",:storedArgs],["$",:conform.args]),
getConstructorDocumentationFromDB opOf conform)
repeat
op1 :=
op = '(Zero) => 0
op = '(One) => 1
op
for [sig,doc] in alist repeat
tableValue($docTable,op1) := [[conform,:alist],:tableValue($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 not integer? op and
digit?((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 tableValue(docTable,op)]
gn u == --u is [origin,entry1,...,:code]
$conform := first u --origin
if $conform isnt [.,:.] then
$conform := [$conform]
code := LASTATOM u --optional topic code
comments := or/[p for entry in rest 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 := applySubst(pairList($FormalMapVariableList,KDR $conform),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) ==
u isnt [.,:.] =>
(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 =>
u isnt [.,:.] => nil
[[u,:true],:dbAddChain u]
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? => getConstructorAbbreviationFromDB 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 key in '(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 := removeDuplicates [item for x in cAlist | pred] where
pred() ==
item := first 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 := [dbConstructorKind constructorDB 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 := getConstructorSourceFileFromDB con)]
bcUnixTable(listSort(function GLESSEQP,removeDuplicates flist))
key = 'documentation => dbShowConsDoc(page,conlist)
if $exposedOnlyIfTrue then
cAlist := [x for x in cAlist | isExposedConstructor opOf first x]
key = 'conditions => dbShowConditions(page,cAlist,kind)
key = 'parameters => bcConTable removeDuplicates ASSOCLEFT cAlist
key = 'kinds => dbShowConsKinds cAlist
dbConsExposureMessage()
htSayStandard("\endscroll ")
dbPresentCons(page,kind,key)
htShowPageNoScroll()
dbConsExposureMessage() ==
$atLeastOneUnexposed =>
htSay '"\newline{}-------------\newline{}{\em *} = unexposed"
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 removeDuplicates 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
builtinFunctorName? conname =>
conname := htpProperty(htPage,'conname)
[["constructor",["NIL",doc]],:.] := property(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 :=
getConstructorKindFromDB conname = "category" =>
applySubst(pairList($TriangleVariableList,conargs),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 ==
symbolTarget('constructor,getConstructorDocumentationFromDB conname)
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 := #(removeDuplicates conlist)
-- count := #conlist
thing = '"benefactor" =>
[toString 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 => [toString count,:modifier,capitalize thing]
firstWord := (count = 0 => '"No "; toString count)
[firstWord,:exposureWord, :modifier,capitalize pluralize thing]
placepart :=
place => ['" of {\em ",form2HtString(place,nil,true),"}"]
nil
heading := [:prefix,:placepart]
connective :=
view in '(abbrs files kinds) => '" as "
'" with "
if count ~= 0 and view in '(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 := '("SPAD")
filename := filePathString findFile(STRINGIMAGE x, ft)
htMakePage [['text, '"\unixcommand{",filePathName x, '"}{",
textEditor(), '" ", filename, '"} "]]
htSay '"}"
htEndTable()
--=======================================================================
-- 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 property(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 property(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
pair.rest := ['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,substitute(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,substitute(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,substitute(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, substitute(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, substitute(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,:makeSymbol digits2Names PNAME arg] for arg in args
| (s := PNAME arg) and
"or"/[digit? stringChar(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 := stringChar(s,i)
segment :=
n := digit? c =>
('("Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine")).n
c
strconc(str, segment)
str