diff --git a/changelog b/changelog index 29a3e35..9f43f13 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090712 tpd src/axiom-website/patches.html 20090712.07.tpd.patch +20090712 tpd src/interp/Makefile remove br-saturn +20090712 tpd src/interp/br-con.boot merge br-saturn.boot +20090712 tpd src/interp/br-saturn.boot removed, merge with br-con 20090712 tpd src/axiom-website/patches.html 20090712.06.tpd.patch 20090712 tpd src/interp/Makefile remove br-prof 20090712 tpd src/interp/br-con.boot merge br-prof.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index f7f6d47..41872b4 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1721,5 +1721,7 @@ merge br-con and br-search
merge br-con and br-util
20090712.06.tpd.patch merge br-con and br-prof
+20090712.07.tpd.patch +merge br-con and br-saturn
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index afc5ad1..83946a9 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -286,8 +286,7 @@ browser. These files should probably be autoloaded. BROBJS= ${AUTO}/bc-matrix.${O} \ ${AUTO}/ht-util.${O} \ ${AUTO}/br-con.${O} \ - ${AUTO}/topics.${O} \ - ${AUTO}/br-saturn.${O} + ${AUTO}/topics.${O} @ The {\bf TRANOBJS} list contains files only used by the {\bf boot} @@ -428,7 +427,6 @@ DOCFILES=${DOC}/alql.boot.dvi \ ${DOC}/bc-matrix.boot.dvi \ ${DOC}/bits.lisp.dvi ${DOC}/bootfuns.lisp.dvi \ ${DOC}/br-con.boot.dvi \ - ${DOC}/br-saturn.boot.dvi \ ${DOC}/buildom.boot.dvi \ ${DOC}/category.boot.dvi ${DOC}/cattable.boot.dvi \ ${DOC}/c-doc.boot.dvi ${DOC}/cformat.boot.dvi \ @@ -5835,55 +5833,6 @@ ${DOC}/br-con.boot.dvi: ${IN}/br-con.boot.pamphlet @ -\subsection{br-saturn.boot} -<>= -${AUTO}/br-saturn.${O}: ${OUT}/br-saturn.${O} - @ echo 489 making ${AUTO}/br-saturn.${O} from ${OUT}/br-saturn.${O} - @ cp ${OUT}/br-saturn.${O} ${AUTO} - -@ -<>= -${OUT}/br-saturn.${O}: ${MID}/br-saturn.clisp - @ echo 490 making ${OUT}/br-saturn.${O} from ${MID}/br-saturn.clisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/br-saturn.clisp"' \ - ':output-file "${OUT}/br-saturn.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/br-saturn.clisp"' \ - ':output-file "${OUT}/br-saturn.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/br-saturn.clisp: ${IN}/br-saturn.boot.pamphlet - @ echo 491 making ${MID}/br-saturn.clisp from ${IN}/br-saturn.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/br-saturn.boot.pamphlet >br-saturn.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "br-saturn.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "br-saturn.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm br-saturn.boot ) - -@ -<>= -${DOC}/br-saturn.boot.dvi: ${IN}/br-saturn.boot.pamphlet - @echo 492 making ${DOC}/br-saturn.boot.dvi \ - from ${IN}/br-saturn.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/br-saturn.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} br-saturn.boot ; \ - rm -f ${DOC}/br-saturn.boot.pamphlet ; \ - rm -f ${DOC}/br-saturn.boot.tex ; \ - rm -f ${DOC}/br-saturn.boot ) - -@ - \subsection{topics.boot} <>= ${AUTO}/topics.${O}: ${OUT}/topics.${O} @@ -7467,11 +7416,6 @@ clean: <> <> -<> -<> -<> -<> - <> <> <> diff --git a/src/interp/br-con.boot.pamphlet b/src/interp/br-con.boot.pamphlet index 83270e2..4426017 100644 --- a/src/interp/br-con.boot.pamphlet +++ b/src/interp/br-con.boot.pamphlet @@ -6132,6 +6132,1863 @@ getInfoAlist conname == alist +--====================> 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{/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( getEnv('"AXIOM"), "/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. `````` +-- for constructors where 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``(R)`MATRIX`" +-- where is "(Ring)->Join(MatrixCategory(R,Vector(R),Vector(R)),etc)". +-- The comment field 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`, where is the character +-- address of the line "dMatrix`.." in dlibdb.text (the first character +-- "d" tells which lidbdb file it comes from, the 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 := nil + $op: local := nil + $functionStats: local:= [0,0] + $argumentConditionList: local := nil + $finalEnv: local := nil + --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 diff --git a/src/interp/br-saturn.boot.pamphlet b/src/interp/br-saturn.boot.pamphlet deleted file mode 100644 index 969f0ac..0000000 --- a/src/interp/br-saturn.boot.pamphlet +++ /dev/null @@ -1,1912 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp br-saturn.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - ---====================> 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{/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( getEnv('"AXIOM"), "/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. `````` --- for constructors where 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``(R)`MATRIX`" --- where is "(Ring)->Join(MatrixCategory(R,Vector(R),Vector(R)),etc)". --- The comment field 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`, where is the character --- address of the line "dMatrix`.." in dlibdb.text (the first character --- "d" tells which lidbdb file it comes from, the 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 := nil - $op: local := nil - $functionStats: local:= [0,0] - $argumentConditionList: local := nil - $finalEnv: local := nil - --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}