<<>> <> <> <> <<>> DIRECTORY Commander, CommanderOps, SymTab, FS, IO, CrankTypes, MPTree, MPLeaves, Rope, CrankOps, CrankAnalyze, RefText; CrankMakeSchemeStubsImpl: CEDAR PROGRAM IMPORTS Commander, CommanderOps, SymTab, FS, IO, Rope, CrankOps, CrankAnalyze, RefText ~ BEGIN OPEN CrankTypes, CrankOps; Break: SIGNAL ~ CODE; 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 => { <> }; 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; }; CrankSchemeStubsCommand: Commander.CommandProc ~ { fileName: ROPE ~ CommanderOps.NextArgument[cmd]; IF fileName = NIL THEN CommanderOps.Failed[cmd.procData.doc]; CrankAnalyze.Convert[fileName: fileName, analyze: TRUE, action: FromTree]; }; Commander.Register["CrankSchemeStubs", CrankSchemeStubsCommand, " - produce fooSchemeStubsImpl.mesa"]; END.