diff options
Diffstat (limited to 'src/interp/pspad1.boot')
| -rw-r--r-- | src/interp/pspad1.boot | 743 |
1 files changed, 743 insertions, 0 deletions
diff --git a/src/interp/pspad1.boot b/src/interp/pspad1.boot new file mode 100644 index 00000000..ce580b14 --- /dev/null +++ b/src/interp/pspad1.boot @@ -0,0 +1,743 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +$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 + $pilesAreOkHere: local:= true + $commentsToPrint: local:= nil + $lineBuffer: local + $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:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c) + if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op + n=1 and GETL(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 GETL(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 GETL(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 + spill("formatFunctionCall1",u) + +formatFunctionCall1 [op,:argl] == +--null argl and getConstructorProperty(op,'niladic) => formatOp op + null argl => + GETL(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 + 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 + 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 + formatSpill("formatPrenAux",a) + +formatPrenAux a == format "_(" and format a and format "_)" + +formatPren1(f,a) == + $pilesAreOkHere: local + 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")<lbp => 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 + 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 + (if formatGetBindingPowerOf("right",a)<lbp then formatPren a else format a) and + formatInfixOp(op,qualification) and (if rbp>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 + GETL(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 + |