open-axiom repository from github
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2011, 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
--=======================================================================
-- Operation Page Menu
--=======================================================================
--opAlist has form [[op,:alist],:.] where each alist
-- has form [sig,pred,origin,exposeFlag,comments]
dbFromConstructor?(htPage) == htpProperty(htPage,'conform)
dbDoesOneOpHaveParameters? opAlist ==
or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn() ==
string? x => dbPart(x,2,1) isnt '"0"
KAR x
--============================================================================
-- Master Switch Functions for Operation Views
--============================================================================
dbShowOps(htPage,which,key,:options) ==
--NEXT LINE SHOULD BE REMOVED if we are sure that which is a string
which := STRINGIMAGE which
if key in '(extended basic all) then
$groupChoice := key
key := htpProperty(htPage,'key) or 'names
opAlist :=
which is '"operation" => htpProperty(htPage,'opAlist)
-- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist))
-- htpSetProperty(htPage,'opAlist,al)
-- al
htpProperty(htPage,'attrAlist)
key is 'generalise =>
arg := STRINGIMAGE CAAR opAlist
which is '"attribute" => aPage arg
oPage arg
key is 'allDomains => dbShowOpAllDomains(htPage,opAlist,which)
key is 'filter =>
--if $saturn, IFCAR options contains filter string
filter := IFCAR options or pmTransFilter(dbGetInputString htPage)
filter is ['error,:.] => bcErrorPage filter
opAlist:= [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)]
null opAlist => emptySearchPage(which,filter)
htPage := htInitPageNoScroll(htCopyProplist htPage)
if which is '"operation"
then htpSetProperty(htPage,'opAlist,opAlist)
else htpSetProperty(htPage,'attrAlist,opAlist)
if htpProperty(htPage,'condition?) isnt 'no then
dbResetOpAlistCondition(htPage,which,opAlist)
dbShowOps(htPage,which,htpProperty(htPage,'exclusion))
htpSetProperty(htPage,'key,key)
if key in '(exposureOn exposureOff) then
$exposedOnlyIfTrue :=
key is 'exposureOn => 'T
nil
key := htpProperty(htPage,'exclusion)
dbShowOp1(htPage,opAlist,which,key)
reduceByGroup(htPage,opAlist) ==
not dbFromConstructor?(htPage) or null $groupChoice => opAlist
dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false)
bitNumber := tableValue($topicHash,$groupChoice)
res := [[op,:newItems] for [op,:items] in opAlist | newItems] where
newItems() ==
null bitNumber => items
[x for x in items | integer? (code := myLastAtom x) and LOGBITP(bitNumber,code)]
res
dbShowOp1(htPage,opAlist,which,key) ==
--set up for filtering below in dbGatherData
$which: local := which
if integer? key then
opAlist := dbSelectData(htPage,opAlist,key)
------> Jump out for constructor names in file <--------
integer? key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile)
and constructor? con => return conPageChoose con
if integer? key then
htPage := htInitPageNoScroll(htCopyProplist htPage)
if which is '"operation"
then htpSetProperty(htPage,'opAlist,opAlist)
else htpSetProperty(htPage,'attrAlist,opAlist)
if htpProperty(htPage,'condition?) isnt 'no then
dbResetOpAlistCondition(htPage,which,opAlist)
dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
--opAlist is expanded to form [[op,[sig,pred,origin,exposed,comments],...],...]
opAlist:=[item for [op,:items] in opAlist | item] where
item() ==
acc := nil
for x in items | x.3 repeat acc:= [x,:acc]
null acc => nil
[op,:reverse! acc]
$conformsAreDomains : local := htpProperty(htPage,'domname)
opCount := opAlistCount(opAlist, which)
branch :=
integer? key =>
opCount <= $opDescriptionThreshold => 'documentation
'names
key is 'names and null rest opAlist => --means a single op
opCount <= $opDescriptionThreshold => 'documentation
'names
key
[what,whats,fn] := LASSOC(branch,$OpViewTable)
data := dbGatherData(htPage,opAlist,which,branch)
dataCount := +/[1 for x in data | (what is '"Name" and $exposedOnlyIfTrue => x isnt [.,:.]; true)]
namedPart :=
null rest opAlist =>
ops := escapeSpecialChars STRINGIMAGE CAAR opAlist
['" {\em ",ops,'"}"]
nil
if what is '"Condition" and null KAR KAR data then dataCount := dataCount - 1
exposurePart :=
$exposedOnlyIfTrue => '(" Exposed ")
nil
firstPart :=
opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which]
dataCount = 1 or dataCount = opCount =>
opCount = 1 => [:exposurePart, capitalize which,:namedPart]
[toString opCount,'" ",:exposurePart,
pluralize capitalize which,:namedPart]
prefix := pluralSay(dataCount,what,whats)
[:prefix,'" for ",toString opCount,'" ",pluralize capitalize which,:namedPart]
page := htInitPageNoScroll(htCopyProplist htPage)
------------>above line used to call htInitPageHoHeading<----------
htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch)
htpSetProperty(page,'data,data)
htpSetProperty(page,'branch,branch)
-- the only place where specialMessage property is set seems to be commented. out
if u := htpProperty(page,'specialMessage) then apply(first u,rest u)
htSayStandard('"\beginscroll ")
apply(fn,[page,opAlist,which,data]) --apply branch function
dbOpsExposureMessage()
htSayStandard("\endscroll ")
dbPresentOps(page,which,branch)
htShowPageNoScroll()
opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo() ==
null $exposedOnlyIfTrue or which is '"attribute" => #items
--count if unexpanded---CDDR(w) = nil---or if w.3 = true
+/[1 for w in items | null (p := CDDR w) or p . 1]
dbShowOpHeading(heading, branch) ==
suffix :=
-- branch is 'signatures => '" viewed as signatures"
branch is 'parameters => '" viewed with parameters"
branch is 'origins => '" organized by origins"
branch is 'conditions => '" organized by conditions"
'""
[:heading, suffix]
dbOpsExposureMessage() ==
$atLeastOneUnexposed => htSay '"{\em *} = unexposed"
fromHeading htPage ==
null htPage => '""
$pn := [htPage.0,'"}{"]
updomain := htpProperty(htPage,'updomain) =>
dnForm := dbExtractUnderlyingDomain updomain
dnString:= form2StringList dnForm
dnFence := form2Fence dnForm
-- upString:= form2StringList updomain
upFence := form2Fence updomain
upOp := symbolName opOf updomain
['" {\em from} ",:dbConformGen dnForm,'" {\em under} \ops{",upOp,'"}{",:$pn,:upFence,'"}"]
domname := htpProperty(htPage,'domname)
numberOfUnderlyingDomains := #[x for x in rest getDualSignature(opOf domname) | x]
-- numberOfUnderlyingDomains = 1 and
-- KDR domname and (dn := dbExtractUnderlyingDomain domname) =>
-- ['" {\em from} ",:pickitForm(domname,dn)]
KDR domname => ['" {\em from} ",:dbConformGen domname]
htpProperty(htPage,'fromHeading)
pickitForm(form,uarg) ==
conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg)
conformString(form) ==
KDR form =>
conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil)
form2StringList form
conform2StringList(form,opFn,argFn,exception) ==
exception := exception or '"%%%nothing%%%"
[op1,:args] := form
op := IFCAR tableValue($lowerCaseConTb,op1) or op1
null args => apply(opFn,[op])
special := builtinConstructor? op
cosig :=
special => [true for x in args]
rest getDualSignature op
atypes :=
special => cosig
getConstructorModemap(op).mmSource
sargl := [fn for x in args for atype in atypes for pred in cosig] where fn() ==
keyword :=
x is [":",y,t] =>
x := t
y
nil
res :=
x = exception => dbOpsForm exception
pred =>
string? x => [x]
u := apply(argFn,[x])
u isnt [.,:.] and [u] or u
typ := sublisFormal(args,atype)
if x is ['QUOTE,a] then x := a
u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u]
integer? x or string? x => [x]
systemError()
keyword => [keyword,'": ",:res]
res
op is 'Mapping => dbMapping2StringList sargl
head :=
special => [op]
apply(opFn,[form])
[:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"]
dbMapping2StringList [target,:sl] ==
null sl => target
restPart :=
null rest sl => nil
"append"/[[",",:y] for y in rest sl]
sourcePart :=
restPart => ['"(",:first sl,:restPart,'")"]
first sl
[:sourcePart,'" -> ",:target]
dbOuttran form ==
if form is [.,:.] then
[op,:args] := form
else
op := form
args := nil
cosig := rest getDualSignature op
atypes := getConstructorModemap(op).mmSource
argl := [fn for x in args for atype in atypes for pred in cosig] where fn() ==
pred => x
typ := sublisFormal(args,atype)
arg :=
x is ['QUOTE,a] => a
x
res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm))
integer? res or string? res => res
quote res
[op,:argl]
dbOpsForm form ==
--one button for the operations of a type
--1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted
--2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|))
["\ops{",:conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"]
dbConformGen form == dbConformGen1(form,true)
--many buttons: one for the type and one for each inner type
--NOTE: must only be called on types KNOWN to be correct
dbConformGenUnder form == dbConformGen1(form,false)
--same as above, except buttons only for the inner types
dbConformGen1(form,opButton?) ==
opFunction :=
opButton? => FUNCTION dbConform
FUNCTION conname2StringList
originalOp := opOf form
op := unAbbreviateIfNecessary opOf form
args := IFCDR form
form :=
originalOp=op => form
[op, :args]
args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil)
apply(opFunction,[form])
unAbbreviateIfNecessary op == IFCAR tableValue($lowerCaseConTb, op) or op
conname2StringList form ==
[PNAME unAbbreviateIfNecessary opOf form]
--===========================================================================
-- Data Gathering Code
--============================================================================
dbGatherData(htPage,opAlist,which,key) ==
key is 'implementation => dbGatherDataImplementation(htPage,opAlist)
dataFunction := LASSOC(key,table) where
table() ==
$dbDataFunctionAlist or
($dbDataFunctionAlist := [
['signatures,:function dbMakeSignature],
['parameters,:function dbContrivedForm],
['origins,:function dbGetOrigin],
['domains,:function dbGetOrigin],
['conditions,:function dbGetCondition]])
null dataFunction =>
--key= names or filter or documentation; do not expand
if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
opAlist := --to get indexing correct
which is '"operation" => htpProperty(htPage,'opAlist)
htpProperty(htPage,'attrAlist)
acc := nil
initialExposure :=
htPage and htpProperty(htPage,'conform) and which isnt '"package operation"
=> true
--never star ops from a constructor
nil
for [op,:alist] in opAlist repeat
exposureFlag := initialExposure
while alist repeat
item := first alist
isExposed? :=
string? item => dbExposed?(item,char "o") --unexpanded case
null (r := rest rest item) => true --assume true if unexpanded
r . 1 --expanded case
if isExposed? then return (exposureFlag := true)
alist := rest alist
node :=
exposureFlag => op
[op,nil]
acc := [node,:acc]
reverse! acc
data := nil
dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in '(origins documentation),false)
--create data, a list of the form ((entry,exposeFlag,:entries)...)
for [op,:alist] in opAlist repeat
for item in alist repeat
entry := apply(dataFunction,[op,item])--get key item
exposeFlag := --is the current op-sig exposed?
null (r := rest rest item) => true --not given, assume yes
r . 1 --is given, use value
tail :=
item is [.,'ASCONST,:.] => 'ASCONST
nil
newEntry :=
u := assoc(entry,data) => --key seen before? look on DATA
u.rest.first := second u or exposeFlag --yes, expose if any 1 is exposed
u
data := [y := [entry,exposeFlag,:tail],:data]
y --no, create new entry in DATA
if key in '(origins conditions) then
r := CDDR newEntry
if r isnt [.,:.] then r := nil --clear out possible 'ASCONST
newEntry.rest.rest := --store op/sigs under key if needed
insert([dbMakeSignature(op,item),exposeFlag,:tail],r)
if key in '(origins conditions) then
for entry in data repeat --sort list of entries (after the 2nd)
tail := CDDR entry
tail :=
tail isnt [.,:.] => tail
listSort(function LEXLESSEQP,tail)
entry.rest.rest := tail
data := listSort(function LEXLESSEQP,data)
data
dbGatherDataImplementation(htPage,opAlist) ==
--returns data, of form ((implementor exposed? entry entry...)...
-- where entry has form ((op sig . implementor) . stuff)
conform := htpProperty(htPage,'conform)
domainForm := htpProperty(htPage,'domname)
dom := eval domainForm
which := '"operation"
[nam,:$domainArgs] := domainForm
$predicateList: local := getConstructorPredicates nam
predVector := domainPredicates dom
u := getDomainOpTable(dom,true,ASSOCLEFT opAlist)
--u has form ((op,sig,:implementor)...)
--sort into 4 groups: domain exports, unexports, default exports, others
for (x := [.,.,:key]) in u for i in 0.. repeat
key = domainForm => domexports := [x,:domexports]
integer? key => unexports := [x,:unexports]
defaultPackageForm? key => defexports := [x,:defexports]
key is 'nowhere => nowheres := [x,:nowheres]
key is 'constant =>constants := [x,:constants]
others := [x,:others] --add chain domains go here
fn [nowheres,constants,domexports,sortBy('CDDR,others),
sortBy('CDDR,defexports),sortBy('CDDR,unexports)] where
fn l ==
alist := nil
for u in l repeat
while u repeat
key := CDDAR u --implementor
entries :=
[[first u,true],:[u and [first u,true] while key = CDDAR (u := rest u)]]
alist := [[key,gn key,:entries],:alist]
reverse! alist
gn key ==
key isnt [.,:.] => true
isExposedConstructor first key
dbSelectData(htPage,opAlist,key) ==
branch := htpProperty(htPage,'branch)
data := htpProperty(htPage,'data)
branch in '(signatures parameters) =>
dbReduceOpAlist(opAlist,data.key,branch)
branch in '(origins conditions implementation) =>
key < 8192 => dbReduceOpAlist(opAlist,data.key,branch)
[newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large
innerData := CDDR data.(newkey - 1)
dbReduceOpAlist(opAlist,innerData.binkey,'signatures)
[opAlist . key]
dbReduceOpAlist(opAlist,data,branch) ==
branch is 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data)
branch is 'origins => dbReduceBySelection(opAlist,first data,function third)
branch is 'conditions => dbReduceBySelection(opAlist,first data,function second)
branch is 'implementation => dbReduceByOpSignature(opAlist,CDDR data)
branch is 'parameters => dbReduceByForm(opAlist,first data)
systemError ['"Unexpected branch: ",branch]
dbReduceByOpSignature(opAlist,datalist) ==
--reduces opAlist by implementation datalist, one of the form
-- (((op,sig,:implementor),:stuff),...)
ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.]
acc := nil
for [op,:alist] in opAlist | symbolMember?(op,ops) repeat
entryList := [entry for (entry := [sig,:.]) in alist | test] where test() ==
or/[x for x in datalist | x is [[=op,=sig,:.],:.]]
entryList => acc := [[op,:reverse! entryList],:acc]
reverse! acc
dbReduceBySignature(opAlist,op,sig) ==
--reduces opAlist to one with a fixed op and sig
[[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]]
dbReduceByForm(opAlist,form) ==
acc := nil
for [op,:alist] in opAlist repeat
items := [x for x in alist | dbContrivedForm(op,x) = form] =>
acc := [[op,:items],:acc]
reverse! acc
dbReduceBySelection(opAlist,key,fn) ==
acc := nil
for [op,:alist] in opAlist repeat
items := [x for x in alist | apply(fn,[x]) = key] =>
acc := [[op,:items],:acc]
reverse! acc
dbContrivedForm(op,[sig,:.]) ==
$which is '"attribute" => [op,sig]
dbMakeContrivedForm(op,sig)
dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format
dbGetOrigin(op,[.,.,origin,:.]) == origin
dbGetCondition(op,[.,pred,:.]) == pred
--dbInsertOpAlist(op,item,opAlist) ==
-- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist)
--dbSortOpAlist opAlist ==
-- [[op,:listSort(function LEXLESSEQP,alist)]
-- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)]
--============================================================================
-- Branches of Views
--============================================================================
dbShowOpNames(htPage,opAlist,which,data) ==
single? := opAlist and null rest data
single? =>
ops := escapeSpecialChars STRINGIMAGE CAAR opAlist
htSayStandard('"Select a view below")
htSaySaturn '"Select a view with the right mouse button"
exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage)
dbShowOpItems(which,data,exposedOnly?)
dbShowOpItems(which,data,exposedOnly?) ==
htBeginTable()
firstTime := true
for i in 0.. for item in data repeat
if firstTime then firstTime := false
else htSaySaturn '"&"
if item isnt [.,:.] then
op := item
exposeFlag := true
else
[op,exposeFlag] := item
ops := escapeSpecialChars STRINGIMAGE op
exposeFlag or not exposedOnly? =>
htSay('"{")
bcStarSpaceOp(ops,exposeFlag)
htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]]
htSay('"}")
htEndTable()
dbShowOpAllDomains(htPage,opAlist,which) ==
dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
catOriginAlist := nil --list of category origins
domOriginAlist := nil --list of domain origins
for [op,:items] in opAlist repeat
for [.,predicate,origin,:.] in items repeat
conname := first origin
getConstructorKindFromDB conname = "category" =>
pred := simpOrDumb(predicate,symbolTarget(conname,catOriginAlist) or true)
catOriginAlist := insertAlist(conname,pred,catOriginAlist)
pred := simpOrDumb(predicate,symbolTarget(conname,domOriginAlist) or true)
domOriginAlist := insertAlist(conname,pred,domOriginAlist)
--the following is similar to "domainsOf" but do not sort immediately
u := [copyTree key for [key,:.] in entries $HasCategoryTable
| symbolTarget(rest key,catOriginAlist)]
for pair in u repeat
[dom,:cat] := pair
symbolTarget(cat,catOriginAlist) is 'etc => pair.rest := 'etc
pair.rest := simpOrDumb(constructorHasCategoryFromDB pair,true)
--now add all of the domains
for [dom,:pred] in domOriginAlist repeat
u := insertAlist(dom,simpOrDumb(pred,symbolTarget(dom,u) or true),u)
cAlist := listSort(function GLESSEQP,u)
for pair in cAlist repeat
pair.first := getConstructorForm first pair
htpSetProperty(htPage,'cAlist,cAlist)
htpSetProperty(htPage,'thing,'"constructor")
htpSetProperty(htPage,'specialHeading,'"hoho")
dbShowCons(htPage,'names)
simpOrDumb(new,old) ==
new is 'etc => 'etc
new isnt [.,:.] => old
'etc
dbShowOpOrigins(htPage,opAlist,which,data) ==
dbGatherThenShow(htPage,opAlist,which,data,true,'"from",function bcStarConform)
dbShowOpImplementations(htPage,opAlist,which,data) ==
dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform)
dbShowOpConditions(htPage,opAlist,which,data) ==
dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred)
dbShowKind conform ==
conname := first conform
kind := getConstructorKindFromDB conname
kind is "domain" =>
isDefaultPackageName conname => '"default package"
'"domain"
symbolName kind
dbShowOpSignatures(htPage,opAlist,which,data) ==
dbShowOpSigList(which,data,0)
dbShowOpSigList(which,dataItems,count) ==
--dataItems is (((op,sig,:.),exposureFlag,...)
single? := null rest dataItems
htBeginTable()
firstTime := true
for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat
if firstTime then firstTime := false
else htSaySaturn '"&";
ops := escapeSpecialChars STRINGIMAGE op
htSay '"{"
-- if single? then htSay('"{\em ",ops,'"}") else.....
htSayExpose(ops,exposureFlag)
htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]]
if which is '"attribute" then htSay args2HtString (sig and [sig]) else
htSay '": "
tail is 'ASCONST => bcConform first sig
bcConform ['Mapping,:sig]
htSay '"}"
count := count + 1
htEndTable()
count
dbShowOpParameters(htPage,opAlist,which,data) ==
single? := null rest data
count := 0
htBeginTable()
firstTime := true
for item in data repeat
if firstTime then firstTime := false
else htSaySaturn '"&"
[opform,exposeFlag,:tail] := item
op := intern IFCAR opform
args := IFCDR opform
ops := escapeSpecialChars STRINGIMAGE op
htSay '"{"
htSayExpose(ops,exposeFlag)
n := #opform
do
n = 2 and symbolTarget('Nud,PROPLIST op) =>
dbShowOpParameterJump(ops,which,count,single?)
htSay('" {\em ",KAR args,'"}")
n = 3 and symbolTarget('Led,PROPLIST op) =>
htSay('"{\em ",KAR args,'"} ")
dbShowOpParameterJump(ops,which,count,single?)
htSay('" {\em ",KAR KDR args,'"}")
dbShowOpParameterJump(ops,which,count,single?)
tail is 'ASCONST or op in '(0 1) or which is '"attribute" and null IFCAR args => 'skip
htSay('"(")
if IFCAR args then htSay('"{\em ",IFCAR args,'"}")
for x in IFCDR args repeat
htSay('",{\em ",x,'"}")
htSay('")")
htSay '"}"
count := count + 1
htEndTable()
dbShowOpParameterJump(ops,which,count,single?) ==
single? => htSay('"{\em ",ops,'"}")
htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]]
dbShowOpDocumentation(htPage,opAlist,which,data) ==
if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
opAlist :=
which is '"operation" => htpProperty(htPage,'opAlist)
htpProperty(htPage,'attrAlist)
--NOTE: this line is necessary to get indexing right.
--The test below for $exposedOnlyIfTrue causes unexposed items
--to be skipped.
newWhich :=
conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform)
which is '"package operation" => '"operation"
which
expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
if expand then
condata := dbGatherData(htPage,opAlist,which,'conditions)
htpSetProperty(htPage,'conditionData,condata)
base := -8192
exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp
htSaySaturn '"\begin{description}"
for [op,:alist] in opAlist repeat
base := 8192 + base
for item in alist for j in 0.. repeat
[sig,predicate,origin,exposeFlag,comments] := item
exposeFlag or not $exposedOnlyIfTrue =>
if comments isnt '"" and string? comments and (k := string2Integer comments) then
comments :=
k in '(0 1) => '""
dbReadComments k
tail := CDDDDR item
tail.first := comments
doc := (comments isnt '"" => comments; nil)
pred := predicate or true
index := (exactlyOneOpSig => nil; base + j)
if which is '"package operation" then
sig := substitute(conform,'_$,sig)
origin := substitute(conform,'_$,origin)
displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,index,'dbChooseDomainOp,null exposeFlag,true)
htSaySaturn '"\end{description}"
dbChooseDomainOp(htPage,which,index) ==
[opKey,entryKey] := DIVIDE(index,8192)
opAlist :=
which is '"operation" => htpProperty(htPage,'opAlist)
htpProperty(htPage,'attrAlist)
[op,:entries] := opAlist . opKey
entry := entries . entryKey
htPage := htInitPageNoScroll(htCopyProplist htPage)
if which is '"operation"
then htpSetProperty(htPage,'opAlist,[[op,entry]])
else htpSetProperty(htPage,'attrAlist,[[op,entry]])
if htpProperty(htPage,'condition?) isnt 'no then
dbResetOpAlistCondition(htPage,which,opAlist)
dbShowOps(htPage,which,'documentation)
htSayExpose(op,flag) ==
$includeUnexposed? =>
flag => htBlank()
stringChar(op,0) = char "*" => htSay '"{\em *} "
htSayUnexposed()
htSay '""
--============================================================================
-- Branch-in From Other Places
--============================================================================
dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists
$groupChoice := nil
conform := htpProperty(htPage,'conform)
if domform := htpProperty(htPage,'domname) then
$conformsAreDomains : local := true
reduceOpAlistForDomain(opAlist,domform,conform)
conform := domform or conform
kind := capitalize htpProperty(htPage,'kind)
exposePart :=
isExposedConstructor opOf conform => '""
'" Unexposed "
fromPart :=
domform => evalableConstructor2HtString domform
form2HtString conform
heading :=
['" from ",exposePart,kind,'" {\em ",fromPart,'"}"]
expandProperty :=
which is '"operation" => 'expandOperations
'expandAttributes
htpSetProperty(htPage,expandProperty,'lists)
htpSetProperty(htPage,'fromHeading,heading)
reducedOpAlist :=
which is '"operation" => reduceByGroup(htPage,opAlist)
opAlist
if which is '"operation"
then
htpSetProperty(htPage,'principalOpAlist,opAlist)
htpSetProperty(htPage,'opAlist,reducedOpAlist)
else htpSetProperty(htPage,'attrAlist,opAlist)
if domform
then htpSetProperty(htPage,'condition?,'no)
else dbResetOpAlistCondition(htPage,which,opAlist)
dbShowOp1(htPage,reducedOpAlist,which,'names)
reduceOpAlistForDomain(opAlist,domform,conform) ==
--destructively simplify all predicates; filter out any that fail
form1 := [domform,:rest domform]
form2 := ['$,:rest conform]
for pair in opAlist repeat
pair.rest := [test for item in rest pair | test] where test() ==
[head,:tail] := item
first tail = true => item
pred := simpHasPred applySubst(pairList(form2,form1),first tail)
null pred => false
item.rest := [pred]
item
opAlist
$attributeArgs := nil
dbShowOperationLines(which,linelist) == --branch in with lines
htPage := htInitPage(nil,nil) --create empty page
opAlist := nil
lines := linelist
while lines repeat
name := dbName (x := first lines)
pile := [x]
while (lines := rest lines) and name = dbName (x := first lines) repeat
pile := [x,:pile]
opAlist := [[name,:reverse! pile],:opAlist]
opAlist := listSort(function LEXLESSEQP,reverse! opAlist)
if which is '"operation"
then htpSetProperty(htPage,'opAlist,opAlist)
else htpSetProperty(htPage,'attrAlist,opAlist)
expandProperty :=
which is '"operation" => 'expandOperations
'expandAttributes
htpSetProperty(htPage,expandProperty,'strings)
dbResetOpAlistCondition(htPage,which,opAlist)
if which is '"attribute" and $attributeArgs then
--code needed to handle commutative("*"); called from aPage
--must completely expand the opAlist then check for those with
--arguments equal to $attributeArgs
--here: opAlist is [[op,:itemlist]]
dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false)
opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | first item = $attributeArgs]]]
dbShowOp1(htPage,opAlist,which,'names)
--============================================================================
-- Code to Expand opAlist
--============================================================================
dbResetOpAlistCondition(htPage,which,opAlist) ==
value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true)
htpSetProperty(htPage,'condition?,(value => 'yes; 'no))
value
dbSetOpAlistCondition(htPage,opAlist,which) ==
--called whenever a new opAlist is needed
--property can only be inherited if 'no (a subset says NO if whole says NO)
condition := htpProperty(htPage,'condition?)
condition in '(yes no) => condition is 'yes
value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true)
htpSetProperty(htPage,'condition?,(value => 'yes; 'no))
value
dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) ==
--if condition? = true, stop when you find a non-trivial predicate
--otherwise, expand in full
--RETURNS:
-- non-trivial predicate, if condition? = true and it finds one
-- nil, otherwise
--SIDE-EFFECT: this function references the "expand" property (set elsewhere):
-- 'strings, if not fully expanded and it contains strings
-- i.e. opAlist is ((op . (string ...))...) if unexpanded
-- 'lists, if not fully expanded and it contains lists
-- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded
condition? := condition? and not $exposedOnlyIfTrue
value := nil --return value
expandProperty :=
which is '"operation" => 'expandOperations
'expandAttributes
expandFlag := htpProperty(htPage,expandProperty)
expandFlag is 'fullyExpanded => nil
expandFlag is 'strings => --strings are partially expanded
for pair in opAlist repeat
[op,:lines] := pair
acc := nil
for line in lines repeat
--NOTE: we must expand all lines here for a given op
-- since below we will change opAlist
--Case 1: Already expanded; just cons it onto ACC
null string? line => --already expanded
if condition? then --this could have been expanded at a lower level
if cons? (pred := second line) then value := pred
acc := [line,:acc] --this one is already expanded; record it anyway
--Case 2: unexpanded; expand it then cons it onto ACC
[name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1)
predicate := ncParseFromString pred
if condition? and cons? predicate then value := predicate
sig := ncParseFromString sigs --is (Mapping,:.)
if which is '"operation" then
if sig isnt ['Mapping,:.]
then sayBrightly ['"Unexpected signature for ",name,'": ",sigs]
else sig := rest sig
conname := intern dbNewConname line
origin := [conname,:getConstructorArgs conname]
exposeFlag := dbExposed?(line,char "o")
acc := [[sig,predicate,origin,exposeFlag,comments],:acc]
--always store the fruits of our labor:
pair.rest := reverse! acc --at least partially expand it
condition? and value => return value --early exit
value => value
condition? => nil
htpSetProperty(htPage,expandProperty,'fullyExpanded)
expandFlag is 'lists => --lists are partially expanded
-- entry is [sig, predicate, origin, exposeFlag, comments]
$value: local := nil
$docTableHash := hashTable 'EQUAL
packageSymbol := false
domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform)
if isDefaultPackageName opOf domform then
catname := intern subString(s := symbolName opOf domform,0,maxIndex s)
packageSymbol := second domform
domform := [catname,:rest rest domform] --skip first argument ($)
docTable:= dbDocTable domform
for [op,:alist] in opAlist repeat
for [sig,:tail] in alist repeat
condition? => --the only purpose here is to find a non-trivial pred
cons? (pred := first tail) => return ($value := pred)
'skip
u :=
tail is [.,origin,:.] and origin =>
-- must change any % into $ otherwise we will not pick up comments properly
-- delete the substitute when we fix on % or $
dbGetDocTable(op,substitute('%,'$,sig),dbDocTable origin,which,nil)
if packageSymbol then sig := substitute('_$,packageSymbol,sig)
dbGetDocTable(op,sig,docTable,which,nil)
origin := IFCAR u or origin
docCode := IFCDR u --> (doc . code)
-- if not integer? rest docCode then harhar(op) -->
if null doc and which is '"attribute" then doc := getRegistry(op,sig)
tail.rest := [origin,isExposedConstructor opOf origin,:docCode]
$value => return $value
$value => $value
condition? => nil
htpSetProperty(htPage,expandProperty,'fullyExpanded)
'done
getRegistry(op,sig) ==
u := getConstructorDocumentationFromDB "AttributeRegistry"
v := LASSOC(op,u)
match := or/[y for y in v | y is [['attribute,: =sig],:.]] => second match
'""
evalableConstructor2HtString domform ==
if vector? domform then domform := devaluate domform
conname := first domform
coSig := rest getDualSignature conname
--entries are T for arguments which are domains; NIL for computational objects
and/[x for x in coSig] => form2HtString(domform,nil,true)
arglist := [unquote x for x in rest domform] where
unquote arg ==
arg is [f,:args] =>
f is 'QUOTE => first args
[f,:[unquote x for x in args]]
arg
fargtypes := getConstructorModemap(conname).mmSource
--argtypes:= sublisFormal(arglist,fargtypes)
form2HtString([conname,:[fn for arg in arglist for x in coSig
for ftype in fargtypes]],nil,true) where
fn() ==
x => arg
typ := sublisFormal(arglist,ftype)
mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm))
mathform2HtString form == escapeString
$fortInts2Floats: local := false
form := niladicHack form
form is ['QUOTE,a] => strconc('"'",strconc/fortexp0 a)
form is ['BRACKET,['AGGLST,:arg]] =>
if arg is ['construct,:r] then arg := r
arg :=
arg isnt [.,:.] => [arg]
[y for x in arg | y := (x is ['QUOTE,a] => a; x)]
tailPart := strconc/[strconc('",",STRINGIMAGE x) for x in rest arg]
strconc('"[",STRINGIMAGE first arg,tailPart,'"]")
form is ['BRACKET,['AGGLST,'QUOTE,arg]] =>
if arg isnt [.,:.] then arg := [arg]
tailPart := strconc/[strconc('",",x) for x in rest arg]
strconc('"[",first arg,tailPart,'"]")
form isnt [.,:.] => form
strconc/fortexp0 form
niladicHack form ==
form isnt [.,:.] => form
form is [x] and niladicConstructor? x => x
[niladicHack x for x in form]
--============================================================================
-- Getting Operations from Domain
--============================================================================
getDomainOpTable(dom,fromIfTrue,:options) ==
ops := KAR options
$predEvalAlist : local := nil
$returnNowhereFromGoGet: local := true
domname := dom.0
conname := first domname
abb := getConstructorAbbreviation conname
opAlist := getConstructorOperationsFromDB conname
"append"/[removeDuplicates [[op1,:fn] for [sig,slot,pred,key,:.] in u
| key isnt 'Subsumed and ((null ops and (op1 := op)) or (op1 := memq(op,ops)))]
for [op,:u] in opAlist] where
memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One
symbolMember?(op,ops) => op
op is 'One => symbolMember?("1",ops) and "1"
op is 'Zero => symbolMember?("0",ops) and "0"
false
fn() ==
sig1 := sublisFormal(rest domname,sig)
predValue := evalDomainOpPred(dom,pred)
info :=
null predValue =>
1 -- signifies not exported
not fromIfTrue => nil
cell := compiledLookup(op,sig1,dom) =>
[f,:r] := cell
f is 'nowhere => 'nowhere --see replaceGoGetSlot
f is 'makeSpadConstant => 'constant
f is 'newGoGet => substitute('_$,domname,devaluate first r)
not vector? r => systemError devaluateList r
substitute('_$,domname,devaluate r)
'nowhere
[sig1,:info]
evalDomainOpPred(dom,pred) == process(dom,pred) where
process(dom,pred) ==
u := convert(dom,pred)
u is 'T => true
evpred(dom,u)
convert(dom,pred) ==
pred is [op,:argl] =>
op in '(AND and) => ['AND,:[convert(dom,x) for x in argl]]
op in '(OR or) => ['OR,:[convert(dom,x) for x in argl]]
op in '(NOT not) => ['NOT,convert(dom,first argl)]
op = "has" =>
[arg,p] := argl
p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a]
['HasCategory,arg,convertCatArg p]
systemError '"unknown predicate form"
pred is 'T => true
systemError nil
convertCatArg p ==
p isnt [.,:.] or #p = 1 => MKQ p
['%list,MKQ first p,:[convertCatArg x for x in rest p]]
evpred(dom,pred) ==
k := valuePosition(pred,$predicateList) => testBitVector(dom.3,k + 1)
evpred1(dom,pred)
evpred1(dom,pred) ==
pred is [op,:argl] =>
op in '(AND and) => "and"/[evpred1(dom,x) for x in argl]
op in '(OR or) => "or"/[evpred1(dom,x) for x in argl]
op is 'NOT => not evpred1(dom,first argl)
k := valuePosition(pred,$predicateList) => testBitVector(dom.3,k + 1)
op is 'HasAttribute =>
[arg,[.,a]] := argl
attPredIndex := LASSOC(a,dom.2)
null attPredIndex => nil
attPredIndex = 0 => true
testBitVector(domainPredicates dom,attPredIndex)
nil
pred is 'T => true
systemError '"unknown atomic predicate form"