DIRECTORY
Atom USING [GetPName, GetProp, MakeAtom, PutProp, PutPropOnList],
BasicTime USING [GMT, Now],
ProcessProps USING [AddPropList, GetProp],
RefTab USING [Create, Fetch, Ref, Store],
Rope USING [FromRefText, Replace, ROPE, Size],
Scheme,
SchemeRegistry USING [],
SymTab USING [Create, EachPairAction, Fetch, Pairs, Ref, Store];

SchemeSupportImpl: CEDAR MONITOR
IMPORTS Atom, BasicTime, ProcessProps, RefTab, Rope, Scheme, SymTab
EXPORTS Scheme, SchemeRegistry
~ BEGIN OPEN Scheme;

ROPE: TYPE ~ Rope.ROPE;

ICar: PROC [any: Any] RETURNS [Any] ~ INLINE {
RETURN [WITH any SELECT FROM pair: Pair => pair.car ENDCASE => Car[any]]
};

ICdr: PROC [any: Any] RETURNS [Any] ~ INLINE {
RETURN [WITH any SELECT FROM pair: Pair => pair.cdr ENDCASE => Cdr[any]]
};

SymbolFromRope: PUBLIC PROC [rope: ROPE] RETURNS [Symbol] ~ {RETURN[Atom.MakeAtom[rope]]};
RopeFromSymbol: PUBLIC PROC [symbol: Symbol] RETURNS [ROPE] ~ {RETURN[Atom.GetPName[symbol]]};

Complain: PUBLIC ERROR [object: Any, msg: ROPE] ~ CODE;
GetUserEnvironment: PUBLIC SIGNAL RETURNS [env: Environment] ~ CODE;

SpecialsRep: TYPE ~ RECORD [false, true, endOfFile, unspecified, undefined: Any, emptyString: String];
GetSpecials: PROC RETURNS [REF SpecialsRep] ~ {
WITH Atom.GetProp[atom: $SchemeSpecialValues, prop: $SchemeSpecialValues] SELECT FROM
s: REF SpecialsRep => RETURN [s];
ENDCASE => {
s: REF SpecialsRep ~ NEW[SpecialsRep ¬ [
false: NEW[BOOL ¬ FALSE],
true: NEW[BOOL ¬ TRUE],
endOfFile: NEW[{eof} ¬ eof],
unspecified: NEW[{unspecified} ¬ unspecified],
undefined: NEW[{undefined} ¬ undefined],
emptyString: NEW[StringRep ¬ [base: NIL]]
]];
Atom.PutProp[atom: $SchemeSpecialValues, prop: $SchemeSpecialValues, val: s];
RETURN [s]
};
};

specials: REF SpecialsRep ~ GetSpecials[];

false: PUBLIC Any ~ specials.false;
true: PUBLIC Any ~ specials.true;
endOfFile: PUBLIC Any ~ specials.endOfFile;
unspecified: PUBLIC Any ~ specials.unspecified;
undefined: PUBLIC Any ~ specials.undefined;
emptyString: PUBLIC String ~ specials.emptyString;

StringFromRope: PUBLIC PROC [rope: ROPE] RETURNS [String] ~ {
RETURN [IF Rope.Size[rope] = 0 THEN emptyString ELSE NEW[StringRep ¬ [base: rope]]]
};

RopeFromString: PUBLIC PROC [string: String] RETURNS [ROPE] ~ {
IF string.buffer = NIL OR string.buffer.length = 0 THEN NULL ELSE {
string.base ¬ Rope.Replace[base: string.base, start: string.where, len: string.buffer.length, with: Rope.FromRefText[string.buffer]];
string.buffer.length ¬ 0;
};
RETURN [string.base]
};

Car: PUBLIC PROC [any: Any] RETURNS [Any] ~ {
WITH any SELECT FROM
pair: Pair => RETURN [pair.car];
list: LIST OF REF ANY => RETURN [list.first];
ENDCASE => Complain[any, "not a pair"];
};

