DIRECTORY Atom, Commander, IO, Process, Rope, Scheme, SchemePrinting, StructuredStreams, UnparserBuffer, UserProfile;

SchemePrinter: CEDAR PROGRAM
IMPORTS Atom, Commander, IO, Process, Rope, Scheme, StructuredStreams, UnparserBuffer, UserProfile
EXPORTS SchemePrinting
=

BEGIN OPEN Scheme, SchemePrinting, SS:StructuredStreams, UB:UnparserBuffer;

PrintStuff: TYPE ~ REF PrintStuffPrivate;
PrintStuffPrivate: TYPE ~ RECORD [
to: IO.STREAM,
how: How,
quit: REF BOOL,
posns: FormToSource
];

PrettyProc: TYPE ~ PROC [ps: PrintStuff, val: Any, nclose: Nat];

BreakSpec: TYPE ~ RECORD [cond: UB.XBreakCondition, offset: INTEGER, sep: ROPE ¬ " ", double: BOOL ¬ FALSE];
aBrk: BreakSpec ~ [always, 0, NIL, FALSE];

unquoteSplicing: ATOM ~ Atom.MakeAtom["unquote-splicing"];
letStar: ATOM ~ Atom.MakeAtom["let*"];
setBang: ATOM ~ Atom.MakeAtom["set!"];
dynamicBind: ATOM ~ Atom.MakeAtom["dynamic-bind"];
dynamicSetBang: ATOM ~ Atom.MakeAtom["dynamic-set!"];
extendSyntax: ATOM ~ Atom.MakeAtom["extend-syntax"];
deliver: ATOM ~ Atom.MakeAtom["=>"];

PrettyPrint: PUBLIC PROC [to: IO.STREAM, val: Any, how: How, context: ATOM, posns: FormToSource ¬ NIL, debugLog: IO.STREAM ¬ NIL, quit: REF BOOL ¬ NIL] ~ {
ps: PrintStuff ~ NEW [PrintStuffPrivate ¬ [to, how, quit, posns]];
IF ps.quit=NIL THEN ps.quit ¬ NEW [BOOL ¬ FALSE];
SELECT context FROM
$expr => PrintExpr[ps, val, 0];
$data => PrintData[ps, val, 0];
ENDCASE => ERROR Complain[context, "invalid context"];
};

