1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34--====================> WAS b-op1.boot <================================ 35 36--======================================================================= 37-- Operation Page Menu 38--======================================================================= 39--opAlist has form [[op,:alist],:.] where each alist 40-- has form [sig,pred,origin,exposeFlag,comments] 41 42dbFromConstructor?(htPage) == htpProperty(htPage,'conform) 43 44dbDoesOneOpHaveParameters? opAlist == 45 or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn == 46 STRINGP x => dbPart(x,2,1) ~= '"0" 47 IFCAR x 48--============================================================================ 49-- Master Switch Functions for Operation Views 50--============================================================================ 51 52dbShowOps(htPage, which, key) == 53 --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string 54 which := STRINGIMAGE which 55 which ~= '"operation" => BREAK() 56 if MEMQ(key,'(extended basic all)) then 57 $groupChoice := key 58 key := htpProperty(htPage,'key) or 'names 59 opAlist := htpProperty(htPage, 'opAlist) 60 key = 'generalise => 61 arg := STRINGIMAGE CAAR opAlist 62 oPage arg 63 key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which) 64 key = 'filter => 65 filter := pmTransFilter(dbGetInputString htPage) 66 filter is ['error,:.] => bcErrorPage filter 67 opAlist:= [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)] 68 null opAlist => emptySearchPage(which, filter, false) 69 htPage := htInitPageNoHeading(htCopyProplist htPage) 70 htpSetProperty(htPage, 'opAlist, opAlist) 71 if not (htpProperty(htPage, 'condition?) = 'no) then 72 dbResetOpAlistCondition(htPage,which,opAlist) 73 dbShowOps(htPage,which,htpProperty(htPage,'exclusion)) 74 htpSetProperty(htPage,'key,key) 75 if MEMQ(key,'(exposureOn exposureOff)) then 76 $exposedOnlyIfTrue := 77 key = 'exposureOn => 'T 78 nil 79 key := htpProperty(htPage,'exclusion) 80 dbShowOp1(htPage,opAlist,which,key) 81 82reduceByGroup(htPage,opAlist) == 83 not dbFromConstructor?(htPage) or null $groupChoice => opAlist 84 dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false) 85 bitNumber := HGET($topicHash,$groupChoice) 86 res := [[op,:newItems] for [op,:items] in opAlist | newItems] where 87 newItems == 88 null bitNumber => items 89 [x for x in items | FIXP (code := LASTATOM x) and LOGBITP(bitNumber,code)] 90 res 91 92dbShowOp1(htPage,opAlist,which,key) == 93 --set up for filtering below in dbGatherData 94 which ~= '"operation" => BREAK() 95 if INTEGERP key then 96 -- BREAK() 97 opAlist := dbSelectData(htPage,opAlist,key) 98 ------> Jump out for constructor names in file <-------- 99 INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile) 100 and constructor? con => return conPageChoose con 101 if INTEGERP key then 102 htPage := htInitPageNoHeading(htCopyProplist htPage) 103 htpSetProperty(htPage, 'opAlist, opAlist) 104 if not (htpProperty(htPage, 'condition?) = 'no) then 105 dbResetOpAlistCondition(htPage,which,opAlist) 106 dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) 107 if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then 108 --opAlist is expanded to form [[op,[sig,pred,origin,exposed,comments],...],...] 109 opAlist:=[item for [op,:items] in opAlist | item] where 110 item == 111 acc := nil 112 for x in items | x.3 repeat acc:= [x,:acc] 113 null acc => nil 114 [op,:NREVERSE acc] 115 $conformsAreDomains : local := htpProperty(htPage,'domname) 116 opCount := opAlistCount(opAlist, which) 117 branch := 118 INTEGERP key => 119 opCount <= $opDescriptionThreshold => 'documentation 120 'names 121 key = 'names and null rest opAlist => --means a single op 122 opCount <= $opDescriptionThreshold => 'documentation 123 'names 124 key 125 [what,whats,fn] := LASSOC(branch,$OpViewTable) 126 data := dbGatherData(htPage,opAlist,which,branch) 127 dataCount := +/[1 for x in data | (what = '"Name" and $exposedOnlyIfTrue => atom x; true)] 128 namedPart := 129 null rest opAlist => 130 ops := escapeSpecialChars STRINGIMAGE CAAR opAlist 131 ['" {\em ",ops,'"}"] 132 nil 133 if what = '"Condition" and null IFCAR IFCAR data then dataCount := dataCount - 1 134 exposurePart := 135 $exposedOnlyIfTrue => '(" Exposed ") 136 nil 137 firstPart := 138 opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which] 139 dataCount = 1 or dataCount = opCount => 140 opCount = 1 => [:exposurePart, capitalize which,:namedPart] 141 [STRINGIMAGE opCount,'" ",:exposurePart, 142 pluralize capitalize which,:namedPart] 143 prefix := pluralSay(dataCount,what,whats) 144 [:prefix,'" for ",STRINGIMAGE opCount,'" ",pluralize capitalize which,:namedPart] 145 page := htInitPageNoHeading(htCopyProplist htPage) 146 ------------>above line used to call htInitPageHoHeading<---------- 147 htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) 148 htpSetProperty(page,'data,data) 149 htpSetProperty(page,'branch,branch) 150 -- the only place where specialMessage property is set seems to be commented. out 151 if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) 152 htSayStandard('"\beginscroll ") 153 FUNCALL(fn,page,opAlist,which,data) --apply branch function 154 dbOpsExposureMessage() 155 htSayStandard("\endscroll ") 156 dbPresentOps(page,which,branch) 157 htShowPageNoScroll() 158 159opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo == 160 which = '"attribute" => BREAK() 161 null $exposedOnlyIfTrue => #items 162 +/[1 for w in items | null (p := CDDR w) or p . 1] 163 164dbShowOpHeading(heading, branch) == 165 suffix := 166-- branch = 'signatures => '" viewed as signatures" 167 branch = 'parameters => '" viewed with parameters" 168 branch = 'origins => '" organized by origins" 169 branch = 'conditions => '" organized by conditions" 170 '"" 171 [:heading, suffix] 172 173dbOpsExposureMessage() == 174 $atLeastOneUnexposed => htSay '"{\em *} = unexposed" 175 176fromHeading htPage == 177 null htPage => '"" 178 $pn := [htPage.0,'"}{"] 179 updomain := htpProperty(htPage,'updomain) => 180 dnForm := dbExtractUnderlyingDomain updomain 181 dnString:= form2StringList dnForm 182 dnFence := form2Fence dnForm 183-- upString:= form2StringList updomain 184 upFence := form2Fence updomain 185 upOp := PNAME opOf updomain 186 ['" {\em from} ",:dbConformGen dnForm,'" {\em under} \ops{",upOp,'"}{",:$pn,:upFence,'"}"] 187 domname := htpProperty(htPage,'domname) 188 numberOfUnderlyingDomains := #[x for x in rest GETDATABASE(opOf domname,'COSIG) | x] 189-- numberOfUnderlyingDomains = 1 and 190-- IFCDR domname and (dn := dbExtractUnderlyingDomain domname) => 191-- ['" {\em from} ",:pickitForm(domname,dn)] 192 IFCDR domname => ['" {\em from} ", :dbConformGen domname] 193 htpProperty(htPage,'fromHeading) 194 195-- pickitForm(form,uarg) == 196-- conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg) 197 198conform2StringList(form, opFn, argFn) == 199 [op1,:args] := form 200 op := IFCAR HGET($lowerCaseConTb,op1) or op1 201 null args => APPLY(opFn,[op]) 202 special := MEMQ(op,'(Union Record Mapping)) 203 cosig := 204 special => ['T for x in args] 205 rest GETDATABASE(op,'COSIG) 206 atypes := 207 special => cosig 208 rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) 209 sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == 210 keyword := 211 special and x is [":",y,t] => 212 x := t 213 y 214 nil 215 res := 216 pred => 217 STRINGP x => [x] 218 u := APPLY(argFn,[x]) 219 atom u and [u] or u 220 typ := sublisFormal(args,atype) 221 if x is ['QUOTE,a] then x := a 222 u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u] 223 NUMBERP x or STRINGP x => [x] 224 systemError() 225 keyword => [keyword,'": ",:res] 226 res 227 op = 'Mapping => dbMapping2StringList sargl 228 head := 229 special => [op] 230 APPLY(opFn,[form]) 231 [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"] 232 233 234dbMapping2StringList [target,:sl] == 235 null sl => target 236 restPart := 237 null rest sl => nil 238 "append"/[[",",:y] for y in rest sl] 239 sourcePart := 240 restPart => ['"(",:first sl,:restPart,'")"] 241 first sl 242 [:sourcePart,'" -> ",:target] 243 244dbOuttran form == 245 if LISTP form then 246 [op,:args] := form 247 else 248 op := form 249 args := nil 250 cosig := rest GETDATABASE(op,'COSIG) 251 atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) 252 argl := [fn for x in args for atype in atypes for pred in cosig] where fn == 253 pred => x 254 typ := sublisFormal(args,atype) 255 arg := 256 x is ['QUOTE,a] => a 257 x 258 res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) 259 NUMBERP res or STRINGP res => res 260 ['QUOTE,res] 261 [op,:argl] 262 263dbConformGen form == dbConformGen1(form,true) 264--many buttons: one for the type and one for each inner type 265--NOTE: must only be called on types KNOWN to be correct 266 267dbConformGenUnder form == dbConformGen1(form,false) 268--same as above, except buttons only for the inner types 269 270dbConformGen1(form,opButton?) == 271 opFunction := 272 opButton? => FUNCTION dbConform 273 FUNCTION conname2StringList 274 originalOp := opOf form 275 op := unAbbreviateIfNecessary opOf form 276 args := IFCDR form 277 form := 278 originalOp=op => form 279 [op, :args] 280 args => conform2StringList(form, opFunction, FUNCTION dbConformGen) 281 APPLY(opFunction,[form]) 282 283unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op 284 285conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form] 286 287--=========================================================================== 288-- Data Gathering Code 289--============================================================================ 290dbGatherData(htPage,opAlist,which,key) == 291 which ~= '"operation" => BREAK() 292 key = 'implementation => dbGatherDataImplementation(htPage,opAlist) 293 dataFunction := LASSOC(key,table) where 294 table == 295 $dbDataFunctionAlist or 296 ($dbDataFunctionAlist := [ 297 ['signatures,:function dbMakeSignature], 298 ['parameters,:function dbContrivedForm], 299 ['origins,:function dbGetOrigin], 300 ['domains,:function dbGetOrigin], 301 ['conditions,:function dbGetCondition]]) 302 null dataFunction => 303 --key= names or filter or documentation; do not expand 304 if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then 305 opAlist := --to get indexing correct 306 which = '"operation" => htpProperty(htPage,'opAlist) 307 htpProperty(htPage,'attrAlist) 308 acc := nil 309 initialExposure := 310 htPage and htpProperty(htPage,'conform) and which ~= '"package operation" 311 => true 312 --never star ops from a constructor 313 nil 314 for [op,:alist] in opAlist repeat 315 exposureFlag := initialExposure 316 while alist repeat 317 item := first alist 318 isExposed? := 319 STRINGP item => dbExposed?(item,char 'o) --unexpanded case 320 null (r := rest rest item) => true --assume true if unexpanded 321 r . 1 --expanded case 322 if isExposed? then return (exposureFlag := true) 323 alist := rest alist 324 node := 325 exposureFlag => op 326 [op,nil] 327 acc := [node,:acc] 328 NREVERSE acc 329 data := nil 330 dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in '(origins documentation),false) 331 --create data, a list of the form ((entry,exposeFlag,:entries)...) 332 for [op,:alist] in opAlist repeat 333 for item in alist repeat 334 entry := FUNCALL(dataFunction,op,item)--get key item 335 exposeFlag := --is the current op-sig exposed? 336 null (r := rest rest item) => true --not given, assume yes 337 r . 1 --is given, use value 338 tail := 339 item is [.,'ASCONST,:.] => 'ASCONST 340 nil 341 newEntry := 342 u := assoc(entry,data) => --key seen before? look on DATA 343 RPLACA(rest u, CADR u or exposeFlag)--yes, expose if any 1 is exposed 344 u 345 data := [y := [entry,exposeFlag,:tail],:data] 346 y --no, create new entry in DATA 347 if member(key,'(origins conditions)) then 348 r := CDDR newEntry 349 if atom r then r := nil --clear out possible 'ASCONST 350 RPLACD(rest newEntry, --store op/sigs under key if needed 351 insert([dbMakeSignature(op,item),exposeFlag,:tail],r)) 352 if member(key,'(origins conditions)) then 353 for entry in data repeat --sort list of entries (after the 2nd) 354 tail := CDDR entry 355 tail := 356 atom tail => tail 357 listSort(function LEXLESSEQP,tail) 358 RPLACD(rest entry, tail) 359 data := listSort(function LEXLESSEQP,data) 360 data 361 362dbGatherDataImplementation(htPage,opAlist) == 363--returns data, of form ((implementor exposed? entry entry...)... 364-- where entry has form ((op sig . implementor) . stuff) 365 conform := htpProperty(htPage,'conform) 366 domainForm := htpProperty(htPage,'domname) 367 dom := EVAL domainForm 368 which := '"operation" 369 [nam, :.] := domainForm 370 $predicateList: local := GETDATABASE(nam,'PREDICATES) 371 predVector := dom.3 372 u := getDomainOpTable2(dom, true, ASSOCLEFT opAlist) 373 --u has form ((op,sig,:implementor)...) 374 --sort into 4 groups: domain exports, unexports, default exports, others 375 376 for (x := [.,.,:key]) in u for i in 0.. repeat 377 key = domainForm => domexports := [x,:domexports] 378 INTEGERP key => unexports := [x,:unexports] 379 isDefaultPackageForm? key => defexports := [x,:defexports] 380 key = 'nowhere => nowheres := [x,:nowheres] 381 key = 'constant =>constants := [x,:constants] 382 others := [x,:others] --add chain domains go here 383 fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR, 384 NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where 385 fn l == 386 alist := nil 387 for u in l repeat 388 while u repeat 389 key := CDDAR u --implementor 390 entries := 391 [[first u, true], 392 :[u and [first u, true] while key = CDDAR(u := rest u)]] 393 alist := [[key,gn key,:entries],:alist] 394 NREVERSE alist 395 gn key == 396 atom key => true 397 isExposedConstructor first key 398 399dbSelectData(htPage,opAlist,key) == 400 branch := htpProperty(htPage,'branch) 401 data := htpProperty(htPage,'data) 402 MEMQ(branch,'(signatures parameters)) => 403 dbReduceOpAlist(opAlist,data.key,branch) 404 MEMQ(branch,'(origins conditions implementation)) => 405 key < 8192 => dbReduceOpAlist(opAlist,data.key,branch) 406 [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large 407 innerData := CDDR data.(newkey - 1) 408 dbReduceOpAlist(opAlist,innerData.binkey,'signatures) 409 [opAlist . key] 410 411dbReduceOpAlist(opAlist,data,branch) == 412 branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data) 413 branch = 'origins => dbReduceBySelection(opAlist, first data, function CADDR) 414 branch = 'conditions => 415 dbReduceBySelection(opAlist, first data, function CADR) 416 branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data) 417 branch = 'parameters => dbReduceByForm(opAlist, first data) 418 systemError ['"Unexpected branch: ",branch] 419 420dbReduceByOpSignature(opAlist,datalist) == 421--reduces opAlist by implementation datalist, one of the form 422-- (((op,sig,:implementor),:stuff),...) 423 ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.] 424 acc := nil 425 for [op,:alist] in opAlist | MEMQ(op,ops) repeat 426 entryList := [entry for (entry := [sig,:.]) in alist | test] where test == 427 or/[x for x in datalist | x is [[=op,=sig,:.],:.]] 428 entryList => acc := [[op,:NREVERSE entryList],:acc] 429 NREVERSE acc 430 431dbReduceBySignature(opAlist,op,sig) == 432--reduces opAlist to one with a fixed op and sig 433 [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]] 434 435dbReduceByForm(opAlist,form) == 436 acc := nil 437 for [op,:alist] in opAlist repeat 438 items := [x for x in alist | dbContrivedForm(op,x) = form] => 439 acc := [[op,:items],:acc] 440 NREVERSE acc 441 442dbReduceBySelection(opAlist,key,fn) == 443 acc := nil 444 for [op,:alist] in opAlist repeat 445 items := [x for x in alist | FUNCALL(fn,x) = key] => 446 acc := [[op,:items],:acc] 447 NREVERSE acc 448 449dbContrivedForm(op,[sig,:.]) == 450 dbMakeContrivedForm(op,sig) 451 452dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format 453 454dbGetOrigin(op,[.,.,origin,:.]) == origin 455 456dbGetCondition(op,[.,pred,:.]) == pred 457 458--============================================================================ 459-- Branches of Views 460--============================================================================ 461dbShowOpNames(htPage,opAlist,which,data) == 462 single? := opAlist and null rest data 463 single? => 464 ops := escapeSpecialChars STRINGIMAGE CAAR opAlist 465 htSayStandard('"Select a view below") 466 exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage) 467 dbShowOpItems(which,data,exposedOnly?) 468 469dbShowOpItems(which,data,exposedOnly?) == 470 htBeginTable() 471 for i in 0.. for item in data repeat 472 if atom item then 473 op := item 474 exposeFlag := true 475 else 476 [op,exposeFlag] := item 477 ops := escapeSpecialChars STRINGIMAGE op 478 exposeFlag or not exposedOnly? => 479 htSay('"{") 480 bcStarSpaceOp(ops,exposeFlag) 481 htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]] 482 htSay('"}") 483 htEndTable() 484 485dbShowOpAllDomains(htPage,opAlist,which) == 486 SAY("dbShowOpAllDomains") 487 BREAK() 488 dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) 489 catOriginAlist := nil --list of category origins 490 domOriginAlist := nil --list of domain origins 491 for [op,:items] in opAlist repeat 492 for [.,predicate,origin,:.] in items repeat 493 conname := first origin 494 GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => 495 pred := simpOrDumb(predicate, QLASSQ(conname, catOriginAlist) or true) 496 catOriginAlist := insertAlist(conname,pred,catOriginAlist) 497 pred := simpOrDumb(predicate, QLASSQ(conname, domOriginAlist) or true) 498 domOriginAlist := insertAlist(conname,pred,domOriginAlist) 499 --the following is similar to "domainsOf" but do not sort immediately 500 u := [COPY key for key in HKEYS($has_category_hash) 501 | QLASSQ(rest key, catOriginAlist)] 502 for pair in u repeat 503 [dom,:cat] := pair 504 QLASSQ(cat, catOriginAlist) = 'etc => RPLACD(pair, 'etc) 505 RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true)) 506 --now add all of the domains 507 for [dom,:pred] in domOriginAlist repeat 508 u := insertAlist(dom, simpOrDumb(pred, QLASSQ(dom, u) or true), u) 509 cAlist := listSort(function GLESSEQP,u) 510 for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair) 511 htpSetProperty(htPage,'cAlist,cAlist) 512 htpSetProperty(htPage,'thing,'"constructor") 513 htpSetProperty(htPage,'specialHeading,'"hoho") 514 dbShowCons(htPage,'names) 515 516simpOrDumb(new,old) == 517 new = 'etc => 'etc 518 atom new => old 519 'etc 520 521dbShowOpOrigins(htPage,opAlist,which,data) == 522 dbGatherThenShow(htPage,opAlist,which,data,true,'"from",function bcStarConform) 523 524dbShowOpImplementations(htPage,opAlist,which,data) == 525 $from_show_implementations : local := true 526 dbGatherThenShow(htPage, opAlist, which, data, true, '"by", 527 function bcStarConform) 528 529dbShowOpConditions(htPage,opAlist,which,data) == 530 dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred) 531 532dbShowKind conform == 533 conname := first conform 534 kind := GETDATABASE(conname,'CONSTRUCTORKIND) 535 kind = 'domain => 536 (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" 537 '"domain" 538 PNAME kind 539 540dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0) 541 542dbShowOpSigList(which,dataItems,count) == 543--dataItems is (((op,sig,:.),exposureFlag,...) 544 which ~= '"operation" => BREAK() 545 single? := null rest dataItems 546 htBeginTable() 547 for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat 548 ops := escapeSpecialChars STRINGIMAGE op 549 htSay '"{" 550 htSayExpose(ops,exposureFlag) 551 htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] 552 htSay '": " 553 if tail = 'ASCONST then 554 bcConform(first(sig)) 555 else 556 bcConform(['Mapping, :sig]) 557 htSay '"}" 558 count := count + 1 559 htEndTable() 560 count 561 562dbShowOpParameters(htPage,opAlist,which,data) == 563 single? := null rest data 564 count := 0 565 htBeginTable() 566 for item in data repeat 567 [opform,exposeFlag,:tail] := item 568 op := intern IFCAR opform 569 args := IFCDR opform 570 ops := escapeSpecialChars STRINGIMAGE op 571 htSay '"{" 572 htSayExpose(ops,exposeFlag) 573 n := #opform 574 do 575 n = 2 and GETL(op, 'Nud) => 576 dbShowOpParameterJump(ops,which,count,single?) 577 htSayList(['" {\em ", IFCAR args, '"}"]) 578 n = 3 and GETL(op, 'Led) => 579 htSayList(['"{\em ", IFCAR args, '"} "]) 580 dbShowOpParameterJump(ops,which,count,single?) 581 htSayList(['" {\em ", IFCAR IFCDR args, '"}"]) 582 dbShowOpParameterJump(ops,which,count,single?) 583 which = '"attribute" => BREAK() 584 tail = 'ASCONST or member(op,'(0 1)) => 'skip 585 htSay('"(") 586 if IFCAR args then htSayList(['"{\em ", IFCAR args, '"}"]) 587 for x in IFCDR args repeat 588 htSayList(['", {\em ", x, '"}"]) 589 htSay('")") 590 htSay '"}" 591 count := count + 1 592 htEndTable() 593 594dbShowOpParameterJump(ops,which,count,single?) == 595 single? => htSayList(['"{\em ", ops, '"}"]) 596 htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] 597 598dbShowOpDocumentation(htPage,opAlist,which,data) == 599 which ~= '"operation" => BREAK() 600 if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then 601 opAlist := htpProperty(htPage, 'opAlist) 602 conform := htpProperty(htPage, 'domname) or htpProperty(htPage, 'conform) 603 expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) 604 if expand then 605 condata := dbGatherData(htPage,opAlist,which,'conditions) 606 htpSetProperty(htPage,'conditionData,condata) 607 base := -8192 608 exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp 609 for [op,:alist] in opAlist repeat 610 base := 8192 + base 611 for item in alist for j in 0.. repeat 612 [sig,predicate,origin,exposeFlag,comments] := item 613 exposeFlag or not $exposedOnlyIfTrue => 614 if comments ~= '"" and STRINGP comments and (k := string2Integer comments) then 615 comments := 616 MEMQ(k,'(0 1)) => '"" 617 dbReadComments k 618 tail := CDDDDR item 619 RPLACA(tail,comments) 620 doc := (STRINGP comments and comments ~= '"" => comments; nil) 621 pred := predicate or true 622 index := (exactlyOneOpSig => nil; base + j) 623 displayDomainOp(htPage, '"operation", origin, op, sig, pred, 624 doc, index, 'dbChooseDomainOp, null(exposeFlag), true) 625 626dbChooseDomainOp(htPage,which,index) == 627 which ~= '"operation" => BREAK() 628 [opKey,entryKey] := DIVIDE(index,8192) 629 opAlist := 630 which = '"operation" => htpProperty(htPage,'opAlist) 631 htpProperty(htPage,'attrAlist) 632 [op,:entries] := opAlist . opKey 633 entry := entries . entryKey 634 htPage := htInitPageNoHeading(htCopyProplist(htPage)) 635 if which = '"operation" 636 then htpSetProperty(htPage,'opAlist,[[op,entry]]) 637 else htpSetProperty(htPage,'attrAlist,[[op,entry]]) 638 if not (htpProperty(htPage, 'condition?) = 'no) then 639 dbResetOpAlistCondition(htPage,which,opAlist) 640 dbShowOps(htPage,which,'documentation) 641 642htSayExpose(op, flag) == 643 $includeUnexposed? => 644 flag => htBlank() 645 op.0 = char '_* => htSay '"{\em *} " 646 htSayUnexposed() 647 htSay '"" 648--============================================================================ 649-- Branch-in From Other Places 650--============================================================================ 651dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists 652 which ~= '"operation" => BREAK() 653 $groupChoice := nil 654 conform := htpProperty(htPage,'conform) 655 --prepare opAlist for possible filtering of groups 656 if null BOUNDP '$topicHash then 657 $topicHash := MAKE_HASHTABLE('ID) 658 for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat 659 HPUT($topicHash,x,c) 660 domform := htpProperty(htPage,'domname) 661 if htpProperty(htPage, 'kind) = '"category" then 662 domform := false 663 if domform then 664 $conformsAreDomains : local := true 665 opAlist := reduceOpAlistForDomain(opAlist, domform, conform) 666 conform := domform or conform 667 kind := capitalize htpProperty(htPage,'kind) 668 exposePart := 669 isExposedConstructor opOf conform => '"" 670 '" Unexposed " 671 fromPart := 672 domform => evalableConstructor2HtString domform 673 form2HtString conform 674 heading := 675 ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"] 676 htpSetProperty(htPage, 'expandOperations, 'lists) 677 htpSetProperty(htPage,'fromHeading,heading) 678 reducedOpAlist := reduceByGroup(htPage, opAlist) 679 htpSetProperty(htPage, 'principalOpAlist, opAlist) 680 htpSetProperty(htPage, 'opAlist, reducedOpAlist) 681 if domform 682 then htpSetProperty(htPage,'condition?,'no) 683 else dbResetOpAlistCondition(htPage,which,opAlist) 684 dbShowOp1(htPage,reducedOpAlist,which,'names) 685 686reduceOpAlistForDomain(opAlist,domform,conform) == 687--destructively simplify all predicates; filter out any that fail 688 form1 := [domform,:rest domform] 689 form2 := ['$,:rest conform] 690 new_opAlist := [] 691 for pair in opAlist repeat 692 n_items := [test for item in rest pair | test] where test == 693 [head,:tail] := item 694 first tail = true => item 695 pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail) 696 null pred => false 697 RPLACD(item,[pred]) 698 item 699 if not(null(n_items)) then 700 n_pair := cons(first(pair), n_items) 701 new_opAlist := cons(n_pair, new_opAlist) 702 NREVERSE(new_opAlist) 703 704dbShowOperationLines(which,linelist) == --branch in with lines 705 which ~= '"operation" => BREAK() 706 htPage := htInitPage(nil,nil) --create empty page 707 opAlist := nil 708 lines := linelist 709 while lines repeat 710 name := dbName (x := first lines) 711 pile := [x] 712 while (lines := rest lines) and name = dbName (x := first lines) repeat 713 pile := [x,:pile] 714 opAlist := [[name,:NREVERSE pile],:opAlist] 715 -- sorting list of pairs (String, List(String)) 716 opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist) 717 if which = '"operation" 718 then htpSetProperty(htPage,'opAlist,opAlist) 719 else htpSetProperty(htPage,'attrAlist,opAlist) 720 expandProperty := 721 which = '"operation" => 'expandOperations 722 'expandAttributes 723 htpSetProperty(htPage,expandProperty,'strings) 724 dbResetOpAlistCondition(htPage,which,opAlist) 725 if which = '"attribute" then BREAK() 726 dbShowOp1(htPage,opAlist,which,'names) 727 728--============================================================================ 729-- Code to Expand opAlist 730--============================================================================ 731dbResetOpAlistCondition(htPage,which,opAlist) == 732 which ~= '"operation" => BREAK() 733 value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) 734 htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) 735 value 736 737dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) == 738--if condition? = true, stop when you find a non-trivial predicate 739--otherwise, expand in full 740--RETURNS: 741-- non-trivial predicate, if condition? = true and it finds one 742-- nil, otherwise 743--SIDE-EFFECT: this function references the "expand" property (set elsewhere): 744-- 'strings, if not fully expanded and it contains strings 745-- i.e. opAlist is ((op . (string ...))...) if unexpanded 746-- 'lists, if not fully expanded and it contains lists 747-- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded 748 which ~= '"operation" => BREAK() 749 condition? := condition? and not $exposedOnlyIfTrue 750 value := nil --return value 751 expandProperty := 752 which = '"operation" => 'expandOperations 753 'expandAttributes 754 expandFlag := htpProperty(htPage,expandProperty) 755 expandFlag = 'fullyExpanded => nil 756 expandFlag = 'strings => --strings are partially expanded 757 for pair in opAlist repeat 758 [op,:lines] := pair 759 acc := nil 760 for line in lines repeat 761 --NOTE: we must expand all lines here for a given op 762 -- since below we will change opAlist 763 --Case 1: Already expanded; just cons it onto ACC 764 null STRINGP line => --already expanded 765 if condition? then --this could have been expanded at a lower level 766 if null atom (pred := CADR line) then value := pred 767 acc := [line,:acc] --this one is already expanded; record it anyway 768 --Case 2: unexpanded; expand it then cons it onto ACC 769 [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1) 770 predicate := ncParseFromString pred 771 if condition? and null atom predicate then value := predicate 772 sig := ncParseFromString sigs --is (Mapping,:.) 773 if which = '"operation" then 774 if sig isnt ['Mapping,:.] 775 then sayBrightly ['"Unexpected signature for ",name,'": ",sigs] 776 else sig := rest sig 777 conname := intern dbNewConname line 778 origin := [conname,:getConstructorArgs conname] 779 exposeFlag := dbExposed?(line,char 'o) 780 acc := [[sig,predicate,origin,exposeFlag,comments],:acc] 781 --always store the fruits of our labor: 782 RPLACD(pair,NREVERSE acc) --at least partially expand it 783 condition? and value => return value --early exit 784 value => value 785 condition? => nil 786 htpSetProperty(htPage,expandProperty,'fullyExpanded) 787 expandFlag = 'lists => --lists are partially expanded 788 -- entry is [sig, predicate, origin, exposeFlag, comments] 789 $value: local := nil 790 $docTableHash := MAKE_HASHTABLE('EQUAL) 791 packageSymbol := false 792 domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) 793 if isDefaultPackageName opOf domform then 794 catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s) 795 packageSymbol := first rest domform 796 domform := [catname,:rest rest domform] --skip first argument ($) 797 docTable:= dbDocTable domform 798 for [op,:alist] in opAlist repeat 799 for [sig,:tail] in alist repeat 800 condition? => --the only purpose here is to find a non-trivial pred 801 null atom (pred := first tail) => return ($value := pred) 802 'skip 803 u := 804 tail is [.,origin,:.] and origin => 805-- must change any % into $ otherwise we will not pick up comments properly 806-- delete the SUBLISLIS when we fix on % or $ 807 dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,which,nil) 808 if packageSymbol then sig := substitute('_$, packageSymbol, sig) 809 dbGetDocTable(op,sig,docTable,which,nil) 810 origin := IFCAR u or origin 811 docCode := IFCDR u --> (doc . code) 812 which = '"attribute" => BREAK() 813 RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode]) 814 $value => return $value 815 $value => $value 816 condition? => nil 817 htpSetProperty(htPage,expandProperty,'fullyExpanded) 818 'done 819 820getRegistry(op,sig) == 821 u := GETDATABASE('AttributeRegistry,'DOCUMENTATION) 822 v := LASSOC(op,u) 823 match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match 824 '"" 825 826evalableConstructor2HtString domform == 827 if VECP domform then domform := devaluate domform 828 conname := first domform 829 coSig := rest GETDATABASE(conname,'COSIG) 830 --entries are T for arguments which are domains; NIL for computational objects 831 and/[x for x in coSig] => form2HtString(domform,nil,true) 832 arglist := [unquote x for x in rest domform] where 833 unquote arg == 834 arg is [f,:args] => 835 f = 'QUOTE => first args 836 [f,:[unquote x for x in args]] 837 arg 838 fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) 839--argtypes:= sublisFormal(arglist,fargtypes) 840 form2HtString([conname,:[fn for arg in arglist for x in coSig 841 for ftype in fargtypes]],nil,true) where 842 fn == 843 x => arg 844 typ := sublisFormal(arglist,ftype) 845 mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) 846 847fortexp0 x == 848 e_to_f := getFunctionFromDomain("expression2Fortran", ['FortranCodeTools], 849 [$OutputForm]) 850 f := SPADCALL(x, e_to_f) 851 p := position('"%l",f) 852 p < 0 => f 853 l := NIL 854 while p < 0 repeat 855 [t,:f] := f 856 l := [t,:l] 857 NREVERSE ['"...",:l] 858 859mathform2HtString form == escapeString 860 form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a) 861 form is ['BRACKET,['AGGLST,:arg]] => 862 if arg is ['construct,:r] then arg := r 863 arg := 864 atom arg => [arg] 865 [y for x in arg | y := (x is ['QUOTE,a] => a; x)] 866 tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg] 867 STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]") 868 form is ['BRACKET,['AGGLST,'QUOTE,arg]] => 869 if atom arg then arg := [arg] 870 tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] 871 STRCONC('"[",first arg,tailPart,'"]") 872 atom form => form 873 "STRCONC"/fortexp0 form 874 875--============================================================================ 876-- Getting Operations from Domain 877--============================================================================ 878 879getDomainOpTable(dom, fromIfTrue) == getDomainOpTable2(dom, fromIfTrue, []) 880 881getDomainOpTable2(dom, fromIfTrue, ops) == 882 $predEvalAlist : local := nil 883 $returnNowhereFromGoGet: local := true 884 domname := dom.0 885 conname := first domname 886 abb := getConstructorAbbreviation conname 887 opAlist := getOperationAlistFromLisplib conname 888 "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u 889 | ((null ops and (op1 := op)) or (op1 := memq(op, ops)))] 890 for [op,:u] in opAlist] where 891 memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One 892 MEMQ(op,ops) => op 893 EQ(op,'One) => MEMQ(1,ops) and 1 894 EQ(op,'Zero) => MEMQ(0,ops) and 0 895 false 896 fn == 897 sig1 := sublisFormal(rest domname,sig) 898 predValue := evalDomainOpPred(dom,pred) 899 info := 900 null predValue => 901 1 -- signifies not exported 902 null fromIfTrue => nil 903 cell := compiledLookup(op,sig1,dom) => 904 [f,:r] := cell 905 f = 'nowhere => 'nowhere --see replaceGoGetSlot 906 f = function makeSpadConstant => 'constant 907 f = function IDENTITY => 'constant 908 f = function newGoGet => substitute('_$, domname, devaluate first r) 909 null VECP r => systemError devaluateList r 910 substitute('_$, domname, devaluate r) 911 'nowhere 912 [sig1,:info] 913 914evalDomainOpPred2(dom, pred) == 915 $predicateList : local := GETDATABASE(first(dom.0), 'PREDICATES) 916 evalDomainOpPred(dom,pred) 917 918evalDomainOpPred(dom,pred) == process(dom,pred) where 919 process(dom,pred) == 920 u := convert(dom,pred) 921 u = 'T => true 922 evpred(dom,u) 923 convert(dom,pred) == 924 pred is [op,:argl] => 925 MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]] 926 MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]] 927 MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)] 928 op = 'has => 929 [arg,p] := argl 930 p is ['ATTRIBUTE,a] => BREAK() 931 ['HasCategory,arg,convertCatArg p] 932 systemError '"unknown predicate form" 933 pred = 'T => true 934 systemError nil 935 convertCatArg p == 936 atom p or #p = 1 => MKQ p 937 ['LIST,MKQ first p,:[convertCatArg x for x in rest p]] 938 evpred(dom,pred) == 939 k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) 940 evpred1(dom,pred) 941 evpred1(dom,pred) == 942 pred is [op,:argl] => 943 MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl] 944 MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl] 945 op = 'NOT => not evpred1(dom,first argl) 946 k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) 947 op = 'HasAttribute => BREAK() 948 nil 949 pred = 'T => true 950 systemError '"unknown atomic predicate form" 951