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