diff --git a/changelog b/changelog index 91bbee5..c11caa4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090816 tpd src/axiom-website/patches.html 20090816.05.tpd.patch +20090816 tpd src/interp/Makefile move format.boot to format.lisp +20090816 tpd src/interp/format.lisp added, rewritten from format.boot +20090816 tpd src/interp/format.boot removed, rewritten to format.lisp 20090815 tpd src/axiom-website/patches.html 20090815.05.tpd.patch 20090815 tpd src/interp/Makefile move database.boot to database.lisp 20090815 tpd src/interp/database.lisp added, rewritten from database.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 86a5d30..09828c8 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1796,6 +1796,8 @@ src/input/Makefile add shannonmatrix.regress
cstream.lisp rewrite from boot to lisp
20090815.05.tpd.patch database.lisp rewrite from boot to lisp
+20090815.06.tpd.patch +format.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 586093c..0c984af 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -422,7 +422,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/define.boot.dvi \ ${DOC}/fname.lisp.dvi \ ${DOC}/foam_l.lisp.dvi \ - ${DOC}/format.boot.dvi ${DOC}/fortcall.boot.dvi \ + ${DOC}/fortcall.boot.dvi \ ${DOC}/functor.boot.dvi ${DOC}/g-boot.boot.dvi \ ${DOC}/g-cndata.boot.dvi ${DOC}/g-error.boot.dvi \ ${DOC}/g-opt.boot.dvi \ @@ -2803,45 +2803,26 @@ ${DOC}/define.boot.dvi: ${IN}/define.boot.pamphlet @ -\subsection{format.boot} +\subsection{format.lisp} <>= -${OUT}/format.${O}: ${MID}/format.clisp - @ echo 249 making ${OUT}/format.${O} from ${MID}/format.clisp - @ (cd ${MID} ; \ +${OUT}/format.${O}: ${MID}/format.lisp + @ echo 136 making ${OUT}/format.${O} from ${MID}/format.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/format.clisp"' \ + echo '(progn (compile-file "${MID}/format.lisp"' \ ':output-file "${OUT}/format.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/format.clisp"' \ + echo '(progn (compile-file "${MID}/format.lisp"' \ ':output-file "${OUT}/format.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/format.clisp: ${IN}/format.boot.pamphlet - @ echo 250 making ${MID}/format.clisp from ${IN}/format.boot.pamphlet +<>= +${MID}/format.lisp: ${IN}/format.lisp.pamphlet + @ echo 137 making ${MID}/format.lisp from ${IN}/format.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/format.boot.pamphlet >format.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "format.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "format.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm format.boot ) - -@ -<>= -${DOC}/format.boot.dvi: ${IN}/format.boot.pamphlet - @echo 251 making ${DOC}/format.boot.dvi from ${IN}/format.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/format.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} format.boot ; \ - rm -f ${DOC}/format.boot.pamphlet ; \ - rm -f ${DOC}/format.boot.tex ; \ - rm -f ${DOC}/format.boot ) + ${TANGLE} ${IN}/format.lisp.pamphlet >format.lisp ) @ @@ -6754,8 +6735,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/format.boot.pamphlet b/src/interp/format.boot.pamphlet deleted file mode 100644 index d8fabbe..0000000 --- a/src/interp/format.boot.pamphlet +++ /dev/null @@ -1,839 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp format.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. - -@ -<<*>>= -<> - ---% Functions for display formatting system objects - --- some of these are redundant and should be compacted -$formatSigAsTeX := 1 - ---% Formatting modemaps - -sayModemap m == - -- sayMSG formatModemap displayTranModemap m - sayMSG formatModemap old2NewModemaps displayTranModemap m - -sayModemapWithNumber(m,n) == - msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ", - STRCONC(lbrkSch(),object2String n,rbrkSch()), - :formatModemap displayTranModemap m,"%u","%u"] - sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3) - -displayOpModemaps(op,modemaps) == - TERPRI() - count:= #modemaps - phrase:= (count=1 => 'modemap;'modemaps) - sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"] - for modemap in modemaps repeat sayModemap modemap - -displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) == - -- The next 8 lines are a HACK to deal with the "partial" definition - -- JHD/RSS - if pred is ['partial,:pred'] then - [b,:c]:=sig - sig:=[['Union,b,'"failed"],:c] - mm:=[[x,:sig],[pred',:y],:z] - else if pred = 'partial then - [b,:c]:=sig - sig:=[['Union,b,'"failed"],:c] - mm:=[[x,:sig],y,:z] - mm' := EQSUBSTLIST('(m n p q r s t i j k l), - MSORT listOfPredOfTypePatternIds pred,mm) - EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14), - MSORT listOfPatternIds [sig,[pred,:y]],mm') - -listOfPredOfTypePatternIds p == - p is ['AND,:lp] or p is ['OR,:lp] => - UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL) - p is [op,a,.] and op = 'ofType => - isPatternVar a => [a] - nil - nil - -removeIsDomains pred == - pred is ['isDomain,a,b] => true - pred is ['AND,:predl] => - MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND) - pred - -canRemoveIsDomain? pred == - -- returns nil OR an alist for substitutions of domains ordered so that - -- after substituting for each pair in turn, no left-hand names remain - alist := - pred is ['isDomain,a,b] => [[a,:b],:alist] - pred is ['AND,:predl] => - [[a,:b] for pred in predl | pred is ['isDomain,a,b]] - findSubstitutionOrder? alist - -findSubstitutionOrder? alist == fn(alist,nil) where - -- returns NIL or an appropriate substituion order - fn(alist,res) == - null alist => NREVERSE res - choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] => - fn(DELETE(choice,alist),[choice,:res]) - nil - -containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist] - -removeIsDomainD pred == - pred is ['isDomain,'D,D] => - [D,nil] - pred is ['AND,:preds] => - D := nil - for p in preds while not D repeat - p is ['isDomain,'D,D1] => - D := D1 - npreds := DELETE(['isDomain,'D,D1],preds) - D => - 1 = #npreds => [D,first npreds] - [D,['AND,:npreds]] - nil - nil - -formatModemap modemap == - [[dc,target,:sl],pred,:.]:= modemap - if alist := canRemoveIsDomain? pred then - dc:= substInOrder(alist,dc) - pred:= substInOrder(alist,removeIsDomains pred) - target:= substInOrder(alist,target) - sl:= substInOrder(alist,sl) - else if removeIsDomainD pred is [D,npred] then - pred := SUBST(D,'D,npred) - target := SUBST(D,'D,target) - sl := SUBST(D,'D,sl) - predPart:= formatIf pred - targetPart:= prefix2String target - argTypeList:= - null sl => nil - concat(prefix2String first sl,fn(rest sl)) where - fn l == - null l => nil - concat(",",prefix2String first l,fn rest l) - argPart:= - #sl<2 => argTypeList - ['"_(",:argTypeList,'"_)"] - fromPart:= - if dc = 'D and D - then concat('%b,'"from",'%d,prefix2String D) - else concat('%b,'"from",'%d,prefix2String dc) - firstPart:= concat('" ",argPart,'" -> ",targetPart) - sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]" - fromPart:= concat('" ",fromPart) - secondPart := - sayWidth fromPart + sayWidth predPart < 75 => - concat(fromPart,predPart) - concat(fromPart,'%l,predPart) - concat(firstPart,'%l,secondPart) - firstPart:= concat(firstPart,fromPart) - sayWidth firstPart + sayWidth predPart < 80 => - concat(firstPart,predPart) - concat(firstPart,'%l,predPart) - -substInOrder(alist,x) == - alist is [[a,:b],:y] => substInOrder(y,SUBST(b,a,x)) - x - -@ -\subsection{reportOpSymbol} -This function prints the modemaps for operations as a result of the -user command for some operation foo: -\begin{verbatim} - )d op foo -\end{verbatim} - -We have enhanced this function to search the documentation for each -domain and print any examples it finds by calling the sayExample -function. Because of the way the databases are currently organized -the documentation is under each domain and is kept separate from -the modemaps. Ideally we'd output the example immediately after -the related modemap but I have yet to figure out how to do that. - -We need to know the name of the function (which the user supplied) -and we need to know a list of all of the domains containing that -function. This is collected using PUSHNEW into the domain list. - -Once we've processed all of the modemaps we have a set of the -domain names. We walk across that set requesting the documentation -strings for that domain. There are a list of documentation strings, -one for each exported function. We call sayExample on each element -of the list. If sayExample finds an example it prints it. -<<*>>= -reportOpSymbol op1 == - op := (STRINGP op1 => INTERN op1; op1) - modemaps := getAllModemapsFromDatabase(op,nil) - null modemaps => - ok := true - sayKeyedMsg("S2IF0010",[op1]) - if SIZE PNAME op1 < 3 then - x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1]) - null MEMQ(STRING2ID_-N(x,1),'(Y YES)) => - ok := nil - sayKeyedMsg("S2IZ0061",[op1]) - ok => apropos [op1] - sayNewLine() - -- filter modemaps on whether they are exposed - mmsE := mmsU := NIL - domlist := NIL - for mm in modemaps repeat - dom := getDomainFromMm(mm) - PUSHNEW(dom,domlist) - isFreeFunctionFromMm(mm) or isExposedConstructor dom => - mmsE := [mm,:mmsE] - mmsU := [mm,:mmsU] - if mmsE then - sayMms(op,mmsE,'"exposed") where - sayMms(op,mms,label) == - m := # mms - sayMSG - m = 1 => - ['"There is one",:bright label,'"function called", - :bright op,'":"] - ['"There are ",m,:bright label,'"functions called", - :bright op,'":"] - for mm in mms for i in 1.. repeat - sayModemapWithNumber(mm,i) - if mmsU then - if mmsE then sayNewLine() - sayMms(op,mmsU,'"unexposed") - for adom in domlist repeat - doc := GETDATABASE(adom,'DOCUMENTATION) - docs := CDR(ASSOC(op,doc)) - sayNewLine() - sayBrightly ['"Examples of ",op," from ",adom] - sayNewLine() - for export in docs repeat - SAYEXAMPLE(CADR(export)) - nil - -formatOpType (form:=[op,:argl]) == - null argl => unabbrev op - form2String [unabbrev op, :argl] - -formatOperationAlistEntry (entry:= [op,:modemaps]) == - -- alist has entries of the form: ((op sig) . pred) - -- opsig on this list => op is defined only when the predicate is true - ans:= nil - for [sig,.,:predtail] in modemaps repeat - pred := (predtail is [p,:.] => p; 'T) - -- operation is always defined - ans := - [concat(formatOpSignature(op,sig),formatIf pred),:ans] - ans - -formatOperation([[op,sig],.,[fn,.,n]],domain) == - opSigString := formatOpSignature(op,sig) - INTEGERP n and Undef = KAR domain.n => - if INTEGERP $commentedOps then $commentedOps := $commentedOps + 1 - concat(" --",opSigString) - opSigString - -formatOpSignature(op,sig) == - concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig) - -formatOpConstant op == - concat('%b,formatOpSymbol(op,'($)),'%d,'": constant") - -formatOpSymbol(op,sig) == - if op = 'Zero then op := "0" - else if op = 'One then op := "1" - null sig => op - quad := specialChar 'quad - n := #sig - (op = 'elt) and (n = 3) => - (CADR(sig) = '_$) => - STRINGP (sel := CADDR(sig)) => - [quad,".",sel] - [quad,".",quad] - op - STRINGP op or GET(op,"Led") or GET(op,"Nud") => - n = 3 => - if op = 'SEGMENT then op := '".." - op = 'in => [quad,'" ",op,'" ",quad] --- stop exquo from being displayed as infix (since it is not accepted --- as such by the interpreter) - op = 'exquo => op - [quad,op,quad] - n = 2 => - not GET(op,"Nud") => [quad,op] - [op,quad] - op - op - -formatAttribute x == - atom x => [" ",x] - x is [op,:argl] => - for x in argl repeat - argPart:= NCONC(argPart,concat(",",formatAttributeArg x)) - argPart => concat(" ",op,"_(",rest argPart,"_)") - [" ",op] - -formatAttributeArg x == - STRINGP x and x ='"*" => "_"*_"" - atom x => formatOpSymbol (x,nil) - x is [":",op,["Mapping",:sig]] => - concat('%b,formatOpSymbol(op,sig),": ",'%d,formatMapping sig) - prefix2String0 x - -formatMapping sig == - "STRCONC"/concat("Mapping(",formatSignature sig,")") - -dollarPercentTran x == - -- Translate $ to %. We actually return %% so that the message - -- printer will display a single % - x is [y,:z] => - y1 := dollarPercentTran y - z1 := dollarPercentTran z - EQ(y, y1) and EQ(z, z1) => x - [y1, :z1] - x = "$" or x = '"$" => "%%" - x - -formatSignatureAsTeX sig == - $formatSigAsTeX: local := 2 - formatSignature0 sig - -formatSignature sig == - $formatSigAsTeX: local := 1 - formatSignature0 sig - -formatSignatureArgs sml == - $formatSigAsTeX: local := 1 - formatSignatureArgs0 sml - -formatSignature0 sig == - null sig => "() -> ()" - INTEGERP sig => '"hashcode" - [tm,:sml] := sig - sourcePart:= formatSignatureArgs0 sml - targetPart:= prefix2String0 tm - dollarPercentTran concat(sourcePart,concat(" -> ",targetPart)) - -formatSignatureArgs0(sml) == --- formats the arguments of a signature - null sml => ["_(_)"] - null rest sml => prefix2String0 first sml - argList:= prefix2String0 first sml - for m in rest sml repeat - argList:= concat(argList,concat(",",prefix2String0 m)) - concat("_(",concat(argList,"_)")) - ---% Conversions to string form - -expr2String x == - atom (u:= prefix2String0 x) => u - "STRCONC"/[atom2String y for y in u] - --- exports (this is a badly named bit of sillyness) -prefix2StringAsTeX form == - form2StringAsTeX form - -prefix2String form == - form2String form - --- local version -prefix2String0 form == - form2StringLocal form - --- SUBRP form => formWrapId BPINAME form --- atom form => --- form=$EmptyMode or form=$quadSymbol => formWrapId specialChar 'quad --- STRINGP form => formWrapId form --- IDENTP form => --- constructor? form => app2StringWrap(formWrapId form, [form]) --- formWrapId form --- formWrapId STRINGIMAGE form - -form2StringWithWhere u == - $permitWhere : local := true - $whereList: local := nil - s:= form2String u - $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u") - s - -form2StringWithPrens form == - null (argl := rest form) => [first form] - null rest argl => [first form,"(",first argl,")"] - form2String form - -formString u == - x := form2String u - atom x => STRINGIMAGE x - "STRCONC"/[STRINGIMAGE y for y in x] - -form2String u == - $formatSigAsTeX: local := 1 - form2StringLocal u - -form2StringAsTeX u == - $formatSigAsTeX: local := 2 - form2StringLocal u - -form2StringLocal u == ---+ - $NRTmonitorIfTrue : local := nil - $fortInts2Floats : local := nil - form2String1 u - -constructorName con == - $abbreviateTypes => abbreviate con - con - -form2String1 u == - ATOM u => - u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad - IDENTP u => - constructor? u => app2StringWrap(formWrapId u, [u]) - u - SUBRP u => formWrapId BPINAME u - STRINGP u => formWrapId u - WRITE_-TO_-STRING formWrapId u - u1 := u - op := CAR u - argl := CDR u - op='Join or op= 'mkCategory => formJoin1(op,argl) - $InteractiveMode and (u:= constructor? op) => - null argl => app2StringWrap(formWrapId constructorName op, u1) - op = "NTuple" => [ form2String1 first argl, "*"] - op = "Map" => ["(",:formatSignature0 [argl.1,argl.0],")"] - op = 'Record => record2String(argl) - null (conSig := getConstructorSignature op) => - application2String(constructorName op,[form2String1(a) for a in argl], u1) - ml := rest conSig - if not freeOfSharpVars ml then - ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList - for val in argl], ml) - argl:= formArguments2String(argl,ml) - -- extra null check to handle mutable domain hack. - null argl => constructorName op - application2String(constructorName op,argl, u1) - op = "Mapping" => ["(",:formatSignature argl,")"] - op = "Record" => record2String(argl) - op = 'Union => - application2String(op,[form2String1 x for x in argl], u1) - op = ":" => - null argl => [ '":" ] - null rest argl => [ '":", form2String1 first argl ] - formDecl2String(argl.0,argl.1) - op = "#" and PAIRP argl and LISTP CAR argl => - STRINGIMAGE SIZE CAR argl - op = 'Join => formJoin2String argl - op = "ATTRIBUTE" => form2String1 first argl - op='Zero => 0 - op='One => 1 - op = 'AGGLST => tuple2String argl - op = 'BRACKET => - argl' := form2String1 first argl - ["[",:(atom argl' => [argl']; argl'),"]"] - op = "SIGNATURE" => - [operation,sig] := argl - concat(operation,": ",formatSignature sig) - op = 'COLLECT => formCollect2String argl - op = 'construct => - concat(lbrkSch(), - tuple2String [form2String1 x for x in argl],rbrkSch()) - op = "SEGMENT" => - null argl => '".." - lo := form2String1 first argl - argl := rest argl - (null argl) or null (first argl) => [lo, '".."] - [lo, '"..", form2String1 first argl] - isBinaryInfix op => fortexp0 [op,:argl] - -- COMPILED_-FUNCTION_-P(op) => form2String1 coerceMap2E(u1,NIL) - application2String(op,[form2String1 x for x in argl], u1) - -formWrapId id == - $formatSigAsTeX = 1 => id - $formatSigAsTeX = 2 => - sep := '"`" - FORMAT(NIL,'"\verb~a~a~a",sep, id, sep) - error "Bad formatSigValue" - -formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where - fn(x,m) == - x=$EmptyMode or x=$quadSymbol => specialChar 'quad - STRINGP(x) or IDENTP(x) => x - x is [ ='_:,:.] => form2String1 x - isValidType(m) and PAIRP(m) and - (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => - (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => - form2String1 objValUnwrap x' - form2String1 x - form2String1 x - -formDecl2String(left,right) == - $declVar: local := left - whereBefore := $whereList - ls:= form2StringLocal left - rs:= form2StringLocal right - NE($whereList,whereBefore) and $permitWhere => ls - concat(form2StringLocal ls,'": ",rs) - -formJoin1(op,u) == - if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u]) - last is [id,.,:r] and id in '(mkCategory CATEGORY) => - $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...") - $permitWhere = true => - opList:= formatJoinKey(r,id) - $whereList:= concat($whereList,"%l",$declVar,": ", - formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u") - formJoin2 argl - opList:= formatJoinKey(r,id) - suffix := concat('%b,'"with",'%d,"%i",opList,"%u") - concat(formJoin2 argl,suffix) - formJoin2 u - -formatJoinKey(r,key) == - key = 'mkCategory => - r is [opPart,catPart,:.] => - opString := - opPart is [='LIST,:u] => - "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred) - for [='QUOTE,[[op,sig],pred]] in u] - nil - catString := - catPart is [='LIST,:u] => - "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred) - for [='QUOTE,[con,pred]] in u] - nil - concat(opString,catString) - '"?? unknown mkCategory format ??" - -- otherwise we have the CATEGORY form - "append"/[fn for x in r] where fn == - x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig)) - x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a) - x - -formJoin2 argl == --- argl is a list of categories NOT containing a "with" - null argl => '"" - 1=#argl => form2StringLocal argl.0 - application2String('Join,[form2StringLocal x for x in argl], NIL) - -formJoin2String (u:=[:argl,last]) == - last is ["CATEGORY",.,:atsigList] => - postString:= concat("_(",formTuple2String atsigList,"_)") - #argl=1 => concat(first argl,'" with ",postString) - concat(application2String('Join,argl, NIL)," with ",postString) - application2String('Join,u, NIL) - -formCollect2String [:itl,body] == - ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"] - -formIterator2String x == - x is ["STEP",y,s,.,:l] => - tail:= (l is [f] => form2StringLocal f; nil) - concat("for ",y," in ",s,'"..",tail) - x is ["tails",y] => concat("tails ",formatIterator y) - x is ["reverse",y] => concat("reverse ",formatIterator y) - x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p) - x is ["until",p] => concat("until ",form2StringLocal p) - x is ["while",p] => concat("while ",form2StringLocal p) - systemErrorHere "formatIterator" - -tuple2String argl == - null argl => nil - string := first argl - if string in '("failed" "nil" "prime" "sqfr" "irred") - then string := STRCONC('"_"",string,'"_"") - else string := - ATOM string => object2String string - [f x for x in string] where - f x == - ATOM x => object2String x - -- [f CAR x,:f CDR x] - [f y for y in x] - for x in rest argl repeat - if x in '("failed" "nil" "prime" "sqfr" "irred") then - x := STRCONC('"_"",x,'"_"") - string:= concat(string,concat(",",f x)) - string - -script2String s == - null s => '"" -- just to be safe - if not PAIRP s then s := [s] - linearFormatForm(CAR s, CDR s) - -linearFormatName x == - atom x => x - linearFormat x - -linearFormat x == - atom x => x - x is [op,:argl] and atom op => - argPart:= - argl is [a,:l] => [a,:"append"/[[",",x] for x in l]] - nil - [op,"(",:argPart,")"] - [linearFormat y for y in x] - -numOfSpadArguments id == - char("*") = (s:= PNAME id).0 => - +/[n for i in 1.. while INTEGERP (n:=PARSE_-INTEGER PNAME s.i)] - keyedSystemError("S2IF0012",[id]) - -linearFormatForm(op,argl) == - s:= PNAME op - indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while - (DIGITP (d:= s.(maxIndex:= i)))] - cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s]) - fnArgs:= - indexList.0 > 0 => - concat('"(",formatArgList take(-indexList.0,argl),'")") - nil - if #indexList > 1 then - scriptArgs:= formatArgList take(indexList.1,argl) - argl := drop(indexList.1,argl) - for i in rest rest indexList repeat - subArglist:= take(i,argl) - argl:= drop(i,argl) - scriptArgs:= concat(scriptArgs,";",formatArgList subArglist) - scriptArgs:= - scriptArgs => concat(specialChar 'lbrk,scriptArgs, specialChar 'rbrk) - nil - l := [(STRINGP f => f; STRINGIMAGE f) for f in - concat(cleanOp,scriptArgs,fnArgs)] - "STRCONC"/l - -formatArgList l == - null l => nil - acc:= linearFormat first l - for x in rest l repeat - acc:= concat(acc,",",linearFormat x) - acc - -formTuple2String argl == - null argl => nil - string:= form2StringLocal first argl - for x in rest argl repeat - string:= concat(string,concat(",",form2StringLocal x)) - string - -isInternalFunctionName(op) == - (not IDENTP(op)) or (op = "*") or (op = "**") => NIL - (1 = SIZE(op':= PNAME op)) or (char("*") ^= op'.0) => NIL - -- if there is a semicolon in the name then it is the name of - -- a compiled spad function - null (e := STRPOS('"_;",op',1,NIL)) => NIL - (char(" ") = (y := op'.1)) or (char("*") = y) => NIL - table := MAKETRTTABLE('"0123456789",NIL) - s := STRPOSL(table,op',1,true) - null(s) or s > e => NIL - SUBSTRING(op',s,e-s) - -application2String(op,argl, linkInfo) == - null argl => - (op' := isInternalFunctionName(op)) => op' - app2StringWrap(formWrapId op, linkInfo) - 1=#argl => - first argl is ["<",:.] => concat(op,first argl) - concat(app2StringWrap(formWrapId op, linkInfo)," ",first argl) ---op in '(UP SM) => --- newop:= (op = "UP" => "P";"M") --- concat(newop,concat(lbrkSch(),argl.0,rbrkSch(),argl.1)) ---op='RM =>concat("M",concat(lbrkSch(), --- argl.0,",",argl.1,rbrkSch(),argl.2)) ---op='MP =>concat("P",concat(argl.0,argl.1)) - op='SEGMENT => - null argl => '".." - (null rest argl) or (null first rest argl) => - concat(first argl, '"..") - concat(first argl, concat('"..", first rest argl)) - concat(app2StringWrap(formWrapId op, linkInfo) , - concat("_(",concat(tuple2String argl,"_)"))) - -app2StringConcat0(x,y) == - FORMAT(NIL, '"~a ~a", x, y) - -app2StringWrap(string, linkInfo) == - not linkInfo => string - $formatSigAsTeX = 1 => string - $formatSigAsTeX = 2 => - str2 := "app2StringConcat0"/form2Fence linkInfo - sep := '"`" - FORMAT(NIL, '"\lispLink{\verb!(|conPage| '~a)!}{~a}", - str2, string) - error "Bad value for $formatSigAsTeX" - -record2String x == - argPart := NIL - for [":",a,b] in x repeat argPart:= - concat(argPart,",",a,": ",form2StringLocal b) - null argPart => '"Record()" - concat("Record_(",rest argPart,"_)") - -plural(n,string) == - suffix:= - n = 1 => '"" - '"s" - [:bright n,string,suffix] - -formatIf pred == - not pred => nil - pred in '(T (QUOTE T)) => nil - concat('%b,'"if",'%d,pred2English pred) - -formatPredParts s == - s is ['QUOTE,s1] => formatPredParts s1 - s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1] - s is ['devaluate,s1] => formatPredParts s1 - s is ['getDomainView,s1,.] => formatPredParts s1 - s is ['SUBST,a,b,c] => -- this is a signature - s1 := formatPredParts SUBST(formatPredParts a,b,c) - s1 isnt [fun,sig] => s1 - ['SIGNATURE,fun,[formatPredParts(r) for r in sig]] - s - -pred2English x == - x is ['IF,cond,thenClause,elseClause] => - c := concat('"if ",pred2English cond) - t := concat('" then ",pred2English thenClause) - e := concat('" else ",pred2English elseClause) - concat(c,t,e) - x is ['AND,:l] => - tail:="append"/[concat(bright '"and",pred2English x) for x in rest l] - concat(pred2English first l,tail) - x is ['OR,:l] => - tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l] - concat(pred2English first l,tail) - x is ['NOT,l] => - concat('"not ",pred2English l) - x is [op,a,b] and op in '(has ofCategory) => - concat(pred2English a,'%b,'"has",'%d,form2String abbreviate b) - x is [op,a,b] and op in '(HasSignature HasAttribute HasCategory) => - concat(prefix2String0 formatPredParts a,'%b,'"has",'%d, - prefix2String0 formatPredParts b) - x is [op,a,b] and op in '(ofType getDomainView) => - if b is ['QUOTE,b'] then b := b' - concat(pred2English a,'": ",form2String abbreviate b) - x is [op,a,b] and op in '(isDomain domainEqual) => - concat(pred2English a,'" = ",form2String abbreviate b) - x is [op,:.] and (translation := LASSOC(op,'( - (_< . " < ") (_<_= . " <= ") - (_> . " > ") (_>_= . " >= ") (_= . " = ") (_^_= . " _^_= ")))) => - concat(pred2English a,translation,pred2English b) - x is ['ATTRIBUTE,form] => - concat("attribute: ",form2String form) - form2String x - -object2String x == - STRINGP x => x - IDENTP x => PNAME x - NULL x => '"" - PAIRP x => STRCONC(object2String first x, object2String rest x) - WRITE_-TO_-STRING x - -object2Identifier x == - IDENTP x => x - STRINGP x => INTERN x - INTERN WRITE_-TO_-STRING x - -blankList x == "append"/[[BLANK,y] for y in x] ---------------------> NEW DEFINITION (see cformat.boot.pamphlet) -pkey keyStuff == - if not PAIRP keyStuff then keyStuff := [keyStuff] - allMsgs := ['" "] - while not null keyStuff repeat - dbN := NIL - argL := NIL - key := first keyStuff - keyStuff := IFCDR keyStuff - next := IFCAR keyStuff - while PAIRP next repeat - if CAR next = 'dbN then dbN := CADR next - else argL := next - keyStuff := IFCDR keyStuff - next := IFCAR keyStuff - oneMsg := returnStLFromKey(key,argL,dbN) - allMsgs := ['" ", :NCONC (oneMsg,allMsgs)] - allMsgs - -string2Float s == - -- takes a string, calls the parser on it and returns a float object - p := ncParseFromString s - p isnt [["$elt", FloatDomain, "float"], x, y, z] => - systemError '"string2Float: did not get a float expression" - flt := getFunctionFromDomain("float", FloatDomain, - [$Integer, $Integer, $PositiveInteger]) - SPADCALL(x, y, z, flt) - - - -form2Fence form == - -- body of dbMkEvalable - [op, :.] := form - kind := GETDATABASE(op,'CONSTRUCTORKIND) - kind = 'category => form2Fence1 form - form2Fence1 mkEvalable form - -form2Fence1 x == - x is [op,:argl] => - op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"] - ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"] - IDENTP x => FORMAT(NIL, '"|~a|", x) --- [x] - ['" ", x] - -form2FenceQuote x == - NUMBERP x => [STRINGIMAGE x] - SYMBOLP x => [FORMAT(NIL, '"|~a|", x)] - atom x => '"??" - ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x] - -form2FenceQuoteTail x == - null x => ['")"] - atom x => ['" . ",:form2FenceQuote x,'")"] - ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x] - -form2StringList u == - atom (r := form2String u) => [r] - r -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/format.lisp.pamphlet b/src/interp/format.lisp.pamphlet new file mode 100644 index 0000000..9cba58f --- /dev/null +++ b/src/interp/format.lisp.pamphlet @@ -0,0 +1,2928 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp format.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;--% Functions for display formatting system objects +;-- some of these are redundant and should be compacted +;$formatSigAsTeX := 1 + +(SPADLET |$formatSigAsTeX| 1) + +;--% Formatting modemaps +;sayModemap m == +; -- sayMSG formatModemap displayTranModemap m +; sayMSG formatModemap old2NewModemaps displayTranModemap m + +(DEFUN |sayModemap| (|m|) + (|sayMSG| (|formatModemap| (|old2NewModemaps| (|displayTranModemap| |m|))))) + +;sayModemapWithNumber(m,n) == +; msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ", +; STRCONC(lbrkSch(),object2String n,rbrkSch()), +; :formatModemap displayTranModemap m,"%u","%u"] +; sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3) + +(DEFUN |sayModemapWithNumber| (|m| |n|) + (PROG (|msg|) + (RETURN + (PROGN + (SPADLET |msg| + (REVERSE + (|cleanUpSegmentedMsg| + (REVERSE + (CONS + (QUOTE |%i|) + (CONS + (QUOTE |%i|) + (CONS + " " + (CONS + (STRCONC (|lbrkSch|) (|object2String| |n|) (|rbrkSch|)) + (APPEND + (|formatModemap| (|displayTranModemap| |m|)) + (CONS (QUOTE |%u|) (CONS (QUOTE |%u|) NIL))))))))))) + (|sayMSG| (|flowSegmentedMsg| (REVERSE |msg|) $LINELENGTH 3)))))) + +;displayOpModemaps(op,modemaps) == +; TERPRI() +; count:= #modemaps +; phrase:= (count=1 => 'modemap;'modemaps) +; sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"] +; for modemap in modemaps repeat sayModemap modemap + +(DEFUN |displayOpModemaps| (|op| |modemaps|) + (PROG (|count| |phrase|) + (RETURN + (SEQ + (PROGN + (TERPRI) + (SPADLET |count| (|#| |modemaps|)) + (SPADLET |phrase| + (COND + ((EQL |count| 1) (QUOTE |modemap|)) + ((QUOTE T) (QUOTE |modemaps|)))) + (|sayMSG| + (CONS + (QUOTE |%b|) + (CONS + |count| + (CONS + (QUOTE |%d|) + (CONS + |phrase| + (CONS + " for" + (CONS + (QUOTE |%b|) + (CONS + |op| + (CONS (QUOTE |%d|) (CONS (MAKESTRING ":") NIL)))))))))) + (DO ((#0=#:G166070 |modemaps| (CDR #0#)) (|modemap| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |modemap| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|sayModemap| |modemap|))))))))) + +;displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) == +; -- The next 8 lines are a HACK to deal with the "partial" definition +; -- JHD/RSS +; if pred is ['partial,:pred'] then +; [b,:c]:=sig +; sig:=[['Union,b,'"failed"],:c] +; mm:=[[x,:sig],[pred',:y],:z] +; else if pred = 'partial then +; [b,:c]:=sig +; sig:=[['Union,b,'"failed"],:c] +; mm:=[[x,:sig],y,:z] +; mm' := EQSUBSTLIST('(m n p q r s t i j k l), +; MSORT listOfPredOfTypePatternIds pred,mm) +; EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14), +; MSORT listOfPatternIds [sig,[pred,:y]],mm') + +(DEFUN |displayTranModemap| (|mm|) + (PROG (|x| |pred| |y| |z| |pred'| |b| |c| |sig| |mm'|) + (RETURN + (PROGN + (SPADLET |x| (CAAR |mm|)) + (SPADLET |sig| (CDAR |mm|)) + (SPADLET |pred| (CAADR |mm|)) + (SPADLET |y| (CDADR |mm|)) + (SPADLET |z| (CDDR |mm|)) + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |partial|)) + (PROGN (SPADLET |pred'| (QCDR |pred|)) (QUOTE T))) + (SPADLET |b| (CAR |sig|)) + (SPADLET |c| (CDR |sig|)) + (SPADLET |sig| + (CONS + (CONS (QUOTE |Union|) (CONS |b| (CONS (MAKESTRING "failed") NIL))) + |c|)) + (SPADLET |mm| (CONS (CONS |x| |sig|) (CONS (CONS |pred'| |y|) |z|)))) + ((BOOT-EQUAL |pred| (QUOTE |partial|)) + (SPADLET |b| (CAR |sig|)) + (SPADLET |c| (CDR |sig|)) + (SPADLET |sig| + (CONS + (CONS (QUOTE |Union|) (CONS |b| (CONS (MAKESTRING "failed") NIL))) + |c|)) + (SPADLET |mm| (CONS (CONS |x| |sig|) (CONS |y| |z|)))) + ((QUOTE T) NIL)) + (SPADLET |mm'| + (EQSUBSTLIST + (QUOTE (|m| |n| |p| |q| |r| |s| |t| |i| |j| |k| |l|)) + (MSORT (|listOfPredOfTypePatternIds| |pred|)) + |mm|)) + (EQSUBSTLIST + (QUOTE (D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14)) + (MSORT (|listOfPatternIds| (CONS |sig| (CONS (CONS |pred| |y|) NIL)))) + |mm'|))))) + +;listOfPredOfTypePatternIds p == +; p is ['AND,:lp] or p is ['OR,:lp] => +; UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL) +; p is [op,a,.] and op = 'ofType => +; isPatternVar a => [a] +; nil +; nil + +(DEFUN |listOfPredOfTypePatternIds| (|p|) + (PROG (|lp| |op| |ISTMP#1| |a| |ISTMP#2|) + (RETURN + (SEQ + (COND + ((OR + (AND (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE AND)) + (PROGN (SPADLET |lp| (QCDR |p|)) (QUOTE T))) + (AND (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE OR)) + (PROGN (SPADLET |lp| (QCDR |p|)) (QUOTE T)))) + (UNIONQ + (PROG (#0=#:G166148) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166153 |lp| (CDR #1#)) (|p1| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |p1| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# (APPEND #0# (|listOfPredOfTypePatternIds| |p1|)))))))) + NIL)) + ((AND (PAIRP |p|) + (PROGN + (SPADLET |op| (QCAR |p|)) + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))) + (BOOT-EQUAL |op| (QUOTE |ofType|))) + (COND + ((|isPatternVar| |a|) (CONS |a| NIL)) + ((QUOTE T) NIL))) + ((QUOTE T) NIL)))))) + +;removeIsDomains pred == +; pred is ['isDomain,a,b] => true +; pred is ['AND,:predl] => +; MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND) +; pred + +(DEFUN |removeIsDomains| (|pred|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |predl|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (QUOTE T)) + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE AND)) + (PROGN (SPADLET |predl| (QCDR |pred|)) (QUOTE T))) + (MKPF + (PROG (#0=#:G166191) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166197 |predl| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((NULL (AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |isDomain|)))) + (SETQ #0# (CONS |x| #0#))))))))) + (QUOTE AND))) + ((QUOTE T) |pred|)))))) + +;canRemoveIsDomain? pred == +; -- returns nil OR an alist for substitutions of domains ordered so that +; -- after substituting for each pair in turn, no left-hand names remain +; alist := +; pred is ['isDomain,a,b] => [[a,:b],:alist] +; pred is ['AND,:predl] => +; [[a,:b] for pred in predl | pred is ['isDomain,a,b]] +; findSubstitutionOrder? alist + +(DEFUN |canRemoveIsDomain?| (|pred|) + (PROG (|predl| |ISTMP#1| |a| |ISTMP#2| |b| |alist|) + (RETURN + (SEQ + (PROGN + (SPADLET |alist| + (COND + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) (QUOTE |isDomain|)) (PROGN (SPADLET |ISTMP#1| (QCDR |pred|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (CONS (CONS |a| |b|) |alist|)) + ((AND (PAIRP |pred|) (EQ (QCAR |pred|) (QUOTE AND)) (PROGN (SPADLET |predl| (QCDR |pred|)) (QUOTE T))) + (PROG (#0=#:G166251) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166257 |predl| (CDR #1#)) (|pred| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |pred| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (SETQ #0# (CONS (CONS |a| |b|) #0#)))))))))))) + (|findSubstitutionOrder?| |alist|)))))) + +;findSubstitutionOrder? alist == fn(alist,nil) where +; -- returns NIL or an appropriate substituion order +; fn(alist,res) == +; null alist => NREVERSE res +; choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] => +; fn(DELETE(choice,alist),[choice,:res]) +; nil + +(DEFUN |findSubstitutionOrder?,fn| (|alist| |res|) + (PROG (|a| |b| |choice|) + (RETURN + (SEQ + (IF (NULL |alist|) (EXIT (NREVERSE |res|))) + (IF + (SPADLET |choice| + (PROG (#0=#:G166281) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166289 NIL #0#) (#2=#:G166290 |alist| (CDR #2#)) (|x| NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ |x| (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR |x|)) + (SPADLET |b| (CDR |x|)) + |x|) + NIL)) + #0#) + (SEQ + (EXIT + (COND + ((NULL (|containedRight| |a| |alist|)) + (SETQ #0# (OR #0# |x|)))))))))) + (EXIT + (|findSubstitutionOrder?,fn| + (|delete| |choice| |alist|) + (CONS |choice| |res|)))) + (EXIT NIL))))) + +(DEFUN |findSubstitutionOrder?| (|alist|) + (|findSubstitutionOrder?,fn| |alist| NIL)) + +;containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist] + +(DEFUN |containedRight| (|x| |alist|) + (PROG (|y|) + (RETURN + (SEQ + (PROG (#0=#:G166312) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166319 NIL #0#) + (#2=#:G166320 |alist| (CDR #2#)) + (#3=#:G166309 NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ #3# (CAR #2#)) NIL) + (PROGN (PROGN (SPADLET |y| (CDR #3#)) #3#) NIL)) + #0#) + (SEQ (EXIT (SETQ #0# (OR #0# (CONTAINED |x| |y|)))))))))))) + +;removeIsDomainD pred == +; pred is ['isDomain,'D,D] => +; [D,nil] +; pred is ['AND,:preds] => +; D := nil +; for p in preds while not D repeat +; p is ['isDomain,'D,D1] => +; D := D1 +; npreds := DELETE(['isDomain,'D,D1],preds) +; D => +; 1 = #npreds => [D,first npreds] +; [D,['AND,:npreds]] +; nil +; nil + +(DEFUN |removeIsDomainD| (|pred|) + (PROG (|preds| |ISTMP#1| |ISTMP#2| D1 D |npreds|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE D)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#2|)) (QUOTE T))))))) + (CONS D (CONS NIL NIL))) + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE AND)) + (PROGN (SPADLET |preds| (QCDR |pred|)) (QUOTE T))) + (SPADLET D NIL) + (SEQ + (DO ((#0=#:G166369 |preds| (CDR #0#)) (|p| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |p| (CAR #0#)) NIL) (NULL (NULL D))) + NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE D)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET D1 (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (EXIT + (PROGN + (SPADLET D D1) + (SPADLET |npreds| + (|delete| + (CONS (QUOTE |isDomain|) (CONS (QUOTE D) (CONS D1 NIL))) + |preds|))))))))) + (COND + (D + (EXIT + (COND + ((EQL 1 (|#| |npreds|)) (CONS D (CONS (CAR |npreds|) NIL))) + ((QUOTE T) (CONS D (CONS (CONS (QUOTE AND) |npreds|) NIL))))))) + NIL)) + ((QUOTE T) NIL)))))) + +;formatModemap modemap == +; [[dc,target,:sl],pred,:.]:= modemap +; if alist := canRemoveIsDomain? pred then +; dc:= substInOrder(alist,dc) +; pred:= substInOrder(alist,removeIsDomains pred) +; target:= substInOrder(alist,target) +; sl:= substInOrder(alist,sl) +; else if removeIsDomainD pred is [D,npred] then +; pred := SUBST(D,'D,npred) +; target := SUBST(D,'D,target) +; sl := SUBST(D,'D,sl) +; predPart:= formatIf pred +; targetPart:= prefix2String target +; argTypeList:= +; null sl => nil +; concat(prefix2String first sl,fn(rest sl)) where +; fn l == +; null l => nil +; concat(",",prefix2String first l,fn rest l) +; argPart:= +; #sl<2 => argTypeList +; ['"_(",:argTypeList,'"_)"] +; fromPart:= +; if dc = 'D and D +; then concat('%b,'"from",'%d,prefix2String D) +; else concat('%b,'"from",'%d,prefix2String dc) +; firstPart:= concat('" ",argPart,'" -> ",targetPart) +; sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]" +; fromPart:= concat('" ",fromPart) +; secondPart := +; sayWidth fromPart + sayWidth predPart < 75 => +; concat(fromPart,predPart) +; concat(fromPart,'%l,predPart) +; concat(firstPart,'%l,secondPart) +; firstPart:= concat(firstPart,fromPart) +; sayWidth firstPart + sayWidth predPart < 80 => +; concat(firstPart,predPart) +; concat(firstPart,'%l,predPart) + +(DEFUN |formatModemap,fn| (|l|) + (SEQ + (IF (NULL |l|) (EXIT NIL)) + (EXIT + (|concat| + (QUOTE |,|) + (|prefix2String| (CAR |l|)) + (|formatModemap,fn| (CDR |l|)))))) + +(DEFUN |formatModemap| (|modemap|) + (PROG (|alist| |dc| |ISTMP#1| D |ISTMP#2| |npred| |pred| |target| |sl| + |predPart| |targetPart| |argTypeList| |argPart| |fromPart| + |secondPart| |firstPart|) + (RETURN + (PROGN + (SPADLET |dc| (CAAR |modemap|)) + (SPADLET |target| (CADAR |modemap|)) + (SPADLET |sl| (CDDAR |modemap|)) + (SPADLET |pred| (CADR |modemap|)) + (COND + ((SPADLET |alist| (|canRemoveIsDomain?| |pred|)) + (SPADLET |dc| (|substInOrder| |alist| |dc|)) + (SPADLET |pred| (|substInOrder| |alist| (|removeIsDomains| |pred|))) + (SPADLET |target| (|substInOrder| |alist| |target|)) + (SPADLET |sl| (|substInOrder| |alist| |sl|))) + ((PROGN + (SPADLET |ISTMP#1| (|removeIsDomainD| |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET D (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |npred| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (SPADLET |pred| (MSUBST D (QUOTE D) |npred|)) + (SPADLET |target| (MSUBST D (QUOTE D) |target|)) + (SPADLET |sl| (MSUBST D (QUOTE D) |sl|))) + ((QUOTE T) NIL)) + (SPADLET |predPart| (|formatIf| |pred|)) + (SPADLET |targetPart| (|prefix2String| |target|)) + (SPADLET |argTypeList| + (COND + ((NULL |sl|) NIL) + ((QUOTE T) + (|concat| + (|prefix2String| (CAR |sl|)) + (|formatModemap,fn| (CDR |sl|)))))) + (SPADLET |argPart| + (COND + ((QSLESSP (|#| |sl|) 2) |argTypeList|) + ((QUOTE T) + (CONS "(" (APPEND |argTypeList| (CONS ")" NIL)))))) + (SPADLET |fromPart| + (COND + ((AND (BOOT-EQUAL |dc| (QUOTE D)) D) + (|concat| + (QUOTE |%b|) + (MAKESTRING "from") + (QUOTE |%d|) + (|prefix2String| D))) + ((QUOTE T) + (|concat| (QUOTE |%b|) "from" (QUOTE |%d|) (|prefix2String| |dc|))))) + (SPADLET |firstPart| (|concat| " " |argPart| " -> " |targetPart|)) + (COND + ((> (PLUS (|sayWidth| |firstPart|) (|sayWidth| |fromPart|)) 74) + (SPADLET |fromPart| (|concat| (MAKESTRING " ") |fromPart|)) + (SPADLET |secondPart| + (COND + ((> 75 (PLUS (|sayWidth| |fromPart|) (|sayWidth| |predPart|))) + (|concat| |fromPart| |predPart|)) + ((QUOTE T) (|concat| |fromPart| (QUOTE |%l|) |predPart|)))) + (|concat| |firstPart| (QUOTE |%l|) |secondPart|)) + ((QUOTE T) + (SPADLET |firstPart| (|concat| |firstPart| |fromPart|)) + (COND + ((> 80 (PLUS (|sayWidth| |firstPart|) (|sayWidth| |predPart|))) + (|concat| |firstPart| |predPart|)) + ((QUOTE T) (|concat| |firstPart| (QUOTE |%l|) |predPart|))))))))) + +;substInOrder(alist,x) == +; alist is [[a,:b],:y] => substInOrder(y,SUBST(b,a,x)) +; x + +(DEFUN |substInOrder| (|alist| |x|) + (PROG (|ISTMP#1| |a| |b| |y|) + (RETURN + (COND + ((AND (PAIRP |alist|) + (PROGN (SPADLET |ISTMP#1| (QCAR |alist|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |b| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (PROGN (SPADLET |y| (QCDR |alist|)) (QUOTE T))) + (|substInOrder| |y| (MSUBST |b| |a| |x|))) + ((QUOTE T) |x|))))) + +;reportOpSymbol op1 == +; op := (STRINGP op1 => INTERN op1; op1) +; modemaps := getAllModemapsFromDatabase(op,nil) +; null modemaps => +; ok := true +; sayKeyedMsg("S2IF0010",[op1]) +; if SIZE PNAME op1 < 3 then +; x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1]) +; null MEMQ(STRING2ID_-N(x,1),'(Y YES)) => +; ok := nil +; sayKeyedMsg("S2IZ0061",[op1]) +; ok => apropos [op1] +; sayNewLine() +; -- filter modemaps on whether they are exposed +; mmsE := mmsU := NIL +; domlist := NIL +; for mm in modemaps repeat +; dom := getDomainFromMm(mm) +; PUSHNEW(dom,domlist) +; isFreeFunctionFromMm(mm) or isExposedConstructor dom => +; mmsE := [mm,:mmsE] +; mmsU := [mm,:mmsU] +; if mmsE then +; sayMms(op,mmsE,'"exposed") where +; sayMms(op,mms,label) == +; m := # mms +; sayMSG +; m = 1 => +; ['"There is one",:bright label,'"function called", +; :bright op,'":"] +; ['"There are ",m,:bright label,'"functions called", +; :bright op,'":"] +; for mm in mms for i in 1.. repeat +; sayModemapWithNumber(mm,i) +; if mmsU then +; if mmsE then sayNewLine() +; sayMms(op,mmsU,'"unexposed") +; for adom in domlist repeat +; doc := GETDATABASE(adom,'DOCUMENTATION) +; docs := CDR(ASSOC(op,doc)) +; sayNewLine() +; sayBrightly ['"Examples of ",op," from ",adom] +; sayNewLine() +; for export in docs repeat +; SAYEXAMPLE(CADR(export)) +; nil + +(DEFUN |reportOpSymbol,sayMms| (|op| |mms| |label|) + (PROG (|m|) + (RETURN + (SEQ + (SPADLET |m| (|#| |mms|)) + (|sayMSG| + (SEQ + (IF (EQL |m| 1) + (EXIT + (CONS + "There is one" + (APPEND + (|bright| |label|) + (CONS "function called" (APPEND (|bright| |op|) (CONS ":" NIL))))))) + (EXIT + (CONS + "There are " + (CONS |m| + (APPEND + (|bright| |label|) + (CONS + "functions called" + (APPEND (|bright| |op|) (CONS ":" NIL))))))))) + (EXIT + (DO ((#0=#:G166477 |mms| (CDR #0#)) (|mm| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|sayModemapWithNumber| |mm| |i|))))))))) + +(DEFUN |reportOpSymbol| (|op1|) + (PROG (|op| |modemaps| |x| |ok| |domlist| |dom| |mmsE| |mmsU| |doc| |docs|) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (COND ((STRINGP |op1|) (INTERN |op1|)) ((QUOTE T) |op1|))) + (SPADLET |modemaps| (|getAllModemapsFromDatabase| |op| NIL)) + (COND + ((NULL |modemaps|) + (SPADLET |ok| (QUOTE T)) + (|sayKeyedMsg| (QUOTE S2IF0010) (CONS |op1| NIL)) + (COND + ((> 3 (SIZE (PNAME |op1|))) + (SPADLET |x| + (UPCASE (|queryUserKeyedMsg| (QUOTE S2IZ0060) (CONS |op1| NIL)))) + (COND + ((NULL (MEMQ (STRING2ID-N |x| 1) (QUOTE (Y YES)))) + (PROGN + (SPADLET |ok| NIL) + (|sayKeyedMsg| (QUOTE S2IZ0061) (CONS |op1| NIL))))))) + (COND (|ok| (|apropos| (CONS |op1| NIL))))) + ((QUOTE T) + (|sayNewLine|) + (SPADLET |mmsE| (SPADLET |mmsU| NIL)) + (SPADLET |domlist| NIL) + (DO ((#0=#:G166497 |modemaps| (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |dom| (|getDomainFromMm| |mm|)) + (PUSHNEW |dom| |domlist|) + (COND + ((OR (|isFreeFunctionFromMm| |mm|) (|isExposedConstructor| |dom|)) + (SPADLET |mmsE| (CONS |mm| |mmsE|))) + ((QUOTE T) + (SPADLET |mmsU| (CONS |mm| |mmsU|)))))))) + (COND + (|mmsE| (|reportOpSymbol,sayMms| |op| |mmsE| (MAKESTRING "exposed")))) + (COND + (|mmsU| + (COND (|mmsE| (|sayNewLine|))) + (|reportOpSymbol,sayMms| |op| |mmsU| (MAKESTRING "unexposed")))) + (DO ((#1=#:G166512 |domlist| (CDR #1#)) (|adom| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |adom| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |doc| (GETDATABASE |adom| (QUOTE DOCUMENTATION))) + (SPADLET |docs| (CDR (|assoc| |op| |doc|))) + (|sayNewLine|) + (|sayBrightly| + (CONS + "Examples of " + (CONS |op| (CONS " from " (CONS |adom| NIL))))) + (|sayNewLine|) + (DO ((#2=#:G166521 |docs| (CDR #2#)) (|export| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |export| (CAR #2#)) NIL)) NIL) + (SEQ (EXIT (SAYEXAMPLE (CADR |export|))))))))) + NIL))))))) + +;formatOpType (form:=[op,:argl]) == +; null argl => unabbrev op +; form2String [unabbrev op, :argl] + +(DEFUN |formatOpType| (|form|) + (PROG (|op| |argl|) + (RETURN + (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (COND + ((NULL |argl|) (|unabbrev| |op|)) + ((QUOTE T) (|form2String| (CONS (|unabbrev| |op|) |argl|)))))))) + +;formatOperationAlistEntry (entry:= [op,:modemaps]) == +; -- alist has entries of the form: ((op sig) . pred) +; -- opsig on this list => op is defined only when the predicate is true +; ans:= nil +; for [sig,.,:predtail] in modemaps repeat +; pred := (predtail is [p,:.] => p; 'T) +; -- operation is always defined +; ans := +; [concat(formatOpSignature(op,sig),formatIf pred),:ans] +; ans + +(DEFUN |formatOperationAlistEntry| (|entry|) + (PROG (|op| |modemaps| |sig| |predtail| |p| |pred| |ans|) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (CAR |entry|)) + (SPADLET |modemaps| (CDR |entry|)) + (SPADLET |ans| NIL) + (DO ((#0=#:G166585 |modemaps| (CDR #0#)) (#1=#:G166559 NIL)) + ((OR (ATOM #0#) (PROGN (SETQ #1# (CAR #0#)) NIL) (PROGN (PROGN (SPADLET |sig| (CAR #1#)) (SPADLET |predtail| (CDDR #1#)) #1#) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |pred| + (COND + ((AND (PAIRP |predtail|) (PROGN (SPADLET |p| (QCAR |predtail|)) (QUOTE T))) + |p|) + ((QUOTE T) + (QUOTE T)))) + (SPADLET |ans| + (CONS + (|concat| (|formatOpSignature| |op| |sig|) (|formatIf| |pred|)) + |ans|)))))) + |ans|))))) + +;formatOperation([[op,sig],.,[fn,.,n]],domain) == +; opSigString := formatOpSignature(op,sig) +; INTEGERP n and Undef = KAR domain.n => +; if INTEGERP $commentedOps then $commentedOps := $commentedOps + 1 +; concat(" --",opSigString) +; opSigString + +(DEFUN |formatOperation| (#0=#:G166605 |domain|) + (PROG (|op| |sig| |fn| |n| |opSigString|) + (RETURN + (PROGN + (SPADLET |op| (CAAR #0#)) + (SPADLET |sig| (CADAR #0#)) + (SPADLET |fn| (CAADDR #0#)) + (SPADLET |n| (CADR (CDADDR #0#))) + (SPADLET |opSigString| (|formatOpSignature| |op| |sig|)) + (COND + ((AND (INTEGERP |n|) (BOOT-EQUAL |Undef| (KAR (ELT |domain| |n|)))) + (COND + ((INTEGERP |$commentedOps|) + (SPADLET |$commentedOps| (PLUS |$commentedOps| 1)))) + (|concat| (QUOTE | --|) |opSigString|)) + ((QUOTE T) |opSigString|)))))) + +;formatOpSignature(op,sig) == +; concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig) + +(DEFUN |formatOpSignature| (|op| |sig|) + (|concat| + (QUOTE |%b|) + (|formatOpSymbol| |op| |sig|) + (QUOTE |%d|) + (QUOTE |: |) + (|formatSignature| |sig|))) + +;formatOpConstant op == +; concat('%b,formatOpSymbol(op,'($)),'%d,'": constant") + +(DEFUN |formatOpConstant| (|op|) + (|concat| + (QUOTE |%b|) + (|formatOpSymbol| |op| (QUOTE ($))) + (QUOTE |%d|) + (MAKESTRING ": constant"))) + +;formatOpSymbol(op,sig) == +; if op = 'Zero then op := "0" +; else if op = 'One then op := "1" +; null sig => op +; quad := specialChar 'quad +; n := #sig +; (op = 'elt) and (n = 3) => +; (CADR(sig) = '_$) => +; STRINGP (sel := CADDR(sig)) => +; [quad,".",sel] +; [quad,".",quad] +; op +; STRINGP op or GET(op,"Led") or GET(op,"Nud") => +; n = 3 => +; if op = 'SEGMENT then op := '".." +; op = 'in => [quad,'" ",op,'" ",quad] +;-- stop exquo from being displayed as infix (since it is not accepted +;-- as such by the interpreter) +; op = 'exquo => op +; [quad,op,quad] +; n = 2 => +; not GET(op,"Nud") => [quad,op] +; [op,quad] +; op +; op + +(DEFUN |formatOpSymbol| (|op| |sig|) + (PROG (|quad| |n| |sel|) + (RETURN + (PROGN + (COND + ((BOOT-EQUAL |op| (QUOTE |Zero|)) (SPADLET |op| (QUOTE |0|))) + ((BOOT-EQUAL |op| (QUOTE |One|)) (SPADLET |op| (QUOTE |1|))) + ((QUOTE T) NIL)) + (COND + ((NULL |sig|) |op|) + ((QUOTE T) + (SPADLET |quad| (|specialChar| (QUOTE |quad|))) + (SPADLET |n| (|#| |sig|)) + (COND + ((AND (BOOT-EQUAL |op| (QUOTE |elt|)) (EQL |n| 3)) + (COND + ((BOOT-EQUAL (CADR |sig|) (QUOTE $)) + (COND + ((STRINGP (SPADLET |sel| (CADDR |sig|))) + (CONS |quad| (CONS (INTERN "." "BOOT") (CONS |sel| NIL)))) + ((QUOTE T) + (CONS |quad| (CONS (INTERN "." "BOOT") (CONS |quad| NIL)))))) + ((QUOTE T) |op|))) + ((OR (STRINGP |op|) (GETL |op| (QUOTE |Led|)) (GETL |op| (QUOTE |Nud|))) + (COND + ((EQL |n| 3) + (COND + ((BOOT-EQUAL |op| (QUOTE SEGMENT)) + (SPADLET |op| (MAKESTRING "..")))) + (COND + ((BOOT-EQUAL |op| (QUOTE |in|)) + (CONS |quad| (CONS " " (CONS |op| (CONS " " (CONS |quad| NIL)))))) + ((BOOT-EQUAL |op| (QUOTE |exquo|)) |op|) + ((QUOTE T) (CONS |quad| (CONS |op| (CONS |quad| NIL)))))) + ((EQL |n| 2) + (COND + ((NULL (GETL |op| (QUOTE |Nud|))) (CONS |quad| (CONS |op| NIL))) + ((QUOTE T) (CONS |op| (CONS |quad| NIL))))) + ((QUOTE T) |op|))) + ((QUOTE T) |op|)))))))) + +;formatAttribute x == +; atom x => [" ",x] +; x is [op,:argl] => +; for x in argl repeat +; argPart:= NCONC(argPart,concat(",",formatAttributeArg x)) +; argPart => concat(" ",op,"_(",rest argPart,"_)") +; [" ",op] + +(DEFUN |formatAttribute| (|x|) + (PROG (|op| |argl| |argPart|) + (RETURN + (SEQ + (COND + ((ATOM |x|) (CONS (QUOTE | |) (CONS |x| NIL))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + (QUOTE T))) + (DO ((#0=#:G166656 |argl| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |argPart| + (NCONC + |argPart| + (|concat| (QUOTE |,|) (|formatAttributeArg| |x|))))))) + (COND + (|argPart| + (|concat| (QUOTE | |) |op| (QUOTE |(|) (CDR |argPart|) (QUOTE |)|))) + ((QUOTE T) + (CONS (QUOTE | |) (CONS |op| NIL)))))))))) + +;formatAttributeArg x == +; STRINGP x and x ='"*" => "_"*_"" +; atom x => formatOpSymbol (x,nil) +; x is [":",op,["Mapping",:sig]] => +; concat('%b,formatOpSymbol(op,sig),": ",'%d,formatMapping sig) +; prefix2String0 x + +(DEFUN |formatAttributeArg| (|x|) + (PROG (|ISTMP#1| |op| |ISTMP#2| |ISTMP#3| |sig|) + (RETURN + (COND + ((AND (STRINGP |x|) (BOOT-EQUAL |x| (MAKESTRING "*"))) (QUOTE |"*"|)) + ((ATOM |x|) (|formatOpSymbol| |x| NIL)) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) (QUOTE |Mapping|)) + (PROGN (SPADLET |sig| (QCDR |ISTMP#3|)) (QUOTE T))))))))) + (|concat| + (QUOTE |%b|) + (|formatOpSymbol| |op| |sig|) + (QUOTE |: |) + (QUOTE |%d|) + (|formatMapping| |sig|))) + ((QUOTE T) (|prefix2String0| |x|)))))) + +;formatMapping sig == +; "STRCONC"/concat("Mapping(",formatSignature sig,")") + +(DEFUN |formatMapping| (|sig|) + (PROG NIL + (RETURN + (SEQ + (PROG (#0=#:G166704) + (SPADLET #0# "") + (RETURN + (DO ((#1=#:G166709 + (|concat| (QUOTE |Mapping(|) (|formatSignature| |sig|) (QUOTE |)|)) + (CDR #1#)) + (#2=#:G166703 NIL)) + ((OR (ATOM #1#) (PROGN (SETQ #2# (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (STRCONC #0# #2#))))))))))) + +;dollarPercentTran x == +; -- Translate $ to %. We actually return %% so that the message +; -- printer will display a single % +; x is [y,:z] => +; y1 := dollarPercentTran y +; z1 := dollarPercentTran z +; EQ(y, y1) and EQ(z, z1) => x +; [y1, :z1] +; x = "$" or x = '"$" => "%%" +; x + +(DEFUN |dollarPercentTran| (|x|) + (PROG (|y| |z| |y1| |z1|) + (RETURN + (COND + ((AND (PAIRP |x|) + (PROGN (SPADLET |y| (QCAR |x|)) (SPADLET |z| (QCDR |x|)) (QUOTE T))) + (SPADLET |y1| (|dollarPercentTran| |y|)) + (SPADLET |z1| (|dollarPercentTran| |z|)) + (COND + ((AND (EQ |y| |y1|) (EQ |z| |z1|)) |x|) + ((QUOTE T) (CONS |y1| |z1|)))) + ((OR (BOOT-EQUAL |x| (QUOTE $)) (BOOT-EQUAL |x| (MAKESTRING "$"))) + (QUOTE %%)) + ((QUOTE T) |x|))))) + +;formatSignatureAsTeX sig == +; $formatSigAsTeX: local := 2 +; formatSignature0 sig + +(DEFUN |formatSignatureAsTeX| (|sig|) + (PROG (|$formatSigAsTeX|) + (DECLARE (SPECIAL |$formatSigAsTeX|)) + (RETURN (PROGN (SPADLET |$formatSigAsTeX| 2) (|formatSignature0| |sig|))))) + +;formatSignature sig == +; $formatSigAsTeX: local := 1 +; formatSignature0 sig + +(DEFUN |formatSignature| (|sig|) + (PROG (|$formatSigAsTeX|) + (DECLARE (SPECIAL |$formatSigAsTeX|)) + (RETURN (PROGN (SPADLET |$formatSigAsTeX| 1) (|formatSignature0| |sig|))))) + +;formatSignatureArgs sml == +; $formatSigAsTeX: local := 1 +; formatSignatureArgs0 sml + +(DEFUN |formatSignatureArgs| (|sml|) + (PROG (|$formatSigAsTeX|) + (DECLARE (SPECIAL |$formatSigAsTeX|)) + (RETURN + (PROGN (SPADLET |$formatSigAsTeX| 1) (|formatSignatureArgs0| |sml|))))) + +; +;formatSignature0 sig == +; null sig => "() -> ()" +; INTEGERP sig => '"hashcode" +; [tm,:sml] := sig +; sourcePart:= formatSignatureArgs0 sml +; targetPart:= prefix2String0 tm +; dollarPercentTran concat(sourcePart,concat(" -> ",targetPart)) + +(DEFUN |formatSignature0| (|sig|) + (PROG (|tm| |sml| |sourcePart| |targetPart|) + (RETURN + (COND + ((NULL |sig|) (QUOTE |() -> ()|)) + ((INTEGERP |sig|) (MAKESTRING "hashcode")) + ((QUOTE T) + (SPADLET |tm| (CAR |sig|)) + (SPADLET |sml| (CDR |sig|)) + (SPADLET |sourcePart| (|formatSignatureArgs0| |sml|)) + (SPADLET |targetPart| (|prefix2String0| |tm|)) + (|dollarPercentTran| + (|concat| |sourcePart| (|concat| (QUOTE | -> |) |targetPart|)))))))) + +;formatSignatureArgs0(sml) == +;-- formats the arguments of a signature +; null sml => ["_(_)"] +; null rest sml => prefix2String0 first sml +; argList:= prefix2String0 first sml +; for m in rest sml repeat +; argList:= concat(argList,concat(",",prefix2String0 m)) +; concat("_(",concat(argList,"_)")) + +(DEFUN |formatSignatureArgs0| (|sml|) + (PROG (|argList|) + (RETURN + (SEQ + (COND + ((NULL |sml|) (CONS (QUOTE |()|) NIL)) + ((NULL (CDR |sml|)) (|prefix2String0| (CAR |sml|))) + ((QUOTE T) + (SPADLET |argList| (|prefix2String0| (CAR |sml|))) + (DO ((#0=#:G166767 (CDR |sml|) (CDR #0#)) (|m| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |m| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |argList| + (|concat| + |argList| + (|concat| (QUOTE |,|) (|prefix2String0| |m|))))))) + (|concat| (QUOTE |(|) (|concat| |argList| (QUOTE |)|))))))))) + +;--% Conversions to string form +;expr2String x == +; atom (u:= prefix2String0 x) => u +; "STRCONC"/[atom2String y for y in u] + +(DEFUN |expr2String| (|x|) + (PROG (|u|) + (RETURN + (SEQ + (COND + ((ATOM (SPADLET |u| (|prefix2String0| |x|))) |u|) + ((QUOTE T) + (PROG (#0=#:G166779) + (SPADLET #0# "") + (RETURN + (DO ((#1=#:G166784 |u| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (STRCONC #0# (|atom2String| |y|)))))))))))))) + +;-- exports (this is a badly named bit of sillyness) +;prefix2StringAsTeX form == +; form2StringAsTeX form + +(DEFUN |prefix2StringAsTeX| (|form|) (|form2StringAsTeX| |form|)) + +;prefix2String form == +; form2String form + +(DEFUN |prefix2String| (|form|) (|form2String| |form|)) + +;-- local version +;prefix2String0 form == +; form2StringLocal form + +(DEFUN |prefix2String0| (|form|) (|form2StringLocal| |form|)) + +;-- SUBRP form => formWrapId BPINAME form +;-- atom form => +;-- form=$EmptyMode or form=$quadSymbol => formWrapId specialChar 'quad +;-- STRINGP form => formWrapId form +;-- IDENTP form => +;-- constructor? form => app2StringWrap(formWrapId form, [form]) +;-- formWrapId form +;-- formWrapId STRINGIMAGE form +;form2StringWithWhere u == +; $permitWhere : local := true +; $whereList: local := nil +; s:= form2String u +; $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u") +; s + +(DEFUN |form2StringWithWhere| (|u|) + (PROG (|$permitWhere| |$whereList| |s|) + (DECLARE (SPECIAL |$permitWhere| |$whereList|)) + (RETURN + (PROGN + (SPADLET |$permitWhere| (QUOTE T)) + (SPADLET |$whereList| NIL) + (SPADLET |s| (|form2String| |u|)) + (COND + (|$whereList| + (|concat| + |s| + (QUOTE |%b|) + "where" + (QUOTE |%d|) + (QUOTE |%i|) + |$whereList| + (QUOTE |%u|))) + ((QUOTE T) |s|)))))) + +;form2StringWithPrens form == +; null (argl := rest form) => [first form] +; null rest argl => [first form,"(",first argl,")"] +; form2String form + +(DEFUN |form2StringWithPrens| (|form|) + (PROG (|argl|) + (RETURN + (COND + ((NULL (SPADLET |argl| (CDR |form|))) (CONS (CAR |form|) NIL)) + ((NULL (CDR |argl|)) + (CONS + (CAR |form|) + (CONS (QUOTE |(|) (CONS (CAR |argl|) (CONS (QUOTE |)|) NIL))))) + ((QUOTE T) (|form2String| |form|)))))) + +;formString u == +; x := form2String u +; atom x => STRINGIMAGE x +; "STRCONC"/[STRINGIMAGE y for y in x] + +(DEFUN |formString| (|u|) + (PROG (|x|) + (RETURN + (SEQ + (PROGN + (SPADLET |x| (|form2String| |u|)) + (COND + ((ATOM |x|) (STRINGIMAGE |x|)) + ((QUOTE T) + (PROG (#0=#:G166821) + (SPADLET #0# "") + (RETURN + (DO ((#1=#:G166826 |x| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (STRCONC #0# (STRINGIMAGE |y|))))))))))))))) + +;form2String u == +; $formatSigAsTeX: local := 1 +; form2StringLocal u + +(DEFUN |form2String| (|u|) + (PROG (|$formatSigAsTeX|) + (DECLARE (SPECIAL |$formatSigAsTeX|)) + (RETURN (PROGN (SPADLET |$formatSigAsTeX| 1) (|form2StringLocal| |u|))))) + +;form2StringAsTeX u == +; $formatSigAsTeX: local := 2 +; form2StringLocal u + +(DEFUN |form2StringAsTeX| (|u|) + (PROG (|$formatSigAsTeX|) + (DECLARE (SPECIAL |$formatSigAsTeX|)) + (RETURN (PROGN (SPADLET |$formatSigAsTeX| 2) (|form2StringLocal| |u|))))) + +;form2StringLocal u == +;--+ +; $NRTmonitorIfTrue : local := nil +; $fortInts2Floats : local := nil +; form2String1 u + +(DEFUN |form2StringLocal| (|u|) + (PROG (|$NRTmonitorIfTrue| |$fortInts2Floats|) + (DECLARE (SPECIAL |$NRTmonitorIfTrue| |$fortInts2Floats|)) + (RETURN + (PROGN + (SPADLET |$NRTmonitorIfTrue| NIL) + (SPADLET |$fortInts2Floats| NIL) + (|form2String1| |u|))))) + +;constructorName con == +; $abbreviateTypes => abbreviate con +; con + +(DEFUN |constructorName| (|con|) + (COND + (|$abbreviateTypes| (|abbreviate| |con|)) + ((QUOTE T) |con|))) + +;form2String1 u == +; ATOM u => +; u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad +; IDENTP u => +; constructor? u => app2StringWrap(formWrapId u, [u]) +; u +; SUBRP u => formWrapId BPINAME u +; STRINGP u => formWrapId u +; WRITE_-TO_-STRING formWrapId u +; u1 := u +; op := CAR u +; argl := CDR u +; op='Join or op= 'mkCategory => formJoin1(op,argl) +; $InteractiveMode and (u:= constructor? op) => +; null argl => app2StringWrap(formWrapId constructorName op, u1) +; op = "NTuple" => [ form2String1 first argl, "*"] +; op = "Map" => ["(",:formatSignature0 [argl.1,argl.0],")"] +; op = 'Record => record2String(argl) +; null (conSig := getConstructorSignature op) => +; application2String(constructorName op,[form2String1(a) for a in argl], u1) +; ml := rest conSig +; if not freeOfSharpVars ml then +; ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList +; for val in argl], ml) +; argl:= formArguments2String(argl,ml) +; -- extra null check to handle mutable domain hack. +; null argl => constructorName op +; application2String(constructorName op,argl, u1) +; op = "Mapping" => ["(",:formatSignature argl,")"] +; op = "Record" => record2String(argl) +; op = 'Union => +; application2String(op,[form2String1 x for x in argl], u1) +; op = ":" => +; null argl => [ '":" ] +; null rest argl => [ '":", form2String1 first argl ] +; formDecl2String(argl.0,argl.1) +; op = "#" and PAIRP argl and LISTP CAR argl => +; STRINGIMAGE SIZE CAR argl +; op = 'Join => formJoin2String argl +; op = "ATTRIBUTE" => form2String1 first argl +; op='Zero => 0 +; op='One => 1 +; op = 'AGGLST => tuple2String argl +; op = 'BRACKET => +; argl' := form2String1 first argl +; ["[",:(atom argl' => [argl']; argl'),"]"] +; op = "SIGNATURE" => +; [operation,sig] := argl +; concat(operation,": ",formatSignature sig) +; op = 'COLLECT => formCollect2String argl +; op = 'construct => +; concat(lbrkSch(), +; tuple2String [form2String1 x for x in argl],rbrkSch()) +; op = "SEGMENT" => +; null argl => '".." +; lo := form2String1 first argl +; argl := rest argl +; (null argl) or null (first argl) => [lo, '".."] +; [lo, '"..", form2String1 first argl] +; isBinaryInfix op => fortexp0 [op,:argl] +; -- COMPILED_-FUNCTION_-P(op) => form2String1 coerceMap2E(u1,NIL) +; application2String(op,[form2String1 x for x in argl], u1) + +(DEFUN |form2String1| (|u|) + (PROG (|u1| |op| |conSig| |ml| |argl'| |operation| |sig| |lo| |argl|) + (RETURN + (SEQ + (COND + ((ATOM |u|) + (COND + ((OR (BOOT-EQUAL |u| |$EmptyMode|) (BOOT-EQUAL |u| |$quadSymbol|)) + (|formWrapId| (|specialChar| (QUOTE |quad|)))) + ((IDENTP |u|) + (COND + ((|constructor?| |u|) + (|app2StringWrap| (|formWrapId| |u|) (CONS |u| NIL))) + ((QUOTE T) |u|))) + ((SUBRP |u|) (|formWrapId| (BPINAME |u|))) + ((STRINGP |u|) (|formWrapId| |u|)) + ((QUOTE T) (WRITE-TO-STRING (|formWrapId| |u|))))) + ((QUOTE T) + (SPADLET |u1| |u|) + (SPADLET |op| (CAR |u|)) + (SPADLET |argl| (CDR |u|)) + (COND + ((OR (BOOT-EQUAL |op| (QUOTE |Join|)) + (BOOT-EQUAL |op| (QUOTE |mkCategory|))) + (|formJoin1| |op| |argl|)) + ((AND |$InteractiveMode| (SPADLET |u| (|constructor?| |op|))) + (COND + ((NULL |argl|) + (|app2StringWrap| (|formWrapId| (|constructorName| |op|)) |u1|)) + ((BOOT-EQUAL |op| (QUOTE |NTuple|)) + (CONS (|form2String1| (CAR |argl|)) (CONS (QUOTE *) NIL))) + ((BOOT-EQUAL |op| (QUOTE |Map|)) + (CONS + (QUOTE |(|) + (APPEND + (|formatSignature0| + (CONS (ELT |argl| 1) (CONS (ELT |argl| 0) NIL))) + (CONS (QUOTE |)|) NIL)))) + ((BOOT-EQUAL |op| (QUOTE |Record|)) (|record2String| |argl|)) + ((NULL (SPADLET |conSig| (|getConstructorSignature| |op|))) + (|application2String| + (|constructorName| |op|) + (PROG (#0=#:G166881) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166886 |argl| (CDR #1#)) (|a| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |a| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|form2String1| |a|) #0#))))))) |u1|)) + ((QUOTE T) + (SPADLET |ml| (CDR |conSig|)) + (COND + ((NULL (|freeOfSharpVars| |ml|)) + (SPADLET |ml| + (SUBLIS + (PROG (#2=#:G166897) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G166903 |$FormalMapVariableList| (CDR #3#)) + (|pvar| NIL) + (#4=#:G166904 |argl| (CDR #4#)) + (|val| NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |pvar| (CAR #3#)) NIL) + (ATOM #4#) + (PROGN (SETQ |val| (CAR #4#)) NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT (SETQ #2# (CONS (CONS |pvar| |val|) #2#))))))) |ml|)))) + (SPADLET |argl| (|formArguments2String| |argl| |ml|)) + (COND + ((NULL |argl|) (|constructorName| |op|)) + ((QUOTE T) + (|application2String| (|constructorName| |op|) |argl| |u1|)))))) + ((BOOT-EQUAL |op| (QUOTE |Mapping|)) + (CONS + (QUOTE |(|) + (APPEND (|formatSignature| |argl|) (CONS (QUOTE |)|) NIL)))) + ((BOOT-EQUAL |op| (QUOTE |Record|)) (|record2String| |argl|)) + ((BOOT-EQUAL |op| (QUOTE |Union|)) + (|application2String| + |op| + (PROG (#5=#:G166917) + (SPADLET #5# NIL) + (RETURN + (DO ((#6=#:G166922 |argl| (CDR #6#)) (|x| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) + (NREVERSE0 #5#)) + (SEQ (EXIT (SETQ #5# (CONS (|form2String1| |x|) #5#))))))) + |u1|)) + ((BOOT-EQUAL |op| (QUOTE |:|)) + (COND + ((NULL |argl|) (CONS (MAKESTRING ":") NIL)) + ((NULL (CDR |argl|)) + (CONS (MAKESTRING ":") (CONS (|form2String1| (CAR |argl|)) NIL))) + ((QUOTE T) (|formDecl2String| (ELT |argl| 0) (ELT |argl| 1))))) + ((AND (BOOT-EQUAL |op| (QUOTE |#|)) (PAIRP |argl|) (LISTP (CAR |argl|))) + (STRINGIMAGE (SIZE (CAR |argl|)))) + ((BOOT-EQUAL |op| (QUOTE |Join|)) (|formJoin2String| |argl|)) + ((BOOT-EQUAL |op| (QUOTE ATTRIBUTE)) (|form2String1| (CAR |argl|))) + ((BOOT-EQUAL |op| (QUOTE |Zero|)) 0) + ((BOOT-EQUAL |op| (QUOTE |One|)) 1) + ((BOOT-EQUAL |op| (QUOTE AGGLST)) (|tuple2String| |argl|)) + ((BOOT-EQUAL |op| (QUOTE BRACKET)) + (SPADLET |argl'| (|form2String1| (CAR |argl|))) + (CONS + (QUOTE [) + (APPEND + (COND ((ATOM |argl'|) (CONS |argl'| NIL)) ((QUOTE T) |argl'|)) + (CONS (QUOTE ]) NIL)))) + ((BOOT-EQUAL |op| (QUOTE SIGNATURE)) + (SPADLET |operation| (CAR |argl|)) + (SPADLET |sig| (CADR |argl|)) + (|concat| |operation| (QUOTE |: |) (|formatSignature| |sig|))) + ((BOOT-EQUAL |op| (QUOTE COLLECT)) (|formCollect2String| |argl|)) + ((BOOT-EQUAL |op| (QUOTE |construct|)) + (|concat| + (|lbrkSch|) + (|tuple2String| + (PROG (#7=#:G166932) + (SPADLET #7# NIL) + (RETURN + (DO ((#8=#:G166937 |argl| (CDR #8#)) (|x| NIL)) + ((OR (ATOM #8#) + (PROGN (SETQ |x| (CAR #8#)) NIL)) + (NREVERSE0 #7#)) + (SEQ (EXIT (SETQ #7# (CONS (|form2String1| |x|) #7#)))))))) + (|rbrkSch|))) + ((BOOT-EQUAL |op| (QUOTE SEGMENT)) + (COND + ((NULL |argl|) (MAKESTRING "..")) + ((QUOTE T) + (SPADLET |lo| (|form2String1| (CAR |argl|))) + (SPADLET |argl| (CDR |argl|)) + (COND + ((OR (NULL |argl|) (NULL (CAR |argl|))) + (CONS |lo| (CONS (MAKESTRING "..") NIL))) + ((QUOTE T) + (CONS + |lo| + (CONS ".." (CONS (|form2String1| (CAR |argl|)) NIL)))))))) + ((|isBinaryInfix| |op|) (|fortexp0| (CONS |op| |argl|))) + ((QUOTE T) + (|application2String| + |op| + (PROG (#9=#:G166947) + (SPADLET #9# NIL) + (RETURN + (DO ((#10=#:G166952 |argl| (CDR #10#)) (|x| NIL)) + ((OR (ATOM #10#) (PROGN (SETQ |x| (CAR #10#)) NIL)) + (NREVERSE0 #9#)) + (SEQ (EXIT (SETQ #9# (CONS (|form2String1| |x|) #9#))))))) + |u1|))))))))) + +;formWrapId id == +; $formatSigAsTeX = 1 => id +; $formatSigAsTeX = 2 => +; sep := '"`" +; FORMAT(NIL,'"\verb~a~a~a",sep, id, sep) +; error "Bad formatSigValue" + +(DEFUN |formWrapId| (|id|) + (PROG (|sep|) + (RETURN + (COND + ((EQL |$formatSigAsTeX| 1) |id|) + ((EQL |$formatSigAsTeX| 2) + (SPADLET |sep| (MAKESTRING "`")) + (FORMAT NIL (MAKESTRING "\\verb~a~a~a") |sep| |id| |sep|)) + ((QUOTE T) (|error| (QUOTE |Bad formatSigValue|))))))) + +;formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where +; fn(x,m) == +; x=$EmptyMode or x=$quadSymbol => specialChar 'quad +; STRINGP(x) or IDENTP(x) => x +; x is [ ='_:,:.] => form2String1 x +; isValidType(m) and PAIRP(m) and +; (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => +; (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => +; form2String1 objValUnwrap x' +; form2String1 x +; form2String1 x + +(DEFUN |formArguments2String,fn| (|x| |m|) + (PROG (|x'|) + (RETURN + (SEQ + (IF (OR (BOOT-EQUAL |x| |$EmptyMode|) (BOOT-EQUAL |x| |$quadSymbol|)) + (EXIT (|specialChar| (QUOTE |quad|)))) + (IF (OR (STRINGP |x|) (IDENTP |x|)) (EXIT |x|)) + (IF (AND (PAIRP |x|) (EQUAL (QCAR |x|) (QUOTE |:|))) + (EXIT (|form2String1| |x|))) + (IF + (AND + (AND (|isValidType| |m|) (PAIRP |m|)) + (BOOT-EQUAL + (GETDATABASE (CAR |m|) (QUOTE CONSTRUCTORKIND)) + (QUOTE |domain|))) + (EXIT + (SEQ + (IF + (SPADLET |x'| + (|coerceInteractive| (|objNewWrap| |x| |m|) |$OutputForm|)) + (EXIT (|form2String1| (|objValUnwrap| |x'|)))) + (EXIT (|form2String1| |x|))))) + (EXIT (|form2String1| |x|)))))) + +(DEFUN |formArguments2String| (|argl| |ml|) + (PROG NIL + (RETURN + (SEQ + (PROG (#0=#:G166997) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167003 |argl| (CDR #1#)) + (|x| NIL) + (#2=#:G167004 |ml| (CDR #2#)) + (|m| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |m| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|formArguments2String,fn| |x| |m|) #0#))))))))))) + +;formDecl2String(left,right) == +; $declVar: local := left +; whereBefore := $whereList +; ls:= form2StringLocal left +; rs:= form2StringLocal right +; NE($whereList,whereBefore) and $permitWhere => ls +; concat(form2StringLocal ls,'": ",rs) + +(DEFUN |formDecl2String| (|left| |right|) + (PROG (|$declVar| |whereBefore| |ls| |rs|) + (DECLARE (SPECIAL |$declVar|)) + (RETURN + (PROGN + (SPADLET |$declVar| |left|) + (SPADLET |whereBefore| |$whereList|) + (SPADLET |ls| (|form2StringLocal| |left|)) + (SPADLET |rs| (|form2StringLocal| |right|)) + (COND + ((AND (NE |$whereList| |whereBefore|) |$permitWhere|) |ls|) + ((QUOTE T) + (|concat| (|form2StringLocal| |ls|) (MAKESTRING ": ") |rs|))))))) + +;formJoin1(op,u) == +; if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u]) +; last is [id,.,:r] and id in '(mkCategory CATEGORY) => +; $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...") +; $permitWhere = true => +; opList:= formatJoinKey(r,id) +; $whereList:= concat($whereList,"%l",$declVar,": ", +; formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u") +; formJoin2 argl +; opList:= formatJoinKey(r,id) +; suffix := concat('%b,'"with",'%d,"%i",opList,"%u") +; concat(formJoin2 argl,suffix) +; formJoin2 u + +(DEFUN |formJoin1| (|op| |u|) + (PROG (|LETTMP#1| |argl| |last| |id| |ISTMP#1| |r| |opList| |suffix|) + (RETURN + (PROGN + (COND + ((BOOT-EQUAL |op| (QUOTE |Join|)) + (SPADLET |LETTMP#1| (REVERSE |u|)) + (SPADLET |last| (CAR |LETTMP#1|)) + (SPADLET |argl| (NREVERSE (CDR |LETTMP#1|))) + |u|) + ((QUOTE T) + (SPADLET |argl| NIL) + (SPADLET |last| (CONS |op| |u|)))) + (COND + ((AND (PAIRP |last|) + (PROGN + (SPADLET |id| (QCAR |last|)) + (SPADLET |ISTMP#1| (QCDR |last|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) (QUOTE T)))) + (|member| |id| (QUOTE (|mkCategory| CATEGORY)))) + (COND + ((BOOT-EQUAL |$abbreviateJoin| (QUOTE T)) + (|concat| + (|formJoin2| |argl|) + (QUOTE |%b|) + (MAKESTRING "with") + (QUOTE |%d|) + (MAKESTRING "..."))) + ((BOOT-EQUAL |$permitWhere| (QUOTE T)) + (SPADLET |opList| (|formatJoinKey| |r| |id|)) + (SPADLET |$whereList| + (|concat| + |$whereList| + (QUOTE |%l|) + |$declVar| + (QUOTE |: |) + (|formJoin2| |argl|) + (QUOTE |%b|) + (MAKESTRING "with") + (QUOTE |%d|) + (QUOTE |%i|) + |opList| + (QUOTE |%u|))) + (|formJoin2| |argl|)) + ((QUOTE T) + (SPADLET |opList| (|formatJoinKey| |r| |id|)) + (SPADLET |suffix| + (|concat| + (QUOTE |%b|) + (MAKESTRING "with") + (QUOTE |%d|) + (QUOTE |%i|) + |opList| + (QUOTE |%u|))) + (|concat| (|formJoin2| |argl|) |suffix|)))) + ((QUOTE T) (|formJoin2| |u|))))))) + +;formatJoinKey(r,key) == +; key = 'mkCategory => +; r is [opPart,catPart,:.] => +; opString := +; opPart is [='LIST,:u] => +; "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred) +; for [='QUOTE,[[op,sig],pred]] in u] +; nil +; catString := +; catPart is [='LIST,:u] => +; "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred) +; for [='QUOTE,[con,pred]] in u] +; nil +; concat(opString,catString) +; '"?? unknown mkCategory format ??" +; -- otherwise we have the CATEGORY form +; "append"/[fn for x in r] where fn == +; x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig)) +; x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a) +; x + +(DEFUN |formatJoinKey| (|r| |key|) + (PROG (|opPart| |catPart| |opString| |u| |con| |pred| |catString| |op| + |ISTMP#2| |sig| |ISTMP#1| |a|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |key| (QUOTE |mkCategory|)) + (COND + ((AND (PAIRP |r|) + (PROGN + (SPADLET |opPart| (QCAR |r|)) + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |catPart| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |opString| + (COND + ((AND (PAIRP |opPart|) + (EQUAL (QCAR |opPart|) (QUOTE LIST)) + (PROGN (SPADLET |u| (QCDR |opPart|)) (QUOTE T))) + (PROG (#0=#:G167117) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167123 |u| (CDR #1#)) (#2=#:G167068 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (COND ((EQUAL (QUOTE QUOTE) (CAR #2#)) (QUOTE QUOTE))) + (SPADLET |op| (CAAADR #2#)) + (SPADLET |sig| (CAR (CDAADR #2#))) + (SPADLET |pred| (CADADR #2#)) + #2#) + NIL)) + #0#) + (SEQ + (EXIT + (SETQ #0# + (APPEND + #0# + (|concat| + (QUOTE |%l|) + (|formatOpSignature| |op| |sig|) + (|formatIf| |pred|)))))))))) + ((QUOTE T) NIL))) + (SPADLET |catString| + (COND + ((AND (PAIRP |catPart|) + (EQUAL (QCAR |catPart|) (QUOTE LIST)) + (PROGN (SPADLET |u| (QCDR |catPart|)) (QUOTE T))) + (PROG (#3=#:G167130) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G167136 |u| (CDR #4#)) (#5=#:G167075 NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ #5# (CAR #4#)) NIL) + (PROGN + (PROGN + (COND ((EQUAL (QUOTE QUOTE) (CAR #5#)) (QUOTE QUOTE))) + (SPADLET |con| (CAADR #5#)) + (SPADLET |pred| (CADADR #5#)) + #5#) + NIL)) + #3#) + (SEQ + (EXIT + (SETQ #3# + (APPEND #3# + (|concat| + (QUOTE |%l|) + (MAKESTRING " ") + (|form2StringLocal| |con|) + (|formatIf| |pred|)))))))))) + ((QUOTE T) NIL))) + (|concat| |opString| |catString|)) + ((QUOTE T) (MAKESTRING "?? unknown mkCategory format ??")))) + ((QUOTE T) + (PROG (#6=#:G167143) + (SPADLET #6# NIL) + (RETURN + (DO ((#7=#:G167159 |r| (CDR #7#)) (|x| NIL)) + ((OR (ATOM #7#) (PROGN (SETQ |x| (CAR #7#)) NIL)) #6#) + (SEQ + (EXIT + (SETQ #6# + (APPEND #6# + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE SIGNATURE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (|concat| (QUOTE |%l|) (|formatOpSignature| |op| |sig|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE ATTRIBUTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|concat| (QUOTE |%l|) (|formatAttribute| |a|))) + ((QUOTE T) |x|))))))))))))))) + +;formJoin2 argl == +;-- argl is a list of categories NOT containing a "with" +; null argl => '"" +; 1=#argl => form2StringLocal argl.0 +; application2String('Join,[form2StringLocal x for x in argl], NIL) + +(DEFUN |formJoin2| (|argl|) + (PROG NIL + (RETURN + (SEQ + (COND + ((NULL |argl|) (MAKESTRING "")) + ((EQL 1 (|#| |argl|)) (|form2StringLocal| (ELT |argl| 0))) + ((QUOTE T) + (|application2String| + (QUOTE |Join|) + (PROG (#0=#:G167194) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167199 |argl| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|form2StringLocal| |x|) #0#))))))) + NIL))))))) + +;formJoin2String (u:=[:argl,last]) == +; last is ["CATEGORY",.,:atsigList] => +; postString:= concat("_(",formTuple2String atsigList,"_)") +; #argl=1 => concat(first argl,'" with ",postString) +; concat(application2String('Join,argl, NIL)," with ",postString) +; application2String('Join,u, NIL) + +(DEFUN |formJoin2String| (|u|) + (PROG (|LETTMP#1| |last| |argl| |ISTMP#1| |atsigList| |postString|) + (RETURN + (PROGN + (SPADLET |LETTMP#1| (REVERSE |u|)) + (SPADLET |last| (CAR |LETTMP#1|)) + (SPADLET |argl| (NREVERSE (CDR |LETTMP#1|))) + (COND + ((AND (PAIRP |last|) + (EQ (QCAR |last|) (QUOTE CATEGORY)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |last|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |atsigList| (QCDR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |postString| + (|concat| (QUOTE |(|) (|formTuple2String| |atsigList|) (QUOTE |)|))) + (COND + ((EQL (|#| |argl|) 1) + (|concat| (CAR |argl|) (MAKESTRING " with ") |postString|)) + ((QUOTE T) + (|concat| + (|application2String| (QUOTE |Join|) |argl| NIL) + (QUOTE | with |) + |postString|)))) + ((QUOTE T) (|application2String| (QUOTE |Join|) |u| NIL))))))) + +;formCollect2String [:itl,body] == +; ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"] + +(DEFUN |formCollect2String| (#0=#:G167238) + (PROG (|LETTMP#1| |body| |itl|) + (RETURN + (SEQ + (PROGN + (SPADLET |LETTMP#1| (REVERSE #0#)) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) + (CONS + (QUOTE |(|) + (CONS + |body| + (APPEND + (PROG (#1=#:G167249) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G167254 |itl| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #1#) + (SEQ (EXIT (SETQ #1# (APPEND #1# (|formIterator2String| |x|)))))))) + (CONS (QUOTE |)|) NIL))))))))) + +;formIterator2String x == +; x is ["STEP",y,s,.,:l] => +; tail:= (l is [f] => form2StringLocal f; nil) +; concat("for ",y," in ",s,'"..",tail) +; x is ["tails",y] => concat("tails ",formatIterator y) +; x is ["reverse",y] => concat("reverse ",formatIterator y) +; x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p) +; x is ["until",p] => concat("until ",form2StringLocal p) +; x is ["while",p] => concat("while ",form2StringLocal p) +; systemErrorHere "formatIterator" + +(DEFUN |formIterator2String| (|x|) + (PROG (|s| |ISTMP#3| |l| |f| |tail| |y| |ISTMP#2| |ISTMP#1| |p|) + (RETURN + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE STEP)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |s| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |l| (QCDR |ISTMP#3|)) + (QUOTE T))))))))) + (SPADLET |tail| + (COND + ((AND (PAIRP |l|) + (EQ (QCDR |l|) NIL) + (PROGN (SPADLET |f| (QCAR |l|)) (QUOTE T))) + (|form2StringLocal| |f|)) + ((QUOTE T) NIL))) + (|concat| (QUOTE |for |) |y| (QUOTE | in |) |s| (MAKESTRING "..") |tail|)) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |tails|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|concat| (QUOTE |tails |) (|formatIterator| |y|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |reverse|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|concat| (QUOTE |reverse |) (|formatIterator| |y|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |\||)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|concat| (|formatIterator| |y|) (QUOTE | \| |) (|form2StringLocal| |p|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |until|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|concat| (QUOTE |until |) (|form2StringLocal| |p|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |while|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|concat| (QUOTE |while |) (|form2StringLocal| |p|))) + ((QUOTE T) (|systemErrorHere| (QUOTE |formatIterator|))))))) + +;tuple2String argl == +; null argl => nil +; string := first argl +; if string in '("failed" "nil" "prime" "sqfr" "irred") +; then string := STRCONC('"_"",string,'"_"") +; else string := +; ATOM string => object2String string +; [f x for x in string] where +; f x == +; ATOM x => object2String x +; -- [f CAR x,:f CDR x] +; [f y for y in x] +; for x in rest argl repeat +; if x in '("failed" "nil" "prime" "sqfr" "irred") then +; x := STRCONC('"_"",x,'"_"") +; string:= concat(string,concat(",",f x)) +; string + +(DEFUN |tuple2String,f| (|x|) + (PROG NIL + (RETURN + (SEQ + (IF (ATOM |x|) (EXIT (|object2String| |x|))) + (EXIT + (PROG (#0=#:G167364) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167369 |x| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|tuple2String,f| |y|) #0#)))))))))))) + +(DEFUN |tuple2String| (|argl|) + (PROG (|x| |string|) + (RETURN + (SEQ + (COND + ((NULL |argl|) NIL) + ((QUOTE T) + (SPADLET |string| (CAR |argl|)) + (COND + ((|member| |string| (QUOTE ("failed" "nil" "prime" "sqfr" "irred"))) + (SPADLET |string| (STRCONC "\"" |string| "\""))) + ((QUOTE T) + (SPADLET |string| + (COND + ((ATOM |string|) (|object2String| |string|)) + ((QUOTE T) + (PROG (#0=#:G167387) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167392 |string| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT (SETQ #0# (CONS (|tuple2String,f| |x|) #0#)))))))))))) + (DO ((#2=#:G167403 (CDR |argl|) (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (COND + ((|member| |x| (QUOTE ("failed" "nil" "prime" "sqfr" "irred"))) + (SPADLET |x| (STRCONC (MAKESTRING "\"") |x| (MAKESTRING "\""))))) + (SPADLET |string| + (|concat| + |string| + (|concat| (QUOTE |,|) (|tuple2String,f| |x|)))))))) + |string|)))))) + +;script2String s == +; null s => '"" -- just to be safe +; if not PAIRP s then s := [s] +; linearFormatForm(CAR s, CDR s) + +(DEFUN |script2String| (|s|) + (COND + ((NULL |s|) (MAKESTRING "")) + ((QUOTE T) + (COND ((NULL (PAIRP |s|)) (SPADLET |s| (CONS |s| NIL)))) + (|linearFormatForm| (CAR |s|) (CDR |s|))))) + +;linearFormatName x == +; atom x => x +; linearFormat x + +(DEFUN |linearFormatName| (|x|) + (COND + ((ATOM |x|) |x|) + ((QUOTE T) (|linearFormat| |x|)))) + +;linearFormat x == +; atom x => x +; x is [op,:argl] and atom op => +; argPart:= +; argl is [a,:l] => [a,:"append"/[[",",x] for x in l]] +; nil +; [op,"(",:argPart,")"] +; [linearFormat y for y in x] + +(DEFUN |linearFormat| (|x|) + (PROG (|op| |argl| |a| |l| |argPart|) + (RETURN + (SEQ + (COND + ((ATOM |x|) |x|) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + (QUOTE T)) + (ATOM |op|)) + (SPADLET |argPart| + (COND + ((AND (PAIRP |argl|) + (PROGN + (SPADLET |a| (QCAR |argl|)) + (SPADLET |l| (QCDR |argl|)) + (QUOTE T))) + (CONS |a| + (PROG (#0=#:G167436) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167441 |l| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# (APPEND #0# (CONS (QUOTE |,|) (CONS |x| NIL))))))))))) + ((QUOTE T) NIL))) + (CONS |op| (CONS (QUOTE |(|) (APPEND |argPart| (CONS (QUOTE |)|) NIL))))) + ((QUOTE T) + (PROG (#2=#:G167451) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167456 |x| (CDR #3#)) (|y| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |y| (CAR #3#)) NIL)) (NREVERSE0 #2#)) + (SEQ (EXIT (SETQ #2# (CONS (|linearFormat| |y|) #2#))))))))))))) + +;numOfSpadArguments id == +; char("*") = (s:= PNAME id).0 => +; +/[n for i in 1.. while INTEGERP (n:=PARSE_-INTEGER PNAME s.i)] +; keyedSystemError("S2IF0012",[id]) + +(DEFUN |numOfSpadArguments| (|id|) + (PROG (|s| |n|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL (|char| (QUOTE *)) (ELT (SPADLET |s| (PNAME |id|)) 0)) + (PROG (#0=#:G167473) + (SPADLET #0# 0) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((NULL + (INTEGERP (SPADLET |n| (PARSE-INTEGER (PNAME (ELT |s| |i|)))))) + #0#) + (SEQ (EXIT (SETQ #0# (PLUS #0# |n|)))))))) + ((QUOTE T) (|keyedSystemError| (QUOTE S2IF0012) (CONS |id| NIL)))))))) + +;linearFormatForm(op,argl) == +; s:= PNAME op +; indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while +; (DIGITP (d:= s.(maxIndex:= i)))] +; cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s]) +; fnArgs:= +; indexList.0 > 0 => +; concat('"(",formatArgList take(-indexList.0,argl),'")") +; nil +; if #indexList > 1 then +; scriptArgs:= formatArgList take(indexList.1,argl) +; argl := drop(indexList.1,argl) +; for i in rest rest indexList repeat +; subArglist:= take(i,argl) +; argl:= drop(i,argl) +; scriptArgs:= concat(scriptArgs,";",formatArgList subArglist) +; scriptArgs:= +; scriptArgs => concat(specialChar 'lbrk,scriptArgs, specialChar 'rbrk) +; nil +; l := [(STRINGP f => f; STRINGIMAGE f) for f in +; concat(cleanOp,scriptArgs,fnArgs)] +; "STRCONC"/l + +(DEFUN |linearFormatForm| (|op| |argl|) + (PROG (|s| |maxIndex| |d| |indexList| |cleanOp| |fnArgs| |subArglist| + |scriptArgs| |l|) + (RETURN + (SEQ + (PROGN + (SPADLET |s| (PNAME |op|)) + (SPADLET |indexList| + (PROG (#0=#:G167500) + (SPADLET #0# NIL) + (RETURN + (DO ((|i| 1 (QSADD1 |i|))) + ((NULL (DIGITP (SPADLET |d| (ELT |s| (SPADLET |maxIndex| |i|))))) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (PARSE-INTEGER (PNAME |d|)) #0#)))))))) + (SPADLET |cleanOp| + (INTERN + (PROG (#1=#:G167509) + (SPADLET #1# "") + (RETURN + (DO ((#2=#:G167514 (MAXINDEX |s|)) (|i| |maxIndex| (+ |i| 1))) + ((> |i| #2#) #1#) + (SEQ (EXIT (SETQ #1# (STRCONC #1# (PNAME (ELT |s| |i|))))))))))) + (SPADLET |fnArgs| + (COND + ((> (ELT |indexList| 0) 0) + (|concat| + "(" + (|formatArgList| (TAKE (SPADDIFFERENCE (ELT |indexList| 0)) |argl|)) + ")")) + ((QUOTE T) NIL))) + (COND + ((> (|#| |indexList|) 1) + (SPADLET |scriptArgs| (|formatArgList| (TAKE (ELT |indexList| 1) |argl|))) + (SPADLET |argl| (DROP (ELT |indexList| 1) |argl|)) + (DO ((#3=#:G167524 (CDR (CDR |indexList|)) (CDR #3#)) (|i| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |i| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |subArglist| (TAKE |i| |argl|)) + (SPADLET |argl| (DROP |i| |argl|)) + (SPADLET |scriptArgs| + (|concat| + |scriptArgs| + (QUOTE |;|) + (|formatArgList| |subArglist|))))))))) + (SPADLET |scriptArgs| + (COND + (|scriptArgs| + (|concat| + (|specialChar| (QUOTE |lbrk|)) + |scriptArgs| + (|specialChar| (QUOTE |rbrk|)))) + ((QUOTE T) NIL))) + (SPADLET |l| + (PROG (#4=#:G167534) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G167539 (|concat| |cleanOp| |scriptArgs| |fnArgs|) (CDR #5#)) + (|f| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |f| (CAR #5#)) NIL)) (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (COND ((STRINGP |f|) |f|) ((QUOTE T) (STRINGIMAGE |f|))) + #4#)))))))) + (PROG (#6=#:G167545) + (SPADLET #6# "") + (RETURN + (DO ((#7=#:G167550 |l| (CDR #7#)) (#8=#:G167488 NIL)) + ((OR (ATOM #7#) (PROGN (SETQ #8# (CAR #7#)) NIL)) #6#) + (SEQ (EXIT (SETQ #6# (STRCONC #6# #8#)))))))))))) + +;formatArgList l == +; null l => nil +; acc:= linearFormat first l +; for x in rest l repeat +; acc:= concat(acc,",",linearFormat x) +; acc + +(DEFUN |formatArgList| (|l|) + (PROG (|acc|) + (RETURN + (SEQ + (COND + ((NULL |l|) NIL) + ((QUOTE T) + (SPADLET |acc| (|linearFormat| (CAR |l|))) + (DO ((#0=#:G167580 (CDR |l|) (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |acc| (|concat| |acc| (QUOTE |,|) (|linearFormat| |x|)))))) + |acc|)))))) + +;formTuple2String argl == +; null argl => nil +; string:= form2StringLocal first argl +; for x in rest argl repeat +; string:= concat(string,concat(",",form2StringLocal x)) +; string + +(DEFUN |formTuple2String| (|argl|) + (PROG (|string|) + (RETURN + (SEQ + (COND + ((NULL |argl|) NIL) + ((QUOTE T) + (SPADLET |string| (|form2StringLocal| (CAR |argl|))) + (DO ((#0=#:G167595 (CDR |argl|) (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |string| + (|concat| + |string| + (|concat| (QUOTE |,|) (|form2StringLocal| |x|))))))) + |string|)))))) + +;isInternalFunctionName(op) == +; (not IDENTP(op)) or (op = "*") or (op = "**") => NIL +; (1 = SIZE(op':= PNAME op)) or (char("*") ^= op'.0) => NIL +; -- if there is a semicolon in the name then it is the name of +; -- a compiled spad function +; null (e := STRPOS('"_;",op',1,NIL)) => NIL +; (char(" ") = (y := op'.1)) or (char("*") = y) => NIL +; table := MAKETRTTABLE('"0123456789",NIL) +; s := STRPOSL(table,op',1,true) +; null(s) or s > e => NIL +; SUBSTRING(op',s,e-s) + +(DEFUN |isInternalFunctionName| (|op|) + (PROG (|op'| |e| |y| |table| |s|) + (RETURN + (COND + ((OR (NULL (IDENTP |op|)) + (BOOT-EQUAL |op| (QUOTE *)) + (BOOT-EQUAL |op| (QUOTE **))) + NIL) + ((OR (EQL 1 (SIZE (SPADLET |op'| (PNAME |op|)))) + (NEQUAL (|char| (QUOTE *)) (ELT |op'| 0))) + NIL) + ((NULL (SPADLET |e| (STRPOS (MAKESTRING ";") |op'| 1 NIL))) NIL) + ((OR (BOOT-EQUAL (|char| (QUOTE | |)) (SPADLET |y| (ELT |op'| 1))) + (BOOT-EQUAL (|char| (QUOTE *)) |y|)) + NIL) + ((QUOTE T) + (SPADLET |table| (MAKETRTTABLE (MAKESTRING "0123456789") NIL)) + (SPADLET |s| (STRPOSL |table| |op'| 1 (QUOTE T))) + (COND + ((OR (NULL |s|) (> |s| |e|)) NIL) + ((QUOTE T) (SUBSTRING |op'| |s| (SPADDIFFERENCE |e| |s|))))))))) + +;application2String(op,argl, linkInfo) == +; null argl => +; (op' := isInternalFunctionName(op)) => op' +; app2StringWrap(formWrapId op, linkInfo) +; 1=#argl => +; first argl is ["<",:.] => concat(op,first argl) +; concat(app2StringWrap(formWrapId op, linkInfo)," ",first argl) +;--op in '(UP SM) => +;-- newop:= (op = "UP" => "P";"M") +;-- concat(newop,concat(lbrkSch(),argl.0,rbrkSch(),argl.1)) +;--op='RM =>concat("M",concat(lbrkSch(), +;-- argl.0,",",argl.1,rbrkSch(),argl.2)) +;--op='MP =>concat("P",concat(argl.0,argl.1)) +; op='SEGMENT => +; null argl => '".." +; (null rest argl) or (null first rest argl) => +; concat(first argl, '"..") +; concat(first argl, concat('"..", first rest argl)) +; concat(app2StringWrap(formWrapId op, linkInfo) , +; concat("_(",concat(tuple2String argl,"_)"))) + +(DEFUN |application2String| (|op| |argl| |linkInfo|) + (PROG (|op'| |ISTMP#1|) + (RETURN + (COND + ((NULL |argl|) + (COND + ((SPADLET |op'| (|isInternalFunctionName| |op|)) |op'|) + ((QUOTE T) (|app2StringWrap| (|formWrapId| |op|) |linkInfo|)))) + ((EQL 1 (|#| |argl|)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (CAR |argl|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE <)))) + (|concat| |op| (CAR |argl|))) + ((QUOTE T) + (|concat| + (|app2StringWrap| (|formWrapId| |op|) |linkInfo|) + (QUOTE | |) + (CAR |argl|))))) + ((BOOT-EQUAL |op| (QUOTE SEGMENT)) + (COND + ((NULL |argl|) (MAKESTRING "..")) + ((OR (NULL (CDR |argl|)) (NULL (CAR (CDR |argl|)))) + (|concat| (CAR |argl|) (MAKESTRING ".."))) + ((QUOTE T) + (|concat| + (CAR |argl|) + (|concat| (MAKESTRING "..") (CAR (CDR |argl|))))))) + ((QUOTE T) + (|concat| + (|app2StringWrap| (|formWrapId| |op|) |linkInfo|) + (|concat| + (QUOTE |(|) + (|concat| (|tuple2String| |argl|) (QUOTE |)|))))))))) + +;app2StringConcat0(x,y) == +; FORMAT(NIL, '"~a ~a", x, y) + +(DEFUN |app2StringConcat0| (|x| |y|) (FORMAT NIL "~a ~a" |x| |y|)) + +;app2StringWrap(string, linkInfo) == +; not linkInfo => string +; $formatSigAsTeX = 1 => string +; $formatSigAsTeX = 2 => +; str2 := "app2StringConcat0"/form2Fence linkInfo +; sep := '"`" +; FORMAT(NIL, '"\lispLink{\verb!(|conPage| '~a)!}{~a}", +; str2, string) +; error "Bad value for $formatSigAsTeX" + +(DEFUN |app2StringWrap| (|string| |linkInfo|) + (PROG (|str2| |sep|) + (RETURN + (SEQ + (COND + ((NULL |linkInfo|) |string|) + ((EQL |$formatSigAsTeX| 1) |string|) + ((EQL |$formatSigAsTeX| 2) + (SPADLET |str2| + (PROG (#0=#:G167632 #1=#:G167633) + (SPADLET #0# (QUOTE #0#)) + (RETURN + (DO ((#2=#:G167640 (|form2Fence| |linkInfo|) (CDR #2#)) + (#3=#:G167629 NIL)) + ((OR (ATOM #2#) + (PROGN + (SETQ #3# (CAR #2#)) + NIL)) + (THETACHECK #0# (QUOTE #0#) (QUOTE |app2StringConcat0|))) + (SEQ + (EXIT + (PROGN + (SPADLET #1# #3#) + (SETQ #0# + (COND + ((EQ #0# (QUOTE #0#)) #1#) + ((QUOTE T) (|app2StringConcat0| #0# #1#))))))))))) + (SPADLET |sep| (MAKESTRING "`")) + (FORMAT NIL "\\lispLink{\\verb!(|conPage| '~a)!}{~a}" |str2| |string|)) + ((QUOTE T) (|error| (QUOTE |Bad value for $formatSigAsTeX|)))))))) + +;record2String x == +; argPart := NIL +; for [":",a,b] in x repeat argPart:= +; concat(argPart,",",a,": ",form2StringLocal b) +; null argPart => '"Record()" +; concat("Record_(",rest argPart,"_)") + +(DEFUN |record2String| (|x|) + (PROG (|a| |b| |argPart|) + (RETURN + (SEQ + (PROGN + (SPADLET |argPart| NIL) + (DO ((#0=#:G167662 |x| (CDR #0#)) (#1=#:G167653 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CADR #1#)) + (SPADLET |b| (CADDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |argPart| + (|concat| + |argPart| + (QUOTE |,|) + |a| + (QUOTE |: |) + (|form2StringLocal| |b|)))))) + (COND + ((NULL |argPart|) + (MAKESTRING "Record()")) + ((QUOTE T) + (|concat| (QUOTE |Record(|) (CDR |argPart|) (QUOTE |)|))))))))) + +;plural(n,string) == +; suffix:= +; n = 1 => '"" +; '"s" +; [:bright n,string,suffix] + +(DEFUN |plural| (|n| |string|) + (PROG (|suffix|) + (RETURN + (PROGN + (SPADLET |suffix| (COND ((EQL |n| 1) "") ((QUOTE T) "s"))) + (APPEND (|bright| |n|) (CONS |string| (CONS |suffix| NIL))))))) + +;formatIf pred == +; not pred => nil +; pred in '(T (QUOTE T)) => nil +; concat('%b,'"if",'%d,pred2English pred) + +(DEFUN |formatIf| (|pred|) + (COND + ((NULL |pred|) NIL) + ((|member| |pred| (QUOTE (T (QUOTE T)))) NIL) + ((QUOTE T) + (|concat| (QUOTE |%b|) "if" (QUOTE |%d|) (|pred2English| |pred|))))) + +;formatPredParts s == +; s is ['QUOTE,s1] => formatPredParts s1 +; s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1] +; s is ['devaluate,s1] => formatPredParts s1 +; s is ['getDomainView,s1,.] => formatPredParts s1 +; s is ['SUBST,a,b,c] => -- this is a signature +; s1 := formatPredParts SUBST(formatPredParts a,b,c) +; s1 isnt [fun,sig] => s1 +; ['SIGNATURE,fun,[formatPredParts(r) for r in sig]] +; s + +(DEFUN |formatPredParts| (|s|) + (PROG (|a| |ISTMP#2| |b| |ISTMP#3| |c| |s1| |fun| |ISTMP#1| |sig|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |s|) + (EQ (QCAR |s|) (QUOTE QUOTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |s|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |s1| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|formatPredParts| |s1|)) + ((AND (PAIRP |s|) + (EQ (QCAR |s|) (QUOTE LIST)) + (PROGN (SPADLET |s1| (QCDR |s|)) (QUOTE T))) + (PROG (#0=#:G167753) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167758 |s1| (CDR #1#)) (|s2| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |s2| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|formatPredParts| |s2|) #0#)))))))) + ((AND (PAIRP |s|) + (EQ (QCAR |s|) (QUOTE |devaluate|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |s|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |s1| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|formatPredParts| |s1|)) + ((AND (PAIRP |s|) + (EQ (QCAR |s|) (QUOTE |getDomainView|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |s|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |s1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (|formatPredParts| |s1|)) + ((AND (PAIRP |s|) + (EQ (QCAR |s|) (QUOTE SUBST)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |s|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |c| (QCAR |ISTMP#3|)) + (QUOTE T))))))))) + (SPADLET |s1| + (|formatPredParts| (MSUBST (|formatPredParts| |a|) |b| |c|))) + (COND + ((NULL + (AND + (PAIRP |s1|) + (PROGN + (SPADLET |fun| (QCAR |s1|)) + (SPADLET |ISTMP#1| (QCDR |s1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |sig| (QCAR |ISTMP#1|)) (QUOTE T)))))) + |s1|) + ((QUOTE T) + (CONS + (QUOTE SIGNATURE) + (CONS + |fun| + (CONS + (PROG (#2=#:G167768) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167773 |sig| (CDR #3#)) (|r| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |r| (CAR #3#)) NIL)) + (NREVERSE0 #2#)) + (SEQ (EXIT (SETQ #2# (CONS (|formatPredParts| |r|) #2#))))))) + NIL)))))) + ((QUOTE T) |s|)))))) + +;pred2English x == +; x is ['IF,cond,thenClause,elseClause] => +; c := concat('"if ",pred2English cond) +; t := concat('" then ",pred2English thenClause) +; e := concat('" else ",pred2English elseClause) +; concat(c,t,e) +; x is ['AND,:l] => +; tail:="append"/[concat(bright '"and",pred2English x) for x in rest l] +; concat(pred2English first l,tail) +; x is ['OR,:l] => +; tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l] +; concat(pred2English first l,tail) +; x is ['NOT,l] => +; concat('"not ",pred2English l) +; x is [op,a,b] and op in '(has ofCategory) => +; concat(pred2English a,'%b,'"has",'%d,form2String abbreviate b) +; x is [op,a,b] and op in '(HasSignature HasAttribute HasCategory) => +; concat(prefix2String0 formatPredParts a,'%b,'"has",'%d, +; prefix2String0 formatPredParts b) +; x is [op,a,b] and op in '(ofType getDomainView) => +; if b is ['QUOTE,b'] then b := b' +; concat(pred2English a,'": ",form2String abbreviate b) +; x is [op,a,b] and op in '(isDomain domainEqual) => +; concat(pred2English a,'" = ",form2String abbreviate b) +; x is [op,:.] and (translation := LASSOC(op,'( +; (_< . " < ") (_<_= . " <= ") +; (_> . " > ") (_>_= . " >= ") (_= . " = ") (_^_= . " _^_= ")))) => +; concat(pred2English a,translation,pred2English b) +; x is ['ATTRIBUTE,form] => +; concat("attribute: ",form2String form) +; form2String x + +(DEFUN |pred2English| (|x|) + (PROG (|cond| |thenClause| |ISTMP#3| |elseClause| |c| |t| |e| |tail| |l| + |b'| |a| |ISTMP#2| |b| |op| |translation| |ISTMP#1| |form|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE IF)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |thenClause| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |elseClause| (QCAR |ISTMP#3|)) + (QUOTE T))))))))) + (SPADLET |c| (|concat| "if " (|pred2English| |cond|))) + (SPADLET |t| (|concat| " then " (|pred2English| |thenClause|))) + (SPADLET |e| (|concat| " else " (|pred2English| |elseClause|))) + (|concat| |c| |t| |e|)) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE AND)) + (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) + (SPADLET |tail| + (PROG (#0=#:G167949) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167954 (CDR |l|) (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# + (APPEND #0# + (|concat| (|bright| "and") (|pred2English| |x|)))))))))) + (|concat| (|pred2English| (CAR |l|)) |tail|)) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE OR)) + (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) + (SPADLET |tail| + (PROG (#2=#:G167960) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167965 (CDR |l|) (CDR #3#)) (|x| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) #2#) + (SEQ + (EXIT + (SETQ #2# + (APPEND #2# + (|concat| (|bright| "or") (|pred2English| |x|)))))))))) + (|concat| (|pred2English| (CAR |l|)) |tail|)) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE NOT)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|concat| (MAKESTRING "not ") (|pred2English| |l|))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|member| |op| (QUOTE (|has| |ofCategory|)))) + (|concat| + (|pred2English| |a|) + (QUOTE |%b|) + (MAKESTRING "has") + (QUOTE |%d|) + (|form2String| (|abbreviate| |b|)))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|member| |op| + (QUOTE (|HasSignature| |HasAttribute| |HasCategory|)))) + (|concat| + (|prefix2String0| (|formatPredParts| |a|)) + (QUOTE |%b|) + (MAKESTRING "has") + (QUOTE |%d|) + (|prefix2String0| (|formatPredParts| |b|)))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|member| |op| (QUOTE (|ofType| |getDomainView|)))) + (COND + ((AND (PAIRP |b|) + (EQ (QCAR |b|) (QUOTE QUOTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |b'| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |b| |b'|))) + (|concat| + (|pred2English| |a|) + (MAKESTRING ": ") + (|form2String| (|abbreviate| |b|)))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|member| |op| (QUOTE (|isDomain| |domainEqual|)))) + (|concat| + (|pred2English| |a|) + (MAKESTRING " = ") + (|form2String| (|abbreviate| |b|)))) + ((AND (PAIRP |x|) + (PROGN (SPADLET |op| (QCAR |x|)) (QUOTE T)) + (SPADLET |translation| + (LASSOC |op| + (QUOTE ((< . " < ") (<= . " <= ") (> . " > ") (>= . " >= ") + (= . " = ") (^= . " ^= ")))))) + (|concat| (|pred2English| |a|) |translation| (|pred2English| |b|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE ATTRIBUTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |form| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|concat| (QUOTE |attribute: |) (|form2String| |form|))) + ((QUOTE T) (|form2String| |x|))))))) + +;object2String x == +; STRINGP x => x +; IDENTP x => PNAME x +; NULL x => '"" +; PAIRP x => STRCONC(object2String first x, object2String rest x) +; WRITE_-TO_-STRING x + +(DEFUN |object2String| (|x|) + (COND + ((STRINGP |x|) |x|) + ((IDENTP |x|) (PNAME |x|)) + ((NULL |x|) (MAKESTRING "")) + ((PAIRP |x|) + (STRCONC (|object2String| (CAR |x|)) (|object2String| (CDR |x|)))) + ((QUOTE T) (WRITE-TO-STRING |x|)))) + +;object2Identifier x == +; IDENTP x => x +; STRINGP x => INTERN x +; INTERN WRITE_-TO_-STRING x + +(DEFUN |object2Identifier| (|x|) + (COND + ((IDENTP |x|) |x|) + ((STRINGP |x|) (INTERN |x|)) + ((QUOTE T) (INTERN (WRITE-TO-STRING |x|))))) + +;blankList x == "append"/[[BLANK,y] for y in x] + +(DEFUN |blankList| (|x|) + (PROG NIL + (RETURN + (SEQ + (PROG (#0=#:G168026) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168031 |x| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (APPEND #0# (CONS BLANK (CONS |y| NIL))))))))))))) + +;--------------------> NEW DEFINITION (see cformat.boot.pamphlet) +;pkey keyStuff == +; if not PAIRP keyStuff then keyStuff := [keyStuff] +; allMsgs := ['" "] +; while not null keyStuff repeat +; dbN := NIL +; argL := NIL +; key := first keyStuff +; keyStuff := IFCDR keyStuff +; next := IFCAR keyStuff +; while PAIRP next repeat +; if CAR next = 'dbN then dbN := CADR next +; else argL := next +; keyStuff := IFCDR keyStuff +; next := IFCAR keyStuff +; oneMsg := returnStLFromKey(key,argL,dbN) +; allMsgs := ['" ", :NCONC (oneMsg,allMsgs)] +; allMsgs + +(DEFUN |pkey| (|keyStuff|) + (PROG (|key| |dbN| |argL| |next| |oneMsg| |allMsgs|) + (RETURN + (SEQ + (PROGN + (COND + ((NULL (PAIRP |keyStuff|)) (SPADLET |keyStuff| (CONS |keyStuff| NIL)))) + (SPADLET |allMsgs| (CONS (MAKESTRING " ") NIL)) + (DO () + ((NULL (NULL (NULL |keyStuff|))) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |dbN| NIL) + (SPADLET |argL| NIL) + (SPADLET |key| (CAR |keyStuff|)) + (SPADLET |keyStuff| (IFCDR |keyStuff|)) + (SPADLET |next| (IFCAR |keyStuff|)) + (DO () + ((NULL (PAIRP |next|)) NIL) + (SEQ + (EXIT + (PROGN + (COND + ((BOOT-EQUAL (CAR |next|) (QUOTE |dbN|)) + (SPADLET |dbN| (CADR |next|))) + ((QUOTE T) + (SPADLET |argL| |next|))) + (SPADLET |keyStuff| (IFCDR |keyStuff|)) + (SPADLET |next| (IFCAR |keyStuff|)))))) + (SPADLET |oneMsg| (|returnStLFromKey| |key| |argL| |dbN|)) + (SPADLET |allMsgs| (CONS " " (NCONC |oneMsg| |allMsgs|))))))) + |allMsgs|))))) + +;string2Float s == +; -- takes a string, calls the parser on it and returns a float object +; p := ncParseFromString s +; p isnt [["$elt", FloatDomain, "float"], x, y, z] => +; systemError '"string2Float: did not get a float expression" +; flt := getFunctionFromDomain("float", FloatDomain, +; [$Integer, $Integer, $PositiveInteger]) +; SPADCALL(x, y, z, flt) + +(DEFUN |string2Float| (|s|) + (PROG (|p| |ISTMP#1| |ISTMP#2| |FloatDomain| |ISTMP#3| |ISTMP#4| |x| + |ISTMP#5| |y| |ISTMP#6| |z| |flt|) + (RETURN + (PROGN + (SPADLET |p| (|ncParseFromString| |s|)) + (COND + ((NULL + (AND (PAIRP |p|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |p|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |$elt|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |FloatDomain| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (EQ (QCAR |ISTMP#3|) (QUOTE |float|)))))))) + (PROGN + (SPADLET |ISTMP#4| (QCDR |p|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| (QCDR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#5|)) + (SPADLET |ISTMP#6| (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCDR |ISTMP#6|) NIL) + (PROGN + (SPADLET |z| (QCAR |ISTMP#6|)) + (QUOTE T)))))))))) + (|systemError| "string2Float: did not get a float expression")) + ((QUOTE T) + (SPADLET |flt| + (|getFunctionFromDomain| + (QUOTE |float|) + |FloatDomain| + (CONS |$Integer| (CONS |$Integer| (CONS |$PositiveInteger| NIL))))) + (SPADCALL |x| |y| |z| |flt|))))))) + +;form2Fence form == +; -- body of dbMkEvalable +; [op, :.] := form +; kind := GETDATABASE(op,'CONSTRUCTORKIND) +; kind = 'category => form2Fence1 form +; form2Fence1 mkEvalable form + +(DEFUN |form2Fence| (|form|) + (PROG (|op| |kind|) + (RETURN + (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |kind| (GETDATABASE |op| (QUOTE CONSTRUCTORKIND))) + (COND + ((BOOT-EQUAL |kind| (QUOTE |category|)) (|form2Fence1| |form|)) + ((QUOTE T) (|form2Fence1| (|mkEvalable| |form|)))))))) + +;form2Fence1 x == +; x is [op,:argl] => +; op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"] +; ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"] +; IDENTP x => FORMAT(NIL, '"|~a|", x) +;-- [x] +; ['" ", x] + +(DEFUN |form2Fence1| (|x|) + (PROG (|op| |argl|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + (QUOTE T))) + (COND + ((BOOT-EQUAL |op| (QUOTE QUOTE)) + (CONS + (MAKESTRING "(QUOTE ") + (APPEND + (|form2FenceQuote| (CAR |argl|)) + (CONS (MAKESTRING ")") NIL)))) + ((QUOTE T) + (CONS + (MAKESTRING "(") + (CONS + (FORMAT NIL (MAKESTRING "|~a|") |op|) + (APPEND + (PROG (#0=#:G168166) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168171 |argl| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (APPEND #0# (|form2Fence1| |y|)))))))) + (CONS (MAKESTRING ")") NIL))))))) + ((IDENTP |x|) (FORMAT NIL (MAKESTRING "|~a|") |x|)) + ((QUOTE T) (CONS (MAKESTRING " ") (CONS |x| NIL)))))))) + +;form2FenceQuote x == +; NUMBERP x => [STRINGIMAGE x] +; SYMBOLP x => [FORMAT(NIL, '"|~a|", x)] +; atom x => '"??" +; ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x] + +(DEFUN |form2FenceQuote| (|x|) + (COND + ((NUMBERP |x|) (CONS (STRINGIMAGE |x|) NIL)) + ((SYMBOLP |x|) (CONS (FORMAT NIL (MAKESTRING "|~a|") |x|) NIL)) + ((ATOM |x|) (MAKESTRING "??")) + ((QUOTE T) + (CONS + (MAKESTRING "(") + (APPEND + (|form2FenceQuote| (CAR |x|)) + (|form2FenceQuoteTail| (CDR |x|))))))) + +;form2FenceQuoteTail x == +; null x => ['")"] +; atom x => ['" . ",:form2FenceQuote x,'")"] +; ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x] + +(DEFUN |form2FenceQuoteTail| (|x|) + (COND + ((NULL |x|) (CONS (MAKESTRING ")") NIL)) + ((ATOM |x|) + (CONS + (MAKESTRING " . ") + (APPEND (|form2FenceQuote| |x|) (CONS (MAKESTRING ")") NIL)))) + ((QUOTE T) + (CONS + (MAKESTRING " ") + (APPEND + (|form2FenceQuote| (CAR |x|)) + (|form2FenceQuoteTail| (CDR |x|))))))) + +;form2StringList u == +; atom (r := form2String u) => [r] +; r + +(DEFUN |form2StringList| (|u|) + (PROG (|r|) + (RETURN + (COND + ((ATOM (SPADLET |r| (|form2String| |u|))) (CONS |r| NIL)) + ((QUOTE T) |r|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}