-- SchemeSysOpsMXCode.mesa
DIRECTORY Atom, BasicTime, Commander, CommanderOps, IO, ProcessProps, Rope, Scheme, SchemeRegistry, SchemeSys;
SchemeSysOpsMXCode: CEDAR PROGRAM
IMPORTS Atom, BasicTime, CommanderOps, IO, ProcessProps, Rope, Scheme, SchemeRegistry, SchemeSys
= BEGIN OPEN Scheme;
SymbolFromRope: PROC [rope: Rope.ROPE] RETURNS [Symbol] ~ {RETURN[Atom.MakeAtom[rope]]};
RopeFromSymbol: PROC [Symbol] RETURNS [Rope.ROPE] ~ Atom.GetPName;
TheEnvironment: PROC [a: Any] RETURNS [Scheme.Environment] = {
WITH a SELECT FROM
a: Scheme.Environment => RETURN [a];
ENDCASE => Complain[a, "not a Scheme.Environment"];
};
TheTimer: PROC [a: Any] RETURNS [Timer] = {
WITH a SELECT FROM
a: Timer => RETURN [a];
ENDCASE => Complain[a, "not a Timer"];
};
TheSymbol: PROC [a: Any] RETURNS [Scheme.Symbol] = {
WITH a SELECT FROM
a: Scheme.Symbol => RETURN [a];
ENDCASE => Complain[a, "not a Scheme.Symbol"];
};
SchemeSysOpsPrim: PROC [SELF: Primitive, ARG1,ARG2,ARG3: Any, REST: ProperList] RETURNS [result: Any ← unspecified] = {
POP: PROC RETURNS [a: Any ← undefined] = {
IF REST#NIL THEN {a ← REST.car; REST ← NARROW[REST.cdr]}};
DATA: Pair ~ NARROW[SELF.data];
env: Environment ~ NARROW[DATA.cdr];
SELECT NAT[NARROW[DATA.car, REF INT]↑] FROM
11 => {
result ← SchemeRegistry.ListNamedInitializers[];
};
10 => {
world: Any ← ARG1;
component: Any ← ARG2;
name: Any ← ARG3;
env: Any ← POP[];
worldRope: ROPE ~ Rope.Concat[RopeFromString[TheString[world]], " "];
componentRope: ROPE ~ Rope.Concat[RopeFromString[TheString[component]], " "];
nameRope: ROPE ~ Rope.Concat[RopeFromString[TheString[name]], " "];
result ← InitializationCommand[env, "Require", nameRope, worldRope, componentRope];
};
9 => {
componentName: Any ← ARG1;
env: Any ← ARG2;
name: ROPE ~ RopeFromString[TheString[componentName]];
result ← InitializationCommand[env, "Install -a", name];
};
8 => {
componentName: Any ← ARG1;
env: Any ← ARG2;
name: ROPE ~ RopeFromString[TheString[componentName]];
result ← InitializationCommand[env, "Install", name];
};
7 => {
commandString: Any ← ARG1;
outputPort: Any ← ARG2;
parent: Commander.Handle ~ WITH ProcessProps.GetProp[$CommanderHandle] SELECT FROM
h: Commander.Handle => h,
ENDCASE => NIL;
commandLine: ROPE ~ RopeFromString[TheString[commandString]];
savedOut: IO.STREAM;
IF parent # NIL THEN {
savedOut ← parent.out;
IF outputPort # undefined THEN parent.out ← ThePort[outputPort];
};
result ← CommanderOps.DoCommand[commandLine: commandLine, parent: parent ! UNWIND => IF parent # NIL THEN parent.out ← savedOut];
IF parent # NIL THEN parent.out ← savedOut;
SELECT result FROM NIL => {result ← true}; $Failure => {result ← false} ENDCASE;
};
6 => {
obj: Any ← ARG1;
result ← WITH obj SELECT FROM t: Timer => true ENDCASE => false;
};
5 => {
timer: Any ← ARG1;
t: Timer ~ TheTimer[timer];
t.pulses ← BasicTime.GetClockPulses[];
};
4 => {
timer: Any ← ARG1;
now: BasicTime.Pulses ~ BasicTime.GetClockPulses[];
result ← MakeFixnum[BasicTime.PulsesToMicroseconds[now-TheTimer[timer].pulses]]
};
3 => {
timer: REF TimerRep ~ NEW[TimerRep];
timer.pulses ← BasicTime.GetClockPulses[];
result ← timer;
};
2 => {
atom: Any ← ARG1;
key: Any ← ARG2;
value: Any ← ARG3;
Atom.PutProp[TheSymbol[atom], key, value];
};
1 => {
atom: Any ← ARG1;
key: Any ← ARG2;
result ← Atom.GetProp[TheSymbol[atom], key];
};
0 => {
portOrString: Any ← ARG1;
args: Any ← REST;
output, input: IO.STREAM;
string: String;
stringResult: BOOL ← FALSE;
IF ISTYPE[portOrString, String] THEN { -- Handle silly Chez Scheme compatibility
args ← Cons[portOrString, args];
portOrString ← false;
};
SELECT portOrString FROM
true => output ← SchemeSys.GetPort[undefined, FALSE];
false => {
output ← IO.ROS[];
stringResult ← TRUE;
};
ENDCASE => output ← ThePort[portOrString];
IF args = NIL THEN Complain[NIL, "Missing format-string argument"];
input ← IO.RIS[RopeFromString[string ← TheString[Car[args]]]];
args ← Cdr[args];
DO
char: CHAR ~ input.GetChar[! IO.EndOfStream => EXIT];
IF char = '~ THEN {
directive: CHAR ~
input.GetChar[! IO.EndOfStream => Complain[string, "Format-string ends with a tilde"]];
NextArg: PROC [] RETURNS [Any] ~ {
IF args = NIL THEN
Complain[NIL, "Too few arguments given to FORMAT"]
ELSE {
a: Any ← Car[args];
args ← Cdr[args];
RETURN[a];
};
};
SELECT directive FROM
's, 'S => Print[NextArg[], output];
'a, 'A => Print[NextArg[], output, INT.FIRST];
'c, 'C => output.PutChar[TheChar[NextArg[]]↑];
'% => output.PutChar['\n];
'\l, '\r => [] ← input.SkipWhitespace[];
'~ => output.PutChar['~];
'l, 'L => output.PutF1["%l", [rope[RopeFromString[TheString[NextArg[]]]]]];
ENDCASE => Complain[MakeChar[directive], "Unknown FORMAT directive"];
}
ELSE
output.PutChar[char];
ENDLOOP;
IF stringResult THEN result ← StringFromRope[IO.RopeFromROS[output]];
};
ENDCASE => ERROR
};
SchemeSysOpsInit: PROC [env: Environment] = {
DefinePrimitive[name: "installation-names", nArgs: 0, proc: SchemeSysOpsPrim, doc: "() Returns the list of component names that have been installed", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[11], env]];
DefinePrimitive[name: "require", nArgs: 4, proc: SchemeSysOpsPrim, doc: "(world component name [ env ]) require a cedar subsystem to be running", env: env, optional: 1, dotted: FALSE, data: Cons[MakeFixnum[10], env]];
DefinePrimitive[name: "reinstall", nArgs: 2, proc: SchemeSysOpsPrim, doc: "(component-name [ env ]) reinstall some object code", env: env, optional: 1, dotted: FALSE, data: Cons[MakeFixnum[9], env]];
DefinePrimitive[name: "install", nArgs: 2, proc: SchemeSysOpsPrim, doc: "(component-name [ env ]) install some object code", env: env, optional: 1, dotted: FALSE, data: Cons[MakeFixnum[8], env]];
DefinePrimitive[name: "do-command", nArgs: 2, proc: SchemeSysOpsPrim, doc: "(command-string [ output-port ]) Quick-and-dirty Commander interface", env: env, optional: 1, dotted: FALSE, data: Cons[MakeFixnum[7], env]];
DefinePrimitive[name: "timer?", nArgs: 1, proc: SchemeSysOpsPrim, doc: "(obj) test for a Timer", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[6], env]];
DefinePrimitive[name: "timer-start!", nArgs: 1, proc: SchemeSysOpsPrim, doc: "(timer) Start a Timer", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[5], env]];
DefinePrimitive[name: "timer-ref", nArgs: 1, proc: SchemeSysOpsPrim, doc: "(timer) Get the number of microseconds since the timer start", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[4], env]];
DefinePrimitive[name: "make-timer", nArgs: 0, proc: SchemeSysOpsPrim, doc: "() Create a timer object", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[3], env]];
DefinePrimitive[name: "atom-put-prop", nArgs: 3, proc: SchemeSysOpsPrim, doc: "(atom key value) Set a Cedar ATOM property", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[2], env]];
DefinePrimitive[name: "atom-get-prop", nArgs: 2, proc: SchemeSysOpsPrim, doc: "(atom key) Get a Cedar ATOM property", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[1], env]];
DefinePrimitive[name: "format", nArgs: 1, proc: SchemeSysOpsPrim, doc: "([port] string . args) Formatted output; PORT is an output-port or a boolean: #t => (current-output-port), #f => a string (default)", env: env, optional: 0, dotted: TRUE, data: Cons[MakeFixnum[0], env]];
};
ROPE: TYPE ~ Rope.ROPE;
Timer: TYPE ~ REF TimerRep;
TimerRep: TYPE ~ RECORD [pulses: BasicTime.Pulses];
BailOut: ERROR ~ CODE;
InitializationCommand: PROC [env: Any, command, name: ROPE, t1, t2: ROPE ← NIL] RETURNS [result: Any] ~ {
Inner: PROC = {
App: PROC [rope: ROPE] ~ {IF rope.Size # 0 THEN cr ← Rope.Cat[cr, " ", rope]};
cr: ROPE ← command; App[t1]; App[t2]; App[name];
result ← false;
IF CommanderOps.DoCommand[cr, NIL] = $Failure THEN BailOut;
result ← true;
};
SchemeRegistry.CollectInitializers[name, Inner ! BailOut => CONTINUE];
IF result # false THEN {
nInit: INT = SchemeRegistry.CallNamedInitializers[name, IF env = undefined THEN GetUserEnvironment[] ELSE TheEnvironment[env]];
IF result = true THEN result ← MakeFixnum[nInit];
};
};
RegisterInit[SchemeSysOpsInit];
END.