Cdr: PUBLIC PROC [any: Any] RETURNS [Any] ~ {
WITH any SELECT FROM
pair: Pair => RETURN [pair.cdr];
list: LIST OF REF ANY => RETURN [list.rest];
ENDCASE => Complain[any, "not a pair"];
};

Cons: PUBLIC PROC [a, b: Any] RETURNS [Pair] ~ { RETURN [NEW[PairRep ¬ [a, b]]] };

ListLength: PUBLIC PROC [a: Any] RETURNS [n: INT ¬ 0] ~ {
DO WITH a SELECT FROM
p: Pair => { n ¬ n + 1; a ¬ p.cdr };
lora: LIST OF REF ANY => { n ¬ n + 1; a ¬ lora.rest };
ENDCASE => IF a = NIL THEN EXIT ELSE { Complain[a, "not a proper list"] }
ENDLOOP;
};

Reverse: PUBLIC PROC [a: Any] RETURNS [Any] ~ {
r: Any ¬ NIL;
FOR each: Any ¬ a, ICdr[each] UNTIL each = NIL DO
r ¬ Cons[ICar[each], r];
ENDLOOP;
RETURN [r]
};

VectorFromList: PUBLIC PROC [a: Any] RETURNS [Any] ~ {
len: NAT ~ ListLength[a];
v: SimpleVector ~ NEW[SimpleVectorRep[len]];
FOR i: NAT IN [0..len) DO v[i] ¬ ICar[a]; a ¬ ICdr[a] ENDLOOP;
RETURN [v]
};

VectorLength: PUBLIC PROC [a: Any] RETURNS [INT] ~ {
WITH a SELECT FROM
v: SimpleVector => RETURN [v.length];
v: Vector => RETURN [v.length];
ENDCASE => Complain[a, "not a vector"];
};

VectorRef: PUBLIC PROC [a: Any, i: INT] RETURNS [Any] ~ {
WITH a SELECT FROM
v: SimpleVector => { IF i IN [0..v.length) THEN RETURN [v[i]] };
v: Vector => { IF i IN [0..v.length) THEN RETURN [v.ref[v, i]] };
ENDCASE => Complain[a, "not a vector"];
Complain[MakeFixnum[i], "index out of bounds"];
};

VectorSet: PUBLIC PROC [a: Any, i: INT, value: Any] ~ {
WITH a SELECT FROM
v: SimpleVector => { IF i IN [0..v.length) THEN {v[i] ¬ value; RETURN} };
v: Vector => { IF i IN [0..v.length) THEN {v.set[v, i, value]; RETURN} };
ENDCASE => Complain[a, "not a vector"];
Complain[MakeFixnum[i], "index out of bounds"];
};

LookupVariableValue: PUBLIC PROC [variable: Any, env: Environment] RETURNS [Any] ~ {
FOR e: Environment ¬ env, e.parent WHILE e # NIL DO
IF e.names = NIL
THEN {
WITH e[0] SELECT FROM
tab: RefTab.Ref => {
WITH RefTab.Fetch[tab, variable].val SELECT FROM
pair: Pair => {
IF pair.cdr = undefined
THEN Complain[variable, "undefined variable"]
ELSE RETURN [pair.cdr];
};
ENDCASE => NULL;
};
ENDCASE => ERROR;
}
ELSE {
FOR i: NAT DECREASING IN [0..e.names.length) DO
IF variable = e.names[i] THEN RETURN [e[i]];
ENDLOOP;
};
ENDLOOP;
Complain[variable, "undefined variable"];
};

SetVariableValue: PUBLIC PROC [variable: Any, value: Any, env: Environment] RETURNS [BOOL] ~ {
FOR e: Environment ¬ env, e.parent WHILE e # NIL DO
IF e.names = NIL
THEN {
WITH e[0] SELECT FROM
tab: RefTab.Ref => {
WITH RefTab.Fetch[tab, variable].val SELECT FROM
pair: Pair => { pair.cdr ¬ value; RETURN [TRUE] }
ENDCASE => NULL;
};
ENDCASE => ERROR;
}
ELSE {
FOR i: NAT DECREASING IN [0..e.names.length) DO
IF variable = e.names[i] THEN { e[i] ¬ value; RETURN [TRUE] };
ENDLOOP;
};
ENDLOOP;
RETURN [FALSE];
};

