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
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];
~
BEGIN
OPEN Scheme;
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];
r: ReversedArgList => RETURN [r.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];
r: ReversedArgList => RETURN [r.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];
};
Registration Support
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] ~ {
Call all the initializers associated with a given name.
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] ~ {
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.
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 {
If nothing was registered, NOP since the installation probably went awry.
[] ¬ SymTab.Store[x: namedInitializers, key: name, val: cell.head.rest];
};
};
RegisterInit:
PUBLIC
ENTRY PROC [initProc:
PROC [Environment]] ~ {
Cedar programs call this to make themselves known to Scheme
WITH ProcessProps.GetProp[$SchemeInitializers]
SELECT
FROM
cell: InitializationCell => {
This is under control of CollectInitializers
cell.last ¬ cell.last.rest ¬ LIST[[initProc]];
};
ENDCASE => {
This is free-floating; add to the global list.
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 = {
[key: ROPE, val: SymTab.Val] RETURNS [quit: BOOL ← FALSE]
list ¬ Cons[StringFromRope[key], list];
};
[] ¬ SymTab.Pairs[x: namedInitializers, action: EachPair]
};