diff --git a/changelog b/changelog index 0000e38..d66592f 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090822 tpd src/axiom-website/patches.html 20090822.06.tpd.patch +20090822 tpd src/interp/Makefile move i-syscmd.boot to i-syscmd.lisp +20090822 tpd src/interp/i-syscmd.lisp added, rewritten from i-syscmd.boot +20090822 tpd src/interp/i-syscmd.boot removed, rewritten to i-syscmd.lisp 20090822 tpd src/axiom-website/patches.html 20090822.05.tpd.patch 20090822 tpd src/interp/Makefile move i-spec2.boot to i-spec2.lisp 20090822 tpd src/interp/i-spec2.lisp added, rewritten from i-spec2.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 52238a8..d069f35 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1844,5 +1844,7 @@ i-resolv.lisp rewrite from boot to lisp
i-spec1.lisp rewrite from boot to lisp
20090822.05.tpd.patch i-spec2.lisp rewrite from boot to lisp
+20090822.06.tpd.patch +i-syscmd.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 4a7e784..4505459 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -431,7 +431,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/info.boot.dvi ${DOC}/interop.boot.dvi \ ${DOC}/intfile.boot.dvi \ ${DOC}/intint.lisp.dvi ${DOC}/int-top.boot.dvi \ - ${DOC}/i-syscmd.boot.dvi ${DOC}/iterator.boot.dvi \ + ${DOC}/iterator.boot.dvi \ ${DOC}/i-toplev.boot.dvi ${DOC}/i-util.boot.dvi \ ${DOC}/lisplib.boot.dvi ${DOC}/macex.boot.dvi \ ${DOC}/Makefile.dvi \ @@ -3365,47 +3365,27 @@ ${MID}/i-spec2.lisp: ${IN}/i-spec2.lisp.pamphlet @ -\subsection{i-syscmd.boot} +\subsection{i-syscmd.lisp} <>= -${OUT}/i-syscmd.${O}: ${MID}/i-syscmd.clisp - @ echo 318 making ${OUT}/i-syscmd.${O} from ${MID}/i-syscmd.clisp - @ (cd ${MID} ; \ +${OUT}/i-syscmd.${O}: ${MID}/i-syscmd.lisp + @ echo 136 making ${OUT}/i-syscmd.${O} from ${MID}/i-syscmd.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-syscmd.clisp"' \ + echo '(progn (compile-file "${MID}/i-syscmd.lisp"' \ ':output-file "${OUT}/i-syscmd.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-syscmd.clisp"' \ + echo '(progn (compile-file "${MID}/i-syscmd.lisp"' \ ':output-file "${OUT}/i-syscmd.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-syscmd.clisp: ${IN}/i-syscmd.boot.pamphlet - @ echo 319 making ${MID}/i-syscmd.clisp \ - from ${IN}/i-syscmd.boot.pamphlet +<>= +${MID}/i-syscmd.lisp: ${IN}/i-syscmd.lisp.pamphlet + @ echo 137 making ${MID}/i-syscmd.lisp from \ + ${IN}/i-syscmd.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-syscmd.boot.pamphlet >i-syscmd.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-syscmd.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-syscmd.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-syscmd.boot ) - -@ -<>= -${DOC}/i-syscmd.boot.dvi: ${IN}/i-syscmd.boot.pamphlet - @echo 320 making ${DOC}/i-syscmd.boot.dvi \ - from ${IN}/i-syscmd.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-syscmd.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-syscmd.boot ; \ - rm -f ${DOC}/i-syscmd.boot.pamphlet ; \ - rm -f ${DOC}/i-syscmd.boot.tex ; \ - rm -f ${DOC}/i-syscmd.boot ) + ${TANGLE} ${IN}/i-syscmd.lisp.pamphlet >i-syscmd.lisp ) @ @@ -6463,8 +6443,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-syscmd.boot.pamphlet b/src/interp/i-syscmd.boot.pamphlet deleted file mode 100644 index a73b79d..0000000 --- a/src/interp/i-syscmd.boot.pamphlet +++ /dev/null @@ -1,985 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-syscmd.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. - -@ -<<*>>= -<> - ---% Utility Variable Initializations - -SETANDFILEQ($cacheAlist,nil) -SETANDFILEQ($reportCompilation,nil) -SETANDFILEQ($compileRecurrence,true) -SETANDFILEQ($errorReportLevel,'warning) -SETANDFILEQ($sourceFileTypes,'(INPUT SPAD BOOT LISP LISP370 META)) - -SETANDFILEQ($countAssoc,'( (cache countCache) )) - ---% Top level system command --- (mapcar #'car $systemCommands) -initializeSystemCommands() == - l := $systemCommands - $SYSCOMMANDS := NIL - while l repeat - $SYSCOMMANDS := CONS(CAAR l, $SYSCOMMANDS) - l := CDR l - $SYSCOMMANDS := NREVERSE $SYSCOMMANDS - -systemCommand [[op,:argl],:options] == - $options: local:= options - $e:local := $CategoryFrame - fun := selectOptionLC(op,$SYSCOMMANDS,'commandError) - argl and (argl.0 = '_?) and fun ^= 'synonym => - helpSpad2Cmd [fun] - fun := selectOption(fun,commandsForUserLevel $systemCommands, - 'commandUserLevelError) - FUNCALL(fun, argl) - -commandsForUserLevel l == --[a for [a,:b] in l | satisfiesUserLevel(a)] - c := nil - for [a,:b] in l repeat - satisfiesUserLevel b => c := [a,:c] - reverse c - -synonymsForUserLevel l == - -- l is a list of synonyms, and this returns a sublist of applicable - -- synonyms at the current user level. - $UserLevel = 'development => l - nl := NIL - for syn in reverse l repeat - cmd := STRING2ID_-N(CDR syn,1) - null selectOptionLC(cmd,commandsForUserLevel - $systemCommands,NIL) => nil - nl := [syn,:nl] - nl - -satisfiesUserLevel x == - x = 'interpreter => true - $UserLevel = 'interpreter => false - x = 'compiler => true - $UserLevel = 'compiler => false - true - -unAbbreviateKeyword x == - x' :=selectOptionLC(x,$SYSCOMMANDS,'commandErrorIfAmbiguous) - if not x' then - x' := 'system - SETQ(LINE, CONCAT('")system ", SUBSTRING(LINE, 1, #LINE-1))) - $currentLine := LINE - selectOption(x',commandsForUserLevel $systemCommands, - 'commandUserLevelError) - -hasOption(al,opt) == - optPname:= PNAME opt - found := NIL - for pair in al while not found repeat - stringPrefix?(PNAME CAR pair,optPname) => found := pair - found - -terminateSystemCommand() == TERSYSCOMMAND() - -commandUserLevelError(x,u) == userLevelErrorMessage("command",x,u) - -optionUserLevelError(x,u) == userLevelErrorMessage("option",x,u) - -userLevelErrorMessage(kind,x,u) == - null u => - sayKeyedMsg("S2IZ0007",[$UserLevel,kind]) - terminateSystemCommand() - commandAmbiguityError(kind,x,u) - -commandError(x,u) == commandErrorMessage("command",x,u) - -optionError(x,u) == commandErrorMessage("option",x,u) - -commandErrorIfAmbiguous(x, u) == - null u => nil - SETQ($OLDLINE, LINE) - commandAmbiguityError("command", x, u) - -commandErrorMessage(kind,x,u) == - SETQ ($OLDLINE,LINE) - null u => - sayKeyedMsg("S2IZ0008",[kind,x]) - terminateSystemCommand() - commandAmbiguityError(kind,x,u) - -commandAmbiguityError(kind,x,u) == - sayKeyedMsg("S2IZ0009",[kind,x]) - for a in u repeat sayMSG ['" ",:bright a] - terminateSystemCommand() - ---% Utility for access to original command line - -getSystemCommandLine() == - p := STRPOS('")",$currentLine,0,NIL) - line := if p then SUBSTRING($currentLine,p,NIL) else $currentLine - maxIndex:= MAXINDEX line - for i in 0..maxIndex while (line.i^=" ") repeat index:= i - if index=maxIndex then line := '"" - else line := SUBSTRING(line,index+2,nil) - line - ------------- start of commands ------------------------------------------ - ---% )display - -getParserMacroNames() == - REMDUP [CAR mac for mac in getParserMacros()] - ---------------------> NEW DEFINITION (override in patches.lisp.pamphlet) -clearParserMacro(macro) == - -- first see if it is one - not IFCDR ASSOC(macro, ($pfMacros)) => NIL - $pfMacros := REMALIST($pfMacros, macro) - -displayMacro name == - m := isInterpMacro name - null m => - sayBrightly ['" ",:bright name,'"is not an interpreter macro."] - -- $op is needed in the output routines. - $op : local := STRCONC('"macro ",object2String name) - [args,:body] := m - args := - null args => nil - null rest args => first args - ['Tuple,:args] - mathprint ['MAP,[args,:body]] - -displayWorkspaceNames() == - imacs := getInterpMacroNames() - pmacs := getParserMacroNames() - sayMessage '"Names of User-Defined Objects in the Workspace:" - names := MSORT append(getWorkspaceNames(),pmacs) - if null names - then sayBrightly " * None *" - else sayAsManyPerLineAsPossible [object2String x for x in names] - imacs := SETDIFFERENCE(imacs,pmacs) - if imacs then - sayMessage '"Names of System-Defined Objects in the Workspace:" - sayAsManyPerLineAsPossible [object2String x for x in imacs] - - -getWorkspaceNames() == - NMSORT [n for [n,:.] in CAAR $InteractiveFrame | - (n ^= "--macros--" and n^= "--flags--")] - -interpFunctionDepAlists() == - $e : local := $InteractiveFrame - deps := getFlag "$dependencies" - $dependentAlist := [[NIL,:NIL]] - $dependeeAlist := [[NIL,:NIL]] - for [dependee,dependent] in deps repeat - $dependentAlist := PUTALIST($dependentAlist,dependee, - CONS(dependent,GETALIST($dependentAlist,dependee))) - $dependeeAlist := PUTALIST($dependeeAlist,dependent, - CONS(dependee,GETALIST($dependeeAlist,dependent))) - -fixObjectForPrinting(v) == - v' := object2Identifier v - EQ(v',"%") => '"\%" - v' in $msgdbPrims => STRCONC('"\",PNAME v') - v - -displayProperties(option,l) == - $dependentAlist : local := nil - $dependeeAlist : local := nil - [opt,:vl]:= (l or ['properties]) - imacs := getInterpMacroNames() - pmacs := getParserMacroNames() - macros := REMDUP append(imacs, pmacs) - if vl is ['all] or null vl then - vl := MSORT append(getWorkspaceNames(),macros) - if $frameMessages then sayKeyedMsg("S2IZ0065",[$interpreterFrameName]) - null vl => - null $frameMessages => sayKeyedMsg("S2IZ0066",NIL) - sayKeyedMsg("S2IZ0067",[$interpreterFrameName]) - interpFunctionDepAlists() - for v in vl repeat - isInternalMapName(v) => 'iterate - pl := getIProplist(v) - option = 'flags => getAndSay(v,"flags") - option = 'value => displayValue(v,getI(v,'value),nil) - option = 'condition => displayCondition(v,getI(v,"condition"),nil) - option = 'mode => displayMode(v,getI(v,'mode),nil) - option = 'type => displayType(v,getI(v,'value),nil) - option = 'properties => - v = "--flags--" => nil - pl is [['cacheInfo,:.],:.] => nil - v1 := fixObjectForPrinting(v) - sayMSG ['"Properties of",:bright prefix2String v1,'":"] - null pl => - v in pmacs => - sayMSG '" This is a user-defined macro." - displayParserMacro v - isInterpMacro v => - sayMSG '" This is a system-defined macro." - displayMacro v - sayMSG '" none" - propsSeen:= nil - for [prop,:val] in pl | ^MEMQ(prop,propsSeen) and val repeat - prop in '(alias generatedCode IS_-GENSYM mapBody localVars) => - nil - prop = 'condition => - displayCondition(prop,val,true) - prop = 'recursive => - sayMSG '" This is recursive." - prop = 'isInterpreterFunction => - sayMSG '" This is an interpreter function." - sayFunctionDeps v where - sayFunctionDeps x == - if dependents := GETALIST($dependentAlist,x) then - null rest dependents => - sayMSG ['" The following function or rule ", - '"depends on this:",:bright first dependents] - sayMSG - '" The following functions or rules depend on this:" - msg := ["%b",'" "] - for y in dependents repeat msg := ['" ",y,:msg] - sayMSG [:nreverse msg,"%d"] - if dependees := GETALIST($dependeeAlist,x) then - null rest dependees => - sayMSG ['" This depends on the following function ", - '"or rule:",:bright first dependees] - sayMSG - '" This depends on the following functions or rules:" - msg := ["%b",'" "] - for y in dependees repeat msg := ['" ",y,:msg] - sayMSG [:nreverse msg,"%d"] - prop = 'isInterpreterRule => - sayMSG '" This is an interpreter rule." - sayFunctionDeps v - prop = 'localModemap => - displayModemap(v,val,true) - prop = 'mode => - displayMode(prop,val,true) - prop = 'value => - val => displayValue(v,val,true) - sayMSG ['" ",prop,'": ",val] - propsSeen:= [prop,:propsSeen] - sayKeyedMsg("S2IZ0068",[option]) - terminateSystemCommand() - -displayModemap(v,val,giveVariableIfNil) == - for mm in val repeat g(v,mm,giveVariableIfNil) where - g(v,mm,giveVariableIfNil) == - [[local,:signature],fn,:.]:= mm - local='interpOnly => nil - varPart:= (giveVariableIfNil => nil; ['" of",:bright v]) - prefix:= [" Compiled function type",:varPart,": "] - sayBrightly concat(prefix,formatSignature signature) - -displayMode(v,mode,giveVariableIfNil) == - null mode => nil - varPart:= (giveVariableIfNil => nil; [" of",:bright fixObjectForPrinting v]) - sayBrightly concat(" Declared type or mode", - varPart,": ",prefix2String mode) - -displayCondition(v,condition,giveVariableIfNil) == - varPart:= (giveVariableIfNil => nil; [" of",:bright v]) - condPart:= condition or 'true - sayBrightly concat(" condition",varPart,": ",pred2English condPart) - -getAndSay(v,prop) == - val:= getI(v,prop) => sayMSG [" ",val,'%l] - sayMSG [" none",'%l] - -displayType($op,u,omitVariableNameIfTrue) == - null u => - sayMSG ['" Type of value of ", - fixObjectForPrinting PNAME $op,'": (none)"] - type := prefix2String objMode(u) - if ATOM type then type := [type] - sayMSG concat ['" Type of value of ",fixObjectForPrinting PNAME $op,'": ",:type] - NIL - -displayValue($op,u,omitVariableNameIfTrue) == - null u => sayMSG [" Value of ",fixObjectForPrinting PNAME $op,'": (none)"] - expr := objValUnwrap(u) - expr is [op,:.] and (op = 'MAP) or objMode(u) = $EmptyMode => - displayRule($op,expr) - label:= - omitVariableNameIfTrue => - rhs := '"): " - '"Value (has type " - rhs := '": " - STRCONC('"Value of ", PNAME $op,'": ") - labmode := prefix2String objMode(u) - if ATOM labmode then labmode := [labmode] - GETDATABASE(expr,'CONSTRUCTORKIND) = 'domain => - sayMSG concat('" ",label,labmode,rhs,form2String expr) - mathprint ['CONCAT,label,:labmode,rhs, - outputFormat(expr,objMode(u))] - NIL - ---% )load - -load args == loadSpad2Cmd args - -loadSpad2Cmd args == - sayKeyedMsg("S2IU0003", nil) - NIL --- load1(args,$forceDatabaseUpdate) - ---load1(args,$forceDatabaseUpdate) == -- $ var is now local --- null args => helpSpad2Cmd '(load) --- loadfun := 'loadLib --- justWondering := nil --- compiler := 'old --- doExpose := true --- $forceDatabaseUpdate := true -- BMT request, 5/14/90 --- for [opt,:.] in $options repeat --- fullopt := selectOptionLC(opt, --- '(cond update query new noexpose noupdate), --- 'optionError) --- fullopt = 'cond => loadfun := 'loadLibIfNotLoaded --- fullopt = 'query => justWondering := true --- fullopt = 'update => $forceDatabaseUpdate := true --- fullopt = 'noexpose => doExpose := false --- fullopt = 'noupdate => $forceDatabaseUpdate := false --- if $forceDatabaseUpdate then clearClams() --- for lib in args repeat --- lib := object2Identifier lib --- justWondering => --- GET(lib,'LOADED) => sayKeyedMsg("S2IZ0028",[lib]) --- sayKeyedMsg("S2IZ0029",[lib]) --- null GETDATABASE(lib,'OBJECT) and --- null (lib := GETDATABASE(lib,'CONSTRUCTOR)) => --- sayKeyedMsg("S2IL0020", [namestring [lib,$spadLibFT,"*"]]) --- null FUNCALL(loadfun,lib) => --- sayKeyedMsg("S2IZ0029",[lib]) --- sayKeyedMsg("S2IZ0028",[lib]) --- if doExpose and --- not isExposedConstructor(lib) then --- setExposeAddConstr([lib]) --- 'EndOfLoad - -reportCount () == - centerAndHighlight(" Current Count Settings ",$LINELENGTH,specialChar 'hbar) - SAY " " - sayBrightly [:bright " cache",fillerSpaces(30,'".")," ",$cacheCount] - if $cacheAlist then - for [a,:b] in $cacheAlist repeat - aPart:= linearFormatName a - n:= sayBrightlyLength aPart - sayBrightly concat(" ",aPart," ",fillerSpaces(32-n,'".")," ",b) - SAY " " - sayBrightly [:bright " stream",fillerSpaces(29,'".")," ",$streamCount] - ---% )read - -read l == readSpad2Cmd l - -readSpad2Cmd l == - ---$saturn => - --- sayErrorly('"Obsolete system command", _ - --- ['" The )read system command is obsolete in this version of AXIOM.", - --- '" Please use Open from the File menu instead."]) - $InteractiveMode : local := true - quiet := nil - ifthere := nil - for [opt,:.] in $options repeat - fullopt := selectOptionLC(opt,'(quiet test ifthere),'optionError) - fullopt = 'ifthere => ifthere := true - fullopt = 'quiet => quiet := true - - ef := pathname _/EDITFILE - if pathnameTypeId(ef) = 'SPAD then - ef := makePathname(pathnameName ef,'"*",'"*") - if l then - l := mergePathnames(pathname l,ef) - else - l := ef - devFTs := '("input" "INPUT" "boot" "BOOT" "lisp" "LISP") - fileTypes := - $UserLevel = 'interpreter => '("input" "INPUT") - $UserLevel = 'compiler => '("input" "INPUT") - devFTs - ll := $FINDFILE (l, fileTypes) - if null ll then - ifthere => return nil -- be quiet about it - throwKeyedMsg("S2IL0003",[namestring l]) - ll := pathname ll - ft := pathnameType ll - upft := UPCASE ft - null MEMBER(upft,fileTypes) => - fs := namestring l - MEMBER(upft,devFTs) => throwKeyedMsg("S2IZ0033",[fs]) - throwKeyedMsg("S2IZ0034",[fs]) - SETQ(_/EDITFILE,ll) - if upft = '"BOOT" then $InteractiveMode := nil - _/READ(ll,quiet) - ---% )savesystem -savesystem l == - #l ^= 1 or not(SYMBOLP CAR l) => helpSpad2Cmd '(savesystem) - SPAD_-SAVE SYMBOL_-NAME CAR l - ---% )show - -show l == showSpad2Cmd l - -showSpad2Cmd l == - l = [NIL] => helpSpad2Cmd '(show) - $showOptions : local := '(attributes operations) - if null $options then $options := '((operations)) - $e : local := $InteractiveFrame - $env : local := $InteractiveFrame - l is [constr] => - constr in '(Union Record Mapping) => - constr = 'Record => - sayKeyedMsg("S2IZ0044R",[constr, '")show Record(a: Integer, b: String)"]) - constr = 'Mapping => - sayKeyedMsg("S2IZ0044M",NIL) - sayKeyedMsg("S2IZ0045T",[constr, '")show Union(a: Integer, b: String)"]) - sayKeyedMsg("S2IZ0045U",[constr, '")show Union(Integer, String)"]) - constr is ['Mapping, :.] => - sayKeyedMsg("S2IZ0044M",NIL) - reportOperations(constr,constr) - reportOperations(l,l) - -reportOperations(oldArg,u) == - -- u might be an uppercased version of oldArg - $env:local := [[NIL]] - $eval:local := true --generate code-- don't just type analyze - $genValue:local := true --evaluate all generated code - null u => nil - $doNotAddEmptyModeIfTrue: local:= true - u = $quadSymbol => - sayBrightly ['" mode denotes", :bright '"any", "type"] - u = "%" => - sayKeyedMsg("S2IZ0063",NIL) - sayKeyedMsg("S2IZ0064",NIL) - u isnt ['Record,:.] and u isnt ['Union,:.] and - null(isNameOfType u) and u isnt ['typeOf,.] => - if ATOM oldArg then oldArg := [oldArg] - sayKeyedMsg("S2IZ0063",NIL) - for op in oldArg repeat - sayKeyedMsg("S2IZ0062",[opOf op]) - (v := isDomainValuedVariable u) => reportOpsFromUnitDirectly0 v - unitForm:= - atom u => opOf unabbrev u - unabbrev u - atom unitForm => reportOpsFromLisplib0(unitForm,u) - unitForm' := evaluateType unitForm - tree := mkAtree removeZeroOneDestructively unitForm - (unitForm' := isType tree) => reportOpsFromUnitDirectly0 unitForm' - sayKeyedMsg("S2IZ0041",[unitForm]) - -reportOpsFromUnitDirectly0 D == - $useEditorForShowOutput => - reportOpsFromUnitDirectly1 D - reportOpsFromUnitDirectly D - -reportOpsFromUnitDirectly1 D == - showFile := pathname ['SHOW,'LISTING,$listingDirectory] - _$ERASE showFile - $sayBrightlyStream : fluid := - DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) - sayShowWarning() - reportOpsFromUnitDirectly D - SHUT $sayBrightlyStream - editFile showFile - -sayShowWarning() == - sayBrightly - '"Warning: this is a temporary file and will be deleted the next" - sayBrightly - '" time you use )show. Rename it and FILE if you wish to" - sayBrightly - '" save the contents." - sayBrightly '"" - -reportOpsFromLisplib0(unitForm,u) == - $useEditorForShowOutput => reportOpsFromLisplib1(unitForm,u) - reportOpsFromLisplib(unitForm,u) - -reportOpsFromLisplib1(unitForm,u) == - showFile := pathname ['SHOW,'LISTING,$listingDirectory] - _$ERASE showFile - $sayBrightlyStream : fluid := - DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) - sayShowWarning() - reportOpsFromLisplib(unitForm,u) - SHUT $sayBrightlyStream - editFile showFile - -reportOpsFromUnitDirectly unitForm == - isRecordOrUnion := unitForm is [a,:.] and a in '(Record Union) - unit:= evalDomain unitForm - top:= CAR unitForm - kind:= GETDATABASE(top,'CONSTRUCTORKIND) - - sayBrightly concat('%b,formatOpType unitForm, - '%d,'"is a",'%b,kind,'%d, '"constructor.") - if not isRecordOrUnion then - abb := GETDATABASE(top,'ABBREVIATION) - sourceFile := GETDATABASE(top,'SOURCEFILE) - sayBrightly ['" Abbreviation for",:bright top,'"is",:bright abb] - verb := - isExposedConstructor top => '"is" - '"is not" - sayBrightly ['" This constructor",:bright verb, - '"exposed in this frame."] - sayBrightly ['" Issue",:bright STRCONC('")edit ", - namestring sourceFile),'"to see algebra source code for", - :bright abb,'%l] - - for [opt] in $options repeat - opt := selectOptionLC(opt,$showOptions,'optionError) - opt = 'attributes => - centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) - isRecordOrUnion => - sayBrightly '" Records and Unions have no attributes." - sayBrightly '"" - attList:= REMDUP MSORT [x for [x,:.] in unit.2] - say2PerLine [formatAttribute x for x in attList] - NIL - opt = 'operations => - $commentedOps: local := 0 - --new form is ( ) - centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) - sayBrightly '"" - if isRecordOrUnion - then - constructorFunction:= GET(top,"makeFunctionList") or - systemErrorHere '"reportOpsFromUnitDirectly" - [funlist,.]:= FUNCALL(constructorFunction,"$",unitForm, - $CategoryFrame) - sigList := REMDUP MSORT [[[a,b],true,[c,0,1]] for - [a,b,c] in funlist] - else - sigList:= REMDUP MSORT getOplistForConstructorForm unitForm - say2PerLine [formatOperation(x,unit) for x in sigList] - if $commentedOps ^= 0 then - sayBrightly - ['"Functions that are not yet implemented are preceded by", - :bright '"--"] - sayBrightly '"" - NIL - -reportOpsFromLisplib(op,u) == - null(fn:= constructor? op) => sayKeyedMsg("S2IZ0054",[u]) - argml := - (s := getConstructorSignature op) => KDR s - NIL - typ:= GETDATABASE(op,'CONSTRUCTORKIND) - nArgs:= #argml - argList:= KDR GETDATABASE(op,'CONSTRUCTORFORM) - functorForm:= [op,:argList] - argml:= EQSUBSTLIST(argList,$FormalMapVariableList,argml) - functorFormWithDecl:= [op,:[[":",a,m] for a in argList for m in argml]] - sayBrightly concat(bright form2StringWithWhere functorFormWithDecl, - '" is a",bright typ,'"constructor") - sayBrightly ['" Abbreviation for",:bright op,'"is",:bright fn] - verb := - isExposedConstructor op => '"is" - '"is not" - sayBrightly ['" This constructor",:bright verb, - '"exposed in this frame."] - sourceFile := GETDATABASE(op,'SOURCEFILE) - sayBrightly ['" Issue",:bright STRCONC('")edit ", - namestring sourceFile), - '"to see algebra source code for",:bright fn,'%l] - - for [opt] in $options repeat - opt := selectOptionLC(opt,$showOptions,'optionError) - opt = 'layout => - dc1 fn - opt = 'views => sayBrightly ['"To get",:bright '"views", - '"you must give parameters of constructor"] - opt = 'attributes => - centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) - sayBrightly '"" - attList:= REMDUP MSORT [x for [x,:.] in - GETDATABASE(op,'ATTRIBUTES)] - null attList => sayBrightly - concat('%b,form2String functorForm,'%d,"has no attributes.",'%l) - say2PerLine [formatAttribute x for x in attList] - NIL - opt = 'operations => displayOperationsFromLisplib functorForm - nil - -displayOperationsFromLisplib form == - [name,:argl] := form - kind := GETDATABASE(name,'CONSTRUCTORKIND) - centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) - opList:= GETDATABASE(name,'OPERATIONALIST) - null opList => reportOpsFromUnitDirectly form - opl:=REMDUP MSORT EQSUBSTLIST(argl,$FormalMapVariableList,opList) - ops:= nil - for x in opl repeat - ops := [:ops,:formatOperationAlistEntry(x)] - say2PerLine ops - nil - ---% )synonym - -synonym(:l) == synonymSpad2Cmd() -- always passed a null list - -synonymSpad2Cmd() == - line := getSystemCommandLine() - if line = '"" then printSynonyms(NIL) - else - pair := processSynonymLine line - if $CommandSynonymAlist then - PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) - else $CommandSynonymAlist := [pair] - terminateSystemCommand() - -processSynonymLine line == - key := STRING2ID_-N (line, 1) - value := removeKeyFromLine line where - removeKeyFromLine line == - line := dropLeadingBlanks line - mx := MAXINDEX line - for i in 0..mx repeat - line.i = " " => - return (for j in (i+1)..mx repeat - line.j ^= " " => return (SUBSTRING (line, j, nil))) - [key, :value] - -printSynonyms(patterns) == - centerAndHighlight("System Command Synonyms",$LINELENGTH,specialChar 'hbar) - ls := filterListOfStringsWithFn(patterns, [[STRINGIMAGE a,:b] - for [a,:b] in synonymsForUserLevel $CommandSynonymAlist], - function CAR) - printLabelledList(ls,'"user",'"synonyms",'")",patterns) - nil - -printLabelledList(ls,label1,label2,prefix,patterns) == - -- prefix goes before each element on each side of the list, eg, - -- ")" - null ls => - null patterns => - sayMessage ['" No ",label1,'"-defined ",label2,'" in effect."] - sayMessage ['" No ",label1,'"-defined ",label2,'" satisfying patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - if patterns then - sayMessage [label1,'"-defined ",label2,'" satisfying patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - for [syn,:comm] in ls repeat - if SUBSTRING(syn,0,1) = '"|" then syn := SUBSTRING(syn,1,NIL) - if syn = '"%i" then syn := '"%i " - wid := MAX(30 - (entryWidth syn),1) - sayBrightly concat('%b,prefix,syn,'%d, - fillerSpaces(wid,'"."),'" ",prefix,comm) - sayBrightly '"" - -whatCommands(patterns) == - label := STRCONC("System Commands for User Level: ", - STRINGIMAGE $UserLevel) - centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) - l := filterListOfStrings(patterns, - [(STRINGIMAGE a) for a in commandsForUserLevel $systemCommands]) - if patterns then - null l => - sayMessage ['"No system commands at this level matching patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - sayMessage ['"System commands at this level matching patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - if l then - sayAsManyPerLineAsPossible l - SAY " " - patterns => nil -- don't be so verbose - sayKeyedMsg("S2IZ0046",NIL) - nil - -reportWhatOptions() == - optList1:= "append"/[['%l,'" ",x] for x in $whatOptions] - sayBrightly - ['%b,'" )what",'%d,'"argument keywords are",'%b,:optList1,'%d,'%l, - '" or abbreviations thereof.",'%l, - '%l,'" Issue",'%b,'")what ?",'%d,'"for more information."] - -filterListOfStrings(patterns,names) == - -- names and patterns are lists of strings - -- returns: list of strings in names that contains any of the strings - -- in patterns - (null patterns) or (null names) => names - names' := NIL - for name in reverse names repeat - satisfiesRegularExpressions(name,patterns) => - names' := [name,:names'] - names' - -filterListOfStringsWithFn(patterns,names,fn) == - -- names and patterns are lists of strings - -- fn is something like CAR or CADR - -- returns: list of strings in names that contains any of the strings - -- in patterns - (null patterns) or (null names) => names - names' := NIL - for name in reverse names repeat - satisfiesRegularExpressions(FUNCALL(fn,name),patterns) => - names' := [name,:names'] - names' - -satisfiesRegularExpressions(name,patterns) == - -- this is a first cut - nf := true - dname := DOWNCASE COPY name - for pattern in patterns while nf repeat - -- use @ as a wildcard - STRPOS(pattern,dname,0,'"@") => nf := nil - null nf - ---% )with ... defined in daase.lisp (boot won't parse it) - ---% Synonym File Reader - ---------------------> NEW DEFINITION (override in util.lisp.pamphlet) -processSynonyms() == - p := STRPOS('")",LINE,0,NIL) - fill := '"" - if p - then - line := SUBSTRING(LINE,p,NIL); - if p > 0 then fill := SUBSTRING(LINE,0,p) - else - p := 0 - line := LINE - to := STRPOS ('" ", line, 1, nil) - if to then to := to - 1 - synstr := SUBSTRING (line, 1, to) - syn := STRING2ID_-N (synstr, 1) - null (fun := LASSOC (syn, $CommandSynonymAlist)) => NIL - to := STRPOS('")",fun,1,NIL) - if to and to ^= SIZE(fun)-1 then - opt := STRCONC('" ",SUBSTRING(fun,to,NIL)) - fun := SUBSTRING(fun,0,to-1) - else opt := '" " - if (SIZE synstr) > (SIZE fun) then - for i in (SIZE fun)..(SIZE synstr) repeat - fun := CONCAT (fun, '" ") --- $currentLine := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) - cl := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) - SETQ(LINE,cl) - SETQ(CHR,LINE.(p+1)) - processSynonyms () - --- functions for interfacing to system commands from algebra code --- common lisp dependent - -tabsToBlanks s == - k := charPosition($charTab,s,0) - n := #s - k < n => - k = 0 => tabsToBlanks SUBSTRING(s,1,nil) - STRCONC(SUBSTRING(s,0,k),$charBlank, tabsToBlanks SUBSTRING(s,k + 1,nil)) - s - -doSystemCommand string == - string := CONCAT('")", EXPAND_-TABS string) - LINE: fluid := string - processSynonyms() - string := LINE - string:=SUBSTRING(string,1,nil) - string = '"" => nil - tok:=getFirstWord(string) - tok => - unab := unAbbreviateKeyword tok - MEMBER(unab, $noParseCommands) => - handleNoParseCommands(unab, string) - optionList := splitIntoOptionBlocks string - MEMBER(unab, $tokenCommands) => - handleTokensizeSystemCommands(unab, optionList) - handleParsedSystemCommands(unab, optionList) - nil - nil - -npboot str == - sex := string2BootTree str - FORMAT(true, '"~&~S~%", sex) - $ans := EVAL sex - FORMAT(true, '"~&Value = ~S~%", $ans) - -stripLisp str == - found := false - strIndex := 0 - lispStr := '"lisp" - for c0 in 0..#str-1 for c1 in 0..#lispStr-1 repeat - (char str.c0) ^= (char lispStr.c1) => - return nil - strIndex := c0+1 - SUBSEQ(str, strIndex) - - -nplisp str == - $ans := EVAL READ_-FROM_-STRING str - FORMAT(true, '"~&Value = ~S~%", $ans) - -npsystem(unab, str) == - spaceIndex := SEARCH('" ", str) - null spaceIndex => - sayKeyedMsg('"S2IZ0080", [str]) - sysPart := SUBSEQ(str, 0, spaceIndex) - -- The following is a hack required by the fact that unAbbreviateKeyword - -- returns the word "system" for unknown words - null SEARCH(sysPart, STRING unab) => - sayKeyedMsg('"S2IZ0080", [sysPart]) - command := SUBSEQ(str, spaceIndex+1) - OBEY command - -npsynonym(unab, str) == - npProcessSynonym(str) - -tokenSystemCommand(unabr, tokList) == - systemCommand tokList - -tokTran tok == - STRINGP tok => - #tok = 0 => nil - isIntegerString tok => READ_-FROM_-STRING tok - STRING tok.0 = '"_"" => - SUBSEQ(tok, 1, #tok-1) - INTERN tok - tok - -isIntegerString tok == - for i in 0..#tok-1 repeat - val := DIGIT_-CHAR_-P tok.i - not val => return nil - val - -splitIntoOptionBlocks str == - inString := false - optionBlocks := nil - blockStart := 0 - parenCount := 0 - for i in 0..#str-1 repeat - STRING str.i = '"_"" => - inString := not inString - if STRING str.i = '"(" and not inString - then parenCount := parenCount + 1 - if STRING str.i = '")" and not inString - then parenCount := parenCount - 1 - STRING str.i = '")" and not inString and parenCount = -1 => - block := stripSpaces SUBSEQ(str, blockStart, i) - blockList := [block, :blockList] - blockStart := i+1 - parenCount := 0 - blockList := [stripSpaces SUBSEQ(str, blockStart), :blockList] - nreverse blockList - -dumbTokenize str == - -- split into tokens delimted by spaces, taking quoted strings into account - inString := false - tokenList := nil - tokenStart := 0 - previousSpace := false - for i in 0..#str-1 repeat - STRING str.i = '"_"" => - inString := not inString - previousSpace := false - STRING str.i = '" " and not inString => - previousSpace => nil - token := stripSpaces SUBSEQ(str, tokenStart, i) - tokenList := [token, :tokenList] - tokenStart := i+1 - previousSpace := true - previousSpace := false - tokenList := [stripSpaces SUBSEQ(str, tokenStart), :tokenList] - nreverse tokenList - -handleParsedSystemCommands(unabr, optionList) == - restOptionList := [dumbTokenize opt for opt in CDR optionList] - parcmd := [parseSystemCmd CAR optionList, - :[[tokTran tok for tok in opt] for opt in restOptionList]] - systemCommand parcmd - -parseSystemCmd opt == - spaceIndex := SEARCH('" ", opt) - spaceIndex => - commandString := stripSpaces SUBSEQ(opt, 0, spaceIndex) - argString := stripSpaces SUBSEQ(opt, spaceIndex) - command := tokTran commandString - pform := parseFromString argString - [command, pform] - [tokTran tok for tok in dumbTokenize opt] - ---------------------> NEW DEFINITION (override in osyscmd.boot.pamphlet) -parseFromString(s) == - $useNewParser => - ncParseFromString s - $InteractiveMode :local := true - $BOOT: local := NIL - $SPAD: local := true - $e:local := $InteractiveFrame - string2SpadTree s - -handleTokensizeSystemCommands(unabr, optionList) == - optionList := [dumbTokenize opt for opt in optionList] - parcmd := [[tokTran tok for tok in opt] for opt in optionList] - parcmd => tokenSystemCommand(unabr, parcmd) - -getFirstWord string == - spaceIndex := SEARCH('" ", string) - null spaceIndex => string - stripSpaces SUBSEQ(string, 0, spaceIndex) - -ltrace l == trace l - ---------------------> NEW DEFINITION (see intint.lisp.pamphlet) -stripSpaces str == - STRING_-TRIM([char '" "], str) - -npProcessSynonym(str) == - if str = '"" then printSynonyms(NIL) - else - pair := processSynonymLine str - if $CommandSynonymAlist then - PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) - else $CommandSynonymAlist := [pair] - terminateSystemCommand() - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} [[src/interp/setq.lisp.pamphlet]] -\end{thebibliography} -\end{document} diff --git a/src/interp/i-syscmd.lisp.pamphlet b/src/interp/i-syscmd.lisp.pamphlet new file mode 100644 index 0000000..6063fc3 --- /dev/null +++ b/src/interp/i-syscmd.lisp.pamphlet @@ -0,0 +1,3192 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-syscmd.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;--% Utility Variable Initializations +;SETANDFILEQ($cacheAlist,nil) + +(SETANDFILEQ |$cacheAlist| NIL) + +;SETANDFILEQ($reportCompilation,nil) + +(SETANDFILEQ |$reportCompilation| NIL) + +;SETANDFILEQ($compileRecurrence,true) + +(SETANDFILEQ |$compileRecurrence| (QUOTE T)) + +;SETANDFILEQ($errorReportLevel,'warning) + +(SETANDFILEQ |$errorReportLevel| (QUOTE |warning|)) + +;SETANDFILEQ($sourceFileTypes,'(INPUT SPAD BOOT LISP LISP370 META)) + +(SETANDFILEQ |$sourceFileTypes| (QUOTE (INPUT SPAD BOOT LISP LISP370 META))) + +;SETANDFILEQ($countAssoc,'( (cache countCache) )) + +(SETANDFILEQ |$countAssoc| (QUOTE ((|cache| |countCache|)))) + +;--% Top level system command +;-- (mapcar #'car $systemCommands) +;initializeSystemCommands() == +; l := $systemCommands +; $SYSCOMMANDS := NIL +; while l repeat +; $SYSCOMMANDS := CONS(CAAR l, $SYSCOMMANDS) +; l := CDR l +; $SYSCOMMANDS := NREVERSE $SYSCOMMANDS + +(DEFUN |initializeSystemCommands| () + (PROG (|l|) + (RETURN + (SEQ (PROGN + (SPADLET |l| |$systemCommands|) + (SPADLET $SYSCOMMANDS NIL) + (DO () ((NULL |l|) NIL) + (SEQ (EXIT (PROGN + (SPADLET $SYSCOMMANDS + (CONS (CAAR |l|) $SYSCOMMANDS)) + (SPADLET |l| (CDR |l|)))))) + (SPADLET $SYSCOMMANDS (NREVERSE $SYSCOMMANDS))))))) + +;systemCommand [[op,:argl],:options] == +; $options: local:= options +; $e:local := $CategoryFrame +; fun := selectOptionLC(op,$SYSCOMMANDS,'commandError) +; argl and (argl.0 = '_?) and fun ^= 'synonym => +; helpSpad2Cmd [fun] +; fun := selectOption(fun,commandsForUserLevel $systemCommands, +; 'commandUserLevelError) +; FUNCALL(fun, argl) + +(DEFUN |systemCommand| (G166076) + (PROG (|$options| |$e| |op| |argl| |options| |fun|) + (DECLARE (SPECIAL |$options| |$e|)) + (RETURN + (PROGN + (SPADLET |op| (CAAR G166076)) + (SPADLET |argl| (CDAR G166076)) + (SPADLET |options| (CDR G166076)) + (SPADLET |$options| |options|) + (SPADLET |$e| |$CategoryFrame|) + (SPADLET |fun| + (|selectOptionLC| |op| $SYSCOMMANDS '|commandError|)) + (COND + ((AND |argl| (BOOT-EQUAL (ELT |argl| 0) '?) + (NEQUAL |fun| '|synonym|)) + (|helpSpad2Cmd| (CONS |fun| NIL))) + ('T + (SPADLET |fun| + (|selectOption| |fun| + (|commandsForUserLevel| |$systemCommands|) + '|commandUserLevelError|)) + (FUNCALL |fun| |argl|))))))) + +;commandsForUserLevel l == --[a for [a,:b] in l | satisfiesUserLevel(a)] +; c := nil +; for [a,:b] in l repeat +; satisfiesUserLevel b => c := [a,:c] +; reverse c + +(DEFUN |commandsForUserLevel| (|l|) + (PROG (|a| |b| |c|) + (RETURN + (SEQ (PROGN + (SPADLET |c| NIL) + (SEQ (DO ((G166110 |l| (CDR G166110)) (G166101 NIL)) + ((OR (ATOM G166110) + (PROGN + (SETQ G166101 (CAR G166110)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G166101)) + (SPADLET |b| (CDR G166101)) + G166101) + NIL)) + NIL) + (SEQ (EXIT (COND + ((|satisfiesUserLevel| |b|) + (EXIT (SPADLET |c| (CONS |a| |c|)))))))) + (REVERSE |c|))))))) + +;synonymsForUserLevel l == +; -- l is a list of synonyms, and this returns a sublist of applicable +; -- synonyms at the current user level. +; $UserLevel = 'development => l +; nl := NIL +; for syn in reverse l repeat +; cmd := STRING2ID_-N(CDR syn,1) +; null selectOptionLC(cmd,commandsForUserLevel +; $systemCommands,NIL) => nil +; nl := [syn,:nl] +; nl + +(DEFUN |synonymsForUserLevel| (|l|) + (PROG (|cmd| |nl|) + (RETURN + (SEQ (COND + ((BOOT-EQUAL |$UserLevel| '|development|) |l|) + ('T (SPADLET |nl| NIL) + (DO ((G166131 (REVERSE |l|) (CDR G166131)) + (|syn| NIL)) + ((OR (ATOM G166131) + (PROGN (SETQ |syn| (CAR G166131)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |cmd| + (STRING2ID-N (CDR |syn|) 1)) + (COND + ((NULL (|selectOptionLC| |cmd| + (|commandsForUserLevel| + |$systemCommands|) + NIL)) + NIL) + ('T (SPADLET |nl| (CONS |syn| |nl|)))))))) + |nl|)))))) + +;satisfiesUserLevel x == +; x = 'interpreter => true +; $UserLevel = 'interpreter => false +; x = 'compiler => true +; $UserLevel = 'compiler => false +; true + +(DEFUN |satisfiesUserLevel| (|x|) + (COND + ((BOOT-EQUAL |x| '|interpreter|) 'T) + ((BOOT-EQUAL |$UserLevel| '|interpreter|) NIL) + ((BOOT-EQUAL |x| '|compiler|) 'T) + ((BOOT-EQUAL |$UserLevel| '|compiler|) NIL) + ('T 'T))) + +;unAbbreviateKeyword x == +; x' :=selectOptionLC(x,$SYSCOMMANDS,'commandErrorIfAmbiguous) +; if not x' then +; x' := 'system +; SETQ(LINE, CONCAT('")system ", SUBSTRING(LINE, 1, #LINE-1))) +; $currentLine := LINE +; selectOption(x',commandsForUserLevel $systemCommands, +; 'commandUserLevelError) + +(DEFUN |unAbbreviateKeyword| (|x|) + (PROG (|x'|) + (RETURN + (PROGN + (SPADLET |x'| + (|selectOptionLC| |x| $SYSCOMMANDS + '|commandErrorIfAmbiguous|)) + (COND + ((NULL |x'|) (SPADLET |x'| '|system|) + (SETQ LINE + (CONCAT (MAKESTRING ")system ") + (SUBSTRING LINE 1 + (SPADDIFFERENCE (|#| LINE) 1)))) + (SPADLET |$currentLine| LINE))) + (|selectOption| |x'| (|commandsForUserLevel| |$systemCommands|) + '|commandUserLevelError|))))) + +;hasOption(al,opt) == +; optPname:= PNAME opt +; found := NIL +; for pair in al while not found repeat +; stringPrefix?(PNAME CAR pair,optPname) => found := pair +; found + +(DEFUN |hasOption| (|al| |opt|) + (PROG (|optPname| |found|) + (RETURN + (SEQ (PROGN + (SPADLET |optPname| (PNAME |opt|)) + (SPADLET |found| NIL) + (SEQ (DO ((G166160 |al| (CDR G166160)) (|pair| NIL)) + ((OR (ATOM G166160) + (PROGN (SETQ |pair| (CAR G166160)) NIL) + (NULL (NULL |found|))) + NIL) + (SEQ (EXIT (COND + ((|stringPrefix?| (PNAME (CAR |pair|)) + |optPname|) + (EXIT (SPADLET |found| |pair|))))))) + (EXIT |found|))))))) + +;terminateSystemCommand() == TERSYSCOMMAND() + +(DEFUN |terminateSystemCommand| NIL (TERSYSCOMMAND)) + +;commandUserLevelError(x,u) == userLevelErrorMessage("command",x,u) + +(DEFUN |commandUserLevelError| (|x| |u|) + (|userLevelErrorMessage| (QUOTE |command|) |x| |u|)) + +;optionUserLevelError(x,u) == userLevelErrorMessage("option",x,u) + +(DEFUN |optionUserLevelError| (|x| |u|) + (|userLevelErrorMessage| (QUOTE |option|) |x| |u|)) + +;userLevelErrorMessage(kind,x,u) == +; null u => +; sayKeyedMsg("S2IZ0007",[$UserLevel,kind]) +; terminateSystemCommand() +; commandAmbiguityError(kind,x,u) + +(DEFUN |userLevelErrorMessage| (|kind| |x| |u|) + (COND + ((NULL |u|) + (|sayKeyedMsg| 'S2IZ0007 (CONS |$UserLevel| (CONS |kind| NIL))) + (|terminateSystemCommand|)) + ('T (|commandAmbiguityError| |kind| |x| |u|)))) + +;commandError(x,u) == commandErrorMessage("command",x,u) + +(DEFUN |commandError| (|x| |u|) + (|commandErrorMessage| (QUOTE |command|) |x| |u|)) + +;optionError(x,u) == commandErrorMessage("option",x,u) + +(DEFUN |optionError| (|x| |u|) + (|commandErrorMessage| (QUOTE |option|) |x| |u|)) + +;commandErrorIfAmbiguous(x, u) == +; null u => nil +; SETQ($OLDLINE, LINE) +; commandAmbiguityError("command", x, u) + +(DEFUN |commandErrorIfAmbiguous| (|x| |u|) + (COND + ((NULL |u|) NIL) + ('T (SETQ $OLDLINE LINE) + (|commandAmbiguityError| '|command| |x| |u|)))) + +;commandErrorMessage(kind,x,u) == +; SETQ ($OLDLINE,LINE) +; null u => +; sayKeyedMsg("S2IZ0008",[kind,x]) +; terminateSystemCommand() +; commandAmbiguityError(kind,x,u) + +(DEFUN |commandErrorMessage| (|kind| |x| |u|) + (PROGN + (SETQ $OLDLINE LINE) + (COND + ((NULL |u|) + (|sayKeyedMsg| 'S2IZ0008 (CONS |kind| (CONS |x| NIL))) + (|terminateSystemCommand|)) + ('T (|commandAmbiguityError| |kind| |x| |u|))))) + +;commandAmbiguityError(kind,x,u) == +; sayKeyedMsg("S2IZ0009",[kind,x]) +; for a in u repeat sayMSG ['" ",:bright a] +; terminateSystemCommand() + +(DEFUN |commandAmbiguityError| (|kind| |x| |u|) + (SEQ (PROGN + (|sayKeyedMsg| 'S2IZ0009 (CONS |kind| (CONS |x| NIL))) + (DO ((G166206 |u| (CDR G166206)) (|a| NIL)) + ((OR (ATOM G166206) + (PROGN (SETQ |a| (CAR G166206)) NIL)) + NIL) + (SEQ (EXIT (|sayMSG| + (CONS (MAKESTRING " ") (|bright| |a|)))))) + (|terminateSystemCommand|)))) + +;--% Utility for access to original command line +;getSystemCommandLine() == +; p := STRPOS('")",$currentLine,0,NIL) +; line := if p then SUBSTRING($currentLine,p,NIL) else $currentLine +; maxIndex:= MAXINDEX line +; for i in 0..maxIndex while (line.i^=" ") repeat index:= i +; if index=maxIndex then line := '"" +; else line := SUBSTRING(line,index+2,nil) +; line + +(DEFUN |getSystemCommandLine| () + (PROG (|p| |maxIndex| |index| |line|) + (RETURN + (SEQ (PROGN + (SPADLET |p| + (STRPOS (MAKESTRING ")") |$currentLine| 0 NIL)) + (SPADLET |line| + (COND + (|p| (SUBSTRING |$currentLine| |p| NIL)) + ('T |$currentLine|))) + (SPADLET |maxIndex| (MAXINDEX |line|)) + (DO ((|i| 0 (QSADD1 |i|))) + ((OR (QSGREATERP |i| |maxIndex|) + (NULL (NEQUAL (ELT |line| |i|) '| |))) + NIL) + (SEQ (EXIT (SPADLET |index| |i|)))) + (COND + ((BOOT-EQUAL |index| |maxIndex|) + (SPADLET |line| (MAKESTRING ""))) + ('T + (SPADLET |line| + (SUBSTRING |line| (PLUS |index| 2) NIL)))) + |line|))))) + +;------------ start of commands ------------------------------------------ +;--% )display +;getParserMacroNames() == +; REMDUP [CAR mac for mac in getParserMacros()] + +(DEFUN |getParserMacroNames| () + (PROG () + (RETURN + (SEQ (REMDUP (PROG (G166237) + (SPADLET G166237 NIL) + (RETURN + (DO ((G166242 (|getParserMacros|) + (CDR G166242)) + (|mac| NIL)) + ((OR (ATOM G166242) + (PROGN + (SETQ |mac| (CAR G166242)) + NIL)) + (NREVERSE0 G166237)) + (SEQ (EXIT (SETQ G166237 + (CONS (CAR |mac|) G166237)))))))))))) + +;--------------------> NEW DEFINITION (override in patches.lisp.pamphlet) +;clearParserMacro(macro) == +; -- first see if it is one +; not IFCDR ASSOC(macro, ($pfMacros)) => NIL +; $pfMacros := REMALIST($pfMacros, macro) + +(DEFUN |clearParserMacro| (|macro|) + (COND + ((NULL (IFCDR (|assoc| |macro| |$pfMacros|))) NIL) + ('T (SPADLET |$pfMacros| (REMALIST |$pfMacros| |macro|))))) + +;displayMacro name == +; m := isInterpMacro name +; null m => +; sayBrightly ['" ",:bright name,'"is not an interpreter macro."] +; -- $op is needed in the output routines. +; $op : local := STRCONC('"macro ",object2String name) +; [args,:body] := m +; args := +; null args => nil +; null rest args => first args +; ['Tuple,:args] +; mathprint ['MAP,[args,:body]] + +(DEFUN |displayMacro| (|name|) + (PROG (|$op| |m| |body| |args|) + (DECLARE (SPECIAL |$op|)) + (RETURN + (PROGN + (SPADLET |m| (|isInterpMacro| |name|)) + (COND + ((NULL |m|) + (|sayBrightly| + (CONS (MAKESTRING " ") + (APPEND (|bright| |name|) + (CONS (MAKESTRING + "is not an interpreter macro.") + NIL))))) + ('T + (SPADLET |$op| + (STRCONC (MAKESTRING "macro ") + (|object2String| |name|))) + (SPADLET |args| (CAR |m|)) (SPADLET |body| (CDR |m|)) + (SPADLET |args| + (COND + ((NULL |args|) NIL) + ((NULL (CDR |args|)) (CAR |args|)) + ('T (CONS '|Tuple| |args|)))) + (|mathprint| (CONS 'MAP (CONS (CONS |args| |body|) NIL))))))))) + +;displayWorkspaceNames() == +; imacs := getInterpMacroNames() +; pmacs := getParserMacroNames() +; sayMessage '"Names of User-Defined Objects in the Workspace:" +; names := MSORT append(getWorkspaceNames(),pmacs) +; if null names +; then sayBrightly " * None *" +; else sayAsManyPerLineAsPossible [object2String x for x in names] +; imacs := SETDIFFERENCE(imacs,pmacs) +; if imacs then +; sayMessage '"Names of System-Defined Objects in the Workspace:" +; sayAsManyPerLineAsPossible [object2String x for x in imacs] + +(DEFUN |displayWorkspaceNames| () + (PROG (|pmacs| |names| |imacs|) + (RETURN + (SEQ (PROGN + (SPADLET |imacs| (|getInterpMacroNames|)) + (SPADLET |pmacs| (|getParserMacroNames|)) + (|sayMessage| + (MAKESTRING + "Names of User-Defined Objects in the Workspace:")) + (SPADLET |names| + (MSORT (APPEND (|getWorkspaceNames|) |pmacs|))) + (COND + ((NULL |names|) + (|sayBrightly| (MAKESTRING " * None *"))) + ('T + (|sayAsManyPerLineAsPossible| + (PROG (G166278) + (SPADLET G166278 NIL) + (RETURN + (DO ((G166283 |names| (CDR G166283)) + (|x| NIL)) + ((OR (ATOM G166283) + (PROGN + (SETQ |x| (CAR G166283)) + NIL)) + (NREVERSE0 G166278)) + (SEQ (EXIT (SETQ G166278 + (CONS (|object2String| |x|) + G166278)))))))))) + (SPADLET |imacs| (SETDIFFERENCE |imacs| |pmacs|)) + (COND + (|imacs| (|sayMessage| + (MAKESTRING + "Names of System-Defined Objects in the Workspace:")) + (|sayAsManyPerLineAsPossible| + (PROG (G166293) + (SPADLET G166293 NIL) + (RETURN + (DO ((G166298 |imacs| + (CDR G166298)) + (|x| NIL)) + ((OR (ATOM G166298) + (PROGN + (SETQ |x| (CAR G166298)) + NIL)) + (NREVERSE0 G166293)) + (SEQ (EXIT + (SETQ G166293 + (CONS (|object2String| |x|) + G166293))))))))) + ('T NIL))))))) + +;getWorkspaceNames() == +; NMSORT [n for [n,:.] in CAAR $InteractiveFrame | +; (n ^= "--macros--" and n^= "--flags--")] + +(DEFUN |getWorkspaceNames| () + (PROG (|n|) + (RETURN + (SEQ (NMSORT (PROG (G166322) + (SPADLET G166322 NIL) + (RETURN + (DO ((G166329 (CAAR |$InteractiveFrame|) + (CDR G166329)) + (G166313 NIL)) + ((OR (ATOM G166329) + (PROGN + (SETQ G166313 (CAR G166329)) + NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR G166313)) + G166313) + NIL)) + (NREVERSE0 G166322)) + (SEQ (EXIT (COND + ((AND (NEQUAL |n| '|--macros--|) + (NEQUAL |n| '|--flags--|)) + (SETQ G166322 + (CONS |n| G166322)))))))))))))) + +;interpFunctionDepAlists() == +; $e : local := $InteractiveFrame +; deps := getFlag "$dependencies" +; $dependentAlist := [[NIL,:NIL]] +; $dependeeAlist := [[NIL,:NIL]] +; for [dependee,dependent] in deps repeat +; $dependentAlist := PUTALIST($dependentAlist,dependee, +; CONS(dependent,GETALIST($dependentAlist,dependee))) +; $dependeeAlist := PUTALIST($dependeeAlist,dependent, +; CONS(dependee,GETALIST($dependeeAlist,dependent))) + +(DEFUN |interpFunctionDepAlists| () + (PROG (|$e| |deps| |dependee| |dependent|) + (DECLARE (SPECIAL |$e|)) + (RETURN + (SEQ (PROGN + (SPADLET |$e| |$InteractiveFrame|) + (SPADLET |deps| (|getFlag| '|$dependencies|)) + (SPADLET |$dependentAlist| (CONS (CONS NIL NIL) NIL)) + (SPADLET |$dependeeAlist| (CONS (CONS NIL NIL) NIL)) + (DO ((G166353 |deps| (CDR G166353)) (G166342 NIL)) + ((OR (ATOM G166353) + (PROGN (SETQ G166342 (CAR G166353)) NIL) + (PROGN + (PROGN + (SPADLET |dependee| (CAR G166342)) + (SPADLET |dependent| (CADR G166342)) + G166342) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |$dependentAlist| + (PUTALIST |$dependentAlist| + |dependee| + (CONS |dependent| + (GETALIST |$dependentAlist| + |dependee|)))) + (SPADLET |$dependeeAlist| + (PUTALIST |$dependeeAlist| + |dependent| + (CONS |dependee| + (GETALIST |$dependeeAlist| + |dependent|))))))))))))) + +;fixObjectForPrinting(v) == +; v' := object2Identifier v +; EQ(v',"%") => '"\%" +; v' in $msgdbPrims => STRCONC('"\",PNAME v') +; v + +(DEFUN |fixObjectForPrinting| (|v|) + (PROG (|v'|) + (RETURN + (PROGN + (SPADLET |v'| (|object2Identifier| |v|)) + (COND + ((EQ |v'| '%) (MAKESTRING "\\%")) + ((|member| |v'| |$msgdbPrims|) + (STRCONC (MAKESTRING "\\") (PNAME |v'|))) + ('T |v|)))))) + +;displayProperties(option,l) == +; $dependentAlist : local := nil +; $dependeeAlist : local := nil +; [opt,:vl]:= (l or ['properties]) +; imacs := getInterpMacroNames() +; pmacs := getParserMacroNames() +; macros := REMDUP append(imacs, pmacs) +; if vl is ['all] or null vl then +; vl := MSORT append(getWorkspaceNames(),macros) +; if $frameMessages then sayKeyedMsg("S2IZ0065",[$interpreterFrameName]) +; null vl => +; null $frameMessages => sayKeyedMsg("S2IZ0066",NIL) +; sayKeyedMsg("S2IZ0067",[$interpreterFrameName]) +; interpFunctionDepAlists() +; for v in vl repeat +; isInternalMapName(v) => 'iterate +; pl := getIProplist(v) +; option = 'flags => getAndSay(v,"flags") +; option = 'value => displayValue(v,getI(v,'value),nil) +; option = 'condition => displayCondition(v,getI(v,"condition"),nil) +; option = 'mode => displayMode(v,getI(v,'mode),nil) +; option = 'type => displayType(v,getI(v,'value),nil) +; option = 'properties => +; v = "--flags--" => nil +; pl is [['cacheInfo,:.],:.] => nil +; v1 := fixObjectForPrinting(v) +; sayMSG ['"Properties of",:bright prefix2String v1,'":"] +; null pl => +; v in pmacs => +; sayMSG '" This is a user-defined macro." +; displayParserMacro v +; isInterpMacro v => +; sayMSG '" This is a system-defined macro." +; displayMacro v +; sayMSG '" none" +; propsSeen:= nil +; for [prop,:val] in pl | ^MEMQ(prop,propsSeen) and val repeat +; prop in '(alias generatedCode IS_-GENSYM mapBody localVars) => +; nil +; prop = 'condition => +; displayCondition(prop,val,true) +; prop = 'recursive => +; sayMSG '" This is recursive." +; prop = 'isInterpreterFunction => +; sayMSG '" This is an interpreter function." +; sayFunctionDeps v where +; sayFunctionDeps x == +; if dependents := GETALIST($dependentAlist,x) then +; null rest dependents => +; sayMSG ['" The following function or rule ", +; '"depends on this:",:bright first dependents] +; sayMSG +; '" The following functions or rules depend on this:" +; msg := ["%b",'" "] +; for y in dependents repeat msg := ['" ",y,:msg] +; sayMSG [:nreverse msg,"%d"] +; if dependees := GETALIST($dependeeAlist,x) then +; null rest dependees => +; sayMSG ['" This depends on the following function ", +; '"or rule:",:bright first dependees] +; sayMSG +; '" This depends on the following functions or rules:" +; msg := ["%b",'" "] +; for y in dependees repeat msg := ['" ",y,:msg] +; sayMSG [:nreverse msg,"%d"] +; prop = 'isInterpreterRule => +; sayMSG '" This is an interpreter rule." +; sayFunctionDeps v +; prop = 'localModemap => +; displayModemap(v,val,true) +; prop = 'mode => +; displayMode(prop,val,true) +; prop = 'value => +; val => displayValue(v,val,true) +; sayMSG ['" ",prop,'": ",val] +; propsSeen:= [prop,:propsSeen] +; sayKeyedMsg("S2IZ0068",[option]) +; terminateSystemCommand() + +(DEFUN |displayProperties,sayFunctionDeps| (|x|) + (PROG (|dependents| |dependees| |msg|) + (RETURN + (SEQ (IF (SPADLET |dependents| (GETALIST |$dependentAlist| |x|)) + (SEQ (IF (NULL (CDR |dependents|)) + (EXIT (|sayMSG| + (CONS (MAKESTRING + " The following function or rule ") + (CONS + (MAKESTRING + "depends on this:") + (|bright| (CAR |dependents|))))))) + (|sayMSG| + (MAKESTRING + " The following functions or rules depend on this:")) + (SPADLET |msg| + (CONS '|%b| + (CONS (MAKESTRING " ") NIL))) + (DO ((G166397 |dependents| (CDR G166397)) + (|y| NIL)) + ((OR (ATOM G166397) + (PROGN (SETQ |y| (CAR G166397)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |msg| + (CONS (MAKESTRING " ") + (CONS |y| |msg|)))))) + (EXIT (|sayMSG| + (APPEND (NREVERSE |msg|) + (CONS '|%d| NIL))))) + NIL) + (EXIT (IF (SPADLET |dependees| + (GETALIST |$dependeeAlist| |x|)) + (SEQ (IF (NULL (CDR |dependees|)) + (EXIT (|sayMSG| + (CONS + (MAKESTRING + " This depends on the following function ") + (CONS (MAKESTRING "or rule:") + (|bright| (CAR |dependees|))))))) + (|sayMSG| + (MAKESTRING + " This depends on the following functions or rules:")) + (SPADLET |msg| + (CONS '|%b| + (CONS (MAKESTRING " ") NIL))) + (DO ((G166406 |dependees| (CDR G166406)) + (|y| NIL)) + ((OR (ATOM G166406) + (PROGN + (SETQ |y| (CAR G166406)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |msg| + (CONS (MAKESTRING " ") + (CONS |y| |msg|)))))) + (EXIT (|sayMSG| + (APPEND (NREVERSE |msg|) + (CONS '|%d| NIL))))) + NIL)))))) + + +(DEFUN |displayProperties| (|option| |l|) + (PROG (|$dependentAlist| |$dependeeAlist| |LETTMP#1| |opt| |imacs| + |pmacs| |macros| |vl| |pl| |ISTMP#1| |v1| |prop| |val| + |propsSeen|) + (DECLARE (SPECIAL |$dependentAlist| |$dependeeAlist|)) + (RETURN + (SEQ (PROGN + (SPADLET |$dependentAlist| NIL) + (SPADLET |$dependeeAlist| NIL) + (SPADLET |LETTMP#1| (OR |l| (CONS '|properties| NIL))) + (SPADLET |opt| (CAR |LETTMP#1|)) + (SPADLET |vl| (CDR |LETTMP#1|)) + (SPADLET |imacs| (|getInterpMacroNames|)) + (SPADLET |pmacs| (|getParserMacroNames|)) + (SPADLET |macros| (REMDUP (APPEND |imacs| |pmacs|))) + (COND + ((OR (AND (PAIRP |vl|) (EQ (QCDR |vl|) NIL) + (EQ (QCAR |vl|) '|all|)) + (NULL |vl|)) + (SPADLET |vl| + (MSORT (APPEND (|getWorkspaceNames|) |macros|))))) + (COND + (|$frameMessages| + (|sayKeyedMsg| 'S2IZ0065 + (CONS |$interpreterFrameName| NIL)))) + (COND + ((NULL |vl|) + (COND + ((NULL |$frameMessages|) + (|sayKeyedMsg| 'S2IZ0066 NIL)) + ('T + (|sayKeyedMsg| 'S2IZ0067 + (CONS |$interpreterFrameName| NIL))))) + ('T (|interpFunctionDepAlists|) + (DO ((G166440 |vl| (CDR G166440)) (|v| NIL)) + ((OR (ATOM G166440) + (PROGN (SETQ |v| (CAR G166440)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|isInternalMapName| |v|) '|iterate|) + ('T (SPADLET |pl| (|getIProplist| |v|)) + (COND + ((BOOT-EQUAL |option| '|flags|) + (|getAndSay| |v| '|flags|)) + ((BOOT-EQUAL |option| '|value|) + (|displayValue| |v| + (|getI| |v| '|value|) NIL)) + ((BOOT-EQUAL |option| '|condition|) + (|displayCondition| |v| + (|getI| |v| '|condition|) NIL)) + ((BOOT-EQUAL |option| '|mode|) + (|displayMode| |v| + (|getI| |v| '|mode|) NIL)) + ((BOOT-EQUAL |option| '|type|) + (|displayType| |v| + (|getI| |v| '|value|) NIL)) + ((BOOT-EQUAL |option| '|properties|) + (COND + ((BOOT-EQUAL |v| '|--flags--|) + NIL) + ((AND (PAIRP |pl|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |pl|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) + '|cacheInfo|)))) + NIL) + ('T + (SPADLET |v1| + (|fixObjectForPrinting| |v|)) + (|sayMSG| + (CONS + (MAKESTRING "Properties of") + (APPEND + (|bright| + (|prefix2String| |v1|)) + (CONS (MAKESTRING ":") NIL)))) + (COND + ((NULL |pl|) + (COND + ((|member| |v| |pmacs|) + (|sayMSG| + (MAKESTRING + " This is a user-defined macro.")) + (|displayParserMacro| |v|)) + ((|isInterpMacro| |v|) + (|sayMSG| + (MAKESTRING + " This is a system-defined macro.")) + (|displayMacro| |v|)) + ('T + (|sayMSG| + (MAKESTRING " none"))))) + ('T (SPADLET |propsSeen| NIL) + (DO + ((G166451 |pl| + (CDR G166451)) + (G166425 NIL)) + ((OR (ATOM G166451) + (PROGN + (SETQ G166425 + (CAR G166451)) + NIL) + (PROGN + (PROGN + (SPADLET |prop| + (CAR G166425)) + (SPADLET |val| + (CDR G166425)) + G166425) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND + (NULL + (MEMQ |prop| + |propsSeen|)) + |val|) + (COND + ((|member| |prop| + '(|alias| + |generatedCode| + IS-GENSYM + |mapBody| + |localVars|)) + NIL) + ((BOOT-EQUAL |prop| + '|condition|) + (|displayCondition| + |prop| |val| 'T)) + ((BOOT-EQUAL |prop| + '|recursive|) + (|sayMSG| + (MAKESTRING + " This is recursive."))) + ((BOOT-EQUAL |prop| + '|isInterpreterFunction|) + (|sayMSG| + (MAKESTRING + " This is an interpreter function.")) + (|displayProperties,sayFunctionDeps| + |v|)) + ((BOOT-EQUAL |prop| + '|isInterpreterRule|) + (|sayMSG| + (MAKESTRING + " This is an interpreter rule.")) + (|displayProperties,sayFunctionDeps| + |v|)) + ((BOOT-EQUAL |prop| + '|localModemap|) + (|displayModemap| + |v| |val| 'T)) + ((BOOT-EQUAL |prop| + '|mode|) + (|displayMode| + |prop| |val| 'T)) + ('T + (SEQ + (COND + ((BOOT-EQUAL + |prop| + '|value|) + (EXIT + (COND + (|val| + (EXIT + (|displayValue| + |v| |val| + 'T))))))) + (|sayMSG| + (CONS + (MAKESTRING + " ") + (CONS |prop| + (CONS + (MAKESTRING + ": ") + (CONS |val| + NIL))))) + (SPADLET + |propsSeen| + (CONS |prop| + |propsSeen|))))))))))))))) + ('T + (|sayKeyedMsg| 'S2IZ0068 + (CONS |option| NIL))))))))) + (|terminateSystemCommand|)))))))) + +;displayModemap(v,val,giveVariableIfNil) == +; for mm in val repeat g(v,mm,giveVariableIfNil) where +; g(v,mm,giveVariableIfNil) == +; [[local,:signature],fn,:.]:= mm +; local='interpOnly => nil +; varPart:= (giveVariableIfNil => nil; ['" of",:bright v]) +; prefix:= [" Compiled function type",:varPart,": "] +; sayBrightly concat(prefix,formatSignature signature) + +(DEFUN |displayModemap,g| (|v| |mm| |giveVariableIfNil|) + (PROG (|local| |signature| |fn| |varPart| |prefix|) + (RETURN + (SEQ (PROGN + (SPADLET |local| (CAAR |mm|)) + (SPADLET |signature| (CDAR |mm|)) + (SPADLET |fn| (CADR |mm|)) + |mm|) + (IF (BOOT-EQUAL |local| '|interpOnly|) (EXIT NIL)) + (SPADLET |varPart| + (SEQ (IF |giveVariableIfNil| (EXIT NIL)) + (EXIT (CONS (MAKESTRING " of") (|bright| |v|))))) + (SPADLET |prefix| + (CONS '| Compiled function type| + (APPEND |varPart| (CONS '|: | NIL)))) + (EXIT (|sayBrightly| + (|concat| |prefix| + (|formatSignature| |signature|)))))))) + + +(DEFUN |displayModemap| (|v| |val| |giveVariableIfNil|) + (SEQ (DO ((G166499 |val| (CDR G166499)) (|mm| NIL)) + ((OR (ATOM G166499) + (PROGN (SETQ |mm| (CAR G166499)) NIL)) + NIL) + (SEQ (EXIT (|displayModemap,g| |v| |mm| |giveVariableIfNil|)))))) + +;displayMode(v,mode,giveVariableIfNil) == +; null mode => nil +; varPart:= (giveVariableIfNil => nil; [" of",:bright fixObjectForPrinting v]) +; sayBrightly concat(" Declared type or mode", +; varPart,": ",prefix2String mode) + +(DEFUN |displayMode| (|v| |mode| |giveVariableIfNil|) + (PROG (|varPart|) + (RETURN + (COND + ((NULL |mode|) NIL) + ('T + (SPADLET |varPart| + (COND + (|giveVariableIfNil| NIL) + ('T + (CONS '| of| + (|bright| (|fixObjectForPrinting| |v|)))))) + (|sayBrightly| + (|concat| '| Declared type or mode| |varPart| '|: | + (|prefix2String| |mode|)))))))) + +;displayCondition(v,condition,giveVariableIfNil) == +; varPart:= (giveVariableIfNil => nil; [" of",:bright v]) +; condPart:= condition or 'true +; sayBrightly concat(" condition",varPart,": ",pred2English condPart) + +(DEFUN |displayCondition| (|v| |condition| |giveVariableIfNil|) + (PROG (|varPart| |condPart|) + (RETURN + (PROGN + (SPADLET |varPart| + (COND + (|giveVariableIfNil| NIL) + ('T (CONS '| of| (|bright| |v|))))) + (SPADLET |condPart| (OR |condition| '|true|)) + (|sayBrightly| + (|concat| '| condition| |varPart| '|: | + (|pred2English| |condPart|))))))) + +;getAndSay(v,prop) == +; val:= getI(v,prop) => sayMSG [" ",val,'%l] +; sayMSG [" none",'%l] + +(DEFUN |getAndSay| (|v| |prop|) + (PROG (|val|) + (RETURN + (COND + ((SPADLET |val| (|getI| |v| |prop|)) + (|sayMSG| (CONS '| | (CONS |val| (CONS '|%l| NIL))))) + ('T (|sayMSG| (CONS '| none| (CONS '|%l| NIL)))))))) + +;displayType($op,u,omitVariableNameIfTrue) == +; null u => +; sayMSG ['" Type of value of ", +; fixObjectForPrinting PNAME $op,'": (none)"] +; type := prefix2String objMode(u) +; if ATOM type then type := [type] +; sayMSG concat ['" Type of value of ",fixObjectForPrinting PNAME $op,'": ",:type] +; NIL + +(DEFUN |displayType| (|$op| |u| |omitVariableNameIfTrue|) + (DECLARE (SPECIAL |$op|)) + (PROG (|type|) + (RETURN + (COND + ((NULL |u|) + (|sayMSG| + (CONS (MAKESTRING " Type of value of ") + (CONS (|fixObjectForPrinting| (PNAME |$op|)) + (CONS (MAKESTRING ": (none)") NIL))))) + ('T (SPADLET |type| (|prefix2String| (|objMode| |u|))) + (COND ((ATOM |type|) (SPADLET |type| (CONS |type| NIL)))) + (|sayMSG| + (|concat| + (CONS (MAKESTRING " Type of value of ") + (CONS (|fixObjectForPrinting| (PNAME |$op|)) + (CONS (MAKESTRING ": ") |type|))))) + NIL))))) + +;displayValue($op,u,omitVariableNameIfTrue) == +; null u => sayMSG [" Value of ",fixObjectForPrinting PNAME $op,'": (none)"] +; expr := objValUnwrap(u) +; expr is [op,:.] and (op = 'MAP) or objMode(u) = $EmptyMode => +; displayRule($op,expr) +; label:= +; omitVariableNameIfTrue => +; rhs := '"): " +; '"Value (has type " +; rhs := '": " +; STRCONC('"Value of ", PNAME $op,'": ") +; labmode := prefix2String objMode(u) +; if ATOM labmode then labmode := [labmode] +; GETDATABASE(expr,'CONSTRUCTORKIND) = 'domain => +; sayMSG concat('" ",label,labmode,rhs,form2String expr) +; mathprint ['CONCAT,label,:labmode,rhs, +; outputFormat(expr,objMode(u))] +; NIL + +(DEFUN |displayValue| (|$op| |u| |omitVariableNameIfTrue|) + (DECLARE (SPECIAL |$op|)) + (PROG (|expr| |op| |rhs| |label| |labmode|) + (RETURN + (COND + ((NULL |u|) + (|sayMSG| + (CONS '| Value of | + (CONS (|fixObjectForPrinting| (PNAME |$op|)) + (CONS (MAKESTRING ": (none)") NIL))))) + ('T (SPADLET |expr| (|objValUnwrap| |u|)) + (COND + ((OR (AND (PAIRP |expr|) + (PROGN (SPADLET |op| (QCAR |expr|)) 'T) + (BOOT-EQUAL |op| 'MAP)) + (BOOT-EQUAL (|objMode| |u|) |$EmptyMode|)) + (|displayRule| |$op| |expr|)) + ('T + (SPADLET |label| + (COND + (|omitVariableNameIfTrue| + (SPADLET |rhs| (MAKESTRING "): ")) + (MAKESTRING "Value (has type ")) + ('T (SPADLET |rhs| (MAKESTRING ": ")) + (STRCONC (MAKESTRING "Value of ") (PNAME |$op|) + (MAKESTRING ": "))))) + (SPADLET |labmode| (|prefix2String| (|objMode| |u|))) + (COND + ((ATOM |labmode|) + (SPADLET |labmode| (CONS |labmode| NIL)))) + (COND + ((BOOT-EQUAL (GETDATABASE |expr| 'CONSTRUCTORKIND) + '|domain|) + (|sayMSG| + (|concat| (MAKESTRING " ") |label| |labmode| |rhs| + (|form2String| |expr|)))) + ('T + (|mathprint| + (CONS 'CONCAT + (CONS |label| + (APPEND |labmode| + (CONS |rhs| + (CONS + (|outputFormat| |expr| + (|objMode| |u|)) + NIL)))))) + NIL))))))))) + +;--% )load +;load args == loadSpad2Cmd args + +(DEFUN |load| (|args|) (|loadSpad2Cmd| |args|)) + +;loadSpad2Cmd args == +; sayKeyedMsg("S2IU0003", nil) +; NIL + +(DEFUN |loadSpad2Cmd| (|args|) + (PROGN (|sayKeyedMsg| (QUOTE S2IU0003) NIL) NIL)) + +;-- load1(args,$forceDatabaseUpdate) +;--load1(args,$forceDatabaseUpdate) == -- $ var is now local +;-- null args => helpSpad2Cmd '(load) +;-- loadfun := 'loadLib +;-- justWondering := nil +;-- compiler := 'old +;-- doExpose := true +;-- $forceDatabaseUpdate := true -- BMT request, 5/14/90 +;-- for [opt,:.] in $options repeat +;-- fullopt := selectOptionLC(opt, +;-- '(cond update query new noexpose noupdate), +;-- 'optionError) +;-- fullopt = 'cond => loadfun := 'loadLibIfNotLoaded +;-- fullopt = 'query => justWondering := true +;-- fullopt = 'update => $forceDatabaseUpdate := true +;-- fullopt = 'noexpose => doExpose := false +;-- fullopt = 'noupdate => $forceDatabaseUpdate := false +;-- if $forceDatabaseUpdate then clearClams() +;-- for lib in args repeat +;-- lib := object2Identifier lib +;-- justWondering => +;-- GET(lib,'LOADED) => sayKeyedMsg("S2IZ0028",[lib]) +;-- sayKeyedMsg("S2IZ0029",[lib]) +;-- null GETDATABASE(lib,'OBJECT) and +;-- null (lib := GETDATABASE(lib,'CONSTRUCTOR)) => +;-- sayKeyedMsg("S2IL0020", [namestring [lib,$spadLibFT,"*"]]) +;-- null FUNCALL(loadfun,lib) => +;-- sayKeyedMsg("S2IZ0029",[lib]) +;-- sayKeyedMsg("S2IZ0028",[lib]) +;-- if doExpose and +;-- not isExposedConstructor(lib) then +;-- setExposeAddConstr([lib]) +;-- 'EndOfLoad +;reportCount () == +; centerAndHighlight(" Current Count Settings ",$LINELENGTH,specialChar 'hbar) +; SAY " " +; sayBrightly [:bright " cache",fillerSpaces(30,'".")," ",$cacheCount] +; if $cacheAlist then +; for [a,:b] in $cacheAlist repeat +; aPart:= linearFormatName a +; n:= sayBrightlyLength aPart +; sayBrightly concat(" ",aPart," ",fillerSpaces(32-n,'".")," ",b) +; SAY " " +; sayBrightly [:bright " stream",fillerSpaces(29,'".")," ",$streamCount] + +(DEFUN |reportCount| () + (PROG (|a| |b| |aPart| |n|) + (RETURN + (SEQ (PROGN + (|centerAndHighlight| '| Current Count Settings | + $LINELENGTH (|specialChar| '|hbar|)) + (SAY (MAKESTRING " ")) + (|sayBrightly| + (APPEND (|bright| '| cache|) + (CONS (|fillerSpaces| 30 (MAKESTRING ".")) + (CONS '| | (CONS |$cacheCount| NIL))))) + (COND + (|$cacheAlist| + (DO ((G166567 |$cacheAlist| (CDR G166567)) + (G166555 NIL)) + ((OR (ATOM G166567) + (PROGN + (SETQ G166555 (CAR G166567)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G166555)) + (SPADLET |b| (CDR G166555)) + G166555) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |aPart| + (|linearFormatName| |a|)) + (SPADLET |n| + (|sayBrightlyLength| + |aPart|)) + (|sayBrightly| + (|concat| '| | |aPart| '| | + (|fillerSpaces| + (SPADDIFFERENCE 32 |n|) + (MAKESTRING ".")) + '| | |b|)))))))) + (SAY (MAKESTRING " ")) + (|sayBrightly| + (APPEND (|bright| '| stream|) + (CONS (|fillerSpaces| 29 (MAKESTRING ".")) + (CONS '| | (CONS |$streamCount| NIL)))))))))) + +;--% )read +;read l == readSpad2Cmd l + +(DEFUN |read| (|l|) (|readSpad2Cmd| |l|)) + +;readSpad2Cmd l == +; ---$saturn => +; --- sayErrorly('"Obsolete system command", _ +; --- ['" The )read system command is obsolete in this version of AXIOM.", +; --- '" Please use Open from the File menu instead."]) +; $InteractiveMode : local := true +; quiet := nil +; ifthere := nil +; for [opt,:.] in $options repeat +; fullopt := selectOptionLC(opt,'(quiet test ifthere),'optionError) +; fullopt = 'ifthere => ifthere := true +; fullopt = 'quiet => quiet := true +; ef := pathname _/EDITFILE +; if pathnameTypeId(ef) = 'SPAD then +; ef := makePathname(pathnameName ef,'"*",'"*") +; if l then +; l := mergePathnames(pathname l,ef) +; else +; l := ef +; devFTs := '("input" "INPUT" "boot" "BOOT" "lisp" "LISP") +; fileTypes := +; $UserLevel = 'interpreter => '("input" "INPUT") +; $UserLevel = 'compiler => '("input" "INPUT") +; devFTs +; ll := $FINDFILE (l, fileTypes) +; if null ll then +; ifthere => return nil -- be quiet about it +; throwKeyedMsg("S2IL0003",[namestring l]) +; ll := pathname ll +; ft := pathnameType ll +; upft := UPCASE ft +; null MEMBER(upft,fileTypes) => +; fs := namestring l +; MEMBER(upft,devFTs) => throwKeyedMsg("S2IZ0033",[fs]) +; throwKeyedMsg("S2IZ0034",[fs]) +; SETQ(_/EDITFILE,ll) +; if upft = '"BOOT" then $InteractiveMode := nil +; _/READ(ll,quiet) + +(DEFUN |readSpad2Cmd| (|l|) + (PROG (|$InteractiveMode| |opt| |fullopt| |ifthere| |quiet| |ef| + |devFTs| |fileTypes| |ll| |ft| |upft| |fs|) + (DECLARE (SPECIAL |$InteractiveMode|)) + (RETURN + (SEQ (PROGN + (SPADLET |$InteractiveMode| 'T) + (SPADLET |quiet| NIL) + (SPADLET |ifthere| NIL) + (DO ((G166598 |$options| (CDR G166598)) + (G166585 NIL)) + ((OR (ATOM G166598) + (PROGN (SETQ G166585 (CAR G166598)) NIL) + (PROGN + (PROGN + (SPADLET |opt| (CAR G166585)) + G166585) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |fullopt| + (|selectOptionLC| |opt| + '(|quiet| |test| |ifthere|) + '|optionError|)) + (COND + ((BOOT-EQUAL |fullopt| '|ifthere|) + (SPADLET |ifthere| 'T)) + ((BOOT-EQUAL |fullopt| '|quiet|) + (SPADLET |quiet| 'T))))))) + (SPADLET |ef| (|pathname| /EDITFILE)) + (COND + ((BOOT-EQUAL (|pathnameTypeId| |ef|) 'SPAD) + (SPADLET |ef| + (|makePathname| (|pathnameName| |ef|) + (MAKESTRING "*") (MAKESTRING "*"))))) + (COND + (|l| (SPADLET |l| + (|mergePathnames| (|pathname| |l|) |ef|))) + ('T (SPADLET |l| |ef|))) + (SPADLET |devFTs| + '("input" "INPUT" "boot" "BOOT" "lisp" "LISP")) + (SPADLET |fileTypes| + (COND + ((BOOT-EQUAL |$UserLevel| '|interpreter|) + '("input" "INPUT")) + ((BOOT-EQUAL |$UserLevel| '|compiler|) + '("input" "INPUT")) + ('T |devFTs|))) + (SPADLET |ll| ($FINDFILE |l| |fileTypes|)) + (COND + ((NULL |ll|) + (COND + (|ifthere| (RETURN NIL)) + ('T + (|throwKeyedMsg| 'S2IL0003 + (CONS (|namestring| |l|) NIL)))))) + (SPADLET |ll| (|pathname| |ll|)) + (SPADLET |ft| (|pathnameType| |ll|)) + (SPADLET |upft| (UPCASE |ft|)) + (COND + ((NULL (|member| |upft| |fileTypes|)) + (SPADLET |fs| (|namestring| |l|)) + (COND + ((|member| |upft| |devFTs|) + (|throwKeyedMsg| 'S2IZ0033 (CONS |fs| NIL))) + ('T (|throwKeyedMsg| 'S2IZ0034 (CONS |fs| NIL))))) + ('T (SETQ /EDITFILE |ll|) + (COND + ((BOOT-EQUAL |upft| (MAKESTRING "BOOT")) + (SPADLET |$InteractiveMode| NIL))) + (/READ |ll| |quiet|)))))))) + +;--% )savesystem +;savesystem l == +; #l ^= 1 or not(SYMBOLP CAR l) => helpSpad2Cmd '(savesystem) +; SPAD_-SAVE SYMBOL_-NAME CAR l + +(DEFUN |savesystem| (|l|) + (COND + ((OR (NEQUAL (|#| |l|) 1) (NULL (SYMBOLP (CAR |l|)))) + (|helpSpad2Cmd| '(|savesystem|))) + ('T (SPAD-SAVE (SYMBOL-NAME (CAR |l|)))))) + +;--% )show +;show l == showSpad2Cmd l + +(DEFUN |show| (|l|) (|showSpad2Cmd| |l|)) + +;showSpad2Cmd l == +; l = [NIL] => helpSpad2Cmd '(show) +; $showOptions : local := '(attributes operations) +; if null $options then $options := '((operations)) +; $e : local := $InteractiveFrame +; $env : local := $InteractiveFrame +; l is [constr] => +; constr in '(Union Record Mapping) => +; constr = 'Record => +; sayKeyedMsg("S2IZ0044R",[constr, '")show Record(a: Integer, b: String)"]) +; constr = 'Mapping => +; sayKeyedMsg("S2IZ0044M",NIL) +; sayKeyedMsg("S2IZ0045T",[constr, '")show Union(a: Integer, b: String)"]) +; sayKeyedMsg("S2IZ0045U",[constr, '")show Union(Integer, String)"]) +; constr is ['Mapping, :.] => +; sayKeyedMsg("S2IZ0044M",NIL) +; reportOperations(constr,constr) +; reportOperations(l,l) + +(DEFUN |showSpad2Cmd| (|l|) + (PROG (|$showOptions| |$e| |$env| |constr|) + (DECLARE (SPECIAL |$showOptions| |$e| |$env|)) + (RETURN + (COND + ((BOOT-EQUAL |l| (CONS NIL NIL)) (|helpSpad2Cmd| '(|show|))) + ('T (SPADLET |$showOptions| '(|attributes| |operations|)) + (COND + ((NULL |$options|) (SPADLET |$options| '((|operations|))))) + (SPADLET |$e| |$InteractiveFrame|) + (SPADLET |$env| |$InteractiveFrame|) + (COND + ((AND (PAIRP |l|) (EQ (QCDR |l|) NIL) + (PROGN (SPADLET |constr| (QCAR |l|)) 'T)) + (COND + ((|member| |constr| '(|Union| |Record| |Mapping|)) + (COND + ((BOOT-EQUAL |constr| '|Record|) + (|sayKeyedMsg| 'S2IZ0044R + (CONS |constr| + (CONS (MAKESTRING + ")show Record(a: Integer, b: String)") + NIL)))) + ((BOOT-EQUAL |constr| '|Mapping|) + (|sayKeyedMsg| 'S2IZ0044M NIL)) + ('T + (|sayKeyedMsg| 'S2IZ0045T + (CONS |constr| + (CONS (MAKESTRING + ")show Union(a: Integer, b: String)") + NIL))) + (|sayKeyedMsg| 'S2IZ0045U + (CONS |constr| + (CONS (MAKESTRING + ")show Union(Integer, String)") + NIL)))))) + ((AND (PAIRP |constr|) (EQ (QCAR |constr|) '|Mapping|)) + (|sayKeyedMsg| 'S2IZ0044M NIL)) + ('T (|reportOperations| |constr| |constr|)))) + ('T (|reportOperations| |l| |l|)))))))) + +;reportOperations(oldArg,u) == +; -- u might be an uppercased version of oldArg +; $env:local := [[NIL]] +; $eval:local := true --generate code-- don't just type analyze +; $genValue:local := true --evaluate all generated code +; null u => nil +; $doNotAddEmptyModeIfTrue: local:= true +; u = $quadSymbol => +; sayBrightly ['" mode denotes", :bright '"any", "type"] +; u = "%" => +; sayKeyedMsg("S2IZ0063",NIL) +; sayKeyedMsg("S2IZ0064",NIL) +; u isnt ['Record,:.] and u isnt ['Union,:.] and +; null(isNameOfType u) and u isnt ['typeOf,.] => +; if ATOM oldArg then oldArg := [oldArg] +; sayKeyedMsg("S2IZ0063",NIL) +; for op in oldArg repeat +; sayKeyedMsg("S2IZ0062",[opOf op]) +; (v := isDomainValuedVariable u) => reportOpsFromUnitDirectly0 v +; unitForm:= +; atom u => opOf unabbrev u +; unabbrev u +; atom unitForm => reportOpsFromLisplib0(unitForm,u) +; unitForm' := evaluateType unitForm +; tree := mkAtree removeZeroOneDestructively unitForm +; (unitForm' := isType tree) => reportOpsFromUnitDirectly0 unitForm' +; sayKeyedMsg("S2IZ0041",[unitForm]) + +(DEFUN |reportOperations| (|oldArg| |u|) + (PROG (|$env| |$eval| |$genValue| |$doNotAddEmptyModeIfTrue| + |ISTMP#1| |v| |unitForm| |tree| |unitForm'|) + (DECLARE (SPECIAL |$env| |$eval| |$genValue| + |$doNotAddEmptyModeIfTrue|)) + (RETURN + (SEQ (PROGN + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (SPADLET |$eval| 'T) + (SPADLET |$genValue| 'T) + (COND + ((NULL |u|) NIL) + ('T (SPADLET |$doNotAddEmptyModeIfTrue| 'T) + (COND + ((BOOT-EQUAL |u| |$quadSymbol|) + (|sayBrightly| + (CONS (MAKESTRING " mode denotes") + (APPEND (|bright| (MAKESTRING "any")) + (CONS '|type| NIL))))) + ((BOOT-EQUAL |u| '%) (|sayKeyedMsg| 'S2IZ0063 NIL) + (|sayKeyedMsg| 'S2IZ0064 NIL)) + ((AND (NULL (AND (PAIRP |u|) + (EQ (QCAR |u|) '|Record|))) + (NULL (AND (PAIRP |u|) + (EQ (QCAR |u|) '|Union|))) + (NULL (|isNameOfType| |u|)) + (NULL (AND (PAIRP |u|) + (EQ (QCAR |u|) '|typeOf|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))))) + (COND + ((ATOM |oldArg|) + (SPADLET |oldArg| (CONS |oldArg| NIL)))) + (|sayKeyedMsg| 'S2IZ0063 NIL) + (DO ((G166662 |oldArg| (CDR G166662)) + (|op| NIL)) + ((OR (ATOM G166662) + (PROGN (SETQ |op| (CAR G166662)) NIL)) + NIL) + (SEQ (EXIT (|sayKeyedMsg| 'S2IZ0062 + (CONS (|opOf| |op|) NIL)))))) + ((SPADLET |v| (|isDomainValuedVariable| |u|)) + (|reportOpsFromUnitDirectly0| |v|)) + ('T + (SPADLET |unitForm| + (COND + ((ATOM |u|) (|opOf| (|unabbrev| |u|))) + ('T (|unabbrev| |u|)))) + (COND + ((ATOM |unitForm|) + (|reportOpsFromLisplib0| |unitForm| |u|)) + ('T + (SPADLET |unitForm'| (|evaluateType| |unitForm|)) + (SPADLET |tree| + (|mkAtree| + (|removeZeroOneDestructively| + |unitForm|))) + (COND + ((SPADLET |unitForm'| (|isType| |tree|)) + (|reportOpsFromUnitDirectly0| |unitForm'|)) + ('T + (|sayKeyedMsg| 'S2IZ0041 + (CONS |unitForm| NIL))))))))))))))) + +;reportOpsFromUnitDirectly0 D == +; $useEditorForShowOutput => +; reportOpsFromUnitDirectly1 D +; reportOpsFromUnitDirectly D + +(DEFUN |reportOpsFromUnitDirectly0| (D) + (COND + (|$useEditorForShowOutput| (|reportOpsFromUnitDirectly1| D)) + ('T (|reportOpsFromUnitDirectly| D)))) + +;reportOpsFromUnitDirectly1 D == +; showFile := pathname ['SHOW,'LISTING,$listingDirectory] +; _$ERASE showFile +; $sayBrightlyStream : fluid := +; DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) +; sayShowWarning() +; reportOpsFromUnitDirectly D +; SHUT $sayBrightlyStream +; editFile showFile + +(DEFUN |reportOpsFromUnitDirectly1| (D) + (PROG (|$sayBrightlyStream| |showFile|) + (DECLARE (SPECIAL |$sayBrightlyStream|)) + (RETURN + (PROGN + (SPADLET |showFile| + (|pathname| + (CONS 'SHOW + (CONS 'LISTING + (CONS |$listingDirectory| NIL))))) + ($ERASE |showFile|) + (SPADLET |$sayBrightlyStream| + (DEFIOSTREAM + (CONS (CONS 'FILE |showFile|) + (CONS '(MODE . OUTPUT) NIL)) + 255 0)) + (|sayShowWarning|) + (|reportOpsFromUnitDirectly| D) + (SHUT |$sayBrightlyStream|) + (|editFile| |showFile|))))) + +;sayShowWarning() == +; sayBrightly +; '"Warning: this is a temporary file and will be deleted the next" +; sayBrightly +; '" time you use )show. Rename it and FILE if you wish to" +; sayBrightly +; '" save the contents." +; sayBrightly '"" + +(DEFUN |sayShowWarning| () + (PROGN + (|sayBrightly| + (MAKESTRING + "Warning: this is a temporary file and will be deleted the next")) + (|sayBrightly| + (MAKESTRING + " time you use )show. Rename it and FILE if you wish to")) + (|sayBrightly| (MAKESTRING " save the contents.")) + (|sayBrightly| (MAKESTRING "")))) + +;reportOpsFromLisplib0(unitForm,u) == +; $useEditorForShowOutput => reportOpsFromLisplib1(unitForm,u) +; reportOpsFromLisplib(unitForm,u) + +(DEFUN |reportOpsFromLisplib0| (|unitForm| |u|) + (COND + (|$useEditorForShowOutput| + (|reportOpsFromLisplib1| |unitForm| |u|)) + ('T (|reportOpsFromLisplib| |unitForm| |u|)))) + +;reportOpsFromLisplib1(unitForm,u) == +; showFile := pathname ['SHOW,'LISTING,$listingDirectory] +; _$ERASE showFile +; $sayBrightlyStream : fluid := +; DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) +; sayShowWarning() +; reportOpsFromLisplib(unitForm,u) +; SHUT $sayBrightlyStream +; editFile showFile + +(DEFUN |reportOpsFromLisplib1| (|unitForm| |u|) + (PROG (|$sayBrightlyStream| |showFile|) + (DECLARE (SPECIAL |$sayBrightlyStream|)) + (RETURN + (PROGN + (SPADLET |showFile| + (|pathname| + (CONS 'SHOW + (CONS 'LISTING + (CONS |$listingDirectory| NIL))))) + ($ERASE |showFile|) + (SPADLET |$sayBrightlyStream| + (DEFIOSTREAM + (CONS (CONS 'FILE |showFile|) + (CONS '(MODE . OUTPUT) NIL)) + 255 0)) + (|sayShowWarning|) + (|reportOpsFromLisplib| |unitForm| |u|) + (SHUT |$sayBrightlyStream|) + (|editFile| |showFile|))))) + +;reportOpsFromUnitDirectly unitForm == +; isRecordOrUnion := unitForm is [a,:.] and a in '(Record Union) +; unit:= evalDomain unitForm +; top:= CAR unitForm +; kind:= GETDATABASE(top,'CONSTRUCTORKIND) +; sayBrightly concat('%b,formatOpType unitForm, +; '%d,'"is a",'%b,kind,'%d, '"constructor.") +; if not isRecordOrUnion then +; abb := GETDATABASE(top,'ABBREVIATION) +; sourceFile := GETDATABASE(top,'SOURCEFILE) +; sayBrightly ['" Abbreviation for",:bright top,'"is",:bright abb] +; verb := +; isExposedConstructor top => '"is" +; '"is not" +; sayBrightly ['" This constructor",:bright verb, +; '"exposed in this frame."] +; sayBrightly ['" Issue",:bright STRCONC('")edit ", +; namestring sourceFile),'"to see algebra source code for", +; :bright abb,'%l] +; for [opt] in $options repeat +; opt := selectOptionLC(opt,$showOptions,'optionError) +; opt = 'attributes => +; centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) +; isRecordOrUnion => +; sayBrightly '" Records and Unions have no attributes." +; sayBrightly '"" +; attList:= REMDUP MSORT [x for [x,:.] in unit.2] +; say2PerLine [formatAttribute x for x in attList] +; NIL +; opt = 'operations => +; $commentedOps: local := 0 +; --new form is ( ) +; centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) +; sayBrightly '"" +; if isRecordOrUnion +; then +; constructorFunction:= GET(top,"makeFunctionList") or +; systemErrorHere '"reportOpsFromUnitDirectly" +; [funlist,.]:= FUNCALL(constructorFunction,"$",unitForm, +; $CategoryFrame) +; sigList := REMDUP MSORT [[[a,b],true,[c,0,1]] for +; [a,b,c] in funlist] +; else +; sigList:= REMDUP MSORT getOplistForConstructorForm unitForm +; say2PerLine [formatOperation(x,unit) for x in sigList] +; if $commentedOps ^= 0 then +; sayBrightly +; ['"Functions that are not yet implemented are preceded by", +; :bright '"--"] +; sayBrightly '"" +; NIL + +(DEFUN |reportOpsFromUnitDirectly| (|unitForm|) + (PROG (|$commentedOps| |isRecordOrUnion| |unit| |top| |kind| |abb| + |sourceFile| |verb| |opt| |x| |attList| + |constructorFunction| |LETTMP#1| |funlist| |a| |b| |c| + |sigList|) + (DECLARE (SPECIAL |$commentedOps|)) + (RETURN + (SEQ (PROGN + (SPADLET |isRecordOrUnion| + (AND (PAIRP |unitForm|) + (PROGN (SPADLET |a| (QCAR |unitForm|)) 'T) + (|member| |a| '(|Record| |Union|)))) + (SPADLET |unit| (|evalDomain| |unitForm|)) + (SPADLET |top| (CAR |unitForm|)) + (SPADLET |kind| (GETDATABASE |top| 'CONSTRUCTORKIND)) + (|sayBrightly| + (|concat| '|%b| (|formatOpType| |unitForm|) '|%d| + (MAKESTRING "is a") '|%b| |kind| '|%d| + (MAKESTRING "constructor."))) + (COND + ((NULL |isRecordOrUnion|) + (SPADLET |abb| (GETDATABASE |top| 'ABBREVIATION)) + (SPADLET |sourceFile| (GETDATABASE |top| 'SOURCEFILE)) + (|sayBrightly| + (CONS (MAKESTRING " Abbreviation for") + (APPEND (|bright| |top|) + (CONS (MAKESTRING "is") + (|bright| |abb|))))) + (SPADLET |verb| + (COND + ((|isExposedConstructor| |top|) + (MAKESTRING "is")) + ('T (MAKESTRING "is not")))) + (|sayBrightly| + (CONS (MAKESTRING " This constructor") + (APPEND (|bright| |verb|) + (CONS (MAKESTRING + "exposed in this frame.") + NIL)))) + (|sayBrightly| + (CONS (MAKESTRING " Issue") + (APPEND (|bright| + (STRCONC (MAKESTRING ")edit ") + (|namestring| |sourceFile|))) + (CONS (MAKESTRING + "to see algebra source code for") + (APPEND (|bright| |abb|) + (CONS '|%l| NIL)))))))) + (DO ((G166753 |$options| (CDR G166753)) + (G166737 NIL)) + ((OR (ATOM G166753) + (PROGN (SETQ G166737 (CAR G166753)) NIL) + (PROGN + (PROGN + (SPADLET |opt| (CAR G166737)) + G166737) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |opt| + (|selectOptionLC| |opt| + |$showOptions| '|optionError|)) + (COND + ((BOOT-EQUAL |opt| '|attributes|) + (|centerAndHighlight| + (MAKESTRING "Attributes") + $LINELENGTH (|specialChar| '|hbar|)) + (COND + (|isRecordOrUnion| + (|sayBrightly| + (MAKESTRING + " Records and Unions have no attributes."))) + ('T (|sayBrightly| (MAKESTRING "")) + (SPADLET |attList| + (REMDUP + (MSORT + (PROG (G166765) + (SPADLET G166765 NIL) + (RETURN + (DO + ((G166771 + (ELT |unit| 2) + (CDR G166771)) + (G166720 NIL)) + ((OR (ATOM G166771) + (PROGN + (SETQ G166720 + (CAR G166771)) + NIL) + (PROGN + (PROGN + (SPADLET |x| + (CAR + G166720)) + G166720) + NIL)) + (NREVERSE0 + G166765)) + (SEQ + (EXIT + (SETQ G166765 + (CONS |x| + G166765)))))))))) + (|say2PerLine| + (PROG (G166782) + (SPADLET G166782 NIL) + (RETURN + (DO + ((G166787 |attList| + (CDR G166787)) + (|x| NIL)) + ((OR (ATOM G166787) + (PROGN + (SETQ |x| + (CAR G166787)) + NIL)) + (NREVERSE0 G166782)) + (SEQ + (EXIT + (SETQ G166782 + (CONS + (|formatAttribute| |x|) + G166782)))))))) + NIL))) + ((BOOT-EQUAL |opt| '|operations|) + (SPADLET |$commentedOps| 0) + (|centerAndHighlight| + (MAKESTRING "Operations") + $LINELENGTH (|specialChar| '|hbar|)) + (|sayBrightly| (MAKESTRING "")) + (COND + (|isRecordOrUnion| + (SPADLET |constructorFunction| + (OR + (GETL |top| '|makeFunctionList|) + (|systemErrorHere| + (MAKESTRING + "reportOpsFromUnitDirectly")))) + (SPADLET |LETTMP#1| + (FUNCALL |constructorFunction| '$ + |unitForm| |$CategoryFrame|)) + (SPADLET |funlist| + (CAR |LETTMP#1|)) + (SPADLET |sigList| + (REMDUP + (MSORT + (PROG (G166798) + (SPADLET G166798 NIL) + (RETURN + (DO + ((G166804 |funlist| + (CDR G166804)) + (G166729 NIL)) + ((OR (ATOM G166804) + (PROGN + (SETQ G166729 + (CAR G166804)) + NIL) + (PROGN + (PROGN + (SPADLET |a| + (CAR G166729)) + (SPADLET |b| + (CADR G166729)) + (SPADLET |c| + (CADDR G166729)) + G166729) + NIL)) + (NREVERSE0 G166798)) + (SEQ + (EXIT + (SETQ G166798 + (CONS + (CONS + (CONS |a| + (CONS |b| NIL)) + (CONS 'T + (CONS + (CONS |c| + (CONS 0 + (CONS 1 NIL))) + NIL))) + G166798))))))))))) + ('T + (SPADLET |sigList| + (REMDUP + (MSORT + (|getOplistForConstructorForm| + |unitForm|)))))) + (|say2PerLine| + (PROG (G166815) + (SPADLET G166815 NIL) + (RETURN + (DO + ((G166820 |sigList| + (CDR G166820)) + (|x| NIL)) + ((OR (ATOM G166820) + (PROGN + (SETQ |x| (CAR G166820)) + NIL)) + (NREVERSE0 G166815)) + (SEQ + (EXIT + (SETQ G166815 + (CONS + (|formatOperation| |x| + |unit|) + G166815)))))))) + (COND + ((NEQUAL |$commentedOps| 0) + (|sayBrightly| + (CONS + (MAKESTRING + "Functions that are not yet implemented are preceded by") + (|bright| (MAKESTRING "--")))))) + (|sayBrightly| (MAKESTRING "")))))))) + NIL))))) + +;reportOpsFromLisplib(op,u) == +; null(fn:= constructor? op) => sayKeyedMsg("S2IZ0054",[u]) +; argml := +; (s := getConstructorSignature op) => KDR s +; NIL +; typ:= GETDATABASE(op,'CONSTRUCTORKIND) +; nArgs:= #argml +; argList:= KDR GETDATABASE(op,'CONSTRUCTORFORM) +; functorForm:= [op,:argList] +; argml:= EQSUBSTLIST(argList,$FormalMapVariableList,argml) +; functorFormWithDecl:= [op,:[[":",a,m] for a in argList for m in argml]] +; sayBrightly concat(bright form2StringWithWhere functorFormWithDecl, +; '" is a",bright typ,'"constructor") +; sayBrightly ['" Abbreviation for",:bright op,'"is",:bright fn] +; verb := +; isExposedConstructor op => '"is" +; '"is not" +; sayBrightly ['" This constructor",:bright verb, +; '"exposed in this frame."] +; sourceFile := GETDATABASE(op,'SOURCEFILE) +; sayBrightly ['" Issue",:bright STRCONC('")edit ", +; namestring sourceFile), +; '"to see algebra source code for",:bright fn,'%l] +; for [opt] in $options repeat +; opt := selectOptionLC(opt,$showOptions,'optionError) +; opt = 'layout => +; dc1 fn +; opt = 'views => sayBrightly ['"To get",:bright '"views", +; '"you must give parameters of constructor"] +; opt = 'attributes => +; centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) +; sayBrightly '"" +; attList:= REMDUP MSORT [x for [x,:.] in +; GETDATABASE(op,'ATTRIBUTES)] +; null attList => sayBrightly +; concat('%b,form2String functorForm,'%d,"has no attributes.",'%l) +; say2PerLine [formatAttribute x for x in attList] +; NIL +; opt = 'operations => displayOperationsFromLisplib functorForm +; nil + +(DEFUN |reportOpsFromLisplib| (|op| |u|) + (PROG (|fn| |s| |typ| |nArgs| |argList| |functorForm| |argml| + |functorFormWithDecl| |verb| |sourceFile| |opt| |x| + |attList|) + (RETURN + (SEQ (COND + ((NULL (SPADLET |fn| (|constructor?| |op|))) + (|sayKeyedMsg| 'S2IZ0054 (CONS |u| NIL))) + ('T + (SPADLET |argml| + (COND + ((SPADLET |s| + (|getConstructorSignature| |op|)) + (KDR |s|)) + ('T NIL))) + (SPADLET |typ| (GETDATABASE |op| 'CONSTRUCTORKIND)) + (SPADLET |nArgs| (|#| |argml|)) + (SPADLET |argList| + (KDR (GETDATABASE |op| 'CONSTRUCTORFORM))) + (SPADLET |functorForm| (CONS |op| |argList|)) + (SPADLET |argml| + (EQSUBSTLIST |argList| |$FormalMapVariableList| + |argml|)) + (SPADLET |functorFormWithDecl| + (CONS |op| + (PROG (G166872) + (SPADLET G166872 NIL) + (RETURN + (DO ((G166878 |argList| + (CDR G166878)) + (|a| NIL) + (G166879 |argml| + (CDR G166879)) + (|m| NIL)) + ((OR (ATOM G166878) + (PROGN + (SETQ |a| (CAR G166878)) + NIL) + (ATOM G166879) + (PROGN + (SETQ |m| (CAR G166879)) + NIL)) + (NREVERSE0 G166872)) + (SEQ + (EXIT + (SETQ G166872 + (CONS + (CONS '|:| + (CONS |a| (CONS |m| NIL))) + G166872))))))))) + (|sayBrightly| + (|concat| + (|bright| + (|form2StringWithWhere| + |functorFormWithDecl|)) + (MAKESTRING " is a") (|bright| |typ|) + (MAKESTRING "constructor"))) + (|sayBrightly| + (CONS (MAKESTRING " Abbreviation for") + (APPEND (|bright| |op|) + (CONS (MAKESTRING "is") + (|bright| |fn|))))) + (SPADLET |verb| + (COND + ((|isExposedConstructor| |op|) + (MAKESTRING "is")) + ('T (MAKESTRING "is not")))) + (|sayBrightly| + (CONS (MAKESTRING " This constructor") + (APPEND (|bright| |verb|) + (CONS (MAKESTRING + "exposed in this frame.") + NIL)))) + (SPADLET |sourceFile| (GETDATABASE |op| 'SOURCEFILE)) + (|sayBrightly| + (CONS (MAKESTRING " Issue") + (APPEND (|bright| + (STRCONC (MAKESTRING ")edit ") + (|namestring| |sourceFile|))) + (CONS (MAKESTRING + "to see algebra source code for") + (APPEND (|bright| |fn|) + (CONS '|%l| NIL)))))) + (DO ((G166896 |$options| (CDR G166896)) + (G166863 NIL)) + ((OR (ATOM G166896) + (PROGN (SETQ G166863 (CAR G166896)) NIL) + (PROGN + (PROGN + (SPADLET |opt| (CAR G166863)) + G166863) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |opt| + (|selectOptionLC| |opt| + |$showOptions| '|optionError|)) + (COND + ((BOOT-EQUAL |opt| '|layout|) + (|dc1| |fn|)) + ((BOOT-EQUAL |opt| '|views|) + (|sayBrightly| + (CONS (MAKESTRING "To get") + (APPEND + (|bright| (MAKESTRING "views")) + (CONS + (MAKESTRING + "you must give parameters of constructor") + NIL))))) + ((BOOT-EQUAL |opt| '|attributes|) + (|centerAndHighlight| + (MAKESTRING "Attributes") + $LINELENGTH + (|specialChar| '|hbar|)) + (|sayBrightly| (MAKESTRING "")) + (SPADLET |attList| + (REMDUP + (MSORT + (PROG (G166908) + (SPADLET G166908 NIL) + (RETURN + (DO + ((G166914 + (GETDATABASE |op| + 'ATTRIBUTES) + (CDR G166914)) + (G166858 NIL)) + ((OR (ATOM G166914) + (PROGN + (SETQ G166858 + (CAR G166914)) + NIL) + (PROGN + (PROGN + (SPADLET |x| + (CAR G166858)) + G166858) + NIL)) + (NREVERSE0 G166908)) + (SEQ + (EXIT + (SETQ G166908 + (CONS |x| + G166908)))))))))) + (COND + ((NULL |attList|) + (|sayBrightly| + (|concat| '|%b| + (|form2String| |functorForm|) + '|%d| '|has no attributes.| '|%l|))) + ('T + (|say2PerLine| + (PROG (G166925) + (SPADLET G166925 NIL) + (RETURN + (DO + ((G166930 |attList| + (CDR G166930)) + (|x| NIL)) + ((OR (ATOM G166930) + (PROGN + (SETQ |x| (CAR G166930)) + NIL)) + (NREVERSE0 G166925)) + (SEQ + (EXIT + (SETQ G166925 + (CONS + (|formatAttribute| |x|) + G166925)))))))) + NIL))) + ((BOOT-EQUAL |opt| '|operations|) + (|displayOperationsFromLisplib| + |functorForm|)) + ('T NIL)))))))))))) + +;displayOperationsFromLisplib form == +; [name,:argl] := form +; kind := GETDATABASE(name,'CONSTRUCTORKIND) +; centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) +; opList:= GETDATABASE(name,'OPERATIONALIST) +; null opList => reportOpsFromUnitDirectly form +; opl:=REMDUP MSORT EQSUBSTLIST(argl,$FormalMapVariableList,opList) +; ops:= nil +; for x in opl repeat +; ops := [:ops,:formatOperationAlistEntry(x)] +; say2PerLine ops +; nil + +(DEFUN |displayOperationsFromLisplib| (|form|) + (PROG (|name| |argl| |kind| |opList| |opl| |ops|) + (RETURN + (SEQ (PROGN + (SPADLET |name| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |kind| (GETDATABASE |name| 'CONSTRUCTORKIND)) + (|centerAndHighlight| (MAKESTRING "Operations") + $LINELENGTH (|specialChar| '|hbar|)) + (SPADLET |opList| (GETDATABASE |name| 'OPERATIONALIST)) + (COND + ((NULL |opList|) (|reportOpsFromUnitDirectly| |form|)) + ('T + (SPADLET |opl| + (REMDUP (MSORT (EQSUBSTLIST |argl| + |$FormalMapVariableList| + |opList|)))) + (SPADLET |ops| NIL) + (DO ((G166964 |opl| (CDR G166964)) (|x| NIL)) + ((OR (ATOM G166964) + (PROGN (SETQ |x| (CAR G166964)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |ops| + (APPEND |ops| + (|formatOperationAlistEntry| + |x|)))))) + (|say2PerLine| |ops|) NIL))))))) + +;--% )synonym +;synonym(:l) == synonymSpad2Cmd() -- always passed a null list + +(DEFUN |synonym| (&REST G166983 &AUX |l|) + (DSETQ |l| G166983) + (|synonymSpad2Cmd|)) + +;synonymSpad2Cmd() == +; line := getSystemCommandLine() +; if line = '"" then printSynonyms(NIL) +; else +; pair := processSynonymLine line +; if $CommandSynonymAlist then +; PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) +; else $CommandSynonymAlist := [pair] +; terminateSystemCommand() + +(DEFUN |synonymSpad2Cmd| () + (PROG (|line| |pair|) + (RETURN + (PROGN + (SPADLET |line| (|getSystemCommandLine|)) + (COND + ((BOOT-EQUAL |line| (MAKESTRING "")) (|printSynonyms| NIL)) + ('T (SPADLET |pair| (|processSynonymLine| |line|)) + (COND + (|$CommandSynonymAlist| + (PUTALIST |$CommandSynonymAlist| (CAR |pair|) + (CDR |pair|))) + ('T (SPADLET |$CommandSynonymAlist| (CONS |pair| NIL)))))) + (|terminateSystemCommand|))))) + +;processSynonymLine line == +; key := STRING2ID_-N (line, 1) +; value := removeKeyFromLine line where +; removeKeyFromLine line == +; line := dropLeadingBlanks line +; mx := MAXINDEX line +; for i in 0..mx repeat +; line.i = " " => +; return (for j in (i+1)..mx repeat +; line.j ^= " " => return (SUBSTRING (line, j, nil))) +; [key, :value] + +(DEFUN |processSynonymLine,removeKeyFromLine| (|line|) + (PROG (|mx|) + (RETURN + (SEQ (SPADLET |line| (|dropLeadingBlanks| |line|)) + (SPADLET |mx| (MAXINDEX |line|)) + (EXIT (DO ((|i| 0 (QSADD1 |i|))) ((QSGREATERP |i| |mx|) NIL) + (SEQ (EXIT (IF (BOOT-EQUAL (ELT |line| |i|) '| |) + (EXIT (RETURN + (DO + ((|j| (PLUS |i| 1) + (+ |j| 1))) + ((> |j| |mx|) NIL) + (SEQ + (EXIT + (IF + (NEQUAL (ELT |line| |j|) + '| |) + (EXIT + (RETURN + (SUBSTRING |line| |j| + NIL)))))))))))))))))) + + +(DEFUN |processSynonymLine| (|line|) + (PROG (|key| |value|) + (RETURN + (PROGN + (SPADLET |key| (STRING2ID-N |line| 1)) + (SPADLET |value| + (|processSynonymLine,removeKeyFromLine| |line|)) + (CONS |key| |value|))))) + +;printSynonyms(patterns) == +; centerAndHighlight("System Command Synonyms",$LINELENGTH,specialChar 'hbar) +; ls := filterListOfStringsWithFn(patterns, [[STRINGIMAGE a,:b] +; for [a,:b] in synonymsForUserLevel $CommandSynonymAlist], +; function CAR) +; printLabelledList(ls,'"user",'"synonyms",'")",patterns) +; nil + +(DEFUN |printSynonyms| (|patterns|) + (PROG (|a| |b| |ls|) + (RETURN + (SEQ (PROGN + (|centerAndHighlight| '|System Command Synonyms| + $LINELENGTH (|specialChar| '|hbar|)) + (SPADLET |ls| + (|filterListOfStringsWithFn| |patterns| + (PROG (G167027) + (SPADLET G167027 NIL) + (RETURN + (DO ((G167033 + (|synonymsForUserLevel| + |$CommandSynonymAlist|) + (CDR G167033)) + (G167017 NIL)) + ((OR (ATOM G167033) + (PROGN + (SETQ G167017 (CAR G167033)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR G167017)) + (SPADLET |b| (CDR G167017)) + G167017) + NIL)) + (NREVERSE0 G167027)) + (SEQ (EXIT + (SETQ G167027 + (CONS + (CONS (STRINGIMAGE |a|) |b|) + G167027))))))) + (|function| CAR))) + (|printLabelledList| |ls| (MAKESTRING "user") + (MAKESTRING "synonyms") (MAKESTRING ")") |patterns|) + NIL))))) + +;printLabelledList(ls,label1,label2,prefix,patterns) == +; -- prefix goes before each element on each side of the list, eg, +; -- ")" +; null ls => +; null patterns => +; sayMessage ['" No ",label1,'"-defined ",label2,'" in effect."] +; sayMessage ['" No ",label1,'"-defined ",label2,'" satisfying patterns:", +; '%l,'" ",'%b,:blankList patterns,'%d] +; if patterns then +; sayMessage [label1,'"-defined ",label2,'" satisfying patterns:", +; '%l,'" ",'%b,:blankList patterns,'%d] +; for [syn,:comm] in ls repeat +; if SUBSTRING(syn,0,1) = '"|" then syn := SUBSTRING(syn,1,NIL) +; if syn = '"%i" then syn := '"%i " +; wid := MAX(30 - (entryWidth syn),1) +; sayBrightly concat('%b,prefix,syn,'%d, +; fillerSpaces(wid,'"."),'" ",prefix,comm) +; sayBrightly '"" + +(DEFUN |printLabelledList| (|ls| |label1| |label2| |prefix| |patterns|) + (PROG (|comm| |syn| |wid|) + (RETURN + (SEQ (COND + ((NULL |ls|) + (COND + ((NULL |patterns|) + (|sayMessage| + (CONS (MAKESTRING " No ") + (CONS |label1| + (CONS (MAKESTRING "-defined ") + (CONS |label2| + (CONS + (MAKESTRING " in effect.") + NIL))))))) + ('T + (|sayMessage| + (CONS (MAKESTRING " No ") + (CONS |label1| + (CONS (MAKESTRING "-defined ") + (CONS |label2| + (CONS + (MAKESTRING + " satisfying patterns:") + (CONS '|%l| + (CONS (MAKESTRING " ") + (CONS '|%b| + (APPEND + (|blankList| |patterns|) + (CONS '|%d| NIL)))))))))))))) + ('T + (COND + (|patterns| + (|sayMessage| + (CONS |label1| + (CONS (MAKESTRING "-defined ") + (CONS |label2| + (CONS + (MAKESTRING + " satisfying patterns:") + (CONS '|%l| + (CONS (MAKESTRING " ") + (CONS '|%b| + (APPEND + (|blankList| |patterns|) + (CONS '|%d| NIL)))))))))))) + (DO ((G167062 |ls| (CDR G167062)) (G167049 NIL)) + ((OR (ATOM G167062) + (PROGN (SETQ G167049 (CAR G167062)) NIL) + (PROGN + (PROGN + (SPADLET |syn| (CAR G167049)) + (SPADLET |comm| (CDR G167049)) + G167049) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((BOOT-EQUAL (SUBSTRING |syn| 0 1) + (MAKESTRING "|")) + (SPADLET |syn| (SUBSTRING |syn| 1 NIL)))) + (COND + ((BOOT-EQUAL |syn| (MAKESTRING "%i")) + (SPADLET |syn| (MAKESTRING "%i ")))) + (SPADLET |wid| + (MAX + (SPADDIFFERENCE 30 + (|entryWidth| |syn|)) + 1)) + (|sayBrightly| + (|concat| '|%b| |prefix| |syn| '|%d| + (|fillerSpaces| |wid| + (MAKESTRING ".")) + (MAKESTRING " ") |prefix| |comm|)))))) + (|sayBrightly| (MAKESTRING "")))))))) + +;whatCommands(patterns) == +; label := STRCONC("System Commands for User Level: ", +; STRINGIMAGE $UserLevel) +; centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) +; l := filterListOfStrings(patterns, +; [(STRINGIMAGE a) for a in commandsForUserLevel $systemCommands]) +; if patterns then +; null l => +; sayMessage ['"No system commands at this level matching patterns:", +; '%l,'" ",'%b,:blankList patterns,'%d] +; sayMessage ['"System commands at this level matching patterns:", +; '%l,'" ",'%b,:blankList patterns,'%d] +; if l then +; sayAsManyPerLineAsPossible l +; SAY " " +; patterns => nil -- don't be so verbose +; sayKeyedMsg("S2IZ0046",NIL) +; nil + +(DEFUN |whatCommands| (|patterns|) + (PROG (|label| |l|) + (RETURN + (SEQ (PROGN + (SPADLET |label| + (STRCONC '|System Commands for User Level: | + (STRINGIMAGE |$UserLevel|))) + (|centerAndHighlight| |label| $LINELENGTH + (|specialChar| '|hbar|)) + (SPADLET |l| + (|filterListOfStrings| |patterns| + (PROG (G167084) + (SPADLET G167084 NIL) + (RETURN + (DO ((G167089 + (|commandsForUserLevel| + |$systemCommands|) + (CDR G167089)) + (|a| NIL)) + ((OR (ATOM G167089) + (PROGN + (SETQ |a| (CAR G167089)) + NIL)) + (NREVERSE0 G167084)) + (SEQ (EXIT + (SETQ G167084 + (CONS (STRINGIMAGE |a|) + G167084))))))))) + (COND + (|patterns| + (COND + ((NULL |l|) + (|sayMessage| + (CONS (MAKESTRING + "No system commands at this level matching patterns:") + (CONS '|%l| + (CONS (MAKESTRING " ") + (CONS '|%b| + (APPEND + (|blankList| |patterns|) + (CONS '|%d| NIL)))))))) + ('T + (|sayMessage| + (CONS (MAKESTRING + "System commands at this level matching patterns:") + (CONS '|%l| + (CONS (MAKESTRING " ") + (CONS '|%b| + (APPEND + (|blankList| |patterns|) + (CONS '|%d| NIL))))))))))) + (COND + (|l| (|sayAsManyPerLineAsPossible| |l|) + (SAY (MAKESTRING " ")))) + (COND + (|patterns| NIL) + ('T (|sayKeyedMsg| 'S2IZ0046 NIL) NIL))))))) + +;reportWhatOptions() == +; optList1:= "append"/[['%l,'" ",x] for x in $whatOptions] +; sayBrightly +; ['%b,'" )what",'%d,'"argument keywords are",'%b,:optList1,'%d,'%l, +; '" or abbreviations thereof.",'%l, +; '%l,'" Issue",'%b,'")what ?",'%d,'"for more information."] + +(DEFUN |reportWhatOptions| () + (PROG (|optList1|) + (RETURN + (SEQ (PROGN + (SPADLET |optList1| + (PROG (G167102) + (SPADLET G167102 NIL) + (RETURN + (DO ((G167107 |$whatOptions| + (CDR G167107)) + (|x| NIL)) + ((OR (ATOM G167107) + (PROGN + (SETQ |x| (CAR G167107)) + NIL)) + G167102) + (SEQ (EXIT (SETQ G167102 + (APPEND G167102 + (CONS '|%l| + (CONS (MAKESTRING " ") + (CONS |x| NIL))))))))))) + (|sayBrightly| + (CONS '|%b| + (CONS (MAKESTRING " )what") + (CONS '|%d| + (CONS + (MAKESTRING + "argument keywords are") + (CONS '|%b| + (APPEND |optList1| + (CONS '|%d| + (CONS '|%l| + (CONS + (MAKESTRING + " or abbreviations thereof.") + (CONS '|%l| + (CONS '|%l| + (CONS + (MAKESTRING " Issue") + (CONS '|%b| + (CONS + (MAKESTRING ")what ?") + (CONS '|%d| + (CONS + (MAKESTRING + "for more information.") + NIL)))))))))))))))))))))) + +;filterListOfStrings(patterns,names) == +; -- names and patterns are lists of strings +; -- returns: list of strings in names that contains any of the strings +; -- in patterns +; (null patterns) or (null names) => names +; names' := NIL +; for name in reverse names repeat +; satisfiesRegularExpressions(name,patterns) => +; names' := [name,:names'] +; names' + +(DEFUN |filterListOfStrings| (|patterns| |names|) + (PROG (|names'|) + (RETURN + (SEQ (COND + ((OR (NULL |patterns|) (NULL |names|)) |names|) + ('T (SPADLET |names'| NIL) + (SEQ (DO ((G167122 (REVERSE |names|) (CDR G167122)) + (|name| NIL)) + ((OR (ATOM G167122) + (PROGN (SETQ |name| (CAR G167122)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|satisfiesRegularExpressions| + |name| |patterns|) + (EXIT + (SPADLET |names'| + (CONS |name| |names'|)))))))) + (EXIT |names'|)))))))) + +;filterListOfStringsWithFn(patterns,names,fn) == +; -- names and patterns are lists of strings +; -- fn is something like CAR or CADR +; -- returns: list of strings in names that contains any of the strings +; -- in patterns +; (null patterns) or (null names) => names +; names' := NIL +; for name in reverse names repeat +; satisfiesRegularExpressions(FUNCALL(fn,name),patterns) => +; names' := [name,:names'] +; names' + +(DEFUN |filterListOfStringsWithFn| (|patterns| |names| |fn|) + (PROG (|names'|) + (RETURN + (SEQ (COND + ((OR (NULL |patterns|) (NULL |names|)) |names|) + ('T (SPADLET |names'| NIL) + (SEQ (DO ((G167137 (REVERSE |names|) (CDR G167137)) + (|name| NIL)) + ((OR (ATOM G167137) + (PROGN (SETQ |name| (CAR G167137)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|satisfiesRegularExpressions| + (FUNCALL |fn| |name|) |patterns|) + (EXIT + (SPADLET |names'| + (CONS |name| |names'|)))))))) + (EXIT |names'|)))))))) + +;satisfiesRegularExpressions(name,patterns) == +; -- this is a first cut +; nf := true +; dname := DOWNCASE COPY name +; for pattern in patterns while nf repeat +; -- use @ as a wildcard +; STRPOS(pattern,dname,0,'"@") => nf := nil +; null nf + +(DEFUN |satisfiesRegularExpressions| (|name| |patterns|) + (PROG (|dname| |nf|) + (RETURN + (SEQ (PROGN + (SPADLET |nf| 'T) + (SPADLET |dname| (DOWNCASE (COPY |name|))) + (SEQ (DO ((G167153 |patterns| (CDR G167153)) + (|pattern| NIL)) + ((OR (ATOM G167153) + (PROGN + (SETQ |pattern| (CAR G167153)) + NIL) + (NULL |nf|)) + NIL) + (SEQ (EXIT (COND + ((STRPOS |pattern| |dname| 0 + (MAKESTRING "@")) + (EXIT (SPADLET |nf| NIL))))))) + (NULL |nf|))))))) + +;--% )with ... defined in daase.lisp (boot won't parse it) +;--% Synonym File Reader +;--------------------> NEW DEFINITION (override in util.lisp.pamphlet) +;processSynonyms() == +; p := STRPOS('")",LINE,0,NIL) +; fill := '"" +; if p +; then +; line := SUBSTRING(LINE,p,NIL); +; if p > 0 then fill := SUBSTRING(LINE,0,p) +; else +; p := 0 +; line := LINE +; to := STRPOS ('" ", line, 1, nil) +; if to then to := to - 1 +; synstr := SUBSTRING (line, 1, to) +; syn := STRING2ID_-N (synstr, 1) +; null (fun := LASSOC (syn, $CommandSynonymAlist)) => NIL +; to := STRPOS('")",fun,1,NIL) +; if to and to ^= SIZE(fun)-1 then +; opt := STRCONC('" ",SUBSTRING(fun,to,NIL)) +; fun := SUBSTRING(fun,0,to-1) +; else opt := '" " +; if (SIZE synstr) > (SIZE fun) then +; for i in (SIZE fun)..(SIZE synstr) repeat +; fun := CONCAT (fun, '" ") +;-- $currentLine := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) +; cl := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) +; SETQ(LINE,cl) +; SETQ(CHR,LINE.(p+1)) +; processSynonyms () + +;;; *** |processSynonyms| REDEFINED + +(DEFUN |processSynonyms| () + (PROG (|fill| |p| |line| |synstr| |syn| |to| |opt| |fun| |cl|) + (RETURN + (SEQ (PROGN + (SPADLET |p| (STRPOS (MAKESTRING ")") LINE 0 NIL)) + (SPADLET |fill| (MAKESTRING "")) + (COND + (|p| (SPADLET |line| (SUBSTRING LINE |p| NIL)) + (COND + ((> |p| 0) + (SPADLET |fill| (SUBSTRING LINE 0 |p|))) + ('T NIL))) + ('T (SPADLET |p| 0) (SPADLET |line| LINE))) + (SPADLET |to| (STRPOS (MAKESTRING " ") |line| 1 NIL)) + (COND (|to| (SPADLET |to| (SPADDIFFERENCE |to| 1)))) + (SPADLET |synstr| (SUBSTRING |line| 1 |to|)) + (SPADLET |syn| (STRING2ID-N |synstr| 1)) + (COND + ((NULL (SPADLET |fun| + (LASSOC |syn| |$CommandSynonymAlist|))) + NIL) + ('T (SPADLET |to| (STRPOS (MAKESTRING ")") |fun| 1 NIL)) + (COND + ((AND |to| + (NEQUAL |to| (SPADDIFFERENCE (SIZE |fun|) 1))) + (SPADLET |opt| + (STRCONC (MAKESTRING " ") + (SUBSTRING |fun| |to| NIL))) + (SPADLET |fun| + (SUBSTRING |fun| 0 (SPADDIFFERENCE |to| 1)))) + ('T (SPADLET |opt| (MAKESTRING " ")))) + (COND + ((> (SIZE |synstr|) (SIZE |fun|)) + (DO ((G167173 (SIZE |synstr|)) + (|i| (SIZE |fun|) (+ |i| 1))) + ((> |i| G167173) NIL) + (SEQ (EXIT (SPADLET |fun| + (CONCAT |fun| + (MAKESTRING " ")))))))) + (SPADLET |cl| + (STRCONC |fill| + (RPLACSTR |line| 1 (SIZE |synstr|) + |fun|) + |opt|)) + (SETQ LINE |cl|) (SETQ CHR (ELT LINE (PLUS |p| 1))) + (|processSynonyms|)))))))) + +;-- functions for interfacing to system commands from algebra code +;-- common lisp dependent +;tabsToBlanks s == +; k := charPosition($charTab,s,0) +; n := #s +; k < n => +; k = 0 => tabsToBlanks SUBSTRING(s,1,nil) +; STRCONC(SUBSTRING(s,0,k),$charBlank, tabsToBlanks SUBSTRING(s,k + 1,nil)) +; s + +(DEFUN |tabsToBlanks| (|s|) + (PROG (|k| |n|) + (RETURN + (PROGN + (SPADLET |k| (|charPosition| |$charTab| |s| 0)) + (SPADLET |n| (|#| |s|)) + (COND + ((> |n| |k|) + (COND + ((EQL |k| 0) (|tabsToBlanks| (SUBSTRING |s| 1 NIL))) + ('T + (STRCONC (SUBSTRING |s| 0 |k|) |$charBlank| + (|tabsToBlanks| + (SUBSTRING |s| (PLUS |k| 1) NIL)))))) + ('T |s|)))))) + +;doSystemCommand string == +; string := CONCAT('")", EXPAND_-TABS string) +; LINE: fluid := string +; processSynonyms() +; string := LINE +; string:=SUBSTRING(string,1,nil) +; string = '"" => nil +; tok:=getFirstWord(string) +; tok => +; unab := unAbbreviateKeyword tok +; MEMBER(unab, $noParseCommands) => +; handleNoParseCommands(unab, string) +; optionList := splitIntoOptionBlocks string +; MEMBER(unab, $tokenCommands) => +; handleTokensizeSystemCommands(unab, optionList) +; handleParsedSystemCommands(unab, optionList) +; nil +; nil + +(DEFUN |doSystemCommand| (|string|) + (PROG (LINE |tok| |unab| |optionList|) + (DECLARE (SPECIAL LINE)) + (RETURN + (PROGN + (SPADLET |string| + (CONCAT (MAKESTRING ")") (EXPAND-TABS |string|))) + (SPADLET LINE |string|) + (|processSynonyms|) + (SPADLET |string| LINE) + (SPADLET |string| (SUBSTRING |string| 1 NIL)) + (COND + ((BOOT-EQUAL |string| (MAKESTRING "")) NIL) + ('T (SPADLET |tok| (|getFirstWord| |string|)) + (COND + (|tok| (SPADLET |unab| (|unAbbreviateKeyword| |tok|)) + (COND + ((|member| |unab| |$noParseCommands|) + (|handleNoParseCommands| |unab| |string|)) + ('T + (SPADLET |optionList| + (|splitIntoOptionBlocks| |string|)) + (COND + ((|member| |unab| |$tokenCommands|) + (|handleTokensizeSystemCommands| |unab| + |optionList|)) + ('T + (|handleParsedSystemCommands| |unab| + |optionList|) + NIL))))) + ('T NIL)))))))) + +;npboot str == +; sex := string2BootTree str +; FORMAT(true, '"~&~S~%", sex) +; $ans := EVAL sex +; FORMAT(true, '"~&Value = ~S~%", $ans) + +(DEFUN |npboot| (|str|) + (PROG (|sex|) + (RETURN + (PROGN + (SPADLET |sex| (|string2BootTree| |str|)) + (FORMAT 'T (MAKESTRING "~&~S~%") |sex|) + (SPADLET |$ans| (EVAL |sex|)) + (FORMAT 'T (MAKESTRING "~&Value = ~S~%") |$ans|))))) + +;stripLisp str == +; found := false +; strIndex := 0 +; lispStr := '"lisp" +; for c0 in 0..#str-1 for c1 in 0..#lispStr-1 repeat +; (char str.c0) ^= (char lispStr.c1) => +; return nil +; strIndex := c0+1 +; SUBSEQ(str, strIndex) + +(DEFUN |stripLisp| (|str|) + (PROG (|found| |lispStr| |strIndex|) + (RETURN + (SEQ (PROGN + (SPADLET |found| NIL) + (SPADLET |strIndex| 0) + (SPADLET |lispStr| (MAKESTRING "lisp")) + (DO ((G167230 (SPADDIFFERENCE (|#| |str|) 1)) + (|c0| 0 (QSADD1 |c0|)) + (G167231 (SPADDIFFERENCE (|#| |lispStr|) 1)) + (|c1| 0 (QSADD1 |c1|))) + ((OR (QSGREATERP |c0| G167230) + (QSGREATERP |c1| G167231)) + NIL) + (SEQ (EXIT (COND + ((NEQUAL (|char| (ELT |str| |c0|)) + (|char| (ELT |lispStr| |c1|))) + (RETURN NIL)) + ('T (SPADLET |strIndex| (PLUS |c0| 1))))))) + (SUBSEQ |str| |strIndex|)))))) + +;nplisp str == +; $ans := EVAL READ_-FROM_-STRING str +; FORMAT(true, '"~&Value = ~S~%", $ans) + +(DEFUN |nplisp| (|str|) + (PROGN + (SPADLET |$ans| (EVAL (READ-FROM-STRING |str|))) + (FORMAT 'T (MAKESTRING "~&Value = ~S~%") |$ans|))) + +;npsystem(unab, str) == +; spaceIndex := SEARCH('" ", str) +; null spaceIndex => +; sayKeyedMsg('"S2IZ0080", [str]) +; sysPart := SUBSEQ(str, 0, spaceIndex) +; -- The following is a hack required by the fact that unAbbreviateKeyword +; -- returns the word "system" for unknown words +; null SEARCH(sysPart, STRING unab) => +; sayKeyedMsg('"S2IZ0080", [sysPart]) +; command := SUBSEQ(str, spaceIndex+1) +; OBEY command + +(DEFUN |npsystem| (|unab| |str|) + (PROG (|spaceIndex| |sysPart| |command|) + (RETURN + (PROGN + (SPADLET |spaceIndex| (SEARCH (MAKESTRING " ") |str|)) + (COND + ((NULL |spaceIndex|) + (|sayKeyedMsg| (MAKESTRING "S2IZ0080") (CONS |str| NIL))) + ('T (SPADLET |sysPart| (SUBSEQ |str| 0 |spaceIndex|)) + (COND + ((NULL (SEARCH |sysPart| (STRING |unab|))) + (|sayKeyedMsg| (MAKESTRING "S2IZ0080") + (CONS |sysPart| NIL))) + ('T + (SPADLET |command| (SUBSEQ |str| (PLUS |spaceIndex| 1))) + (OBEY |command|))))))))) + +;npsynonym(unab, str) == +; npProcessSynonym(str) + +(DEFUN |npsynonym| (|unab| |str|) + (|npProcessSynonym| |str|)) + +;tokenSystemCommand(unabr, tokList) == +; systemCommand tokList + +(DEFUN |tokenSystemCommand| (|unabr| |tokList|) + (|systemCommand| |tokList|)) + +;tokTran tok == +; STRINGP tok => +; #tok = 0 => nil +; isIntegerString tok => READ_-FROM_-STRING tok +; STRING tok.0 = '"_"" => +; SUBSEQ(tok, 1, #tok-1) +; INTERN tok +; tok + +(DEFUN |tokTran| (|tok|) + (COND + ((STRINGP |tok|) + (COND + ((EQL (|#| |tok|) 0) NIL) + ((|isIntegerString| |tok|) (READ-FROM-STRING |tok|)) + ((BOOT-EQUAL (STRING (ELT |tok| 0)) (MAKESTRING "\"")) + (SUBSEQ |tok| 1 (SPADDIFFERENCE (|#| |tok|) 1))) + ('T (INTERN |tok|)))) + ('T |tok|))) + +;isIntegerString tok == +; for i in 0..#tok-1 repeat +; val := DIGIT_-CHAR_-P tok.i +; not val => return nil +; val + +(DEFUN |isIntegerString| (|tok|) + (PROG (|val|) + (RETURN + (SEQ (PROGN + (DO ((G167273 (SPADDIFFERENCE (|#| |tok|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G167273) NIL) + (SEQ (EXIT (PROGN + (SPADLET |val| + (DIGIT-CHAR-P (ELT |tok| |i|))) + (COND ((NULL |val|) (RETURN NIL))))))) + |val|))))) + +;splitIntoOptionBlocks str == +; inString := false +; optionBlocks := nil +; blockStart := 0 +; parenCount := 0 +; for i in 0..#str-1 repeat +; STRING str.i = '"_"" => +; inString := not inString +; if STRING str.i = '"(" and not inString +; then parenCount := parenCount + 1 +; if STRING str.i = '")" and not inString +; then parenCount := parenCount - 1 +; STRING str.i = '")" and not inString and parenCount = -1 => +; block := stripSpaces SUBSEQ(str, blockStart, i) +; blockList := [block, :blockList] +; blockStart := i+1 +; parenCount := 0 +; blockList := [stripSpaces SUBSEQ(str, blockStart), :blockList] +; nreverse blockList + +(DEFUN |splitIntoOptionBlocks| (|str|) + (PROG (|optionBlocks| |inString| |block| |blockStart| |parenCount| + |blockList|) + (RETURN + (SEQ (PROGN + (SPADLET |inString| NIL) + (SPADLET |optionBlocks| NIL) + (SPADLET |blockStart| 0) + (SPADLET |parenCount| 0) + (DO ((G167291 (SPADDIFFERENCE (|#| |str|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G167291) NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL (STRING (ELT |str| |i|)) + (MAKESTRING "\"")) + (SPADLET |inString| (NULL |inString|))) + ('T + (COND + ((AND (BOOT-EQUAL + (STRING (ELT |str| |i|)) + (MAKESTRING "(")) + (NULL |inString|)) + (SPADLET |parenCount| + (PLUS |parenCount| 1)))) + (COND + ((AND (BOOT-EQUAL + (STRING (ELT |str| |i|)) + (MAKESTRING ")")) + (NULL |inString|)) + (SPADLET |parenCount| + (SPADDIFFERENCE |parenCount| + 1)))) + (COND + ((AND (BOOT-EQUAL + (STRING (ELT |str| |i|)) + (MAKESTRING ")")) + (NULL |inString|) + (BOOT-EQUAL |parenCount| + (SPADDIFFERENCE 1))) + (PROGN + (SPADLET |block| + (|stripSpaces| + (SUBSEQ |str| |blockStart| + |i|))) + (SPADLET |blockList| + (CONS |block| |blockList|)) + (SPADLET |blockStart| (PLUS |i| 1)) + (SPADLET |parenCount| 0))))))))) + (SPADLET |blockList| + (CONS (|stripSpaces| (SUBSEQ |str| |blockStart|)) + |blockList|)) + (NREVERSE |blockList|)))))) + +;dumbTokenize str == +; -- split into tokens delimted by spaces, taking quoted strings into account +; inString := false +; tokenList := nil +; tokenStart := 0 +; previousSpace := false +; for i in 0..#str-1 repeat +; STRING str.i = '"_"" => +; inString := not inString +; previousSpace := false +; STRING str.i = '" " and not inString => +; previousSpace => nil +; token := stripSpaces SUBSEQ(str, tokenStart, i) +; tokenList := [token, :tokenList] +; tokenStart := i+1 +; previousSpace := true +; previousSpace := false +; tokenList := [stripSpaces SUBSEQ(str, tokenStart), :tokenList] +; nreverse tokenList + +(DEFUN |dumbTokenize| (|str|) + (PROG (|inString| |token| |tokenStart| |previousSpace| |tokenList|) + (RETURN + (SEQ (PROGN + (SPADLET |inString| NIL) + (SPADLET |tokenList| NIL) + (SPADLET |tokenStart| 0) + (SPADLET |previousSpace| NIL) + (DO ((G167317 (SPADDIFFERENCE (|#| |str|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G167317) NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL (STRING (ELT |str| |i|)) + (MAKESTRING "\"")) + (SPADLET |inString| (NULL |inString|)) + (SPADLET |previousSpace| NIL)) + ((AND (BOOT-EQUAL (STRING (ELT |str| |i|)) + (MAKESTRING " ")) + (NULL |inString|)) + (COND + (|previousSpace| NIL) + ('T + (SPADLET |token| + (|stripSpaces| + (SUBSEQ |str| |tokenStart| + |i|))) + (SPADLET |tokenList| + (CONS |token| |tokenList|)) + (SPADLET |tokenStart| (PLUS |i| 1)) + (SPADLET |previousSpace| 'T)))) + ('T (SPADLET |previousSpace| NIL)))))) + (SPADLET |tokenList| + (CONS (|stripSpaces| (SUBSEQ |str| |tokenStart|)) + |tokenList|)) + (NREVERSE |tokenList|)))))) + +;handleParsedSystemCommands(unabr, optionList) == +; restOptionList := [dumbTokenize opt for opt in CDR optionList] +; parcmd := [parseSystemCmd CAR optionList, +; :[[tokTran tok for tok in opt] for opt in restOptionList]] +; systemCommand parcmd + +(DEFUN |handleParsedSystemCommands| (|unabr| |optionList|) + (PROG (|restOptionList| |parcmd|) + (RETURN + (SEQ (PROGN + (SPADLET |restOptionList| + (PROG (G167341) + (SPADLET G167341 NIL) + (RETURN + (DO ((G167346 (CDR |optionList|) + (CDR G167346)) + (|opt| NIL)) + ((OR (ATOM G167346) + (PROGN + (SETQ |opt| (CAR G167346)) + NIL)) + (NREVERSE0 G167341)) + (SEQ (EXIT (SETQ G167341 + (CONS (|dumbTokenize| |opt|) + G167341)))))))) + (SPADLET |parcmd| + (CONS (|parseSystemCmd| (CAR |optionList|)) + (PROG (G167356) + (SPADLET G167356 NIL) + (RETURN + (DO ((G167361 |restOptionList| + (CDR G167361)) + (|opt| NIL)) + ((OR (ATOM G167361) + (PROGN + (SETQ |opt| (CAR G167361)) + NIL)) + (NREVERSE0 G167356)) + (SEQ (EXIT + (SETQ G167356 + (CONS + (PROG (G167371) + (SPADLET G167371 NIL) + (RETURN + (DO + ((G167376 |opt| + (CDR G167376)) + (|tok| NIL)) + ((OR (ATOM G167376) + (PROGN + (SETQ |tok| + (CAR G167376)) + NIL)) + (NREVERSE0 G167371)) + (SEQ + (EXIT + (SETQ G167371 + (CONS + (|tokTran| |tok|) + G167371))))))) + G167356))))))))) + (|systemCommand| |parcmd|)))))) + +;parseSystemCmd opt == +; spaceIndex := SEARCH('" ", opt) +; spaceIndex => +; commandString := stripSpaces SUBSEQ(opt, 0, spaceIndex) +; argString := stripSpaces SUBSEQ(opt, spaceIndex) +; command := tokTran commandString +; pform := parseFromString argString +; [command, pform] +; [tokTran tok for tok in dumbTokenize opt] + +(DEFUN |parseSystemCmd| (|opt|) + (PROG (|spaceIndex| |commandString| |argString| |command| |pform|) + (RETURN + (SEQ (PROGN + (SPADLET |spaceIndex| (SEARCH (MAKESTRING " ") |opt|)) + (COND + (|spaceIndex| + (SPADLET |commandString| + (|stripSpaces| + (SUBSEQ |opt| 0 |spaceIndex|))) + (SPADLET |argString| + (|stripSpaces| (SUBSEQ |opt| |spaceIndex|))) + (SPADLET |command| (|tokTran| |commandString|)) + (SPADLET |pform| (|parseFromString| |argString|)) + (CONS |command| (CONS |pform| NIL))) + ('T + (PROG (G167396) + (SPADLET G167396 NIL) + (RETURN + (DO ((G167401 (|dumbTokenize| |opt|) + (CDR G167401)) + (|tok| NIL)) + ((OR (ATOM G167401) + (PROGN (SETQ |tok| (CAR G167401)) NIL)) + (NREVERSE0 G167396)) + (SEQ (EXIT (SETQ G167396 + (CONS (|tokTran| |tok|) + G167396)))))))))))))) + +;--------------------> NEW DEFINITION (override in osyscmd.boot.pamphlet) +;parseFromString(s) == +; $useNewParser => +; ncParseFromString s +; $InteractiveMode :local := true +; $BOOT: local := NIL +; $SPAD: local := true +; $e:local := $InteractiveFrame +; string2SpadTree s + +(DEFUN |parseFromString| (|s|) + (PROG (|$InteractiveMode| $BOOT $SPAD |$e|) + (DECLARE (SPECIAL |$InteractiveMode| $BOOT $SPAD |$e|)) + (RETURN + (COND + (|$useNewParser| (|ncParseFromString| |s|)) + ('T (SPADLET |$InteractiveMode| 'T) (SPADLET $BOOT NIL) + (SPADLET $SPAD 'T) (SPADLET |$e| |$InteractiveFrame|) + (|string2SpadTree| |s|)))))) + +;handleTokensizeSystemCommands(unabr, optionList) == +; optionList := [dumbTokenize opt for opt in optionList] +; parcmd := [[tokTran tok for tok in opt] for opt in optionList] +; parcmd => tokenSystemCommand(unabr, parcmd) + +(DEFUN |handleTokensizeSystemCommands| (|unabr| |optionList|) + (PROG (|parcmd|) + (RETURN + (SEQ (PROGN + (SPADLET |optionList| + (PROG (G167437) + (SPADLET G167437 NIL) + (RETURN + (DO ((G167442 |optionList| (CDR G167442)) + (|opt| NIL)) + ((OR (ATOM G167442) + (PROGN + (SETQ |opt| (CAR G167442)) + NIL)) + (NREVERSE0 G167437)) + (SEQ (EXIT (SETQ G167437 + (CONS (|dumbTokenize| |opt|) + G167437)))))))) + (SPADLET |parcmd| + (PROG (G167452) + (SPADLET G167452 NIL) + (RETURN + (DO ((G167457 |optionList| (CDR G167457)) + (|opt| NIL)) + ((OR (ATOM G167457) + (PROGN + (SETQ |opt| (CAR G167457)) + NIL)) + (NREVERSE0 G167452)) + (SEQ (EXIT (SETQ G167452 + (CONS + (PROG (G167467) + (SPADLET G167467 NIL) + (RETURN + (DO + ((G167472 |opt| + (CDR G167472)) + (|tok| NIL)) + ((OR (ATOM G167472) + (PROGN + (SETQ |tok| + (CAR G167472)) + NIL)) + (NREVERSE0 G167467)) + (SEQ + (EXIT + (SETQ G167467 + (CONS + (|tokTran| |tok|) + G167467))))))) + G167452)))))))) + (COND (|parcmd| (|tokenSystemCommand| |unabr| |parcmd|)))))))) + +;getFirstWord string == +; spaceIndex := SEARCH('" ", string) +; null spaceIndex => string +; stripSpaces SUBSEQ(string, 0, spaceIndex) + +(DEFUN |getFirstWord| (|string|) + (PROG (|spaceIndex|) + (RETURN + (PROGN + (SPADLET |spaceIndex| (SEARCH (MAKESTRING " ") |string|)) + (COND + ((NULL |spaceIndex|) |string|) + ('T (|stripSpaces| (SUBSEQ |string| 0 |spaceIndex|)))))))) + +;ltrace l == trace l + +(DEFUN |ltrace| (|l|) (|trace| |l|)) + +;--------------------> NEW DEFINITION (see intint.lisp.pamphlet) +;stripSpaces str == +; STRING_-TRIM([char '" "], str) + +(DEFUN |stripSpaces| (|str|) + (STRING-TRIM (CONS (|char| (MAKESTRING " ")) NIL) |str|)) + +;npProcessSynonym(str) == +; if str = '"" then printSynonyms(NIL) +; else +; pair := processSynonymLine str +; if $CommandSynonymAlist then +; PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) +; else $CommandSynonymAlist := [pair] +; terminateSystemCommand() + +(DEFUN |npProcessSynonym| (|str|) + (PROG (|pair|) + (RETURN + (PROGN + (COND + ((BOOT-EQUAL |str| (MAKESTRING "")) (|printSynonyms| NIL)) + ('T (SPADLET |pair| (|processSynonymLine| |str|)) + (COND + (|$CommandSynonymAlist| + (PUTALIST |$CommandSynonymAlist| (CAR |pair|) + (CDR |pair|))) + ('T (SPADLET |$CommandSynonymAlist| (CONS |pair| NIL)))))) + (|terminateSystemCommand|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} [[src/interp/setq.lisp.pamphlet]] +\end{thebibliography} +\end{document}