-- 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] [STRINGIMAGE opCount,'" ",:exposurePart, pluralize capitalize which,:namedPart] prefix := pluralSay(dataCount,what,whats) [:prefix,'" for ",STRINGIMAGE opCount,'" ",pluralize capitalize which,:namedPart] page := htInitPageNoScroll(htCopyProplist htPage) ------------>above line used to call htInitPageHoHeading<---------- htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) htpSetProperty(page,'data,data) htpSetProperty(page,'branch,branch) -- 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 ") FUNCALL(fn,page,opAlist,which,data) --apply branch function dbOpsExposureMessage() htSayStandard("\endscroll ") dbPresentOps(page,which,branch) htShowPageNoScroll() opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo() == null $exposedOnlyIfTrue or which 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 := op in '(Union Record Mapping) cosig := special => ['T 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 LISTP form 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 := FUNCALL(dataFunction,op,item)--get key item exposeFlag := --is the current op-sig exposed? null (r := rest rest item) => true --not given, assume yes r . 1 --is given, use value tail := item is [.,'ASCONST,:.] => 'ASCONST nil newEntry := u := assoc(entry,data) => --key seen before? look on DATA 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,reverse! others),SORTBY('CDDR, reverse! defexports),SORTBY('CDDR,reverse! 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 | FUNCALL(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,QLASSQ(conname,catOriginAlist) or true) catOriginAlist := insertAlist(conname,pred,catOriginAlist) pred := simpOrDumb(predicate,QLASSQ(conname,domOriginAlist) or true) domOriginAlist := insertAlist(conname,pred,domOriginAlist) --the following is similar to "domainsOf" but do not sort immediately u := [COPY key for [key,:.] in entries _*HASCATEGORY_-HASH_* | QLASSQ(rest key,catOriginAlist)] for pair in u repeat [dom,:cat] := pair QLASSQ(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,QLASSQ(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 symbolLassoc('Nud,PROPLIST op) => dbShowOpParameterJump(ops,which,count,single?) htSay('" {\em ",KAR args,'"}") n = 3 and symbolLassoc('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 = function IDENTITY => '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 := POSN1(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 := POSN1(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"