aboutsummaryrefslogtreecommitdiff
path: root/src/interp/br-saturn.boot.pamphlet
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-11-14 01:19:25 +0000
committerdos-reis <gdr@axiomatics.org>2007-11-14 01:19:25 +0000
commit62b279b28cf02d59e0f860aac46968223c43cfc3 (patch)
tree52b6bd0af8e2cbd1bcc5bc60fdaf1ee1c293d4b4 /src/interp/br-saturn.boot.pamphlet
parentfabbf02ee4b80241b75826536502c2d683e8462e (diff)
downloadopen-axiom-62b279b28cf02d59e0f860aac46968223c43cfc3.tar.gz
remove more pamphlets
Diffstat (limited to 'src/interp/br-saturn.boot.pamphlet')
-rw-r--r--src/interp/br-saturn.boot.pamphlet1919
1 files changed, 0 insertions, 1919 deletions
diff --git a/src/interp/br-saturn.boot.pamphlet b/src/interp/br-saturn.boot.pamphlet
deleted file mode 100644
index 212411af..00000000
--- a/src/interp/br-saturn.boot.pamphlet
+++ /dev/null
@@ -1,1919 +0,0 @@
-\documentclass{article}
-\usepackage{axiom}
-
-\title{\File{src/interp/br-saturn.boot} Pamphlet}
-\author{The Axiom Team}
-
-\begin{document}
-\maketitle
-\begin{abstract}
-\end{abstract}
-\eject
-\tableofcontents
-\eject
-
-\section{License}
-
-<<license>>=
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- All rights reserved.
---
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions are
--- met:
---
--- - Redistributions of source code must retain the above copyright
--- notice, this list of conditions and the following disclaimer.
---
--- - Redistributions in binary form must reproduce the above copyright
--- notice, this list of conditions and the following disclaimer in
--- the documentation and/or other materials provided with the
--- distribution.
---
--- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--- names of its contributors may be used to endorse or promote products
--- derived from this software without specific prior written permission.
---
--- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
--- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
--- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
--- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
--- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
--- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
--- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
--- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
--- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
--- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
--- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-@
-<<*>>=
-<<license>>
-
-import '"bc-util"
-)package "BOOT"
-
---====================> WAS b-saturn.boot <================================
--- New file as of 6/95
-$aixTestSaturn := false
---These will be set in patches.lisp:
---$saturn := false --true to write SATURN output to $browserOutputStream
---$standard:= true --true to write browser output on AIX
-$saturnAmpersand := '"\&\&"
-$saturnFileNumber --true to write DOS files for Thinkpad (testing only)
- := false
-$kPageSaturnArguments := nil --bound by $kPageSaturn
-$atLeastOneUnexposed := false
-$saturnContextMenuLines := nil
-$saturnContextMenuIndex := 0
-$saturnMacros := '(
- "\def\unixcommand#1#2{{\em #1}}"_
- "\def\lispFunctionLink#1#2{\lispLink[d]{#1}{{\bf #2}}}"_
- "\def\lispTypeLink#1#2{\lispLink[d]{#1}{{\sf #2}}}"_
- "\def\menuitemstyle{\menubutton}"_
- "\def\browseTitle#1{\windowTitle{#1}\section{#1}}"_
- "\def\ttrarrow{$\rightarrow$}"_
- "\def\spadtype#1{\lispLink[d]{\verb!(|spadtype| '|#1|)!}{\sf #1}}"_
- "\def\spad#1{{\em #1}}"_
- "\def\spadfun#1{{\em #1}}"_
- )
-$FormalFunctionParameterList := '(_#_#1 _#_#2 _#_#3 _#_#4 _#_#5 _#_#6 _#_#7 _#_#8 _#_#9 _#_#10 _#_#11 _#_#12 _#_#13 _#_#14 _#_#15)
-
-on() ==
- $saturn := true
- $standard := false
-off()==
- $saturn := false
- $standard := true
-
---=======================================================================
--- Function for testing SATURN output
---=======================================================================
--- protectedEVAL x ==
--- $saturn =>
--- protectedEVAL0(x, true, false)
--- if $aixTestSaturn then protectedEVAL0(x, false, true)
--- protectedEVAL1 x
---
---protectedEVAL0(x, $saturn, $standard) ==
--- protectedEVAL1 x
---
---protectedEVAL1 x ==
--- error := true
--- val := NIL
--- UNWIND_-PROTECT((val := saturnEVAL x; error := NIL),
--- error => (resetStackLimits(); sendHTErrorSignal()))
--- val
---
---saturnEVAL x ==
--- fn :=
--- $aixTestSaturn => '"/tmp/sat.text"
--- '"/windows/temp/browser.text"
--- $saturn =>
--- saturnEvalToFile(x, fn)
--- OBEY '"cat /tmp/sat.text"
--- EVAL x
-
-
---=======================================================================
--- Functions to write DOS files to disk
---=======================================================================
-ts(command) ==
- $saturn := true
- $saturnFileNumber := false
- $standard := false
- saturnEvalToFile(command, '"/tmp/sat.text")
-
-ut() ==
- $saturn := false
- $standard := true
- 'done
-
-onDisk() ==
- $saturnFileNumber := 1
- obey '"dosdir"
-
-offDisk() ==
- $saturnFileNumber := false
-
-page() ==
- $standard => $curPage
- $saturnPage
---=======================================================================
--- Functions that affect $saturnPage
---=======================================================================
-
---------------------> OLD DEFINITION (override in br-util.boot.pamphlet)
-htSay(x,:options) == --say for possibly both $saturn and standard code
- htSayBind(x, options)
-
-htSayCold x ==
- htSay '"\lispLink{}{"
- htSay x
- htSay '"}"
-
-htSayIfStandard(x, :options) == --do only for $standard
- $standard => htSayBind(x,options)
-
-htSayStandard(x, :options) == --do AT MOST for $standard
- $saturn: local := nil
- htSayBind(x, options)
-
-htSaySaturn(x, :options) == --do AT MOST for $saturn
- $standard: local := nil
- htSayBind(x, options)
-
-htSayBind(x, options) ==
- bcHt x
- for y in options repeat bcHt y
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-bcHt line ==
- $newPage => --this path affects both saturn and old lines
- text :=
- PAIRP line => [['text, :line]]
- STRINGP line => line
- [['text, line]]
- if $saturn then htpAddToPageDescription($saturnPage, text)
- if $standard then htpAddToPageDescription($curPage, text)
- PAIRP line =>
- $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList)
- $htLineList := [basicStringize line, :$htLineList]
-
---=======================================================================
--- New issueHT
---=======================================================================
-
---------------------> NEW DEFINITION (see ht-util.boot.pamphlet)
-htShowPage() ==
--- show the page which has been computed
- htSayStandard '"\endscroll"
- htShowPageNoScroll()
-
-------------------> NEW DEFINITION (see ht-util.boot.pamphlet)
-htShowPageNoScroll() ==
--- show the page which has been computed
- htSayStandard '"\autobuttons"
- if $standard then
- htpSetPageDescription($curPage, nreverse htpPageDescription $curPage)
- if $saturn then
- htpSetPageDescription($saturnPage, nreverse htpPageDescription $saturnPage)
- $newPage := false
- ----------------------
- if $standard then
- $htLineList := nil
- htMakePage htpPageDescription $curPage
- if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList)
- issueHTStandard line
- ----------------------
- if $saturn then
- $htLineList := nil
- htMakePage htpPageDescription $saturnPage
- if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList)
- issueHTSaturn line
- ----------------------
- endHTPage()
-
---------------------> NEW DEFINITION <--------------------------
-issueHTSaturn line == --called by htMakePageNoScroll and htMakeErrorPage
- if $saturn then
- $marg : local := 0
- $linelength: local := 80
- writeSaturn '"\inputonce{<AXIOM>/doc/browser/browmacs.tex}"
- writeSaturnPrefix()
- writeSaturn(line)
- writeSaturnSuffix()
- if $saturnFileNumber then
- fn := STRCONC('"sat", STRINGIMAGE $saturnFileNumber, '".tex")
- obey STRCONC('"doswrite -a saturn.tex ",fn, '".tex")
- $saturnFileNumber := $saturnFileNumber + 1
-
-writeSaturnPrefix() ==
- $saturnContextMenuLines =>
- index :=
- STRINGIMAGE ($saturnContextMenuIndex := $saturnContextMenuIndex + 1)
- writeSaturnLines
- ['"\newmenu{BCM", index,
- '"}{",:nreverse $saturnContextMenuLines,
- '"}\usemenu{BCM", index,'"}{\vbox{"]
-
-writeSaturnSuffix() ==
- $saturnContextMenuLines => saturnPRINTEXP '"}}"
-
-issueHTStandard line == --called by htMakePageNoScroll and htMakeErrorPage
- if $standard then
- --unescapeStringsInForm line
- sockSendInt($MenuServer, $SendLine)
- sockSendString($MenuServer, line)
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htMakeErrorPage htPage ==
- $newPage := false
- $htLineList := nil
- if $standard then $curPage := htPage
- if $saturn then $saturnPage := htPage
- htMakePage htpPageDescription htPage
- line := APPLY(function CONCAT, nreverse $htLineList)
- issueHT line
- endHTPage()
-
-writeSaturnLines lines ==
- for line in lines repeat
- if line ^= '"" and line.0 = char '_\ then saturnTERPRI()
- saturnPRINTEXP line
-
-writeSaturn(line) ==
- k := 0
- n := MAXINDEX line
- while --advance k if true
- k > n => false
- line.k ^= char '_\ => true
- code := isBreakSegment?(line, k + 1,n) => false
- true
- repeat (k := k + 1)
- k > n => writeSaturnPrint(line)
- segment := SUBSTRING(line,0,k)
- writeSaturnPrint(segment)
- code = 1 =>
- writeSaturnPrint('"\\")
- writeSaturn SUBSTRING(line,k + 2, nil)
- code = 2 =>
- writeSaturnPrint('" &")
- writeSaturn SUBSTRING(line,k + 4, nil)
- code = 3 =>
- writeSaturnPrint('"\item")
- writeSaturn SUBSTRING(line,k + 5,nil)
- code = 4 =>
- writeSaturnPrint('"\newline")
- writeSaturn SUBSTRING(line,k + 8,nil)
- code = 5 =>
- writeSaturnPrint('"\table{")
- $marg := $marg + 3
- writeSaturnTable SUBSTRING(line,k + 7,nil)
- code = 6 =>
- i := charPosition(char '_},line,k + 4)
- tabCode := SUBSTRING(line,k, i - k + 1)
- writeSaturnPrint tabCode
- line := SUBSTRING(line,i + 1, nil)
- writeSaturn line
- code = 7 =>
- saturnTERPRI()
- writeSaturn SUBSTRING(line, k + 2,nil)
- code = 8 =>
- i :=
- substring?('"\beginmenu", line,k) => k + 9
- substring?('"\beginscroll",line,k) => k + 11
- charPosition(char '_},line,k)
- if char '_[ = line.(i + 1) then
- i := charPosition(char '_], line, i + 2)
- beginCode := SUBSTRING(line,k, i - k + 1)
- writeSaturnPrint(beginCode)
- line := SUBSTRING(line,i + 1,nil)
- writeSaturn line
- code = 9 =>
- i :=
- substring?('"\endmenu",line,k) => k + 7
- substring?('"\endscroll",line,k) => k + 9
- charPosition(char '_},line,k)
- endCode := SUBSTRING(line,k, i - k + 1)
- writeSaturnPrint(endCode)
- line := SUBSTRING(line,i + 1,nil)
- $marg := $marg - 3
- writeSaturn line
- systemError code
-
-isBreakSegment?(line, k, n) ==
- k > n => nil
- char2 := line . k
- char2 = (char '_\) => 1
- char2 = (char '_&) =>
- substring?('"&\&", line, k) => 2
- nil
- char2 = char 'i =>
- substring?('"item",line,k) => 3
- nil
- char2 = char 'n =>
- substring?('"newline",line,k) => 4
- nil
- char2 = char 't =>
- (k := k + 2) > n => nil
- line.(k - 1) = char 'a and line.k = char 'b =>
- (k := k + 1) > n => nil
- line.k = char "{" => 6
- substring?('"table",line,k - 3) => 5
- nil
- char2 = (char '_!) => 7
- char2 = char 'b =>
- substring?('"begin",line,k) => 8
- nil
- char2 = (char 'e) =>
- substring?('"end",line,k) => 9
- nil
- nil
-
-writeSaturnPrint s ==
- for i in 0..($marg - 1) repeat saturnPRINTEXP '" "
- saturnPRINTEXP s
- saturnTERPRI()
-
-saturnPRINTEXP s ==
- $browserOutputStream => PRINTEXP(s,$browserOutputStream)
- PRINTEXP s
-
-saturnTERPRI() ==
- $browserOutputStream => TERPRI($browserOutputStream)
- TERPRI()
-
-writeSaturnTable line ==
- open := charPosition(char '"_{",line,0)
- close:= charPosition(char '"_}",line,0)
- open < close =>
- close := findBalancingBrace(line,open + 1,MAXINDEX line,0) or error '"no balancing brace"
- writeSaturnPrint SUBSTRING(line,0,close + 1)
- writeSaturnTable SUBSTRING(line,close + 1,nil)
- $marg := $marg - 3
- writeSaturnPrint SUBSTRING(line,0,close + 1)
- writeSaturn SUBSTRING(line, close + 1,nil)
-
-findBalancingBrace(s,k,n,level) ==
- k > n => nil
- c := s . k
- c = char '_{ => findBalancingBrace(s, k + 1, n, level + 1)
- c = char '_} =>
- level = 0 => k
- findBalancingBrace(s, k + 1, n, level - 1)
- findBalancingBrace(s, k + 1, n, level)
-
---=======================================================================
--- htMakePage and friends
---=======================================================================
-htMakePageStandard itemList ==
- $saturn => nil
- htMakePage itemList
-
-htMakePageSaturn itemList ==
- $standard => nil
- htMakePage itemList
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htMakePage itemList ==
- if $newPage then
- if $saturn then htpAddToPageDescription($saturnPage, saturnTran itemList)
- if $standard then htpAddToPageDescription($curPage, itemList)
- htMakePage1 itemList
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htMakePage1 itemList ==
--- make a page given the description in itemList
- for u in itemList repeat
- itemType := 'text
- items :=
- STRINGP u => u
- ATOM u => STRINGIMAGE u
- STRINGP first u => u
- u is ['text, :s] => s
- itemType := first u
- rest u
- itemType = 'text => iht items
--- $saturn => bcHt items
--- $standard => iht items
- itemType = 'lispLinks => htLispLinks items
- itemType = 'lispmemoLinks => htLispMemoLinks items
- itemType = 'bcLinks => htBcLinks items --->
- itemType = 'bcLinksNS => htBcLinks(items,true)
- itemType = 'bcLispLinks => htBcLispLinks items --->
- itemType = 'radioButtons => htRadioButtons items
- itemType = 'bcRadioButtons => htBcRadioButtons items
- itemType = 'inputStrings => htInputStrings items
- itemType = 'domainConditions => htProcessDomainConditions items
- itemType = 'bcStrings => htProcessBcStrings items
- itemType = 'toggleButtons => htProcessToggleButtons items
- itemType = 'bcButtons => htProcessBcButtons items
- itemType = 'doneButton => htProcessDoneButton items
- itemType = 'doitButton => htProcessDoitButton items
- systemError '"unexpected branch"
-
-saturnTran x ==
- x is [[kind, [s1, s2, :callTail]]] and MEMQ(kind,'(bcLinks bcLispLinks)) =>
- text := saturnTranText s2
- fs := getCallBackFn callTail
- y := isMenuItemStyle? s1 => ----> y is text for button in 2nd column
- t1 := mkDocLink(fs, mkMenuButton())
- y = '"" =>
- s2 = '"" => t1
- mkTabularItem [t1, text]
- t2 := mkDocLink(fs, y)
- mkTabularItem [t1, t2, text]
- t := mkDocLink(fs, s1)
- [:t, :text]
- x is [['text,:r],:.] => r
- error nil
-
-mkBold s ==
- secondPart :=
- atom s => [s, '"}"]
- [:s, '"}"]
- ['"{\bf ", :secondPart]
-
-mkMenuButton() == [menuButton()]
-
-menuButton() == '"\menuitemstyle{}"
--- Saturn must translate \menuitemstyle ==> {\menuButton}
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
---replaces htMakeButton
-getCallBackFn form ==
- func := mkCurryFun(first form, rest form)
- STRCONC('"(|htDoneButton| '|", func, '"| ",htpName page(), '")")
-
-mkDocLink(code,s) ==
- if atom code then code := [code]
- if atom s then s := [s]
- ['"\lispLink[d]{\verb!", :code, '"!}{", :s, '"}"]
-
-saturnTranText x ==
- STRINGP x => [unTab x]
- null x => nil
- r is [s,fn,:.] and s = '"\unixcommand{" => ['"{\it ",s,'".spad}"]
- x is [['text, :s],:r] => unTab [:s, :saturnTranText r]
- error nil
-
-isMenuItemStyle? s ==
- 15 = STRING_<('"\menuitemstyle{", s) => SUBSTRING(s,15,(MAXINDEX s) - 15)
- nil
-
-getCallBack callTail ==
- LASSOC(callTail, $callTailList) or
- callTail is [fn] => callTail
- error nil
-
---=======================================================================
--- Redefinitions from hypertex.boot
---=======================================================================
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-endHTPage() ==
- $standard => sockSendInt($MenuServer, $EndOfPage)
- nil
-
---=======================================================================
--- Redefinitions from ht-util.boot
---=======================================================================
-htSayHrule() == bcHt
- $saturn => '"\hrule{}\newline{}"
- '"\horizontalline{}\newline{}"
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htpAddInputAreaProp(htPage, label, prop) ==
-------------> Add STRINGIMAGE
- SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)])
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htpSetLabelInputString(htPage, label, val) ==
-------------> Add STRINGIMAGE
--- value user typed as input string on page
- props := LASSOC(label, htpInputAreaAlist htPage)
- props => SETELT(props, 0, STRINGIMAGE val)
- nil
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htDoneButton(func, htPage, :optionalArgs) ==
-------> Handle argument values passed from page if present
- if optionalArgs then
- htpSetInputAreaAlist(htPage,CAR optionalArgs)
- typeCheckInputAreas htPage =>
- htMakeErrorPage htPage
- NULL FBOUNDP func =>
- systemError ['"unknown function", func]
- FUNCALL(SYMBOL_-FUNCTION func, htPage)
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htBcLinks(links,:options) ==
- skipStateInfo? := IFCAR options
- [links,options] := beforeAfter('options,links)
- for [message, info, func, :value] in links repeat
- link :=
- $saturn => '"\lispLink[d]"
- '"\lispdownlink"
- htMakeButton(link,message,
- mkCurryFun(func, value),skipStateInfo?)
- bcIssueHt info
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htBcLispLinks links ==
- [links,options] := beforeAfter('options,links)
- for [message, info, func, :value] in links repeat
- link :=
- $saturn => '"\lispLink[n]"
- '"\lisplink"
- htMakeButton(link ,message, mkCurryFun(func, value))
- bcIssueHt info
-
-htMakeButton(htCommand, message, func,:options) ==
- $saturn => htMakeButtonSaturn(htCommand, message, func, options)
- skipStateInfo? := IFCAR options
- iht [htCommand, '"{"]
- bcIssueHt message
- skipStateInfo? =>
- iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"]
- iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "]
- for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat
- iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "]
- if type = 'string then
- iht ['"_"\stringvalue{", id, '"}_""]
- else
- iht ['"_"\boxvalue{", id, '"}_""]
- iht '") "
- iht [htpName $curPage, '"))}"]
-
-htMakeButtonSaturn(htCommand, message, func,options) ==
- skipStateInfo? := IFCAR options
- iht htCommand
- skipStateInfo? =>
- iht ['"{\verb!(|htDoneButton| '|", func, '"| ",htpName page(), '")!}{"]
- bcIssueHt message
- iht '"}"
- iht ['"{\verb!(|htDoneButton| '|", func, '"| "]
- if $kPageSaturnArguments then
- iht '"(PROGN "
- for id in $kPageSaturnArguments for var in $PatternVariableList repeat
- iht ['"(|htpSetLabelInputString| ", htpName page(), '"'|", var, '"| "]
- iht ["'|!\", id, '"\verb!|"]
- iht '")"
- iht htpName $saturnPage
- iht '")"
- else
- iht htpName $saturnPage
- iht '")!}{"
- bcIssueHt message
- iht '"}"
-
-htpAddToPageDescription(htPage, pageDescrip) ==
- newDescript :=
- STRINGP pageDescrip => [pageDescrip, :ELT(htPage, 7)]
- nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7))
- SETELT(htPage, 7, newDescript)
-
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htProcessBcStrings strings ==
- for [numChars, default, stringName, spadType, :filter] in strings repeat
- mess2 := '""
- if NULL LASSOC(stringName, htpInputAreaAlist page()) then
- setUpDefault(stringName, ['string, default, spadType, filter])
- if htpLabelErrorMsg(page(), stringName) then
- iht ['"\centerline{{\em ", htpLabelErrorMsg(page(), stringName), '"}}"]
- mess2 := CONCAT(mess2, bcSadFaces())
- htpSetLabelErrorMsg(page(), stringName, nil)
- iht ['"\inputstring{", stringName, '"}{",
- numChars, '"}{", htpLabelDefault(page(),stringName), '"} ", mess2]
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-setUpDefault(name, props) ==
- htpAddInputAreaProp(page(), name, props)
-
---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet)
-htInitPage(title, propList) ==
--- start defining a hyperTeX page
- htInitPageNoScroll(propList, title)
- htSayStandard '"\beginscroll "
- page()
-
---------------------> NEW DEFINITION <--------------------------
-htInitPageNoScroll(propList, :options) ==
---start defining a hyperTeX page
- $atLeastOneUnexposed := nil --reset every time a new page is initialized
- $saturnContextMenuLines := nil
- title := IFCAR options
- $curPage :=
- $standard => htpMakeEmptyPage(propList)
- nil
- if $saturn then $saturnPage := htpMakeEmptyPage(propList)
- $newPage := true
- $htLineList := nil
- if title then
- if $standard then htSayStandard ['"\begin{page}{", htpName $curPage, '"}{"]
- htSaySaturn '"\browseTitle{"
- htSay title
- htSaySaturn '"}"
- htSayStandard '"} "
- page()
---------------------> NEW DEFINITION <--------------------------
-htInitPageNoHeading(propList) ==
---start defining a hyperTeX page
- $curPage :=
- $standard => htpMakeEmptyPage(propList)
- if $saturn then $saturnPage := htpMakeEmptyPage(propList)
- $newPage := true
- $htLineList := nil
- page()
-
---------------------> NEW DEFINITION <--------------------------
-htpMakeEmptyPage(propList,:options) ==
- name := IFCAR options or GENTEMP()
- if not $saturn then
- $activePageList := [name, :$activePageList]
- SET(name, val := VECTOR(name, nil, nil, nil, nil, nil, propList, nil))
- val
-
---=======================================================================
--- Redefinitions from br-con.boot
---=======================================================================
-kPage(line,:options) == --any cat, dom, package, default package
---constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X)
- parts := dbXParts(line,7,1)
- [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts
- form := IFCAR options
- isFile := null kind
- kind := kind or '"package"
- RPLACA(parts,kind)
- conform := mkConform(kind,name,args)
- $kPageSaturnArguments: local := rest conform
- conname := opOf conform
- capitalKind := capitalize kind
- signature := ncParseFromString sig
- sourceFileName := dbSourceFile INTERN name
- constrings :=
- KDR form => dbConformGenUnder form
- [STRCONC(name,args)]
- emString := ['"{\sf ",:constrings,'"}"]
- heading := [capitalKind,'" ",:emString]
- if not isExposedConstructor conname then heading := ['"Unexposed ",:heading]
- if name=abbrev then abbrev := asyAbbreviation(conname,nargs)
- page := htInitPageNoScroll nil
- htAddHeading heading
- htSayStandard("\beginscroll ")
- htpSetProperty(page,'argSublis,mkConArgSublis rest conform)
- htpSetProperty(page,'isFile,true)
- htpSetProperty(page,'parts,parts)
- htpSetProperty(page,'heading,heading)
- htpSetProperty(page,'kind,kind)
- if asharpConstructorName? conname then
- htpSetProperty(page,'isAsharpConstructor,true)
- htpSetProperty(page,'conform,conform)
- htpSetProperty(page,'signature,signature)
- ---what follows is stuff from kiPage with domain = nil
- $conformsAreDomains := nil
- dbShowConsDoc1(page,conform,nil)
- if kind ^= 'category and nargs > 0 then addParameterTemplates(page,conform)
- if $atLeastOneUnexposed then htSay '"\newline{}{\em *} = unexposed"
- htSayStandard("\endscroll ")
- kPageContextMenu page
- htShowPageNoScroll()
-
-kPageContextMenu page ==
- $saturn => kPageContextMenuSaturn page
- [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts)
- conform := htpProperty(page,'conform)
- conname := opOf conform
- htBeginTable()
- htSay '"{"
- htMakePage [['bcLinks,['Ancestors,'"",'kcaPage,nil]]]
- htSay '"}{"
- htMakePage [['bcLinks,['Attributes,'"",'koPage,'"attribute"]]]
- if kind = '"category" then
- htSay '"}{"
- htMakePage [['bcLinks,['Children,'"",'kccPage,nil]]]
- if not asharpConstructorName? conname then
- htSay '"}{"
- htMakePage [['bcLinks,['Dependents,'"",'kcdePage,nil]]]
- if kind = '"category" then
- htSay '"}{"
- htMakePage [['bcLinks,['Descendents,'"",'kcdPage,nil]]]
- if kind = '"category" then
- htSay '"}{"
- if not asharpConstructorName? conname then
- htMakePage [['bcLinks,['Domains,'"",'kcdoPage,nil]]]
- else htSay '"{\em Domains}"
- htSay '"}{"
- if kind ^= '"category" and (pathname := dbHasExamplePage conname)
- then htMakePage [['bcLinks,['Examples,'"",'kxPage,pathname]]]
- else htSay '"{\em Examples}"
- htSay '"}{"
- htMakePage [['bcLinks,['Exports,'"",'kePage,nil]]]
- htSay '"}{"
- htMakePage [['bcLinks,['Operations,'"",'koPage,'"operation"]]]
- htSay '"}{"
- htMakePage [['bcLinks,['Parents,'"",'kcpPage,'"operation"]]]
- if kind ^= '"category" then
- htSay '"}{"
- if not asharpConstructorName? conname
- then htMakePage [['bcLinks,["Search Path",'"",'ksPage,nil]]]
- else htSay '"{\em Search Path}"
- if kind ^= '"category" then
- htSay '"}{"
- htMakePage [['bcLinks,['Users,'"",'kcuPage,nil]]]
- htSay '"}{"
- htMakePage [['bcLinks,['Uses,'"",'kcnPage,nil]]]
- htSay '"}"
- if $standard then htEndTable()
-
-kPageContextMenuSaturn page ==
- $newPage : local := nil
- [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts)
- $htLineList : local := nil
- conform := htpProperty(page,'conform)
- conname := opOf conform
- htMakePage [['bcLinks,['"\&Ancestors",'"",'kcaPage,nil]]]
- htMakePage [['bcLinks,['"Attri\&butes",'"",'koPage,'"attribute"]]]
- if kind = '"category" then
- htMakePage [['bcLinks,['"\&Children",'"",'kccPage,nil]]]
- if not asharpConstructorName? conname then
- htMakePage [['bcLinks,['"\&Dependents",'"",'kcdePage,nil]]]
- if kind = '"category" then
- htMakePage [['bcLinks,['"Desce\&ndents",'"",'kcdPage,nil]]]
- if kind = '"category" then
- if not asharpConstructorName? conname then
- htMakePage [['bcLinks,['"Do\&mains",'"",'kcdoPage,nil]]]
- else htSayCold '"Do\&mains"
- if kind ^= '"category" and (name := saturnHasExamplePage conname)
- then saturnExampleLink name
- else htSayCold '"E\&xamples"
- htMakePage [['bcLinks,['"\&Exports",'"",'kePage,nil]]]
- htMakePage [['bcLinks,['"\&Operations",'"",'koPage,'"operation"]]]
- htMakePage [['bcLinks,['"\&Parents",'"",'kcpPage,'"operation"]]]
- if not asharpConstructorName? conname
- then htMakePage [['bcLinks,['"Search O\&rder",'"",'ksPage,nil]]]
- else htSayCold '"Search Order"
- if kind ^= '"category" or dbpHasDefaultCategory? xpart
- then
- htMakePage [['bcLinks,['"\&Users",'"",'kcuPage,nil]]]
- htMakePage [['bcLinks,['"U\&ses",'"",'kcnPage,nil]]]
- else
- htSayCold '"\&Users"
- htSayCold '"U\&ses"
- $saturnContextMenuLines := $htLineList
-
-saturnExampleLink lname ==
- htSay '"\docLink{\csname "
- htSay STRCONC(CAR(CDR(lname)), '"\endcsname}{E&xamples}")
-
-$exampleConstructors := nil
-
-saturnHasExamplePage conname ==
- if not $exampleConstructors then
- $exampleConstructors := getSaturnExampleList()
- ASSQ(conname, $exampleConstructors)
-
-getSaturnExampleList() ==
- file := STRCONC(systemRootDirectory(), "/doc/axug/examples.lsp")
- not PROBE_-FILE file => nil
- fp := MAKE_-INSTREAM file
- lst := READ fp
- SHUT fp
- lst
-
---------------------> NEW DEFINITION (see br-con.boot.pamphlet)
-dbPresentCons(htPage,kind,:exclusions) ==
- $saturn => dbPresentConsSaturn(htPage,kind,exclusions)
- htpSetProperty(htPage,'exclusion,first exclusions)
- cAlist := htpProperty(htPage,'cAlist)
- empty? := null cAlist
- one? := null CDR cAlist
- one? := empty? or one?
- exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92
- star? := true --always include information on exposed/unexposed 4/92
- if $standard then htBeginTable()
- htSay '"{"
- if one? or member('abbrs,exclusions)
- then htSay '"{\em Abbreviations}"
- else htMakePage [['bcLispLinks,['"Abbreviations",'"",'dbShowCons,'abbrs]]]
- htSay '"}{"
- if one? or member('conditions,exclusions) or "and"/[CDR x = true for x in cAlist]
- then htSay '"{\em Conditions}"
- else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowCons,'conditions]]]
- htSay '"}{"
- if empty? or member('documentation,exclusions)
- then htSay '"{\em Descriptions}"
- else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowCons,'documentation]]]
- htSay '"}{"
- if one? or null CDR cAlist
- then htSay '"{\em Filter}"
- else htMakePage
- [['bcLinks,['"Filter",'"",'htFilterPage,['dbShowCons,'filter]]]]
- htSay '"}{"
- if one? or member('kinds,exclusions) or kind ^= 'constructor
- then htSay '"{\em Kinds}"
- else htMakePage [['bcLispLinks,['"Kinds",'"",'dbShowCons,'kinds]]]
- htSay '"}{"
- if one? or member('names,exclusions)
- then htSay '"{\em Names}"
- else htMakePage [['bcLispLinks,['"Names",'"",'dbShowCons,'names]]]
- htSay '"}{"
- if one? or member('parameters,exclusions) or not "or"/[CDAR x for x in cAlist]
- then htSay '"{\em Parameters}"
- else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowCons,'parameters]]]
- htSay '"}{"
- if $exposedOnlyIfTrue
- then
- if one?
- then htSay '"{\em Unexposed Also}"
- else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowCons,'exposureOff]]]
- else
- if one?
- then htSay '"{\em Exposed Only}"
- else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowCons,'exposureOn]]]
- htSay '"}"
- if $standard then htEndTable()
-
-dbPresentConsSaturn(htPage,kind,exclusions) ==
- $htLineList : local := nil
- $newPage : local := nil
- htpSetProperty(htPage,'exclusion,first exclusions)
- cAlist := htpProperty(htPage,'cAlist)
- empty? := null cAlist
- one? := null KDR cAlist
- one? := empty? or one?
- exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92
- star? := true --always include information on exposed/unexposed 4/92
- if $standard then htBeginTable()
- if one? or member('abbrs,exclusions)
- then htSayCold '"\&Abbreviations"
- else htMakePage [['bcLispLinks,['"\&Abbreviations",'"",'dbShowCons,'abbrs]]]
- if one? or member('conditions,exclusions) or "and"/[CDR x = true for x in cAlist]
- then htSayCold '"\&Conditions"
- else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowCons,'conditions]]]
- if empty? or member('documentation,exclusions)
- then htSayCold '"\&Descriptions"
- else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowCons,'documentation]]]
- if one? or null CDR cAlist
- then htSayCold '"\&Filter"
- else htMakeSaturnFilterPage ['dbShowCons, 'filter]
- if one? or member('kinds,exclusions) or kind ^= 'constructor
- then htSayCold '"\&Kinds"
- else htMakePage [['bcLispLinks,['"\&Kinds",'"",'dbShowCons,'kinds]]]
- if one? or member('names,exclusions)
- then htSayCold '"\&Names"
- else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowCons,'names]]]
- if one? or member('parameters,exclusions) or not "or"/[CDAR x for x in cAlist]
- then htSayCold '"\&Parameters"
- else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowCons,'parameters]]]
- htSaySaturn '"\hrule"
- if $exposedOnlyIfTrue
- then
- if one? then htSayCold '"\&Unexposed Also"
- else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowCons,'exposureOff]]]
- else
- if one? then htSayCold '"\Exposed Only\&y"
- else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowCons,'exposureOn]]]
- if $standard then htEndTable()
- $saturnContextMenuLines := $htLineList
-
-htFilterPage(htPage,args) ==
- htInitPage("Filter String",htCopyProplist htPage)
- htSay "\centerline{Enter filter string (use {\em *} for wild card):}"
- htSay '"\centerline{"
- htMakePage [['bcStrings, [50,'"",'filter,'EM]]]
- htSay '"}\vspace{1}\centerline{"
- htMakePage [['bcLispLinks,['"\fbox{Filter}",'"",:args]]]
- htSay '"}"
- htShowPage()
-
-htMakeSaturnFilterPage [fn2Call,:args] ==
- htSay '"\inputboxLink[\lispLink[d]{\verb+(|"
- htSay fn2Call
- htSay '"| "
- htSay htpName $saturnPage
- for x in args repeat
- htSay '" '|"
- htSay x
- htSay '"|"
- htSay '" _"+_\FILTERSTRING\verb+_")+}{}]{\FILTERSTRING}{*}"
- htSay '"{\centerline{Enter filter string (use {\em *} for wild card):}}"
- htSay '"{Filter Page}{\&Filter}"
-
-dbShowConsKinds cAlist ==
- cats := doms := paks := defs := nil
- for x in cAlist repeat
- op := CAAR x
- kind := dbConstructorKind op
- kind = 'category => cats := [x,:cats]
- kind = 'domain => doms := [x,:doms]
- kind = 'package => paks := [x,:paks]
- defs := [x,:defs]
- lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs]
- htBeginMenu 'description
- htSayStandard '"\indent{1}"
- kinds := +/[1 for x in lists | #x > 0]
- firstTime := true
- for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat
- if firstTime then firstTime := false
- else htSaySaturn '"\\"
- htSaySaturn '"\item["
- htSayStandard '"\item"
- if kinds = 1
- then htSay menuButton()
- else htMakePage
- [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]]
- htSaySaturn '"]"
- htSayStandard '"\tab{1}"
- htSay('"{\em ",c := #x,'" ")
- htSay(c > 1 => pluralize kind; kind)
- htSay '":}"
- htSaySaturn '"\\"
- bcConTable REMDUP [CAAR y for y in x]
- htEndMenu 'description
- htSayStandard '"\indent{0}"
-
-addParameterTemplates(page, conform) ==
----------------> from kPage <-----------------------
- parlist := [STRINGIMAGE par for par in rest conform]
- manuelsCode? := "MAX"/[#s for s in parlist] > 10
- w := (manuelsCode? => 55; 23)
- htSaySaturn '"\colorbuttonbox{lightgray}{"
- htSay '"Optional argument value"
- htSay
- CDR parlist => '"s:"
- '":"
- htSaySaturn '"}"
- if CDR conform then htSaySaturn '"\newline{}"
- htSaySaturn '"\begin{tabular}{p{.25in}l}"
- firstTime := true
- odd := false
- argSublis := htpProperty(page,'argSublis)
- for parname in $PatternVariableList for par in rest conform repeat
- htSayStandard (odd or manuelsCode? => "\newline";"\tab{29}")
- if firstTime then firstTime := false
- else htSaySaturn '"\\"
- odd := not odd
- argstring :=
- $conArgstrings is [a,:r] => ($conArgstrings := r; a)
- '""
- htMakePageStandard [['text,'"{\em ",par,'"} = "],
- ['bcStrings,[w - #STRINGIMAGE par,argstring,parname,'EM]]]
- if $saturn then
- setUpDefault(parname, ['string, '"", 'EM, nil])
- htSaySaturn '"{\em "
- htSaySaturn par
- htSaySaturn '" = }"
- htSaySaturnAmpersand()
- htSaySaturn '"\colorbuttonbox{lightgray}{\inputbox[2.5in]{\"
- htSaySaturn SUBLIS(argSublis,par)
- htSaySaturn '"}{"
- htSaySaturn argstring
- htSaySaturn '"}}"
- htEndTabular()
-
---------------------> NEW DEFINITION (see br-con.boot.pamphlet)
-kPageArgs([op,:args],[.,.,:source]) ==
- htSaySaturn '"\begin{tabular}{p{.25in}lp{0in}}"
- firstTime := true
- coSig := rest GETDATABASE(op,'COSIG)
- for x in args for t in source for pred in coSig repeat
- if firstTime then firstTime := false
- else
- htSaySaturn '"\\"
- htSayStandard '", and"
- htSayStandard '"\newline "
- htSaySaturnAmpersand()
- typeForm := (t is [":",.,t1] => t1; t)
- if pred = true
- then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]]
- else htSay('"{\em ",x,'"}")
- htSayStandard( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ")
- htSaySaturnAmpersand()
- htSay
- pred => '"a domain of category "
- '"an element of the domain "
- bcConform(typeForm,true)
- htEndTabular()
-
---=======================================================================
--- Redefinitions from br-op1.boot
---=======================================================================
---------------------> NEW DEFINITION (see br-op1.boot.pamphlet)
-dbConform form ==
---one button for the main constructor page of a type
- $saturn => ["\lispLink[d]{\verb!(|conPage| '",:form2Fence dbOuttran form,'")!}{",
- :form2StringList opOf form,"}"]
- ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"]
-
---------------------> NEW DEFINITION (see br-op1.boot.pamphlet)
-htTab s == if $standard then htSayStandard ('"\tab{",s,'"}")
-
---------------------> NEW DEFINITION (see br-op1.boot.pamphlet)
-dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) ==
- single? := null rest data
- htBeginMenu 'description
- bincount := 0
- for [thing,exposeFlag,:items] in data repeat
- htSaySaturn '"\item["
- htSayStandard ('"\item")
- if single? then htSay(menuButton())
- else
- htMakePageStandard
- [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]]
- button := mkButtonBox (1 + bincount)
- htMakePageSaturn [['bcLinks,[button,'"",'dbShowOps,which,bincount]]]
- htSaySaturn '"]"
- htSay '"{\em "
- htSay
- thing = 'nowhere => '"implemented nowhere"
- thing = 'constant => '"constant"
- thing = '_$ => '"by the domain"
- INTEGERP thing => '"unexported"
- constructorIfTrue =>
- htSay word
- atom thing => '" an unknown constructor"
- '""
- atom thing => '"unconditional"
- '""
- htSay '"}"
- if null atom thing then
- if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}")
- htSay '" "
- FUNCALL(fn,thing)
- htSay('":\newline ")
- dbShowOpSigList(which,items,(1 + bincount) * 8192)
- bincount := bincount + 1
- htEndMenu 'description
-
---------------------> NEW DEFINITION (see br-op1.boot.pamphlet)
-dbPresentOps(htPage,which,:exclusions) ==
- $saturn => dbPresentOpsSaturn(htPage,which,exclusions)
- asharp? := htpProperty(htPage,'isAsharpConstructor)
- fromConPage? := (conname := opOf htpProperty(htPage,'conform))
- usage? := nil
- star? := not fromConPage? or which = '"package operation"
- implementation? := not asharp? and
- $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed?
- rightmost? := star? or (implementation? and not $includeUnexposed?)
- if INTEGERP first exclusions then exclusions := ['documentation]
- htpSetProperty(htPage,'exclusion,first exclusions)
- opAlist :=
- which = '"operation" => htpProperty(htPage,'opAlist)
- htpProperty(htPage,'attrAlist)
- empty? := null opAlist
- one? := opAlist is [entry] and 2 = #entry
- one? := empty? or one?
- htBeginTable()
- htSay '"{"
- if one? or member('conditions,exclusions)
- or (htpProperty(htPage,'condition?) = 'no)
- then htSay '"{\em Conditions}"
- else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowOps,which,'conditions]]]
- htSay '"}{"
- if empty? or member('documentation,exclusions)
- then htSay '"{\em Descriptions}"
- else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowOps,which,'documentation]]]
- htSay '"}{"
- if null IFCDR opAlist
- then htSay '"{\em Filter}"
- else htMakePage [['bcLinks,['"Filter ",'"",'htFilterPage,['dbShowOps,which,'filter]]]]
- htSay '"}{"
- if one? or member('names,exclusions) or null KDR opAlist
- then htSay '"{\em Names}"
- else htMakePage [['bcLispLinks,['"Names",'"",'dbShowOps,which,'names]]]
- if not star? then
- htSay '"}{"
- if not implementation? or member('implementation,exclusions) or which = '"attribute" or
- ((conname := opOf htpProperty(htPage,'conform))
- and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category)
- then htSay '"{\em Implementations}"
- else htMakePage
- [['bcLispLinks,['"Implementations",'"",'dbShowOps,which,'implementation]]]
- htSay '"}{"
- if one? or member('origins,exclusions)
- then htSay '"{\em Origins}"
- else htMakePage [['bcLispLinks,['"Origins",'"",'dbShowOps,which,'origins]]]
- htSay '"}{"
- if one? or member('parameters,exclusions) --also test for some parameter
- or not dbDoesOneOpHaveParameters? opAlist
- then htSay '"{\em Parameters}"
- else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowOps,which,'parameters]]]
- htSay '"}{"
- if which ^= '"attribute" then
- if one? or member('signatures,exclusions)
- then htSay '"{\em Signatures}"
- else htMakePage [['bcLispLinks,['"Signatures",'"",'dbShowOps,which,'signatures]]]
- htSay '"}"
- if star? then
- htSay '"{"
- if $exposedOnlyIfTrue
- then if one?
- then htSay '"{\em Unexposed Also}"
- else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowOps,which,'exposureOff]]]
- else if one?
- then htSay '"{\em Exposed Only}"
- else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowOps, which,'exposureOn]]]
- htSay '"}"
- htEndTable()
-
-dbPresentOpsSaturn(htPage,which,exclusions) ==
- $htLineList : local := nil
- $newPage : local := nil
- asharp? := htpProperty(htPage,'isAsharpConstructor)
- fromConPage? := (conname := opOf htpProperty(htPage,'conform))
- usage? := nil
- star? := not fromConPage? or which = '"package operation"
- implementation? := not asharp? and
- $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed?
- rightmost? := star? or (implementation? and not $includeUnexposed?)
- if INTEGERP first exclusions then exclusions := ['documentation]
- htpSetProperty(htPage,'exclusion,first exclusions)
- opAlist :=
- which = '"operation" => htpProperty(htPage,'opAlist)
- htpProperty(htPage,'attrAlist)
- empty? := null opAlist
- one? := opAlist is [entry] and 2 = #entry
- one? := empty? or one?
- if one? or member('conditions,exclusions)
- or (htpProperty(htPage,'condition?) = 'no)
- then htSayCold '"\&Conditions"
- else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowOps,which,'conditions]]]
- if empty? or member('documentation,exclusions)
- then htSayCold '"\&Descriptions"
- else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowOps,which,'documentation]]]
- if null IFCDR opAlist
- then htSayCold '"\&Filter"
- else htMakeSaturnFilterPage ['dbShowOps, which, 'filter]
- if not implementation? or member('implementation,exclusions) or which = '"attribute" or
- ((conname := opOf htpProperty(htPage,'conform))
- and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category)
- then htSayCold '"\&Implementations"
- else htMakePage
- [['bcLispLinks,['"\&Implementations",'"",'dbShowOps,which,'implementation]]]
- if one? or member('names,exclusions) or null KDR opAlist
- then htSayCold '"\&Names"
- else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowOps,which,'names]]]
- if one? or member('origins,exclusions)
- then htSayCold '"\&Origins"
- else htMakePage [['bcLispLinks,['"\&Origins",'"",'dbShowOps,which,'origins]]]
- if one? or member('parameters,exclusions) --also test for some parameter
- or not dbDoesOneOpHaveParameters? opAlist
- then htSayCold '"\&Parameters"
- else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowOps,which,'parameters]]]
- if which ^= '"attribute" then
- if one? or member('signatures,exclusions)
- then htSayCold '"\&Signatures"
- else htMakePage [['bcLispLinks,['"\&Signatures",'"",'dbShowOps,which,'signatures]]]
- if star? then
- htSay '"\hrule"
- if $exposedOnlyIfTrue
- then if one? then htSayCold '"\&Unexposed Also"
- else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowOps,which,'exposureOff]]]
- else
- if one? then htSayCold '"Exposed Onl\&y"
- else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowOps,which,'exposureOn]]]
- $saturnContextMenuLines := $htLineList
-
---=======================================================================
--- Redefinitions from br-search.boot
---=======================================================================
----------------------> OLD DEFINITION (override in br-search.boot.pamphlet)
-htShowPageStar() ==
- $saturn => htShowPageStarSaturn()
- htSayStandard '"\endscroll "
- if $exposedOnlyIfTrue then
- htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]]
- else
- htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]]
- htShowPageNoScroll()
-
-htShowPageStarSaturn() ==
- $newPage : local := nil
- $htLineList : local := nil
- if $exposedOnlyIfTrue then
- htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]]
- else
- htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]]
- $saturnContextMenuLines := $htLineList
- htShowPageNoScroll()
-
---=======================================================================
--- Redefinitions from br-op2.boot
---=======================================================================
-
---------------> NEW DEFINITION (see br-op2.boot.pamphlet)
-displayDomainOp(htPage,which,origin,op,sig,predicate,
- doc,index,chooseFn,unexposed?,$generalSearch?) ==
- $chooseDownCaseOfType : local := true --see dbGetContrivedForm
- $whereList : local := nil
- $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 )
- $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 )
- $FunctionList:local := '(f g h d e F G H)
- $DomainList: local := '(D R S E T A B C M N P Q U V W)
- exactlyOneOpSig := null index
- conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform)
- or origin
- if $generalSearch? then $DomainList := rest $DomainList
- opform :=
- which = '"attribute" =>
- null sig => [op]
- [op,sig]
- which = '"constructor" => origin
- dbGetDisplayFormForOp(op,sig,doc)
- htSayStandard('"\newline")
- -----------------------------------------------------------
- htSaySaturn '"\item["
- if exactlyOneOpSig
- then htSay menuButton()
- else htMakePage
- [['bcLinks,[menuButton(),'"",chooseFn,which,index]]]
- htSaySaturn '"]"
- htSayStandard '"\tab{2}"
- op := IFCAR opform
- args := IFCDR opform
- ops := escapeSpecialChars STRINGIMAGE op
- n := #sig
- do
- n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}")
- n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}")
- if unexposed? and $includeUnexposed? then
- htSayUnexposed()
- htSay(ops)
- predicate='ASCONST or GETDATABASE(op,'NILADIC) or member(op,'(0 1)) => 'skip
- which = '"attribute" and null args => 'skip
- htSay('"(")
- if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}")
- for x in IFCDR args repeat
- htSay('",{\em ",quickForm2HtString x,'"}")
- htSay('")")
- -----------prepare to print description---------------------
- constring := form2HtString conform
- conname := first conform
- $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category"
- or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)
- $conlength : local := #constring
- $conform : local := conform
- $conargs : local := rest conform
- if which = '"operation" then
- $signature : local :=
- MEMQ(conname,$Primitives) => nil
- CDAR getConstructorModemap conname
- --RDJ: this next line is necessary until compiler bug is fixed
- --that forgets to substitute #variables for t#variables;
- --check the signature for SegmentExpansionCategory, e.g.
- tvarlist := TAKE(# $conargs,$TriangleVariableList)
- $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature)
- $sig :=
- which = '"attribute" or which = '"constructor" => sig
- $conkind ^= '"package" => sig
- symbolsUsed := [x for x in rest conform | IDENTP x]
- $DomainList := SETDIFFERENCE($DomainList,symbolsUsed)
- getSubstSigIfPossible sig
- -----------------------------------------------------------
- htSaySaturn '"\begin{tabular}{lp{0in}}"
- -----------------------------------------------------------
- if member(which,'("operation" "constructor")) then
- $displayReturnValue: local := nil
- if args then
- htSayStandard('"\newline\tab{2}{\em Arguments:}")
- htSaySaturn '"{\em Arguments:}"
- htSaySaturnAmpersand()
- firstTime := true
- coSig := KDR GETDATABASE(op,'COSIG) --check if op is constructor
- for a in args for t in rest $sig repeat
- if not firstTime then
- htSaySaturn '"\\ "
- htSaySaturnAmpersand()
- firstTime := false
- htSayIndentRel(15, true)
- position := KAR relatives
- relatives := KDR relatives
- if KAR coSig and t ^= '(Type)
- then htMakePage [['bcLinks,[a,'"",'kArgPage,a]]]
- else htSay('"{\em ",form2HtString(a),'"}")
- htSay ", "
- coSig := KDR coSig
- htSayValue t
- htSayIndentRel(-15,true)
- htSayStandard('"\newline ")
- htSaySaturn '"\\"
- if first $sig then
- $displayReturnValue := true
- htSayStandard('"\newline\tab{2}")
- htSay '"{\em Returns:}"
- htSaySaturnAmpersand()
- htSayIndentRel(15, true)
- htSayValue first $sig
- htSayIndentRel(-15, true)
- htSaySaturn '"\\"
- -----------------------------------------------------------
- if origin and ($generalSearch? or origin ^= conform) and op^=opOf origin then
- htSaySaturn '"{\em Origin:}"
- htSaySaturnAmpersand()
- htSayStandard('"\newline\tab{2}{\em Origin:}")
- htSayIndentRel(15)
- if not isExposedConstructor opOf origin and $includeUnexposed?
- then htSayUnexposed()
- bcConform(origin,true)
- htSayIndentRel(-15)
- htSaySaturn '"\\"
- -----------------------------------------------------------
- if not MEMQ(predicate,'(T ASCONST)) then
- pred := sublisFormal(KDR conform,predicate)
- count := #pred
- htSaySaturn '"{\em Conditions:}"
- htSayStandard('"\newline\tab{2}{\em Conditions:}")
- firstTime := true
- for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat
- if not firstTime then htSaySaturn '"\\"
- htSayIndentRel(15,count > 1)
- firstTime := false
- htSaySaturnAmpersand()
- bcPred(p,$conform,true)
- htSayIndentRel(-15,count > 1)
- htSayStandard('"\newline ")
- htSaySaturn '"\\"
- -----------------------------------------------------------
- if $whereList then
- count := #$whereList
- htSaySaturn '"{\em Where:}"
- htSayStandard('"\newline\tab{2}{\em Where:}")
- firstTime := true
- if ASSOC("$",$whereList) then
- htSayIndentRel(15,true)
- htSaySaturnAmpersand()
- htSayStandard '"{\em \$} is "
- htSaySaturn '"{\em \%} is "
- htSay
- $conkind = '"category" => '"of category "
- '"the domain "
- bcConform(conform,true,true)
- firstTime := false
- htSayIndentRel(-15,true)
- for [d,key,:t] in $whereList | d ^= "$" repeat
- htSayIndentRel(15,count > 1)
- if not firstTime then htSaySaturn '"\\ "
- htSaySaturnAmpersand()
- firstTime := false
- htSay("{\em ",d,"} is ")
- htSayConstructor(key,sublisFormal(KDR conform,t))
- htSayIndentRel(-15,count > 1)
- htSaySaturn '"\\"
- -----------------------------------------------------------
- if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then
- htSaySaturn '"{\em Description:}"
- htSaySaturnAmpersand()
- htSayStandard('"\newline\tab{2}{\em Description:}")
- htSayIndentRel(15)
- if doc = $charFauxNewline then htSay $charNewline
- else
- ndoc:=
- -- we are confused whether doc is a string or a list of strings
- CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc]
- SUBSTITUTE($charNewline, $charFauxNewline,doc)
- htSay ndoc
--- htSaySaturn '"\\"
- htSayIndentRel(-15)
- --------> print abbr and source file for constructors <---------
- if which = '"constructor" then
- if (abbr := GETDATABASE(conname,'ABBREVIATION)) then
- htSaySaturn '"\\"
- htSaySaturn '"{\em Abbreviation:}"
- htSaySaturnAmpersand()
- htSayStandard('"\tab{2}{\em Abbreviation:}")
- htSayIndentRel(15)
- htSay abbr
- htSayIndentRel(-15)
- htSayStandard('"\newline{}")
- if ( $saturn and (link := saturnHasExamplePage conname)) then
- htSaySaturn '"\\"
- htSaySaturn '"{\em Examples:}"
- htSaySaturnAmpersand()
- htSayIndentRel(15)
- htSay '"\spadref{"
- htSay CAR(CDR(link))
- htSay '"}"
- htSayIndentRel(-15)
- htSayStandard('"\newline{}")
- htSaySaturn '"\\"
- htSaySaturn '"{\em Source File:}"
- htSaySaturnAmpersand()
- htSayStandard('"\tab{2}{\em Source File:}")
- htSayIndentRel(15)
- htSaySourceFile conname
- htSayIndentRel(-15)
- ------------------> remove profile printouts for now <-------------------
- if $standard and
- exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then
- displayInfoOp(htPage,infoAlist,op,sig)
- -----------------------------------------------------------
- htSaySaturn '"\end{tabular}"
-
-htSaySourceFile conname ==
- sourceFileName := (GETDATABASE(conname,'SOURCEFILE) or '"none")
- filename := extractFileNameFromPath sourceFileName
- htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ",
- sourceFileName, '" ", conname, '"}"]]
-
---------------------> NEW DEFINITION (see br-op2.boot.pamphlet)
-htSayIndentRel(n,:options) ==
- flag := IFCAR options
- m := ABSVAL n
- if flag then m := m + 2
- if $standard then htSayStandard
- n > 0 =>
- flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"]
- ['"\indent{",STRINGIMAGE m,'"}\tab{0}"]
- n < 0 => ['"\indent{0}\newline "]
-
-htSayUnexposed() ==
- htSay '"{\em *}"
- $atLeastOneUnexposed := true
---=======================================================================
--- Page Operations
---=======================================================================
-
-htEndTabular() ==
- htSaySaturn '"\end{tabular}"
-
-htPopSaturn s ==
- pageDescription := ELT($saturnPage, 7)
- pageDescription is [=s,:b] => SETELT($saturnPage, 7, CDR pageDescription)
- nil
-
-htBeginTable() ==
- htSaySaturn '"\begin{dirlist}[lv]"
- htSayStandard '"\table{"
-
-htEndTable() ==
- htSaySaturn '"\end{dirlist}"
- htSayStandard '"}"
-
-htBeginMenu(kind,:options) ==
- skip := IFCAR options
- if $saturn then
- kind = 'description => htSaySaturn '"\begin{description}"
- htSaySaturn '"\begin{tabular}"
- htSaySaturn
- kind = 3 => '"{llp{0in}}"
- kind = 2 => '"{lp{0in}}"
- error nil
- null skip => htSayStandard '"\beginmenu "
- nil
-
-htEndMenu(kind) ==
- if $saturn then
- kind = 'description => htSaySaturn '"\end{description}"
- htPopSaturn '"\\"
- htSaySaturn '"\end{tabular}"
- htSayStandard '"\endmenu "
-
-htSayConstructorName(nameShown, name) ==
- if $saturn then
- code := ['"(|conPage| '|", name, '"|)"]
- htSaySaturn mkDocLink(code,nameShown)
- if $standard then
- htSayStandard ["\lispdownlink{",nameShown,'"}{(|conPage| '|",name,'"|)}"]
-
---------------------> NEW DEFINITION (see ht-util.boot.pamphlet)
-htAddHeading(title) ==
- htNewPage title
- page()
-
-------------> called by htAddHeading, htInitPageNoScroll <-----------
-htNewPage title ==
- if $saturn then
- htSaySaturn '"\browseTitle{"
- htSaySaturn title
- htSaySaturn '"}"
- if $standard then htSayStandard('"\begin{page}{", htpName $curPage, '"}{")
- htSayStandard title
- htSayStandard '"}"
-
---=======================================================================
--- Utilities
---=======================================================================
-mkTabularItem u == [:first u,:fn rest u] where fn x ==
- null x => nil
- [$saturnAmpersand, x,:fn rest x]
-
-htSaySaturnAmpersand() == htSaySaturn $saturnAmpersand
-
-htBlank(:options) ==
- options is [n] =>
- htSaySaturn("STRCONC"/['"\phantom{*}" for i in 1..n])
- htSayStandard STRCONC('"\space{",STRINGIMAGE n,'"}")
- htSaySaturn '"\phantom{*}"
- htSayStandard '"\space{1}"
-
-unTab s ==
- STRINGP s => unTab1 s
- atom s => s
- [unTab1 first s, :rest s]
-
-unTab1 s ==
- STRING_<('"\tab{", s) = 5 and (k := charPosition(char '_}, s, 4)) =>
- SUBSTRING(s, k + 1, nil)
- s
-
-satBreak() ==
- htSaySaturn '"\\ "
- htSayStandard '"\item "
-
-htBigSkip() ==
- htSaySaturn '"\bigskip{}"
- htSayStandard '"\vspace{1}\newline "
-
-htSaturnBreak() == htSaySaturn '"\!"
-
-satDownLink(s,code) ==
- htSaySaturn '"\lispFunctionLink{\verb!"
- htSaySaturn code
- htSaySaturn '"!}{"
- htSaySaturn s
- htSaySaturn '"}"
- ------------------
- htSayStandard '"\lispdownlink{"
- htSayStandard s
- htSayStandard '"}{"
- htSayStandard code
- htSayStandard '"}"
-
-satTypeDownLink(s,code) ==
- htSaySaturn '"\lispLink[d]{\verb!"
- htSaySaturn code
- htSaySaturn '"!}{"
- htSaySaturn s
- htSaySaturn '"}"
- ------------------
- htSayStandard '"\lispdownlink{"
- htSayStandard s
- htSayStandard '"}{"
- htSayStandard code
- htSayStandard '"}"
-
-mkButtonBox n == STRCONC('"\buttonbox{", STRINGIMAGE n, '"}")
-
---=======================================================================
--- Create separate databases for operations, constructors
---=======================================================================
------------> use br-data.boot definition
---dbSplitLibdb() ==
---This function splits lidbd.text into files to make searching quicker.
--- alibdb.text attributes
--- clibdb.text categories
--- dlibdb.text domains
--- plibdb.text packages
--- olibdb.text operations
--- xlibdb.text default packages
---These files have the same format as the single file libdb.text did in old
--- version: e.g. <key><name>`<args>`<exposure>`<sig>`<args>`<abbrev>`<doc>
--- for constructors where <key> is a single character, one of acdopx
--- (identifying it as an attribute, category, domain, operator, package,
--- or default package), its name, number of arguments, whether exposed or
--- unexposed, its signature (sometimes abbreviated), its arguments as given
--- in the original definition, its abbreviation, and documentation.
--- For example, domain Matrix has line "dMatrix`1`x`<sig>`(R)`MATRIX`<com>"
--- where <sig> is "(Ring)->Join(MatrixCategory(R,Vector(R),Vector(R)),etc)".
--- The comment field <com> contains the character address of the comments
--- for Matrix in file comdb.text.
---There is thus ONE file comdb.text for documentation of all structures
--- (to facilitate a general search through all documentation)
--- into for comments. The format of entries in comdb.text are lines with
--- two fields of the form d<nnnnn>`<ccccc>, where <nnnnn> is the character
--- address of the line "dMatrix`.." in dlibdb.text (the first character
--- "d" tells which lidbdb file it comes from, the <ccccc> is the
--- documentation for Matrix.
---NOTE: In each file, the first character, one of acdpox, is retained
--- so that lines have the same format as the previous version of the browser
--- (this minimized the number of lines of code that had to be changed from
--- previous version of the browser).
--- key := nil --dummy first key
--- instream := MAKE_-INSTREAM '"libdb.text"
--- comstream := MAKE_-OUTSTREAM '"comdb.text"
--- PRINTEXP(0, comstream)
--- PRINTEXP($tick,comstream)
--- PRINTEXP('"", comstream)
--- TERPRI(comstream)
--- while not EOFP instream repeat
--- line := READLINE instream
--- comP := FILE_-POSITION comstream
--- if key ^= line.0 then
--- if outstream then SHUT outstream
--- key := line . 0
--- outstream := MAKE_-OUTSTREAM STRCONC(STRINGIMAGE key,'"libdb.text")
--- outP := FILE_-POSITION outstream
--- [prefix,:comments] := dbSplit(line,6,1)
--- PRINTEXP(prefix,outstream)
--- PRINTEXP($tick ,outstream)
--- null comments =>
--- PRINTEXP(0,outstream)
--- TERPRI(outstream)
--- PRINTEXP(comP,outstream)
--- TERPRI(outstream)
--- PRINTEXP(key, comstream) --identifies file the backpointer is to
--- PRINTEXP(outP ,comstream)
--- PRINTEXP($tick ,comstream)
--- PRINTEXP(first comments,comstream)
--- TERPRI(comstream)
--- for c in rest comments repeat
--- PRINTEXP(key, comstream) --identifies file the backpointer is to
--- PRINTEXP(outP ,comstream)
--- PRINTEXP($tick ,comstream)
--- PRINTEXP(c, comstream)
--- TERPRI(comstream)
--- SHUT instream
--- SHUT outstream
--- SHUT comstream
---OBEY '"rm libdb.text"
-
-dbSort(x,y) ==
- sin := STRINGIMAGE x
- sout:= STRINGIMAGE y
- OBEY STRCONC('"sort -f _"",sin,'".text_" > _"", sout, '".text_"")
- OBEY STRCONC('"rm ", sin, '".text")
-
-
---=======================================================================
--- from define.boot
---=======================================================================
-----------------------> (override in define.boot.pamphlet)
-compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body],
- m,oldE,$prefix,$formalArgList) ==
- [lineNumber,:specialCases] := specialCases
- e := oldE
- --1. bind global variables
- $form: local
- $op: local
- $functionStats: local:= [0,0]
- $argumentConditionList: local
- $finalEnv: local
- --used by ReplaceExitEtc to get a common environment
- $initCapsuleErrorCount: local:= #$semanticErrorStack
- $insideCapsuleFunctionIfTrue: local:= true
- $CapsuleModemapFrame: local:= e
- $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e)
- $insideExpressionIfTrue: local:= true
- $returnMode:= m
- [$op,:argl]:= form
- $form:= [$op,:argl]
- argl:= stripOffArgumentConditions argl
- $formalArgList:= [:argl,:$formalArgList]
-
- --let target and local signatures help determine modes of arguments
- argModeList:=
- identSig:= hasSigInTargetCategory(argl,form,first signature,e) =>
- (e:= checkAndDeclare(argl,form,identSig,e); rest identSig)
- [getArgumentModeOrMoan(a,form,e) for a in argl]
- argModeList:= stripOffSubdomainConditions(argModeList,argl)
- signature':= [first signature,:argModeList]
- if null identSig then --make $op a local function
- oldE := put($op,'mode,['Mapping,:signature'],oldE)
-
- --obtain target type if not given
- if null first signature' then signature':=
- identSig => identSig
- getSignature($op,rest signature',e) or return nil
-
- --replace ##1,.. in signature by arguments
--- pp signature'
- signature':= SUBLISLIS(argl,$FormalFunctionParameterList,signature')
--- pp '"------after----"
--- pp signature'
- e:= giveFormalParametersValues(argl,e)
-
- $signatureOfForm:= signature' --this global is bound in compCapsuleItems
- $functionLocations := [[[$op,$signatureOfForm],:lineNumber],
- :$functionLocations]
- e:= addDomain(first signature',e)
- e:= compArgumentConditions e
-
- if $profileCompiler then
- for x in argl for t in rest signature' repeat profileRecord('arguments,x,t)
-
-
- --4. introduce needed domains into extendedEnv
- for domain in signature' repeat e:= addDomain(domain,e)
-
- --6. compile body in environment with extended environment
- rettype:= resolve(signature'.target,$returnMode)
-
- localOrExported :=
- null member($op,$formalArgList) and
- getmode($op,e) is ['Mapping,:.] => 'local
- 'exported
-
- --6a skip if compiling only certain items but not this one
- -- could be moved closer to the top
- formattedSig := formatUnabbreviated ['Mapping,:signature']
- $compileOnlyCertainItems and _
- not member($op, $compileOnlyCertainItems) =>
- sayBrightly ['" skipping ", localOrExported,:bright $op]
- [nil,['Mapping,:signature'],oldE]
- sayBrightly ['" compiling ",localOrExported,
- :bright $op,'": ",:formattedSig]
-
- if $newComp = true then
- wholeBody := ['DEF, form, signature', specialCases, body]
- T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e))
- or [" ",rettype,e]
- T := [T.expr.2.2, rettype, T.env]
- if $newCompCompare=true then
- oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e))
- or [" ",rettype,e]
- SAY '"The old compiler generates:"
- prTriple oldT
- SAY '"The new compiler generates:"
- prTriple T
- else
- T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e))
- or [" ",rettype,e]
---+
- NRTassignCapsuleFunctionSlot($op,signature')
- if $newCompCompare=true then
- SAY '"The old compiler generates:"
- prTriple T
--- A THROW to the above CATCH occurs if too many semantic errors occur
--- see stackSemanticError
- catchTag:= MKQ GENSYM()
- fun:=
- body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode)
- body':= addArgumentConditions(body',$op)
- finalBody:= ["CATCH",catchTag,body']
- compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE)
- $functorStats:= addStats($functorStats,$functionStats)
-
-
--- 7. give operator a 'value property
- val:= [fun,signature',e]
- [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e)
-
---from postpar
---------------------> NEW DEFINITION (override in postpar.boot.pamphlet)
-postSignature ['Signature,op,sig] ==
- sig is ["->",:.] =>
- sig1:= postType sig
- op:= postAtom (STRINGP op => INTERN op; op)
- ["SIGNATURE",op,:removeSuperfluousMapping killColons postDoubleSharp sig1]
-
-postDoubleSharp sig ==
- sig is [['Mapping,target,:r]] =>
- -- replace #1,... by ##1,...
- [['Mapping, SUBLISLIS($FormalFunctionParameterList, $FormalMapVariableList, target),
- :r]]
- sig
-
--- override in br-util.boot.pamphlet
-bcConform1 form == main where
- main() ==
- form is ['ifp,form1,:pred] =>
- hd form1
- bcPred pred
- hd form
- hd form ==
- atom form =>
- not MEMQ(form,$Primitives) and null constructor? form =>
- s := STRINGIMAGE form
- (s.0 = char '_#) =>
- (n := POSN1(form, $FormalFunctionParameterList)) =>
- htSay form2HtString ($FormalMapVariableList . n)
- htSay '"\"
- htSay form
- htSay escapeSpecialChars STRINGIMAGE form
- s := STRINGIMAGE form
- $italicHead? => htSayItalics s
- $bcMultipleNames =>
- satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"])
- satTypeDownLink(s, ["(|conPage| '|",s,'"|)"])
- (head := QCAR form) = 'QUOTE =>
- htSay('"'")
- hd CADR form
- head = 'SIGNATURE =>
- htSay(CADR form,'": ")
- mapping CADDR form
- head = 'Mapping and rest form => rest form => mapping rest form
- head = ":" =>
- hd CADR form
- htSay '": "
- hd CADDR form
- QCDR form and dbEvalableConstructor? form
- => bcConstructor(form,head)
- hd head
- null (r := QCDR form) => nil
- tl QCDR form
- mapping [target,:source] ==
- tuple source
- bcHt
- $saturn => '" {\ttrarrow} "
- '" -> "
- hd target
- tuple u ==
- null u => bcHt '"()"
- null rest u => hd u
- bcHt '"("
- hd first u
- for x in rest u repeat
- bcHt '","
- hd x
- bcHt '")"
- tl u ==
- bcHt '"("
- firstTime := true
- for x in u repeat
- if not firstTime then bcHt '","
- firstTime := false
- hd x
- bcHt '")"
- say x ==
- if $italics? then bcHt '"{\em "
- if x = 'etc then x := '"..."
- bcHt escapeSpecialIds STRINGIMAGE x
- if $italics? then bcHt '"}"
-
---=======================================================================
--- Code for Private Libdbs
---=======================================================================
---extendLocalLibdb conlist == --called by function "compiler"(see above)
--- buildLibdb conlist --> puts datafile into temp.text
--- $newConstructorList := union(conlist, $newConstructorList)
--- localLibdb := '"libdb.text"
--- not isExistingFile '"libdb.text" => RENAME_-FILE('"temp.text",'"libdb.text")
--- oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist)
--- newlines := dbReadLines '"temp.text"
--- dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text")
--- deleteFile '"temp.text"
-
-purgeNewConstructorLines(lines, conlist) ==
- [x for x in lines | not screenLocalLine(x, conlist)]
-
--- Got rid of debugging statement and deleted screenLocalLine1, MCD 26/3/96
---screenLocalLine(line,conlist) ==
--- u := screenLocalLine1(line,conlist)
--- if u then
--- sayBrightly ['"Purging--->", line]
--- u
-
--- screenLocalLine1(line, conlist) ==
-screenLocalLine(line, conlist) ==
- k := dbKind line
- con := INTERN
- k = char 'o or k = char 'a =>
- s := dbPart(line,5,1)
- k := charPosition(char '_(,s,1)
- SUBSTRING(s,1,k - 1)
- dbName line
- MEMQ(con, conlist)
-
---------------> NEW DEFINITION (see br-data.boot.pamphlet)
-purgeLocalLibdb() == --called by the user through a clear command?
- $newConstructorList := nil
- deleteFile '"libdb.text"
-
---moveFile(before,after) ==
--- $saturn => MOVE_-FILE(before, after)
--- RENAME_-FILE(before, after)
--- --obey STRCONC('"mv ", before, '" ", after)
-
--- deleted JHD/MCD, since already one in pathname.boot
---deleteFile fn ==
--- $saturn => DELETE_-FILE fn
--- obey STRCONC('"rm ",fn)
-
---=======================================================================
--- from DAASE.LISP
---=======================================================================
---library(args) ==
--- $newConlist: local := nil
--- LOCALDATABASE(args,$options)
--- extendLocalLibdb $newConlist
--- TERSYSCOMMAND()
-
-
-@
-\eject
-\begin{thebibliography}{99}
-\bibitem{1} nothing
-\end{thebibliography}
-\end{document}