Subject: v13i054: New release of little smalltalk, Part02/05 Newsgroups: comp.sources.unix Sender: sources Approved: rsalz@uunet.UU.NET Submitted-by: Tim Budd Posting-number: Volume 13, Issue 54 Archive-name: little-st2/part02 #!/bin/sh # # # This is version 2.02 of Little Smalltalk, distributed in five parts. # # This version is dated 12/25/87 # # Several bugs and many features and improvements have been made since the # first posting to comp.src.unix. See the file ``todo'' for a partial list. # # Comments, bug reports, and the like should be submitted to: # Tim Budd # Smalltalk Distribution # Department of Computer Science # Oregon State University # Corvallis, Oregon # 97330 # # budd@cs.orst.edu # {hp-pcd, tektronix}!orstcs!budd # # echo 'Start of small.v2, part 02 of 05:' echo 'x - explore.ms' sed 's/^X//' > explore.ms << '/' X.SH XExploring and Creating X.PP XThis document describes how to discover information about existing objects Xand create new objects using the Unix interface to the Little Smalltalk Xsystem (version two). The Little Smalltalk system running Xunder different operating Xsystems may have a slightly different interface, and the reader should be Xforewarned. X.PP XWhen you start version two Little Smalltalk under Unix, you will be given a Xprompt. XYou can enter expressions in response to the prompt, and the system will Xevaluate them (although it will not print the result unless you request Xit\s-2\u*\d\s+2). X.FS X* Note that this is a change from version one of Little Smalltalk, where Xexpressions were automatically printed. XThe reason has to do with now expressions are compiled and executed Xnow, using more Smalltalk code, and less C code. X.FE X.DS I X> (5 + 7) print X12 X> X.DE XIn Smalltalk one communicates with objects by passing messages to them. XEven the addition sign shown above is treated as a message passed to the Xobject 5, with argument 7. Other messages can be used to discover Xinformation about various objects. XThe most basic fact you can discover about an object is its class. XThis is given by the message \fBclass\fP, as in the following examples: X.DS I X> 7 class print XInteger X> nil class print XUndefinedObject X.DE X.PP XOccasionally, especially when programming, one would like to ask whether Xthe class of an object matches some known class. One way to do this would Xbe to use the message \fB=\!=\fP, which tells whether two expressions Xrepresent the same object: X.DS I X> ( 7 class =\!= Integer) print XTrue X> nil class == Object ; print XFalse X.DE X.LP X(Notice that second example uses cascades in place of parenthesis. XThe only difference between these two is that in the first example the Xresult of the expression is the value returned by the print, whereas in the Xsecond the result of the expression is the value returned by =\!=. But Xsince in any case the value is thrown away, it makes no difference.) X.PP XAn easier way is to use the message \fBisMemberOf:\fP; X.DS I X> 7 isMemberOf: Integer ; print XTrue X> nil isMemberOf: Integer ; print XFalse X.DE X.PP XSometimes you want to know if an object is an instance of a particular Xclass or one if its subclasses; in this case the appropriate message is X\fBisKindOf:\fP. X.DS I X> 7 isMemberOf: Number ; print XFalse X> 7 isKindOf: Number ; print XTrue X.DE X.PP XAll objects will respond to the message \fBdisplay\fP by telling a little Xabout themselves. Many just give their class and their printable Xrepresentation: X.DS I X> 7 display X(Class Integer) 7 X> nil display X(Class UndefinedObject) nil X.DE X.LP XOthers, such as classes, are a little more verbose: X.DS I X> Integer display XClass Name: Integer XSuperClass: Number XInstance Variables: Xno instance variables XSubclasses: X.DE X.LP XThe display shows that the class \fBInteger\fP is a subclass of class X\fBNumber\fP (that is, class \fBNumber\fP is the superclass of X\fBInteger\fP). There are no instance variables for this class, and it Xcurrently has no subclasses. XAll of this information could be obtained by means of other messages, Xalthough the \fBdisplay\fP form is the easiest. X.DS I X> List variables display Xlinks X> Integer superClass print XNumber X> Collection subClasses display XIndexedCollection XInterval XList X.DE XAbout the only bit of information that is not provided when one passes the Xmessage \fBdisplay\fP to a class Xis a list of methods the class responds to. There are two Xreasons for this omission; the first is that this list can often be quite Xlong, and we don't want to scroll the other information off the screen Xbefore the user has seen it. The second reason is that there are really Xtwo different questions the user could be asking. The first is what Xmethods are actually implemented in a given class. A dictionary containing Xthe set of methods implemented in a class can be found by passing the Xmessage \fBmethods\fP to a class. Since we are only interested in the set Xof keys for this dictionary (that is, the message selectors), we can use Xthe message \fBkeys\fP. Finally, as we saw with the message X\fBsubClasses\fP shown above, our old friend \fBdisplay\fP prints this Xinformation out one method to a line: X.DS I X> True methods keys display X#ifTrue:ifFalse: X#not X.DE X.PP XA second question that one could ask is what message selectors an instance of a Xgiven class will respond to, whether they are inherited from superclasses Xor are defined in the given class. This set is given in response to the Xmessage \fBrespondsTo\fP. X.DS I X> True respondsTo display X#class X#== X#hash X#isNil X#display X#= X#basicSize X#isMemberOf: X#notNil X#print X#basicAt:put: X#isKindOf: X#basicAt: X#printString X#or: X#and: X#ifFalse:ifTrue: X#ifTrue: X#ifFalse: X#not X#ifTrue:ifFalse: X.DE X.PP XAlternatively, one can ask whether instances of a given class will respond Xto a specific message by writing the message selector as a symbol: X.DS I X> ( String respondsTo: #print ) print XTrue X> String respondsTo: #+ ; print XFalse X.DE X.PP XThe inverse of this would be to ask what classes contain methods for a Xgiven message selector. Class \fBSymbol\fP defines a method to yield just Xthis information: X.DS I X> #+ respondsTo display XInteger XNumber XFloat X.DE X.PP XThe method that will be executed in response to a given message selector Xcan be displayed by means of the message \fBviewMethod:\fP X.DS I X> Integer viewMethod: #gcd: Xgcd: value X (value = 0) ifTrue: [ \(ua self ]. X (self negative) ifTrue: [ \(ua self negated gcd: value ]. X (value negative) ifTrue: [ \(ua self gcd: value negated ]. X (value > self) ifTrue: [ \(ua value gcd: self ]. X \(ua value gcd: (self rem: value) X.DE X.PP XNew functionality can be added using the message \fBaddMethod\fP. XWhen passed to an instance of \fBClass\fP, this message drops the user into Xa standard Unix Editor. A body for a new method can then be entered. XWhen the user exists the editor, the method body is compiled. If it is Xsyntactically correct, it is added to the methods for the class. If it is Xincorrect, the user is given the option of re-editing the method. X.DS I X> Integer addMethod X\& ... drop into editor and enter the following text X% x X \(ua ( x + ) X\& ... exit editor Xcompiler error: invalid expression start ) Xedit again (yn) ? X\& ... X.DE X.PP XIn a similar manner, existing methods can be editing by passing their Xselectors, as symbols to the message \fBeditMethod:\fP. X.DS I X> Integer editMethod: #gcd: X\& ... drop into editor working on the body of gcd: X.DE X.PP XThe name of the editor used by these methods is taken from a string Xpointed to by the global variable \fIeditor\fP. Different editors can be Xselected merely by redefining this value: X.DS I XglobalNames at: #editor put: 'emacs' X.DE X.PP XSome Smalltalk systems make it very difficult for you to discover the Xbytecodes that a method gets translated into. Since the primary goal of XLittle Smalltalk is to help the student to discover how a modern very high Xleval language is implemented, it makes sense that the system should help Xyou as much as possible discover everything about its internal structure. XThus a method, when presented with the message \fBdisplay\fP, will print Xout its bytecode representation. X.DS I X> Char methods at: #isAlphabetic ; display XMethod #isAlphabetic X isAlphabetic X ^ (self isLowercase) or: [ self isUppercase ] X Xliterals XArray ( #isLowercase #isUppercase ) Xbytecodes X32 2 0 X144 9 0 X0 0 0 X250 15 10 X8 0 8 X32 2 0 X144 9 0 X1 0 1 X242 15 2 X241 15 1 X.DE X.PP XBytecodes are represented by four bit opcodes and four bit operands, with Xoccasional bytes representing data (more detail can be found in the book). XThe three numbers written on each line for the bytecodes represent the Xbyte value followed by the upper four bits and the lower four bits. X.PP XNew objects are created using the message \fBnew\fP. XWithin a method Xthese can be assigned to instance varibles using the assignment arrow. X.DS I X\fBaMethod\fP X x \(<- Set new. X \&... X.DE X.PP XThe assignment arrow is not recognized at the topmost level. Instead, Xglobal variables (variables recognized in any context), are created by Xpassing messages to \fBglobalNames\fP (below). X.PP XNew classes, on the Xother hand, are created by sending a message \fBaddSubClass\fP to the class Xthat will be the superclass of the new class. The user will then be Xinterrogated for information to be associated with the new class: X.DS I X> Object addSubClass XClass Name? Foo XInstance Variables? x y z XAdd a method (yn) ? y X\&... X> Foo display XClass Name: Foo XSuperclass: Object XInstance Variables: Xx Xy Xz XSubclasses: X.DE X.PP XClasses created using \fBaddSubClass\fP will be automatically added to the Xlist of global variables. Other global variables can be created merely by Xplacing their name and value into the Xdictionary \fBglobalNames\fP\s-2\u*\d\s+2. X.DS I X> globalNames at: #version put: 2.1 X X> version print X2.1 X.DE X.FS X* This is a change from version 1 of Little Smalltalk, where it was Xpossible to create global variables merely by assiging a value to them at Xthe command level. The change is an unfortunate consequence of the Xfact that more is done now Xis Smalltalk, and less in C. The bytecode interpreter now knows little Xabout the object globalNames, in particular, the bytecode interpreter Xdoesn't know how to add a new object; this is done entirely in Smalltalk Xcode. One possiblity would be to automatically have the parser change an Xassignment at the command level into an at:put:, but this would seem to Xcomplicate the parser unnecessarily. X.FE X.PP XIf you have written a new class and want to print the class methods on a Xfile you can use the message \fBfileOut:\fP, after first creating a file to Xwrite to. Both classes and individual methods can be filed out, and Xseveral classes and/or methods can be placed in one file. X.DS I X> globalNames at: #f put: File new X> f name: 'foo.st' X> f open: 'w' X> Foo fileOut: f X> Bar fileOut: f X> Object fileOutMethod: #isFoo to: f X> f close X.DE X.LP XThe file ``newfile'' will now have a printable representation of the Xmethods for the class Foo. XThese can subsequently be filed back into a different smalltalk image. X.DS I X> globalNames at: #f put: File new X> f name: 'foo.st' X> f open: 'r' X> f fileIn X> 2 isFoo print XFalse X.DE X.PP XFinally, once the user has added classes and variables and made whatever other Xchanges they want, the message \fBsaveImage\fP, passed to the pseudo Xvariable \fBsmalltalk\fP, can be used to save an entire object image on a file. XIf the writing of the image is successful, a message will be displayed. X.DS I X> smalltalk saveImage XImage name? newimage Ximage newimage created X> X.DE X.PP XTyping control-D causes the interpreter to exit. X.PP XWhen the smalltalk system is restarted, an alternative image, such as the Ximage just created, can be specified by giving its name on the argument Xline: X.DS I Xst newimage X.DE X.PP XFurther information on Little Smalltalk can be found in the book. X.SH XIncompatabilities with the Book X.PP XIt is unfortunately the case that during the transition from version 1 (the Xversion described in the book) and version 2 (the new version that is one Xthird the size and three times faster), certain changes to the user Xinterface were required. I will describe these here. X.PP XThe first incompatability comes at the very beginning. In version 1 there Xwere a great number of command line options. These have all been Xeliminated in version two. In version two the only command line option is Xthe file name of an image file. X.PP XIn version 1 it is possible to create global variables simply by assigning Xto them. That is, a statement such as X.DS I Xxx \(<- 27 X.DE Xwhen issued at the command level would create a new global variable. XSince it is not possible to assign to an unknown name within a method, this Xin effect required the version one system to keep around two parsers, one Xfor methods and another for command lines. These were replaced with a Xsingle parser in version two, which necessitated a change. Now to create a Xglobal variable one must first establish it in the dictionary, using the Xcommand X.DS I XglobalNames at: #xx put: 27 X.DE XIt is not possible to use assignment to create a global variable in version Xtwo. X.PP XThe interface to the editor has been changed. In version one this was Xhandled by the system, and not by Smalltalk code. This required a command Xformat that was clearly not a Smalltalk command, so that they could be Xdistinguished. The convention adoped was to use an APL style system Xcommand: X.DS I X)e filename X.DE XIn version two we have moved these functions into Smalltalk code. Now Xthe problem is just the reverse, we need a command that is a Smalltalk Xcommand. In addition, in version one entire classes were edited at once, Xwhereas in version two only individual methods are edited. As we have Xalready noted, the new commands to add or edit methods are as follows: X.DS I X\fIclassname\fP addMethod X\fIclassname\fP editMethod: \fImethodname\fP X.DE X.PP XThe only other significant syntactic change is the way primitive methods Xare invoked. In version one these were either named or numbered, Xsomething like the following: X.DS I X X X.DE XIn version two we have simply eliminated the keyword \fBprimitive\fP, so Xprimitives now look like: X.DS I X<37 a b> X.DE X.PP XThere are far fewer primitives in version two, and much more of the system Xis now performed using Smalltalk code. X.PP XIn addition to these syntactic changes, there are various small changes in Xthe class structure. I hope to have a document describing these changes at Xsome point, but as of right now the code itself is the best description. / echo 'x - image.c' sed 's/^X//' > image.c << '/' X/* X Little Smalltalk, version 2 X Written by Tim Budd, Oregon State University, July 1987 X X routines used in the making of the initial object image X*/ X X# include X# include "env.h" X# include "memory.h" X# include "names.h" X# include "lex.h" X# ifdef STRING X# include X# endif X# ifdef STRINGS X# include X# endif X X# define SymbolTableSize 71 X# define GlobalNameTableSize 53 X# define MethodTableSize 39 X X# define globalNameSet(sym, value) nameTableInsert(globalNames, sym, value) X/* X the following classes are used repeately, so we put them in globals. X*/ Xstatic object ObjectClass; Xstatic object ClassClass; Xstatic object LinkClass; Xstatic object DictionaryClass; Xstatic object ArrayClass; X X/* X we read the input a line at a time, putting lines into the following X buffer. In addition, all methods must also fit into this buffer. X*/ X# define TextBufferSize 1024 Xstatic char textBuffer[TextBufferSize]; X X/* X nameTableInsert is used to insert a symbol into a name table. X see names.c for futher information on name tables X*/ XnameTableInsert(dict, symbol, value) Xobject dict, symbol, value; X{ object table, link, newLink, nextLink, tablentry; X int hash; X X /* first get the hash table */ X table = basicAt(dict, 1); X X if (objectSize(table) < 3) X sysError("attempt to insert into","too small name table"); X else { X hash = 3 * ( symbol % (objectSize(table) / 3)); X tablentry = basicAt(table, hash+1); X if ((tablentry == nilobj) || (tablentry == symbol)) { X basicAtPut(table, hash+1, symbol); X basicAtPut(table, hash+2, value); X } X else { X newLink = allocObject(3); X incr(newLink); X setClass(newLink, globalSymbol("Link")); X basicAtPut(newLink, 1, symbol); X basicAtPut(newLink, 2, value); X link = basicAt(table, hash+3); X if (link == nilobj) X basicAtPut(table, hash+3, newLink); X else X while(1) X if (basicAt(link,1) == symbol) { X basicAtPut(link, 2, value); X break; X } X else if ((nextLink = basicAt(link, 3)) == nilobj) { X basicAtPut(link, 3, newLink); X break; X } X else X link = nextLink; X decr(newLink); X } X } X} X X/* X there is sort of a chicken and egg problem about building the X first classes. X in order to do it, you need symbols, X but in order to make symbols, you need the class Symbol. X the routines makeClass and buildInitialNameTable attempt to get X carefully get around this initialization problem X*/ X Xstatic object makeClass(name) Xchar *name; X{ object theClass, theSymbol; X X /* this can only be called once newSymbol works properly */ X X theClass = allocObject(classSize); X theSymbol = newSymbol(name); X basicAtPut(theClass, nameInClass, theSymbol); X globalNameSet(theSymbol, theClass); X setClass(theClass, ClassClass); X X return(theClass); X} X XbuildInitialNameTables() X{ object symbolString, classString; X object globalHashTable; X int hash; X char *p; X X /* build the table that contains all symbols */ X symbols = allocObject(2 * SymbolTableSize); X incr(symbols); X X /* build the table (a dictionary) that contains all global names */ X globalNames = allocObject(1); X globalHashTable = allocObject(3 * GlobalNameTableSize); X incr(globalNames); X basicAtPut(globalNames, 1, globalHashTable); X X /* next create class Symbol, so we can call newSymbol */ X /* notice newSymbol uses the global variable symbolclass */ X symbolString = allocSymbol("Symbol"); X symbolclass = allocObject(classSize); X setClass(symbolString, symbolclass); X basicAtPut(symbolclass, nameInClass, symbolString); X /* we recreate the hash computation used by newSymbol */ X hash = 0; X for (p = "Symbol"; *p; p++) X hash += *p; X if (hash < 0) hash = - hash; X hash %= (objectSize(symbols) / 2); X basicAtPut(symbols, 2*hash + 1, symbolString); X globalNameSet(symbolString, symbolclass); X /* now the routine newSymbol should work properly */ X X /* now go on to make class Class so we can call makeClass */ X ClassClass = allocObject(classSize); X classString = newSymbol("Class"); X basicAtPut(ClassClass, nameInClass, classString); X globalNameSet(classString, ClassClass); X setClass(ClassClass, ClassClass); X setClass(symbolclass, ClassClass); X X /* now create a few other important classes */ X ObjectClass = makeClass("Object"); X LinkClass = makeClass("Link"); X setClass(nilobj, makeClass("UndefinedObject")); X DictionaryClass = makeClass("Dictionary"); X ArrayClass = makeClass("Array"); X setClass(symbols, DictionaryClass); X setClass(globalNames, DictionaryClass); X setClass(globalHashTable, ArrayClass); X X} X X/* X findClass gets a class object, X either by finding it already or making it X in addition, it makes sure it has a size, by setting X the size to zero if it is nil. X*/ Xstatic object findClass(name) Xchar *name; X{ object newobj; X X newobj = globalSymbol(name); X if (newobj == nilobj) X newobj = makeClass(name); X if (basicAt(newobj, sizeInClass) == nilobj) X basicAtPut(newobj, sizeInClass, newInteger(0)); X return(newobj); X} X X/* X readDeclaration reads a declaration of a class X*/ Xstatic readDeclaration() X{ object classObj, super, vars; X int i, size, instanceTop; X object instanceVariables[15]; X X if (nextToken() != nameconst) X sysError("bad file format","no name in declaration"); X classObj = findClass(tokenString); X size = 0; X if (nextToken() == nameconst) { /* read superclass name */ X super = findClass(tokenString); X basicAtPut(classObj, superClassInClass, super); X size = intValue(basicAt(super, sizeInClass)); X ignore nextToken(); X } X if (token == nameconst) { /* read instance var names */ X instanceTop = 0; X while (token == nameconst) { X instanceVariables[instanceTop++] = newSymbol(tokenString); X size++; X ignore nextToken(); X } X vars = newArray(instanceTop); X for (i = 0; i < instanceTop; i++) X basicAtPut(vars, i+1, instanceVariables[i]); X basicAtPut(classObj, variablesInClass, vars); X } X basicAtPut(classObj, sizeInClass, newInteger(size)); X} X X/* X readInstance - read an instance directive X*/ Xstatic readInstance() X{ object classObj, newObj; X int size; X X if (nextToken() != nameconst) X sysError("no name","following instance command"); X classObj = globalSymbol(tokenString); X if (nextToken() != nameconst) X sysError("no instance name","in instance command"); X X /* now make a new instance of the class - X note that we can't do any initialization */ X size = intValue(basicAt(classObj, sizeInClass)); X newObj = allocObject(size); X setClass(newObj, classObj); X globalNameSet(newSymbol(tokenString), newObj); X} X X/* X readClass reads a class method description X*/ Xstatic readClass(fd, printit) XFILE *fd; Xboolean printit; X{ object classObj, methTable, theMethod, selector; X# define LINEBUFFERSIZE 512 X object methDict; X char *eoftest, lineBuffer[LINEBUFFERSIZE]; X X /* if we haven't done it already, read symbols now */ X if (trueobj == nilobj) X initCommonSymbols(); X X if (nextToken() != nameconst) X sysError("missing name","following Class keyword"); X classObj = findClass(tokenString); X setInstanceVariables(classObj); X if (printit) Xignore fprintf(stderr,"class %s\n", charPtr(basicAt(classObj, nameInClass))); X X /* find or create a methods table */ X methTable = basicAt(classObj, methodsInClass); X if (methTable == nilobj) { X methTable = allocObject(1); X basicAtPut(classObj, methodsInClass, methTable); X setClass(methTable, globalSymbol("Dictionary")); X methDict = allocObject(MethodTableSize); X basicAtPut(methTable, 1, methDict); X setClass(methDict, globalSymbol("Array")); X } X X /* now go read the methods */ X do { X textBuffer[0] = '\0'; X while((eoftest = fgets(lineBuffer, LINEBUFFERSIZE, fd)) != NULL) { X if ((lineBuffer[0] == '|') || (lineBuffer[0] == ']')) X break; X ignore strcat(textBuffer, lineBuffer); X } X if (eoftest == NULL) { X sysError("unexpected end of file","while reading method"); X break; X } X /* now we have a method */ X theMethod = allocObject(methodSize); X setClass(theMethod, globalSymbol("Method")); X if (parse(theMethod, textBuffer)) { X selector = basicAt(theMethod, messageInMethod); X if (printit) Xignore fprintf(stderr,"method %s\n", charPtr(selector)); X nameTableInsert(methTable, selector, theMethod); X } X else { X /* get rid of unwanted method */ X incr(theMethod); X decr(theMethod); Xignore fprintf(stderr,"push return to continue\n"); Xignore gets(textBuffer); X } X X } while (lineBuffer[0] != ']'); X} X X/* X readFile reads a class descriptions file X*/ XreadFile(fd, printit) XFILE *fd; Xboolean printit; X{ X while(fgets(textBuffer, TextBufferSize, fd) != NULL) { X lexinit(textBuffer); X if (token == inputend) X ; /* do nothing, get next line */ X else if ((token == binary) && streq(tokenString, "*")) X ; /* do nothing, its a comment */ X else if ((token == nameconst) && streq(tokenString, "Declare")) X readDeclaration(); X else if ((token == nameconst) && streq(tokenString,"Instance")) X readInstance(); X else if ((token == nameconst) && streq(tokenString,"Class")) X readClass(fd, printit); X else X ignore fprintf(stderr,"unknown line %s\n", textBuffer); X } X} / echo 'x - parser.c' sed 's/^X//' > parser.c << '/' X/* X Little Smalltalk, version 2 X Written by Tim Budd, Oregon State University, July 1987 X X Method parser - parses the textual description of a method, X generating bytecodes and literals. X X This parser is based around a simple minded recursive descent X parser. X It is used both by the module that builds the initial virtual image, X and by a primitive when invoked from a running Smalltalk system. X X The latter case could, if the bytecode interpreter were fast enough, X be replaced by a parser written in Smalltalk. This would be preferable, X but not if it slowed down the system too terribly. X X To use the parser the routine setInstanceVariables must first be X called with a class object. This places the appropriate instance X variables into the memory buffers, so that references to them X can be correctly encoded. X X As this is recursive descent, you should read it SDRAWKCAB ! X (from bottom to top) X*/ X# include X# include "env.h" X# include "memory.h" X# include "names.h" X# include "interp.h" X# include "lex.h" X# ifdef STRING X# include X# endif X# ifdef STRINGS X# include X# endif X X /* all of the following limits could be increased (up to X 256) without any trouble. They are kept low X to keep memory utilization down */ X X# define codeLimit 256 /* maximum number of bytecodes permitted */ X# define literalLimit 32 /* maximum number of literals permitted */ X# define temporaryLimit 16 /* maximum number of temporaries permitted */ X# define argumentLimit 16 /* maximum number of arguments permitted */ X# define instanceLimit 16 /* maximum number of instance vars permitted */ X# define methodLimit 32 /* maximum number of methods permitted */ X Xextern object binSyms[]; Xextern object keySyms[]; Xextern char *unStrs[], *binStrs[], *keyStrs[]; X Xstatic boolean parseok; /* parse still ok? */ Xstatic int codeTop; /* top position filled in code array */ Xstatic byte codeArray[codeLimit]; /* bytecode array */ Xstatic int literalTop; /* ... etc. */ Xstatic object literalArray[literalLimit]; Xstatic int temporaryTop; Xstatic char *temporaryName[temporaryLimit]; Xstatic int argumentTop; Xstatic char *argumentName[argumentLimit]; Xstatic int instanceTop; Xstatic char *instanceName[instanceLimit]; X Xstatic int maxTemporary; /* highest temporary see so far */ Xstatic char selector[80]; /* message selector */ X Xstatic boolean inBlock; /* true if compiling a block */ Xstatic boolean optimizedBlock; /* true if compiling optimized block */ X XsetInstanceVariables(aClass) Xobject aClass; X{ int i, limit; X object vars; X X if (aClass == nilobj) X instanceTop = 0; X else { X setInstanceVariables(basicAt(aClass, superClassInClass)); X vars = basicAt(aClass, variablesInClass); X if (vars != nilobj) { X limit = objectSize(vars); X for (i = 1; i <= limit; i++) X instanceName[++instanceTop] = charPtr(basicAt(vars, i)); X } X } X} X XcompilWarn(str1, str2) Xchar *str1, *str2; X{ X ignore fprintf(stderr,"compiler warning: %s %s\n", str1, str2); X} X XcompilError(str1, str2) Xchar *str1, *str2; X{ X ignore fprintf(stderr,"compiler error: %s %s\n", str1, str2); X parseok = false; X} X Xstatic object newChar(value) Xint value; X{ object newobj; X X newobj = allocObject(1); X basicAtPut(newobj, 1, newInteger(value)); X setClass(newobj, globalSymbol("Char")); X return(newobj); X} X Xstatic object newByteArray(size) Xint size; X{ object newobj; X X newobj = allocByte(size); X setClass(newobj, globalSymbol("ByteArray")); X return(newobj); X} X Xstatic genCode(value) Xint value; X{ X if (codeTop >= codeLimit) X compilError("too many bytecode instructions in method",""); X else X codeArray[codeTop++] = value; X} X Xstatic genInstruction(high, low) Xint high, low; X{ X if (low >= 16) { X genInstruction(0, high); X genCode(low); X } X else X genCode(high * 16 + low); X} X Xstatic int genLiteral(aLiteral) Xobject aLiteral; X{ X if (literalTop >= literalLimit) X compilError("too many literals in method",""); X else { X literalArray[++literalTop] = aLiteral; X incr(aLiteral); X } X return(literalTop - 1); X} X Xstatic char *glbsyms[] = {"nil", "true", "false", "smalltalk", "globalNames", X0 }; X Xstatic boolean nameTerm(name) Xchar *name; X{ int i; X boolean done = false; X boolean isSuper = false; X object newterm; X X /* it might be self or super */ X if (streq(name, "self") || streq(name, "super")) { X genInstruction(PushArgument, 0); X done = true; X if (streq(name,"super")) isSuper = true; X } X X /* or it might be a temporary */ X if (! done) X for (i = 1; (! done) && ( i <= temporaryTop ) ; i++) X if (streq(name, temporaryName[i])) { X genInstruction(PushTemporary, i-1); X done = true; X } X X /* or it might be an argument */ X if (! done) X for (i = 1; (! done) && (i <= argumentTop ) ; i++) X if (streq(name, argumentName[i])) { X genInstruction(PushArgument, i); X done = true; X } X X /* or it might be an instance variable */ X if (! done) X for (i = 1; (! done) && (i <= instanceTop); i++) { X if (streq(name, instanceName[i])) { X genInstruction(PushInstance, i-1); X done = true; X } X } X X /* or it might be a global constant */ X if (! done) X for (i = 0; (! done) && glbsyms[i]; i++) X if (streq(name, glbsyms[i])) { X genInstruction(PushConstant, i+4); X done = true; X } X X /* not anything else, it must be a global */ X /* see if we know of it first */ X if (! done) { X newterm = globalSymbol(name); X if (newterm != nilobj) { X genInstruction(PushLiteral, genLiteral(newterm)); X done = true; X } X } X X /* otherwise, must look it up at run time */ X if (! done) { X genInstruction(PushGlobal, genLiteral(newSymbol(name))); X } X X return(isSuper); X} X Xstatic int parseArray() X{ int i, size, base; X object newLit, obj; X X base = literalTop; X ignore nextToken(); X while (parseok && (token != closing)) { X switch(token) { X case arraybegin: X ignore parseArray(); X break; X X case intconst: X ignore genLiteral(newInteger(tokenInteger)); X ignore nextToken(); X break; X X case floatconst: X ignore genLiteral(newFloat(tokenFloat)); X ignore nextToken(); X break; X X case nameconst: case namecolon: case symconst: X ignore genLiteral(newSymbol(tokenString)); X ignore nextToken(); X break; X X case binary: X if (streq(tokenString, "(")) { X ignore parseArray(); X } X else { X ignore genLiteral(newSymbol(tokenString)); X ignore nextToken(); X } X break; X X case charconst: X ignore genLiteral(newChar( X newInteger(tokenInteger))); X ignore nextToken(); X break; X X case strconst: X ignore genLiteral(newStString(tokenString)); X ignore nextToken(); X break; X X default: X compilError("illegal text in literal array", X tokenString); X ignore nextToken(); X break; X } X } X X if (parseok) X if (! streq(tokenString, ")")) X compilError("array not terminated by right parenthesis", X tokenString); X else X ignore nextToken(); X size = literalTop - base; X newLit = newArray(size); X for (i = size; i >= 1; i--) { X obj = literalArray[literalTop]; X basicAtPut(newLit, i, obj); X decr(obj); X literalArray[literalTop] = nilobj; X literalTop = literalTop - 1; X } X return(genLiteral(newLit)); X} X Xstatic boolean term() X{ boolean superTerm = false; /* true if term is pseudo var super */ X X if (token == nameconst) { X superTerm = nameTerm(tokenString); X ignore nextToken(); X } X else if (token == intconst) { X if ((tokenInteger >= 0) && (tokenInteger <= 2)) X genInstruction(PushConstant, tokenInteger); X else X genInstruction(PushLiteral, X genLiteral(newInteger(tokenInteger))); X ignore nextToken(); X } X else if (token == floatconst) { X genInstruction(PushLiteral, genLiteral(newFloat(tokenFloat))); X ignore nextToken(); X } X else if ((token == binary) && streq(tokenString, "-")) { X ignore nextToken(); X if (token == intconst) { X if (tokenInteger == 1) X genInstruction(PushConstant, 3); X else X genInstruction(PushLiteral, X genLiteral(newInteger( - tokenInteger))); X } X else if (token == floatconst) { X genInstruction(PushLiteral, X genLiteral(newFloat(-tokenFloat))); X } X else X compilError("negation not followed", X "by number"); X ignore nextToken(); X } X else if (token == charconst) { X genInstruction(PushLiteral, X genLiteral(newChar(tokenInteger))); X ignore nextToken(); X } X else if (token == symconst) { X genInstruction(PushLiteral, X genLiteral(newSymbol(tokenString))); X ignore nextToken(); X } X else if (token == strconst) { X genInstruction(PushLiteral, X genLiteral(newStString(tokenString))); X ignore nextToken(); X } X else if (token == arraybegin) { X genInstruction(PushLiteral, parseArray()); X } X else if ((token == binary) && streq(tokenString, "(")) { X ignore nextToken(); X expression(); X if (parseok) X if ((token != closing) || ! streq(tokenString, ")")) X compilError("Missing Right Parenthesis",""); X else X ignore nextToken(); X } X else if ((token == binary) && streq(tokenString, "<")) X parsePrimitive(); X else if ((token == binary) && streq(tokenString, "[")) X block(); X else X compilError("invalid expression start", tokenString); X X return(superTerm); X} X Xstatic parsePrimitive() X{ int primitiveNumber, argumentCount; X X if (nextToken() != intconst) X compilError("primitive number missing",""); X primitiveNumber = tokenInteger; X ignore nextToken(); X argumentCount = 0; X while (parseok && ! ((token == binary) && streq(tokenString, ">"))) { X ignore term(); X argumentCount++; X } X genInstruction(DoPrimitive, argumentCount); X genCode(primitiveNumber); X ignore nextToken(); X} X Xstatic genMessage(toSuper, argumentCount, messagesym) Xboolean toSuper; Xint argumentCount; Xobject messagesym; X{ X if (toSuper) { X genInstruction(DoSpecial, SendToSuper); X genCode(argumentCount); X } X else X genInstruction(SendMessage, argumentCount); X genCode(genLiteral(messagesym)); X} X Xstatic boolean unaryContinuation(superReceiver) Xboolean superReceiver; X{ int i; X boolean sent; X object messagesym; X X while (parseok && (token == nameconst)) { X /* first check to see if it could be a temp by mistake */ X for (i=1; i < temporaryTop; i++) X if (streq(tokenString, temporaryName[i])) X compilWarn("message same as temporary:", X tokenString); X for (i=1; i < argumentTop; i++) X if (streq(tokenString, argumentName[i])) X compilWarn("message same as argument:", X tokenString); X /* the next generates too many spurious messages */ X /* for (i=1; i < instanceTop; i++) X if (streq(tokenString, instanceName[i])) X compilWarn("message same as instance", X tokenString); */ X X sent = false; X messagesym = newSymbol(tokenString); X /* check for built in messages */ X if (! superReceiver) X for (i = 0; (! sent) && unStrs[i] ; i++) X if (streq(tokenString, unStrs[i])) { X genInstruction(SendUnary, i); X sent = true; X } X if (! sent) { X genMessage(superReceiver, 0, messagesym); X } X /* once a message is sent to super, reciever is not super */ X superReceiver = false; X ignore nextToken(); X } X return(superReceiver); X} X Xstatic boolean binaryContinuation(superReceiver) Xboolean superReceiver; X{ int i; X boolean sent, superTerm; X object messagesym; X X superReceiver = unaryContinuation(superReceiver); X while (parseok && (token == binary)) { X messagesym = newSymbol(tokenString); X ignore nextToken(); X superTerm = term(); X ignore unaryContinuation(superTerm); X sent = false; X /* check for built in messages */ X if (! superReceiver) { X for (i = 0; (! sent) && binStrs[i]; i++) X if (messagesym == binSyms[i]) { X genInstruction(SendBinary, i); X sent = true; X } X X } X if (! sent) { X genMessage(superReceiver, 1, messagesym); X } X superReceiver = false; X } X return(superReceiver); X} X Xstatic int optimizeBlock(instruction, dopop) Xint instruction; Xboolean dopop; X{ int location; X boolean saveOB; X X genInstruction(DoSpecial, instruction); X location = codeTop; X genCode(0); X if (dopop) X genInstruction(DoSpecial, PopTop); X ignore nextToken(); X if (streq(tokenString, "[")) { X ignore nextToken(); X saveOB = optimizedBlock; X optimizedBlock = true; X body(); X optimizedBlock = saveOB; X if (! streq(tokenString, "]")) X compilError("missing close","after block"); X ignore nextToken(); X } X else { X ignore binaryContinuation(term()); X genInstruction(SendUnary, 3 /* value command */); X } X codeArray[location] = codeTop; X return(location); X} X Xstatic boolean keyContinuation(superReceiver) Xboolean superReceiver; X{ int i, j, argumentCount; X boolean sent, superTerm; X object messagesym; X char pattern[80]; X X superReceiver = binaryContinuation(superReceiver); X if (token == namecolon) { X if (streq(tokenString, "ifTrue:")) { X i = optimizeBlock(BranchIfFalse, false); X if (streq(tokenString, "ifFalse:")) { X codeArray[i] = codeTop + 3; X ignore optimizeBlock(Branch, true); X } X } X else if (streq(tokenString, "ifFalse:")) { X i = optimizeBlock(BranchIfTrue, false); X if (streq(tokenString, "ifTrue:")) { X codeArray[i] = codeTop + 3; X ignore optimizeBlock(Branch, true); X } X } X else if (streq(tokenString, "whileTrue:")) { X j = codeTop; X genInstruction(DoSpecial, Duplicate); X genInstruction(SendUnary, 3 /* value command */); X i = optimizeBlock(BranchIfFalse, false); X genInstruction(DoSpecial, PopTop); X genInstruction(DoSpecial, Branch); X genCode(j); X codeArray[i] = codeTop; X genInstruction(DoSpecial, PopTop); X } X else if (streq(tokenString, "and:")) X ignore optimizeBlock(AndBranch, false); X else if (streq(tokenString, "or:")) X ignore optimizeBlock(OrBranch, false); X else { X pattern[0] = '\0'; X argumentCount = 0; X while (parseok && (token == namecolon)) { X ignore strcat(pattern, tokenString); X argumentCount++; X ignore nextToken(); X superTerm = term(); X ignore binaryContinuation(superTerm); X } X sent = false; X X /* check for predefined messages */ X messagesym = newSymbol(pattern); X if (! superReceiver) { X for (i = 0; (! sent) && binStrs[i]; i++) X if (messagesym == binSyms[i]) { X sent = true; X genInstruction(SendBinary, i); X } X X for (i = 0; (! sent) && keyStrs[i]; i++) X if (messagesym == keySyms[i]) { X genInstruction(SendKeyword, i); X sent = true; X } X } X X if (! sent) { X genMessage(superReceiver, argumentCount, messagesym); X } X } X superReceiver = false; X } X return(superReceiver); X} X Xstatic continuation(superReceiver) Xboolean superReceiver; X{ X superReceiver = keyContinuation(superReceiver); X X while (parseok && (token == closing) && streq(tokenString, ";")) { X genInstruction(DoSpecial, Duplicate); X ignore nextToken(); X ignore keyContinuation(superReceiver); X genInstruction(DoSpecial, PopTop); X } X} X Xstatic expression() X{ boolean superTerm; X X superTerm = term(); X if (parseok) X continuation(superTerm); X} X Xstatic assignment(name) Xchar *name; X{ int i; X boolean done; X X done = false; X X /* it might be a temporary */ X for (i = 1; (! done) && (i <= temporaryTop); i++) X if (streq(name, temporaryName[i])) { X genInstruction(PopTemporary, i-1); X done = true; X } X X /* or it might be an instance variable */ X for (i = 1; (! done) && (i <= instanceTop); i++) X if (streq(name, instanceName[i])) { X genInstruction(PopInstance, i-1); X done = true; X } X X if (! done) X compilError("assignment to unknown name", name); X} X Xstatic statement() X{ char assignname[80]; X boolean superReceiver = false; X X if ((token == binary) && streq(tokenString, "^")) { X ignore nextToken(); X expression(); X if (inBlock) X genInstruction(DoSpecial, BlockReturn); X else X genInstruction(DoSpecial, StackReturn); X } X else if (token == nameconst) { /* possible assignment */ X ignore strcpy(assignname, tokenString); X ignore nextToken(); X if ((token == binary) && streq(tokenString, "<-")) { X ignore nextToken(); X expression(); X if (inBlock || optimizedBlock) X if ((token == closing) && streq(tokenString,"]")) X genInstruction(DoSpecial, Duplicate); X assignment(assignname); X if (inBlock && (token == closing) && X streq(tokenString, "]")) X genInstruction(DoSpecial, StackReturn); X } X else { /* not an assignment after all */ X superReceiver = nameTerm(assignname); X continuation(superReceiver); X if ((token == closing) && streq(tokenString, "]")) { X if (inBlock && ! optimizedBlock) X genInstruction(DoSpecial, StackReturn); X } X else X genInstruction(DoSpecial, PopTop); X } X } X else { X expression(); X if ((token == closing) && streq(tokenString, "]")) { X if (inBlock && ! optimizedBlock) X genInstruction(DoSpecial, StackReturn); X } X else X genInstruction(DoSpecial, PopTop); X } X} X Xstatic body() X{ X if (inBlock || optimizedBlock) X if ((token == closing) && streq(tokenString, "]")) { X genInstruction(PushConstant, 4); X if (! optimizedBlock) X genInstruction(DoSpecial, StackReturn); X return; X } X X while(parseok) { X statement(); X if (token == closing) X if (streq(tokenString,".")) { X ignore nextToken(); X if (token == inputend) X break; X } X else X break; X else X if (token == inputend) X break; X else { X compilError("invalid statement ending; token is ", X tokenString); X } X } X} X Xstatic block() X{ int saveTemporary, argumentCount, fixLocation; X boolean saveInBlock, saveOB; X object tempsym; X X saveTemporary = temporaryTop; X argumentCount = 0; X ignore nextToken(); X if ((token == binary) && streq(tokenString, ":")) { X while (parseok && (token == binary) && streq(tokenString,":")) { X if (nextToken() != nameconst) X compilError("name must follow colon", X "in block argument list"); X if (++temporaryTop > maxTemporary) X maxTemporary = temporaryTop; X argumentCount++; X if (temporaryTop > temporaryLimit) X compilError("too many temporaries in method",""); X else { X tempsym = newSymbol(tokenString); X temporaryName[temporaryTop] = charPtr(tempsym); X } X ignore nextToken(); X } X if ((token != binary) || ! streq(tokenString, "|")) X compilError("block argument list must be terminated", X "by |"); X ignore nextToken(); X } X genInstruction(CreateBlock, argumentCount); X if (argumentCount != 0){ X genCode(saveTemporary + 1); X } X fixLocation = codeTop; X genCode(0); X saveInBlock = inBlock; X saveOB = optimizedBlock; X inBlock = true; X optimizedBlock = false; X body(); X if ((token == closing) && streq(tokenString, "]")) X ignore nextToken(); X else X compilError("block not terminated by ]",""); X codeArray[fixLocation] = codeTop; X inBlock = saveInBlock; X optimizedBlock = saveOB; X temporaryTop = saveTemporary; X} X Xstatic temporaries() X{ object tempsym; X X temporaryTop = 0; X if ((token == binary) && streq(tokenString, "|")) { X ignore nextToken(); X while (token == nameconst) { X if (++temporaryTop > maxTemporary) X maxTemporary = temporaryTop; X if (temporaryTop > temporaryLimit) X compilError("too many temporaries in method",""); X else { X tempsym = newSymbol(tokenString); X temporaryName[temporaryTop] = charPtr(tempsym); X } X ignore nextToken(); X } X if ((token != binary) || ! streq(tokenString, "|")) X compilError("temporary list not terminated by bar",""); X else X ignore nextToken(); X } X} X Xstatic messagePattern() X{ object argsym; X X argumentTop = 0; X ignore strcpy(selector, tokenString); X if (token == nameconst) /* unary message pattern */ X ignore nextToken(); X else if (token == binary) { /* binary message pattern */ X ignore nextToken(); X if (token != nameconst) X compilError("binary message pattern not followed by name",selector); X argsym = newSymbol(tokenString); X argumentName[++argumentTop] = charPtr(argsym); X ignore nextToken(); X } X else if (token == namecolon) { /* keyword message pattern */ X selector[0] = '\0'; X while (parseok && (token == namecolon)) { X ignore strcat(selector, tokenString); X ignore nextToken(); X if (token != nameconst) X compilError("keyword message pattern", X "not followed by a name"); X if (++argumentTop > argumentLimit) X compilError("too many arguments in method",""); X argsym = newSymbol(tokenString); X argumentName[argumentTop] = charPtr(argsym); X ignore nextToken(); X } X } X else X compilError("illegal message selector", tokenString); X} X Xboolean parse(method, text) Xobject method; Xchar *text; X{ int i; X object bytecodes, theLiterals; X byte *bp; X X lexinit(text); X parseok = true; X codeTop = 0; X literalTop = temporaryTop = argumentTop =0; X maxTemporary = 0; X inBlock = optimizedBlock = false; X X messagePattern(); X if (parseok) X temporaries(); X if (parseok) X body(); X if (parseok) X genInstruction(DoSpecial, SelfReturn); X X if (! parseok) X basicAtPut(method, bytecodesInMethod, nilobj); X else { X bytecodes = newByteArray(codeTop); X bp = bytePtr(bytecodes); X for (i = 0; i < codeTop; i++) { X bp[i] = codeArray[i]; X } X basicAtPut(method, messageInMethod, newSymbol(selector)); X basicAtPut(method, bytecodesInMethod, bytecodes); X if (literalTop > 0) { X theLiterals = newArray(literalTop); X for (i = 1; i <= literalTop; i++) { X basicAtPut(theLiterals, i, literalArray[i]); X decr(literalArray[i]); X } X basicAtPut(method, literalsInMethod, theLiterals); X } X else X basicAtPut(method, literalsInMethod, nilobj); X basicAtPut(method, stackSizeInMethod, newInteger(6)); X basicAtPut(method, temporarySizeInMethod, X newInteger(1 + maxTemporary)); X basicAtPut(method, textInMethod, newStString(text)); X return(true); X } X return(false); X} / echo 'x - queen.st' sed 's/^X//' > queen.st << '/' XClass Queen Object #row #column #neighbor XMethod Queen X setColumn: aNumber neighbor: aQueen X column <- aNumber. X neighbor <- aQueen X X| XMethod Queen X checkRow: testRow column: testColumn | columnDifference | X columnDifference <- testColumn - column. X (((row = testRow) or: X [ row + columnDifference = testRow]) or: X [ row - columnDifference = testRow]) X ifTrue: [ ^ true ]. X (neighbor notNil) X ifTrue: [ ^ neighbor checkRow: testRow X column: testColumn ] X ifFalse: [ ^ false ] X X| XMethod Queen X first X (neighbor notNil) X ifTrue: [ neighbor first ]. X row <- 1. X ^ self testPosition X X| XMethod Queen X next X (row = 8) X ifTrue: [ ((neighbor isNil) or: [neighbor next isNil]) X ifTrue: [ ^ nil ]. X row <- 0 ]. X row <- row + 1. X ^ self testPosition X X| XMethod Queen X testPosition X (neighbor isNil) ifTrue: [ ^ self ]. X (neighbor checkRow: row column: column) X ifTrue: [ ^ self next ] X ifFalse: [ ^ self ] X X| XMethod Queen X result X ^ ((neighbor isNil) X ifTrue: [ List new ] X ifFalse: [ neighbor result ] ) X addLast: row X X| XMethod Test X queen | lastQueen | X lastQueen <- nil. X (1 to: 8) do: [:i | lastQueen <- Queen new; X setColumn: i neighbor: lastQueen ]. X lastQueen first. X (lastQueen result asArray = #(1 5 8 6 3 7 2 4) ) X ifTrue: ['8 queens test passed' print] X ifFalse: [smalltalk error: '8queen test failed'] X X| / echo 'Part 02 of small.v2 complete.' exit