diff --git a/changelog b/changelog index 4aabbc4..0238f0b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090903 tpd src/axiom-website/patches.html 20090903.02.tpd.patch +20090903 tpd src/interp/Makefile move pspad1.boot to pspad1.lisp +20090903 tpd src/interp/pspad1.lisp added, rewritten from pspad1.boot +20090903 tpd src/interp/pspad1.boot removed, rewritten to pspad1.lisp 20090903 tpd src/axiom-website/patches.html 20090903.01.tpd.patch 20090903 tpd src/interp/Makefile move topics.boot to topics.lisp 20090903 tpd src/interp/topics.lisp added, rewritten from topics.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 796c171..8b36b4a 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1982,5 +1982,7 @@ src/interp/parini.lisp rewrite from boot to lisp
src/interp/interop.lisp rewrite from boot to lisp
20090903.01.tpd.patch src/interp/topics.lisp rewrite from boot to lisp
+20090903.02.tpd.patch +src/interp/pspad1.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 05397b1..7bb11fa 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -4110,32 +4110,23 @@ ${MID}/wi2.clisp: ${IN}/wi2.boot.pamphlet \subsection{pspad1.boot} <>= -${AUTO}/pspad1.${O}: ${MID}/pspad1.clisp - @ echo 598 making ${AUTO}/pspad1.${O} from ${MID}/pspad1.clisp +${AUTO}/pspad1.${O}: ${MID}/pspad1.lisp + @ echo 598 making ${AUTO}/pspad1.${O} from ${MID}/pspad1.lisp @ (cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/pspad1.clisp"' \ + echo '(progn (compile-file "${MID}/pspad1.lisp"' \ ':output-file "${AUTO}/pspad1.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/pspad1.clisp"' \ + echo '(progn (compile-file "${MID}/pspad1.lisp"' \ ':output-file "${AUTO}/pspad1.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/pspad1.clisp: ${IN}/pspad1.boot.pamphlet - @ echo 599 making ${MID}/pspad1.clisp from ${IN}/pspad1.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/pspad1.boot.pamphlet >pspad1.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "pspad1.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "pspad1.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm pspad1.boot ) +<>= +${MID}/pspad1.lisp: ${IN}/pspad1.lisp.pamphlet + @ echo 599 making ${MID}/pspad1.lisp from ${IN}/pspad1.lisp.pamphlet + @ ${TANGLE} ${IN}/pspad1.lisp.pamphlet >${MID}/pspad1.lisp @ @@ -4693,7 +4684,7 @@ clean: <> <> -<> +<> <> <> diff --git a/src/interp/pspad1.boot.pamphlet b/src/interp/pspad1.boot.pamphlet deleted file mode 100644 index 79ad6a1..0000000 --- a/src/interp/pspad1.boot.pamphlet +++ /dev/null @@ -1,762 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pspad1.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. - -@ -<<*>>= -<> - -$escapeWords := ["always", "assert", "but", "define", - "delay", "do", "except", "export", "extend", "fix", "fluid", - "from", "generate", "goto", "import", "inline", "never", "select", - "try", "yield"] -$pileStyle := false -$commentIndentation := 8 -$braceIndentation := 8 -$doNotResetMarginIfTrue := true -$marginStack := nil -$numberOfSpills := 0 -$lineFragmentBuffer:= nil -$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) -$lineBuffer := nil -$formatForcePren := nil -$underScore := char ('__) -$rightBraceFlag := nil -$semicolonFlag := nil -$newLineWritten := nil -$comments := nil -$noColonDeclaration := false -$renameAlist := '( - (SmallInteger . SingleInteger) - (SmallFloat . DoubleFloat) - (Void . _(_)) - (xquo . exquo) - (setelt . set_!) - (_$ . _%) - (_$_$ . _$) - (_*_* . _^) - (_^_= . _~_=) - (_^ . _~)) - ---$opRenameAlist := '( --- (and . AND) --- (or . OR) --- (not . NOT)) - - ---====================================================================== --- Main Translator Function ---====================================================================== ---% lisp-fragment to boot-fragment functions -lisp2Boot x == - --entry function - $fieldNames := nil - $eltIfNil: local --changes NEW META to generate ELTs for infix dot - $pilesAreOkHere: local:= true - $commentsToPrint: local:= nil - $lineBuffer: local := nil - $braceStack: local := nil - $marginStack: local:= [0] - --$autoLine is true except when inside a try---if true, lines are allowed to break - $autoLine:= true - $lineFragmentBuffer:= nil - $bc:=0 --brace count - $m:= 0 - $c:= $m - $numberOfSpills:= 0 - $lineLength:= 80 - format x - formatOutput REVERSE $lineFragmentBuffer - [fragmentsToLine y for y in REVERSE $lineBuffer] - -fragmentsToLine fragments == - string:= lispStringList2String fragments - line:= GETSTR 240 - for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) - line - -lispStringList2String x == - null x => '"" - atom x => STRINGIMAGE x - CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) - lispStringList2String CAR x - ---% routines for buffer and margin adjustment - -formatOutput x == - for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat - startY:= rest start - for [loc,comment] in stack repeat - commentY:= rest loc - gap:= startY-commentY - gap>0 => before:= [[commentY,first loc,gap,comment],:before] - gap=0 => same:= [[startY,1,gap,comment],:same] - true => after:= [[startY,first loc,-gap,comment],:after] - if before then putOut before - if same then - [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] - line:= fragmentsToLine x - x:= - #line+#y>$lineLength => - (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) - [line,y] - consLineBuffer x - for y in extraLines repeat consLineBuffer LIST y - if after then putOut after - $commentsToPrint:= nil - -consLineBuffer x == $lineBuffer := [x,:$lineBuffer] - -putOut x == - eject ("min"/[gap for [.,.,gap,:.] in x]) - for u in orderList x repeat addComment u - -eject n == for i in 2..n repeat consLineBuffer nil - -addComment u == - for x in mkCommentLines u repeat consLineBuffer LIST x - -mkCommentLines [.,n,.,s] == - lines:= breakComments s - lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] - [:l,last]:= lines1 - [:l,fragmentsToLine [last,"_}"]] - -breakComments s == - n:= containsString(s,PNAME "ENDOFLINECHR") => - #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] - LIST SUBSTRING(s,0,n) - LIST s - -containsString(x,y) == - --if string x contains string y, return start index - for i in 0..MAXINDEX x-MAXINDEX y repeat - and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i - ---====================================================================== --- Character/String Buffer Functions ---====================================================================== -consBuffer item == - if item = '"failed" then item := 'failed - n:= - STRINGP item => 2+#item - IDENTP item => #PNAME item - #STRINGIMAGE item - columnsLeft:= $lineLength-$c - if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 - columnsLeft:= $lineLength-$c - --cheat for semicolons, strings, and delimiters: they are NEVER too long - not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => - $autoLine => - --is true except within try - formatOutput REVERSE $lineFragmentBuffer - $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) - $lineFragmentBuffer:= LIST nBlanks $c - consBuffer item - nil - $lineFragmentBuffer:= - ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] - NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] - STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] - sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] - $lineFragmentBuffer - $rightBraceFlag := item = "}" - $semicolonFlag := item = "; " --prevents consecutive semicolons - $c:= $c+n - -isSpecialBufferItem item == - item = "; " or STRINGP item => true - false - -isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") - ---====================================================================== --- Formatting/Line Control Functions ---====================================================================== -newLine() == - null $autoLine => nil - $newLineWritten := true - formatOutput REVERSE $lineFragmentBuffer - $lineFragmentBuffer:= LIST nBlanks $m - $c:= $m - -optNewLine() == - $newLineWritten => newLine() - $c - -spillLine() == - null $autoLine => nil - formatOutput REVERSE $lineFragmentBuffer - $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) - $lineFragmentBuffer:= LIST nBlanks $c - $c - -indent() == - $m:= $m+2*($numberOfSpills+1) - $marginStack:= [$m,:$marginStack] - $numberOfSpills:= 0 - $m - -undent() == --- $doNotResetMarginIfTrue=true => --- pp '"hoho" --- $c - $marginStack is [m,:r] => - $marginStack := r - $m := m - 0 - -spill(fn,a) == - u := try FUNCALL(fn,a) => u - (nearMargin() or spillLine()) and FUNCALL(fn,a) - -formatSpill(fn,a) == - u := try FUNCALL(fn,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) - w := stay or undent() - v and w - -formatSpill2(fn,f,a) == - u := try FUNCALL(fn,f,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) - w := stay or undent() - v and w - -nearMargin() == - $c=$m or $c=$m+1 => $c - ---====================================================================== --- Main Formatting Functions ---====================================================================== -format(x,:options) == - oldC:= $c - qualification := IFCAR options - newCOrNil:= - x is [op,:argl] => - if op = 'return then argl := rest argl - n := #argl - op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) - op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => - formatDollar(name,p,argl) - op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => - formatDollar1(CAR argl,CADR argl) - fn:= GET(op,"PSPAD") => formatFn(fn,x,$m,$c) - if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op - n=1 and GET(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => - formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) - n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => - formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) - formatForm x - formatAtom x - null newCOrNil => ($c:= oldC; nil) - null FIXP newCOrNil => error() - $c:= newCOrNil - - -getOp(op,kind) == - kind = 'Led => - MEMQ(op,'(_div _exquo)) => nil - GET(op,'Led) - GET(op,'Nud) - -formatDollar(name,p,argl) == - name := markMacroTran name - n := #argl - kind := (n=1 => "Nud"; "Led") - IDENTP name and GET(p,kind) => format([p,:argl],name) - formatForcePren [p,:argl] and - (try (format "$$" and formatForcePren name) - or (indent() and format "$__" and formatForcePren name and undent())) - -formatMacroCheck name == - ATOM name => name - u := or/[x for [x,:y] in $globalMacroStack | y = name] => u - u := or/[x for [x,:y] in $localMacroStack | y = name] => u - [op,:argl] := name - MEMQ(op,'(Record Union)) => - pp ['"Cannot find: ",name] - name - [op,:[formatMacroCheck x for x in argl]] - -formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) - -formatDollar1(name,arg) == - id := - IDENTP name => name - name is [p] and GET(p,'NILADIC) => p - name - format arg and format "$$" and formatForcePren id - - -formatForcePren x == - $formatForcePren: local := true - format x - -formatAtom(x,:options) == - if u := LASSOC(x,$renameAlist) then x := u - null x or isIdentifier x => - if MEMQ(x,$escapeWords) then - consBuffer $underScore - consBuffer ident2PrintImage PNAME x - consBuffer x - -formatFn(fn,x,$m,$c) == FUNCALL(fn,x) - -formatFree(['free,:u]) == - format 'free and format " " and formatComma u - -formatUnion(['Union,:r]) == - $count : local := 0 - formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == - x is [":",y,'Branch] => fn STRINGIMAGE y - STRINGP x => [":", INTERN x, ['Enumeration,x]] - x is [":",:.] => x - tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) - [":", tag, x] - -formatTestForPartial u == - u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => - ['Partial, S] - u - -formatEnumeration(y is ['Enumeration,:r]) == - r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" - formatForm y - -formatRecord(u) == formatFormNoColonDecl u - -formatFormNoColonDecl u == - $noColonDeclaration: local := true - formatForm u - -formatElt(u) == - u is ["elt",a,b] => formatApplication rest u - formatForm u - -formatForm (u) == - [op,:argl] := u - if MEMQ(op, '(Record Union)) then - $fieldNames := UNION(getFieldNames argl,$fieldNames) - MEMQ(op,'((QUOTE T) true)) => format "true" - MEMQ(op,'(false nil)) => format op - u='(Zero) => format 0 - u='(One) => format 1 - 1=#argl => formatApplication u - formatFunctionCall u - -formatFunctionCall u == - $pilesAreOkHere: local := nil - spill("formatFunctionCall1",u) - -formatFunctionCall1 [op,:argl] == ---null argl and getConstructorProperty(op,'niladic) => formatOp op - null argl => - GET(op,'NILADIC) => formatOp op - formatOp op and format "()" - formatOp op and formatFunctionCallTail argl - -formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" - -formatComma argl == - format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c - -formatOp op == - atom op => formatAtom op - formatPren op - -formatApplication u == - [op,a] := u - MEMQ(a, $fieldNames) => formatSelection u - atom op => - formatHasDotLeadOp a => formatOpPren(op,a) - formatApplication0 u - formatSelection u - -formatHasDotLeadOp u == - u is [op,:.] and (op = "." or not atom op) - -formatApplication0 u == ---format as f(x) as f x if possible - $pilesAreOkHere: local := nil - formatSpill("formatApplication1",u) - -formatApplication1 u == - [op,x] := u - formatHasDollarOp x or $formatForcePren or - pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) - try (formatOp op and format " ") and - (try formatApplication2 x or - format "(" and formatApplication2 x and format ")") - -formatHasDollarOp x == - x is ["elt",a,b] and isTypeProbably? a - -isTypeProbably? x == - IDENTP x and UPPER_-CASE_-P (PNAME x).0 - -formatOpPren(op,x) == formatOp op and formatPren x - -formatApplication2 x == - leadOp := - x is [['elt,.,y],:.] => y - opOf x - MEMQ(leadOp,'(COLLECT LIST construct)) or - pspadBindingPowerOf("left",x)<1000 => formatPren x - format x - -formatDot ["dot",a,x] == - try (formatOp a and format ".") and - ATOM x => format x - formatPren x - -formatSelection u == - $pilesAreOkHere: local := nil - formatSpill("formatSelection1",u) - -formatSelection1 [f,x] == formatSelectionOp f and format "." and - ATOM x => format x - formatPren x - -formatSelectionOp op == - op is [f,.] and not GET(f,'Nud) or - 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op - formatPren1("formatSelectionOp1",op) - -formatSelectionOp1 f == - f is [op,:argl] => - argl is [a] => - not ATOM op and ATOM a => formatSelection1 [op,a] - formatPren f - format f - formatOp f - -formatPren a == - $pilesAreOkHere: local := nil - formatSpill("formatPrenAux",a) - -formatPrenAux a == format "_(" and format a and format "_)" - -formatPren1(f,a) == - $pilesAreOkHere: local := nil - formatSpill2("formatPren1Aux",f,a) - -formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" - -formatLeft(fn,x,op,key) == - lbp:= formatOpBindingPower(op,key,"left") - formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) - FUNCALL(fn,x) - -formatRight(fn,x,op,key) == - --are there exceptional cases where piles are ok? - x is ['LET,:.] => FUNCALL(fn,x) - --decide on basis of binding power whether prens are needed - rbp := formatOpBindingPower(op,key,"right") - lbp := formatOpBindingPower(opOf x,key,"left") - lbp < rbp => formatPren1(fn,x) - FUNCALL(fn,x) - -formatCut a == formatSpill("format",a) - ---====================================================================== --- Prefix/Infix Operators ---====================================================================== -formatPrefix(op,arg,lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local := nil - formatPrefixOp(op,qualification) and - (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) - -formatPrefixOp(op,:options) == - qualification := IFCAR options - op=char '" " => format " =" - qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => - formatQual(op,qualification) and format " " - format op - -formatQual(op,D) == - null D => format op - format op and format "$$" and format D - -formatInfix(op,[a,b],lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local := nil - (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) - then formatPren b else format b) - -formatGetBindingPowerOf(leftOrRight,x) == --- this function is nearly identical with getBindingPowerOf --- leftOrRight = "left" => 0 --- 1 - pspadBindingPowerOf(leftOrRight,x) - -pspadBindingPowerOf(key,x) == - --binding powers can be found in file NEWAUX LISP - x is ['REDUCE,:.] => (key='left => 130; key='right => 0) - x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) - x is ["COND",:.] => (key="left" => 130; key="right" => 0) - x is [op,:argl] => - if op is [a,:.] then op:= a - op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 - op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) - (n:= #argl)=1 => - key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m - 1000 - n>1 => - key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m - op="ELT" => 1002 - 1000 - 1000 - 1002 - -pspadOpBindingPower(op,LedOrNud,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - MEMQ(op,'(_:)) and LedOrNud = 'Led => - leftOrRight = 'left => 195 - 196 - exception:= - leftOrRight="left" => 0 - 105 - bp:= - leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) - rightBindingPowerOf(op,LedOrNud) - bp^=exception => bp - 1000 - -formatOpBindingPower(op,key,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - op = '_$ => 1002 - MEMQ(op,'(_:)) and key = 'Led => - leftOrRight = 'left => 195 - 196 - MEMQ(op,'(_^_= _>_=)) => 400 - op = "not" and key = "Nud" => - leftOrRight = 'left => 1000 - 1001 - GET(op,key) is [.,.,:r] => - leftOrRight = 'left => KAR r or 0 - KAR KDR r or 1 - 1000 - -formatInfixOp(op,:options) == - qualification := IFCAR options - qualification or - (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " - format op - ---====================================================================== --- Special Handlers: DEF forms ---====================================================================== - -formatDEF def == formatDEF0(def,$DEFdepth + 1) - -formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == - if not MEMQ(KAR form,'(Exports Implementation)) then - $form := - form is [":",a,:.] => a - form - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $abb :local := constructor? opOf $form - if $DEFdepth < 2 then - condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] - $numberOfSpills := -1 - consComments(condoc,'"+++ ") - form := formatDeftranForm(form,tlist) - u := ["DEF",form,tlist,sclist,body] - v := formatDEF1 u => v - $insideDEF: local := $DEFdepth > 1 - $DEFdepth = 1 => - exname := 'Exports - impname := 'Implementation - form is [":",.,=exname] or body = impname => nil - exports := - form is [":",a,b] => - form := a - [["MDEF",exname,'(NIL),'(NIL),b]] - nil - [op,:argl] := form --- decls := [x for x in argl | x is [":",:.]] --- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] --- $DEFdepth := $DEFdepth - 1 - formatWHERE(["where", - ["DEF",[":",form,exname],[nil for x in form],sclist,impname], - ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) - $insideTypeExpression: local := true - body := formatDeftran(body,false) - body is ["add",a,:b] => formatAddDef(form,a,b) ---body is ["with",a,:b] => formatWithDef(form,a,b) - tryBreakNB(format form and format " == ",body,"==","Led") - -formatDEF1 ["DEF",form,tlist,b,body] == - $insideDEF: local := $DEFdepth > 1 - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - form := formatDeftran(form,false) - body := formatDeftran(body,false) - ---------> terrible, hideous, but temporary, hack - if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] - prefix := (opOf tlist = 'Category => "define "; nil) - body is ["add",a,b] => formatAddDef(form,a,b) - body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) - prefix => - tryBreak(format prefix and format form and format " == ",body,"==","Led") - tryBreak(format form and format " == ",body,"==","Led") - -formatDefForm(form,:options) == - prefix := IFCAR options - $insideTypeExpression : local := true - form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) - prefix => format prefix and format form - format form - -formatAddDef(form,a,b) == - $insideCAPSULE : local := true - $insideDEF : local := false - formatDefForm form or return nil - $marginStack := [0] - $m := $c := 0 - $insideTypeExpression : local := false - cap := (b => b; "") - tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") - and format " add ", cap,"add","Led") - -formatWithDef(form,a,b,separator,:options) == - prefix := IFCAR options - $insideEXPORTS : local := true - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - a1 := formatWithKillSEQ a - b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") - and format " with ",first b,"with","Led") - tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") - -formatWithKillSEQ x == - x is ['SEQ,['exit,.,y]] => ['BRACE, y] - x - -formatBrace ['BRACE, x] == format "{" and format x and format "}" - -formatWith ["with",a,:b] == - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatWithDefault ["withDefault",a,b] == - if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then - part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] - if IFCAR init then - a:= IFCAR init - b:= [part2] - else - a := part2 - b := nil - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatDefaultDefs ["default",a, :b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreak(formatLeft("format",a,"default","Led") and - format " default ", first b,"default","Led") - tryBreak(format "default ",a,"default","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatAdd ["add",a,:b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreakNB(formatLeft("format",a,"and","Led") and - format " and ", first b,"and","Led") - tryBreakNB(format "add ",a,"and","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatMDEF ["MDEF",form,.,.,body] == - form is '(Rep) => formatDEF ["DEF",form,.,.,body] - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - body := formatDeftran(body,false) - name := opOf form - tryBreakNB(format name and format " ==> ",body,"==","Led") - and ($insideCAPSULE and $c or format(";")) - -insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue - or $noColonDeclaration - -formatImport ["import",a] == - addFieldNames a - addFieldNames macroExpand(a,$e) - format "import from " and formatLocal1 a - -addFieldNames a == - a is [op,:r] and MEMQ(op,'(Record Union)) => - $fieldNames := UNION(getFieldNames r,$fieldNames) - a is ['List,:b] => addFieldNames b - nil - -getFieldNames r == - r is [[":",a,b],:r] => [a,:getFieldNames r] - nil - -formatLocal ["local",a] == format "local " and formatLocal1 a - -formatLocal1 a == - $insideTypeExpression: local := true - format a - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pspad1.lisp.pamphlet b/src/interp/pspad1.lisp.pamphlet new file mode 100644 index 0000000..9bc833f --- /dev/null +++ b/src/interp/pspad1.lisp.pamphlet @@ -0,0 +1,2615 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp pspad1.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;$escapeWords := ["always", "assert", "but", "define", +; "delay", "do", "except", "export", "extend", "fix", "fluid", +; "from", "generate", "goto", "import", "inline", "never", "select", +; "try", "yield"] + +(SPADLET |$escapeWords| + (CONS '|always| + (CONS '|assert| + (CONS '|but| + (CONS '|define| + (CONS '|delay| + (CONS '|do| + (CONS '|except| + (CONS '|export| + (CONS '|extend| + (CONS '|fix| + (CONS '|fluid| + (CONS '|from| + (CONS '|generate| + (CONS '|goto| + (CONS '|import| + (CONS '|inline| + (CONS '|never| + (CONS '|select| + (CONS '|try| + (CONS '|yield| + NIL))))))))))))))))))))) + +;$pileStyle := false + +(SPADLET |$pileStyle| NIL) + +;$commentIndentation := 8 + +(SPADLET |$commentIndentation| 8) + +;$braceIndentation := 8 + +(SPADLET |$braceIndentation| 8) + +;$doNotResetMarginIfTrue := true + +(SPADLET |$doNotResetMarginIfTrue| t) + +;$marginStack := nil + +(SPADLET |$marginStack| NIL) + +;$numberOfSpills := 0 + +(SPADLET |$numberOfSpills| 0) + +;$lineFragmentBuffer:= nil + +(SPADLET |$lineFragmentBuffer| NIL) + +;$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) + +(SPADLET |$pspadRelationAlist| + '((= . ~=) (< . >=) (<= . >) (~= . =) (>= . <) (> . <=))) + +;$lineBuffer := nil + +(SPADLET |$lineBuffer| NIL) + +;$formatForcePren := nil + +(SPADLET |$formatForcePren| NIL) + +;$underScore := char ('__) + +(SPADLET |$underScore| (|char| '_)) + +;$rightBraceFlag := nil + +(SPADLET |$rightBraceFlag| NIL) + +;$semicolonFlag := nil + +(SPADLET |$semicolonFlag| NIL) + +;$newLineWritten := nil + +(SPADLET |$newLineWritten| NIL) + +;$comments := nil + +(SPADLET |$comments| NIL) + +;$noColonDeclaration := false + +(SPADLET |$noColonDeclaration| NIL) + +;$renameAlist := '( +; (SmallInteger . SingleInteger) +; (SmallFloat . DoubleFloat) +; (Void . _(_)) +; (xquo . exquo) +; (setelt . set_!) +; (_$ . _%) +; (_$_$ . _$) +; (_*_* . _^) +; (_^_= . _~_=) +; (_^ . _~)) + +(SPADLET |$renameAlist| + '((|SmallInteger| . |SingleInteger|) + (|SmallFloat| . |DoubleFloat|) (|Void| . |()|) + (|xquo| . |exquo|) (|setelt| . |set!|) ($ . %) ($$ . $) + (** . ^) (^= . ~=) (^ . ~))) + +;--$opRenameAlist := '( +;-- (and . AND) +;-- (or . OR) +;-- (not . NOT)) +;--====================================================================== +;-- Main Translator Function +;--====================================================================== +;--% lisp-fragment to boot-fragment functions +;lisp2Boot x == +; --entry function +; $fieldNames := nil +; $eltIfNil: local --changes NEW META to generate ELTs for infix dot +; $pilesAreOkHere: local:= true +; $commentsToPrint: local:= nil +; $lineBuffer: local := nil +; $braceStack: local := nil +; $marginStack: local:= [0] +; --$autoLine is true except when inside a try---if true, lines are allowed to break +; $autoLine:= true +; $lineFragmentBuffer:= nil +; $bc:=0 --brace count +; $m:= 0 +; $c:= $m +; $numberOfSpills:= 0 +; $lineLength:= 80 +; format x +; formatOutput REVERSE $lineFragmentBuffer +; [fragmentsToLine y for y in REVERSE $lineBuffer] + +(DEFUN |lisp2Boot| (|x|) + (PROG (|$eltIfNil| |$pilesAreOkHere| |$commentsToPrint| |$lineBuffer| + |$braceStack| |$marginStack|) + (DECLARE (SPECIAL |$eltIfNil| |$pilesAreOkHere| |$commentsToPrint| |$bc| + |$lineBuffer| |$braceStack| |$marginStack| |$m| |$c| + |$lineFragmentBuffer| |$lineLength| |$autoLine| + |$fieldNames| |$numberOfSpills|)) + (RETURN + (SEQ (PROGN + (SPADLET |$fieldNames| NIL) + (SPADLET |$eltIfNil| NIL) + (SPADLET |$pilesAreOkHere| 'T) + (SPADLET |$commentsToPrint| NIL) + (SPADLET |$lineBuffer| NIL) + (SPADLET |$braceStack| NIL) + (SPADLET |$marginStack| (CONS 0 NIL)) + (SPADLET |$autoLine| 'T) + (SPADLET |$lineFragmentBuffer| NIL) + (SPADLET |$bc| 0) + (SPADLET |$m| 0) + (SPADLET |$c| |$m|) + (SPADLET |$numberOfSpills| 0) + (SPADLET |$lineLength| 80) + (|format| |x|) + (|formatOutput| (REVERSE |$lineFragmentBuffer|)) + (PROG (G166062) + (SPADLET G166062 NIL) + (RETURN + (DO ((G166067 (REVERSE |$lineBuffer|) + (CDR G166067)) + (|y| NIL)) + ((OR (ATOM G166067) + (PROGN (SETQ |y| (CAR G166067)) NIL)) + (NREVERSE0 G166062)) + (SEQ (EXIT (SETQ G166062 + (CONS (|fragmentsToLine| |y|) + G166062)))))))))))) + +;fragmentsToLine fragments == +; string:= lispStringList2String fragments +; line:= GETSTR 240 +; for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) +; line + +(DEFUN |fragmentsToLine| (|fragments|) + (PROG (|string| |line|) + (RETURN + (SEQ (PROGN + (SPADLET |string| (|lispStringList2String| |fragments|)) + (SPADLET |line| (GETSTR 240)) + (DO ((G166107 (MAXINDEX |string|)) (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166107) NIL) + (SEQ (EXIT (SPADLET |line| + (SUFFIX (ELT |string| |i|) |line|))))) + |line|))))) + +;lispStringList2String x == +; null x => '"" +; atom x => STRINGIMAGE x +; CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) +; lispStringList2String CAR x + +(DEFUN |lispStringList2String| (|x|) + (COND + ((NULL |x|) (MAKESTRING "")) + ((ATOM |x|) (STRINGIMAGE |x|)) + ((CDR |x|) + (APPLY (|function| STRCONC) + (MAPCAR (|function| |lispStringList2String|) |x|))) + ('T (|lispStringList2String| (CAR |x|))))) + +;--% routines for buffer and margin adjustment +; +;formatOutput x == +; for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat +; startY:= rest start +; for [loc,comment] in stack repeat +; commentY:= rest loc +; gap:= startY-commentY +; gap>0 => before:= [[commentY,first loc,gap,comment],:before] +; gap=0 => same:= [[startY,1,gap,comment],:same] +; true => after:= [[startY,first loc,-gap,comment],:after] +; if before then putOut before +; if same then +; [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] +; line:= fragmentsToLine x +; x:= +; #line+#y>$lineLength => +; (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) +; [line,y] +; consLineBuffer x +; for y in extraLines repeat consLineBuffer LIST y +; if after then putOut after +; $commentsToPrint:= nil + +(DEFUN |formatOutput| (|x|) + (PROG (|currentColumn| |start| |end| |stack| |startY| |loc| |comment| + |commentY| |gap| |before| |same| |after| |LETTMP#1| |line| + |y| |extraLines|) + (declare (special |$commentsToPrint| |$m| |$lineLength|)) + (RETURN + (SEQ (PROGN + (DO ((G166156 (REVERSE |$commentsToPrint|) + (CDR G166156)) + (G166127 NIL)) + ((OR (ATOM G166156) + (PROGN (SETQ G166127 (CAR G166156)) NIL) + (PROGN + (PROGN + (SPADLET |currentColumn| (CAR G166127)) + (SPADLET |start| (CADR G166127)) + (SPADLET |end| (CADDR G166127)) + (SPADLET |stack| (CADDDR G166127)) + G166127) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |startY| (CDR |start|)) + (DO ((G166170 |stack| (CDR G166170)) + (G166122 NIL)) + ((OR (ATOM G166170) + (PROGN + (SETQ G166122 (CAR G166170)) + NIL) + (PROGN + (PROGN + (SPADLET |loc| + (CAR G166122)) + (SPADLET |comment| + (CADR G166122)) + G166122) + NIL)) + NIL) + (SEQ (EXIT + (PROGN + (SPADLET |commentY| (CDR |loc|)) + (SPADLET |gap| + (SPADDIFFERENCE |startY| + |commentY|)) + (COND + ((> |gap| 0) + (SPADLET |before| + (CONS + (CONS |commentY| + (CONS (CAR |loc|) + (CONS |gap| + (CONS |comment| NIL)))) + |before|))) + ((EQL |gap| 0) + (SPADLET |same| + (CONS + (CONS |startY| + (CONS 1 + (CONS |gap| + (CONS |comment| NIL)))) + |same|))) + ('T + (SPADLET |after| + (CONS + (CONS |startY| + (CONS (CAR |loc|) + (CONS + (SPADDIFFERENCE |gap|) + (CONS |comment| NIL)))) + |after|)))))))))))) + (COND (|before| (|putOut| |before|))) + (COND + (|same| (SPADLET |LETTMP#1| + (PROG (G166177) + (SPADLET G166177 NIL) + (RETURN + (DO + ((G166182 (|orderList| |same|) + (CDR G166182)) + (|u| NIL)) + ((OR (ATOM G166182) + (PROGN + (SETQ |u| (CAR G166182)) + NIL)) + G166177) + (SEQ + (EXIT + (SETQ G166177 + (APPEND G166177 + (|mkCommentLines| |u|))))))))) + (SPADLET |y| (CAR |LETTMP#1|)) + (SPADLET |extraLines| (CDR |LETTMP#1|)) + (SPADLET |line| (|fragmentsToLine| |x|)) + (SPADLET |x| + (COND + ((> (PLUS (|#| |line|) (|#| |y|)) + |$lineLength|) + (SPADLET |y| + (STRCONC (|nBlanks| |$m|) |y|)) + (SPADLET |extraLines| + (CONS |y| |extraLines|)) + |x|) + ('T (CONS |line| (CONS |y| NIL))))))) + (|consLineBuffer| |x|) + (DO ((G166191 |extraLines| (CDR G166191)) (|y| NIL)) + ((OR (ATOM G166191) + (PROGN (SETQ |y| (CAR G166191)) NIL)) + NIL) + (SEQ (EXIT (|consLineBuffer| (LIST |y|))))) + (COND (|after| (|putOut| |after|))) + (SPADLET |$commentsToPrint| NIL)))))) + +;consLineBuffer x == $lineBuffer := [x,:$lineBuffer] + +(DEFUN |consLineBuffer| (|x|) + (declare (special |$lineBuffer|)) + (SPADLET |$lineBuffer| (CONS |x| |$lineBuffer|))) + +;putOut x == +; eject ("min"/[gap for [.,.,gap,:.] in x]) +; for u in orderList x repeat addComment u + +(DEFUN |putOut| (|x|) + (PROG (|gap|) + (RETURN + (SEQ (PROGN + (|eject| (PROG (G166229 G166230) + (SPADLET G166229 'G166229) + (RETURN + (DO ((G166238 |x| (CDR G166238)) + (G166225 NIL)) + ((OR (ATOM G166238) + (PROGN + (SETQ G166225 (CAR G166238)) + NIL) + (PROGN + (PROGN + (SPADLET |gap| + (CADDR G166225)) + G166225) + NIL)) + (THETACHECK G166229 'G166229 '|min|)) + (SEQ (EXIT (PROGN + (SPADLET G166230 |gap|) + (SETQ G166229 + (COND + ((EQ G166229 'G166229) + G166230) + ('T + (|min| G166229 + G166230))))))))))) + (DO ((G166248 (|orderList| |x|) (CDR G166248)) + (|u| NIL)) + ((OR (ATOM G166248) + (PROGN (SETQ |u| (CAR G166248)) NIL)) + NIL) + (SEQ (EXIT (|addComment| |u|))))))))) + +;eject n == for i in 2..n repeat consLineBuffer nil + +(DEFUN |eject| (|n|) + (SEQ (DO ((|i| 2 (QSADD1 |i|))) ((QSGREATERP |i| |n|) NIL) + (SEQ (EXIT (|consLineBuffer| NIL)))))) + +;addComment u == +; for x in mkCommentLines u repeat consLineBuffer LIST x + +(DEFUN |addComment| (|u|) + (SEQ (DO ((G166272 (|mkCommentLines| |u|) (CDR G166272)) + (|x| NIL)) + ((OR (ATOM G166272) + (PROGN (SETQ |x| (CAR G166272)) NIL)) + NIL) + (SEQ (EXIT (|consLineBuffer| (LIST |x|))))))) + +;mkCommentLines [.,n,.,s] == +; lines:= breakComments s +; lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] +; [:l,last]:= lines1 +; [:l,fragmentsToLine [last,"_}"]] + +(DEFUN |mkCommentLines| (G166286) + (PROG (|n| |s| |lines| |lines1| |LETTMP#1| |last| |l|) + (RETURN + (PROGN + (SPADLET |n| (CADR G166286)) + (SPADLET |s| (CADDDR G166286)) + (SPADLET |lines| (|breakComments| |s|)) + (SPADLET |lines1| + (CONS (|fragmentsToLine| + (CONS (|nBlanks| |n|) + (CONS '{ (CONS (CAR |lines|) NIL)))) + (CDR |lines|))) + (SPADLET |LETTMP#1| (REVERSE |lines1|)) + (SPADLET |last| (CAR |LETTMP#1|)) + (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) + (APPEND |l| + (CONS (|fragmentsToLine| (CONS |last| (CONS '} NIL))) + NIL)))))) + +;breakComments s == +; n:= containsString(s,PNAME "ENDOFLINECHR") => +; #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] +; LIST SUBSTRING(s,0,n) +; LIST s + +(DEFUN |breakComments| (|s|) + (PROG (|n|) + (RETURN + (COND + ((SPADLET |n| (|containsString| |s| (PNAME 'ENDOFLINECHR))) + (COND + ((> (|#| |s|) (PLUS |n| 12)) + (CONS (SUBSTRING |s| 0 |n|) + (|breakComments| (SUBSTRING |s| (PLUS |n| 12) NIL)))) + ('T (LIST (SUBSTRING |s| 0 |n|))))) + ('T (LIST |s|)))))) + +;containsString(x,y) == +; --if string x contains string y, return start index +; for i in 0..MAXINDEX x-MAXINDEX y repeat +; and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i + +(DEFUN |containsString| (|x| |y|) + (PROG () + (RETURN + (SEQ (DO ((G166318 + (SPADDIFFERENCE (MAXINDEX |x|) (MAXINDEX |y|))) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166318) NIL) + (SEQ (EXIT (COND + ((PROG (G166322) + (SPADLET G166322 'T) + (RETURN + (DO ((G166328 NIL (NULL G166322)) + (G166329 (MAXINDEX |y|)) + (|j| 0 (QSADD1 |j|))) + ((OR G166328 + (QSGREATERP |j| G166329)) + G166322) + (SEQ (EXIT + (SETQ G166322 + (AND G166322 + (BOOT-EQUAL + (ELT |x| (PLUS |i| |j|)) + (ELT |y| |j|))))))))) + (EXIT (RETURN |i|))))))))))) + +;--====================================================================== +;-- Character/String Buffer Functions +;--====================================================================== +;consBuffer item == +; if item = '"failed" then item := 'failed +; n:= +; STRINGP item => 2+#item +; IDENTP item => #PNAME item +; #STRINGIMAGE item +; columnsLeft:= $lineLength-$c +; if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 +; columnsLeft:= $lineLength-$c +; --cheat for semicolons, strings, and delimiters: they are NEVER too long +; not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => +; $autoLine => +; --is true except within try +; formatOutput REVERSE $lineFragmentBuffer +; $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) +; $lineFragmentBuffer:= LIST nBlanks $c +; consBuffer item +; nil +; $lineFragmentBuffer:= +; ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] +; NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] +; STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] +; sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] +; $lineFragmentBuffer +; $rightBraceFlag := item = "}" +; $semicolonFlag := item = "; " --prevents consecutive semicolons +; $c:= $c+n + +(DEFUN |consBuffer| (|item|) + (PROG (|n| |columnsLeft|) + (declare (special |$c| |$semicolonFlag| |$rightBraceFlag| |$m| |$autoLine| + |$lineFragmentBuffer| |$lineLength| |$numberOfSpills|)) + (RETURN + (PROGN + (COND + ((BOOT-EQUAL |item| (MAKESTRING "failed")) + (SPADLET |item| '|failed|))) + (SPADLET |n| + (COND + ((STRINGP |item|) (PLUS 2 (|#| |item|))) + ((IDENTP |item|) (|#| (PNAME |item|))) + ('T (|#| (STRINGIMAGE |item|))))) + (SPADLET |columnsLeft| (SPADDIFFERENCE |$lineLength| |$c|)) + (COND + ((AND (<= |columnsLeft| 0) (|isCloseDelimiter| |item|)) + (SPADLET |$lineLength| (PLUS |$lineLength| 2)))) + (SPADLET |columnsLeft| (SPADDIFFERENCE |$lineLength| |$c|)) + (COND + ((AND (NULL (|isSpecialBufferItem| |item|)) + (OR (> |n| |columnsLeft|) (MINUSP |columnsLeft|))) + (COND + (|$autoLine| + (|formatOutput| (REVERSE |$lineFragmentBuffer|)) + (SPADLET |$c| + (REMAINDER + (PLUS |$m| + (TIMES 2 + (SPADLET |$numberOfSpills| + (PLUS |$numberOfSpills| 1)))) + |$lineLength|)) + (SPADLET |$lineFragmentBuffer| + (LIST (|nBlanks| |$c|))) + (|consBuffer| |item|)) + ('T NIL))) + ('T + (SPADLET |$lineFragmentBuffer| + (COND + ((OR (NULL |item|) (IDENTP |item|)) + (CONS (PNAME |item|) |$lineFragmentBuffer|)) + ((OR (NUMBERP |item|) (CHARP |item|)) + (CONS (STRINGIMAGE |item|) + |$lineFragmentBuffer|)) + ((STRINGP |item|) + (CONS '|"| + (CONS (|string2PrintImage| |item|) + (CONS '|"| |$lineFragmentBuffer|)))) + ('T + (|sayBrightly| + (CONS (MAKESTRING + "Unexpected line buffer item: ") + (CONS (STRINGIMAGE |item|) NIL))) + |$lineFragmentBuffer|))) + (SPADLET |$rightBraceFlag| (BOOT-EQUAL |item| '})) + (SPADLET |$semicolonFlag| (BOOT-EQUAL |item| '|; |)) + (SPADLET |$c| (PLUS |$c| |n|)))))))) + +;isSpecialBufferItem item == +; item = "; " or STRINGP item => true +; false + +(DEFUN |isSpecialBufferItem| (|item|) + (COND ((OR (BOOT-EQUAL |item| '|; |) (STRINGP |item|)) 'T) ('T NIL))) + +;isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") + +(DEFUN |isCloseDelimiter| (|item|) + (OR (EQ |item| '|)|) (EQ |item| ']) (EQ |item| '}))) + +;--====================================================================== +;-- Formatting/Line Control Functions +;--====================================================================== +;newLine() == +; null $autoLine => nil +; $newLineWritten := true +; formatOutput REVERSE $lineFragmentBuffer +; $lineFragmentBuffer:= LIST nBlanks $m +; $c:= $m + +(DEFUN |newLine| () + (declare (special |$c| |$m| |$lineFragmentBuffer| |$newLineWritten| + |$autoLine|)) + (COND + ((NULL |$autoLine|) NIL) + ('T (SPADLET |$newLineWritten| 'T) + (|formatOutput| (REVERSE |$lineFragmentBuffer|)) + (SPADLET |$lineFragmentBuffer| (LIST (|nBlanks| |$m|))) + (SPADLET |$c| |$m|)))) + +;optNewLine() == +; $newLineWritten => newLine() +; $c + +(DEFUN |optNewLine| () + (declare (special |$newLineWritten| |$c|)) + (COND (|$newLineWritten| (|newLine|)) ('T |$c|))) + +;spillLine() == +; null $autoLine => nil +; formatOutput REVERSE $lineFragmentBuffer +; $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) +; $lineFragmentBuffer:= LIST nBlanks $c +; $c + +(DEFUN |spillLine| () + (declare (special |$c| |$lineFragmentBuffer| |$numberOfSpills| |$m| + |$autoLine|)) + (COND + ((NULL |$autoLine|) NIL) + ('T (|formatOutput| (REVERSE |$lineFragmentBuffer|)) + (SPADLET |$c| + (PLUS |$m| + (TIMES 2 + (SPADLET |$numberOfSpills| + (PLUS |$numberOfSpills| 1))))) + (SPADLET |$lineFragmentBuffer| (LIST (|nBlanks| |$c|))) |$c|))) + +;indent() == +; $m:= $m+2*($numberOfSpills+1) +; $marginStack:= [$m,:$marginStack] +; $numberOfSpills:= 0 +; $m + +(DEFUN |indent| () + (declare (special |$m| |$marginStack| |$numberOfSpills|)) + (PROGN + (SPADLET |$m| (PLUS |$m| (TIMES 2 (PLUS |$numberOfSpills| 1)))) + (SPADLET |$marginStack| (CONS |$m| |$marginStack|)) + (SPADLET |$numberOfSpills| 0) + |$m|)) + +;undent() == +;-- $doNotResetMarginIfTrue=true => +;-- pp '"hoho" +;-- $c +; $marginStack is [m,:r] => +; $marginStack := r +; $m := m +; 0 + +(DEFUN |undent| () + (PROG (|m| |r|) + (declare (special |$m| |$marginStack|)) + (RETURN + (COND + ((AND (PAIRP |$marginStack|) + (PROGN + (SPADLET |m| (QCAR |$marginStack|)) + (SPADLET |r| (QCDR |$marginStack|)) + 'T)) + (SPADLET |$marginStack| |r|) (SPADLET |$m| |m|)) + ('T 0))))) + +;spill(fn,a) == +; u := try FUNCALL(fn,a) => u +; (nearMargin() or spillLine()) and FUNCALL(fn,a) + +(DEFUN |spill| (|fn| |a|) + (PROG (|u|) + (RETURN + (COND + ((SPADLET |u| (|try| (FUNCALL |fn| |a|))) |u|) + ('T (AND (OR (|nearMargin|) (|spillLine|)) (FUNCALL |fn| |a|))))))) + +;formatSpill(fn,a) == +; u := try FUNCALL(fn,a) => u +; v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) +; w := stay or undent() +; v and w + +(DEFUN |formatSpill| (|fn| |a|) + (PROG (|u| |stay| |v| |w|) + (RETURN + (COND + ((SPADLET |u| (|try| (FUNCALL |fn| |a|))) |u|) + ('T + (SPADLET |v| + (AND (SPADLET |stay| + (OR (|nearMargin|) + (AND (|indent|) (|newLine|)))) + (FUNCALL |fn| |a|))) + (SPADLET |w| (OR |stay| (|undent|))) (AND |v| |w|)))))) + +;formatSpill2(fn,f,a) == +; u := try FUNCALL(fn,f,a) => u +; v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) +; w := stay or undent() +; v and w + +(DEFUN |formatSpill2| (|fn| |f| |a|) + (PROG (|u| |stay| |v| |w|) + (RETURN + (COND + ((SPADLET |u| (|try| (FUNCALL |fn| |f| |a|))) |u|) + ('T + (SPADLET |v| + (AND (SPADLET |stay| + (OR (|nearMargin|) + (AND (|indent|) (|newLine|)))) + (FUNCALL |fn| |f| |a|))) + (SPADLET |w| (OR |stay| (|undent|))) (AND |v| |w|)))))) + +;nearMargin() == +; $c=$m or $c=$m+1 => $c + +(DEFUN |nearMargin| () + (declare (special |$c| |$m|)) + (SEQ (COND + ((OR (BOOT-EQUAL |$c| |$m|) (BOOT-EQUAL |$c| (PLUS |$m| 1))) + (EXIT |$c|))))) + +;--====================================================================== +;-- Main Formatting Functions +;--====================================================================== +;format(x,:options) == +; oldC:= $c +; qualification := IFCAR options +; newCOrNil:= +; x is [op,:argl] => +; if op = 'return then argl := rest argl +; n := #argl +; op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) +; op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => +; formatDollar(name,p,argl) +; op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => +; formatDollar1(CAR argl,CADR argl) +; fn:= GET(op,"PSPAD") => formatFn(fn,x,$m,$c) +; if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op +; n=1 and GET(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => +; formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) +; n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => +; formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) +; formatForm x +; formatAtom x +; null newCOrNil => ($c:= oldC; nil) +; null FIXP newCOrNil => error() +; $c:= newCOrNil + +(DEFUN |format| (&REST G166482 &AUX |options| |x|) + (DSETQ (|x| . |options|) G166482) + (PROG (|oldC| |qualification| |argl| |n| |y| |ISTMP#1| |name| + |ISTMP#2| |p| |fn| |op| |lbp| |newCOrNil|) + (declare (special |$c| |$m|)) + (RETURN + (PROGN + (SPADLET |oldC| |$c|) + (SPADLET |qualification| (IFCAR |options|)) + (SPADLET |newCOrNil| + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T)) + (COND + ((BOOT-EQUAL |op| '|return|) + (SPADLET |argl| (CDR |argl|)))) + (SPADLET |n| (|#| |argl|)) + (COND + ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (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) + (EQ (QCAR |ISTMP#2|) + '|construct|)))))) + (|formatDollar| |y| '|construct| |argl|)) + ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |p| (QCAR |ISTMP#2|)) + 'T))))) + (UPPER-CASE-P + (ELT (STRINGIMAGE (|opOf| |name|)) 0))) + (|formatDollar| |name| |p| |argl|)) + ((AND (BOOT-EQUAL |op| '|elt|) + (UPPER-CASE-P + (ELT (STRINGIMAGE + (|opOf| (CAR |argl|))) + 0))) + (|formatDollar1| (CAR |argl|) (CADR |argl|))) + ((SPADLET |fn| (GETL |op| 'PSPAD)) + (|formatFn| |fn| |x| |$m| |$c|)) + ('T + (COND + ((MEMQ |op| '(AND OR NOT)) + (SPADLET |op| (DOWNCASE |op|)))) + (COND + ((AND (EQL |n| 1) (GETL |op| '|Nud|) + (SPADLET |lbp| + (|formatOpBindingPower| |op| + '|Nud| '|left|))) + (|formatPrefix| |op| (CAR |argl|) |lbp| + (|formatOpBindingPower| |op| '|Nud| + '|right|) + |qualification|)) + ((AND (EQL |n| 2) + (OR (BOOT-EQUAL |op| '$) + (|getOp| |op| '|Led|)) + (SPADLET |lbp| + (|formatOpBindingPower| |op| + '|Led| '|left|))) + (|formatInfix| |op| |argl| |lbp| + (|formatOpBindingPower| |op| '|Led| + '|right|) + |qualification|)) + ('T (|formatForm| |x|)))))) + ('T (|formatAtom| |x|)))) + (COND + ((NULL |newCOrNil|) (SPADLET |$c| |oldC|) NIL) + ((NULL (FIXP |newCOrNil|)) (|error|)) + ('T (SPADLET |$c| |newCOrNil|))))))) + +;getOp(op,kind) == +; kind = 'Led => +; MEMQ(op,'(_div _exquo)) => nil +; GET(op,'Led) +; GET(op,'Nud) + +(DEFUN |getOp| (|op| |kind|) + (COND + ((BOOT-EQUAL |kind| '|Led|) + (COND ((MEMQ |op| '(|div| |exquo|)) NIL) ('T (GETL |op| '|Led|)))) + ('T (GETL |op| '|Nud|)))) + +;formatDollar(name,p,argl) == +; name := markMacroTran name +; n := #argl +; kind := (n=1 => "Nud"; "Led") +; IDENTP name and GET(p,kind) => format([p,:argl],name) +; formatForcePren [p,:argl] and +; (try (format "$$" and formatForcePren name) +; or (indent() and format "$__" and formatForcePren name and undent())) + +(DEFUN |formatDollar| (|name| |p| |argl|) + (PROG (|n| |kind|) + (RETURN + (PROGN + (SPADLET |name| (|markMacroTran| |name|)) + (SPADLET |n| (|#| |argl|)) + (SPADLET |kind| (COND ((EQL |n| 1) '|Nud|) ('T '|Led|))) + (COND + ((AND (IDENTP |name|) (GETL |p| |kind|)) + (|format| (CONS |p| |argl|) |name|)) + ('T + (AND (|formatForcePren| (CONS |p| |argl|)) + (OR (|try| (AND (|format| '$$) + (|formatForcePren| |name|))) + (AND (|indent|) (|format| '$_) + (|formatForcePren| |name|) (|undent|)))))))))) + +;formatMacroCheck name == +; ATOM name => name +; u := or/[x for [x,:y] in $globalMacroStack | y = name] => u +; u := or/[x for [x,:y] in $localMacroStack | y = name] => u +; [op,:argl] := name +; MEMQ(op,'(Record Union)) => +; pp ['"Cannot find: ",name] +; name +; [op,:[formatMacroCheck x for x in argl]] + +(DEFUN |formatMacroCheck| (|name|) + (PROG (|x| |y| |u| |op| |argl|) + (declare (special |$localMacroStack| |$globalMacroStack|)) + (RETURN + (SEQ (COND + ((ATOM |name|) |name|) + ((SPADLET |u| + (PROG (G166509) + (SPADLET G166509 NIL) + (RETURN + (DO ((G166517 NIL G166509) + (G166518 |$globalMacroStack| + (CDR G166518)) + (G166496 NIL)) + ((OR G166517 (ATOM G166518) + (PROGN + (SETQ G166496 (CAR G166518)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G166496)) + (SPADLET |y| (CDR G166496)) + G166496) + NIL)) + G166509) + (SEQ (EXIT (COND + ((BOOT-EQUAL |y| |name|) + (SETQ G166509 + (OR G166509 |x|)))))))))) + |u|) + ((SPADLET |u| + (PROG (G166526) + (SPADLET G166526 NIL) + (RETURN + (DO ((G166534 NIL G166526) + (G166535 |$localMacroStack| + (CDR G166535)) + (G166500 NIL)) + ((OR G166534 (ATOM G166535) + (PROGN + (SETQ G166500 (CAR G166535)) + NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR G166500)) + (SPADLET |y| (CDR G166500)) + G166500) + NIL)) + G166526) + (SEQ (EXIT (COND + ((BOOT-EQUAL |y| |name|) + (SETQ G166526 + (OR G166526 |x|)))))))))) + |u|) + ('T (SPADLET |op| (CAR |name|)) + (SPADLET |argl| (CDR |name|)) + (COND + ((MEMQ |op| '(|Record| |Union|)) + (|pp| (CONS (MAKESTRING "Cannot find: ") + (CONS |name| NIL))) + |name|) + ('T + (CONS |op| + (PROG (G166547) + (SPADLET G166547 NIL) + (RETURN + (DO ((G166552 |argl| (CDR G166552)) + (|x| NIL)) + ((OR (ATOM G166552) + (PROGN + (SETQ |x| (CAR G166552)) + NIL)) + (NREVERSE0 G166547)) + (SEQ (EXIT (SETQ G166547 + (CONS (|formatMacroCheck| |x|) + G166547)))))))))))))))) + +;formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) + +(DEFUN |formatDOLLAR| (G166572) + (PROG (|x| |y|) + (RETURN + (PROGN + (SPADLET |x| (CADR G166572)) + (SPADLET |y| (CADDR G166572)) + (|formatDollar1| |y| |x|))))) + +;formatDollar1(name,arg) == +; id := +; IDENTP name => name +; name is [p] and GET(p,'NILADIC) => p +; name +; format arg and format "$$" and formatForcePren id + +(DEFUN |formatDollar1| (|name| |arg|) + (PROG (|p| |id|) + (RETURN + (PROGN + (SPADLET |id| + (COND + ((IDENTP |name|) |name|) + ((AND (PAIRP |name|) (EQ (QCDR |name|) NIL) + (PROGN (SPADLET |p| (QCAR |name|)) 'T) + (GETL |p| 'NILADIC)) + |p|) + ('T |name|))) + (AND (|format| |arg|) (|format| '$$) (|formatForcePren| |id|)))))) + +;formatForcePren x == +; $formatForcePren: local := true +; format x + +(DEFUN |formatForcePren| (|x|) + (PROG (|$formatForcePren|) + (DECLARE (SPECIAL |$formatForcePren|)) + (RETURN (PROGN (SPADLET |$formatForcePren| 'T) (|format| |x|))))) + +;formatAtom(x,:options) == +; if u := LASSOC(x,$renameAlist) then x := u +; null x or isIdentifier x => +; if MEMQ(x,$escapeWords) then +; consBuffer $underScore +; consBuffer ident2PrintImage PNAME x +; consBuffer x + +(DEFUN |formatAtom| (&REST G166607 &AUX |options| |x|) + (DSETQ (|x| . |options|) G166607) + (PROG (|u|) + (declare (special |$underScore| |$escapeWords| |$renameAlist|)) + (RETURN + (PROGN + (COND + ((SPADLET |u| (LASSOC |x| |$renameAlist|)) (SPADLET |x| |u|))) + (COND + ((OR (NULL |x|) (|isIdentifier| |x|)) + (COND + ((MEMQ |x| |$escapeWords|) (|consBuffer| |$underScore|))) + (|consBuffer| (|ident2PrintImage| (PNAME |x|)))) + ('T (|consBuffer| |x|))))))) + +;formatFn(fn,x,$m,$c) == FUNCALL(fn,x) + +(DEFUN |formatFn| (|fn| |x| |$m| |$c|) + (DECLARE (SPECIAL |$m| |$c|)) + (FUNCALL |fn| |x|)) + +;formatFree(['free,:u]) == +; format 'free and format " " and formatComma u + +(DEFUN |formatFree| (G166612) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (CDR G166612)) + (AND (|format| '|free|) (|format| '| |) (|formatComma| |u|)))))) + +;formatUnion(['Union,:r]) == +; $count : local := 0 +; formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == +; x is [":",y,'Branch] => fn STRINGIMAGE y +; STRINGP x => [":", INTERN x, ['Enumeration,x]] +; x is [":",:.] => x +; tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) +; [":", tag, x] + +(DEFUN |formatUnion,fn| (|x|) + (PROG (|ISTMP#1| |y| |ISTMP#2| |tag|) + (declare (special |$count|)) + (RETURN + (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) + (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) + (EQ (QCAR |ISTMP#2|) '|Branch|)))))) + (EXIT (|formatUnion,fn| (STRINGIMAGE |y|)))) + (IF (STRINGP |x|) + (EXIT (CONS '|:| + (CONS (INTERN |x|) + (CONS (CONS '|Enumeration| + (CONS |x| NIL)) + NIL))))) + (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|:|)) (EXIT |x|)) + (SPADLET |tag| + (INTERN (STRCONC '|value| + (STRINGIMAGE + (SPADLET |$count| + (PLUS |$count| 1)))))) + (EXIT (CONS '|:| (CONS |tag| (CONS |x| NIL)))))))) + +(DEFUN |formatUnion| (G166644) + (PROG (|$count| |r|) + (DECLARE (SPECIAL |$count|)) + (RETURN + (SEQ (PROGN + (SPADLET |r| (CDR G166644)) + (SPADLET |$count| 0) + (|formatFormNoColonDecl| + (|formatTestForPartial| + (CONS '|Union| + (PROG (G166655) + (SPADLET G166655 NIL) + (RETURN + (DO ((G166660 |r| (CDR G166660)) + (|x| NIL)) + ((OR (ATOM G166660) + (PROGN + (SETQ |x| (CAR G166660)) + NIL)) + (NREVERSE0 G166655)) + (SEQ (EXIT + (SETQ G166655 + (CONS (|formatUnion,fn| |x|) + G166655))))))))))))))) + +;formatTestForPartial u == +; u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => +; ['Partial, S] +; u + +(DEFUN |formatTestForPartial| (|u|) + (PROG (|a| |b| |ISTMP#1| |ISTMP#2| S) + (RETURN + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Union|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (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|)) 'T))))) + (PAIRP |b|) (EQ (QCAR |b|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |b|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|failed|))) + (PAIRP |a|) (EQ (QCAR |a|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET S (QCAR |ISTMP#2|)) 'T)))))) + (CONS '|Partial| (CONS S NIL))) + ('T |u|))))) + +;formatEnumeration(y is ['Enumeration,:r]) == +; r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" +; formatForm y + +(DEFUN |formatEnumeration| (|y|) + (PROG (|r| |x|) + (RETURN + (PROGN + (SPADLET |r| (CDR |y|)) + (COND + ((AND (PAIRP |r|) (EQ (QCDR |r|) NIL) + (PROGN (SPADLET |x| (QCAR |r|)) 'T)) + (AND (|format| '|'|) (|format| (INTERN (STRINGIMAGE |x|))) + (|format| '|'|))) + ('T (|formatForm| |y|))))))) + +;formatRecord(u) == formatFormNoColonDecl u + +(DEFUN |formatRecord| (|u|) (|formatFormNoColonDecl| |u|)) + +;formatFormNoColonDecl u == +; $noColonDeclaration: local := true +; formatForm u + +(DEFUN |formatFormNoColonDecl| (|u|) + (PROG (|$noColonDeclaration|) + (DECLARE (SPECIAL |$noColonDeclaration|)) + (RETURN + (PROGN (SPADLET |$noColonDeclaration| 'T) (|formatForm| |u|))))) + +;formatElt(u) == +; u is ["elt",a,b] => formatApplication rest u +; formatForm u + +(DEFUN |formatElt| (|u|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|elt|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (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|)) 'T)))))) + (|formatApplication| (CDR |u|))) + ('T (|formatForm| |u|)))))) + +;formatForm (u) == +; [op,:argl] := u +; if MEMQ(op, '(Record Union)) then +; $fieldNames := UNION(getFieldNames argl,$fieldNames) +; MEMQ(op,'((QUOTE T) true)) => format "true" +; MEMQ(op,'(false nil)) => format op +; u='(Zero) => format 0 +; u='(One) => format 1 +; 1=#argl => formatApplication u +; formatFunctionCall u + +(DEFUN |formatForm| (|u|) + (PROG (|op| |argl|) + (declare (special |$fieldNames|)) + (RETURN + (PROGN + (SPADLET |op| (CAR |u|)) + (SPADLET |argl| (CDR |u|)) + (COND + ((MEMQ |op| '(|Record| |Union|)) + (SPADLET |$fieldNames| + (|union| (|getFieldNames| |argl|) |$fieldNames|)))) + (COND + ((MEMQ |op| '('T |true|)) (|format| '|true|)) + ((MEMQ |op| '(|false| |nil|)) (|format| |op|)) + ((BOOT-EQUAL |u| '(|Zero|)) (|format| 0)) + ((BOOT-EQUAL |u| '(|One|)) (|format| 1)) + ((EQL 1 (|#| |argl|)) (|formatApplication| |u|)) + ('T (|formatFunctionCall| |u|))))))) + +;formatFunctionCall u == +; $pilesAreOkHere: local := nil +; spill("formatFunctionCall1",u) + +(DEFUN |formatFunctionCall| (|u|) + (PROG (|$pilesAreOkHere|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (SPADLET |$pilesAreOkHere| NIL) + (|spill| '|formatFunctionCall1| |u|))))) + +;formatFunctionCall1 [op,:argl] == +;--null argl and getConstructorProperty(op,'niladic) => formatOp op +; null argl => +; GET(op,'NILADIC) => formatOp op +; formatOp op and format "()" +; formatOp op and formatFunctionCallTail argl + +(DEFUN |formatFunctionCall1| (G166781) + (PROG (|op| |argl|) + (RETURN + (PROGN + (SPADLET |op| (CAR G166781)) + (SPADLET |argl| (CDR G166781)) + (COND + ((NULL |argl|) + (COND + ((GETL |op| 'NILADIC) (|formatOp| |op|)) + ('T (AND (|formatOp| |op|) (|format| '|()|))))) + ('T + (AND (|formatOp| |op|) (|formatFunctionCallTail| |argl|)))))))) + +;formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" + +(DEFUN |formatFunctionCallTail| (|argl|) + (AND (|format| '|(|) (|formatComma| |argl|) (|format| '|)|))) + +;formatComma argl == +; format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c + +(DEFUN |formatComma| (|argl|) + (PROG () + (declare (special |$c|)) + (RETURN + (SEQ (AND (|format| (CAR |argl|)) + (PROG (G166798) + (SPADLET G166798 'T) + (RETURN + (DO ((G166804 NIL (NULL G166798)) + (G166805 (CDR |argl|) (CDR G166805)) + (|x| NIL)) + ((OR G166804 (ATOM G166805) + (PROGN (SETQ |x| (CAR G166805)) NIL)) + G166798) + (SEQ (EXIT (SETQ G166798 + (AND G166798 + (AND (|format| '|,|) + (|formatCut| |x|))))))))) + |$c|))))) + +;formatOp op == +; atom op => formatAtom op +; formatPren op + +(DEFUN |formatOp| (|op|) + (COND ((ATOM |op|) (|formatAtom| |op|)) ('T (|formatPren| |op|)))) + +;formatApplication u == +; [op,a] := u +; MEMQ(a, $fieldNames) => formatSelection u +; atom op => +; formatHasDotLeadOp a => formatOpPren(op,a) +; formatApplication0 u +; formatSelection u + +(DEFUN |formatApplication| (|u|) + (PROG (|op| |a|) + (declare (special |$fieldNames|)) + (RETURN + (PROGN + (SPADLET |op| (CAR |u|)) + (SPADLET |a| (CADR |u|)) + (COND + ((MEMQ |a| |$fieldNames|) (|formatSelection| |u|)) + ((ATOM |op|) + (COND + ((|formatHasDotLeadOp| |a|) (|formatOpPren| |op| |a|)) + ('T (|formatApplication0| |u|)))) + ('T (|formatSelection| |u|))))))) + +;formatHasDotLeadOp u == +; u is [op,:.] and (op = "." or not atom op) + +(DEFUN |formatHasDotLeadOp| (|u|) + (PROG (|op|) + (RETURN + (AND (PAIRP |u|) (PROGN (SPADLET |op| (QCAR |u|)) 'T) + (OR (BOOT-EQUAL |op| (INTERN "." "BOOT")) + (NULL (ATOM |op|))))))) + +;formatApplication0 u == +;--format as f(x) as f x if possible +; $pilesAreOkHere: local := nil +; formatSpill("formatApplication1",u) + +(DEFUN |formatApplication0| (|u|) + (PROG (|$pilesAreOkHere|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (SPADLET |$pilesAreOkHere| NIL) + (|formatSpill| '|formatApplication1| |u|))))) + +;formatApplication1 u == +; [op,x] := u +; formatHasDollarOp x or $formatForcePren or +; pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) +; try (formatOp op and format " ") and +; (try formatApplication2 x or +; format "(" and formatApplication2 x and format ")") + +(DEFUN |formatApplication1| (|u|) + (PROG (|op| |x|) + (declare (special |$formatForcePren|)) + (RETURN + (PROGN + (SPADLET |op| (CAR |u|)) + (SPADLET |x| (CADR |u|)) + (COND + ((OR (|formatHasDollarOp| |x|) |$formatForcePren| + (> 1000 (|pspadBindingPowerOf| '|left| |x|))) + (|formatOpPren| |op| |x|)) + ('T + (AND (|try| (AND (|formatOp| |op|) (|format| '| |))) + (OR (|try| (|formatApplication2| |x|)) + (AND (|format| '|(|) (|formatApplication2| |x|) + (|format| '|)|)))))))))) + +;formatHasDollarOp x == +; x is ["elt",a,b] and isTypeProbably? a + +(DEFUN |formatHasDollarOp| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) + (PROGN + (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|)) 'T))))) + (|isTypeProbably?| |a|))))) + +;isTypeProbably? x == +; IDENTP x and UPPER_-CASE_-P (PNAME x).0 + +(DEFUN |isTypeProbably?| (|x|) + (AND (IDENTP |x|) (UPPER-CASE-P (ELT (PNAME |x|) 0)))) + +;formatOpPren(op,x) == formatOp op and formatPren x + +(DEFUN |formatOpPren| (|op| |x|) + (AND (|formatOp| |op|) (|formatPren| |x|))) + +;formatApplication2 x == +; leadOp := +; x is [['elt,.,y],:.] => y +; opOf x +; MEMQ(leadOp,'(COLLECT LIST construct)) or +; pspadBindingPowerOf("left",x)<1000 => formatPren x +; format x + +(DEFUN |formatApplication2| (|x|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |y| |leadOp|) + (RETURN + (PROGN + (SPADLET |leadOp| + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|elt|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#3|)) + 'T)))))))) + |y|) + ('T (|opOf| |x|)))) + (COND + ((OR (MEMQ |leadOp| '(COLLECT LIST |construct|)) + (> 1000 (|pspadBindingPowerOf| '|left| |x|))) + (|formatPren| |x|)) + ('T (|format| |x|))))))) + +;formatDot ["dot",a,x] == +; try (formatOp a and format ".") and +; ATOM x => format x +; formatPren x + +(DEFUN |formatDot| (G166908) + (PROG (|a| |x|) + (RETURN + (PROGN + (COND ((EQ (CAR G166908) '|dot|) (CAR G166908))) + (SPADLET |a| (CADR G166908)) + (SPADLET |x| (CADDR G166908)) + (AND (|try| (AND (|formatOp| |a|) + (|format| (INTERN "." "BOOT")))) + (COND + ((ATOM |x|) (|format| |x|)) + ('T (|formatPren| |x|)))))))) + +;formatSelection u == +; $pilesAreOkHere: local := nil +; formatSpill("formatSelection1",u) + +(DEFUN |formatSelection| (|u|) + (PROG (|$pilesAreOkHere|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (SPADLET |$pilesAreOkHere| NIL) + (|formatSpill| '|formatSelection1| |u|))))) + +;formatSelection1 [f,x] == formatSelectionOp f and format "." and +; ATOM x => format x +; formatPren x + +(DEFUN |formatSelection1| (G166932) + (PROG (|f| |x|) + (RETURN + (PROGN + (SPADLET |f| (CAR G166932)) + (SPADLET |x| (CADR G166932)) + (AND (|formatSelectionOp| |f|) (|format| (INTERN "." "BOOT")) + (COND + ((ATOM |x|) (|format| |x|)) + ('T (|formatPren| |x|)))))))) + +;formatSelectionOp op == +; op is [f,.] and not GET(f,'Nud) or +; 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op +; formatPren1("formatSelectionOp1",op) + +(DEFUN |formatSelectionOp| (|op|) + (PROG (|f| |ISTMP#1|) + (RETURN + (COND + ((OR (AND (PAIRP |op|) + (PROGN + (SPADLET |f| (QCAR |op|)) + (SPADLET |ISTMP#1| (QCDR |op|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) + (NULL (GETL |f| '|Nud|))) + (> (|pspadBindingPowerOf| '|right| |op|) 1000)) + (|formatSelectionOp1| |op|)) + ('T (|formatPren1| '|formatSelectionOp1| |op|)))))) + +;formatSelectionOp1 f == +; f is [op,:argl] => +; argl is [a] => +; not ATOM op and ATOM a => formatSelection1 [op,a] +; formatPren f +; format f +; formatOp f + +(DEFUN |formatSelectionOp1| (|f|) + (PROG (|op| |argl| |a|) + (RETURN + (COND + ((AND (PAIRP |f|) + (PROGN + (SPADLET |op| (QCAR |f|)) + (SPADLET |argl| (QCDR |f|)) + 'T)) + (COND + ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL) + (PROGN (SPADLET |a| (QCAR |argl|)) 'T)) + (COND + ((AND (NULL (ATOM |op|)) (ATOM |a|)) + (|formatSelection1| (CONS |op| (CONS |a| NIL)))) + ('T (|formatPren| |f|)))) + ('T (|format| |f|)))) + ('T (|formatOp| |f|)))))) + +;formatPren a == +; $pilesAreOkHere: local := nil +; formatSpill("formatPrenAux",a) + +(DEFUN |formatPren| (|a|) + (PROG (|$pilesAreOkHere|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (SPADLET |$pilesAreOkHere| NIL) + (|formatSpill| '|formatPrenAux| |a|))))) + +;formatPrenAux a == format "_(" and format a and format "_)" + +(DEFUN |formatPrenAux| (|a|) + (AND (|format| '|(|) (|format| |a|) (|format| '|)|))) + +;formatPren1(f,a) == +; $pilesAreOkHere: local := nil +; formatSpill2("formatPren1Aux",f,a) + +(DEFUN |formatPren1| (|f| |a|) + (PROG (|$pilesAreOkHere|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (SPADLET |$pilesAreOkHere| NIL) + (|formatSpill2| '|formatPren1Aux| |f| |a|))))) + +;formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" + +(DEFUN |formatPren1Aux| (|f| |a|) + (AND (|format| '|(|) (FUNCALL |f| |a|) (|format| '|)|))) + +;formatLeft(fn,x,op,key) == +; lbp:= formatOpBindingPower(op,key,"left") +; formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) +; FUNCALL(fn,x) + +(DEFUN |formatLeft| (|fn| |x| |op| |key|) + (PROG (|lbp|) + (RETURN + (PROGN + (SPADLET |lbp| (|formatOpBindingPower| |op| |key| '|left|)) + (COND + ((> |lbp| + (|formatOpBindingPower| (|opOf| |x|) |key| '|right|)) + (|formatPren1| |fn| |x|)) + ('T (FUNCALL |fn| |x|))))))) + +;formatRight(fn,x,op,key) == +; --are there exceptional cases where piles are ok? +; x is ['LET,:.] => FUNCALL(fn,x) +; --decide on basis of binding power whether prens are needed +; rbp := formatOpBindingPower(op,key,"right") +; lbp := formatOpBindingPower(opOf x,key,"left") +; lbp < rbp => formatPren1(fn,x) +; FUNCALL(fn,x) + +(DEFUN |formatRight| (|fn| |x| |op| |key|) + (PROG (|rbp| |lbp|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET)) (FUNCALL |fn| |x|)) + ('T + (SPADLET |rbp| (|formatOpBindingPower| |op| |key| '|right|)) + (SPADLET |lbp| + (|formatOpBindingPower| (|opOf| |x|) |key| '|left|)) + (COND + ((> |rbp| |lbp|) (|formatPren1| |fn| |x|)) + ('T (FUNCALL |fn| |x|)))))))) + +;formatCut a == formatSpill("format",a) + +(DEFUN |formatCut| (|a|) (|formatSpill| '|format| |a|)) + +;--====================================================================== +;-- Prefix/Infix Operators +;--====================================================================== +;formatPrefix(op,arg,lbp,rbp,:options) == +; qualification := IFCAR options +; $pilesAreOkHere: local := nil +; formatPrefixOp(op,qualification) and +; (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) + +(DEFUN |formatPrefix| + (&REST G167012 &AUX |options| |rbp| |lbp| |arg| |op|) + (DSETQ (|op| |arg| |lbp| |rbp| . |options|) G167012) + (PROG (|$pilesAreOkHere| |qualification|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (SPADLET |qualification| (IFCAR |options|)) + (SPADLET |$pilesAreOkHere| NIL) + (AND (|formatPrefixOp| |op| |qualification|) + (COND + ((> |rbp| (|formatGetBindingPowerOf| '|left| |arg|)) + (|formatPren| |arg|)) + ('T (|format| |arg|)))))))) + +;formatPrefixOp(op,:options) == +; qualification := IFCAR options +; op=char '" " => format " =" +; qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => +; formatQual(op,qualification) and format " " +; format op + +(DEFUN |formatPrefixOp| (&REST G167018 &AUX |options| |op|) + (DSETQ (|op| . |options|) G167018) + (PROG (|qualification|) + (declare (special |$spadTightList|)) + (RETURN + (PROGN + (SPADLET |qualification| (IFCAR |options|)) + (COND + ((BOOT-EQUAL |op| (|char| (MAKESTRING " "))) + (|format| '| =|)) + ((OR |qualification| + (AND (GETL |op| '|Nud|) + (NULL (MEMQ |op| |$spadTightList|)))) + (AND (|formatQual| |op| |qualification|) (|format| '| |))) + ('T (|format| |op|))))))) + +;formatQual(op,D) == +; null D => format op +; format op and format "$$" and format D + +(DEFUN |formatQual| (|op| D) + (COND + ((NULL D) (|format| |op|)) + ('T (AND (|format| |op|) (|format| '$$) (|format| D))))) + +;formatInfix(op,[a,b],lbp,rbp,:options) == +; qualification := IFCAR options +; $pilesAreOkHere: local := nil +; (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) +; then formatPren b else format b) + +(DEFUN |formatInfix| + (&REST G167042 &AUX |options| |rbp| |lbp| G167024 |op|) + (DSETQ (|op| G167024 |lbp| |rbp| . |options|) G167042) + (PROG (|$pilesAreOkHere| |a| |b| |qualification|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (SPADLET |a| (CAR G167024)) + (SPADLET |b| (CADR G167024)) + (SPADLET |qualification| (IFCAR |options|)) + (SPADLET |$pilesAreOkHere| NIL) + (AND (COND + ((> |lbp| (|formatGetBindingPowerOf| '|right| |a|)) + (|formatPren| |a|)) + ('T (|format| |a|))) + (|formatInfixOp| |op| |qualification|) + (COND + ((> |rbp| (|formatGetBindingPowerOf| '|left| |b|)) + (|formatPren| |b|)) + ('T (|format| |b|)))))))) + +;formatGetBindingPowerOf(leftOrRight,x) == +;-- this function is nearly identical with getBindingPowerOf +;-- leftOrRight = "left" => 0 +;-- 1 +; pspadBindingPowerOf(leftOrRight,x) + +(DEFUN |formatGetBindingPowerOf| (|leftOrRight| |x|) + (|pspadBindingPowerOf| |leftOrRight| |x|)) + +;pspadBindingPowerOf(key,x) == +; --binding powers can be found in file NEWAUX LISP +; x is ['REDUCE,:.] => (key='left => 130; key='right => 0) +; x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) +; x is ["COND",:.] => (key="left" => 130; key="right" => 0) +; x is [op,:argl] => +; if op is [a,:.] then op:= a +; op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 +; op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) +; (n:= #argl)=1 => +; key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m +; key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m +; 1000 +; n>1 => +; key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m +; key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m +; op="ELT" => 1002 +; 1000 +; 1000 +; 1002 + +(DEFUN |pspadBindingPowerOf| (|key| |x|) + (PROG (|argl| |a| |op| |n| |m|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'REDUCE)) + (COND + ((BOOT-EQUAL |key| '|left|) 130) + ((BOOT-EQUAL |key| '|right|) 0))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'REPEAT)) + (COND + ((BOOT-EQUAL |key| '|left|) 130) + ((BOOT-EQUAL |key| '|right|) 0))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'COND)) + (COND + ((BOOT-EQUAL |key| '|left|) 130) + ((BOOT-EQUAL |key| '|right|) 0))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + 'T)) + (COND + ((AND (PAIRP |op|) (PROGN (SPADLET |a| (QCAR |op|)) 'T)) + (SPADLET |op| |a|))) + (COND + ((BOOT-EQUAL |op| 'SLASH) + (SPADDIFFERENCE + (|pspadBindingPowerOf| |key| (CONS '/ |argl|)) 1)) + ((BOOT-EQUAL |op| 'OVER) + (|pspadBindingPowerOf| |key| (CONS '/ |argl|))) + ((EQL (SPADLET |n| (|#| |argl|)) 1) + (COND + ((AND (BOOT-EQUAL |key| '|left|) + (SPADLET |m| + (|pspadOpBindingPower| |op| '|Nud| + '|left|))) + |m|) + ((AND (BOOT-EQUAL |key| '|right|) + (SPADLET |m| + (|pspadOpBindingPower| |op| '|Nud| + '|right|))) + |m|) + ('T 1000))) + ((> |n| 1) + (COND + ((AND (BOOT-EQUAL |key| '|left|) + (SPADLET |m| + (|pspadOpBindingPower| |op| '|Led| + '|left|))) + |m|) + ((AND (BOOT-EQUAL |key| '|right|) + (SPADLET |m| + (|pspadOpBindingPower| |op| '|Led| + '|right|))) + |m|) + ((BOOT-EQUAL |op| 'ELT) 1002) + ('T 1000))) + ('T 1000))) + ('T 1002))))) + +;pspadOpBindingPower(op,LedOrNud,leftOrRight) == +; if op in '(SLASH OVER) then op := "/" +; MEMQ(op,'(_:)) and LedOrNud = 'Led => +; leftOrRight = 'left => 195 +; 196 +; exception:= +; leftOrRight="left" => 0 +; 105 +; bp:= +; leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) +; rightBindingPowerOf(op,LedOrNud) +; bp^=exception => bp +; 1000 + +(DEFUN |pspadOpBindingPower| (|op| |LedOrNud| |leftOrRight|) + (PROG (|exception| |bp|) + (RETURN + (PROGN + (COND ((|member| |op| '(SLASH OVER)) (SPADLET |op| '/))) + (COND + ((AND (MEMQ |op| '(|:|)) (BOOT-EQUAL |LedOrNud| '|Led|)) + (COND ((BOOT-EQUAL |leftOrRight| '|left|) 195) ('T 196))) + ('T + (SPADLET |exception| + (COND + ((BOOT-EQUAL |leftOrRight| '|left|) 0) + ('T 105))) + (SPADLET |bp| + (COND + ((BOOT-EQUAL |leftOrRight| '|left|) + (|leftBindingPowerOf| |op| |LedOrNud|)) + ('T (|rightBindingPowerOf| |op| |LedOrNud|)))) + (COND ((NEQUAL |bp| |exception|) |bp|) ('T 1000)))))))) + +;formatOpBindingPower(op,key,leftOrRight) == +; if op in '(SLASH OVER) then op := "/" +; op = '_$ => 1002 +; MEMQ(op,'(_:)) and key = 'Led => +; leftOrRight = 'left => 195 +; 196 +; MEMQ(op,'(_^_= _>_=)) => 400 +; op = "not" and key = "Nud" => +; leftOrRight = 'left => 1000 +; 1001 +; GET(op,key) is [.,.,:r] => +; leftOrRight = 'left => KAR r or 0 +; KAR KDR r or 1 +; 1000 + +(DEFUN |formatOpBindingPower| (|op| |key| |leftOrRight|) + (PROG (|ISTMP#1| |ISTMP#2| |r|) + (RETURN + (PROGN + (COND ((|member| |op| '(SLASH OVER)) (SPADLET |op| '/))) + (COND + ((BOOT-EQUAL |op| '$) 1002) + ((AND (MEMQ |op| '(|:|)) (BOOT-EQUAL |key| '|Led|)) + (COND ((BOOT-EQUAL |leftOrRight| '|left|) 195) ('T 196))) + ((MEMQ |op| '(^= >=)) 400) + ((AND (BOOT-EQUAL |op| '|not|) (BOOT-EQUAL |key| '|Nud|)) + (COND ((BOOT-EQUAL |leftOrRight| '|left|) 1000) ('T 1001))) + ((PROGN + (SPADLET |ISTMP#1| (GETL |op| |key|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN (SPADLET |r| (QCDR |ISTMP#2|)) 'T))))) + (COND + ((BOOT-EQUAL |leftOrRight| '|left|) (OR (KAR |r|) 0)) + ('T (OR (KAR (KDR |r|)) 1)))) + ('T 1000)))))) + +;formatInfixOp(op,:options) == +; qualification := IFCAR options +; qualification or +; (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " +; format op + +(DEFUN |formatInfixOp| (&REST G167104 &AUX |options| |op|) + (DSETQ (|op| . |options|) G167104) + (PROG (|qualification|) + (declare (special |$spadTightList|)) + (RETURN + (PROGN + (SPADLET |qualification| (IFCAR |options|)) + (COND + ((OR |qualification| + (AND (NEQUAL |op| '$) + (NULL (MEMQ |op| |$spadTightList|)))) + (AND (|format| '| |) (|formatQual| |op| |qualification|) + (|format| '| |))) + ('T (|format| |op|))))))) + +;--====================================================================== +;-- Special Handlers: DEF forms +;--====================================================================== +;formatDEF def == formatDEF0(def,$DEFdepth + 1) + +(DEFUN |formatDEF| (|def|) + (declare (special |$DEFdepth|)) + (|formatDEF0| |def| (PLUS |$DEFdepth| 1))) + +;formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == +; if not MEMQ(KAR form,'(Exports Implementation)) then +; $form := +; form is [":",a,:.] => a +; form +; con := opOf $form +; $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) +; $abb :local := constructor? opOf $form +; if $DEFdepth < 2 then +; condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] +; $numberOfSpills := -1 +; consComments(condoc,'"+++ ") +; form := formatDeftranForm(form,tlist) +; u := ["DEF",form,tlist,sclist,body] +; v := formatDEF1 u => v +; $insideDEF: local := $DEFdepth > 1 +; $DEFdepth = 1 => +; exname := 'Exports +; impname := 'Implementation +; form is [":",.,=exname] or body = impname => nil +; exports := +; form is [":",a,b] => +; form := a +; [["MDEF",exname,'(NIL),'(NIL),b]] +; nil +; [op,:argl] := form +;-- decls := [x for x in argl | x is [":",:.]] +;-- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] +;-- $DEFdepth := $DEFdepth - 1 +; formatWHERE(["where", +; ["DEF",[":",form,exname],[nil for x in form],sclist,impname], +; ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) +; $insideTypeExpression: local := true +; body := formatDeftran(body,false) +; body is ["add",a,:b] => formatAddDef(form,a,b) +;--body is ["with",a,:b] => formatWithDef(form,a,b) +; tryBreakNB(format form and format " == ",body,"==","Led") + +(DEFUN |formatDEF0| (G167151 |$DEFdepth|) + (DECLARE (SPECIAL |$DEFdepth|)) + (PROG (|$comments| |$abb| |$insideDEF| |$insideTypeExpression| + |tlist| |sclist| |con| |condoc| |u| |v| |exname| |impname| + |ISTMP#2| |form| |exports| |op| |argl| |body| |ISTMP#1| |a| + |b|) + (DECLARE (SPECIAL |$comments| |$abb| |$insideDEF| |$numberOfSpills| + |$insideTypeExpression| |$form|)) + (RETURN + (SEQ (PROGN + (COND ((EQ (CAR G167151) 'DEF) (CAR G167151))) + (SPADLET |form| (CADR G167151)) + (SPADLET |tlist| (CADDR G167151)) + (SPADLET |sclist| (CADDDR G167151)) + (SPADLET |body| (CAR (CDDDDR G167151))) + (COND + ((NULL (MEMQ (KAR |form|) '(|Exports| |Implementation|))) + (SPADLET |$form| + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + 'T)))) + |a|) + ('T |form|))))) + (SPADLET |con| (|opOf| |$form|)) + (SPADLET |$comments| + (MSUBST '$ '% (GETDATABASE |con| 'DOCUMENTATION))) + (SPADLET |$abb| (|constructor?| (|opOf| |$form|))) + (COND + ((> 2 |$DEFdepth|) + (SPADLET |condoc| + (OR (AND (SPADLET |u| + (LASSOC '|constructor| + |$comments|)) + (KDR (KAR |u|))) + (CONS (MAKESTRING "") NIL))) + (SPADLET |$numberOfSpills| (SPADDIFFERENCE 1)) + (|consComments| |condoc| (MAKESTRING "+++ ")))) + (SPADLET |form| (|formatDeftranForm| |form| |tlist|)) + (SPADLET |u| + (CONS 'DEF + (CONS |form| + (CONS |tlist| + (CONS |sclist| + (CONS |body| NIL)))))) + (COND + ((SPADLET |v| (|formatDEF1| |u|)) |v|) + ('T (SPADLET |$insideDEF| (> |$DEFdepth| 1)) + (COND + ((EQL |$DEFdepth| 1) (SPADLET |exname| '|Exports|) + (SPADLET |impname| '|Implementation|) + (COND + ((OR (AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) + |exname|)))))) + (BOOT-EQUAL |body| |impname|)) + NIL) + ('T + (SPADLET |exports| + (COND + ((AND (PAIRP |form|) + (EQ (QCAR |form|) '|:|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |form|)) + (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|)) + 'T)))))) + (SPADLET |form| |a|) + (CONS (CONS 'MDEF + (CONS |exname| + (CONS '(NIL) + (CONS '(NIL) (CONS |b| NIL))))) + NIL)) + ('T NIL))) + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (|formatWHERE| + (CONS '|where| + (CONS (CONS 'DEF + (CONS + (CONS '|:| + (CONS |form| + (CONS |exname| NIL))) + (CONS + (PROG (G167193) + (SPADLET G167193 NIL) + (RETURN + (DO + ((G167198 |form| + (CDR G167198)) + (|x| NIL)) + ((OR (ATOM G167198) + (PROGN + (SETQ |x| + (CAR G167198)) + NIL)) + (NREVERSE0 G167193)) + (SEQ + (EXIT + (SETQ G167193 + (CONS NIL G167193))))))) + (CONS |sclist| + (CONS |impname| NIL))))) + (CONS + (CONS 'PROGN + (APPEND |exports| + (CONS + (CONS 'MDEF + (CONS |impname| + (CONS '(NIL) + (CONS '(NIL) + (CONS |body| NIL))))) + NIL))) + NIL))))))) + ('T (SPADLET |$insideTypeExpression| 'T) + (SPADLET |body| (|formatDeftran| |body| NIL)) + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |b| (QCDR |ISTMP#1|)) + 'T)))) + (|formatAddDef| |form| |a| |b|)) + ('T + (|tryBreakNB| + (AND (|format| |form|) (|format| '| == |)) + |body| '== '|Led|)))))))))))) + +;formatDEF1 ["DEF",form,tlist,b,body] == +; $insideDEF: local := $DEFdepth > 1 +; $insideEXPORTS: local := form = 'Exports +; $insideTypeExpression: local := true +; form := formatDeftran(form,false) +; body := formatDeftran(body,false) +; ---------> terrible, hideous, but temporary, hack +; if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] +; prefix := (opOf tlist = 'Category => "define "; nil) +; body is ["add",a,b] => formatAddDef(form,a,b) +; body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) +; prefix => +; tryBreak(format prefix and format form and format " == ",body,"==","Led") +; tryBreak(format form and format " == ",body,"==","Led") + +(DEFUN |formatDEF1| (G167277) + (PROG (|$insideDEF| |$insideEXPORTS| |$insideTypeExpression| |tlist| + |form| |body| |prefix| |ISTMP#2| |ISTMP#1| |a| |b|) + (DECLARE (SPECIAL |$insideDEF| |$insideEXPORTS| |$DEFdepth| + |$insideTypeExpression|)) + (RETURN + (PROGN + (COND ((EQ (CAR G167277) 'DEF) (CAR G167277))) + (SPADLET |form| (CADR G167277)) + (SPADLET |tlist| (CADDR G167277)) + (SPADLET |b| (CADDDR G167277)) + (SPADLET |body| (CAR (CDDDDR G167277))) + (SPADLET |$insideDEF| (> |$DEFdepth| 1)) + (SPADLET |$insideEXPORTS| (BOOT-EQUAL |form| '|Exports|)) + (SPADLET |$insideTypeExpression| 'T) + (SPADLET |form| (|formatDeftran| |form| NIL)) + (SPADLET |body| (|formatDeftran| |body| NIL)) + (COND + ((AND (NULL |$insideDEF|) (PAIRP |body|) + (EQ (QCAR |body|) 'SEQ)) + (SPADLET |body| (CONS '|add| (CONS |body| NIL))))) + (SPADLET |prefix| + (COND + ((BOOT-EQUAL (|opOf| |tlist|) '|Category|) + '|define |) + ('T NIL))) + (COND + ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (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|)) + 'T)))))) + (|formatAddDef| |form| |a| |b|)) + ((AND (PAIRP |body|) (EQ (QCAR |body|) '|with|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |b| (QCDR |ISTMP#1|)) + 'T)))) + (|formatWithDef| |form| |a| |b| '== |prefix|)) + (|prefix| + (|tryBreak| + (AND (|format| |prefix|) (|format| |form|) + (|format| '| == |)) + |body| '== '|Led|)) + ('T + (|tryBreak| (AND (|format| |form|) (|format| '| == |)) + |body| '== '|Led|))))))) + +;formatDefForm(form,:options) == +; prefix := IFCAR options +; $insideTypeExpression : local := true +; form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) +; prefix => format prefix and format form +; format form + +(DEFUN |formatDefForm| (&REST G167392 &AUX |options| |form|) + (DSETQ (|form| . |options|) G167392) + (PROG (|$insideTypeExpression| |prefix| |ISTMP#1| |form1| |ISTMP#2| + |ISTMP#3| |ISTMP#4| |a| |b|) + (DECLARE (SPECIAL |$insideTypeExpression|)) + (RETURN + (PROGN + (SPADLET |prefix| (IFCAR |options|)) + (SPADLET |$insideTypeExpression| 'T) + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |form1| (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|) '|with|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |a| + (QCAR |ISTMP#4|)) + (SPADLET |b| + (QCDR |ISTMP#4|)) + 'T)))))))))) + (|formatWithDef| |form1| |a| |b| '|:| |prefix|)) + (|prefix| (AND (|format| |prefix|) (|format| |form|))) + ('T (|format| |form|))))))) + +;formatAddDef(form,a,b) == +; $insideCAPSULE : local := true +; $insideDEF : local := false +; formatDefForm form or return nil +; $marginStack := [0] +; $m := $c := 0 +; $insideTypeExpression : local := false +; cap := (b => b; "") +; tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") +; and format " add ", cap,"add","Led") + +(DEFUN |formatAddDef| (|form| |a| |b|) + (PROG (|$insideCAPSULE| |$insideDEF| |$insideTypeExpression| |cap|) + (DECLARE (SPECIAL |$insideCAPSULE| |$insideDEF| |$c| |$m| + |$insideTypeExpression| |$marginStack|)) + (RETURN + (PROGN + (SPADLET |$insideCAPSULE| 'T) + (SPADLET |$insideDEF| NIL) + (OR (|formatDefForm| |form|) (RETURN NIL)) + (SPADLET |$marginStack| (CONS 0 NIL)) + (SPADLET |$m| (SPADLET |$c| 0)) + (SPADLET |$insideTypeExpression| NIL) + (SPADLET |cap| (COND (|b| |b|) ('T '||))) + (|tryBreakNB| + (AND (|newLine|) (|format| '|== |) + (|formatLeft| '|format| |a| '|add| '|Led|) + (|format| '| add |)) + |cap| '|add| '|Led|))))) + +;formatWithDef(form,a,b,separator,:options) == +; prefix := IFCAR options +; $insideEXPORTS : local := true +; $insideCAPSULE : local := true +; $insideDEF : local := false +; $insideTypeExpression : local := false +; a1 := formatWithKillSEQ a +; b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") +; and format " with ",first b,"with","Led") +; tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") + +(DEFUN |formatWithDef| + (&REST G167429 &AUX |options| |separator| |b| |a| |form|) + (DSETQ (|form| |a| |b| |separator| . |options|) G167429) + (PROG (|$insideEXPORTS| |$insideCAPSULE| |$insideDEF| + |$insideTypeExpression| |prefix| |a1|) + (DECLARE (SPECIAL |$insideEXPORTS| |$insideCAPSULE| |$insideDEF| + |$insideTypeExpression|)) + (RETURN + (PROGN + (SPADLET |prefix| (IFCAR |options|)) + (SPADLET |$insideEXPORTS| 'T) + (SPADLET |$insideCAPSULE| 'T) + (SPADLET |$insideDEF| NIL) + (SPADLET |$insideTypeExpression| NIL) + (SPADLET |a1| (|formatWithKillSEQ| |a|)) + (COND + (|b| (|tryBreakNB| + (AND (|formatDefForm| |form| |prefix|) + (|format| |separator|) (|format| '| with |) + (|formatLeft| '|format| |a| '|with| '|Led|) + (|format| '| with |)) + (CAR |b|) '|with| '|Led|)) + ('T + (|tryBreak| + (AND (|formatDefForm| |form| |prefix|) + (|format| |separator|) (|format| '| with |)) + |a1| '|with| '|Nud|))))))) + +;formatWithKillSEQ x == +; x is ['SEQ,['exit,.,y]] => ['BRACE, y] +; x + +(DEFUN |formatWithKillSEQ| (|x|) + (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| |y|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SEQ) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|exit|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#4|)) + 'T)))))))))) + (CONS 'BRACE (CONS |y| NIL))) + ('T |x|))))) + +;formatBrace ['BRACE, x] == format "{" and format x and format "}" + +(DEFUN |formatBrace| (G167467) + (PROG (|x|) + (RETURN + (PROGN + (SPADLET |x| (CADR G167467)) + (AND (|format| '{) (|format| |x|) (|format| '})))))) + +;formatWith ["with",a,:b] == +; $pilesAreOkHere: local := true +; b => +; tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") +; tryBreak(format "with ",a,"with","Nud") + +(DEFUN |formatWith| (G167479) + (PROG (|$pilesAreOkHere| |a| |b|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (COND ((EQ (CAR G167479) '|with|) (CAR G167479))) + (SPADLET |a| (CADR G167479)) + (SPADLET |b| (CDDR G167479)) + (SPADLET |$pilesAreOkHere| 'T) + (COND + (|b| (|tryBreakNB| + (AND (|formatLeft| '|format| |a| '|with| '|Led|) + (|format| '| with |)) + (CAR |b|) '|with| '|Led|)) + ('T (|tryBreak| (|format| '|with |) |a| '|with| '|Nud|))))))) + +;formatWithDefault ["withDefault",a,b] == +; if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then +; part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] +; if IFCAR init then +; a:= IFCAR init +; b:= [part2] +; else +; a := part2 +; b := nil +; $pilesAreOkHere: local := true +; b => +; tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") +; tryBreak(format "with ",a,"with","Nud") + +(DEFUN |formatWithDefault| (G167580) + (PROG (|$pilesAreOkHere| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| + |ISTMP#5| |ISTMP#6| |ISTMP#7| |ISTMP#8| |x| |items| |init| + |part2| |a| |b|) + (DECLARE (SPECIAL |$pilesAreOkHere|)) + (RETURN + (PROGN + (COND ((EQ (CAR G167580) '|withDefault|) (CAR G167580))) + (SPADLET |a| (CADR G167580)) + (SPADLET |b| (CADDR G167580)) + (COND + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|with|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) 'SEQ) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |ISTMP#5| + (REVERSE |ISTMP#4|)) + 'T) + (PAIRP |ISTMP#5|) + (PROGN + (SPADLET |ISTMP#6| + (QCAR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCAR |ISTMP#6|) '|exit|) + (PROGN + (SPADLET |ISTMP#7| + (QCDR |ISTMP#6|)) + (AND (PAIRP |ISTMP#7|) + (PROGN + (SPADLET |ISTMP#8| + (QCDR |ISTMP#7|)) + (AND (PAIRP |ISTMP#8|) + (EQ (QCDR |ISTMP#8|) NIL) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#8|)) + 'T))))))) + (PROGN + (SPADLET |items| + (QCDR |ISTMP#5|)) + 'T) + (PROGN + (SPADLET |items| + (NREVERSE |items|)) + 'T))))) + (PROGN (SPADLET |init| (QCDR |ISTMP#2|)) 'T) + (PROGN (SPADLET |init| (NREVERSE |init|)) 'T)))) + (SPADLET |part2| + (CONS 'SEQ + (APPEND |items| + (CONS |x| + (CONS + (CONS '|exit| + (CONS NIL + (CONS + (CONS '|defaultDefs| + (CONS |b| NIL)) + NIL))) + NIL))))) + (COND + ((IFCAR |init|) (SPADLET |a| (IFCAR |init|)) + (SPADLET |b| (CONS |part2| NIL))) + ('T (SPADLET |a| |part2|) (SPADLET |b| NIL))))) + (SPADLET |$pilesAreOkHere| 'T) + (COND + (|b| (|tryBreakNB| + (AND (|formatLeft| '|format| |a| '|with| '|Led|) + (|format| '| with |)) + (CAR |b|) '|with| '|Led|)) + ('T (|tryBreak| (|format| '|with |) |a| '|with| '|Nud|))))))) + +;formatDefaultDefs ["default",a, :b] == +; $insideCAPSULE : local := true +; $insideDEF : local := false +; $insideTypeExpression : local := false +; b => +; tryBreak(formatLeft("format",a,"default","Led") and +; format " default ", first b,"default","Led") +; tryBreak(format "default ",a,"default","Nud") + +(DEFUN |formatDefaultDefs| (G167644) + (PROG (|$insideCAPSULE| |$insideDEF| |$insideTypeExpression| |a| |b|) + (DECLARE (SPECIAL |$insideCAPSULE| |$insideDEF| + |$insideTypeExpression|)) + (RETURN + (PROGN + (COND ((EQ (CAR G167644) '|default|) (CAR G167644))) + (SPADLET |a| (CADR G167644)) + (SPADLET |b| (CDDR G167644)) + (SPADLET |$insideCAPSULE| 'T) + (SPADLET |$insideDEF| NIL) + (SPADLET |$insideTypeExpression| NIL) + (COND + (|b| (|tryBreak| + (AND (|formatLeft| '|format| |a| '|default| '|Led|) + (|format| '| default |)) + (CAR |b|) '|default| '|Led|)) + ('T + (|tryBreak| (|format| '|default |) |a| '|default| '|Nud|))))))) + +;--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace +;formatAdd ["add",a,:b] == +; $insideCAPSULE : local := true +; $insideDEF : local := false +; $insideTypeExpression : local := false +; b => +; tryBreakNB(formatLeft("format",a,"and","Led") and +; format " and ", first b,"and","Led") +; tryBreakNB(format "add ",a,"and","Nud") + +(DEFUN |formatAdd| (G167670) + (PROG (|$insideCAPSULE| |$insideDEF| |$insideTypeExpression| |a| |b|) + (DECLARE (SPECIAL |$insideCAPSULE| |$insideDEF| + |$insideTypeExpression|)) + (RETURN + (PROGN + (COND ((EQ (CAR G167670) '|add|) (CAR G167670))) + (SPADLET |a| (CADR G167670)) + (SPADLET |b| (CDDR G167670)) + (SPADLET |$insideCAPSULE| 'T) + (SPADLET |$insideDEF| NIL) + (SPADLET |$insideTypeExpression| NIL) + (COND + (|b| (|tryBreakNB| + (AND (|formatLeft| '|format| |a| '|and| '|Led|) + (|format| '| and |)) + (CAR |b|) '|and| '|Led|)) + ('T (|tryBreakNB| (|format| '|add |) |a| '|and| '|Nud|))))))) + +;--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace +;formatMDEF ["MDEF",form,.,.,body] == +; form is '(Rep) => formatDEF ["DEF",form,.,.,body] +; $insideEXPORTS: local := form = 'Exports +; $insideTypeExpression: local := true +; body := formatDeftran(body,false) +; name := opOf form +; tryBreakNB(format name and format " ==> ",body,"==","Led") +; and ($insideCAPSULE and $c or format(";")) + +(DEFUN |formatMDEF| (G167696) + (PROG (|$insideEXPORTS| |$insideTypeExpression| |form| |body| |name|) + (DECLARE (SPECIAL |$insideEXPORTS| |$insideTypeExpression| + |$insideCAPSULE| |$c|)) + (RETURN + (PROGN + (COND ((EQ (CAR G167696) 'MDEF) (CAR G167696))) + (SPADLET |form| (CADR G167696)) + (SPADLET |body| (CAR (CDDDDR G167696))) + (COND + ((EQUAL |form| '(|Rep|)) + (|formatDEF| + (CONS 'DEF + (CONS |form| + (CONS '|.| (CONS '|.| (CONS |body| NIL))))))) + ('T (SPADLET |$insideEXPORTS| (BOOT-EQUAL |form| '|Exports|)) + (SPADLET |$insideTypeExpression| 'T) + (SPADLET |body| (|formatDeftran| |body| NIL)) + (SPADLET |name| (|opOf| |form|)) + (AND (|tryBreakNB| + (AND (|format| |name|) (|format| '| ==> |)) |body| + '== '|Led|) + (OR (AND |$insideCAPSULE| |$c|) (|format| '|;|))))))))) + +;insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue +; or $noColonDeclaration + +(DEFUN |insideCat| () + (declare (special |$noColonDeclaration| |$insideCategoryIfTrue| + |$insideFunctorIfTrue|)) + (OR (AND |$insideCategoryIfTrue| (NULL |$insideFunctorIfTrue|)) + |$noColonDeclaration|)) + +;formatImport ["import",a] == +; addFieldNames a +; addFieldNames macroExpand(a,$e) +; format "import from " and formatLocal1 a + +(DEFUN |formatImport| (G167724) + (PROG (|a|) + (declare (special |$e|)) + (RETURN + (PROGN + (COND ((EQ (CAR G167724) '|import|) (CAR G167724))) + (SPADLET |a| (CADR G167724)) + (|addFieldNames| |a|) + (|addFieldNames| (|macroExpand| |a| |$e|)) + (AND (|format| '|import from |) (|formatLocal1| |a|)))))) + +;addFieldNames a == +; a is [op,:r] and MEMQ(op,'(Record Union)) => +; $fieldNames := UNION(getFieldNames r,$fieldNames) +; a is ['List,:b] => addFieldNames b +; nil + +(DEFUN |addFieldNames| (|a|) + (PROG (|op| |r| |b|) + (declare (special |$fieldNames|)) + (RETURN + (COND + ((AND (PAIRP |a|) + (PROGN + (SPADLET |op| (QCAR |a|)) + (SPADLET |r| (QCDR |a|)) + 'T) + (MEMQ |op| '(|Record| |Union|))) + (SPADLET |$fieldNames| + (|union| (|getFieldNames| |r|) |$fieldNames|))) + ((AND (PAIRP |a|) (EQ (QCAR |a|) '|List|) + (PROGN (SPADLET |b| (QCDR |a|)) 'T)) + (|addFieldNames| |b|)) + ('T NIL))))) + +;getFieldNames r == +; r is [[":",a,b],:r] => [a,:getFieldNames r] +; nil + +(DEFUN |getFieldNames| (|r|) + (PROG (|ISTMP#1| |ISTMP#2| |a| |ISTMP#3| |b|) + (RETURN + (COND + ((AND (PAIRP |r|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |r|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|:|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#3|)) + 'T))))))) + (PROGN (SPADLET |r| (QCDR |r|)) 'T)) + (CONS |a| (|getFieldNames| |r|))) + ('T NIL))))) + +;formatLocal ["local",a] == format "local " and formatLocal1 a + +(DEFUN |formatLocal| (G167783) + (PROG (|a|) + (RETURN + (PROGN + (COND ((EQ (CAR G167783) '|local|) (CAR G167783))) + (SPADLET |a| (CADR G167783)) + (AND (|format| '|local |) (|formatLocal1| |a|)))))) + +;formatLocal1 a == +; $insideTypeExpression: local := true +; format a + +(DEFUN |formatLocal1| (|a|) + (PROG (|$insideTypeExpression|) + (DECLARE (SPECIAL |$insideTypeExpression|)) + (RETURN + (PROGN (SPADLET |$insideTypeExpression| 'T) (|format| |a|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}