PrintExpr: PROC [ps: PrintStuff, val: Any, nclose: Nat] ~ {
Process.CheckForAbort[];
IF ps.quit­ THEN ERROR ABORTED;
WITH val SELECT FROM
v: SimpleVector => PrintVector[ps, v, nclose, PrintExpr];
v: Vector => PrintVector[ps, v, nclose, PrintExpr];
p: Pair => {
IF p.cdr=NIL THEN {
ps.to.PutChar['(];
PrintExpr[ps, p.car, nclose.SUCC];
RETURN};
WITH p.car SELECT FROM
a: ATOM => SELECT a FROM
$quote => PrintQuote[ps, "'", a, p.cdr, nclose];
$quasiquote => PrintQuote[ps, "`", a, p.cdr, nclose];
$unquote => PrintUnquote[ps, ",", a, p.cdr, nclose];
unquoteSplicing => PrintUnquote[ps, ",@", a, p.cdr, nclose];
$define, setBang, dynamicSetBang => PrintDef[ps, a, p.cdr, nclose];
$lambda => PrintLambda[ps, a, p.cdr, nclose];
$if => PrintIf[ps, a, p.cdr, nclose];
$when, $unless => PrintWhen[ps, a, p.cdr, nclose];
$cond => PrintCond[ps, a, p.cdr, FALSE, nclose];
$case => PrintCond[ps, a, p.cdr, TRUE, nclose];
$let => PrintLet[ps, a, p.cdr, TRUE, nclose];
$letrec, letStar, dynamicBind, $with => PrintLet[ps, a, p.cdr, FALSE, nclose];
$begin => PrintBegin[ps, a, p.cdr, nclose];
$do => PrintDo[ps, a, p.cdr, nclose];
extendSyntax => PrintExtSyn[ps, a, p.cdr, nclose];
$export => PrintExport[ps, a, p.cdr, nclose];
ENDCASE => PrintComb[ps, a, p.cdr, TRUE, TRUE, nclose];
ENDCASE => PrintComb[ps, p.car, p.cdr, FALSE, Simple[p.car, ps.how], nclose]};
ENDCASE => {Print[val, ps.to]; Multiply[ps, '), nclose]};
RETURN};

PrintData: PROC [ps: PrintStuff, val: Any, nclose: Nat] ~ {
Process.CheckForAbort[];
IF ps.quit­ THEN ERROR ABORTED;
WITH val SELECT FROM
v: SimpleVector => PrintVector[ps, v, nclose, PrintData];
v: Vector => PrintVector[ps, v, nclose, PrintData];
p: Pair => {
WITH p.car SELECT FROM
a: ATOM => SELECT a FROM
$unquote => PrintUnquote[ps, ",", a, p.cdr, nclose];
unquoteSplicing => PrintUnquote[ps, ",@", a, p.cdr, nclose];
ENDCASE => PrintListForm[ps, p, [lookLeft, ps.how.sia], PrintData, nclose];
ENDCASE => PrintListForm[ps, p, [lookLeft, ps.how.sia], PrintData, nclose]};
ENDCASE => {Print[val, ps.to]; Multiply[ps, '), nclose]};
RETURN};

PrintVector: PROC [ps: PrintStuff, v: Any, nclose: Nat, Inner: PrettyProc] ~ {
len: INT ~ VectorLength[v];
ps.to.PutRope["#("];
IF len=0 THEN {Multiply[ps, '), nclose.SUCC]; RETURN};
SS.Begin[ps.to];
FOR i: INT IN [0 .. len) DO
elt: Any ~ VectorRef[v, i];
IF i>0 THEN SS.XBp[ps.to, lookLeft, 0, " "];
Inner[ps, elt, IF i.SUCC=len THEN nclose.SUCC ELSE 0];
ENDLOOP;
SS.End[ps.to];
RETURN};

PrintQuote: PROC [ps: PrintStuff, intro: ROPE, head: ATOM, rest: Any, nclose: Nat] ~ {
WITH rest SELECT FROM
p: Pair => IF p.cdr=NIL THEN {
ps.to.PutRope[intro];
PrintData[ps, p.car, nclose];
RETURN};
ENDCASE => NULL;
PrintComb[ps, head, rest, TRUE, TRUE, nclose];
RETURN};

PrintUnquote: PROC [ps: PrintStuff, intro: ROPE, head: ATOM, rest: Any, nclose: Nat] ~ {
WITH rest SELECT FROM
p: Pair => IF p.cdr=NIL THEN {
ps.to.PutRope[intro];
PrintExpr[ps, p.car, nclose];
RETURN};
ENDCASE => NULL;
PrintComb[ps, head, rest, TRUE, TRUE, nclose];
RETURN};

PrintDef: PROC [ps: PrintStuff, head: ATOM, rest: Any, nclose: Nat] ~ {
WITH rest SELECT FROM
p: Pair => {
sep: BreakSpec ~ IF Atomic[p.car, ps.how]
THEN WITH p.cdr SELECT FROM
q: Pair => IF q.cdr=NIL AND Simple[q.car, ps.how] THEN [lookLeft, ps.how.sia] ELSE [always, ps.how.sia],
ENDCASE => [always, ps.how.sia]
ELSE [always, ps.how.sia];
SS.Begin[ps.to];
ps.to.PutChar['(];
ps.to.PutRope[Atom.GetPName[head]];
ps.to.PutChar[' ];
PrintFormals[ps, p.car, IF p.cdr=NIL THEN nclose.SUCC ELSE 0];
PrintSeries[ps, p.cdr, FALSE, sep, PrintExpr, nclose.SUCC]};
ENDCASE => PrintComb[ps, head, rest, TRUE, TRUE, nclose]};

PrintLambda: PROC [ps: PrintStuff, head: ATOM, rest: Any, nclose: Nat] ~ {
WITH rest SELECT FROM
formalsTail: Pair => WITH formalsTail.cdr SELECT FROM
bodyTail: Pair => {
simple: BOOL ~ bodyTail.cdr=NIL AND Simple[bodyTail.car, ps.how];
SS.Begin[ps.to];
ps.to.PutChar['(];
ps.to.PutRope[Atom.GetPName[head]];
ps.to.PutChar[' ];
PrintFormals[ps, formalsTail.car, 0];
PrintSeries[ps, bodyTail, FALSE, [IF simple THEN lookLeft ELSE always, ps.how.sia], PrintExpr, nclose.SUCC];
RETURN};
ENDCASE => NULL;
ENDCASE => --what??--NULL;
PrintComb[ps, head, rest, TRUE, TRUE, nclose];
RETURN};

PrintFormals: PROC [ps: PrintStuff, formals: Any, nclose: Nat] ~ {
PrintListForm[ps, formals, [lookLeft, 1], PrintExpr, nclose]};

PrintIf: PROC [ps: PrintStuff, head: ATOM, args: Any, nclose: Nat] ~ {
WITH args SELECT FROM
testTail: Pair => --(test cons alt) or (test cons)
WITH testTail.cdr SELECT FROM
consTail: Pair => {--(cons alt) or (cons)
testSimple: BOOL ~ Simple[testTail.car, ps.how];
consSimple, consAtomic, special: BOOL ¬ FALSE;
consSep: BreakSpec;
SELECT Classify[consTail.car, ps.how] FROM
atomic => consSimple ¬ consAtomic ¬ TRUE;
simple => consSimple ¬ TRUE;
complex => consSimple ¬ FALSE;
ENDCASE => ERROR;
IF consTail.cdr=NIL THEN NULL
ELSE IF consSimple THEN WITH consTail.cdr SELECT FROM
altTail: Pair => SELECT Classify[altTail.car, ps.how] FROM
atomic => NULL;
simple => consAtomic ¬ FALSE;
complex => consSimple ¬ consAtomic ¬ FALSE;
ENDCASE => ERROR;
ENDCASE => consSimple ¬ consAtomic ¬ FALSE;
SS.Begin[ps.to];
ps.to.PutRope["(if "];
PrintExpr[ps, testTail.car, 0];
SS.XBp[ps.to, IF testSimple AND consSimple THEN lookLeft ELSE always, ps.how.sia, " "];
special ¬ testSimple AND consAtomic;
consSep ¬ [IF consAtomic THEN lookLeft ELSE united, IF special THEN 0 ELSE ps.how.sia];
IF special THEN SS.Begin[ps.to];
PrintSeries[ps, consTail, TRUE, consSep, PrintExpr, nclose.SUCC];
IF special THEN SS.End[ps.to];
RETURN};
ENDCASE => NULL;
ENDCASE => NULL;
PrintComb[ps, head, args, TRUE, TRUE, nclose];
RETURN};

PrintWhen: PROC [ps: PrintStuff, head: ATOM, rest: Any, nclose: Nat] ~ {
WITH rest SELECT FROM
predTail: Pair => {
SS.Begin[ps.to];
ps.to.PutChar['(];
ps.to.PutRope[Atom.GetPName[head]];
ps.to.PutChar[' ];
PrintExpr[ps, predTail.car, IF predTail.cdr=NIL THEN nclose.SUCC ELSE 0];
PrintSeries[ps, predTail.cdr, FALSE, [always, ps.how.sia], PrintExpr, nclose.SUCC];
RETURN};
ENDCASE => PrintComb[ps, head, rest, TRUE, TRUE, nclose]};

PrintCond: PROC [ps: PrintStuff, head: ATOM, args: Any, case: BOOL, nclose: Nat] ~ {
expr: Any ¬ NIL;
arms: Any ¬ args;
first: BOOL ¬ TRUE;
IF case THEN WITH args SELECT FROM
p: Pair => {expr ¬ p.car; arms ¬ p.cdr};
ENDCASE => {PrintComb[ps, head, args, TRUE, TRUE, nclose]; RETURN};
SS.Begin[ps.to];
ps.to.PutChar['(];
ps.to.PutRope[Atom.GetPName[head]];
IF case THEN {
ps.to.PutChar[' ];
PrintExpr[ps, expr, IF arms=NIL THEN nclose.SUCC ELSE 0];
SS.XBp[ps.to, always, ps.how.sia, " "];
}
ELSE {
IF arms=NIL THEN {Multiply[ps, '), nclose.SUCC]; SS.End[ps.to]; RETURN};
SS.XBp[ps.to, miser, ps.how.sia, " "]};
SS.Begin[ps.to];
PrintSeries[ps, arms, TRUE, [always, 0], PrintCondClause, nclose.SUCC];
SS.End[ps.to];
RETURN};

PrintCondClause: PROC [ps: PrintStuff, val: Any, nclose: Nat] ~ {
WITH val SELECT FROM
c0: Pair => {
predSimple: BOOL ~ Simple[c0.car, ps.how];
Finish: PROC [rest: Any, del, long, exprSimple: BOOL] ~ {
sep: BreakSpec ~ [IF long OR NOT (predSimple AND exprSimple) THEN always ELSE lookLeft, 0];
IF del THEN {ApplyBS[ps, sep]; ps.to.PutRope["=> "]};
PrintSeries[ps, rest, del, sep, PrintExpr, nclose.SUCC];
};
ps.to.PutChar['(];
SS.Begin[ps.to];
PrintExpr[ps, c0.car, IF c0.cdr=NIL THEN nclose.SUCC ELSE 0];
IF c0.cdr=NIL THEN {SS.End[ps.to]; RETURN};
WITH c0.cdr SELECT FROM
c1: Pair => SELECT c1.car FROM
deliver => WITH c1.cdr SELECT FROM
c2: Pair => Finish[c1.cdr, TRUE, c2.cdr#NIL, Simple[c2.car, ps.how]];
ENDCASE => IF c1.cdr#NIL
THEN Finish[c1.cdr, TRUE, TRUE, FALSE]
ELSE Finish[c0.cdr, FALSE, FALSE, FALSE];
ENDCASE => Finish[c0.cdr, FALSE, c1.cdr#NIL, Simple[c1.car, ps.how]];
ENDCASE => Finish[c0.cdr, FALSE, TRUE, FALSE];
};
ENDCASE => PrintExpr[ps, val, nclose];
RETURN};

PrintLet: PROC [ps: PrintStuff, head: ATOM, rest: Any, mayName: BOOL, nclose: Nat] ~ {
named: BOOL ¬ FALSE;
name: ATOM ¬ NIL;
tail: Any ¬ rest;
IF mayName THEN WITH rest SELECT FROM
p: Pair => WITH p.car SELECT FROM
a: ATOM => {named ¬ TRUE; name ¬ a; tail ¬ p.cdr};
ENDCASE => NULL;
ENDCASE => NULL;
WITH tail SELECT FROM
bindTail: Pair => {--(bindings . body)
SS.Begin[ps.to];
ps.to.PutChar['(];
ps.to.PutRope[Atom.GetPName[head]];
ps.to.PutChar[' ];
IF named THEN {
SS.Begin[ps.to];
ps.to.PutRope[Atom.GetPName[name]];
SS.XBp[ps.to, miser, 0, " "]};
PrintListForm[ps, bindTail.car, [always, 1], PrintBinding, IF bindTail.cdr=NIL THEN nclose.SUCC ELSE 0];
IF named THEN SS.End[ps.to];
PrintSeries[ps, bindTail.cdr, FALSE, [always, ps.how.sia], PrintExpr, nclose.SUCC];
};
ENDCASE => PrintComb[ps, head, rest, TRUE, TRUE, nclose];
RETURN};

PrintBinding: PROC [ps: PrintStuff, val: Any, nclose: Nat] ~ {
WITH val SELECT FROM
vTail: Pair => --(v e)-- WITH vTail.car SELECT FROM
v: ATOM => WITH vTail.cdr SELECT FROM
eTail: Pair => --(e)-- IF eTail.cdr=NIL THEN {
PrintListForm[ps, val, [miser, ps.how.sia], PrintExpr, nclose];
RETURN};
ENDCASE => NULL;
ENDCASE => NULL;
ENDCASE => NULL;
PrintListForm[ps, val, [lookLeft, ps.how.sia], PrintExpr, nclose];
RETURN};

PrintBegin: PROC [ps: PrintStuff, head: ATOM, args: Any, nclose: Nat] ~ {
SS.Begin[ps.to];
ps.to.PutRope["(begin"];
IF args=NIL THEN {Multiply[ps, '), nclose.SUCC]; SS.End[ps.to]; RETURN};
SS.XBp[ps.to, miser, ps.how.sia, " "];
SS.Begin[ps.to];
PrintSeries[ps, args, TRUE, [always, 0], PrintExpr, nclose.SUCC];
SS.End[ps.to];
RETURN};

PrintDo: PROC [ps: PrintStuff, head: ATOM, args: Any, nclose: Nat] ~ {
WITH args SELECT FROM
bindTail: Pair => --(bindings test . body)-- WITH bindTail.cdr SELECT FROM
testTail: Pair => {--(test . body)
bindings: Any ¬ bindTail.car;
SS.Begin[ps.to];
ps.to.PutRope["(do "];
SS.Begin[ps.to];
PrintListForm[ps, bindTail.car, [always, 1], PrintAnyComb, 0];
SS.XBp[ps.to, always, 0, " "];
PrintCondClause[ps, testTail.car, IF testTail.cdr=NIL THEN nclose.SUCC ELSE 0];
SS.End[ps.to];
PrintSeries[ps, testTail.cdr, FALSE, [always, ps.how.sia], PrintExpr, nclose.SUCC];
RETURN};
ENDCASE => NULL;
ENDCASE => NULL;
PrintComb[ps, head, args, TRUE, TRUE, nclose];
RETURN};

PrintExtSyn: PROC [ps: PrintStuff, head: ATOM, rest: Any, nclose: Nat] ~ {
WITH rest SELECT FROM
keyTail: Pair => {--(keylist . stmts)
SS.Begin[ps.to];
ps.to.PutChar['(];
ps.to.PutRope[Atom.GetPName[head]];
ps.to.PutChar[' ];
PrintListForm[ps, keyTail.car, [width, 1], PrintExpr, IF keyTail.cdr=NIL THEN nclose.SUCC ELSE 0];
PrintSeries[ps, keyTail.cdr, FALSE, [always, ps.how.sia], PrintSyntaxStmt, nclose.SUCC];
RETURN};
ENDCASE => PrintComb[ps, head, rest, TRUE, TRUE, nclose];
RETURN};

PrintSyntaxStmt: PROC [ps: PrintStuff, val: Any, nclose: Nat] ~ {
PrintListForm[ps, val, [always, 1], PrintExpr, nclose]};

PrintExport: PROC [ps: PrintStuff, head: ATOM, rest: Any, nclose: Nat] ~ {
wasDefine: BOOL ¬ FALSE;
ExportEltSep: PROC [elt: Any, first, last: BOOL, how: How] RETURNS [BreakSpec] ~ {
prevDefine: BOOL ~ wasDefine;
isDefine: BOOL ~ WITH elt SELECT FROM
p: Pair => p.car=$define,
ENDCASE => FALSE;
wasDefine ¬ isDefine;
RETURN [[always, how.sia, " ", prevDefine OR isDefine]]};
WITH rest SELECT FROM
formalTail: Pair => {
SS.Begin[ps.to];
ps.to.PutChar['(];
ps.to.PutRope[Atom.GetPName[head]];
ps.to.PutChar[' ];
PrintFormals[ps, formalTail.car, 0];
IF formalTail.cdr#NIL THEN PrintEngine[ps, formalTail.cdr, FALSE, ExportEltSep, AlwaysSia, PrintExpr, nclose.SUCC]
ELSE {
SS.XBp[ps.to, always, ps.how.sia, NIL];
Multiply[ps, '), nclose.SUCC];
SS.End[ps.to]};
};
ENDCASE => PrintComb[ps, head, rest, TRUE, TRUE, nclose]};

PrintAnyComb: PROC [ps: PrintStuff, val: Any, nclose: Nat] ~ {
WITH val SELECT FROM
p: Pair => WITH p.car SELECT FROM
a: ATOM => PrintComb[ps, a, p.cdr, TRUE, TRUE, nclose];
ENDCASE => PrintComb[ps, p.car, p.cdr, FALSE, Simple[p.car, ps.how], nclose];
ENDCASE => PrintExpr[ps, val, nclose]};

PrintComb: PROC [ps: PrintStuff, head: Any, args: Any, procAtomic, procSimple: BOOL, nclose: Nat] ~ {
wasSimple: BOOL ¬ TRUE;
EltBrk: PROC [elt: Any, first, last: BOOL, how: How] RETURNS [BreakSpec] ~ {
prevSimple: BOOL ~ wasSimple;
isSimple: BOOL ~ last OR Simple[elt, how];
wasSimple ¬ isSimple;
IF first THEN RETURN [[never, 0, NIL]]
ELSE RETURN[[IF prevSimple AND isSimple THEN lookLeft ELSE always, 0]]};
SS.Begin[ps.to];
ps.to.PutChar['(];
PrintExpr[ps, head, IF args=NIL THEN nclose.SUCC ELSE 0];
IF procAtomic THEN SS.XBp[ps.to, miser, ps.how.sia, " "]
ELSE IF procSimple THEN SS.XBp[ps.to, lookLeft, ps.how.sia, " "]
ELSE SS.XBp[ps.to, always, 1, " "];
SS.Begin[ps.to];
PrintEngine[ps, args, TRUE, EltBrk, NeverBreak, PrintExpr, nclose.SUCC];
SS.End[ps.to];
RETURN};

PrintSeries: PROC [ps: PrintStuff, rest: Any, first: BOOL, sep: BreakSpec, Inner: PrettyProc, nclose: Nat] ~ {
EltBrk: PROC [elt: Any, first, last: BOOL, how: How] RETURNS [BreakSpec]
~ {RETURN [IF first THEN [never, 0, NIL] ELSE sep]};
PrintEngine[ps, rest, first, EltBrk, NeverBreak, Inner, nclose]};

PrintListForm: PROC [ps: PrintStuff, list: Any, sep: BreakSpec, Inner: PrettyProc, nclose: Nat] ~ {
EltBrk: PROC [elt: Any, first, last: BOOL, how: How] RETURNS [BreakSpec]
~ {RETURN [IF first THEN [never, 0, NIL] ELSE sep]};
IF list=NIL THEN {ps.to.PutChar['(]; Multiply[ps, '), nclose.SUCC]; RETURN};
WITH list SELECT FROM
p: Pair => {
SS.Begin[ps.to];
ps.to.PutChar['(];
PrintEngine[ps, list, TRUE, EltBrk, NeverBreak, Inner, nclose.SUCC]};
ENDCASE => PrintExpr[ps, list, nclose];
RETURN};

Breaker: TYPE ~ PROC [elt: Any, first, last: BOOL, how: How] RETURNS [BreakSpec];

PrintEngine: PROC [ps: PrintStuff, tail: Any, first: BOOL, EltBrk, EndBrk: Breaker, Inner: PrettyProc, nclose: Nat] ~ {
IF tail#NIL THEN DO
WITH tail SELECT FROM
p: Pair => {last: BOOL ~ (tail ¬ p.cdr)=NIL;
sep: BreakSpec ~ EltBrk[p.car, first, last, ps.how];
final: BreakSpec ~ IF last THEN EndBrk[NIL, FALSE, TRUE, ps.how] ELSE aBrk;
first ¬ FALSE;
ApplyBS[ps, sep];
Inner[ps, p.car, IF final.cond#never THEN 0 ELSE nclose];
IF last THEN {
ApplyBS[ps, final];
IF final.cond#never THEN Multiply[ps, '), nclose];
EXIT}};
ENDCASE => {
sep: BreakSpec ~ EltBrk[tail, first, TRUE, ps.how];
final: BreakSpec ~ EndBrk[NIL, FALSE, TRUE, ps.how];
ApplyBS[ps, sep];
ps.to.PutRope[". "];
Inner[ps, tail, IF final.cond#never THEN 0 ELSE nclose];
ApplyBS[ps, final];
IF final.cond#never THEN Multiply[ps, '), nclose];
EXIT};
ENDLOOP;
SS.End[ps.to];
RETURN};

NeverBreak: Breaker ~ {RETURN [[never, 0, NIL]]};

AlwaysSia: Breaker ~ {RETURN [[always, how.sia]]};

Atomic: PROC [val: Any, how: How] RETURNS [BOOL] ~ {
WITH val SELECT FROM
p: Pair => IF how.simpleQuote AND (p.car=$quote OR p.car=$quasiquote)
THEN WITH p.cdr SELECT FROM
q: Pair => RETURN [q.cdr=NIL AND Atomic[q.car, how]];
ENDCASE => RETURN [FALSE]
ELSE RETURN [FALSE]
ENDCASE => RETURN [TRUE]};

Simple: PROC [val: Any, how: How] RETURNS [BOOL]
~ INLINE {RETURN [Classify[val, how] < complex]};

Classification: TYPE ~ {atomic, simple, complex};

Classify: PROC [val: Any, how: How] RETURNS [Classification] ~ {
WITH val SELECT FROM
p: Pair => {
len: Nat ¬ 1;
car: Any ¬ p.car;
rest: Any ¬ p.cdr;
IF how.simpleQuote AND (car=$quote OR car=$quasiquote)
THEN WITH rest SELECT FROM
q: Pair => IF q.cdr=NIL
THEN RETURN Classify[q.car, how]
ELSE RETURN [complex]
ENDCASE => RETURN [complex];
DO
IF len>how.simpleLen THEN RETURN [complex];
WITH car SELECT FROM
q: Pair => RETURN [complex];
ENDCASE => NULL;
IF rest=NIL THEN RETURN [simple];
WITH rest SELECT FROM
q: Pair => {car ¬ q.car; rest ¬ q.cdr; len ¬ len.SUCC};
ENDCASE => RETURN [IF len < how.simpleLen THEN simple ELSE complex];
ENDLOOP};
ENDCASE => RETURN [atomic]};

ApplyBS: PROC [ps: PrintStuff, bs: BreakSpec] ~ INLINE {
SS.XBp[ps.to, bs.cond, bs.offset, bs.sep];
IF bs.double THEN SS.XBp[ps.to, bs.cond, bs.offset, bs.sep];
RETURN};

Multiply: PROC [ps: PrintStuff, c: CHAR, n: NAT]
~ {THROUGH [1..n] DO ps.to.PutChar[c] ENDLOOP};

Cmd: PROC [cmd: Commander.Handle] RETURNS [result: REF ANY ¬ NIL, msg: ROPE ¬ NIL] --Commander.CommandProc-- ~ {
specIn: IO.STREAM ~ IO.RIS[cmd.commandLine];
how: How ¬ defaultHow;
margin: INT ¬ defaultMargin;
barfum: ROPE ¬ NIL;
msg ¬ NIL;
DO
ENABLE Complain => {
barfum ¬ Rope.Concat["Scheme err on command line: ", msg];
GOTO Abort};
spec: Any ¬ Read[specIn];
Car: PROC [a: Any] RETURNS [Any] ~ {
WITH a SELECT FROM
p: Pair => RETURN[p.car];
ENDCASE => Complain[a, "spec must be of form (name val)"]};
IF spec=endOfFile THEN EXIT;
WITH spec SELECT FROM
p: Pair => SELECT p.car FROM
$margin => margin ¬ TheINT[Car[p.cdr]];
$sia => how.sia ¬ TheINT[Car[p.cdr]];
$simplelen => how.simpleLen ¬ TheINT[Car[p.cdr]];
$simplequote => how.simpleQuote ¬ True[Car[p.cdr]];
ENDCASE => RETURN [$Failure, Rope.Concat["unrecognized spec: ", Fmt[spec]]];
ENDCASE => RETURN [$Failure, Rope.Concat["unrecognized spec: ", Fmt[spec]]];
REPEAT
Abort => RETURN [$Failure, msg.Cat["; ", barfum].Substr[2]];
ENDLOOP;
{h: UB.Handle ~ UB.Create[[margin: margin, output: [stream[cmd.out]] ]];
out: IO.STREAM ~ SS.Create[h];
cmd.out.PutF1["%l", [rope["f"]]];
DO
{arg: Any ~ Read[cmd.in];
IF arg=endOfFile THEN EXIT;
out.PutRope["\n"];
PrettyPrint[out, arg, how, NARROW[cmd.procData.clientData]];
out.PutRope["\n"];
}ENDLOOP;
cmd.out.PutF1["%l", [rope[" "]]];
IF msg#NIL THEN msg ¬ msg.Substr[2];
RETURN}};
defaultHow: How ¬ [];
defaultMargin: INT ¬ 80;

Fmt: PROC [a: Any] RETURNS [ROPE] ~ {
buf: IO.STREAM ~ IO.ROS[];
Print[a, buf];
RETURN buf.RopeFromROS[]};

NoteProfile: PROC [reason: UserProfile.ProfileChangeReason] --UserProfile.ProfileChangedProc--~ {
defaultHow ¬ [
sia: UserProfile.Number["SchemePretty.sia", 2],
simpleLen: UserProfile.Number["SchemePretty.simpleLen", 2],
simpleQuote: UserProfile.Boolean["SchemePretty.simpleQuote", TRUE]
];
};

UserProfile.CallWhenProfileChanges[NoteProfile];

Commander.Register[key: "SchemePrettyPrintExpr", proc: Cmd, doc: "Pretty prints stdin to stdout", clientData: $expr];
Commander.Register[key: "SchemePrettyPrintData", proc: Cmd, doc: "Pretty prints stdin to stdout", clientData: $data];

END.

˜
SchemePrinter.mesa
Copyright Σ 1990, 1992 by Xerox Corporation.  All rights reserved.
Last tweaked by Mike Spreitzer on May 12, 1992 9:44 am PDT
Κ~–
(cedarcode) style•NewlineDelimiter

™
codeš
œ™Kšœ
Οe
œ7™BK™:—K˜KšΟk	œžœX˜uK˜šΟn
œžœ
ž˜KšžœžœG˜bKšžœ˜Kš
œ
˜
—K˜Kšžœ
žœžœžœ˜KK˜Kšœžœžœ˜)šœžœžœ˜"Kšœžœ
žœ
˜K˜	Kšœžœ
žœ
˜Kš
œ˜K˜—K˜Kšœžœžœ)˜@K˜Kšœžœžœžœžœžœžœžœ˜lKšœžœžœ˜*K˜Kšœžœ%˜:Kšœ	žœ˜&Kšœ	žœ˜&Kšœ
žœ!˜2Kšœžœ!˜5Kšœžœ"˜4Kšœ	žœ˜$K˜šŸœžœ
žœžœ
žœžœžœžœ
žœžœžœ
žœžœ˜›
Kšœžœ.˜BKšžœ	žœ
žœžœžœžœ˜1šžœ	ž˜Kš
œ˜K˜Kšžœžœ&˜6—K˜—K˜šŸ	œžœ,˜;K˜Kšžœ
žœ
žœ
žœ
˜šžœžœ
ž˜Kš
œ9˜9Kš
œ3˜3š
œ˜šžœžœ
žœ˜Kš
œ˜Kšœžœ˜"Kšžœ˜—šžœžœ
ž˜šœžœžœž˜Kš
œ0˜0Kš
œ5˜5Kš
œ4˜4Kš
œ<˜<Kš
œC˜CKš
œ-˜-Kš
œ%˜%K˜2Kšœ!žœ
˜0Kšœ!žœ
˜/Kšœžœ
˜-Kšœ?žœ
˜NKš
œ+˜+Kš
œ%˜%Kš
œ2˜2K˜-Kšžœžœžœ
˜7—Kšžœ žœ"˜N——Kšžœ2˜9—Kšžœ˜—K˜šŸ	œžœ,˜;K˜Kšžœ
žœ
žœ
žœ
˜šžœžœ
ž˜Kš
œ9˜9Kš
œ3˜3š
œ˜šžœžœ
ž˜šœžœžœž˜Kš
œ4˜4Kš
œ<˜<KšžœD˜K—KšžœE˜L——Kšžœ2˜9—Kšžœ˜—K˜šŸœžœ'Ÿœ˜NKšœžœ˜K˜Kšžœžœžœžœ˜6Kšžœ˜šžœžœ
žœž˜K˜Kšžœžœ
žœ˜,Kšœžœžœžœžœ
žœ˜6Kšžœ
˜—Kšžœ˜Kšžœ˜—K˜šŸ
œžœžœžœ˜Všžœžœ
ž˜šœžœžœ
žœ˜K˜K˜Kšžœ˜—Kšžœžœ
˜—Kšœžœžœ
˜.Kšžœ˜—K˜šŸœžœžœžœ˜Xšžœžœ
ž˜šœžœžœ
žœ˜K˜K˜Kšžœ˜—Kšžœžœ
˜—Kšœžœžœ
˜.Kšžœ˜—K˜šŸœžœžœ˜Gšžœžœ
ž˜˜šœžœ˜)šžœ
žœžœ
ž˜Kšœžœžœ
žœžœžœ˜hKšžœ˜—Kšžœ˜—Kšžœ˜K˜K˜#K˜Kšœžœžœ
žœžœ
žœ˜>Kšœžœžœ˜<—Kšžœžœžœ˜:——K˜šŸœžœžœ˜Jšžœžœ
ž˜šœžœžœ
ž˜5˜Kšœžœžœ
žœ˜AKšžœ˜K˜K˜#K˜Kš
œ%˜%Kšœžœžœžœ
žœ(žœ˜lKšžœ˜—Kšžœžœ
˜—KšžœΟc
žœ
˜—Kšœžœžœ
˜.Kšžœ˜—K˜šŸœžœ0˜BKš
œ>˜>—K˜šŸœžœžœ˜Fšžœžœ
ž˜šœ  ˜2šžœžœ
ž˜šœ ˜)Kšœžœ ˜0Kšœ!žœžœ
˜.K˜šžœ ž˜*Kšœ$žœ
˜)Kšœžœ
˜Kšœžœ
˜Kšžœžœ
˜—Kšžœžœ
žœ
ž˜šžœ
žœžœ
žœžœ
ž˜5šœžœž˜:Kšœ
žœ
˜Kšœžœ
˜Kšœ%žœ
˜+Kšžœžœ
˜—Kšžœžœ
˜+—Kšžœ˜K˜Kš
œ˜Kš
žœžœžœžœ
žœ˜WKšœžœ˜$Kš
œžœžœ
žœ	žœ	žœžœ
˜WKšžœ	žœ
žœ˜ Kšœžœžœ˜AKšžœ	žœ
žœ˜Kšžœ˜—Kšžœžœ
˜——Kšžœžœ
˜—Kšœžœžœ
˜.Kšžœ˜—K˜šŸ	œžœžœ˜Hšžœžœ
ž˜˜Kšžœ˜K˜K˜#K˜Kšœžœžœ
žœžœ
žœ˜IKšœžœ*žœ˜SKšžœ˜—Kšžœžœžœ˜:——K˜šŸ	œžœžœžœ˜TKšœžœ
˜K˜Kšœžœžœ
˜š	žœžœ
žœžœ
ž˜"K˜(Kšžœžœžœžœ˜C—Kšžœ˜K˜K˜#šžœžœ˜K˜Kšœžœžœ
žœžœ
žœ˜9Kšžœ%˜'K˜
—šžœ˜Kšžœžœ
žœžœžœ
žœ˜HKšžœ%˜'—Kšžœ˜Kšœžœ'žœ˜GKšžœ˜Kšžœ˜—K˜šŸœžœ,˜Ašžœžœ
ž˜š
œ
˜
Kšœžœ˜*šŸœžœ$žœ˜9Kš
œžœžœ
žœ
žœ
žœžœ˜[Kšžœžœ*˜5Kšœ2žœ˜8K˜—K˜Kšžœ˜Kšœžœžœ
žœžœ
žœ˜=Kš
žœžœ
žœžœ
žœ˜+šžœžœ
ž˜šœžœž˜šœžœžœ
ž˜"Kšœžœ	žœ˜Ešžœžœž˜Kšžœžœžœžœ
˜&Kšžœžœžœžœ˜)——Kšžœžœ	žœ˜E—Kšžœžœžœžœ˜.—Kš
œ˜—Kšžœ˜&—Kšžœ˜—K˜šŸœžœžœžœ˜VKšœžœžœ
˜Kšœžœžœ
˜K˜š	žœ	žœ
žœžœ
ž˜%šœžœžœ
ž˜!Kšœžœ
žœ˜2Kšžœžœ
˜—Kšžœžœ
˜—šžœžœ
ž˜šœ ˜&Kšžœ˜K˜K˜#K˜šžœžœ˜Kšžœ˜Kš
œ#˜#Kšžœ˜—Kšœ;žœžœ
žœžœ
žœ˜hKšžœžœ
žœ˜Kšœžœ*žœ˜SKš
œ˜—Kšžœžœžœ
˜9—Kšžœ˜—K˜šŸœžœ,˜>šžœžœ
ž˜šœ 	œ
žœžœ
ž˜3šœžœžœžœ
ž˜%š	œ œ
žœžœ
žœ˜.Kš
œ?˜?Kšžœ˜—Kšžœžœ
˜—Kšžœžœ
˜—Kšžœžœ
˜—Kš
œB˜BKšžœ˜—K˜šŸ
œžœžœ˜IKšžœ˜K˜Kšžœžœ
žœžœžœ
žœ˜HKšžœ$˜&Kšžœ˜Kšœžœ!žœ˜AKšžœ˜Kšžœ˜—K˜šŸœžœžœ˜Fšžœžœ
ž˜šœ œ
žœžœ
ž˜Jšœ ˜"K˜Kšžœ˜K˜Kšžœ˜Kš
œ>˜>Kšžœ˜Kšœ"žœžœ
žœžœ
žœ˜OKšžœ˜Kšœžœ*žœ˜SKšžœ˜—Kšžœžœ
˜—Kšžœžœ
˜—Kšœžœžœ
˜.Kšžœ˜—K˜šŸœžœžœ˜Jšžœžœ
ž˜šœ ˜%Kšžœ˜K˜K˜#K˜Kšœ6žœ
žœ
žœžœ
žœ˜bKšœžœ0žœ˜XKšžœ˜—Kšžœžœžœ
˜9—Kšžœ˜—K˜šŸœžœ,˜AKš
œ8˜8—K˜šŸœžœžœ˜JKšœžœžœ
˜šŸœžœžœžœ˜RKšœžœ
˜šœ
žœžœžœ
ž˜%Kš
œ˜Kšžœžœ
˜—K˜Kšžœ$žœ
˜9—šžœžœ
ž˜˜Kšžœ˜K˜K˜#K˜Kš
œ$˜$Kš
žœžœ
žœ!žœ-žœ
˜ršžœ˜Kšžœ žœ˜'Kšœžœ˜Kšžœ
˜—Kš
œ˜—Kšžœžœžœ˜:——K˜šŸœžœ,˜>šžœžœ
ž˜šœžœžœ
ž˜!Kšœžœžœžœ
˜7Kšžœ žœ!˜M—Kšžœ ˜'——K˜šŸ	œžœ@žœ˜eKšœžœžœ
˜šŸœžœžœžœ˜LKšœžœ
˜Kšœ
žœžœ˜*K˜Kšžœžœ
žœ
žœ˜&Kšžœ
žœžœžœ
žœ
žœ˜H—Kšžœ˜K˜Kšœžœžœ
žœžœ
žœ˜9Kšžœžœ
žœ#˜8Kšžœ
žœžœ
žœ&˜@Kšžœ
žœ˜#Kšžœ˜Kšœžœ(žœ˜HKšžœ˜Kšžœ˜—K˜šŸœžœ$žœŸœ˜nšŸœžœžœžœ˜HKšœžœžœžœžœžœ˜4—Kš
œA˜A—K˜šŸ
œžœ-Ÿœ˜cšŸœžœžœžœ˜HKšœžœžœžœžœžœ˜4—Kš
žœžœ
žœ-žœžœ˜Lšžœžœ
ž˜˜Kšžœ˜K˜Kšœžœ$žœ˜E—Kšžœ ˜'—Kšžœ˜—K˜Kš	œ	žœžœžœžœ
˜QK˜š
Ÿœžœ$žœ
ŸœŸœ˜wšžœžœ
žœ
ž˜šžœžœ
ž˜šœžœžœ
˜,Kš
œ4˜4Kš
œžœžœžœžœžœ
žœ˜KKšœžœ
˜Kš
œ˜Kšœžœžœžœ	˜9šžœžœ˜Kš
œ˜Kšžœžœ˜2Kšžœ˜——šžœ˜Kšœ%žœ
˜3Kšœžœžœžœ
˜4Kš
œ˜K˜Kšœžœžœžœ	˜8Kš
œ˜Kšžœžœ˜2Kšžœ˜——Kšžœ
˜—Kšžœ˜Kšžœ˜—K˜KšŸ
œ
žœ
žœ˜1K˜KšŸ	œ
žœ˜2K˜šŸœžœžœžœ˜4šžœžœ
ž˜šœžœžœžœ˜Ešžœ
žœžœ
ž˜Kšœžœžœ
žœ˜5Kšžœžœžœ
˜—Kšžœ
žœžœ
˜—Kšžœžœžœ˜——K˜šŸœžœžœžœ
˜0Kšœžœžœ!˜1—K˜Kšœžœ˜1K˜šŸœžœžœ˜@šžœžœ
ž˜š
œ˜K˜
K˜K˜šžœžœ
žœ˜6šžœ
žœžœ
ž˜šœžœž˜Kšžœ
žœ˜ Kšžœ
žœ
˜—Kšžœžœ˜——š
ž˜Kšžœžœ
žœ˜+šžœžœ
ž˜Kšœžœ˜Kšžœžœ
˜—Kšžœžœ
žœ
žœ
˜!šžœžœ
ž˜Kšœ1žœ˜7Kš
žœžœžœžœžœ
˜D—Kšžœ˜	——Kšžœžœ˜——K˜šŸœžœ#žœ˜8Kšžœ(˜*Kšžœžœ
žœ(˜<Kšžœ˜—K˜šŸœžœžœžœ
˜0Kšœžœžœžœ˜/—K˜šŸœžœžœ
žœ
žœžœžœžœ œ˜pKš	œžœ
žœžœ
žœ˜,K˜Kšœžœ˜Kšœžœžœ
˜Kšœžœ
˜
š
ž˜šžœ˜K˜:Kšžœ˜—K˜šŸœžœ
žœ
˜$šžœžœ
ž˜Kšœžœ˜Kšžœ4˜;——Kšžœžœ
žœ
˜šžœžœ
ž˜šœžœž˜K˜'K˜%K˜1K˜3Kšžœžœ;˜L—Kšžœžœ;˜L—š
ž˜Kšœ	žœ-˜<—Kšžœ
˜—Kšœžœ
žœ6˜HKšœžœ
žœžœ˜K˜!š
ž˜K˜Kšžœžœ
žœ
˜K˜Kšœžœ˜<K˜Kšœ
žœ
˜	—K˜!Kšžœžœ
žœ˜$Kšžœ˜	K˜Kšœžœ˜—K˜šŸœžœ
žœžœ˜%Kš	œžœ
žœžœ
žœ˜K˜Kšžœ˜—K˜šŸœžœ+ "œ˜a˜Kš
œ/˜/Kš
œ;˜;Kšœ=žœ
˜BK˜—K˜—K˜Kš
œ0˜0K˜Kš
œu˜uKš
œu˜uK˜Kšžœ
˜K˜—…—K eΆ