DefineVariable: PUBLIC PROC [variable: Any, value: Any, env: Environment] ~ {
WITH env[0] SELECT FROM
x: RefTab.Ref => {
WITH RefTab.Fetch[x, variable].val SELECT FROM
binding: Pair => { binding.cdr ¬ value }
ENDCASE => { [] ¬ RefTab.Store[x: x, key: variable, val: Cons[variable, value]] };
};
ENDCASE => Complain[variable, "defines must be at top level"];
};

ExportVariable: PUBLIC PROC [fromEnv, toEnv: Environment, fromName, toName: Symbol] ~ {
fromTab, toTab: RefTab.Ref;
found: BOOL;
binding: Any;
IF fromEnv.names # NIL OR toEnv.names # NIL THEN 
Complain[$exportVariable, "Not Implemented: export to/from a non-top-level environment"];
fromTab ¬ NARROW[fromEnv[0]];
toTab ¬ NARROW[toEnv[0]];
[found, binding] ¬ RefTab.Fetch[fromTab, fromName];
IF NOT found THEN Complain[fromName, "attempt to export an undefined variable"];
[] ¬ RefTab.Store[toTab, toName, binding];
};

DefinePrimitive: PUBLIC PROC [name: ROPE, nArgs: NAT, dotted: BOOL, proc: PROC [Primitive, Any, Any, Any, ProperList] RETURNS [Any], doc: Rope.ROPE, env: Environment, data: REF ¬ NIL, optional: NAT ¬ 0] ~ {
symbol: Symbol ~ SymbolFromRope[name];
DefineVariable[variable: symbol, value: NEW[PrimitiveRep ¬ [minArgs: nArgs - optional, maxArgs: nArgs, dotted: dotted, proc: proc, doc: doc, data: data, symbol: symbol]], env: env];
};
Initializer: TYPE ~ RECORD [initProc: PROC [Environment]];
initHead: LIST OF Initializer ~ LIST[[NIL]];
lastInit: LIST OF Initializer ¬ initHead;
versionRef: REF ¬ Cons[$VERSION, NEW[BasicTime.GMT ¬ BasicTime.Now[]]];

NewEnvironmentStructure: PUBLIC PROC RETURNS [userEnv: Environment] ~ {
NewEnvironment: PROC [parent: Environment, id: Rope.ROPE]
RETURNS [env: Environment] ~ {
env ¬ NEW[EnvironmentRep[2]];
env.parent ¬ parent;
env.names ¬ NIL;
env.mark ¬ 100;
env.values[0] ¬ RefTab.Create[];
env.values[1] ¬ StringFromRope[id];
};
userEnv ¬ NewEnvironment[NIL, "user"];

DefineVariable[
variable: SymbolFromRope["user"],
value: userEnv,
env: userEnv];

InitializeEnvironmentStructure[userEnv];
};

InitializeEnvironmentStructure: PUBLIC PROC [userEnv: Environment] ~ {
ENABLE
GetUserEnvironment => RESUME[userEnv];
IF RefTab.Fetch[x: NARROW[userEnv.values[0]], key: $VERSION].val # versionRef THEN {
FOR each: LIST OF Initializer ¬ initHead.rest, each.rest UNTIL each = NIL DO
each.first.initProc[userEnv];
ENDLOOP;
[] ¬ RefTab.Store[x: NARROW[userEnv.values[0]], key: $VERSION, val: versionRef];
};
};

namedInitializers: SymTab.Ref -- OF LIST OF Initializer -- ~ SymTab.Create[case: FALSE];

