SchemeSysImpl.mesa
Copyright Ó 1987, 1988, 1991 by Xerox Corporation. All rights reserved.
Michael Plass, December 2, 1991 11:14 am PST
Last changed by Pavel on May 16, 1988 7:38:35 pm PDT
Carl Hauser, October 17, 1988 2:43:19 pm PDT
DIRECTORY Ascii, Atom, Commander, IO, ProcessProps, Rope, RuntimeError, Scheme, SchemePrivate, SchemeStart, SchemeSys, UXIO;
SchemeSysImpl: CEDAR PROGRAM
IMPORTS Atom, Commander, IO, ProcessProps, Rope, RuntimeError, Scheme, UXIO
EXPORTS SchemeSys, SchemeStart
~ BEGIN OPEN Scheme;
ROPE: TYPE ~ Rope.ROPE;
savedEnv: Environment ¬ NIL;
RunScheme: PUBLIC --SchemeStart-- PROC ~ {
Call this from pcr to get things started:
callall ←RunScheme�
env: Environment ¬ savedEnv;
in: IO.STREAM ¬ UXIO.CreateStandardStream[input];
out: IO.STREAM ¬ UXIO.CreateStandardStream[output];
Inner: PROC ~ {
IF env = NIL
THEN { savedEnv ¬ env ¬ NewEnvironmentStructure[] }
ELSE { InitializeEnvironmentStructure[env] };
ReadEvalPrintLoop[in, out, env];
SELECT IO.PeekChar[in] FROM
Ascii.LF, Ascii.CR => [] ¬ IO.GetChar[in];
ENDCASE;
};
DoWithPorts[in: in, out: out, proc: Inner];
};
System-dependent functions
OpenedStream: TYPE ~ RECORD [s: IO.STREAM ¬ NIL, fullFName: ROPE ¬ NIL, shortFName: ROPE, searchRules: LIST OF ROPE];
IsFileStream: PUBLIC PROC [stream: IO.STREAM] RETURNS [BOOL] ~ {
RETURN [FALSE]
};
GetFileNameForStream: PUBLIC PROC [stream: IO.STREAM] RETURNS [ROPE] ~ {
RETURN [NIL];
};
GetFileCreateDateForStream: PUBLIC PROC [stream: IO.STREAM] RETURNS [ROPE] ~ {
RETURN [NIL];
};
CheckForAbort: PUBLIC PROC ~ { };
GetStdStream: SIGNAL [inP: BOOL] RETURNS [IO.STREAM] ~ CODE;
GetPort: PUBLIC PROC [param: REF, in: BOOL] RETURNS [IO.STREAM] ~ {
IF param = undefined
THEN {
stream: IO.STREAM ¬ GetStdStream[inP: in];
RETURN [stream]
}
ELSE RETURN [ThePort[param]];
};
SetPortSignal: SIGNAL [newPort: IO.STREAM, setIn: BOOL] ~ CODE;
SetPortSignal is raised by SetPort and caught & resumed by DoWithPort or DoWithPorts
SetPort: PUBLIC PROC [port: IO.STREAM, in: BOOL] ~ {
We assume that we're in the scope of DoWithPort or DoWithPorts
SIGNAL SetPortSignal[port, in];
};
DoWithPort: PUBLIC PROC [port: IO.STREAM, proc: PROC, in: BOOL] ~ {
proc[ !
GetStdStream => {IF inP = in THEN RESUME[port] ELSE REJECT};
SetPortSignal => {IF setIn = in THEN {port ¬ newPort; RESUME} ELSE REJECT}
];
};
ErrorPrompt: PROC [in, out: IO.STREAM, sig: SIGNAL ANY RETURNS ANY] RETURNS [reject: BOOL ¬ FALSE] ~ {
SigToRope: PROC [signal: SIGNAL ANY RETURNS ANY] RETURNS [signalRope: ROPE] ~ {
OPEN RuntimeError;
signalRope ¬
SELECT signal FROM
System errors
LOOPHOLE[Aborted] => "Aborted",
LOOPHOLE[AbstractionFault] => "AbstractionFault",
LOOPHOLE[ArithmeticFault] => "ArithmeticFault",
LOOPHOLE[AssignRefCompositeFault] => "AssignRefCompositeFault",
LOOPHOLE[BoundsFault] => "BoundsFault",
LOOPHOLE[DivideCheck] => "DivideCheck",
LOOPHOLE[LinkageFault] => "LinkageFault",
LOOPHOLE[NarrowFault] => "NarrowFault",
LOOPHOLE[NarrowRefFault] => "NarrowRefFault",
LOOPHOLE[NestedProcFault] => "NestedProcFault",
LOOPHOLE[NilFault] => "NilFault",
LOOPHOLE[ResumeFault] => "ResumeFault",
LOOPHOLE[SendMsg] => "SendMsg",
LOOPHOLE[StackFault] => "StackFault",
LOOPHOLE[StartFault] => "StartFault",
LOOPHOLE[UnboundProcedureFault] => "UnboundProcedureFault",
LOOPHOLE[Uncaught] => "Uncaught",
LOOPHOLE[UnnamedError] => "UnnamedError",
LOOPHOLE[UnnamedSignal] => "UnnamedSignal",
LOOPHOLE[Unwind] => "Unwind",
LOOPHOLE[UnwindFault] => "UnwindFault",
LOOPHOLE[ZeroDivisor] => "ZeroDivisor",
local errors
LOOPHOLE[FileNotFound] => "FileNotFound",
ENDCASE => "unrecognized error";
};
IO.PutRope[out, "\n*** Bad News; uncaught ERROR or SIGNAL: "];
IO.PutRope[out, SigToRope[sig]];
IO.PutRope[out, "\n*** REJECT? "];
IO.Flush[out];
SELECT IO.PeekChar[in] FROM
Ascii.LF, Ascii.CR => [] ¬ IO.GetChar[in];
ENDCASE;
DO
c: CHAR ~ IO.GetChar[in];
UNTIL IO.GetChar[in] < ' DO ENDLOOP;
SELECT c FROM
'y, 'Y => RETURN [TRUE];
'n, 'N => RETURN [FALSE];
ENDCASE => IO.PutRope[out, "\n*** Type 'y' to REJECT the signal and land in the system debugger, 'n' to try for the Scheme debugger: "];
ENDLOOP;
};
DoWithPorts: PUBLIC PROC [in, out: IO.STREAM, proc: PROC] ~ {
proc[ !
GetStdStream => RESUME[IF inP THEN in ELSE out];
SetPortSignal => {IF setIn THEN in ¬ newPort ELSE out ¬ newPort; RESUME};
RuntimeError.UNCAUGHT => IF ErrorPrompt[in, out, signal].reject THEN REJECT ELSE Complain[$ERROR, "Unknown ERROR or SIGNAL"]
];
};
DoWithIOErrorCatch: PUBLIC PROC [proc: PROC] ~ {
proc[ !
IO.Error => {Complain[NIL, IO.PutFR1[format: "%g", value: [refAny[NEW[IO.ErrorCode ¬ ec]]]]]};
UXIO.Error => {Complain[NIL, "I/O error"]};
FileNotFound => {Complain[NIL, "File Not Found"]};
IO.Rubout => {Complain[NIL, "<DEL>"]};
];
};
OpenFile: PUBLIC PROC [fileName: Rope.ROPE, in: BOOL] RETURNS [IO.STREAM] ~ {
RETURN [UXIO.CreateFileStream[name: fileName, access: IF in THEN $read ELSE $write]]
};
FileNotFound: ERROR ~ CODE;
TryToOpen: PROC [names: LIST OF ROPE, searchRules: LIST OF ROPE] RETURNS [r: OpenedStream] ~ {
tried: ProperList ¬ NIL;
IF searchRules = NIL THEN searchRules ¬ LIST[NIL];
FOR sR: LIST OF ROPE ¬ searchRules, sR.rest UNTIL sR=NIL DO
FOR nms: LIST OF ROPE ¬ names, nms.rest UNTIL nms=NIL DO
r.shortFName ¬ nms.first;
IF NOT Rope.IsEmpty[nms.first] THEN {
r.fullFName ¬ Rope.Concat[sR.first, nms.first];
tried ¬ Cons[r.fullFName, tried];
r.s ¬ UXIO.CreateFileStream[name: r.fullFName, access: read ! UXIO.Error => CONTINUE];
IF r.s # NIL THEN {r.searchRules ¬ sR; RETURN};
};
IF Rope.Size[sR.first] > 0 THEN EXIT; -- don't look for .scheme outside of cwd
ENDLOOP;
ENDLOOP;
DebugPrint[$failedToOpen, Reverse[tried]];
ERROR FileNotFound;
};
loadSearchRules: LIST OF ROPE ¬ LIST["", "schemeFiles/", "/usr/local/lib/scheme/"];
FindFileToLoad: PUBLIC PROC [loadeeName: Rope.ROPE, inner: PROC [port: IO.STREAM, doExpand: BOOL]] ~ {
fileName: ROPE ~ loadeeName;
schemeName: ROPE;
xSchemeName: ROPE;
SELECT TRUE FROM
Rope.Match[pattern: "*.$cheme", object: fileName, case: TRUE] => {
xSchemeName ¬ fileName;
};
Rope.Match[pattern: "*.*", object: fileName, case: TRUE] => {
schemeName ¬ fileName;
};
ENDCASE => {
schemeName ¬ Rope.Concat[fileName, ".scheme"];
xSchemeName ¬ Rope.Concat[fileName, ".$cheme"];
};
{
searchRules: LIST OF ROPE ~ NARROW[ProcessProps.GetProp[$SchemeLoadSearchRules]];
in: OpenedStream ~ TryToOpen[names: LIST[xSchemeName, schemeName], searchRules: IF searchRules # NIL THEN searchRules ELSE loadSearchRules];
Inner: PROC ~ {
inner[port: in.s, doExpand: in.shortFName#xSchemeName ! UNWIND => IO.Close[in.s]];
};
ProcessProps.AddPropList[propList: Atom.PutPropOnList[propList: NIL, prop: $SchemeLoadSearchRules, val: in.searchRules], inner: Inner];
IO.Close[in.s];
};
};
GetRope: PUBLIC PROC [self: IO.STREAM, len: INT, demand: BOOL ¬ FALSE] RETURNS [ROPE] ~ {
buf: REF TEXT ¬ NEW[TEXT[len]];
[] ¬ IO.GetBlock[self: self, block: buf];
IF demand AND buf.length # len THEN ERROR;
RETURN [Rope.FromRefText[buf]]
};
Debug Printing
debugPrintControl: REF ¬ $TRUE;
DebugPrintSwitch: PUBLIC PROC [control: REF] ~ {
debugPrintControl ¬ control;
};
PrintC: PROC [c: CHAR] ~ TRUSTED MACHINE CODE {"XR�ugPutChar"};
PrintN: PROC [n: INT] ~ {
IF n < 0 THEN PrintC['-];
PrintCard[ABS[n]];
};
PrintCard: PROC [n: CARD] ~ {
IF n <= 9 THEN PrintC['0+n] ELSE {PrintCard[n/10]; PrintC['0+(n MOD 10)]}
};
PrintOctal: PROC [n: CARD] ~ {
IF n = 0 THEN PrintC['0] ELSE { PrintOctal[n/8]; PrintC['0+(n MOD 8)] }
};
PrintRopeLiteral: PROC [rope: ROPE] ~ {
i: INT ¬ 0;
Action: PROC [c: CHAR] RETURNS [quit: BOOL ¬ FALSE] ~ {
IF c = '" OR c='\\ THEN PrintC['\\];
PrintC[c];
i ¬ i + 1;
RETURN [i > 250]
};
PrintC['"];
[] ¬ Rope.Map[base: rope, action: Action];
PrintC['"];
};
PrintRope: PROC [rope: ROPE] ~ {
Action: PROC [c: CHAR] RETURNS [quit: BOOL ¬ FALSE] ~ { PrintC[c] };
[] ¬ Rope.Map[base: rope, action: Action];
};
DPrint: PROC [a: Any, terse: BOOL ¬ FALSE] ~ {
PrintList: PROC [pair: Pair] ~ {
rest: Pair ¬ NIL;
rem: INT ¬ width;
FOR each: Pair ¬ pair, rest UNTIL each = NIL DO
IF rest # NIL THEN PrintC[' ];
IF rem <= 0 THEN {PrintRope["..."]; EXIT};
DPrint[each.car];
rem ¬ rem - 1;
WITH each.cdr SELECT FROM
p: Pair => rest ¬ p;
ENDCASE => {
IF each.cdr # NIL THEN {
PrintRope[" . "];
DPrint[each.cdr];
};
rest ¬ NIL;
};
ENDLOOP;
};
IF depth = 0 THEN { PrintRope["#<...>"]; RETURN};
depth ¬ depth - 1;
WITH a SELECT FROM
pair: Pair => {
IF depth = 0
THEN {PrintRope["( . . . )"]; RETURN}
ELSE {
PrintRope["("];
PrintList[pair];
PrintRope[")"];
};
};
num: Fixnum => PrintN[num­];
num: Flonum => PrintRope["#<flonum>"];
num: Bignum => PrintRope["#<bignum>"];
num: Ratnum => PrintRope["#<ratnum>"];
num: Complex => PrintRope["#<complex>"];
b: REF BOOL => PrintRope[IF b­ THEN "#t" ELSE "#f"];
v: SimpleVector => {
PrintRope["#( . . . )"];
};
symbol: Symbol => {
rope: ROPE ~ Atom.GetPName[symbol];
PrintRope[rope];
};
string: String => {
PrintRopeLiteral[Scheme.RopeFromString[string]];
};
rope: ROPE => {
PrintRope["#<rope "];
PrintRope[rope];
PrintRope[">"];
};
text: REF TEXT => {
PrintRope["#<REF TEXT "];
FOR i: NAT IN [0..text.length) DO PrintC[text[i]] ENDLOOP;
PrintRope[">"];
};
char: Char => {
PrintRope["#\\"];
PrintC[char­];
};
p: Primitive => {
PrintRope["#<primitive procedure>"];
};
p: SchemePrivate.TidbitProcedure => {
PrintRope["#<compound procedure>"];
};
s: Syntax => {
PrintRope["#<syntax>"];
};
p: PrimitiveSyntax => {
SELECT p­ FROM
quote => PrintRope["QUOTE"];
define => PrintRope["DEFINE"];
setBang => PrintRope["SET!"];
lambda => PrintRope["LAMBDA"];
begin => PrintRope["BEGIN"];
if => PrintRope["IF"];
ENDCASE => ERROR;
};
env: Environment => {
PrintRope["#<environment>"];
};
p: Port => {
PrintRope["#<port>"];
};
ENDCASE => {
IF a = NIL
THEN PrintRope["()"]
ELSE { PrintRope["#<??? "]; TRUSTED {PrintOctal[LOOPHOLE[a]]}; PrintRope[">"] }
};
depth ¬ depth + 1;
};
width: INT ¬ 100;
maxDepth: NAT ¬ 40;
depth: NAT ¬ 40;
DebugPrint: PUBLIC PROC [where: ATOM, any: REF] ~ {
depth ¬ 40;
PrintC['[];
IF where # NIL THEN PrintRope[Atom.GetPName[where]];
PrintC[' ];
DPrint[any];
PrintC[']];
PrintC['\n];
};
Commander commands
GetEnvFromCommander: PROC [cmd: Commander.Handle] RETURNS [newEnv: Environment] = {
Inner: PROC ~ {
WITH Atom.GetPropFromList[cmd.propertyList, $SchemeEvironment] SELECT FROM
e: Environment => {
InitializeEnvironmentStructure[e];
newEnv ¬ e;
};
ENDCASE => {
e: Environment ~ NewEnvironmentStructure[];
cmd.propertyList ¬ Atom.PutPropOnList[cmd.propertyList, $SchemeEvironment, e];
newEnv ¬ e;
};
};
DoWithPorts[in: cmd.in, out: cmd.out, proc: Inner];
};
SchemeCommand: Commander.CommandProc = {
[cmd: Commander.Handle] RETURNS [result: REF ANY ← NIL, msg: ROPE ← NIL]
userEnv: Environment ~ GetEnvFromCommander[cmd];
ris: IO.STREAM ~ IO.RIS[cmd.commandLine];
promptName: Symbol ~ Atom.MakeAtom["*read-eval-print-prompt*"];
IF Scheme.Read[ris] = endOfFile
THEN {
DefineVariable[variable: promptName, value: true, env: userEnv];
ReadEvalPrintLoop[cmd.in, cmd.out, userEnv];
}
ELSE {
DefineVariable[variable: promptName, value: false, env: userEnv];
IO.SetIndex[ris, 0];
ReadEvalPrintLoop[ris, cmd.out, userEnv];
};
};
Commander.Register[key: "Scheme", proc: SchemeCommand, doc: "Scheme read-eval-print loop", interpreted: FALSE
! RuntimeError.UNCAUGHT => {
DebugPrint[$SchemeSysImpl, "Failed to register Scheme command"];
CONTINUE
}
];
END.