SchemePrinter.mesa
Copyright Ó 1990, 1992 by Xerox Corporation. All rights reserved.
Last tweaked by Mike Spreitzer on May 12, 1992 9:44 am PDT
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.