CallNamedInitializers: PUBLIC PROC [name: ROPE, env: Environment] RETURNS [nInit: INT ¬ 0] ~ {
WITH SymTab.Fetch[x: namedInitializers, key: name].val SELECT FROM
initializers: LIST OF Initializer => {
FOR tail: LIST OF Initializer ¬ initializers, tail.rest UNTIL tail = NIL DO
tail.first.initProc[env];
nInit ¬ nInit + 1;
ENDLOOP;
};
ENDCASE => NULL;
};

InitializationCell: TYPE ~ REF InitializationCellRep;
InitializationCellRep: TYPE ~ RECORD [
head: LIST OF Initializer,
last: LIST OF Initializer
];

CollectInitializers: PUBLIC PROC [name: ROPE, proc: PROC] ~ {
cell: InitializationCell ¬ NEW[InitializationCellRep];
cell.last ¬ cell.head ¬ LIST[[NIL]];
ProcessProps.AddPropList[propList: Atom.PutPropOnList[propList: NIL, prop: $SchemeInitializers, val: cell], inner: proc];
IF cell.head.rest # NIL THEN {
[] ¬ SymTab.Store[x: namedInitializers, key: name, val: cell.head.rest];
};
};

RegisterInit: PUBLIC ENTRY PROC [initProc: PROC [Environment]] ~ {
WITH ProcessProps.GetProp[$SchemeInitializers] SELECT FROM
cell: InitializationCell => {
cell.last ¬ cell.last.rest ¬ LIST[[initProc]];
};
ENDCASE => {
lastInit ¬ lastInit.rest ¬ LIST[[initProc]];
versionRef ¬ Cons[$VERSION, NEW[BasicTime.GMT ¬ BasicTime.Now[]]];
};
};

InitializerIsDefined: PUBLIC PROC [name: ROPE] RETURNS [BOOL] ~ {
RETURN[SymTab.Fetch[namedInitializers, name].found]
};

ListNamedInitializers: PUBLIC PROC RETURNS [list: ProperList ¬ NIL] ~ {
EachPair: SymTab.EachPairAction = {
list ¬ Cons[StringFromRope[key], list];
};
[] ¬ SymTab.Pairs[x: namedInitializers, action: EachPair]
};

END.

h
SchemeSupportImpl.mesa
Copyright Σ 1987, 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.
Formerly part of SchemeEvalImpl.mesa
Michael Plass, March 6, 1989 2:52:52 pm PST
Last changed by Pavel on March 15, 1989 12:42:54 pm PST
r: ReversedArgList => RETURN [r.car];
r: ReversedArgList => RETURN [r.cdr];
Registration Support 
Call all the initializers associated with a given name.
All calls to RegisterInit while proc has control will be collected into a named table of Initializers.  Normally proc will cause a Cedar module (or perhaps several) to be loaded and run.
If nothing was registered, NOP since the installation probably went awry.
Cedar programs call this to make themselves known to Scheme
This is under control of CollectInitializers
This is free-floating; add to the global list.
[key: ROPE, val: SymTab.Val] RETURNS [quit: BOOL _ FALSE]
ΚΤ–
(cedarcode) style•NewlineDelimiter

