Schemize:
PROC [r1, r2, r3:
ROPE ¬
NIL]
RETURNS [s:
ROPE] ~ {
text: REF TEXT ¬ RefText.ObtainScratch[100];
P:
PROC [c:
CHAR]
RETURNS [
BOOL ¬
FALSE] ~ {
SELECT c
FROM
IN ['A..'Z] => {
IF NOT prevCap AND text.length > 0 AND text[text.length-1] # '- THEN text ¬ RefText.AppendChar[text, '-];
text ¬ RefText.AppendChar[text, c+('a-'A)];
prevCap ¬ TRUE;
};
ENDCASE => {
text ¬ RefText.AppendChar[text, c];
prevCap ¬ FALSE;
};
};
prevCap: BOOL ¬ TRUE;
text ¬ RefText.AppendRope[to: text, from: r1];
[] ¬ Rope.Map[base: r2, action: P];
[] ¬ Rope.Map[base: r3, action: P];
s ¬ Rope.FromRefText[text];
RefText.ReleaseScratch[text];
};
FromTree:
PROC [tree: Tree, context: Context] ~ {
dir: SymTab.Ref ¬ SymTab.Create[];
InsertDir: PROC [rope: ROPE] ~ { [] ¬ SymTab.Insert[dir, rope, rope] };
codeStream: IO.STREAM ¬ IO.ROS[];
delayed: IO.STREAM ¬ IO.ROS[];
moduleID: ROPE ¬ NIL;
primNumber: INT ¬ 0;
MakePrimitive:
PROC [name:
ROPE, nArgs:
INT, doc:
ROPE, code:
ROPE] ~ {
IO.PutF1[codeStream, "%g => {\n", [integer[primNumber]]];
IO.PutRope[codeStream, code];
IO.PutRope[codeStream, "};\n"];
IO.PutFL[delayed, "DefinePrimitive[name: \"%g\", nArgs: %g, dotted: FALSE, proc: Prim, doc: %g, env: env, data: MakeFixnum[%g]];\n",
LIST[
[rope[name]], -- primitive name
[integer[nArgs]], -- number of arguments
[refAny[doc]], -- documentation
[integer[primNumber]] -- index for select statement
]];
primNumber ¬ primNumber + 1;
};
NameOfType:
PROC [typeCode: TypeCode]
RETURNS [
ROPE] ~ {
typeNameList: LIST OF REF ~ GetTypeName[context, typeCode, FALSE];
qual: ROPE ~ NARROW[typeNameList.first];
base: ROPE ~ NARROW[typeNameList.rest.first];
IF Rope.Equal[qual, "BUILTIN", TRUE] THEN RETURN [base];
InsertDir[qual];
RETURN [Rope.Cat[qual, ".", base]]
};
D:
PROC [idNode, typeNode, valueNode:
REF] = {
self: AttributedNode = NARROW[tree];
Each:
PROC [item: Tree] = {
id: ROPE = GetIdentifier[item];
};
DoList[idNode, Each];
};
TypeDecl:
PROC [identifierNode, typeNode, initialValueNode:
REF] = {
Each:
PROC [item: Tree] = {
id: ROPE = GetIdentifier[item];
referentTypeName: ROPE = Rope.Cat[moduleID, ".", id];
schemeTypeName: ROPE = Schemize["ref-", moduleID, id];
MakePrimitive[name: Rope.Concat[schemeTypeName, "?"], nArgs: 1, doc:
IO.PutFR1["Test for a REF %g", [rope[referentTypeName]]], code:
IO.PutFR1[
"result ← WITH a SELECT FROM a: REF %g => true ENDCASE => false",
[rope[referentTypeName]]
]];
WITH UnderType[context.types, GetTypeValueAttribute[context.types, typeNode]]
SELECT
FROM
record:
REF TypeRep.record => {
GenFieldListPrinter[varName, record.fieldList, referentTypeName]
};
array:
REF TypeRep.array => {
indexMesa: ROPE ¬ NIL; -- template for mesa code to
refifyMesa: ROPE ¬ NIL; -- template for mesa code to turn something to a REF
WITH UnderType[context.types, array.domainType]
SELECT
FROM
subrange: REF TypeRep.subrange => indexMesa ¬ "KCheck[b, LENGTH[a^]]";
ENDCASE => NULL;
WITH UnderType[context.types, array.rangeType]
SELECT
FROM
reference:
REF TypeRep.reference => {
refifyMesa ¬ "%g";
};
scalar:
REF TypeRep.scalar => {
refifyMesa ¬ "MakeFixnum[ORD[%g]]"; -- not right yet
};
subrange:
REF TypeRep.subrange => {
refifyMesa ¬ "MakeFixnum[ORD[%g]]"; -- not right yet
};
ENDCASE => NULL;
IF indexMesa#
NIL
AND refifyMesa#
NIL
THEN {
r: ROPE ~ IO.PutFR1[refifyMesa, [rope[IO.PutFR1["a[%g]", [rope[indexMesa]]]]]];
MakePrimitive[
name: Rope.Concat[schemeTypeName, "-ref"],
nArgs: 2,
doc: IO.PutFR1["(schemeTypeName k) index into a %g", [rope[referentTypeName]]],
code:
IO.PutFR[
"result ← WITH a SELECT FROM a: REF %g => result ← %g ENDCASE => ERROR Complain[a, \"not a REF %g\"]",
[rope[referentTypeName]],
[rope[r]],
[rope[referentTypeName]]
]
];
};
};
ENDCASE => NULL;
};
DoList[identifierNode, Each];
};
Body:
PROC [openNode, declarationsNode, bodyContentsNode, exitsNode:
REF] = {
EachDecl:
PROC [item: Tree] = {
[] ¬ With3[item, typedecl, TypeDecl];
};
DoList[declarationsNode, EachDecl];
};
TopLevelDecl:
PROC [idNode, typeNode, valueNode:
REF] = {
self: AttributedNode = NARROW[tree];
Each: PROC [item: Tree] = {moduleID ¬ GetIdentifier[item]};
DoList[idNode, Each];
IO.PutF1[codeStream, "%gSchemeStubsImpl: CEDAR PROGRAM IMPORTS Scheme = BEGIN OPEN Scheme;\n", [rope[moduleID]]];
IO.PutRope[codeStream, "Prim: PROC [self: Primitive, a, b, c: Any, rest: ProperList] RETURNS [result: Any ← unspecified] ~ {\n SELECT KCheck[self.data] FROM\n"];
Assert[With4[valueNode, body, Body]];
IO.PutRope[codeStream, " ENDCASE;\n};\n"];
IO.PutRope[codeStream, "Init: PROC [env: Environment] = {\n"];
IO.PutRope[codeStream, IO.RopeFromROS[delayed]];
IO.PutRope[codeStream, "};\n"];
IO.PutRope[codeStream, "RegisterInit[Init]\n"];
IO.PutRope[codeStream, "END.\n"];
};
M:
PROC [directory, imports, exports, shares, locks, decl:
REF] = {
self: AttributedNode = NARROW[tree];
Assert[With3[decl, decl, TopLevelDecl]];
};
InsertDir["Scheme"];
Assert[With6[tree, module, M]];
IF moduleID = NIL THEN ERROR;
InsertDir[moduleID];
BEGIN
s: IO.STREAM = FS.StreamOpen[Rope.Concat[moduleID, "SchemeStubsImpl.mesa"], $create];
i: INT ¬ SymTab.GetSize[dir];
PairAction: SymTab.EachPairAction = {
IO.PutRope[s, key];
i ¬ i - 1;
IF i # 0 THEN IO.PutRope[s, ", "];
};
IO.PutRope[s, "DIRECTORY "];
[] ¬ SymTab.Pairs[x: dir, action: PairAction];
IO.PutRope[s, ";\n"];
IO.PutRope[s, IO.RopeFromROS[codeStream]];
IO.Close[s];
END;
};
Commander.Register["CrankSchemeStubs", CrankSchemeStubsCommand, "<fileName> - produce fooSchemeStubsImpl.mesa"];