diff options
Diffstat (limited to 'src/interp/htsetvar.boot')
| -rw-r--r-- | src/interp/htsetvar.boot | 483 |
1 files changed, 483 insertions, 0 deletions
diff --git a/src/interp/htsetvar.boot b/src/interp/htsetvar.boot new file mode 100644 index 00000000..a563645e --- /dev/null +++ b/src/interp/htsetvar.boot @@ -0,0 +1,483 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)package "BOOT" + +htsv() == + startHTPage(50) + htSetVars() + +htSetVars() == + $path := nil + $lastTree := nil + if 0 ^= LASTATOM $setOptions then htMarkTree($setOptions,0) + htShowSetTree($setOptions) + +htShowSetTree(setTree) == + $path := TAKE(- LASTATOM setTree,$path) + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page, 'setTree, setTree) + links := nil + maxWidth1 := maxWidth2 := 0 + for setData in setTree repeat + satisfiesUserLevel setData.setLevel => + okList := [setData,:okList] + maxWidth1 := MAX(# PNAME setData.setName,maxWidth1) + maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2) + maxWidth1 := MAX(9,maxWidth1) + maxWidth2 := MAX(41,maxWidth2) + tabset1 := STRINGIMAGE (maxWidth1) + tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1) + htSay('"\tab{2}\newline Variable\tab{",STRINGIMAGE (maxWidth1 + (maxWidth2/3)),'"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),'"}Value\newline\beginitems ") + for setData in REVERSE okList repeat + htSay '"\item" + label := STRCONC('"\menuitemstyle{",setData.setName,'"}") + links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]], + 'htShowSetPage, setData.setName] + htMakePage [['bcLispLinks, links,'options,'(indent . 0)]] + htSay '"\enditems" + htShowPage() + +htShowCount s == --# discounting {\em .. } + m := #s + m < 8 => m - 1 + i := 0 + count := 0 + while i < m - 7 repeat + s.i = char '_{ and s.(i+1) = char '_\ and s.(i+2) = char 'e + and s.(i+3) = char 'm => i := i + 6 --discount {\em } + i := i + 1 + count := count + 1 + count + (m - i) + +htShowSetTreeValue(setData) == + st := setData.setType + st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%") + st = 'INTEGER => object2String eval setData.setVar + st = 'STRING => object2String eval setData.setVar + st = 'LITERALS => + object2String translateTrueFalse2YesNo eval setData.setVar + st = 'TREE => '"..." + systemError() + +mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}") + +listOfStrings2String u == + null u => '"" + STRCONC(listOfStrings2String rest u,'" ",stringize first u) + +htShowSetPage(htPage, branch) == + setTree := htpProperty(htPage, 'setTree) + $path := [branch,:TAKE(- LASTATOM setTree,$path)] + setData := assoc(branch, setTree) + null setData => + systemError('"No Set Data") + st := setData.setType + st = 'FUNCTION => htShowFunctionPage(htPage, setData) + st = 'INTEGER => htShowIntegerPage(htPage,setData) + st = 'LITERALS => htShowLiteralsPage(htPage, setData) + st = 'TREE => htShowSetTree(setData.setLeaf) + + st = 'STRING => -- have to add this + htSetNotAvailable(htPage,'")set compiler") + + systemError '"Unknown data type" + +htShowLiteralsPage(htPage, setData) == + htSetLiterals(htPage,setData.setName,setData.setLabel, + setData.setVar,setData.setLeaf,'htSetLiteral) + +htSetLiterals(htPage,name,message,variable,values,functionToCall) == + page := htInitPage('"Set Command", htpPropertyList htPage) + htpSetProperty(page, 'variable, variable) + bcHt ['"\centerline{Set {\em ", name, '"}}\newline"] + bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] + bcHt '"Select one of the following: \newline\tab{3} " + links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values] + htMakePage [['bcLispLinks, :links]] + bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ", + translateTrueFalse2YesNo EVAL variable, '"} "] + htShowPage() + +htSetLiteral(htPage, val) == + htInitPage('"Set Command", nil) + SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) + htKill(htPage,val) + +htShowIntegerPage(htPage, setData) == + page := htInitPage(mkSetTitle(), htpPropertyList htPage) + htpSetProperty(page, 'variable, setData.setVar) + bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] +-- message := isKeyedMsgInDb($path,'(setvar text A)) or setData.setLabel + message := setData.setLabel + bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] + [$htInitial,$htFinal] := setData.setLeaf + if $htFinal = $htInitial + 1 + then + bcHt '"Enter the integer {\em " + bcHt stringize $htInitial + bcHt '"} or {\em " + bcHt stringize $htFinal + bcHt '"}:" + else if null $htFinal then + bcHt '"Enter an integer greater than {\em " + bcHt stringize ($htInitial - 1) + bcHt '"}:" + else + bcHt '"Enter an integer between {\em " + bcHt stringize $htInitial + bcHt '"} and {\em " + bcHt stringize $htFinal + bcHt '"}:" + htMakePage [ + '(domainConditions (Satisfies S chkRange)), + ['bcStrings,[5,eval setData.setVar,'value,'S]]] + htSetvarDoneButton('"Select to Set Value",'htSetInteger) + htShowPage() + +htSetInteger(htPage) == + htInitPage(mkSetTitle(), nil) + val := chkRange htpLabelInputString(htPage,'value) + not INTEGERP val => + errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"]) + SET(htpProperty(htPage, 'variable), val) + htKill(htPage,val) + +htShowFunctionPage(htPage,setData) == + fn := setData.setDef => FUNCALL(fn,htPage) + htpSetProperty(htPage,'setData,setData) + htpSetProperty(htPage,'parts, setData.setLeaf) + htShowFunctionPageContinued(htPage) + +htShowFunctionPageContinued(htPage) == + parts := htpProperty(htPage,'parts) + setData := htpProperty(htPage,'setData) + [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts + htpSetProperty(htPage, 'variable, variable) + htpSetProperty(htPage, 'checker, checker) + htpSetProperty(htPage, 'parts, restParts) + kind = 'LITERALS => htSetLiterals(htPage,setData.setName, + phrase,variable,checker,'htFunctionSetLiteral) + page := htInitPage(mkSetTitle(), htpPropertyList htPage) + bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] + bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "] + currentValue := EVAL variable + htMakePage + [ ['domainConditions, ['Satisfies,'S,checker]], + ['text,:phrase], + ['inputStrings, + [ '"", '"", 60, currentValue, 'value, 'S]]] + htSetvarDoneButton('"Select To Set Value",'htSetFunCommand) + htShowPage() + +htSetvarDoneButton(message, func) == + bcHt '"\newline\vspace{1}\centerline{" + + if message = '"Select to Set Value" or message = '"Select to Set Values" then + bchtMakeButton('"\lisplink",'"\ControlBitmap{ClickToSet}", func) + else + bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func) + + bcHt '"} " + + +htFunctionSetLiteral(htPage, val) == + htInitPage('"Set Command", nil) + SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) + htSetFunCommandContinue(htPage,val) + +htSetFunCommand(htPage) == + variable := htpProperty(htPage,'variable) + checker := htpProperty(htPage,'checker) + value := htCheck(checker,htpLabelInputString(htPage,'value)) + SET(variable,value) --kill this later + htSetFunCommandContinue(htPage,value) + +htSetFunCommandContinue(htPage,value) == + parts := htpProperty(htPage,'parts) + continue := + null parts => false + parts is [['break,predicate],:restParts] => eval predicate + true + continue => + htpSetProperty(htPage,'parts,restParts) + htShowFunctionPageContinued(htPage) + htKill(htPage,value) + +htKill(htPage,value) == + htInitPage('"System Command", nil) + string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}") + htMakePage [ + '(text + "{Here is the AXIOM system command you could have issued:}" + "\vspace{2}\newline\centerline{\tt"), + ['text,:string]] + htMakePage '((text . "}\vspace{1}\newline\rm")) + htSay '"\vspace{2}{Select \ \UpButton{} \ to go back.}" + htSay '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htSetNotAvailable(htPage,whatToType) == + page := htInitPage('"Unavailable Set Command", htpPropertyList htPage) + htInitPage('"Unavailable System Command", nil) + string := STRCONC('"{\em ",whatToType,'"}") + htMakePage [ + '(text "\vspace{1}\newline" + "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" + "\vspace{2}\newline\centerline{\tt"), + ['text,:string]] + htMakePage '((text . "}\vspace{1}\newline")) + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htDoNothing(htPage,command) == nil + +htCheck(checker,value) == + PAIRP checker => htCheckList(checker,parseWord value) + FUNCALL(checker,value) + +parseWord x == + STRINGP x => + and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x + INTERN x + x + +htCheckList(checker,value) == + if value in '(y ye yes Y YE YES) then value := 'yes + if value in '(n no N NO) then value := 'no + checker is [n,m] and INTEGERP n => + m = n + 1 => + value in checker => value + n + null m => + INTEGERP value and value >= n => value + n + INTEGERP m => + INTEGERP value and value >= n and value <= m => value + n + value in checker => value + first checker +-- emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker] +-- STRCONC('"Please enter one of: ",emlist) + +translateYesNoToTrueFalse x == + x = 'yes => true + x = 'no => false + x + +chkNameList x == + u := bcString2ListWords x + parsedNames := [ncParseFromString x for x in u] + and/[IDENTP x for x in parsedNames] => parsedNames + '"Please enter a list of identifiers separated by blanks" + +chkPosInteger s == + (u := parseOnly s) and INTEGERP u and u > 0 => u + '"Please enter a positive integer" + +chkOutputFileName s == + bcString2WordList s in '(CONSOLE console) => 'console + chkDirectory s + +chkDirectory s == s + +chkNonNegativeInteger s == + (u := ncParseFromString s) and INTEGERP u and u >= 0 => u + '"Please enter a non-negative integer" + +chkRange s == + (u := ncParseFromString s) and INTEGERP u + and u >= $htInitial and (NULL $htFinal or u <= $htFinal) + => u + null $htFinal => + STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1)) + STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ", + stringize $htFinal) + +chkAllNonNegativeInteger s == + (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL + or chkNonNegativeInteger s + or '"Please enter {\em all} or a non-negative integer" + +htMakePathKey path == + null path => systemError '"path is not set" + INTERN fn(PNAME first path,rest path) where + fn(a,b) == + null b => a + fn(STRCONC(a,'".",PNAME first b),rest b) + +htMarkTree(tree,n) == + RPLACD(LASTTAIL tree,n) + for branch in tree repeat + branch.3 = 'TREE => htMarkTree(branch.5,n + 1) + +htSetHistory htPage == + msg := "when the history facility is on (yes), results of computations are saved in memory" + data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)] + htShowLiteralsPage(htPage,data) + +htSetOutputLibrary htPage == + htSetNotAvailable(htPage,'")set compiler output") + +htSetInputLibrary htPage == + htSetNotAvailable(htPage,'")set compiler input") + +htSetExpose htPage == + htSetNotAvailable(htPage,'")set expose") + +htSetKernelProtect htPage == + htSetNotAvailable(htPage,'")set kernel protect") + +htSetKernelWarn htPage == + htSetNotAvailable(htPage,'")set kernel warn") + +htSetOutputCharacters htPage == + htSetNotAvailable(htPage,'")set output characters") + +htSetLinkerArgs htPage == + htSetNotAvailable(htPage,'")set fortran calling linker") + +htSetCache(htPage,:options) == + $path := '(functions cache) + htPage := htInitPage(mkSetTitle(),nil) + $valueList := nil + htMakePage '( + (text + "Use this system command to cause the AXIOM interpreter to `remember' " + "past values of interpreter functions. " + "To remember a past value of a function, the interpreter " + "sets up a {\em cache} for that function based on argument values. " + "When a value is cached for a given argument value, its value is gotten " + "from the cache and not recomputed. Caching can often save much " + "computing time, particularly with recursive functions or functions that " + "are expensive to compute and that are called repeatedly " + "with the same argument." + "\vspace{1}\newline ") + (domainConditions (Satisfies S chkNameList)) + (text + "Enter below a list of interpreter functions you would like specially cached. " + "Use the name {\em all} to give a default setting for all " + "interpreter functions. " + "\vspace{1}\newline " + "Enter {\em all} or a list of names (separate names by blanks):") + (inputStrings ("" "" 60 "all" names S)) + (doneButton "Push to enter names" htCacheAddChoice)) + htShowPage() + +htCacheAddChoice htPage == + names := bcString2WordList htpLabelInputString(htPage,'names) + $valueList := [listOfStrings2String names,:$valueList] + null names => htCacheAddQuery() + null rest names => htCacheOne names + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page,'names,names) + htMakePage '( + (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) + (text + "For each function, enter below a {\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. " + "A cache length of {\em 0} means the function won't be cached. " + "To cache all past values, " + "enter {\em all}." + "\vspace{1}\newline " + "For each function name, enter {\em all} or a positive integer:")) + for i in 1.. for name in names repeat htMakePage [ + ['inputStrings, + [STRCONC('"Function {\em ",name,'"} will cache"), + '"values",5,10,htMakeLabel('"c",i),'ALLPI]]] + htSetvarDoneButton('"Select to Set Values",'htCacheSet) + htShowPage() + +htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i) + +htCacheSet htPage == + names := htpProperty(htPage,'names) + for i in 1.. for name in names repeat + num := chkAllNonNegativeInteger + htpLabelInputString(htPage,htMakeLabel('"c",i)) + $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist) + if (n := LASSOC('all,$cacheAlist)) then + $cacheCount := n + $cacheAlist := deleteAssoc('all,$cacheAlist) + htInitPage('"Cache Summary",nil) + bcHt '"In general, interpreter functions " + bcHt + $cacheCount = 0 => "will {\em not} be cached." + bcHt '"cache " + htAllOrNum $cacheCount + '"} values." + bcHt '"\vspace{1}\newline " + if $cacheAlist then +-- bcHt '" However, \indent{3}" + for [name,:val] in $cacheAlist | val ^= $cacheCount repeat + bcHt '"\newline function {\em " + bcHt stringize name + bcHt '"} will cache " + htAllOrNum val + bcHt '"} values" + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htAllOrNum val == bcHt + val = 'all => '"{\em all" + val = 0 => '"{\em no" + STRCONC('"the last {\em ",stringize val) + +htCacheOne names == + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page,'names,names) + htMakePage '( + (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) + (text + "Enter below a {\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. To cache all past values, " + "enter {\em all}." + "\vspace{1}\newline ") + (inputStrings + ("Enter {\em all} or a positive integer:" + "" 5 10 c1 ALLPI))) + htSetvarDoneButton('"Select to Set Value",'htCacheSet) + htShowPage() + + + + + + + + |