v17i053: New release of little smalltalk, Part05/05
Rich Salz
rsalz at bbn.com
Tue Feb 23 10:09:10 AEST 1988
Submitted-by: Tim Budd <budd at MIST.CS.ORST.EDU>
Posting-number: Volume 13, Issue 57
Archive-name: little-st2/part05
#!/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 at cs.orst.edu
# {hp-pcd, tektronix}!orstcs!budd
#
#
echo 'Start of small.v2, part 05 of 05:'
echo 'x - Bugs'
sed 's/^X//' > Bugs << '/'
Xobjects are limited to size 256
X this mostly limits the text (char) size of methods - to 512 chars.
X this could be fixed by changing memory.c.
X
Xradices other than 10 aren't implemented.
X
XThe parser doesn always do literal arrays correctly, in particular, I
X think negation signs on numbers aren't recognized within arrays.
X (should be reorganized in the parser).
X
Xparser should leave method text in method, so it can be edited dynamically
X(does this now, but it should be an option, to save space on small
Xsystems).
X
XThe collection hierarchy has been completely reorginized (this isn't a bug)
X many of the more obscure messages are left unimplmented.
X many of the abstract classes are eliminated
X Bags have been eliminated (they can be replaced by lists)
X collections are now magnitudes (set subset relations)
X
XThe basic classes are somewhat incomplete, in particular
X points aren't implemented
X radians are implemented (neither are trig functions)
X
XBytearrays are a bit odd. In particular,
X converting to bytearrays gives something too big (by twice)
X converting bytearrays to strings can cause bugs if the last
X byte is not zero (causing non null terminated strings)
X
XSemaphores and processes aren't implemented yet - even in the multiprocess
X version
X initial experiments aren't encouraging -
X they seem to be too slow.
X
XPROJECTS______________________________________________________________
XFor those with time on their hands and nothing to do, here is a list
Xof several projects that need doing.
X
X1. Profiling indicates that about 45% of execution time is spent in the
Xroutine ``execute'', in interp.c. Rewrite this in your favorite assembly
Xlanguage to speed it up.
X
X2. Rewrite the memory manager. Possible changes
X a. use garbage collection of some sort
X b. allow big objects (bigger than 256 words)
X
X3. Rewrite the process manager in assembly language, permitting the
X Smalltalk process stack to exist intermixed with the C
X execution stack.
X
X4. Port to your favorite machine, making the interface fit the machine.
X Make sure you send me a diff script of any changes you made,
X so I can incorporate them into the next release
X
X5. Lots of extensions could stand implementing, such as
X infinite precision numbers
X semaphores and processes
/
echo 'x - Makefile'
sed 's/^X//' > Makefile << '/'
X#
X# Makefile for Little Smalltalk, version 2
X#
XCFLAGS = -g
X
XCOMMONc = memory.c names.c lex.c parser.c
XCOMMONo = memory.o names.o lex.o parser.o
XPARSEc = comp.c $(COMMONc) image.c
XPARSEo = comp.o $(COMMONo) image.o
XSTc = main.c $(COMMONc) process.c primitive.c interp.c
XSTo = main.o $(COMMONo) process.o primitive.o interp.o
Xclasses = basic.st unix.st mult.st munix.st test.st
Xallfiles = READ_ME Bugs Makefile todo *.ms *.h *.c *.st *.ini
X
Xinstall: stest sunix
X echo "created single process version, see docs for more info"
X
X#
X# parse - the object image parser.
X# used to build the initial object image
X#
Xparse: $(PARSEo)
X cc -o parse $(CFLAGS) $(PARSEo)
X
Xparseprint:
X pr *.h $(PARSEc) | lpr
X
Xparselint:
X lint $(PARSEc)
X
X#
X# st - the actual bytecode interpreter
X# runs bytecodes from the initial image, or another image
X#
Xst: $(STo)
X cc $(CFLAGS) -o st $(STo) -lm
X
Xstlint:
X lint $(STc)
X
Xstprint:
X pr *.h $(STc) | lpr
X
X#
X# image - build the initial object image
X#
Xclasslpr:
X pr $(classes) | lpr
X
Xsunix: parse st
X parse basic.st unix.st
X st - - <script.ini
X
Xmunix: parse st
X parse basic.st unix.st mult.st munix.st
X st - - <script.ini
X
Xstest: parse st
X parse -s basic.st unix.st test.st
X st - - <script.ini
X st <test.ini
X
Xmtest: parse st
X parse -s basic.st unix.st mult.st munix.st test.st mtest.st
X st - - <script.ini
X st <test.ini
X
X#
X# include file dependencies
X#
Xcomp.o: env.h memory.h names.h
Ximage.o: env.h memory.h names.h lex.h
Xinterp.o: env.h memory.h names.h process.h interp.h
Xlex.o: env.h memory.h lex.h
Xmain.o: env.h memory.h names.h interp.h process.h
Xmemory.o: env.h memory.h
Xnames.o: env.h memory.h names.h
Xparser.o: env.h memory.h names.h interp.h lex.h
Xprimitive.o: env.h memory.h names.h process.h
Xprocess.o: env.h memory.h names.h process.h
X
X#
X# distribution bundles
X#
X
Xtar:
X tar cvf ../smalltalk.v2.tar .
X compress -c ../smalltalk.v2.tar >../smalltalk.v2.tar.Z
X
Xpack:
X packmail -o'small.v2' -h'head' $(allfiles)
/
echo 'x - comp.c'
sed 's/^X//' > comp.c << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X
X Unix specific front end for the initial object image maker
X (parse utility)
X*/
X
X# include <stdio.h>
X# include "env.h"
X# include "memory.h"
X# include "names.h"
X
Xmain(argc, argv)
Xint argc;
Xchar **argv;
X{ FILE *fp;
X int i;
X boolean printit = true;
X
X initMemoryManager();
X
X buildInitialNameTables();
X
X if (argc == 1)
X readFile(stdin, printit);
X else
X for (i = 1; i < argc; i++) {
X if (argv[i][0] == '-') {
X switch(argv[i][1]) {
X case 's': printit = false; break;
X case 'v': printit = true; break;
X }
X }
X else {
X fp = fopen(argv[i], "r");
X if (fp == NULL) {
X ignore fprintf(stderr,
X "can't open file %s", argv[i]);
X exit(1);
X }
X else {
X readFile(fp, printit);
X ignore fclose(fp);
X }
X }
X }
X
X# ifndef BINREADWRITE
X fp = fopen(INITIALIMAGE, "w");
X# endif
X# ifdef BINREADWRITE
X fp = fopen(INITIALIMAGE, "wb");
X# endif
X if (fp == NULL) sysError("error during image file open",INITIALIMAGE);
X imageWrite(fp);
X ignore fclose(fp);
X exit(0);
X}
/
echo 'x - interp.h'
sed 's/^X//' > interp.h << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X*/
X/*
X symbolic definitions for the bytecodes
X*/
X
X# define Extended 0
X# define PushInstance 1
X# define PushArgument 2
X# define PushTemporary 3
X# define PushLiteral 4
X# define PushConstant 5
X# define PushGlobal 6
X# define PopInstance 7
X# define PopTemporary 8
X# define SendMessage 9
X# define SendUnary 10
X# define SendBinary 11
X# define SendKeyword 12
X# define DoPrimitive 13
X# define CreateBlock 14
X# define DoSpecial 15
X
X/* types of special instructions (opcode 15) */
X
X# define SelfReturn 1
X# define StackReturn 2
X# define BlockReturn 3
X# define Duplicate 4
X# define PopTop 5
X# define Branch 6
X# define BranchIfTrue 7
X# define BranchIfFalse 8
X# define AndBranch 9
X# define OrBranch 10
X# define SendToSuper 11
/
echo 'x - lex.h'
sed 's/^X//' > lex.h << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X*/
X/*
X values returned by the lexical analyzer
X*/
X
X# ifndef NOENUMS
X
Xtypedef enum tokensyms { nothing, nameconst, namecolon,
X intconst, floatconst, charconst, symconst,
X arraybegin, strconst, binary, closing, inputend} tokentype;
X# endif
X
X# ifdef NOENUMS
X# define tokentype int
X# define nothing 0
X# define nameconst 1
X# define namecolon 2
X# define intconst 3
X# define floatconst 4
X# define charconst 5
X# define symconst 6
X# define arraybegin 7
X# define strconst 8
X# define binary 9
X# define closing 10
X# define inputend 11
X
X# endif
X
Xextern tokentype nextToken(NOARGS);
X
Xextern tokentype token; /* token variety */
Xextern char tokenString[]; /* text of current token */
Xextern int tokenInteger; /* integer (or character) value of token */
Xextern double tokenFloat; /* floating point value of token */
Xextern noreturn lexinit(); /* initialization routine */
/
echo 'x - main.c'
sed 's/^X//' > main.c << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X
X unix specific driver (front-end) for bytecode interpreter.
X*/
X# include <stdio.h>
X
X# include "env.h"
X# include "memory.h"
X# include "names.h"
X# include "interp.h"
X# include "process.h"
X
X# ifdef STRING
X# include <string.h>
X# endif
X# ifdef STRINGS
X# include <strings.h>
X# endif
X# ifdef SIGNALS
X# include <signal.h>
X# include <setjmp.h>
Xjmp_buf intenv;
X# endif
X# ifdef SSIGNALS
X# include <signal.h>
X# include <setjmp.h>
Xjmp_buf intenv;
X# endif
X
Xextern int processStackTop;
Xextern object processStack[];
X
X# ifdef SIGNALS
Xbrkfun() { longjmp(intenv, 1); }
X# endif
X# ifdef SSIGNALS
Xbrkfun() { longjmp(intenv, 1); }
X# endif
X
Xmain(argc, argv)
Xint argc;
Xchar **argv;
X{
XFILE *fp;
Xchar fileName[120];
X
XinitMemoryManager();
X
Xif ((argc == 1) || ((argc > 1) && streq(argv[1],"-"))){
X# ifdef BINREADWRITE
X fp = fopen(INITIALIMAGE,"rb");
X# endif
X# ifndef BINREADWRITE
X fp = fopen(INITIALIMAGE,"r");
X# endif
X if (fp == NULL)
X sysError("cannot read image file",INITIALIMAGE);
X }
Xelse {
X# ifdef BINREADWRITE
X fp = fopen(argv[1], "rb");
X# endif
X# ifndef BINREADWRITE
X fp = fopen(argv[1], "r");
X# endif
X if (fp == NULL)
X sysError("cannot read image file", argv[1]);
X }
XimageRead(fp);
Xignore fclose(fp);
X
XinitCommonSymbols();
X
Xignore fprintf(stderr,"initially %d objects\n", objcount());
X
X/* now we are ready to start */
X
X# ifdef SIGNALS
Xignore signal(SIGINT, brkfun);
Xignore setjmp(intenv);
X# endif
X# ifdef SSIGNALS
Xignore ssignal(SIGINT, brkfun);
Xignore setjmp(intenv);
X# endif
X
Xprpush(smallobj);
XsendMessage(newSymbol("commandLoop"), getClass(smallobj), 0);
Xflushstack();
X
Xignore fprintf(stderr,"finally %d objects\n", objcount());
X
Xif (argc > 2) {
X if (streq(argv[2],"-"))
X ignore strcpy(fileName, INITIALIMAGE);
X else
X ignore strcpy(fileName, argv[2]);
X# ifdef BINREADWRITE
X fp = fopen(fileName,"wb");
X# endif
X# ifndef BINREADWRITE
X fp = fopen(fileName,"w");
X# endif
X if (fp == NULL)
X sysError("cannot write image file",fileName);
X else {
X ignore fprintf(stderr,"creating image file %s\n", fileName);
X imageWrite(fp);
X ignore fclose(fp);
X }
X }
Xexit(0);
X}
/
echo 'x - mtest.st'
sed 's/^X//' > mtest.st << '/'
X*
X* tests for multiprocessing system
X*
XDeclare Mtest Test
XDeclare Future Object result sem
XInstance Mtest test
XClass Mtest
X all
X super all.
X 'all multiprocessing tests passed' print.
X|
X future | a f |
X a <- List new.
X f <- Future new; eval: [(1 to: 100) do: [:x | nil].
X a addLast: 2. 3].
X a addLast: 1.
X a addLast: f value.
X (a asArray = #(1 2 3))
X ifFalse: [ smalltalk error: 'future error'].
X 'future test passed' print
X]
XClass Future
X new
X sem <- Semaphore new; set: 0
X|
X eval: aBlock
X [ result <- aBlock value. sem signal ] fork
X|
X value
X sem wait.
X sem signal.
X ^ result
X]
X
/
echo 'x - mult.st'
sed 's/^X//' > mult.st << '/'
X*
X* Little Smalltalk, version 2
X* Written by Tim Budd, Oregon State University, July 1987
X*
X* multiprocess scheduler - this is optional
X*
XDeclare Interpreter Object context prev creating stack stackTop byteCodePointer
XDeclare Process Object interpreter yield
XDeclare Scheduler Object processList atomic currentProcess
XDeclare Semaphore Object count processList
XInstance Scheduler scheduler
XClass Block
X newProcess
X ^ (context newInterpreter: bytecodeCounter) newProcess
X|
X fork
X self newProcess resume
X]
XClass Context
X newInterpreter: start
X ^ Interpreter new;
X context: self;
X byteCounter: start;
X stack: (Array new: 20)
X]
XClass Interpreter
X new
X stackTop <- 0.
X byteCodePointer <- 0
X|
X execute
X ^ <19 self>
X|
X byteCounter: start
X byteCodePointer <- start
X|
X context: value
X context <- value
X|
X stack: value
X stack <- value.
X|
X newProcess
X ^ Process new; interpreter: self
X]
XClass Method
X executeWith: arguments
X ( ( Context new ; method: self ;
X temporaries: ( Array new: temporarySize) ;
X arguments: arguments ) newInterpreter: 0 )
X newProcess resume
X]
XClass Process
X execute | i |
X yield <- true.
X i <- 0.
X [ interpreter notNil and: [ yield ]]
X whileTrue: [ interpreter <- interpreter execute.
X i <- i + 1.
X (i > 200) ifTrue: [yield <- false ]].
X (interpreter isNil)
X ifTrue: [ self terminate ]
X|
X interpreter: value
X interpreter <- value
X|
X resume
X scheduler addProcess: self
X|
X terminate
X scheduler removeProcess: self
X|
X yield
X yield <- false
X]
XClass Scheduler
X new
X processList <- Set new.
X atomic <- false
X|
X addProcess: aProcess
X processList add: aProcess
X|
X critical: aBlock
X atomic <- true.
X aBlock value.
X atomic <- false
X|
X currentProcess
X ^ currentProcess
X|
X removeProcess: aProcess
X processList remove: aProcess
X|
X run
X [ processList size ~= 0 ] whileTrue:
X [ processList do:
X [ :x | currentProcess <- x.
X [ x execute. atomic ] whileTrue ] ]
X]
XClass Semaphore
X new
X count <- 0.
X processList <- List new
X|
X critical: aBlock
X self wait.
X aBlock value.
X self signal
X|
X set: aNumber
X count <- aNumber
X|
X signal
X (processList size = 0)
X ifTrue: [ count <- count + 1]
X ifFalse: [ scheduler critical:
X [ processList first resume.
X processList removeFirst ]]
X|
X wait | process |
X (count = 0)
X ifTrue: [ scheduler critical:
X [ process <- scheduler currentProcess.
X processList add: process.
X scheduler removeProcess: process].
X scheduler currentProcess yield ]
X ifFalse: [ count <- count - 1]
X]
/
echo 'x - munix.st'
sed 's/^X//' > munix.st << '/'
X*
X* Little Smalltalk, version 2
X* Written by Tim Budd, Oregon State University, July 1987
X*
X* unix specific routines for the multiprocess front end
X*
X*
XClass Smalltalk
X commandLoop | string |
X self openFiles.
X scheduler new.
X [ string <- stdin getPrompt: '> '. string notNil ]
X whileTrue: [ (string size strictlyPositive)
X ifTrue: [ self doIt: string ] ]
X|
X doIt: aString | method |
X method <- Method new.
X method text: ( 'proceed ', aString ).
X (method compileWithClass: Object)
X ifTrue: [ method executeWith: #( 1 ).
X scheduler run ]
X|
X error: aString | process |
X stderr print: 'Error: ', aString.
X scheduler critical:
X [ process <- scheduler currentProcess.
X scheduler removeProcess: process].
X " flush out current process "
X scheduler currentProcess yield.
X " could we do traceback here?"
X]
/
echo 'x - names.h'
sed 's/^X//' > names.h << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X*/
X/*
X names and sizes of internally object used internally in the system
X*/
X
X# define classSize 6
X# define nameInClass 1
X# define sizeInClass 2
X# define methodsInClass 3
X# define superClassInClass 4
X# define variablesInClass 5
X
X# define methodSize 6
X# define textInMethod 1
X# define messageInMethod 2
X# define bytecodesInMethod 3
X# define literalsInMethod 4
X# define stackSizeInMethod 5
X# define temporarySizeInMethod 6
X
X# define contextSize 6
X# define methodInContext 1
X# define methodClassInContext 2
X# define argumentsInContext 3
X# define temporariesInContext 4
X
X# define blockSize 6
X# define contextInBlock 1
X# define argumentCountInBlock 2
X# define argumentLocationInBlock 3
X# define bytecountPositionInBlock 4
X# define creatingInterpreterInBlock 5
X
X# define InterpreterSize 6
X# define contextInInterpreter 1
X# define previousInterpreterInInterpreter 2
X# define creatingInterpreterInInterpreter 3
X# define stackInInterpreter 4
X# define stackTopInInterpreter 5
X# define byteCodePointerInInterpreter 6
X
Xextern object nameTableLookup(OBJ X OBJ);
X
X# define globalSymbol(s) nameTableLookup(globalNames, newSymbol(s))
X
Xextern object trueobj; /* the pseudo variable true */
Xextern object falseobj; /* the pseudo variable false */
Xextern object smallobj; /* the pseudo variable smalltalk */
Xextern object blockclass; /* the class ``Block'' */
Xextern object contextclass; /* the class ``Context'' */
Xextern object intclass; /* the class ``Integer'' */
Xextern object intrclass; /* the class ``Interpreter'' */
Xextern object symbolclass; /* the class ``Symbol'' */
Xextern object stringclass; /* the class ``String'' */
X
Xextern object getClass(OBJ); /* get class of an object */
Xextern object newSymbol(STR); /* new smalltalk symbol */
Xextern object newArray(INT); /* new array */
Xextern object newStString(STR); /* new smalltalk string */
Xextern object newFloat(FLOAT); /* new floating point number */
Xextern noreturn initCommonSymbols(); /* common symbols */
/
echo 'x - process.h'
sed 's/^X//' > process.h << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X*/
X/*
X constants and types used by process manager.
X See process.c and interp.c for more details.
X*/
X/*
X if there are no enumerated types, make tasks simply integer constants
X*/
X# ifdef NOENUMS
X# define taskType int
X
X# define sendMessageTask 1
X# define sendSuperTask 2
X# define ReturnTask 3
X# define BlockReturnTask 4
X# define BlockCreateTask 5
X# define ContextExecuteTask 6
X
X#endif
X
X# ifndef NOENUMS
X
Xtypedef enum {sendMessageTask, sendSuperTask, ReturnTask, BlockReturnTask,
X BlockCreateTask, ContextExecuteTask} taskType;
X
X# endif
X
Xextern int finalStackTop; /* stack top when finished with interpreter */
Xextern int finalByteCounter; /* bytecode counter when finished with interpreter */
Xextern int argumentsOnStack; /* position of arguments on stack for mess send */
Xextern object messageToSend; /* message to send */
Xextern object returnedObject; /* object returned from message */
Xextern taskType finalTask; /* next task to do (see below) */
Xextern object creator;
X
X
Xextern noreturn sendMessage(OBJ X OBJ X INT);
Xextern noreturn prpush(OBJ);
/
echo 'x - test.st'
sed 's/^X//' > test.st << '/'
X*
X*
X* Little Smalltalk, version 2
X* Written by Tim Budd, Oregon State University, July 1987
X*
X* a few test cases.
X* invoke by messages to global variable ``test'', i.e.
X* test collection
X*
X* all test cases can be run by sending the message all to test
X* test all
X*
XDeclare Test Object
XDeclare One Object
XDeclare Two One
XDeclare Three Two
XDeclare Four Three
XInstance Test test
XClass One
X test
X ^ 1
X|
X result1
X ^ self test
X]
XClass Two
X test
X ^ 2
X]
XClass Three
X result2
X ^ self result1
X|
X result3
X ^ super test
X]
XClass Four
X test
X ^ 4
X]
XClass Test
X all
X self super.
X self conversions.
X self collections.
X self factorial.
X self filein.
X 'all tests completed' print
X|
X conversions
X " test a few conversion routines "
X ( (#abc == #abc asString asSymbol) and: [
X ($A == $A asInteger asCharacter) and: [
X (12 == 12 asDigit digitValue) and: [
X (237 == 237 asString asInteger) and: [
X (43 = 43 asFloat truncated) and: [
X $A == ($A asString at: 1) ] ] ] ] ] )
X ifFalse: [^ smalltalk error: 'conversion failure'].
X 'conversion test passed' print.
X|
X collections
X " test the collection classes a little"
X ( (#(1 2 3 3 2 4 2) asSet = #(1 2 3 4) asSet) and: [
X (#(1 5 3 2 4) sort asArray = #(1 2 3 4 5)) and: [
X ((#+ respondsTo occurrencesOf: Float) = 1) and: [
X ('First' < 'last') ] ] ] )
X ifFalse: [^smalltalk error: 'collection failure'].
X 'collection test passed' print.
X|
X factorial | t |
X t <- [:x | (x = 1) ifTrue: [ 1 ]
X ifFalse: [ x * (t value: x - 1) ] ].
X ((t value: 5) = 5 factorial)
X ifFalse: [ smalltalk error: 'factorial failure'].
X 'factorial test passed' print
X
X|
X filein
X File new; name: 'queen.st'; open: 'r'; fileIn.
X (globalNames includesKey: #Queen )
X ifFalse: [ smalltalk error: 'fileIn failure'].
X 'file in test passed' print.
X self queen
X|
X super2 | x1 x2 x3 x4 |
X x1 <- One new.
X x2 <- Two new.
X x3 <- Three new.
X x4 <- Four new.
X ^ List new; addLast: x1 test;
X addLast: x1 result1;
X addLast: x2 test;
X addLast: x2 result1;
X addLast: x3 test;
X addLast: x4 result1;
X addLast: x3 result2;
X addLast: x4 result2;
X addLast: x3 result3;
X addLast: x4 result3
X|
X super
X (self super2 asArray = #(1 1 2 2 2 4 2 4 2 2) )
X ifTrue: ['super test passed' print]
X ifFalse: [ smalltalk error: 'super test failed']
X]
/
echo 'Part 05 of small.v2 complete.'
exit
--
For comp.sources.unix stuff, mail to sources at uunet.uu.net.
More information about the Comp.sources.unix
mailing list