™
codeš
œ™Kšœ
Οe
œC™NKš
œ$™$K™+K™7—K˜š
Οk	˜	Kšœžœ7˜AKšœ
žœžœ˜Kšœ
žœ˜*Kšœžœ˜)Kšœžœžœ˜.Kš
œ˜Kšœžœ˜Kšœžœ4˜@—K˜KšΟnœžœ
ž˜ Kšžœ<˜CKšžœ˜šœžœ
žœ˜K˜šžœžœžœ
˜K˜—šŸœžœžœ	žœ˜.Kš
žœžœžœ
žœžœ
˜HK˜K˜—šŸœžœžœ	žœ˜.Kš
žœžœžœ
žœžœ
˜HK˜K˜—KšŸœžœ
žœžœžœ
žœ˜ZKšŸœžœ
žœžœžœžœ˜^K˜Kš
Ÿœžœ
žœžœžœ
˜7š
Ÿœžœ
žœ
žœžœ
˜DK˜—Kšœ
žœžœL˜f•StartOfExpansion[atom: 
ATOM, prop: 
REF ANY]šŸœžœ
žœžœ˜/šžœFžœ
ž˜UKšœžœžœ˜!šžœ˜šœžœžœ˜(Kšœžœ
žœžœ˜Kšœžœ
žœžœ˜Kšœžœ˜Kšœ
žœ˜.Kšœžœ˜(Kšœ
žœžœ˜)Kš
œ˜—K–/[atom: 
ATOM, prop: 
REF ANY, val: 
REF ANY]š
œM˜MKšžœ˜
Kš
œ˜——š
œ˜K˜——šœ
žœ˜*K˜—Kšœžœ˜#Kšœžœ˜!Kšœžœ˜+Kšœ
žœ˜/Kšœžœ˜+šœ
žœ˜2K˜—š
Ÿœžœ
žœžœžœ
˜=Kš
žœžœžœ
žœ
žœ˜SKš
œ˜K˜—š
Ÿœžœ
žœžœžœ˜?–M[base: 
ROPE, start: 
INT _ 0, len: 
INT _ 2147483647, with: 
ROPE _ NIL]šžœžœ
žœžœ
žœ
žœ˜CK˜…
K˜Kš
œ˜—Kšžœ˜Kš
œ˜K˜—šŸœžœ
žœžœ
˜-šžœžœ
ž˜Kšœžœ˜ Kšœžœ	™%Kšœžœ
žœ
žœ
žœžœ˜-Kšžœ ˜'—Kš
œ˜K˜—šŸœžœ
žœžœ
˜-šžœžœ
ž˜Kšœžœ˜ Kšœžœ	™%Kšœžœ
žœ
žœ
žœžœ
˜,Kšžœ ˜'—Kš
œ˜K˜—šŸœžœ
žœ
žœžœžœ˜RK˜—š
Ÿ
œžœ
žœ
žœžœ	˜9šžœ
žœžœ
ž˜K˜$Kš	œžœ
žœ
žœ
žœ!˜6Kšžœžœžœ
žœ
žœ
žœ%˜IKšžœ
˜—Kš
œ˜K˜—šŸœžœ
žœ
žœ
˜/Kšœ	žœ
˜
šžœžœžœ
ž˜1K˜Kšžœ
˜—Kšžœ˜
Kš
œ˜K˜—šŸœžœ
žœ
žœ
˜6Kšœžœ˜Kšœžœ˜,Kšžœžœ
žœ
žœž
œžœ
˜>Kšžœ˜
Kš
œ˜K˜—š
Ÿœžœ
žœ
žœžœ˜4šžœžœ
ž˜Kšœžœ˜%Kšœ
žœ˜Kšžœ ˜'—Kš
œ˜K˜—š
Ÿ	œžœ
žœ
žœžœ
˜9šžœžœ
ž˜Kš	œžœžœžœ
žœ
˜@Kš	œžœžœžœ
žœ˜AKšžœ ˜'—Kš
œ/˜/Kš
œ˜K˜—šŸ	œžœ
žœ
žœ˜7šžœžœ
ž˜Kš	œžœžœžœžœ˜IKš	œžœžœžœžœ˜IKšžœ ˜'—Kš
œ/˜/Kš
œ˜K˜—šŸœžœ
žœ#žœ
˜Tšžœ žœžœ
ž˜3šžœž˜šžœ˜šžœžœ
ž˜˜šžœ!žœ
ž˜0š
œ˜šžœ˜Kšžœ)˜-Kšžœ˜—Kš
œ˜—Kšžœžœ
˜—K˜—Kšžœžœ
˜—Kš
œ
˜
—šžœ˜šžœžœ
ž
œž˜/Kšžœžœ
žœ˜,Kšžœ
˜—Kš
œ˜——Kšžœ
˜—K˜)Kš
œ˜K˜—š
Ÿœžœ
žœ/žœžœ˜^šžœ žœžœ
ž˜3šžœž˜šžœ˜šžœžœ
ž˜˜šžœ!žœ
ž˜0Kšœ"žœžœ˜1Kšžœžœ
˜—K˜—Kšžœžœ
˜—Kš
œ
˜
—šžœ˜šžœžœ
ž
œž˜/Kšžœžœžœžœ˜>Kšžœ
˜—Kš
œ˜——Kšžœ
˜—Kšžœžœ˜K˜K˜—šŸœžœ
žœ2˜Mšžœžœ
ž˜š
œ˜šžœžœ
ž˜.K˜(KšžœK˜R—Kš
œ˜—Kšžœ7˜>—K˜K˜—šŸœžœ
žœ<˜WKš
œ˜Kšœžœ
˜K˜
š
žœžœ
žœžœ
žœ
˜1K˜Y—Kšœ
žœ
˜Kšœžœ˜K˜3Kšžœ
žœžœ?˜PK˜*K˜K˜—šŸœžœ
žœžœ	žœ
žœžœ(žœžœžœžœžœ	˜Ξ
Kš
œ&˜&Kšœ(žœŠ
˜΅
Kš
œ˜——
head™Kšœ
žœžœžœ˜:Kš	œ
žœ
žœžœžœ˜,Kšœ
žœ
žœ˜)šœžœžœžœ˜GK˜—šŸœžœ
žœ
žœ˜GšŸœžœ žœžœ˜XKšœžœ˜K˜Kšœžœ
˜K˜K˜ K˜#K˜—Kšœžœ
˜&K˜š
œ˜Kš
œ!˜!Kš
œ˜Kš
œ˜—K˜Kš
œ(˜(Kš
œ˜K˜—šŸœžœ
žœ˜F–$[x: 
RefTab.Ref, key: 
RefTab.Key]š
ž˜Kšœžœ
˜&—šžœžœ5žœ˜Tšžœžœ
žœ(žœžœ
ž˜LKš
œ˜Kšžœ
˜—K–7[x: 
RefTab.Ref, key: 
RefTab.Key, val: 
RefTab.Val]šœžœ5˜PKš
œ˜—Kš
œ˜K˜—–&[mod: 
NAT _ 17, case: 
BOOL _ TRUE]šœΟcœžœ˜XK˜—šŸœžœ
žœžœžœ	žœ	˜^K–[x: 
SymTab.Ref, key: 
ROPE]™7šžœ3žœ
ž˜Bšœžœ
žœ˜&šžœžœ
žœ'žœžœ
ž˜KKš
œ˜K˜Kšžœ
˜—Kš
œ˜—Kšžœžœ
˜—Kš
œ˜K˜—Kšœžœžœ˜5šœžœžœ˜&Kšœžœ
žœž
˜Kšœžœ
žœ˜Kš
œ˜K˜—š
Ÿœžœ
žœžœžœ˜=Kšœ
Ÿœ‘
™Ί
Kšœžœ˜6Kšœžœžœ˜$Kšœ@žœ6˜y–1[x: 
SymTab.Ref, key: 
ROPE, val: 
SymTab.Val]šžœžœ
žœ˜K™IK˜HKš
œ˜—Kš
œ˜K˜—šŸœžœ
ž
œžœ˜BK™;šžœ+žœ
ž˜:š
œ˜KšœŸ™,Kšœžœ
˜.Kš
œ˜—šžœ˜K™.Kšœžœ
˜,Kšœžœžœ˜BKš
œ˜——Kš
œ˜K˜—šŸœžœ
žœžœžœžœ˜AKšžœ-˜3Kš
œ˜K˜—š
Ÿœžœ
žœ
žœžœ˜G–= -- [key: ROPE, val: SymTab.Val] RETURNS [quit: BOOL _ FALSE]šŸœ˜#Kš
Πck9™9K˜'K˜—K˜9Kš
œ˜K˜——Kšžœ
˜K˜—…—%B8~