Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Path: utzoo!mnetor!uunet!husc6!necntc!ncoast!allbery From: dietz@zhmti.UUCP (Dieter H. Zebbedies) Newsgroups: comp.sources.misc Subject: "Producer" translates Smalltalk to Objective-C (Part 4 of 5) Message-ID: <4220@ncoast.UUCP> Date: Wed, 19-Aug-87 21:57:37 EDT Article-I.D.: ncoast.4220 Posted: Wed Aug 19 21:57:37 1987 Date-Received: Sat, 22-Aug-87 07:20:25 EDT Sender: allbery@ncoast.UUCP Organization: Zebb-Hoff Machine Tool Inc's Automated Mfg. Project, Cleve., OH Lines: 1474 Approved: allbery@ncoast.UUCP X-Archive: comp.sources.misc/8708/33 "Producer", A package to translate Smalltalk-80 code to your favorite object oriented language, Objective-C. #!/bin/sh # to extract, remove the header and type "sh filename" if `test ! -d ./src` then mkdir ./src echo "mkdir ./src" fi if `test ! -s ./src/Substrate.h` then echo "writting ./src/Substrate.h" cat > ./src/Substrate.h << '\Rogue\Monster\' /*{^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Substrate.h: Extensions to the Objective-C Primitive and Collection substrate The macros hide nonPortable `features' of some C compilers (e.g. VMS). ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}*/ #ifndef SUBSTRATE_H #define SUBSTRATE_H # include "objc.h" # include "assert.h" # undef CATEGORIES # define CATEGORIES() (Substrate, Primitive) /*{ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Stylistic Conventions The IMPORT/EXPORT convention (EXPORT int foo=aValue to export foo, IMPORT int foo to import it) is used instead of of the usual C conventions (int foo=aValue to export foo and extern int foo to import it) to provides a distinctive marker on each global declaration that string search tools key off of to find all global declarations reliably. The convention also provides a convenient way to overcome deficiencies in some C compilers; notably VMS C. ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ }*/ # define LOCAL static # define USE @requires #ifdef VMS # define IMPORT globalref # define EXPORT globaldef #else # define IMPORT extern # define EXPORT /*export*/ #endif // Obsolete # define FACTORY USE /*{ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Renaming Translate all occurrences of external names that appear in the Primitive or Collection categories to new names defined in the Substrate category. ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ }*/ #define OrderedCollection OrdCltn /*{ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Bit banging macros ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ }*/ # define RBIT(bits, mask) (bits &= ~mask) # define SBIT(bits, mask) (bits |= mask) # define TBIT(bits, mask) (bits & mask) typedef int *WORD; /* Amorphous typed machine word */ typedef unsigned int WRD; /* amorphous type; `word' */ typedef char BYTE; unsigned _strhash(); IMPORT void put(); #endif \Rogue\Monster\ else echo "will not over write ./src/Substrate.h" fi if `test ! -s ./src/AbstractTranslation.m` then echo "writting ./src/AbstractTranslation.m" cat > ./src/AbstractTranslation.m << '\Rogue\Monster\' #include "Producer.h" = AbstractTranslation : Object CATEGORIES() { id type; } + type:aType { return [[self new] type:aType]; } - type { return type; } - type:aType { type = aType; return self; } - (STR)str { return (STR)[self subclassResponsibility]; } - asTypedByteArray { return (id)[self subclassResponsibility]; } - assignTypesTo:aSelector { id s = [aSelector asByteArray]; info("%s ignoring type assignment of %s\n", NAMEOF(self), [s str]); [s free]; return self; } \Rogue\Monster\ else echo "will not over write ./src/AbstractTranslation.m" fi if `test ! -s ./src/ArgumentList.m` then echo "writting ./src/ArgumentList.m" cat > ./src/ArgumentList.m << '\Rogue\Monster\' #include "Producer.h" = ArgumentList:Node CATEGORIES() { id argumentType, argumentName; } + type:aType name:aName { self = [super new]; argumentType = aType; argumentName = aName; return self; } - argumentType { return argumentType; } - argumentName { return argumentName; } \Rogue\Monster\ else echo "will not over write ./src/ArgumentList.m" fi if `test ! -s ./src/Block.m` then echo "writting ./src/Block.m" cat > ./src/Block.m << '\Rogue\Monster\' #include "Producer.h" IMPORT id symbolScope; USE Set; = Block:Node CATEGORIES() { id blockVariables, statements; } + statements:aStatementList { return [[self new] statements:aStatementList]; } - variables:aVarList { if (!aVarList || [aVarList isEmpty]) return self; [aVarList addContentsTo:blockVariables = [Set new]]; [symbolScope add:blockVariables]; return self; } - statements:aStatementList { statements = aStatementList; return self; } - gen { BOOL needsCompound = blockVariables || [statements size] > 1; if (needsCompound) gc('{'/*}*/); #ifndef COXLIB [blockVariables elementsPerform:@selector(genDeclaration)]; #else [blockVariables eachElementPerform:@selector(genDeclaration)]; #endif [statements genExpr]; if (needsCompound) gc(/*{*/'}'); return self; } - free { [symbolScope remove:blockVariables]; [blockVariables freeContents]; [blockVariables free]; [statements free]; return [super free]; } - type { [statements type]; return types.BLOCK; } \Rogue\Monster\ else echo "will not over write ./src/Block.m" fi if `test ! -s ./src/CharConstant.m` then echo "writting ./src/CharConstant.m" cat > ./src/CharConstant.m << '\Rogue\Monster\' #include "Producer.h" = CharConstant : Constant CATEGORIES() {} - type { return types.CHAR; } - gen { gf("'%s'", [self str]); return self; } \Rogue\Monster\ else echo "will not over write ./src/CharConstant.m" fi if `test ! -s ./src/Class.m` then echo "writting ./src/Class.m" cat > ./src/Class.m << '\Rogue\Monster\' #include "Producer.h" BOOL autoFileFlag; USE OrderedCollection, Identifier; IMPORT id symbolScope; IMPORT STR index(); IMPORT id findSymbol(); = Class:Object CATEGORIES() { id name, superclass, instanceVariables, classVariables, pdn, category; id instanceVariableScope, classVariableScope; } + name:aClass { self = [super new]; name = aClass; if (autoFileFlag) { char buf[80]; sprintf(buf, "%s.m", [name str]); genOpen(buf); } return self; } - superclass:aClass { superclass = aClass; return self; } - instanceVariableNames:aString { STR s = [aString str], end; if (!instanceVariables) instanceVariables = [OrderedCollection new]; if (*s == '\'') s++; while(end = index(s, ' ')) { while(*end == ' ') *end++ = 0; [instanceVariables add:findSymbol([Identifier str:s])]; s = end; } if (end = index(s, '\'')) { *end = 0; [instanceVariables add:findSymbol([Identifier str:s])]; } [symbolScope add:instanceVariableScope=[instanceVariables asSet]]; return self; } - classVariableNames:aString { STR s = [aString str], end; if (!classVariables) classVariables = [OrderedCollection new]; if (*s == '\'') s++; while(end = index(s, ' ')) { while(*end == ' ') *end++ = 0; [classVariables add:findSymbol([Identifier str:s])]; s = end; } if (end = index(s, '\'')) { *end = 0; [instanceVariables add:findSymbol([Identifier str:s])]; } [symbolScope add:classVariableScope=[classVariables asSet]]; return self; } - poolDictionaries:aString { pdn = aString; return self; } - category:aString { category = aString; return self; } - gen { STR start, end, index(); gn(); gs("#include \"st80.h\"\n"); gs("= "); [name gen]; gc(':'); [superclass gen]; gs(" CATEGORIES()"); gc('{'/*}*/); #ifndef COXLIB [instanceVariables elementsPerform:@selector(genDeclaration)]; gc(/*{*/'}'); if (classVariables) [classVariables elementsPerform:@selector(genDeclaration)]; #else [instanceVariables eachElementPerform:@selector(genDeclaration)]; gc(/*{*/'}'); if (classVariables) [classVariables eachElementPerform:@selector(genDeclaration)]; #endif return self; } - free { [symbolScope remove:instanceVariableScope]; [symbolScope remove:classVariableScope]; [classVariables freeContents]; [instanceVariables freeContents]; [classVariables free]; [instanceVariables free]; [name free]; [superclass free]; [pdn free]; [category free]; return [super free]; } \Rogue\Monster\ else echo "will not over write ./src/Class.m" fi if `test ! -s ./src/Comment.m` then echo "writting ./src/Comment.m" cat > ./src/Comment.m << '\Rogue\Monster\' #include "Producer.h" static id head = nil, tail = nil; BOOL stripCommentsFlag = YES; = Comment:Node CATEGORIES() { STR text; } + str:(STR)aString { if (!aString) return nil; self = [super new]; text = (STR)strCopy(aString); if (head == nil) head = self; else tail->successor = self; return tail = self; } + gen { genReset(); [head gen]; [head free]; head = tail = nil; return self; } + free { if (head) [head free]; head = tail = nil; return self; } - (STR)str { return text; } - free { free(text); return [super free]; } - gen { if (!stripCommentsFlag) { gf("// %s", text); [successor gen]; } return self; } \Rogue\Monster\ else echo "will not over write ./src/Comment.m" fi if `test ! -s ./src/Constant.m` then echo "writting ./src/Constant.m" cat > ./src/Constant.m << '\Rogue\Monster\' #include "Producer.h" = Constant:Symbol CATEGORIES() - gen { gs([self str]); return self; } - type { return [self subclassResponsibility]; } - asByteArray { return self; } \Rogue\Monster\ else echo "will not over write ./src/Constant.m" fi if `test ! -s ./src/Expr.m` then echo "writting ./src/Expr.m" cat > ./src/Expr.m << '\Rogue\Monster\' // Expressions: a source (a message or primary) for a value and a list of // targets (variables) to assign values to. Cascaded message expressions // are handled by linking expressions through their successor fields. // // Rewrites cascaded expressions like // Foo new bar gag extent:hack; bletch. // as // cascadeReceiver = [[[Foo new] bar] gag]. // [cascadeReceiver extent:hack]; // [cascadeReceiver ... #include "Producer.h" IMPORT id temporaryVariablePool; USE Msg, List, Identifier; = Expr:Node CATEGORIES() { id assignmentList; id value; } + assign:anAssignmentList value:aValue { return [[[super new] assign:anAssignmentList] value:aValue]; } - assign:aList { assignmentList = aList; return self; } - value:aValue { if (value) info("value of %s reassigned\n", NAMEOF(self)); value = aValue; return self; } - value { return value; } - gen { if (assignmentList) { id s, v; for (s = [assignmentList eachElement]; v = [s next]; ) { [v gen]; gs(" = "); } [s free]; } [value gen]; if (successor) { gc(';'); [successor gen]; } return self; } - type { id type = [value type]; if (successor) [successor type]; #ifndef COXLIB if (assignmentList) [assignmentList elementsPerform:@selector(type:rule:) with:type with:"value assignment"]; #else if (assignmentList) [assignmentList eachElementPerform:@selector(type:rule:) with:type with:"value assignment"]; #endif return type; } - cascade:anExpr { id newReceiver = [Identifier uniqueIdentifier:"tmp"]; if ([value isKindOf:Msg]) { id newValue = [Msg receiver:newReceiver selector:[value selector]]; id newExpr = [Expr assign:assignmentList value:newValue]; value = [value receiver]; assignmentList = [List with:1, newReceiver]; [self successor:newExpr]; [newExpr successor:anExpr]; do { id msg = [newExpr value]; if ([msg isKindOf:Msg]) [msg receiver:newReceiver]; } while (newExpr = [newExpr successor]); } else { if (!assignmentList) assignmentList = [List new]; [assignmentList add:newReceiver]; [self successor:anExpr]; } [temporaryVariablePool add:newReceiver]; return self; } - free { [assignmentList free]; [value free]; return [super free]; } \Rogue\Monster\ else echo "will not over write ./src/Expr.m" fi if `test ! -s ./src/FunctionTranslation.m` then echo "writting ./src/FunctionTranslation.m" cat > ./src/FunctionTranslation.m << '\Rogue\Monster\' #include "Producer.h" = FunctionTranslation : AbstractTranslation CATEGORIES() { id functionName; id functionArgumentList; } + name:aFunctionName args:anArgumentList { self = [super new]; functionName = aFunctionName; functionArgumentList = anArgumentList; return self; } - genReceiver:aReceiver selector:aSelector { id arg; unsigned argNumber = 0; USE Msg; [functionName gen]; gc('('); for (arg = functionArgumentList; arg; arg = [arg successor]) { STR name = [arg str]; if (argNumber != 0) gc(','); if (*name == '%') { unsigned index = atoi(name+1); if (index == 0) [aReceiver gen]; else if (index >= [aSelector size]) wer("argument offset %d out of range", index); else [[[aSelector at:index-1] argument] gen]; } else if (argNumber == 0) [aReceiver gen]; else [[[aSelector at:argNumber-1] argument] gen]; argNumber++; } gc(')'); return self; } - (STR)str { return [functionName str]; } #define MAXARRAY 2048 - asTypedByteArray { char buf[MAXARRAY]; id arg; USE ByteArray; strcpy(buf, [functionName str]); for (arg = functionArgumentList; arg; arg = [arg successor]) { sprintf(buf+strlen(buf), "(%s)%s ", [[arg argumentType] str], [[arg argumentName] str]);; } return [ByteArray str:buf]; } \Rogue\Monster\ else echo "will not over write ./src/FunctionTranslation.m" fi if `test ! -s ./src/Identifier.m` then echo "writting ./src/Identifier.m" cat > ./src/Identifier.m << '\Rogue\Monster\' #include "Producer.h" USE Set, OrdCltn; IMPORT id identifierTranslator; = Identifier:ByteArray CATEGORIES() { id translation, type; } + name:aByteArray { return [self str:[aByteArray str]]; } + str:(STR)aString { self = [super str:aString]; type = types.UNKNOWN; translation = [identifierTranslator find:self]; return self; } + uniqueIdentifier:(STR)aString { static int uniqueness = 0; return [self sprintf:"%s%d", aString, uniqueness++]; } - gen { if (translation) [translation gen]; else gs([self str]); return self; } - genDeclaration { if (translation) [translation genDeclaration]; else { if (type == nil) gs(""); else [type gen]; gc(' '); gs([self str]); gc(';'); } return self; } - type { if (translation) return type = [translation type]; // dbg("%s: (%s)%s\n", NAMEOF(self), [type str], [self str]); // if (type == types.UNKNOWN) [self type:types.ID rule:"default: first use"]; return type; } - type:aType rule:(STR)aString { if (translation && type != aType) { info("attempt to change type of translated symbol %s ignored (%s)", [self str], aString); return self; } if (aType == nil) return [self error:"nil type"]; if (type != types.UNKNOWN && aType != type) { wer("%s %s; tried to change type from %s to %s ignored (%s)", NAMEOF(self), [self str], [type str], [aType str], aString); } else { info("type of %s is (%s) (%s)\n", [self str], [aType str], aString); type = aType; } return self; } - free { return nil; } =: \Rogue\Monster\ else echo "will not over write ./src/Identifier.m" fi if `test ! -s ./src/IdentifierTranslation.m` then echo "writting ./src/IdentifierTranslation.m" cat > ./src/IdentifierTranslation.m << '\Rogue\Monster\' // type inferencing template #include "Producer.h" #include "assert.h" USE Set, IntArray, Msg; IMPORT id identifierTranslator, globalSymbols; = IdentifierTranslation:ByteArray CATEGORIES() { id type, targetIdentifier; } + sourceName:sourceIdentifier targetType:aType targetName:anIdentifier { id result; self = [super str:[sourceIdentifier str]]; [sourceIdentifier free]; targetIdentifier = anIdentifier; if (aType == 0 || aType == types.UNKNOWN) type = types.ID; else type = aType; [targetIdentifier type:type rule:"explicit rule"]; #ifndef COXLIB if ([identifierTranslator addNTest:self]) result = self; else result = [identifierTranslator find:self]; #else result = [identifierTranslator add:self]; #endif if (result && result != self && result->type != type) { dbg("result=%x result->type=%x\n", result, result->type); wer("incompatible translations for identifier %s. Using %s, ignoring %s", [self str], [type str], [result->type str]); } [globalSymbols add:self]; return self; } - type { return type; } - type:aType rule:(STR)aString { info("IdentifierTranslation %s ignored type change from %s to %s", [self str], [type str], [aType str]); return self; } - gen { gs([targetIdentifier str]); return self; } - genDeclaration { [type gen]; gc(' '); gs([targetIdentifier str]); gc(';'); return self; } - targetIdentifier { return targetIdentifier; } - free { return nil; } - asTypedByteArray { return [ByteArray sprintf:"(%s)%s", [type str], [self str]]; } =: \Rogue\Monster\ else echo "will not over write ./src/IdentifierTranslation.m" fi if `test ! -s ./src/List.m` then echo "writting ./src/List.m" cat > ./src/List.m << '\Rogue\Monster\' #include "Producer.h" = List:OrdCltn CATEGORIES() #ifndef COXLIB - gen { [self elementsPerform:_cmd]; return self; } #else - gen { [self eachElementPerform:_cmd]; return self; } #endif \Rogue\Monster\ else echo "will not over write ./src/List.m" fi if `test ! -s ./src/METHODDECLS.m` then echo "writting ./src/METHODDECLS.m" cat > ./src/METHODDECLS.m << '\Rogue\Monster\' #include "Producer.h" = METHODDECLS:Object CATEGORIES() {} - (BOOL)isEmpty {;} - (BOOL)isEqual:aStr {;} - (BOOL)isEqualSTR:(STR)aStr {;} - (BOOL)isUnary {;} - (STR)str {;} - (unsigned)hash {;} - (unsigned)size {;} - add:aLink {;} - argument {;} - argument:anArgument {;} - argumentType {;} - array:anArray {;} - asByteArray {;} - assign:aList {;} - assign:anAssignmentList value:aValue {;} - at:(unsigned)anInt {;} - cascade:anExpr {;} - category:aString {;} - classVariableNames:aString {;} - comment:aString {;} - elementsPerform:(SEL)aSelector with:arg1 with:arg2 {;} - elementsPerform:(SEL)aSelector with:arg1 {;} - elementsPerform:(SEL)aSelector {;} - eachElementPerform:(SEL)aSelector with:arg1 with:arg2 {;} - eachElementPerform:(SEL)aSelector with:arg1 {;} - eachElementPerform:(SEL)aSelector {;} - expr {;} - expr:anExpr {;} - free {;} - freeContents {;} - gen {;} - genDeclaration {;} - genExpr {;} - genPrivate {;} - genReceiver:aReceiver selector:aSelector {;} - initialize {;} - insert:aLink {;} - install:aTemplate translation:aTranslation {;} - instanceVariableNames:aString {;} - lastElement {;} - name:aByteArray {;} - name:aFunctionName args:anArgumentList {;} - name:aString argument:anArgument {;} - poolDictionaries:aString {;} - predecessorOf:aLink {;} - primitive:aToken {;} - receiver {;} - receiver:anObject selector:aSelector {;} - receiver:anObject {;} - receiverType {;} - receiverType:aType selector:aSelector {;} - remove:aLink {;} - selector {;} - selector:aSelector asFactory:(BOOL)isFactoryMethod {;} - selector:aSelector {;} - sourceName:sourceIdentifier targetType:aType targetName:anIdentifier {;} - statements:aStatementList {;} - str:(STR)aString {;} - successor {;} - successor:aLink {;} - superclass:aClass {;} - template:aTemplate translation:aTranslation {;} - translation {;} - translation:aTranslation {;} - translationFor:aMsg {;} - type {;} - type:aType name:aName {;} - type:aType rule:(STR)aString {;} - type:aType translation:aByteArray {;} - type:aType {;} - uniqueIdentifier:(STR)aString {;} - value {;} - value:aValue {;} - variables:aVarList {;} \Rogue\Monster\ else echo "will not over write ./src/METHODDECLS.m" fi if `test ! -s ./src/Method.m` then echo "writting ./src/Method.m" cat > ./src/Method.m << '\Rogue\Monster\' #include "Producer.h" IMPORT id symbolScope; USE Set, Identifier; EXPORT id temporaryVariablePool = nil; = Method:Object CATEGORIES() { id selector, comment, primitive, statements; id argumentVariables, localVariables; id type, concatenatedSelector; BOOL isFactory; id translation; } + selector:aSelector asFactory:(BOOL)aBoolean { id sel, arg; self = [super new]; selector = aSelector; isFactory = aBoolean; concatenatedSelector = [aSelector asByteArray]; argumentVariables = [Set new]; type = types.UNKNOWN; [argumentVariables add:[[Identifier str:"self"] type:types.ID rule:"hardwired"]]; for (sel = aSelector; sel && (arg = [sel argument]); sel = [sel successor]) [argumentVariables add:arg]; [symbolScope add:argumentVariables]; temporaryVariablePool = localVariables = [Set new]; return self; } - receiverType { return types.ID; } - comment:aString { comment = aString; return self; } - variables:aVarList { [aVarList addContentsTo:localVariables]; [symbolScope add:localVariables]; return self; } - selector { return selector; } - statements:aStmtList { statements = aStmtList; return self; } - primitive:aToken { primitive = aToken; return self; } - gen { USE Return; dbg("//=======================Method gen==================================\n"); [self type]; // this triggers the type inferencing machinery dbg("//-----------------------Method gen----------------------------------\n"); gn(); gc(isFactory ? '+' : '-'); gc(' '); if (type != types.ID) { gc('('); [type gen]; gc(')'); } [selector genDeclaration]; gs(" {"); #ifndef COXLIB [localVariables elementsPerform:@selector(genDeclaration)]; #else [localVariables eachElementPerform:@selector(genDeclaration)]; #endif [primitive gen]; [statements gen]; if (![[statements lastElement] isKindOf:Return]) gs("return self;"); gc('}'); return self; } - type { IMPORT id msgTranslator; id t; STR failReason = "name not found"; id key, sourceStr, msgTranslation, stmt, s; if (translation) return [translation type]; [statements type]; [selector type]; key = [selector asByteArray]; sourceStr = [selector asTypedByteArray]; if (msgTranslation = [msgTranslator find:key]) { unsigned i, n; dbg("translation for method %s\n", [sourceStr str]); if (![selector isUnary]) { id s; for (s = selector; s; s = [s successor]) { id st = [s type]; if (st == types.UNKNOWN) [s type:types.ID rule:"method arg"]; } } for (n = [msgTranslation size], i = 0; i < n; i++) { id s, p, targetPattern = [msgTranslation at:i], targetStr; failReason = "types didn't match"; if (![selector isUnary]) { unsigned offset = 1; for (s = selector; s; s = [s successor]) { id rt = [s type], pt = [targetPattern at:offset++]; dbg(" actualArgType=%s patternArgType=%s\n", [rt str], [pt str]); if ((pt != types.ANY) && (rt != pt)) goto tryAgain; // break out to try next pattern } } translation = [targetPattern translation]; type = [translation type]; targetStr = [translation asTypedByteArray]; info("method %s translated to (%s)%s (type match)\n", [sourceStr str], [type str], [targetStr str]); [targetStr free]; [translation assignTypesTo:selector]; goto succeed; tryAgain:; } } info("method %s translated literally (%s)\n", [sourceStr str], failReason); succeed: if (!type) { for (stmt = statements; stmt; stmt = [stmt successor]) { if ([stmt isKindOf:Return]) [self type:[stmt type] rule:"used type from return stmt"]; } } if (type == types.UNKNOWN) [self type:types.ID rule:"default method type"]; [key free]; [sourceStr free]; return type; } - type:aType rule:(STR)aString { if (aType == nil) return [self error:"nil type"]; if (type != types.UNKNOWN && aType != type) { wer("attempt to change type of method %s from %s to %s ignored (%s)", [self str], [type str], [aType str], aString); } else { id s = [selector asByteArray]; info("type of method %s set to (%s) (%s)\n", [s str], [aType str], aString); [s free]; type = aType; } return self; } - free { [symbolScope remove:argumentVariables]; [symbolScope remove:localVariables]; [primitive free]; [selector free]; [comment free]; [argumentVariables freeContents]; [argumentVariables free]; [localVariables freeContents]; [localVariables free]; [concatenatedSelector free]; [statements free]; return [super free]; } =: \Rogue\Monster\ else echo "will not over write ./src/Method.m" fi if `test ! -s ./src/Msg.m` then echo "writting ./src/Msg.m" cat > ./src/Msg.m << '\Rogue\Monster\' #include "Producer.h" = Msg:Object CATEGORIES() { id receiver; id selector; id translation; } IMPORT id msgTranslator; USE Template; + receiver:anObject { return [[self new] receiver:anObject]; } + receiver:anObject selector:aSelector { return [[[self new] receiver:anObject] selector:aSelector]; } + selector:aSelector { return [[self new] selector:aSelector]; } - receiver { return receiver; } - receiverType { return [receiver type]; } - receiver:anObject { receiver = anObject; return self; } - selector { return selector; } - selector:aSelector { selector = aSelector; return self; } - free { [receiver free]; [selector free]; return [super free]; } // ByteArray Emulation - (STR)str { return [selector str]; } - (unsigned)hash { return _strhash([self str]); } - (BOOL)isEqual:aStr { return strcmp([self str], [aStr str]) == 0; } - (BOOL)isEqualSTR:(STR)aStr { return strcmp([self str], aStr) == 0; } - type { id type; if (!translation) { unsigned i, n; STR failReason = 0; id s, key = [selector asByteArray]; id msgTranslation, receiverType = [receiver type]; id sourceStr = [selector asTypedByteArray]; dbg("translating message [(%s) %s]\n", [[receiver type] str], [sourceStr str]); if (![selector isUnary]) { for (s = selector; s; s = [s successor]) { id st = [s argumentType]; if (st == types.UNKNOWN) [s type:types.ID rule:"msg arg"]; } } if (msgTranslation = [msgTranslator find:key]) { for (n = [msgTranslation size], i = 0; i < n; i++) { unsigned offset = 0; id s, targetStr; id targetPattern = [msgTranslation at:i]; id patternReceiverType = [targetPattern at:offset++]; dbg(" actualReceiverType=%s patternReceiver=%s\n", [receiverType str], [patternReceiverType str]); failReason = "receiver types didn't match"; if (patternReceiverType == types.ANY || patternReceiverType == receiverType) { if (![selector isUnary]) { // if not unary selector failReason = "argument types didn't match"; for (s = selector; s; s = [s successor]) { id rt = [s type], pt = [targetPattern at:offset++]; dbg(" actualArgType=%s patternArgType=%s\n", [rt str], [pt str]); if ((pt != types.ANY) && (rt != pt)) goto fail; // break out to try next pattern } } translation = [targetPattern translation]; targetStr = [translation asTypedByteArray]; info("message [(%s)%s] translated to (%s)%s (type match)\n", [receiverType str], [sourceStr str], [[translation type] str], [targetStr str]); [targetStr free]; goto succeed; } fail:; } } else failReason = "name not found"; info("message [(%s)%s] translated literally (%s)\n", [receiverType str], [sourceStr str], failReason); succeed: [key free]; [sourceStr free]; if ([receiver type] == types.UNKNOWN) [receiver type:types.ID rule:"message receiver"]; } type = translation ? [translation type] : types.ID; return type == types.UNKNOWN ? types.ID : type; } - gen { if (translation) [translation genReceiver:receiver selector:selector]; else { gc('['); [receiver gen]; gc(' '); [selector gen]; gc(']'); } return self; } =: \Rogue\Monster\ else echo "will not over write ./src/Msg.m" fi if `test ! -s ./src/MsgArgPattern.m` then echo "writting ./src/MsgArgPattern.m" cat > ./src/MsgArgPattern.m << '\Rogue\Monster\' #include "Producer.h" = MsgArgPattern : IdArray CATEGORIES() { id translation; } + template:aTemplate translation:aTranslation { id s; unsigned i = 0; self = [self new:[aTemplate size]+1]; [self at:i++ put:[aTemplate receiverType]]; for (s = [aTemplate selector]; s; s = [s successor]) { id t = [s type]; if (t == 0 || t == types.UNKNOWN) t = types.ANY; [self at:i++ put:t]; } return [self translation:aTranslation]; } - type { return [translation type]; } - translation:aTranslation { translation = aTranslation; return self; } - translation { return translation; } \Rogue\Monster\ else echo "will not over write ./src/MsgArgPattern.m" fi if `test ! -s ./src/MsgNamePattern.m` then echo "writting ./src/MsgNamePattern.m" cat > ./src/MsgNamePattern.m << '\Rogue\Monster\' // Each message may have several translations depending on the type of // the receiver and the message's arguments. MsgNamePattern holds the // name of the message (concatenated selector in selectorByteArray) // and an ordered collection of MsgArgPatterns. These are IdArrays // holding the type of the receiver followed by the types of the arguments. // Each MsgArgPattern also holds the translation for the messages that // match in name and argument type. #include "Producer.h" = MsgNamePattern : OrdCltn CATEGORIES() { id selectorByteArray; } + name:aByteArray { self = [super new]; selectorByteArray = aByteArray; return self; } - (unsigned)hash { return [selectorByteArray hash]; } - (BOOL)isEqual:aMsgNamePattern { return [selectorByteArray isEqual:aMsgNamePattern]; } - (STR)str { return [selectorByteArray str]; } \Rogue\Monster\ else echo "will not over write ./src/MsgNamePattern.m" fi if `test ! -s ./src/MsgTranslation.m` then echo "writting ./src/MsgTranslation.m" cat > ./src/MsgTranslation.m << '\Rogue\Monster\' #include "Producer.h" = MsgTranslation : AbstractTranslation CATEGORIES() { id receiverType, selector; } + receiverType:aType selector:aSelector { self = [super type:types.ID]; receiverType = aType ? aType : types.ANY; selector = aSelector; return self; } - selector { return selector; } - receiverType { return receiverType; } - (STR)str { return [selector str]; } - genReceiver:aReceiver selector:aSelector { USE Msg; unsigned argNumber = 0; id sel; gc('['); [aReceiver gen]; for (sel = selector; sel; sel = [sel successor], argNumber++) { STR name = [sel str]; gc(' '); if (*name == '%') { unsigned index = atoi(&name[1]); if (index == 0) wer("%%0 not allowed in MsgPattern rules"); else if (index >= [aSelector size]) { wer("argument offset %d out of range", index); } else { gs([[selector at:index-1] str]); [[[aSelector at:index-1] argument] gen]; } } else { gs([[selector at:argNumber] str]); [[[aSelector at:argNumber] argument] gen]; } } gc(']'); return self; } - asTypedByteArray { return [selector asTypedByteArray]; } - free { return nil; } - assignTypesTo:aSelector { id s = aSelector, p = [self selector]; while(s && p) { [s type:[p type]]; s = [s successor]; p = [p successor]; } return self; } \Rogue\Monster\ else echo "will not over write ./src/MsgTranslation.m" fi if `test ! -s ./src/MsgTranslator.m` then echo "writting ./src/MsgTranslator.m" cat > ./src/MsgTranslator.m << '\Rogue\Monster\' // MsgTranslator: a set of MsgNamePatterns. These hold a string (the // concatenated selector characters) and a collection of MsgArgPatterns // describing one of the types (for receiver and arguments) for which // a translation is known #include "Producer.h" EXPORT id msgTranslator = nil; USE MsgNamePattern, MsgArgPattern, Msg; = MsgTranslator : Set CATEGORIES() + initialize { if (!msgTranslator) msgTranslator = [self new]; return self; } - install:aTemplate translation:aTranslation { id name = [[aTemplate selector] asByteArray]; id msgNamePattern = [self find:name]; if (msgNamePattern) [name free]; else [self add:msgNamePattern=[MsgNamePattern name:name]]; [msgNamePattern add:[MsgArgPattern template:aTemplate translation:aTranslation]]; return self; } \Rogue\Monster\ else echo "will not over write ./src/MsgTranslator.m" fi if `test ! -s ./src/Node.m` then echo "writting ./src/Node.m" cat > ./src/Node.m << '\Rogue\Monster\' #include "Producer.h" = Node:Object CATEGORIES() { id successor; } - successor { return successor; } - successor:aLink { id me = successor; successor = aLink; return me; } - lastElement { while(successor) self = successor; return self; } // Reply the predecessor of the indicated link. - predecessorOf:aLink { do { if (successor == aLink) return self; } while (self = successor); return nil; } // Reply the n'th link in this chain. - at:(unsigned)anInt { register unsigned i = anInt; register id obj = self; while (i-- && obj) obj = obj->successor; return obj ? obj : [self error:"range error: %d", anInt]; } // Append another instance to this chain. - add:aLink { id me = self; while (successor) self = successor; successor = aLink; return me; } // Free this link and all successors - freeContents { register id next; do { next = successor; [super free]; } while (self = next); } // remove - remove:aLink { self =[self predecessorOf:aLink]; if (self == nil) return nil; successor= [ aLink successor]; return aLink; } // insert - insert:aLink { [ aLink successor:successor]; successor= aLink; return self; } - gen { [self show]; [successor show]; return self; } - free { [successor free]; return [super free]; } // Reply the number of linked instances #ifdef OBSOLETE - (unsigned)size { register unsigned n = 1; while(self = successor) n++; return n; } #endif - (unsigned)size { unsigned i; for (i=1; self = successor; i++); return i; } #ifndef COXLIB - elementsPerform:(SEL)aSelector { do { [self perform:aSelector]; } while (self = successor); return self; } - elementsPerform:(SEL)aSelector with:arg1 { do { [self perform:aSelector with:arg1]; } while (self = successor); return self; } - elementsPerform:(SEL)aSelector with:arg1 with:arg2 { do { [self perform:aSelector with:arg1 with:arg2]; } while (self = successor); return self; } #else - eachElementPerform:(SEL)aSelector { do { [self perform:aSelector]; } while (self = successor); return self; } - eachElementPerform:(SEL)aSelector with:arg1 { do { [self perform:aSelector with:arg1]; } while (self = successor); return self; } - eachElementPerform:(SEL)aSelector with:arg1 with:arg2 { do { [self perform:aSelector with:arg1 with:arg2]; } while (self = successor); return self; } #endif =: \Rogue\Monster\ else echo "will not over write ./src/Node.m" fi if `test ! -s ./src/Scope.m` then echo "writting ./src/Scope.m" cat > ./src/Scope.m << '\Rogue\Monster\' // Symbol scoping // A scope is an ordered collection Sets of identifiers #include "Producer.h" USE Set, IntArray, Msg; EXPORT id symbolScope = nil, undefinedSymbols = nil, globalSymbols = nil, identifierTranslator = nil; = Scope:OrderedCollection CATEGORIES() + initialize { if (!symbolScope) { symbolScope = [self new]; undefinedSymbols = [Set new]; globalSymbols = [Set new]; [symbolScope add:globalSymbols]; [symbolScope add:undefinedSymbols]; identifierTranslator = [Set new]; } return self; } =: id findSymbol(aVariable) id aVariable; { int i, n = [symbolScope size]; for (i = n-1; i >= 0; i--) { id hit; if (hit = [[symbolScope at:i] find:aVariable]) return hit; } info("undefined %s %s\n", NAMEOF(aVariable), [aVariable str]); [undefinedSymbols add:aVariable]; return aVariable; } \Rogue\Monster\ else echo "will not over write ./src/Scope.m" fi if `test ! -s ./src/NumberConstant.m` then echo "writting ./src/NumberConstant.m" cat > ./src/NumberConstant.m << '\Rogue\Monster\' #include "Producer.h" = NumberConstant : Constant CATEGORIES() {} - gen { gs([self str]); return self; } + str:(STR)aString { return [super str:aString]; } - type { return index([self str], '.') ? types.FLOAT : types.INT; } \Rogue\Monster\ else echo "will not over write ./src/NumberConstant.m" fi if `test ! -s ./src/Return.m` then echo "writting ./src/Return.m" cat > ./src/Return.m << '\Rogue\Monster\' #include "Producer.h" = Return:Node CATEGORIES() { id body; } + expr:anExpr { self = [super new]; body = anExpr; return self; } - gen { [self genExpr]; gc(';'); return self; } - genExpr { gs("return "); [body gen]; return self; } - free { [body free]; return [super free]; } - type { return [body type]; } \Rogue\Monster\ else echo "will not over write ./src/Return.m" fi if `test ! -s ./src/Selector.m` then echo "writting ./src/Selector.m" cat > ./src/Selector.m << '\Rogue\Monster\' #include "Producer.h" #define strEq(p, q) (strcmp(p, q) == 0) #define strHas(s, c) (index(s, c) != 0) #define MAXSELECTOR 512 STR strCopy(), xlate(); USE ByteArray, IdArray; = Selector:Node CATEGORIES() { STR name; id argument; } + name:aString argument:anArgument { return [[self name:aString] argument:anArgument]; } + name:aString { return [self str:[aString str]]; } + str:(STR)aString { self = [super new]; name = strCopy(aString); if (strlen(name) < 1) return [self error:"nil selector"]; return self; } // Inherited deepCopy seems to not copy the name argument correctly - deepCopy { id t = [[isa str:name] argument:argument]; [t successor:[successor deepCopy]]; return t; } - (BOOL)isUnary { return argument == nil; } - asByteArray { char strBuf[MAXSELECTOR]; strBuf[0] = 0; do { strcat(strBuf, name); } while (self = successor); return [ByteArray str:strBuf]; } - asTypeArray { id typeArray; if ([self isUnary]) typeArray = [IdArray new:0]; else { typeArray = [IdArray new:[self size]]; do { [typeArray add:[argument type]]; } while (self = successor); } return typeArray; } - asTypedByteArray { char strBuf[MAXSELECTOR]; strBuf[0] = 0; do { strcat(strBuf, name); if (argument) sprintf(strBuf+strlen(strBuf), "(%s) ", [[argument type] str]);; } while (self = successor); return [ByteArray str:strBuf]; } // ByteArray emulation - (STR)str { return name; } - (unsigned)hash { return _strhash(name); } - (BOOL)isEqual:anObject { return self == anObject || strcmp(name, [anObject str]) == 0; } - (BOOL)isEqualSTR:(STR)aStr { return strcmp(name, aStr) == 0; } - type { if (successor) [successor type]; return [argument type]; } - type:aType { return [self type:aType rule:"force"]; } - type:aType rule:(STR)aString { [argument type:aType rule:aString]; return self; } - argument:anArgument { argument = anArgument; return self; } - argument { return argument; } - argumentType { return [argument type]; } - free { free(name); [argument free]; return [super free]; } - gen { gs(xlate(name)); [argument gen]; if (successor) { gc(' '); [successor gen]; } return self; } - genDeclaration { gs(xlate(name)); if (argument && [argument type] != types.ID) { gc('('); gs([[argument type] str]); gc(')'); } [argument gen]; if (successor) { gc(' '); [successor genDeclaration]; } return self; } =: // Translate Smalltalk binary selectors to Objective-C keyword static STR xlate(s) STR s; { static STR binarySelectorTbl= // parallel arrays! "+-/\\*~<>=@%&?!,|", objcSelectorStrings[]= { "plus", "minus", "slash", "backslash", "times", "tilde", "lesser", "greater", "equals", "point", "percent", "ampersand", "question", "bang", "comma", "or", "/*@*/", 0}; STR i, index(); static char buf[MAXSELECTOR]; *buf = 0; if (i = index(binarySelectorTbl, s[0])) { strcat(buf, objcSelectorStrings[i-binarySelectorTbl]); if (s[1]) { if (i = index(binarySelectorTbl, s[1])) strcat(buf, objcSelectorStrings[i-binarySelectorTbl]); else wer("bad char in binary selector <%c>", s[1]); if (s[2]) wer("binary selector more than 2 chars long <%s>", s); } strcat(buf, ":"); return buf; } return s; } \Rogue\Monster\ else echo "will not over write ./src/Selector.m" fi if `test ! -s ./src/SelectorConstant.m` then echo "writting ./src/SelectorConstant.m" cat > ./src/SelectorConstant.m << '\Rogue\Monster\' #include "Producer.h" = SelectorConstant : Constant CATEGORIES() {} - type { return types.SELECTOR; } - gen { id t = types.SELECTOR; dbg("%s: (%s)%s\n", NAMEOF(self), [t str], [self str]); gs("@selector("); [super gen]; gc(')'); return self; } =: \Rogue\Monster\ else echo "will not over write ./src/SelectorConstant.m" fi if `test ! -s ./src/StArray.m` then echo "writting ./src/StArray.m" cat > ./src/StArray.m << '\Rogue\Monster\' #include "Producer.h" = StArray:OrdCltn CATEGORIES() { id type; } - gen { id s, m; gs("={"); for (s = [self eachElement]; m = [s next]; ) { [m gen]; gs(", "); } [s free]; gc('}'); return self; } - type { id s, m; if (type) return type; if ([self isEmpty]) return types.ID; type = [[self firstElement] type]; for (s = [self eachElement]; m = [s next]; ) if ([m type] != type) wer("this array holds diverse types"); [s free]; return type; } \Rogue\Monster\ else echo "will not over write ./src/StArray.m" fi if `test ! -s ./src/Stmt.m` then echo "writting ./src/Stmt.m" cat > ./src/Stmt.m << '\Rogue\Monster\' #include "Producer.h" = Stmt:Node CATEGORIES() { id expr, type; } + expr:anExpr { self = [super new]; expr = anExpr; return self; } - expr { return expr; } - free { [expr free]; return [super free]; } - gen { [expr gen]; if (type != types.STMT) gc(';'); [successor gen]; return self; } - genExpr { [expr gen]; if (successor) { if (type != types.STMT) gc(';'); [successor gen]; } return self; } - type { if (type) return type; type = [expr type]; [successor type]; return type; } \Rogue\Monster\ else echo "will not over write ./src/Stmt.m" fi if `test ! -s ./src/StringConstant.m` then echo "writting ./src/StringConstant.m" cat > ./src/StringConstant.m << '\Rogue\Monster\' #include "Producer.h" = StringConstant : Constant CATEGORIES() {} + str:(STR)aString { STR rindex(), p; if (*aString == '\'' && (p = rindex(aString, '\''))) { char c = *p; *p = 0; self = [super str:aString+1]; *p = c; return self; } else return [super str:aString]; } - type { id t = types.CSTRING; return t; } - gen { gc('"'); [super gen]; gc('"'); return self; } =: \Rogue\Monster\ else echo "will not over write ./src/StringConstant.m" fi if `test ! -s ./src/StringTranslation.m` then echo "writting ./src/StringTranslation.m" cat > ./src/StringTranslation.m << '\Rogue\Monster\' // Translate message to string #include "Producer.h" #include "ctype.h" = StringTranslation:AbstractTranslation CATEGORIES() { id translation; } + type:aType translation:aByteArray { return [[self type:aType] translation:aByteArray]; } - translation:aByteArray { translation = aByteArray; return self; } - (STR)str { return [translation str]; } - genReceiver:aReceiver selector:aSelector { STR rindex(), q, p; p = [translation str]; for (; *p; p++) { if (*p == '\\') { gc(*p++); gc(*p); continue; } else if (*p == '%') { unsigned index = atoi(++p); if (index == 0) [aReceiver gen]; else if (--index >= [aSelector size]) wer("bad rule", index+1); else [[[aSelector at:index] argument] gen]; while (isdigit(*p)) p++; p--; } else if (*p == '\n') { while(isspace(*p)) p++; p--; } else gc(*p); } return self; } - asTypedByteArray { return [translation asByteArray]; } =: static verifyArgCount(targetString, sourcePattern) STR targetString; id sourcePattern; { STR p; for (p = targetString; *p; p++) { if (*p == '\\') { *p++; continue; } else if (*p == '%') { unsigned index = atoi(++p); if (index != 0 && --index >= [sourcePattern size]) wer("no such argument"); while (isdigit(*p)) p++; p--; } } } \Rogue\Monster\ else echo "will not over write ./src/StringTranslation.m" fi if `test ! -s ./src/Template.m` then echo "writting ./src/Template.m" cat > ./src/Template.m << '\Rogue\Monster\' #include "Producer.h" #define MAXSELECTOR 5000 = Template : ByteArray CATEGORIES() { id receiverType, selector; } + receiverType:aType selector:aSelector { char strBuf[MAXSELECTOR]; id s = aSelector; strBuf[0] = 0; for (s = aSelector; s; s = [s successor]) strcat(strBuf, [s str]); self = [super str:strBuf]; receiverType = aType; selector = aSelector; return self; } - receiverType { return receiverType; } - selector { return selector; } \Rogue\Monster\ else echo "will not over write ./src/Template.m" fi echo "Finished archive 4 of 5" exit ---- Dieter H. Zebbedies ('dee-ter ayech 'zeb-ed-eez) Zebb-Hoff Mach. Tool's Automated Manufacturing Project Cleveland, OH (USnail): 9535 Clinton Rd, Cleveland, OH 44144 (+216 631 6100) (+216 741-5994) (UUCP): ...{decvax,sun,cbosgd}!cwruecmp!zhmti!dieter (CSNET/ARPA/BITNET): dieter@CWRU.EDU