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-saturn.boot <================================ 35-- New file as of 6/95 36$atLeastOneUnexposed := false 37 38page() == $curPage 39 40--======================================================================= 41-- Functions that affect $saturnPage 42--======================================================================= 43 44--------------------> OLD DEFINITION (override in br-util.boot) 45htSay(x) == 46 bcHt(x) 47 48htSayCold x == 49 htSay '"\lispLink{}{" 50 htSay x 51 htSay '"}" 52 53htSayStandard(x) == --do AT MOST for $standard 54 bcHt(x) 55 56htSayStandardList(lx) == 57 htSayList(lx) 58 59htSayList(lx) == 60 for x in lx repeat bcHt(x) 61 62--------------------> NEW DEFINITION (override in ht-util.boot) 63bcHt line == 64 $newPage => --this path affects both saturn and old lines 65 text := 66 PAIRP line => [['text, :line]] 67 STRINGP line => line 68 [['text, line]] 69 htpAddToPageDescription($curPage, text) 70 PAIRP line => 71 $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) 72 $htLineList := [basicStringize line, :$htLineList] 73 74--======================================================================= 75-- New issueHT 76--======================================================================= 77 78--------------------> NEW DEFINITION (see ht-util.boot) 79htShowPage() == 80-- show the page which has been computed 81 htSayStandard '"\endscroll" 82 htShowPageNoScroll() 83 84htShowPageNoScroll() == 85-- show the page which has been computed 86 htSayStandard '"\autobuttons" 87 htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) 88 $newPage := false 89 $htLineList := nil 90 htMakePage htpPageDescription $curPage 91 if $htLineList then line := concatenateStringList(nreverse $htLineList) 92 issueHTStandard line 93 endHTPage() 94 95 96issueHTStandard line == --called by htMakePageNoScroll and htMakeErrorPage 97 sockSendInt($MenuServer, $SendLine) 98 sockSendString($MenuServer, line) 99 100--------------------> NEW DEFINITION (override in ht-util.boot) 101htMakeErrorPage htPage == 102 $newPage := false 103 $htLineList := nil 104 $curPage := htPage 105 htMakePage htpPageDescription htPage 106 line := concatenateStringList(nreverse $htLineList) 107 issueHT line 108 endHTPage() 109 110--======================================================================= 111-- htMakePage and friends 112--======================================================================= 113 114--------------------> NEW DEFINITION (override in ht-util.boot) 115htMakePage itemList == 116 if $newPage then 117 htpAddToPageDescription($curPage, itemList) 118 htMakePage1 itemList 119 120--------------------> NEW DEFINITION (override in ht-util.boot) 121htMakePage1 itemList == 122-- make a page given the description in itemList 123 for u in itemList repeat 124 itemType := 'text 125 items := 126 STRINGP u => u 127 ATOM u => STRINGIMAGE u 128 STRINGP first u => u 129 u is ['text, :s] => s 130 itemType := first u 131 rest u 132 itemType = 'text => iht items 133 itemType = 'lispLinks => htLispLinks items 134 itemType = 'lispmemoLinks => htLispMemoLinks items 135 itemType = 'bcLinks => htBcLinks(items) 136 itemType = 'bcLispLinks => htBcLispLinks items ---> 137 itemType = 'radioButtons => htRadioButtons items 138 itemType = 'bcRadioButtons => htBcRadioButtons items 139 itemType = 'inputStrings => htInputStrings items 140 itemType = 'domainConditions => htProcessDomainConditions items 141 itemType = 'bcStrings => htProcessBcStrings items 142 itemType = 'toggleButtons => htProcessToggleButtons items 143 itemType = 'bcButtons => htProcessBcButtons items 144 itemType = 'doneButton => htProcessDoneButton items 145 itemType = 'doitButton => htProcessDoitButton items 146 systemError '"unexpected branch" 147 148menuButton() == '"\menuitemstyle{}" 149 150 151endHTPage() == 152 sockSendInt($MenuServer, $EndOfPage) 153 154htSayHrule() == bcHt 155 '"\horizontalline{}\newline{}" 156 157htpAddInputAreaProp(htPage, label, prop) == 158 SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) 159 160htpSetLabelInputString(htPage, label, val) == 161 -- value user typed as input string on page 162 props := LASSOC(label, htpInputAreaAlist htPage) 163 props => SETELT(props, 0, STRINGIMAGE val) 164 nil 165 166--------------------> NEW DEFINITION (override in ht-util.boot) 167htDoneButton(func, htPage, :optionalArgs) == 168------> Handle argument values passed from page if present 169 if optionalArgs then 170 htpSetInputAreaAlist(htPage, first optionalArgs) 171 typeCheckInputAreas htPage => 172 htMakeErrorPage htPage 173 NULL FBOUNDP func => 174 systemError ['"unknown function", func] 175 FUNCALL(SYMBOL_-FUNCTION func, htPage) 176 177--------------------> NEW DEFINITION (override in ht-util.boot) 178htBcLinks(links) == 179 [links,options] := beforeAfter('options,links) 180 for [message, info, func, :value] in links repeat 181 link := '"\lispdownlink" 182 htMakeButton(link, message, mkCurryFun(func, value)) 183 bcIssueHt info 184 185--------------------> NEW DEFINITION (override in ht-util.boot) 186htBcLispLinks links == 187 [links,options] := beforeAfter('options,links) 188 for [message, info, func, :value] in links repeat 189 link := 190 '"\lisplink" 191 htMakeButton(link ,message, mkCurryFun(func, value)) 192 bcIssueHt info 193 194htMakeButton(htCommand, message, func) == 195 iht [htCommand, '"{"] 196 bcIssueHt message 197 iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] 198 for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat 199 iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] 200 if type = 'string then 201 iht ['"_"\stringvalue{", id, '"}_""] 202 else 203 iht ['"_"\boxvalue{", id, '"}_""] 204 iht '") " 205 iht [htpName $curPage, '"))}"] 206 207htpAddToPageDescription(htPage, pageDescrip) == 208 newDescript := 209 STRINGP pageDescrip => [pageDescrip, :ELT(htPage, 7)] 210 nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7)) 211 SETELT(htPage, 7, newDescript) 212 213 214--------------------> NEW DEFINITION (override in ht-util.boot) 215htProcessBcStrings strings == 216 for [numChars, default, stringName, spadType, :filter] in strings repeat 217 mess2 := '"" 218 if NULL LASSOC(stringName, htpInputAreaAlist page()) then 219 setUpDefault(stringName, ['string, default, spadType, filter]) 220 if htpLabelErrorMsg(page(), stringName) then 221 iht ['"\centerline{{\em ", htpLabelErrorMsg(page(), stringName), '"}}"] 222 mess2 := CONCAT(mess2, bcSadFaces()) 223 htpSetLabelErrorMsg(page(), stringName, nil) 224 iht ['"\inputstring{", stringName, '"}{", 225 numChars, '"}{", htpLabelDefault(page(),stringName), '"} ", mess2] 226 227--------------------> NEW DEFINITION (override in ht-util.boot) 228setUpDefault(name, props) == 229 htpAddInputAreaProp(page(), name, props) 230 231--------------------> NEW DEFINITION (override in ht-util.boot) 232htInitPage(title, propList) == 233-- start defining a hyperTeX page 234 page := htInitPageNoScroll(propList, title) 235 htSayStandard '"\beginscroll " 236 page 237 238--------------------> NEW DEFINITION <-------------------------- 239htInitPageNoScroll(propList, title) == 240--start defining a hyperTeX page 241 page := htInitPageNoHeading(propList) 242 htSayStandard ['"\begin{page}{", htpName page, '"}{"] 243 htSay title 244 htSayStandard '"} " 245 page 246 247--------------------> NEW DEFINITION <-------------------------- 248htInitPageNoHeading(propList) == 249--start defining a hyperTeX page 250 $atLeastOneUnexposed := nil 251 page := htpMakeEmptyPage(propList) 252 $curPage := page 253 $newPage := true 254 $htLineList := nil 255 page 256 257--------------------> NEW DEFINITION <-------------------------- 258htpMakeEmptyPage(propList) == 259 name := GENTEMP() 260 $activePageList := [name, :$activePageList] 261 SET(name, val := VECTOR(name, nil, nil, nil, nil, nil, propList, nil)) 262 val 263 264--======================================================================= 265-- Redefinitions from br-con.boot 266--======================================================================= 267kPage(line, options) == --any cat, dom, package, default package 268--constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) 269 parts := dbXParts(line,7,1) 270 [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts 271 form := IFCAR options 272 isFile := null kind 273 kind := kind or '"package" 274 RPLACA(parts,kind) 275 conform := mkConform(kind,name,args) 276 conname := opOf conform 277 capitalKind := capitalize kind 278 signature := ncParseFromString sig 279 sourceFileName := dbSourceFile INTERN name 280 constrings := 281 IFCDR form => dbConformGenUnder form 282 [STRCONC(name,args)] 283 emString := ['"{\sf ",:constrings,'"}"] 284 heading := [capitalKind,'" ",:emString] 285 if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] 286 if name=abbrev then abbrev := asyAbbreviation(conname,nargs) 287 page := htInitPageNoHeading(nil) 288 htAddHeading heading 289 htSayStandard("\beginscroll ") 290 htpSetProperty(page,'isFile,true) 291 htpSetProperty(page,'parts,parts) 292 htpSetProperty(page,'heading,heading) 293 htpSetProperty(page,'kind,kind) 294 if asharpConstructorName? conname then 295 htpSetProperty(page,'isAsharpConstructor,true) 296 htpSetProperty(page,'conform,conform) 297 htpSetProperty(page,'signature,signature) 298 ---what follows is stuff from kiPage with domain = nil 299 $conformsAreDomains := nil 300 dbShowConsDoc1(page,conform,nil) 301 if kind ~= 'category and nargs > 0 then addParameterTemplates(page,conform) 302 if $atLeastOneUnexposed then htSay '"\newline{}{\em *} = unexposed" 303 htSayStandard("\endscroll ") 304 kPageContextMenu page 305 htShowPageNoScroll() 306 307kPageContextMenu page == 308 [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) 309 conform := htpProperty(page,'conform) 310 conname := opOf conform 311 htBeginTable() 312 htSay '"{" 313 htMakePage [['bcLinks,['Ancestors,'"",'kcaPage,nil]]] 314 if kind = '"category" then 315 htSay '"}{" 316 htMakePage [['bcLinks,['Children,'"",'kccPage,nil]]] 317 if not asharpConstructorName? conname then 318 htSay '"}{" 319 htMakePage [['bcLinks,['Dependents,'"",'kcdePage,nil]]] 320 if kind = '"category" then 321 htSay '"}{" 322 htMakePage [['bcLinks,['Descendents,'"",'kcdPage,nil]]] 323 if kind = '"category" then 324 htSay '"}{" 325 if not asharpConstructorName? conname then 326 htMakePage [['bcLinks,['Domains,'"",'kcdoPage,nil]]] 327 else htSay '"{\em Domains}" 328 htSay '"}{" 329 if kind ~= '"category" and (pathname := dbHasExamplePage conname) 330 then htMakePage [['bcLinks,['Examples,'"",'kxPage,pathname]]] 331 else htSay '"{\em Examples}" 332 htSay '"}{" 333 htMakePage [['bcLinks,['Exports,'"",'kePage,nil]]] 334 htSay '"}{" 335 htMakePage [['bcLinks,['Operations,'"",'koPage,'"operation"]]] 336 htSay '"}{" 337 htMakePage [['bcLinks,['Parents,'"",'kcpPage,'"operation"]]] 338 if kind ~= '"category" then 339 htSay '"}{" 340 if not asharpConstructorName? conname 341 then htMakePage [['bcLinks,["Search Path",'"",'ksPage,nil]]] 342 else htSay '"{\em Search Path}" 343 if kind ~= '"category" then 344 htSay '"}{" 345 htMakePage [['bcLinks,['Users,'"",'kcuPage,nil]]] 346 htSay '"}{" 347 htMakePage [['bcLinks,['Uses,'"",'kcnPage,nil]]] 348 htSay '"}" 349 htEndTable() 350 351--------------------> NEW DEFINITION (see br-con.boot) 352dbPresentCons(htPage,kind,:exclusions) == 353 htpSetProperty(htPage,'exclusion,first exclusions) 354 cAlist := htpProperty(htPage,'cAlist) 355 empty? := null cAlist 356 one? := null rest cAlist 357 one? := empty? or one? 358 exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 359 star? := true --always include information on exposed/unexposed 4/92 360 htBeginTable() 361 htSay '"{" 362 if one? or member('abbrs,exclusions) 363 then htSay '"{\em Abbreviations}" 364 else htMakePage [['bcLispLinks,['"Abbreviations",'"",'dbShowCons,'abbrs]]] 365 htSay '"}{" 366 if one? or member('conditions, exclusions) or 367 and/[rest x = true for x in cAlist] 368 then htSay '"{\em Conditions}" 369 else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowCons,'conditions]]] 370 htSay '"}{" 371 if empty? or member('documentation,exclusions) 372 then htSay '"{\em Descriptions}" 373 else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowCons,'documentation]]] 374 htSay '"}{" 375 if one? or null rest cAlist 376 then htSay '"{\em Filter}" 377 else htMakePage 378 [['bcLinks,['"Filter",'"",'htFilterPage,['dbShowCons,'filter]]]] 379 htSay '"}{" 380 if one? or member('kinds,exclusions) or kind ~= 'constructor 381 then htSay '"{\em Kinds}" 382 else htMakePage [['bcLispLinks,['"Kinds",'"",'dbShowCons,'kinds]]] 383 htSay '"}{" 384 if one? or member('names,exclusions) 385 then htSay '"{\em Names}" 386 else htMakePage [['bcLispLinks,['"Names",'"",'dbShowCons,'names]]] 387 htSay '"}{" 388 if one? or member('parameters, exclusions) or not(or/[CDAR x for x in cAlist]) 389 then htSay '"{\em Parameters}" 390 else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowCons,'parameters]]] 391 htSay '"}{" 392 if $exposedOnlyIfTrue 393 then 394 htMakePage([['bcLinks, ['"Unexposed Also", '"", 'dbShowCons, 395 'exposureOff]]]) 396 else 397 if one? 398 then htSay '"{\em Exposed Only}" 399 else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowCons,'exposureOn]]] 400 htSay '"}" 401 htEndTable() 402 403htFilterPage(htPage,args) == 404 htInitPage("Filter String",htCopyProplist htPage) 405 htSay "\centerline{Enter filter string (use {\em *} for wild card):}" 406 htSay '"\centerline{" 407 htMakePage [['bcStrings, [50,'"",'filter,'EM]]] 408 htSay '"}\vspace{1}\centerline{" 409 htMakePage [['bcLispLinks,['"\fbox{Filter}",'"",:args]]] 410 htSay '"}" 411 htShowPage() 412 413dbShowConsKinds cAlist == 414 cats := doms := paks := defs := nil 415 for x in cAlist repeat 416 op := CAAR x 417 kind := dbConstructorKind op 418 kind = 'category => cats := [x,:cats] 419 kind = 'domain => doms := [x,:doms] 420 kind = 'package => paks := [x,:paks] 421 defs := [x,:defs] 422 lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] 423 htBeginMenu 'description 424 htSayStandard '"\indent{1}" 425 kinds := +/[1 for x in lists | #x > 0] 426 for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat 427 htSayStandard '"\item" 428 if kinds = 1 429 then htSay menuButton() 430 else htMakePage 431 [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] 432 htSayStandard '"\tab{1}" 433 htSayList(['"{\em ", c := #x, '" "]) 434 htSay(c > 1 => pluralize kind; kind) 435 htSay '":}" 436 bcConTable REMDUP [CAAR y for y in x] 437 htEndMenu 'description 438 htSayStandard '"\indent{0}" 439 440addParameterTemplates(page, conform) == 441---------------> from kPage <----------------------- 442 parlist := [STRINGIMAGE par for par in rest conform] 443 manuelsCode? := "MAX"/[#s for s in parlist] > 10 444 w := (manuelsCode? => 55; 23) 445 htSay '"Optional argument value" 446 htSay 447 rest parlist => '"s:" 448 '":" 449 odd := false 450 for parname in $PatternVariableList for par in rest conform repeat 451 htSayStandard (odd or manuelsCode? => "\newline";"\tab{29}") 452 odd := not odd 453 argstring := 454 $conArgstrings is [a,:r] => ($conArgstrings := r; a) 455 '"" 456 htMakePage [['text,'"{\em ",par,'"} = "], 457 ['bcStrings,[w - #STRINGIMAGE par,argstring,parname,'EM]]] 458 459--------------------> NEW DEFINITION (see br-con.boot) 460kPageArgs([op,:args],[.,.,:source]) == 461 firstTime := true 462 coSig := rest GETDATABASE(op,'COSIG) 463 for x in args for t in source for pred in coSig repeat 464 if firstTime then firstTime := false 465 else 466 htSayStandard '", and" 467 htSayStandard '"\newline " 468 typeForm := (t is [":",.,t1] => t1; t) 469 if pred = true 470 then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] 471 else htSayList(['"{\em ", x, '"}"]) 472 htSayStandardList(['"\tab{", STRINGIMAGE( # PNAME x), '"}, "]) 473 htSay 474 pred => '"a domain of category " 475 '"an element of the domain " 476 bcConform(typeForm,true) 477 478--======================================================================= 479-- Redefinitions from br-op1.boot 480--======================================================================= 481--------------------> NEW DEFINITION (see br-op1.boot) 482dbConform form == 483--one button for the main constructor page of a type 484 ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] 485 486--------------------> NEW DEFINITION (see br-op1.boot) 487htTab s == htSayStandardList(['"\tab{", s, '"}"]) 488 489--------------------> NEW DEFINITION (see br-op1.boot) 490dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == 491 which ~= '"operation" => BREAK() 492 single? := null rest data 493 htBeginMenu 'description 494 bincount := 0 495 for [thing,exposeFlag,:items] in data repeat 496 htSayStandard ('"\item") 497 if single? then htSay(menuButton()) 498 else 499 htMakePage 500 [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] 501 button := mkButtonBox (1 + bincount) 502 htSay '"{\em " 503 htSay 504 thing = 'nowhere => '"implemented nowhere" 505 thing = 'constant => '"constant" 506 thing = '_$ => '"by the domain" 507 INTEGERP thing => '"unexported" 508 constructorIfTrue => 509 htSay word 510 atom thing => '" an unknown constructor" 511 '"" 512 atom thing => '"unconditional" 513 '"" 514 htSay '"}" 515 if null atom thing then 516 if constructorIfTrue then 517 htSayList(['" {\em ", dbShowKind thing, '"}"]) 518 htSay '" " 519 FUNCALL(fn,thing) 520 htSay('":\newline ") 521 dbShowOpSigList(which,items,(1 + bincount) * 8192) 522 bincount := bincount + 1 523 htEndMenu 'description 524 525--------------------> NEW DEFINITION (see br-op1.boot) 526dbPresentOps(htPage, which, exclusion) == 527 which ~= '"operation" => BREAK() 528 exclusions := [exclusion] 529 asharp? := htpProperty(htPage,'isAsharpConstructor) 530 fromConPage? := (conname := opOf htpProperty(htPage,'conform)) 531 usage? := nil 532 star? := not fromConPage? or which = '"package operation" 533 implementation? := not asharp? and 534 $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? 535 rightmost? := star? or (implementation? and not $includeUnexposed?) 536 if INTEGERP first exclusions then exclusions := ['documentation] 537 htpSetProperty(htPage,'exclusion,first exclusions) 538 opAlist := 539 which = '"operation" => htpProperty(htPage,'opAlist) 540 htpProperty(htPage,'attrAlist) 541 empty? := null opAlist 542 one? := opAlist is [entry] and 2 = #entry 543 one? := empty? or one? 544 htBeginTable() 545 htSay '"{" 546 if one? or member('conditions,exclusions) 547 or (htpProperty(htPage,'condition?) = 'no) 548 then htSay '"{\em Conditions}" 549 else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowOps,which,'conditions]]] 550 htSay '"}{" 551 if empty? or member('documentation,exclusions) 552 then htSay '"{\em Descriptions}" 553 else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowOps,which,'documentation]]] 554 htSay '"}{" 555 if null IFCDR opAlist 556 then htSay '"{\em Filter}" 557 else htMakePage [['bcLinks,['"Filter ",'"",'htFilterPage,['dbShowOps,which,'filter]]]] 558 htSay '"}{" 559 if one? or member('names,exclusions) or null IFCDR opAlist 560 then htSay '"{\em Names}" 561 else htMakePage [['bcLispLinks,['"Names",'"",'dbShowOps,which,'names]]] 562 if not star? then 563 htSay '"}{" 564 which = '"attribute" => BREAK() 565 if not(implementation?) or member('implementation, exclusions) or 566 ((conname := opOf htpProperty(htPage,'conform)) 567 and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) 568 then htSay '"{\em Implementations}" 569 else htMakePage 570 [['bcLispLinks,['"Implementations",'"",'dbShowOps,which,'implementation]]] 571 htSay '"}{" 572 if one? or member('origins,exclusions) 573 then htSay '"{\em Origins}" 574 else htMakePage [['bcLispLinks,['"Origins",'"",'dbShowOps,which,'origins]]] 575 htSay '"}{" 576 if one? or member('parameters,exclusions) --also test for some parameter 577 or not dbDoesOneOpHaveParameters? opAlist 578 then htSay '"{\em Parameters}" 579 else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowOps,which,'parameters]]] 580 htSay '"}{" 581 which = '"attribute" => BREAK() 582 if one? or member('signatures, exclusions) 583 then htSay '"{\em Signatures}" 584 else htMakePage [['bcLispLinks,['"Signatures",'"",'dbShowOps,which,'signatures]]] 585 htSay '"}" 586 if star? then 587 htSay '"{" 588 if $exposedOnlyIfTrue 589 then 590 htMakePage([['bcLinks, ['"Unexposed Also", '"", 'dbShowOps, 591 which, 'exposureOff]]]) 592 else if one? 593 then htSay '"{\em Exposed Only}" 594 else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowOps, which,'exposureOn]]] 595 htSay '"}" 596 htEndTable() 597 598--======================================================================= 599-- Redefinitions from br-search.boot 600--======================================================================= 601---------------------> OLD DEFINITION (override in br-search.boot) 602htShowPageStar() == 603 htSayStandard '"\endscroll " 604 if $exposedOnlyIfTrue then 605 htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] 606 else 607 htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] 608 htShowPageNoScroll() 609 610--======================================================================= 611-- Redefinitions from br-op2.boot 612--======================================================================= 613 614--------------> NEW DEFINITION (see br-op2.boot) 615displayDomainOp(htPage,which,origin,op,sig,predicate, 616 doc,index,chooseFn,unexposed?,$generalSearch?) == 617 $chooseDownCaseOfType : local := true --see dbGetContrivedForm 618 $whereList : local := nil 619 $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) 620 $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) 621 $FunctionList:local := '(f g h d e F G H) 622 $DomainList: local := '(D R S E T A B C M N P Q U V W) 623 exactlyOneOpSig := null index 624 conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) 625 or origin 626 if $generalSearch? then $DomainList := rest $DomainList 627 opform := 628 which = '"attribute" => BREAK() 629 which = '"constructor" => origin 630 dbGetDisplayFormForOp(op,sig,doc) 631 htSayStandard('"\newline") 632 ----------------------------------------------------------- 633 if exactlyOneOpSig 634 then htSay menuButton() 635 else htMakePage 636 [['bcLinks,[menuButton(),'"",chooseFn,which,index]]] 637 htSayStandard '"\tab{2}" 638 op := IFCAR opform 639 args := IFCDR opform 640 ops := escapeSpecialChars STRINGIMAGE op 641 n := #sig 642 do 643 n = 2 and GETL(op, 'Nud) => 644 htSayList([ops, '" {\em ", quickForm2HtString IFCAR args, '"}"]) 645 n = 3 and GETL(op, 'Led) => 646 htSayList(['"{\em ", quickForm2HtString IFCAR args, '"} ", ops, 647 '" {\em ", quickForm2HtString IFCAR IFCDR args, '"}"]) 648 if unexposed? and $includeUnexposed? then 649 htSayUnexposed() 650 htSay(ops) 651 predicate='ASCONST or GETDATABASE(op,'NILADIC) or member(op,'(0 1)) => 'skip 652 which = '"attribute" => BREAK() 653 htSay('"(") 654 if IFCAR args then 655 htSayList(['"{\em ", quickForm2HtString IFCAR args, '"}"]) 656 for x in IFCDR args repeat 657 htSayList(['",{\em ", quickForm2HtString x, '"}"]) 658 htSay('")") 659 -----------prepare to print description--------------------- 660 constring := form2HtString conform 661 conname := first conform 662 $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" 663 or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) 664 $conlength : local := #constring 665 $conform : local := conform 666 $conargs : local := rest conform 667 if which = '"operation" then 668 $signature : local := 669 MEMQ(conname,$Primitives) => nil 670 CDAR getConstructorModemap conname 671 --RDJ: this next line is necessary until compiler bug is fixed 672 --that forgets to substitute #variables for t#variables; 673 --check the signature for SegmentExpansionCategory, e.g. 674 tvarlist := TAKE(# $conargs,$TriangleVariableList) 675 $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) 676 which = '"attribute" => BREAK() 677 $sig := 678 which = '"constructor" => sig 679 $conkind ~= '"package" => sig 680 symbolsUsed := [x for x in rest conform | IDENTP x] 681 $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) 682 getSubstSigIfPossible sig 683 ----------------------------------------------------------- 684 if member(which,'("operation" "constructor")) then 685 $displayReturnValue: local := nil 686 if args then 687 htSayStandard('"\newline\tab{2}{\em Arguments:}") 688 coSig := IFCDR GETDATABASE(op, 'COSIG) --check if op is constructor 689 for a in args for t in rest $sig repeat 690 htSayIndentRel2(15, true) 691 position := IFCAR relatives 692 relatives := IFCDR relatives 693 if IFCAR coSig and t ~= '(Type) 694 then htMakePage [['bcLinks,[a,'"",'kArgPage,a]]] 695 else htSayList(['"{\em ", form2HtString(a), '"}"]) 696 htSay ", " 697 coSig := IFCDR coSig 698 htSayValue t 699 htSayIndentRel2(-15, true) 700 htSayStandard('"\newline ") 701 if first $sig then 702 $displayReturnValue := true 703 htSayStandard('"\newline\tab{2}") 704 htSay '"{\em Returns:}" 705 htSayIndentRel2(15, true) 706 htSayValue first $sig 707 htSayIndentRel2(-15, true) 708 ----------------------------------------------------------- 709 if origin and ($generalSearch? or origin ~= conform) and op~=opOf origin then 710 htSayStandard('"\newline\tab{2}{\em Origin:}") 711 htSayIndentRel(15) 712 if not isExposedConstructor opOf origin and $includeUnexposed? 713 then htSayUnexposed() 714 bcConform(origin,true) 715 htSayIndentRel(-15) 716 ----------------------------------------------------------- 717 if not MEMQ(predicate,'(T ASCONST)) then 718 pred := sublisFormal(IFCDR conform, predicate) 719 count := #pred 720 htSayStandard('"\newline\tab{2}{\em Conditions:}") 721 for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat 722 htSayIndentRel2(15, count > 1) 723 bcPred(p,$conform,true) 724 htSayIndentRel2(-15, count > 1) 725 htSayStandard('"\newline ") 726 ----------------------------------------------------------- 727 if $whereList then 728 count := #$whereList 729 htSayStandard('"\newline\tab{2}{\em Where:}") 730 if assoc("$",$whereList) then 731 htSayIndentRel2(15, true) 732 htSayStandard '"{\em \$} is " 733 htSay 734 $conkind = '"category" => '"of category " 735 '"the domain " 736 bcConform(conform,true,true) 737 htSayIndentRel2(-15, true) 738 for [d,key,:t] in $whereList | d ~= "$" repeat 739 htSayIndentRel2(15, count > 1) 740 htSayList(["{\em ", d, "} is "]) 741 htSayConstructor(key, sublisFormal(IFCDR conform, t)) 742 htSayIndentRel2(-15, count > 1) 743 ----------------------------------------------------------- 744 if doc and (doc ~= '"" and (doc isnt [d] or d ~= '"")) then 745 htSayStandard('"\newline\tab{2}{\em Description:}") 746 htSayIndentRel(15) 747 if doc = $charFauxNewline then htSay $charNewline 748 else 749 ndoc:= 750 -- we are confused whether doc is a string or a list of strings 751 CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] 752 SUBSTITUTE($charNewline, $charFauxNewline,doc) 753 htSay ndoc 754 htSayIndentRel(-15) 755 --------> print abbr and source file for constructors <--------- 756 if which = '"constructor" then 757 if (abbr := GETDATABASE(conname,'ABBREVIATION)) then 758 htSayStandard('"\tab{2}{\em Abbreviation:}") 759 htSayIndentRel(15) 760 htSay abbr 761 htSayIndentRel(-15) 762 htSayStandard('"\newline{}") 763 htSayStandard('"\tab{2}{\em Source File:}") 764 htSayIndentRel(15) 765 htSaySourceFile conname 766 htSayIndentRel(-15) 767 768htSaySourceFile conname == 769 sourceFileName := (GETDATABASE(conname,'SOURCEFILE) or '"none") 770 filename := extractFileNameFromPath sourceFileName 771 htMakePage [['text,'"\unixcommand{",filename,'"}{_\$FRICAS/lib/SPADEDIT ", 772 sourceFileName, '" ", conname, '"}"]] 773 774--------------------> NEW DEFINITION (see br-op2.boot) 775htSayIndentRel(n) == htSayIndentRel2(n, false) 776 777htSayIndentRel2(n, flag) == 778 m := ABS n 779 if flag then m := m + 2 780 htSayStandard 781 n > 0 => 782 flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] 783 ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] 784 n < 0 => ['"\indent{0}\newline "] 785 786htSayUnexposed() == 787 htSay '"{\em *}" 788 $atLeastOneUnexposed := true 789--======================================================================= 790-- Page Operations 791--======================================================================= 792 793htBeginTable() == 794 htSayStandard '"\table{" 795 796htEndTable() == 797 htSayStandard '"}" 798 799htBeginMenu(kind) == 800 htSayStandard '"\beginmenu " 801 802htEndMenu(kind) == 803 htSayStandard '"\endmenu " 804 805htSayConstructorName(nameShown, name) == 806 htSayStandard ["\lispdownlink{",nameShown,'"}{(|conPage| '|",name,'"|)}"] 807 808--------------------> NEW DEFINITION (see ht-util.boot) 809htAddHeading(title) == 810 htNewPage title 811 page() 812 813------------> called by htAddHeading, htInitPageNoScroll <----------- 814htNewPage title == 815 htSayStandardList(['"\begin{page}{", htpName $curPage, '"}{"]) 816 htSayStandard title 817 htSayStandard '"}" 818 819--======================================================================= 820-- Utilities 821--======================================================================= 822 823htBlank() == 824 htSayStandard '"\space{1}" 825 826htBlanks(n) == 827 htSayStandard STRCONC('"\space{",STRINGIMAGE n,'"}") 828 829unTab s == 830 STRINGP s => unTab1 s 831 atom s => s 832 [unTab1 first s, :rest s] 833 834unTab1 s == 835 STRING_<('"\tab{", s) = 5 and (k := charPosition(char '_}, s, 4)) => 836 SUBSTRING(s, k + 1, nil) 837 s 838 839satBreak() == 840 htSayStandard '"\item " 841 842htBigSkip() == 843 htSayStandard '"\vspace{1}\newline " 844 845satDownLink(s,code) == 846 htSayStandard '"\lispdownlink{" 847 htSayStandard s 848 htSayStandard '"}{" 849 htSayStandard code 850 htSayStandard '"}" 851 852satTypeDownLink(s,code) == 853 htSayStandard '"\lispdownlink{" 854 htSayStandard s 855 htSayStandard '"}{" 856 htSayStandard code 857 htSayStandard '"}" 858 859mkButtonBox n == STRCONC('"\buttonbox{", STRINGIMAGE n, '"}") 860 861purgeNewConstructorLines(lines, conlist) == 862 [x for x in lines | not screenLocalLine(x, conlist)] 863 864screenLocalLine(line, conlist) == 865 k := dbKind line 866 con := INTERN 867 k = char 'o or k = char 'a => 868 s := dbPart(line,5,1) 869 k := charPosition(char '_(,s,1) 870 SUBSTRING(s,1,k - 1) 871 dbName line 872 MEMQ(con, conlist) 873 874--------------> NEW DEFINITION (see br-data.boot) 875purgeLocalLibdb() == --called by the user through a clear command? 876 $newConstructorList := nil 877 deleteFile '"libdb.text" 878