SchemePrimitivesImpl.mesa
Copyright Ó 1987, 1988, 1989, 1991 by Xerox Corporation. All rights reserved.
Michael Plass, December 2, 1991 10:25 am PST
Last changed by Pavel on March 20, 1989 6:16:08 pm PST
DIRECTORY
Ascii USING [CR, Digit, FF, Letter, LF, Lower, SP, TAB, Upper],
Atom USING [GetPName, MakeAtom],
Basics USING [BITXOR, CompareCard, Comparison, LongNumber],
BigCardinals USING [BigToREAL],
IO,
List USING [Compare, CompareProc, Sort],
Random USING [ChooseInt],
Rope USING [AppendChars, Cat, Compare, Concat, Fetch, Flatten, FromChar, FromProc, Match, ROPE, Size, Substr, Text],
SafeStorage USING [GetReferentType, Type],
Scheme,
SchemePrivate,
SchemeSys USING [CheckForAbort];
SchemePrimitivesImpl: CEDAR PROGRAM
IMPORTS Ascii, Atom, Basics, BigCardinals, IO, List, Random, Rope, SafeStorage, Scheme, SchemeSys
EXPORTS Scheme
~ BEGIN OPEN Scheme, SchemePrivate;
ROPE: TYPE ~ Rope.ROPE;
PrimitiveProc: TYPE ~ PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any ¬ NIL];
Support for primitives
MakeBoolean: PUBLIC PROC [b: BOOL] RETURNS [Any] ~ {
RETURN [IF b THEN true ELSE false]
};
TheBOOL: PUBLIC PROC [any: Any] RETURNS [BOOL] ~ {
RETURN [SELECT any FROM true => TRUE, false => FALSE ENDCASE => ERROR Complain[any, "neither #t or #f"]]
};
True: PUBLIC PROC [any: Any] RETURNS [BOOL] ~ {
RETURN [SELECT any FROM false, NIL => FALSE ENDCASE => TRUE]
};
False: PUBLIC PROC [any: Any] RETURNS [BOOL] ~ {
RETURN [SELECT any FROM false, NIL => TRUE ENDCASE => FALSE]
};
MakeChar: PUBLIC PROC [char: CHAR] RETURNS [Char] ~ {
RETURN [charTable[char]]
};
TheChar: PUBLIC PROC [any: Any] RETURNS [Char] ~ {
WITH any SELECT FROM
c: Char => RETURN [c];
ENDCASE => Complain[any, "not a character"];
};
TheROPE: PUBLIC PROC [a: Any] RETURNS [Rope.ROPE] ~ {
WITH a SELECT FROM
string: String => RETURN [RopeFromString[string]];
rope: ROPE => RETURN [rope]; -- we're nice guys, but how did this happen?
ENDCASE => Complain[a, "not a string"];
};
IsProcedure: PUBLIC PROC [a: Any] RETURNS [BOOL] ~ {
WITH a SELECT FROM
a: Primitive => RETURN [TRUE];
a: TidbitProcedure => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
};
ProcedureDocumentation: PUBLIC PROC [a: Any] RETURNS [ROPE] ~ {
WITH a SELECT FROM
p: Primitive => RETURN [p.doc];
p: TidbitProcedure => RETURN [p.code.doc];
ENDCASE => Complain[a, "not a procedure"];
};
Primitives
HashPrim: PrimitiveProc ~ {
SELECT self.data FROM
$eqHash => result ¬ MakeFixnum[LOOPHOLE[a]];
$eqvHash => {
XOR: PROC [a, b: INT] RETURNS [INT] ~ INLINE {
RETURN[LOOPHOLE[DoubleXor[LOOPHOLE[a], LOOPHOLE[b]]]];
};
DoubleXor: PROC [a,b: Basics.LongNumber] RETURNS [Basics.LongNumber] ~ INLINE {
RETURN [[pair[lo: Basics.BITXOR[a.lo, b.lo], hi: Basics.BITXOR[a.hi, b.hi]]]]
};
EqvHash: PROC [a: Any] RETURNS [result: INT] ~ {
WITH a SELECT FROM
a: Fixnum =>
result ¬ a­;
a: Flonum =>
result ¬ LOOPHOLE[a.real];
a: Bignum =>
result ¬ LOOPHOLE[BigCardinals.BigToREAL[a.magnitude]];
a: Ratnum =>
result ¬ XOR[EqvHash[a.numerator], EqvHash[a.denominator]];
a: Complex =>
result ¬ XOR[EqvHash[a.x], EqvHash[a.y]];
a: Char =>
result ¬ ORD[a­] + 1000;
a: PrimitiveSyntax =>
result ¬ ORD[a­] + 2000;
ENDCASE =>
result ¬ LOOPHOLE[a];
};
result ¬ MakeFixnum[EqvHash[a]];
};
ENDCASE => ERROR;
};
RandomPrim: PrimitiveProc ~ {
result ¬ MakeFixnum[Random.ChooseInt[max: KCheck[a] - 1]];
};
EqPredPrim: PrimitiveProc ~ {
result ¬ IF a = b THEN true ELSE false;
};
EqvPredPrim: PrimitiveProc ~ {
IF a = b THEN RETURN [true];
WITH a SELECT FROM
a: Fixnum => {
WITH b SELECT FROM
b: Fixnum => {
RETURN [IF a­ = b­ THEN true ELSE false];
};
b: Number => {
RETURN [IF b.exact AND Arith[equality, a, b] # false THEN true ELSE false];
};
ENDCASE => RETURN [false];
};
a: Number => {
WITH b SELECT FROM
b: Fixnum => {
RETURN [IF a.exact AND Arith[equality, a, b] # false THEN true ELSE false];
};
b: Number => {
RETURN [IF a.exact=b.exact AND Arith[equality, a, b] # false THEN true ELSE false];
};
ENDCASE => RETURN [false];
};
a: Char => {
WITH b SELECT FROM
b: Char => RETURN [IF a­ = b­ THEN true ELSE false];
ENDCASE => RETURN [false];
};
a: PrimitiveSyntax => {
WITH b SELECT FROM
b: PrimitiveSyntax => RETURN [IF a­ = b­ THEN true ELSE false];
ENDCASE => RETURN [false];
};
ENDCASE => RETURN [false];
};
ConsPrim: PrimitiveProc ~ { result ¬ Cons[a, b] };
ListPrim: PrimitiveProc ~ {
SELECT self.data FROM
$list => RETURN [rest];
$length => RETURN[MakeFixnum[ListLength[a]]];
$reverse => RETURN[Reverse[a]];
$sort => {
predicate: Any ~ b;
key: Any ~ c;
zPair: Pair ~ Cons[NIL, NIL];
yPair: Pair ~ Cons[NIL, zPair];
List1: PROC [s: Any] RETURNS [Pair] ~ INLINE { zPair.car ¬ s; RETURN [zPair] };
List2: PROC [s, t: Any] RETURNS [Pair] ~ INLINE { yPair.car ¬ s; zPair.car ¬ t; RETURN [yPair] };
Compare: List.CompareProc = {
[ref1: REF ANY, ref2: REF ANY] RETURNS [Basics.Comparison]
arg1: Any ~ IF key # undefined THEN Apply[proc: key, arguments: List1[ref1]] ELSE ref1;
arg2: Any ~ IF key # undefined THEN Apply[proc: key, arguments: List1[ref2]] ELSE ref2;
test: Any ~ Apply[proc: predicate, arguments: List2[arg1, arg2]];
RETURN [IF test = NIL OR test = false THEN less ELSE greater] -- sense is to sort list in reverse order
};
lora: LIST OF REF ANY ¬ NIL;
result ¬ NIL;
FOR tail: Any ¬ a, Cdr[tail] UNTIL tail = NIL DO
lora ¬ CONS[Car[tail], lora];
ENDLOOP;
RETURN [Reverse[List.Sort[list: lora, compareProc: Compare]]]
};
ENDCASE => ERROR;
};
CXRName: PROC [code: NAT] RETURNS [ROPE] ~ {
Makes names like car, cdr, caar, ...
code should be greater than 1
rope: ROPE ¬ "r";
FOR s: NAT ¬ code, s/2 UNTIL s = 1 DO
rope ¬ Rope.Concat[IF s MOD 2 = 0 THEN "a" ELSE "d", rope];
ENDLOOP;
RETURN [Rope.Concat["c", rope]];
};
CXRPrim: PrimitiveProc ~ {
result ¬ a;
FOR s: NAT ¬ NARROW[self.data, REF NAT]­, s/2 UNTIL s = 1 DO
result ¬ IF s MOD 2 = 0 THEN Car[result] ELSE Cdr[result];
ENDLOOP;
};
SetPrim: PrimitiveProc ~ {
result ¬ unspecified;
WITH a SELECT FROM
p: Pair => {IF self.data = $car THEN p.car ¬ b ELSE p.cdr ¬ b};
ENDCASE => Complain[a, "not a pair"];
};
TypePredPrim: PrimitiveProc ~ {
The primitive's data field should be a LIST OF REF; returns true if the argument's type matches the type of any of the elements of this LIST.
prototypes: LIST OF REF ANY ~ NARROW[self.data];
type: SafeStorage.Type ~ SafeStorage.GetReferentType[a];
FOR each: LIST OF REF ANY ¬ prototypes, each.rest UNTIL each = NIL DO
IF type = SafeStorage.GetReferentType[each.first] THEN RETURN [true]
ENDLOOP;
RETURN [false]
};
MemberPrim: PrimitiveProc ~ {
obj: Any ~ a;
test: Primitive ~ NARROW[self.data];
FOR list: Any ¬ b, Cdr[list] UNTIL list = NIL DO
first: Any ~ Car[list];
IF first = obj OR (test#NIL AND test.proc[test, obj, first, NIL, NIL]#false) THEN RETURN [list];
SchemeSys.CheckForAbort[];
ENDLOOP;
RETURN [false]
};
AssocPrim: PrimitiveProc ~ {
obj: Any ~ a;
test: Primitive ~ NARROW[self.data];
FOR list: Any ¬ b, Cdr[list] UNTIL list = NIL DO
first: Any ~ Car[list];
key: Any ~ Car[first];
IF key = obj OR (test#NIL AND test.proc[test, obj, key, NIL, NIL]#false) THEN RETURN [first];
SchemeSys.CheckForAbort[];
ENDLOOP;
RETURN [false]
};
VectorPrim: PrimitiveProc ~ {
WITH a SELECT FROM
v: SimpleVector => {
SELECT self.data FROM
$length => RETURN [MakeFixnum[v.length]];
$ref => {i: INT ~ KCheck[b, v.length-1]; RETURN [v[i]]};
$set => {i: INT ~ KCheck[b, v.length-1]; v[i] ¬ c; RETURN [unspecified]};
ENDCASE => ERROR;
};
v: Vector => {
SELECT self.data FROM
$length => RETURN [MakeFixnum[v.length]];
$ref => {i: INT ~ KCheck[b, v.length-1]; RETURN [v.ref[v, i]]};
$set => {i: INT ~ KCheck[b, v.length-1]; v.set[v, i, c]; RETURN [unspecified]};
ENDCASE => ERROR;
};
ENDCASE => Complain[a, "not a vector"];
};
MakePrim: PrimitiveProc ~ {
SELECT self.data FROM
$string => {
fill: CHAR ~ IF b = undefined THEN '\040 ELSE TheChar[b]­;
RETURN [StringFromRope[FillRope[fill: fill, length: KCheck[a]]]];
};
$vector => {
length: NAT ~ KCheck[a, NAT.LAST-8];
fill: Any ~ IF b = undefined THEN NIL ELSE b;
v: SimpleVector ~ NEW[SimpleVectorRep[length]];
FOR i: NAT IN [0..length) DO v[i] ¬ fill ENDLOOP;
RETURN [v]
};
ENDCASE => ERROR;
};
ConvertPrim: PrimitiveProc ~ {
types: LIST OF REF ~ NARROW[self.data];
target: REF ~ types.rest.first;
SELECT types.first FROM
$symbol => {
WITH a SELECT FROM
a: Symbol => {
SELECT target FROM
$string => {RETURN [StringFromRope[RopeFromSymbol[a]]]};
ENDCASE => ERROR;
};
ENDCASE => Complain[a, "not a symbol"];
};
$string => {
WITH a SELECT FROM
a: String => {
SELECT target FROM
$symbol => {RETURN [SymbolFromRope[RopeFromString[a]]]};
$list => {
list: Any ¬ NIL;
FOR i: INT DECREASING IN [0..StringLength[a]) DO
list ¬ Cons[MakeChar[StringRef[a, i]], list];
ENDLOOP;
RETURN [list]
};
ENDCASE => ERROR;
};
ENDCASE => Complain[a, "not a string"];
};
$list => {
length: INT ¬ 0;
FOR each: Any ¬ a, Cdr[each] UNTIL each = NIL DO
length ¬ length + 1;
ENDLOOP;
SELECT target FROM
$vector => {
IF length <= NAT.LAST-8
THEN {
v: SimpleVector ~ NEW[SimpleVectorRep[length]];
i: NAT ¬ 0;
FOR each: Any ¬ a, Cdr[each] UNTIL each = NIL DO
v[i] ¬ Car[each];
i ¬ i + 1;
ENDLOOP;
RETURN [v];
}
ELSE Complain[a, "too long to convert to a vector"];
};
$string => {
rest: Any ¬ a;
P: PROC RETURNS [CHAR] ~ {
c: Any ¬ Car[rest];
rest ¬ Cdr[rest];
RETURN [TheChar[c]­]
};
rope: ROPE ~ Rope.FromProc[len: length, p: P];
RETURN [StringFromRope[rope]]
};
ENDCASE => ERROR;
};
$char => {
WITH a SELECT FROM
c: Char => {
SELECT target FROM
$integer => RETURN [MakeFixnum[ORD[c­]]];
ENDCASE => ERROR;
};
ENDCASE => Complain[a, "not a character"];
};
$integer => {
SELECT target FROM
$char => RETURN [MakeChar[VAL[BYTE[KCheck[a]]]]];
ENDCASE => ERROR;
};
ENDCASE => ERROR;
};
gensymCounter: CARD ¬ 0;
GensymPrim: PrimitiveProc ~ {
prefix: ROPE ~ IF a = undefined THEN "t" ELSE RopeFromString[TheString[a]];
THROUGH [0..10000) DO
trial: Rope.Text ~ Rope.Flatten[IO.PutFR["%g%g", [rope[prefix]], [cardinal[gensymCounter]]]];
atom: ATOM ~ Atom.MakeAtom[trial];
gensymCounter ¬ gensymCounter + 1;
IF Atom.GetPName[atom] = trial THEN RETURN [atom];
Note this relies on MakeAtom and GetPName to not copy a flat rope.
ENDLOOP;
ERROR; -- somebody probably changed AtomImpl.
};
RecordPrim: PrimitiveProc ~ {
SELECT self.data FROM
$make => result ¬ NEW[RecordRep[KCheck[a]]];
$test =>
WITH a SELECT FROM
r: Record => result ¬ true;
ENDCASE => result ¬ false;
$length =>
WITH a SELECT FROM
r: Record => result ¬ MakeFixnum[r.length];
ENDCASE => Complain[a, "not a structure"];
$ref =>
WITH a SELECT FROM
r: Record => result ¬ r[KCheck[b, r.length - 1]];
ENDCASE => Complain[a, "not a structure"];
$set =>
WITH a SELECT FROM
r: Record => {
r[KCheck[b, r.length - 1]] ¬ c;
result ¬ unspecified;
};
ENDCASE => Complain[a, "not a structure"];
ENDCASE => ERROR;
};
Comparison Primitives
CompareDataRep: TYPE ~ RECORD [type: ATOM, case: BOOL, min: Basics.Comparison, max: Basics.Comparison];
ComparePrim: PrimitiveProc ~ {
data: REF CompareDataRep ~ NARROW[self.data];
comparison: Basics.Comparison ¬ equal;
SELECT data.type FROM
$string => { comparison ¬ Rope.Compare[s1: RopeFromString[TheString[a]], s2: RopeFromString[TheString[b]], case: data.case] };
$char => {
IF data.case
THEN comparison ¬ Basics.CompareCard[ORD[TheChar[a]­], ORD[TheChar[b]­]]
ELSE {
c1: CHAR ¬ TheChar[a]­;
c2: CHAR ¬ TheChar[b]­;
IF c1 <= 'Z AND c1 >= 'A THEN c1 ¬ c1 + ('a-'A);
IF c2 <= 'Z AND c2 >= 'A THEN c2 ¬ c2 + ('a-'A);
comparison ¬ Basics.CompareCard[ORD[c1], ORD[c2]];
};
};
$numeric => {
rc: REF Basics.Comparison ~ NARROW[Arith[compare, a, b]];
comparison ¬ rc­;
};
ENDCASE => ERROR;
RETURN [IF comparison IN [data.min..data.max] THEN true ELSE false]
};
NAryComparePrim: PrimitiveProc ~ {
prev: Any ¬ b;
result ¬ ComparePrim[self, a, b, undefined, NIL];
WHILE result = true AND rest # NIL DO
result ¬ ComparePrim[self, prev, rest.car, undefined, NIL];
prev ¬ rest.car;
rest ¬ NARROW[rest.cdr];
ENDLOOP;
};
DefineComparisons: PROC [type: ATOM, env: Environment, case: BOOL ¬ TRUE, nAry: BOOL ¬ FALSE] ~ {
t: ARRAY [0..5) OF ROPE ~ ["<", "<=", "=", ">=", ">"];
r: ARRAY [0..5) OF RECORD [min, max: Basics.Comparison] ~ [[less, less], [less, equal], [equal, equal], [equal, greater], [greater, greater]];
stem: ROPE ~ SELECT type FROM $string => "string", $char => "char", $numeric => NIL, ENDCASE => ERROR;
doc: ROPE ¬ SELECT type FROM
$string => (IF case THEN "case-sensitive string " ELSE "case-insensitive string "),
$char => (IF case THEN "case-sensitive character " ELSE "case-insensitive character "),
$numeric => ("numerical "),
ENDCASE => ERROR;
prim: PrimitiveProc ~ IF nAry THEN NAryComparePrim ELSE ComparePrim;
IF nAry THEN
doc ¬ Rope.Concat["n-ary ", doc];
FOR i: NAT IN [0..5) DO
name: ROPE ~ IF stem = NIL THEN t[i] ELSE Rope.Cat[stem, IF case THEN NIL ELSE "-ci", t[i], "?"];
DefinePrimitive[name: name, nArgs: 2, dotted: nAry, proc: prim, env: env,
doc: Rope.Cat[doc, t[i], " test"], data: NEW[CompareDataRep ¬ [type: type, case: case, min: r[i].min, max: r[i].max]]];
ENDLOOP;
};
String/Character Primitives
charTable: REF ARRAY CHAR OF Char ~ InitCharTable[];
InitCharTable: PROC RETURNS [a: REF ARRAY CHAR OF Char] ~ {
a ¬ NEW[ARRAY CHAR OF Char];
FOR i: CHAR IN CHAR DO
a[i] ¬ NEW[CHAR ¬ i];
ENDLOOP;
};
CharPrim: PrimitiveProc ~ {
c1: CHAR ¬ TheChar[a]­;
SELECT self.data FROM
$alphaPred => {RETURN [IF Ascii.Letter[c1] THEN true ELSE false]};
$upperPred => {
RETURN [
SELECT c1 FROM
IN ['a..'z] => false,
IN ['A..'Z] => true
ENDCASE => Complain[a, "not a letter"]
]
};
$lowerPred => {
RETURN [
SELECT c1 FROM
IN ['a..'z] => true,
IN ['A..'Z] => false
ENDCASE => Complain[a, "not a letter"]
]
};
$numericPred => {RETURN [IF Ascii.Digit[c1] THEN true ELSE false]};
$whitespacePred => {
RETURN [
SELECT c1 FROM
Ascii.SP, Ascii.CR, Ascii.TAB, Ascii.LF, Ascii.FF => true
ENDCASE => false
]
};
$upcase => {RETURN [MakeChar[Ascii.Upper[c1]]]};
$downcase => {RETURN [MakeChar[Ascii.Lower[c1]]]};
ENDCASE => ERROR;
};
StringLength: PUBLIC PROC [string: String] RETURNS [INT] ~ {
RETURN [MAX[Rope.Size[string.base], (IF string.buffer = NIL THEN 0 ELSE string.where+string.buffer.length)]]
};
StringRef: PUBLIC PROC [string: String, i: INT] RETURNS [CHAR] ~ {
RETURN [IF string.buffer # NIL AND i IN [string.where..string.where+string.buffer.length) THEN string.buffer[i-string.where] ELSE Rope.Fetch[string.base, i]]
};
maxStringBufferSize: NAT ¬ 60;
StringSet: PUBLIC PROC [string: String, i: INT, c: CHAR] ~ {
length: INT ~ StringLength[string];
IF string.buffer = NIL THEN string.buffer ¬ NEW[TEXT[MIN[length, maxStringBufferSize]]];
IF i NOT IN [string.where..string.where + string.buffer.length) THEN {
[] ¬ RopeFromString[string];
string.where ¬ IF i < string.where THEN MAX[0, i-string.buffer.maxLength/2] ELSE i;
[] ¬ Rope.AppendChars[buffer: string.buffer, rope: string.base, start: string.where];
};
string.buffer[i-string.where] ¬ c;
};
TheString: PUBLIC PROC [any: Any] RETURNS [String] ~ {
WITH any SELECT FROM
s: String => RETURN [s];
ENDCASE => Complain[any, "not a string"];
};
StringPrim: PrimitiveProc ~ {
string: String ¬ TheString[a];
SELECT self.data FROM
$length => RETURN [MakeFixnum[StringLength[string]]];
$ref => RETURN [MakeChar[StringRef[string, KCheck[b, StringLength[string]-1]]]];
$set => {StringSet[string, KCheck[b, StringLength[string]-1], TheChar[c]­]; RETURN [unspecified]};
$substring => {
length: INT ~ StringLength[string];
start: INT ~ KCheck[b, length];
end: INT ~ KCheck[c, length];
IF NOT (0 <= start) AND (start <= end) AND (end <= length) THEN
Complain[Cons[a, Cons[b, NIL]], "invalid substring"];
RETURN [StringFromRope[Rope.Substr[base: RopeFromString[string], start: start, len: end-start]]]};
$append => {
RETURN [
StringFromRope[Rope.Concat[RopeFromString[string],
RopeFromString[TheString[b]]]]]
};
$copy => { RETURN [StringFromRope[RopeFromString[string]]] };
$fill => {
fill: CHAR ~ TheChar[b]­;
[] ¬ RopeFromString[string];
string.base ¬ FillRope[fill, Rope.Size[string.base]];
RETURN [unspecified]
};
$stringmatch, $stringcimatch => {
pattern: ROPE ~ RopeFromString[string];
target: ROPE ~ WITH b SELECT FROM b: Symbol => RopeFromSymbol[b] ENDCASE => RopeFromString[TheString[b]];
RETURN [IF Rope.Match[pattern: pattern, object: target, case: self.data=$stringmatch] THEN true ELSE false];
};
ENDCASE => ERROR;
};
FillRope: PROC [fill: CHAR, length: INT] RETURNS [ROPE] ~ {
r: ROPE ¬ Rope.FromChar[fill];
UNTIL Rope.Size[r] = length DO
r ¬ Rope.Concat[r, Rope.Substr[r, 0, length-Rope.Size[r]]];
ENDLOOP;
RETURN [r]
};
Syntax Primitives
symbolForPrimitiveSyntaxRep: PUBLIC REF ARRAY PrimitiveSyntaxRep OF Symbol ~ NEW[ARRAY PrimitiveSyntaxRep OF Symbol ¬ [quote: $quote, define: $define, setBang: SymbolFromRope["set!"], lambda: $lambda, begin: $begin, if: $if]];
primitiveSyntaxForPrimitiveSyntaxRep: PUBLIC REF ARRAY PrimitiveSyntaxRep OF PrimitiveSyntax ~ InitRefForPrimitiveSyntax[];
InitRefForPrimitiveSyntax: PROC RETURNS [a: REF ARRAY PrimitiveSyntaxRep OF PrimitiveSyntax] ~ {
a ¬ NEW[ARRAY PrimitiveSyntaxRep OF PrimitiveSyntax];
FOR p: PrimitiveSyntaxRep IN PrimitiveSyntaxRep DO
a[p] ¬ NEW[PrimitiveSyntaxRep ¬ p];
ENDLOOP;
};
ExpandPrimitiveSyntaxPrim: PrimitiveProc ~ {
IF self.maxArgs >= 3 THEN rest ¬ Cons[c, rest];
IF self.maxArgs >= 2 THEN rest ¬ Cons[b, rest];
IF self.maxArgs >= 1 THEN rest ¬ Cons[a, rest];
RETURN [Cons[self.data, rest]]
};
SyntaxPrim: PrimitiveProc ~ {
SELECT self.data FROM
$make => {
syntax: Syntax ~ NEW[SyntaxRep];
IF IsProcedure[a] THEN
syntax.expander ¬ a
ELSE
Complain[a, "not a procedure"];
result ¬ syntax;
};
$syntaxP => {
WITH a SELECT FROM
s: Syntax => RETURN [true];
ENDCASE => RETURN [false];
};
$expander => {
WITH a SELECT FROM
s: Syntax => RETURN [s.expander];
ENDCASE => Complain[a, "not a syntax object"];
};
$toSymbol => {
WITH a SELECT FROM
p: PrimitiveSyntax => RETURN [symbolForPrimitiveSyntaxRep[p­]];
ENDCASE => Complain[a, "not a primitive-syntax-marker"];
};
$toMarker => {
FOR p: PrimitiveSyntaxRep IN PrimitiveSyntaxRep DO
IF symbolForPrimitiveSyntaxRep[p] = a THEN RETURN [primitiveSyntaxForPrimitiveSyntaxRep[p]]
ENDLOOP;
Complain[a, "not the name of a primitive-syntax-marker"];
};
$primitiveSyntaxP => {
WITH a SELECT FROM
p: PrimitiveSyntax => RETURN [true];
ENDCASE => RETURN [false];
};
ENDCASE => ERROR;
};
Registration of Primitives
RegisterEssentials: PROC [env: Environment] ~ {
nArgsPS: ARRAY PrimitiveSyntaxRep OF NAT ~ [quote: 1, define: 2, setBang: 2, lambda: 1, begin: 0, if: 3];
dottedPS: ARRAY PrimitiveSyntaxRep OF BOOL ~ [quote: FALSE, define: FALSE, setBang: FALSE, lambda: TRUE, begin: TRUE, if: FALSE];
FOR p: PrimitiveSyntaxRep IN PrimitiveSyntaxRep DO
symbol: Symbol ~ symbolForPrimitiveSyntaxRep[p];
expander: Primitive ~ NEW[PrimitiveRep ¬ [minArgs: nArgsPS[p], maxArgs: nArgsPS[p], dotted: dottedPS[p], proc: ExpandPrimitiveSyntaxPrim, doc: Rope.Concat[RopeFromSymbol[symbol], " primitive syntax"], data: NEW[PrimitiveSyntaxRep ¬ p], symbol: symbol]];
value: Syntax ~ NEW[SyntaxRep ¬ [expander: expander]];
DefineVariable[variable: symbol, value: value, env: env];
ENDLOOP;
DefineComparisons[type: $numeric, env: env];
DefineComparisons[type: $string, env: env, case: TRUE];
DefineComparisons[type: $char, env: env, case: TRUE];
DefinePrimitive[name: "eq?", nArgs: 2, dotted: FALSE, proc: EqPredPrim, env: env,
doc: "Pointer equality"];
DefinePrimitive[name: "eqv?", nArgs: 2, dotted: FALSE, proc: EqvPredPrim, env: env,
doc: "operational equivalence"];
DefinePrimitive[name: "cons", nArgs: 2, dotted: FALSE, proc: ConsPrim, env: env,
doc: "New pair"];
FOR i: NAT IN [2..32) DO
name: ROPE ~ CXRName[i];
DefinePrimitive[name: name, nArgs: 1, dotted: FALSE, proc: CXRPrim, env: env, data: NEW[NAT ¬ i], doc: name];
ENDLOOP;
DefinePrimitive[name: "list", nArgs: 0, dotted: TRUE, proc: ListPrim, env: env, data: $list, doc: "Construct a list of the arguments"];
DefinePrimitive[name: "length", nArgs: 1, dotted: FALSE, proc: ListPrim, env: env, data: $length, doc: "length of a list"];
DefinePrimitive[name: "boolean?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env, data: LIST[false], doc: "test for boolean type"];
DefinePrimitive[name: "char?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env, data: LIST[MakeChar['a]], doc: "test for character type"];
DefinePrimitive[name: "pair?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
data: LIST[Cons[NIL, NIL], LIST[NIL]], doc: "test for pair type"];
DefinePrimitive[name: "symbol?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
data: LIST[$a], doc: "test for symbol type"];
DefinePrimitive[name: "vector?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
data: LIST[NEW[SimpleVectorRep[0]], NEW[VectorRep ¬ [0, NIL, NIL, NIL]]], doc: "test for vector type"];
DefinePrimitive[name: "string?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
data: LIST[emptyString], doc: "test for string type"];
DefinePrimitive[name: "procedure?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env,
data: LIST[NEW[PrimitiveRep], NEW[TidbitProcedureRep]], doc: "test for procedure type"];
DefinePrimitive[name: "number?", nArgs: 1, dotted: FALSE, proc: TypePredPrim, env: env, data: LIST[MakeFixnum[0], NEW[NumberRep ¬ [TRUE, flonum[0.0]]]], doc: "test for number type"];
DefinePrimitive[name: "memv", nArgs: 2, dotted: FALSE, proc: MemberPrim, env: env, data: LookupVariableValue[SymbolFromRope["eqv?"], env], doc: "membership test using eqv?"];
DefinePrimitive[name: "memq", nArgs: 2, dotted: FALSE, proc: MemberPrim, env: env, data: NIL, doc: "membership test using eq?"];
DefinePrimitive[name: "assv", nArgs: 2, dotted: FALSE, proc: AssocPrim, env: env, data: LookupVariableValue[SymbolFromRope["eqv?"], env], doc: "association list lookup using eqv?"];
DefinePrimitive[name: "assq", nArgs: 2, dotted: FALSE, proc: AssocPrim, env: env, data: NIL, doc: "association list lookup using eq?"];
DefinePrimitive[name: "set-car!", nArgs: 2, dotted: FALSE, proc: SetPrim, env: env, data: $car, doc: "Store object in car field"];
DefinePrimitive[name: "set-cdr!", nArgs: 2, dotted: FALSE, proc: SetPrim, env: env, data: $cdr, doc: "Store object in cdr field"];
DefinePrimitive[name: "symbol->string", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$symbol, $string], doc: "convert a symbol to a string"];
DefinePrimitive[name: "string->symbol", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$string, $symbol], doc: "convert a string to a symbol"];
DefinePrimitive[name: "string->list", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$string, $list], doc: "convert a string to a list"];
DefinePrimitive[name: "list->string", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$list, $string], doc: "convert a list to a string"];
DefinePrimitive[name: "list->vector", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$list, $vector], doc: "convert a list to a vector"];
DefinePrimitive[name: "char->integer", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$char, $integer], doc: "convert a char to an integer"];
DefinePrimitive[name: "integer->char", nArgs: 1, dotted: FALSE, proc: ConvertPrim, env: env, data: LIST[$integer, $char], doc: "convert an integer to a char"];
DefinePrimitive[name: "make-string", nArgs: 2, optional: 1, dotted: FALSE, proc: MakePrim, env: env, data: $string, doc: "make a new string"];
DefinePrimitive[name: "string-length", nArgs: 1, dotted: FALSE, proc: StringPrim, env: env, data: $length, doc: "length of a string"];
DefinePrimitive[name: "string-ref", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $ref, doc: "element b in string a"];
DefinePrimitive[name: "string-set!", nArgs: 3, dotted: FALSE, proc: StringPrim, env: env, data: $set, doc: "set element b in string a to c"];
DefinePrimitive[name: "substring", nArgs: 3, dotted: FALSE, proc: StringPrim, env: env, data: $substring, doc: "substring of a starting at b and ending before c"];
DefinePrimitive[name: "string-copy", nArgs: 1, dotted: FALSE, proc: StringPrim, env: env, data: $copy, doc: "copy the string"];
DefinePrimitive[name: "essential-string-append", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $append, doc: "append two strings"];
DefinePrimitive[name: "string-fill!", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $fill, doc: "fill string a with character b"];
DefinePrimitive[name: "make-vector", nArgs: 2, optional: 1, dotted: FALSE, proc: MakePrim, env: env, data: $vector, doc: "make a new vector"];
DefinePrimitive[name: "vector-length", nArgs: 1, dotted: FALSE, proc: VectorPrim, env: env, data: $length, doc: "length of a vector"];
DefinePrimitive[name: "vector-ref", nArgs: 2, dotted: FALSE, proc: VectorPrim, env: env, data: $ref, doc: "element b in vector a"];
DefinePrimitive[name: "vector-set!", nArgs: 3, dotted: FALSE, proc: VectorPrim, env: env, data: $set, doc: "set element b in vector a to c"];
};
RegisterOptionals: PROC [env: Environment] ~ {
DefineComparisons[type: $numeric, env: env, nAry: TRUE];
DefineComparisons[type: $string, env: env, case: TRUE, nAry: TRUE];
DefineComparisons[type: $char, env: env, case: TRUE, nAry: TRUE];
DefineComparisons[type: $string, env: env, case: FALSE, nAry: TRUE];
DefineComparisons[type: $char, env: env, case: FALSE, nAry: TRUE];
DefinePrimitive[name: "reverse", nArgs: 1, dotted: FALSE, proc: ListPrim, env: env, data: $reverse, doc: "reverse a list"];
DefinePrimitive[name: "char-alphabetic?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $alphaPred,
doc: "test for an alphabetic character"];
DefinePrimitive[name: "char-upper-case?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $upperPred,
doc: "test for an upper-case letter"];
DefinePrimitive[name: "char-lower-case?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $lowerPred,
doc: "test for a lower-case letter"];
DefinePrimitive[name: "char-numeric?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $numericPred,
doc: "test for a digit"];
DefinePrimitive[name: "char-whitespace?", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $whitespacePred,
doc: "test for whitespace"];
DefinePrimitive[name: "char-upcase", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $upcase,
doc: "convert char to upper case"];
DefinePrimitive[name: "char-downcase", nArgs: 1, dotted: FALSE, proc: CharPrim, env: env, data: $downcase,
doc: "convert char to lower case"];
};
RegisterExtensions: PROC [env: Environment] ~ {
DefinePrimitive[name: "make-syntax", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
doc: "Make a syntax object", data: $make];
DefinePrimitive[name: "syntax?", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
doc: "Is this a syntax expander?", data: $syntaxP];
DefinePrimitive[name: "syntax-expander", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
doc: "Extract the expansion function from a syntax object", data: $expander];
DefinePrimitive[name: "primitive-syntax-marker->symbol", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
doc: "Convert a primitive syntax marker to a symbol", data: $toSymbol];
DefinePrimitive[name: "symbol->primitive-syntax-marker", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
doc: "Convert a symbol to a primitive syntax marker", data: $toMarker];
DefinePrimitive[name: "primitive-syntax-marker?", nArgs: 1, dotted: FALSE, proc: SyntaxPrim, env: env,
doc: "test for a primitive syntax marker", data: $primitiveSyntaxP];
DefinePrimitive[name: "gensym", nArgs: 1, optional: 1, dotted: FALSE, proc: GensymPrim, env: env, data: NIL, doc: "generate a new symbol [with prefix a]"];
DefinePrimitive[name: "sort", nArgs: 3, optional: 1, dotted: FALSE, proc: ListPrim, env: env, data: $sort, doc: "(list predicate [ key ]) sort a list"];
DefinePrimitive[name: "eq-hash", nArgs: 1, dotted: FALSE, proc: HashPrim, env: env, data: $eqHash, doc: "Hash function respecting the EQ? predicate"];
DefinePrimitive[name: "eqv-hash", nArgs: 1, dotted: FALSE, proc: HashPrim, env: env, data: $eqvHash, doc: "Hash function respecting the EQV? predicate"];
DefinePrimitive[name: "random", nArgs: 1, dotted: FALSE, proc: RandomPrim, env: env, doc: "Returns a random integer in the range [0..a)"];
DefinePrimitive[name: "string-match?", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $stringmatch, doc: "(pattern-string target) Does pattern-string match target? Use \"*\" as a wildcard."];
DefinePrimitive[name: "string-ci-match?", nArgs: 2, dotted: FALSE, proc: StringPrim, env: env, data: $stringcimatch, doc: "(pattern-string target) Does pattern-string match target, ignoring case? Use \"*\" as a wildcard."];
DefinePrimitive[name: "%make-record", nArgs: 1, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $make, doc: "(length) PRIVATE: make a new structure object of the given length"];
DefinePrimitive[name: "%record-ref", nArgs: 2, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $ref, doc: "(structure index) PRIVATE: get a field of a structure"];
DefinePrimitive[name: "%record-set!", nArgs: 3, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $set, doc: "(structure index value) PRIVATE: set a field of a structure"];
DefinePrimitive[name: "%record-length", nArgs: 1, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $length, doc: "(structure) PRIVATE: return length of a structure object"];
DefinePrimitive[name: "%record?", nArgs: 1, optional: 0, dotted: FALSE, proc: RecordPrim, env: env, data: $test, doc: "(value) PRIVATE: is this a structure?"];
};
Initalization
RegisterInit[RegisterEssentials];
RegisterInit[RegisterOptionals];
RegisterInit[RegisterExtensions];
END.