Evaluation Support
CopyActivation:
PROC [a: Activation]
RETURNS [Activation] ~ {
This gets called if we encounter an activation that is part of a continuation.
new: Activation = NEW[ActivationRep ¬ a];
new.s ¬ NEW[StackRep ¬ a.s];
IF a.sEx #
NIL
THEN {
o: SimpleVector = a.sEx;
p: SimpleVector = NEW[SimpleVectorRep[o.length]];
FOR i:
NAT
IN [0..o.length)
DO
p[i] ¬ o[i];
ENDLOOP;
new.sEx ¬ p;
};
new.shared ¬ FALSE;
RETURN [new]
};
RetainStack:
PROC [a: Activation] ~ {
FOR p: Activation ¬ a, p.link
UNTIL p =
NIL
OR p.shared
DO
IF p.env # NIL THEN p.env.mark ¬ 100;
p.shared ¬ TRUE;
ENDLOOP;
};
handlerSymbol: Symbol ~ SymbolFromRope["*system-error-handler*"];
HandleError:
PROC [a: Activation, name, culprit: Any, msg:
ROPE]
RETURNS [debuggerFrame: Activation] ~ {
userEnv: Environment ~ GetUserEnvironment[]; -- I wish there was another way...
handler: Any ~ LookupVariableValue[handlerSymbol, userEnv ! Complain => ERROR];
debuggerFrame ¬
NEW[ActivationRep ¬ [
link: a,
env: NIL,
code: NIL,
bottom: 0,
n: 5, -- (handler parent-activation name culprit message)
pc: -1,
s: NEW[StackRep ¬ ALL[NIL]],
sEx: NIL
]];
RetainStack[a];
debuggerFrame.s[0] ¬ handler;
debuggerFrame.s[1] ¬ a;
debuggerFrame.s[2] ¬ name;
debuggerFrame.s[3] ¬ culprit;
debuggerFrame.s[4] ¬ StringFromRope[msg];
RETURN;
};
GetArgList:
PROC [a: Activation]
RETURNS [Any] ~ {
A:
PROC [i:
NAT]
RETURNS [Any] =
INLINE {
RETURN [IF i < smallActivationSize THEN a.s[i] ELSE a.sEx[i-smallActivationSize]]
};
list: Any ¬ NIL;
FOR i:
NAT
DECREASING
IN [1..a.n)
DO
list ¬ Cons[A[i+a.bottom], list];
ENDLOOP;
RETURN [list]
};
CommonEnvSizes: TYPE ~ [0..20);
Pool: TYPE ~ REF PoolRep;
PoolRep:
TYPE ~
RECORD [
avail: Activation ¬ NIL, -- free list for activations
envAvail: ARRAY CommonEnvSizes OF REF Environment
];
envStatLimit: NAT ~ 40;
EnvStatEntry: TYPE ~ RECORD [alloc, reused, freed: INT ¬ 0];
envStats:
REF
ARRAY [0..envStatLimit]
OF EnvStatEntry ~
IF doStats
THEN
NEW[
ARRAY [0..envStatLimit]
OF EnvStatEntry]
ELSE
NIL;
PushEnvironment:
PROC [parent: Environment, names: SimpleVector, pool: Pool]
RETURNS [newEnv: Environment] ~ {
n: NAT ~ names.length;
envCell: REF Environment ¬ NIL;
IF n
IN CommonEnvSizes
AND (envCell ¬ pool.envAvail[n]) #
NIL
THEN {
IF doStats THEN envStats[n].reused ¬ envStats[n].reused+1;
newEnv ¬ envCell;
envCell ¬ newEnv.parent;
IF newEnv.mark # 666 THEN ERROR;
}
ELSE {
k: NAT ~ MIN[n, envStatLimit];
IF doStats THEN envStats[k].alloc ¬ envStats[k].alloc+1;
newEnv ¬ NEW[EnvironmentRep[n]];
};
newEnv.parent ¬ parent;
newEnv.names ¬ names;
newEnv.mark ¬ 0;
};
FreeEnv:
PROC [e: Environment, pool: Pool] ~ {
n: NAT ~ e.size;
IF e.mark # 0 THEN ERROR;
e.mark ¬ 666;
e.names ← NIL;
FOR i: NAT IN [0..n) DO e[i] ← NIL ENDLOOP;
IF n
IN CommonEnvSizes
THEN {
envCell: REF Environment ~ pool.envAvail[n];
IF doStats THEN envStats[n].freed ¬ envStats[n].freed+1;
e.parent ¬ envCell;
envCell ¬ e;
};
};
CleanupStorage:
PROC [pool: Pool] ~ {
WHILE pool.avail #
NIL
DO
a: Activation ~ pool.avail;
s: Stack ~ a.s;
pool.avail ¬ a.link;
FOR i:
NAT
IN [0..smallActivationSize)
DO
s[i] ¬ NIL;
ENDLOOP;
a.env ¬ NIL;
a.link ¬ NIL;
ENDLOOP;
FOR i:
NAT
IN CommonEnvSizes
DO
envCell: REF Environment ~ pool.envAvail[i];
WHILE envCell #
NIL
DO
env: Environment ~ envCell;
envCell ¬ env.parent;
FOR j: NAT IN [0..env.size) DO env[j] ¬ NIL ENDLOOP;
env.names ¬ NIL;
env.parent ¬ NIL;
ENDLOOP;
ENDLOOP;
};
Evaluator
abortCheckInterval: CARDINAL ¬ 100;
Run:
PROC [activation: Activation]
RETURNS [Any] = {
name: Any ¬ NIL;
Inner:
PROC [a: Activation, pool: Pool]
RETURNS [Any] ~ {
abortCheckCounter: CARDINAL ¬ abortCheckInterval;
DO
result: Any ¬ a.s[0];
IF abortCheckCounter # 0
THEN { abortCheckCounter ¬ abortCheckCounter - 1 }
ELSE {
SchemeSys.CheckForAbort[];
abortCheckCounter ¬ abortCheckInterval
};
IF a.shared THEN { a ¬ CopyActivation[a] };
IF a.n > 0
THEN {
s: Stack ~ a.s;
A:
PROC [i:
NAT]
RETURNS [Any] =
INLINE {
RETURN [IF i < smallActivationSize THEN s[i] ELSE a.sEx[i-smallActivationSize]]
};
WITH A[a.bottom]
SELECT
FROM
fun: TidbitProcedure => {
env: Environment ~ PushEnvironment[parent: fun.env, names: fun.code.envNames, pool: pool];
m: NAT ~ fun.code.maxArgs; -- number of (non-rest) arguments
n: NAT ~ a.n-1; -- number of actual arguments
argBase: NAT ~ a.bottom+1;
name ¬ fun.code.name;
SELECT
TRUE
FROM
((n = m)
AND (argBase+m <= smallActivationSize)) => {
FOR i:
NAT
IN [0..m)
DO
env[i] ¬ s[argBase+i];
ENDLOOP;
IF fun.code.dotted THEN env[m] ¬ NIL;
};
(n
IN [fun.code.minArgs..m]) => {
L: NAT = MIN[m, n]; -- number of supplied (non-rest) arguments
FOR i:
NAT
IN [0..L)
DO
env[i] ¬ A[argBase+i];
ENDLOOP;
FOR i:
NAT
IN [L..m)
DO
env[i] ¬ undefined;
ENDLOOP;
IF fun.code.dotted THEN env[m] ¬ NIL;
};
(fun.code.dotted
AND n >= m) => {
rest: Any ¬ NIL;
FOR i:
NAT
IN [0..m)
DO
env[i] ¬ A[argBase+i];
ENDLOOP;
FOR i:
NAT
DECREASING IN [m..n)
DO
rest ¬ Cons[A[argBase+i], rest];
ENDLOOP;
env[m] ¬ rest;
};
ENDCASE => {
activation ¬ a;
Complain[GetArgList[a], "Wrong number of arguments"];
};
IF a.pc < 0
THEN {
This is a tail call. Reuse the old activation storage.
IF a.shared THEN ERROR;
IF a.env # NIL AND a.env.mark = 0 THEN FreeEnv[a.env, pool];
a.sEx ¬ NIL;
}
ELSE {
new: Activation ¬ pool.avail;
IF new =
NIL
THEN {
new ¬ NEW[ActivationRep];
new.s ¬ NEW[StackRep];
}
ELSE
pool.avail ¬ new.link;
new.link ¬ a;
new.fluidBindings ¬ a.fluidBindings;
a ¬ new;
};
IF a.shared THEN ERROR;
a.env ¬ env;
a.code ¬ fun.code;
a.pc ¬ fun.code.initialPC;
a.sEx ¬ NIL;
activation ¬ a.link;
fun.code.proc[a];
LOOP;
};
p: Primitive => {
n: NAT ~ a.n-1;
argBase: NAT = a.bottom+1;
name ¬ p.symbol;
activation ¬ a;
SELECT
TRUE
FROM
n <= 3
AND argBase+n <= smallActivationSize
AND
((n = p.maxArgs)
OR (n
IN [p.minArgs..p.maxArgs])) => {
SELECT n
FROM
0 => result ¬ p.proc[p, undefined, undefined, undefined, NIL];
1 => result ¬ p.proc[p, s[argBase], undefined, undefined, NIL];
2 => result ¬ p.proc[p, s[argBase], s[argBase+1], undefined, NIL];
3 => result ¬ p.proc[p, s[argBase], s[argBase+1], s[argBase+2], NIL];
ENDCASE;
};
n
IN [p.minArgs..p.maxArgs]
OR (p.dotted
AND n >= p.maxArgs) => {
list: ProperList ¬ NIL;
f: ARRAY [0..3) OF Any ¬ ALL[undefined];
nFast: NAT ~ MIN[n, p.maxArgs, 3];
FOR i:
INT
DECREASING
IN [nFast..n)
DO
list ¬ Cons[A[argBase+i], list];
ENDLOOP;
FOR i:
NAT
IN [0..nFast)
DO
f[i] ¬ A[argBase+i];
ENDLOOP;
result ¬ p.proc[p, f[0], f[1], f[2], list];
};
ENDCASE => Complain[GetArgList[a], "Wrong number of arguments"];
};
ENDCASE => {
name ¬ $apply;
activation ¬ a;
Complain[A[a.bottom], "Not a procedure"];
};
};
WHILE a.pc < 0
DO
IF a.shared
THEN { a ¬ a.link }
ELSE {
IF a.env # NIL AND a.env.mark = 0 THEN FreeEnv[a.env, pool];
a.sEx ¬ NIL;
{old: Activation ~ a; a ¬ old.link; old.link ¬ pool.avail; pool.avail ¬ old};
};
IF a = NIL THEN RETURN [result]
ENDLOOP;
IF a.shared THEN { a ¬ CopyActivation[a] };
IF a.bottom < smallActivationSize
THEN a.s[a.bottom] ¬ result
ELSE a.sEx[a.bottom-smallActivationSize] ¬ result;
activation ¬ a.link;
name ¬ a.code.name;
a.code.proc[a];
ENDLOOP;
};
pool: Pool ~ NEW[PoolRep];
FOR i: NAT IN CommonEnvSizes DO pool.envAvail[i] ¬ NEW[Environment ¬ NIL] ENDLOOP;
DO
result: Any ¬ NIL;
SchemeSys.CheckForAbort[];
result ¬ Inner[activation, pool !
Complain => { activation ¬ HandleError[activation, name, object, msg]; LOOP }
];
CleanupStorage[pool];
RETURN [result]
ENDLOOP;
};
Apply:
PUBLIC
PROC [proc: Procedure, arguments: Any]
RETURNS [Any] ~ {
activation: Activation ¬
NEW[ActivationRep ¬ [
link: NIL,
env: NIL,
code: NIL,
bottom: 0,
n: 1 + ListLength[arguments],
pc: -1,
s: NEW[StackRep ¬ ALL[NIL]],
sEx: NIL
]];
tail: Any ¬ arguments;
activation.s[0] ¬ proc;
FOR i:
NAT
IN [1..activation.n)
DO
activation.s[i] ¬ Car[tail];
tail ¬ Cdr[tail];
ENDLOOP;
RETURN [Run[activation]]
};
Eval:
PUBLIC PROC [exp: Any, env: Environment]
RETURNS [Any] ~ {
thunk: Any ~ Compile[Expand[exp, env], env];
IF IsProcedure[thunk]
THEN
RETURN [Apply[thunk, NIL]]
ELSE
RETURN [unspecified];
};
compilerKey: Symbol ¬ SymbolFromRope["*system-compiler*"];
Compile:
PUBLIC
PROC [form: Any, env: Environment]
RETURNS [Any] ~ {
compiler: Any ¬ LookupVariableValue[compilerKey, env ! Complain => ERROR];
value: Any ¬ Apply[compiler, Cons[form, Cons[env, NIL]]];
IF IsProcedure[value]
THEN
RETURN [value]
ELSE
RETURN [unspecified]
};
expanderKey: Symbol ¬ SymbolFromRope["*system-syntax-expander*"];
Expand:
PUBLIC
PROC [form: Any, env: Environment]
RETURNS [Any] ~ {
value: Any ¬ LookupVariableValue[expanderKey, env ! Complain => ERROR];
form ¬ Apply[value, Cons[form, Cons[env, NIL]]];
RETURN [form]
};
Tidbit Support
SV1:
PUBLIC PROC [a0: Any]
RETURNS [SimpleVector] ~ {
s: SimpleVector ~ NEW[SimpleVectorRep[1]];
s[0] ¬ a0;
RETURN [s]
};
SV2:
PUBLIC PROC [a0: Any, a1: Any]
RETURNS [SimpleVector] ~ {
s: SimpleVector ~ NEW[SimpleVectorRep[2]];
s[0] ¬ a0;
s[1] ¬ a1;
RETURN [s]
};
SV3:
PUBLIC PROC [a0: Any, a1: Any, a2: Any]
RETURNS [SimpleVector] ~ {
s: SimpleVector ~ NEW[SimpleVectorRep[3]];
s[0] ¬ a0;
s[1] ¬ a1;
s[2] ¬ a2;
RETURN [s]
};
SV4:
PUBLIC PROC [a0: Any, a1: Any, a2: Any, a3: Any]
RETURNS [SimpleVector] ~ {
s: SimpleVector ~ NEW[SimpleVectorRep[4]];
s[0] ¬ a0;
s[1] ¬ a1;
s[2] ¬ a2;
s[3] ¬ a3;
RETURN [s]
};
SV5:
PUBLIC PROC [a0: Any, a1: Any, a2: Any, a3: Any, a4: Any]
RETURNS [SimpleVector] ~ {
s: SimpleVector ~ NEW[SimpleVectorRep[5]];
s[0] ¬ a0;
s[1] ¬ a1;
s[2] ¬ a2;
s[3] ¬ a3;
s[4] ¬ a4;
RETURN [s]
};
SV6:
PUBLIC PROC [a0: Any, a1: Any, a2: Any, a3: Any, a4: Any, a5: Any]
RETURNS [SimpleVector] ~ {
s: SimpleVector ~ NEW[SimpleVectorRep[6]];
s[0] ¬ a0;
s[1] ¬ a1;
s[2] ¬ a2;
s[3] ¬ a3;
s[4] ¬ a4;
s[5] ¬ a5;
RETURN [s]
};
SV7:
PUBLIC
PROC [a0: Any, a1: Any, a2: Any, a3: Any, a4: Any, a5: Any, a6: Any]
RETURNS [SimpleVector] ~ {
s: SimpleVector ~ NEW[SimpleVectorRep[7]];
s[0] ¬ a0;
s[1] ¬ a1;
s[2] ¬ a2;
s[3] ¬ a3;
s[4] ¬ a4;
s[5] ¬ a5;
s[6] ¬ a6;
RETURN [s]
};
risCache: IO.STREAM ¬ NIL;
MakeRIS:
ENTRY
PROC [rope:
ROPE]
RETURNS [
IO.
STREAM] ~ {
s: IO.STREAM ¬ risCache;
risCache ¬ NIL;
s ¬ IO.RIS[rope: rope, oldStream: s];
RETURN [s]
};
FreeRIS:
ENTRY
PROC [s:
IO.
STREAM]
RETURNS [
IO.
STREAM ¬
NIL] ~ { risCache ¬ s };
ReadRopeVector:
PUBLIC
PROC [rope:
ROPE]
RETURNS [v: SimpleVector] ~ {
s: IO.STREAM ¬ MakeRIS[rope];
v ¬ NARROW[Read[s]];
s ¬ FreeRIS[s];
};
MakeTidbitCode:
PUBLIC PROC [
identifiers: Rope.ROPE, -- name, followed by 2 lists in read form: local names, then global names
env: Environment, -- global environment
nArgs: INTEGER, -- number of arguments, including rest; negative if dotted.
proc: TidbitCodeProc, -- the implementation procedure
literals: Any, -- A SimpleVector or a LIST OF REF; use SV*, above
initialPC: INTEGER, -- the initial pc for this procedure
doc: Rope.ROPE, -- documentation
ext: REF ¬ NIL -- for extensions (such as debugging info)
] RETURNS [TidbitCode] ~ {
s: IO.STREAM ¬ MakeRIS[identifiers];
name: Any ~ Read[s];
envNames: SimpleVector ~ NARROW[VectorFromList[Read[s]]];
globalBindings: PairSeq ~ GlobalsVector[env, Read[s]];
literalsVector: SimpleVector ~
WITH literals
SELECT
FROM
sv: SimpleVector => sv,
ENDCASE => NARROW[VectorFromList[literals]];
n: NAT ~ MAX[nArgs, -1-nArgs];
s ¬ FreeRIS[s];
RETURN [
NEW [TidbitCodeRep ¬ [
name: name,
envNames: envNames,
dotted: (nArgs < 0),
minArgs: n,
maxArgs: n,
proc: proc,
globalBindings: globalBindings,
literals: literalsVector,
initialPC: initialPC,
doc: doc,
ext: ext
]]]
};
GlobalsVector:
PROC [env: Environment, globalNames: Any]
RETURNS [PairSeq] ~ {
p: PairSeq ~ NEW[PairSeqRep[ListLength[globalNames]]];
FOR i:
NAT
IN [0..p.length)
DO
p[i] ¬ LookupCell[env: env, name: Car[globalNames]];
globalNames ¬ Cdr[globalNames];
ENDLOOP;
RETURN [p]
};
SymbolFromAny:
PROC [name: Any]
RETURNS [Symbol] ~ {
RETURN [
WITH name
SELECT
FROM
text: REF TEXT => Atom.MakeAtomFromRefText[text],
rope: ROPE => Atom.MakeAtom[rope],
atom: ATOM => atom,
string: String => SymbolFromRope[RopeFromString[string]],
ENDCASE => ERROR]
};
LookupCell:
PUBLIC
PROC [env: Environment, name: Any]
RETURNS [result: Pair ¬
NIL] ~ {
variable: Symbol ~ SymbolFromAny[name];
TryLookup:
PROC ~ {
FOR e: Environment ¬ env, e.parent
UNTIL e=
NIL
DO
IF e.names # NIL THEN Complain[e, "not a top-level environment"];
WITH RefTab.Fetch[
NARROW[e[0]], variable].val
SELECT
FROM
pair: Pair => { result ¬ pair; EXIT };
ENDCASE => NULL;
ENDLOOP;
};
TryLookup[];
IF result =
NIL
THEN {
DefineVariable[variable: variable, value: undefined, env: env];
TryLookup[];
};
IF result = NIL THEN ERROR;
};
CloseProcedure:
PUBLIC
PROC [p: Any, env: Environment]
RETURNS [TidbitProcedure] ~ {
IF env.parent # NIL AND env.parent.mark=0 THEN ERROR;
env.mark ¬ 100;
RETURN [NEW[TidbitProcedureRep ¬ [code: NARROW[p], env: env]]];
};
DefineProcedure:
PUBLIC
PROC [name: Rope.
ROPE, nArgs:
NAT, envNames:
LIST
OF
REF, dotted:
BOOL, proc: TidbitCodeProc, doc: Rope.
ROPE, env: Environment, lexicalEnv: Environment ¬
NIL, initialPC:
INTEGER ¬ 0, globalNames:
LIST
OF
REF ¬
NIL, literals: SimpleVector ¬
NIL, optional:
NAT ¬ 0] ~ {
code: TidbitCode ~
NEW [TidbitCodeRep ¬ [
name: SymbolFromRope[name],
envNames: NARROW[VectorFromList[envNames]],
dotted: dotted,
minArgs: nArgs-optional,
maxArgs: nArgs,
proc: proc,
globalBindings: GlobalsVector[env, globalNames],
literals: literals,
initialPC: initialPC,
doc: doc,
ext: NIL
]];
DefineVariable[variable: code.name, value: NEW[TidbitProcedureRep ¬ [code, lexicalEnv]], env: env];
};
Initialization
Init:
PROC [env: Environment] ~ {
DefineProcedure[name: "essential-apply", nArgs: 2, envNames: LIST[$procedure, $arguments], dotted: FALSE, proc: ApplyProcedureCode, doc: "Essential apply", env: env];
DefineProcedure[name: "primitive-call/cc", nArgs: 1, envNames: LIST[$procedure], dotted: FALSE, proc: CallCCProcedureCode, doc: "Primitive version of call/cc", env: env];
DefineProcedure[name: "error", nArgs: 3, dotted: FALSE, envNames: LIST[$name, $culprit, $message], proc: ErrorProcedureCode, doc: "(name culprit message) Enter the debugger", env: env, globalNames: LIST[SymbolFromRope["*system-error-handler*"]]];
};
RegisterInit[Init];