<<>>
    <<SchemeSysOps.mx>>
        <<Copyright Ó 1989, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Created by Michael Plass, February 14, 1989>>
        <<Michael Plass, December 2, 1991 12:30 pm PST>>
        <<Last changed by Pavel on March 9, 1989 10:24:24 pm PST>>
    <<>>
    <<Documentation>>
    <<Cedar system operations>>
    <<Common types>>
    (cedar-directory "Rope")
    (define-ref-type "Scheme" "Symbol")
    ROPE: TYPE ~ Rope.ROPE;
<<Format>>
(cedar-imports "IO" "SchemeSys")

(define-proc (format port-or-string . args)
"([port] string . args) Formatted output; PORT is an output-port or a boolean: #t => (current-output-port), #f => a string 
(default)"
    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]];
)
<<Atom>>
(cedar-imports "Atom")
(define-proc (atom-get-prop atom key)
"Get a Cedar ATOM property"
    result _ Atom.GetProp[TheSymbol[atom], key];
)
(define-proc (atom-put-prop atom key value)
"Set a Cedar ATOM property"
    Atom.PutProp[TheSymbol[atom], key, value];
)
<<Timer>>
(cedar-imports "BasicTime")
(define-ref-type #f "Timer")
    Timer: TYPE ~ REF TimerRep;
    TimerRep: TYPE ~ RECORD [pulses: BasicTime.Pulses]; 
(define-proc (make-timer)
"Create a timer object"
    timer: REF TimerRep ~ NEW[TimerRep];
    timer.pulses _ BasicTime.GetClockPulses[];
    result _ timer;
)
(define-proc (timer-ref timer)
"Get the number of microseconds since the timer start"
    now: BasicTime.Pulses ~ BasicTime.GetClockPulses[];
    result _ MakeFixnum[BasicTime.PulsesToMicroseconds[now-TheTimer[timer].pulses]]
)
(define-proc (timer-start! timer)
"Start a Timer"
    t: Timer ~ TheTimer[timer];
    t.pulses _ BasicTime.GetClockPulses[];
)
(define-proc (timer? obj)
"test for a Timer"
    result _ WITH obj SELECT FROM t: Timer => true ENDCASE => false;
)
<<Commander>>
(cedar-imports "CommanderOps" "SchemeRegistry" "ProcessProps" "Atom" "Rope")
(cedar-directory "Commander" "IO")
(define-ref-type "Scheme" "Environment")

(define-proc (do-command command-string (output-port))
"Quick-and-dirty Commander interface"
    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;
)
    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];
            };
        };

(define-proc (install component-name (env))
"install some object code"
    name: ROPE ~ RopeFromString[TheString[componentName]];
    result _ InitializationCommand[env, "Install", name];
)
(define-proc (reinstall component-name (env))
"reinstall some object code"
    name: ROPE ~ RopeFromString[TheString[componentName]];
    result _ InitializationCommand[env, "Install -a", name];
)
(define-proc (require world component name (env))
"require a cedar subsystem to be running"
    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];
)
(define-proc (installation-names)
"Returns the list of component names that have been installed"
    result _ SchemeRegistry.ListNamedInitializers[];
)