-- 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.