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[];
)