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. Ψ CrankMakeSchemeStubsImpl.mesa Copyright Σ 1988, 1991 by Xerox Corporation. All rights reserved. Michael Plass, December 3, 1991 11:46 am PST GenFieldListPrinter[varName, record.fieldList, referentTypeName] ΚΞ•NewlineDelimiter –(cedarcode) style™code™Kšœ Οeœ7™BK™,K™—KšΟk œ"žœžœF˜wK˜Ihead2šœžœž˜'Kšžœ"žœžœ'˜Všœžœžœ˜"K˜šΟnœžœžœ˜K˜—š Ÿœžœžœžœžœžœ˜=Kšœžœžœ˜,•StartOfExpansionD[to: REF TEXT, from: ROPE, start: INT _ 0, len: NAT _ 32767]š Ÿœžœžœžœžœžœ˜,šžœž˜ šžœ˜Kš žœžœ žœžœžœ%˜iK˜+Kšœ žœ˜K˜—šžœ˜ K˜#Kšœ žœ˜K˜——K˜—Kšœ žœžœ˜K˜.K–T[base: ROPE, start: INT _ 0, len: INT _ 2147483647, action: Rope.ActionType]˜#K–T[base: ROPE, start: INT _ 0, len: INT _ 2147483647, action: Rope.ActionType]˜#K˜K˜K˜K˜—šŸœžœ#˜1K˜"KšŸ œžœžœ,˜GKš œ žœžœžœžœ˜!Kš œ žœžœžœžœ˜Kšœ žœžœ˜Kšœ žœ˜š Ÿ œžœžœ žœžœžœ˜GKšžœ7˜9Kšžœ˜Kšžœ˜šžœƒžœ˜ŠKšœΟc˜Kšœ ˜(Kšœ ˜Kšœ ˜3K˜—K˜K˜—šŸ œžœžœžœ˜8Kš œžœžœžœ"žœ˜BKšœžœžœ˜(Kšœžœžœ˜-Kšžœžœžœžœ˜8K˜Kšžœ˜"K˜—šŸœžœžœ˜.Kšœžœ˜$šŸœžœ˜Kšœžœ˜K˜—K˜K˜—šŸœžœ.žœ˜DšŸœžœ˜Kšœžœ˜Kšœžœ˜5Kšœžœ"˜6šœEžœ>žœ˜K˜AK˜K˜—šžœJžœž˜Yšœžœ˜K™@K˜—šœžœ˜Kšœ žœžœ ˜4Kšœ žœžœ 4˜Lšžœ,žœž˜;Kšœ žœ9˜FKšžœžœ˜—šžœ+žœž˜:šœ žœ˜%K˜K˜—šœžœ˜Kšœ$ ˜4K˜—šœ žœ˜#Kšœ$ ˜4K˜—Kšžœžœ˜—š žœ žœžœ žœžœ˜*Kšœžœžœžœ'˜O˜K˜*K˜ KšœžœH˜Ošœžœ˜K˜fK˜K˜ K˜K˜—K˜—K˜—K˜—Kšžœžœ˜—K˜—K˜K˜—šŸœžœ;žœ˜MšŸœžœ˜K˜%K˜—K˜#K˜—šŸ œžœžœ˜9Kšœžœ˜$KšŸœžœ1˜;K˜Kšžœo˜qKšžœŸ˜‘K˜%Kšžœ)˜+Kšžœ<˜>Kšžœžœ˜0Kšžœ˜Kšžœ-˜/Kšžœ˜!K˜—šŸœžœ4žœ˜CKšœžœ˜$K˜(K˜—K˜K˜Kšžœ žœžœžœ˜K˜šž˜KšœžœžœžœD˜UKšœžœ˜–= -- [key: ROPE, val: SymTab.Val] RETURNS [quit: BOOL _ FALSE]šŸ œ˜%Kšžœ˜K˜ Kšžœžœžœ˜"K˜—Kšžœ˜K˜.Kšžœ˜Kšžœ žœ˜*Kšžœ ˜ Kšžœ˜—K˜K˜—šŸœ˜2Kšœ žœ"˜0Kšžœ žœžœ'˜=Kšœ2žœ˜JK˜K˜—K˜pK˜—K˜Kšžœ˜—…— Ζ