SchemeSysPFSImpl.mesa
Copyright Ó 1987, 1988, 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
Michael Plass, December 2, 1991 10:31 am PST
Last changed by Pavel on February 28, 1990 5:50 pm PST
Carl Hauser, October 17, 1988 2:43:19 pm PDT
DIRECTORY Ascii, Atom, BasicTime, Commander, IO, PFS, PFSNames, Process, Rope, RuntimeError, Scheme, SchemePrivate, SchemeStart, SchemeSys, UXIO;
SchemeSysPFSImpl: CEDAR PROGRAM
IMPORTS Atom, BasicTime, Commander, IO, PFS, PFSNames, Process, Rope, RuntimeError, Scheme, UXIO
EXPORTS SchemeSys, SchemeStart
~ BEGIN OPEN Scheme;
ROPE: TYPE ~ Rope.ROPE;
PATH: TYPE ~ PFS.PATH;
savedEnv: Environment ¬ NIL;
SymbolForErrorCode: REF ARRAY IO.ErrorCode OF Symbol = InitSymbolForErrorCode[];
InitSymbolForErrorCode: PROC RETURNS [a: REF ARRAY IO.ErrorCode OF Symbol] = {
a ¬ NEW[ARRAY IO.ErrorCode OF Symbol];
a[Null] ¬ Atom.MakeAtom["/null"];
a[NotImplementedForThisStream] ¬ Atom.MakeAtom["/not-implemented-for-this-stream"];
a[StreamClosed] ¬ Atom.MakeAtom["/stream-closed"];
a[Failure] ¬ Atom.MakeAtom["/failure"];
a[IllegalBackup] ¬ Atom.MakeAtom["/illegal-backup"];
a[BufferOverflow] ¬ Atom.MakeAtom["/buffer-overflow"];
a[BadIndex] ¬ Atom.MakeAtom["/bad-index"];
a[SyntaxError] ¬ Atom.MakeAtom["/syntax-error"];
a[Overflow] ¬ Atom.MakeAtom["/overflow"];
a[PFInvalidCode] ¬ Atom.MakeAtom["/p-f-invalid-code"];
a[PFInvalidPFProcs] ¬ Atom.MakeAtom["/p-f-invalid-p-f-procs"];
a[PFCantBindConversionProc] ¬ Atom.MakeAtom["/p-f-cant-bind-conversion-proc"];
a[PFFormatSyntaxError] ¬ Atom.MakeAtom["/p-f-format-syntax-error"];
a[PFTypeMismatch] ¬ Atom.MakeAtom["/p-f-type-mismatch"];
a[PFUnprintableValue] ¬ Atom.MakeAtom["/p-f-unprintable-value"];
};
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 ~ {
Process.CheckForAbort[];
};
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",
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[SymbolForErrorCode[ec], "I/O Error"]};
UXIO.Error => {Complain[NIL, "Unix I/O error"]};
PFS.Error => {Complain[Cons[$pfserror, Cons[error.code, NIL]], error.explanation]};
IO.Rubout => {Complain[NIL, "<DEL>"]};
];
};
OpenFile: PUBLIC PROC [fileName: Rope.ROPE, in: BOOL] RETURNS [IO.STREAM] ~ {
path: PFS.PATH ~ PFS.PathFromRope[fileName];
stream: IO.STREAM ~ PFS.StreamOpen[fileName: path, accessOptions: IF in THEN read ELSE create];
RETURN [stream]
};
loadSearchRules: LIST OF PATH ¬ LIST[PFS.PathFromRope["/Cedar/SchemeLib/"]];
FindFileToLoad: PUBLIC PROC [loadeeName: ROPE, inner: PROC [port: IO.STREAM, doExpand: BOOL]] ~ {
schemeName: ROPE ¬ NIL;
xSchemeName: ROPE ¬ NIL;
WithCatch: PROC = {
LookupObjectWithRules: PROC [path: PATH] ~ {
IF PFSNames.ComponentCount[path] > 1 THEN
name has directory component so don't use the search rules
Doit[path, FALSE]
ELSE {
fullPath: PATH ~ PFS.FileSearch[path, CONS[PFS.GetWDir[], loadSearchRules]];
IF fullPath = NIL THEN
Complain[StringFromRope[PFS.RopeFromPath[path]], "file cannot be found."]
ELSE
Doit[fullPath, FALSE]
};
};
Doit: PROC [path: PATH, doExpand: BOOL] ~ {
dir: PATH ~ PFSNames.Directory[PFS.AbsoluteName[path]];
Action: PROC ~ {
inner[
port: PFS.StreamOpen[path, $read
! PFS.Error =>
Complain[StringFromRope[PFS.RopeFromPath[PFS.AbsoluteName[path]]],
Rope.Concat["file cannot be opened: ", error.explanation]]],
doExpand: doExpand];
};
PFS.DoInWDir[dir, Action];
};
IF xSchemeName = NIL THEN -- "foo.scheme" was specified; don't use search rules
Doit[PFS.PathFromRope[schemeName], TRUE]
ELSE IF schemeName = NIL THEN -- "foo.$cheme" was specified; do use rules
LookupObjectWithRules[PFS.PathFromRope[xSchemeName]]
ELSE {
no extension specified; check for most recent in WDir and then xScheme with rules
path: PATH ~ PFS.PathFromRope[schemeName];
xPath: PATH ~ PFS.PathFromRope[xSchemeName];
date, xDate: BasicTime.GMT ¬ BasicTime.nullGMT;
date ¬ PFS.FileInfo[path ! PFS.Error => CONTINUE].uniqueID.egmt.gmt;
IF date = BasicTime.nullGMT THEN -- no ".scheme" version in WDir
LookupObjectWithRules[xPath]
ELSE {
xDate ¬ PFS.FileInfo[xPath ! PFS.Error => CONTINUE].uniqueID.egmt.gmt;
IF xDate = BasicTime.nullGMT OR BasicTime.Period[from: date, to: xDate] < 0 THEN
Doit[path, TRUE]
ELSE
Doit[xPath, FALSE];
};
};
};
SELECT TRUE FROM
Rope.Match[pattern: "*.$cheme", object: loadeeName, case: TRUE] => {
xSchemeName ¬ loadeeName;
};
Rope.Match[pattern: "*.*", object: loadeeName, case: TRUE] => {
schemeName ¬ loadeeName;
};
ENDCASE => {
schemeName ¬ Rope.Concat[loadeeName, ".scheme"];
xSchemeName ¬ Rope.Concat[loadeeName, ".$cheme"];
};
DoWithIOErrorCatch[WithCatch];
};
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.