# This is a shell archive. Remove anything before this line, # then unpack it by saving it in a file and typing "sh file". # # Wrapped by Tim Budd on Wed Mar 24 10:12:19 1993 # # This archive contains: # Makefile README basic.st collect.st # env.h file.st filein.c graphics.st # initial.c install.ms interp.c interp.h # lex.c lex.h mag.st manual.ms # memory.c memory.h mult.st names.c # names.h news.c parser.c primitive.c # queen.st st.c stdevent.h stdtext.h # stdwin.h stdwin.st test.st tty.c # tty.st unixio.c vms.com winprim.c # LANG=""; export LANG PATH=/bin:/usr/bin:$PATH; export PATH echo x - Makefile cat >Makefile <<'@EOF' CFLAGS = -O # define groups of files, to make later commands easier INTERPc = memory.c names.c news.c interp.c INTERPo = memory.o names.o news.o interp.o PRIMITIVEc = primitive.c filein.c lex.c parser.c unixio.c PRIMITIVEo = primitive.o filein.o lex.o parser.o unixio.o basicST = basic.st mag.st collect.st unixST = file.st mult.st testST = test.st queen.st CFILES = *.h $(INTERPc) $(PRIMITIVEc) st.c initial.c tty.c winprim.c OFILES = $(INTERPo) $(PRIMITIVEo) STFILES = $(basicST) $(unixST) $(testST) tty.st graphics.st stdwin.st FILES = README Makefile vms.com $(CFILES) $(STFILES) *.ms # the following are used only by turboc on the ibm pc TURBOc=memory names news interp primitive filein lex parser unixio tty TINCLUDE=c:\turboc\include TLIB=c:\turboc\lib # the following is for those poor souls who say ``make'' without looking help: @echo "select one of the following to make" @echo "bsdtty: Berkeley 4.2/4.3 with teletype interface " @echo "sysvtty: System V with teletype interface " @echo "bsdx11: Berkeley 4.2/4.3 with stdwin interface on top of X11" @echo "ibmturboc: IBM PC with Turbo C compiler (see install.ms)" winfiles: $(OFILES) winprim.o initial.o st.o # initial - the initial object maker initial: $(INTERPo) $(PRIMITIVEo) initial.o $(INTERFACE) cc -o initial $(CFLAGS) $(INTERPo) $(PRIMITIVEo) initial.o $(INTERFACE) -lm $(LIBS) # st - the actual bytecode interpreter st: $(INTERPo) $(PRIMITIVEo) st.o $(INTERFACE) cc -o st $(CFLAGS) $(INTERPo) $(PRIMITIVEo) st.o $(INTERFACE) -lm $(LIBS) # bsdtty - berkeley 4.2/4.3 with tty style interface bsdtty: make "CFLAGS=$(CFLAGS) -DB42" "LIBS=" "INTERFACE= tty.o" initial st initial $(basicST) $(unixST) tty.st bsdtty.lint: lint -DB42 $(INTERPc) $(PRIMITIVEc) tty.c initial.c -lm lint -DB42 $(INTERPc) $(PRIMITIVEc) tty.c st.c -lm # sysvtty - system V with tty style interface sysvtty: make "CFLAGS=$(CFLAGS) -DSYSV" "LIBS=" "INTERFACE= tty.o" initial st initial $(basicST) $(unixST) tty.st sysvtty.lint: lint -DSYSV $(INTERPc) $(PRIMITIVEc) tty.c initial.c -lm lint -DSYSV $(INTERPc) $(PRIMITIVEc) tty.c st.c -lm # bsdterm - berkekey 4.2/4.3 with stdwin interface on top of termcap # requires Guido van Rossum's standard window package # (currently doesn't work) bsdterm: stdw.o make "CFLAGS=$(CFLAGS) -DB42 -DSTDWIN" "LIBS= -ltermcap" "INTERFACE= winprim.o stdw.o" initial st initial $(basicST) $(unixST) graphics.st stdwin.st # bsdx11 - berkekey 4.2/4.3 with stdwin interface on top of x11 # requires Guido van Rossum's standard window package bsdx11: stdw.o make "CFLAGS=$(CFLAGS) -DB42 -DSTDWIN" "LIBS= -lX" "INTERFACE= winprim.o stdw.o" initial st initial $(basicST) $(unixST) graphics.st stdwin.st bsdx11.lint: lint -DB42 -DSTDWIN $(INTERPc) $(PRIMITIVEc) winprim.c initial.c -lm -lX lint -DB42 -DSTDWIN $(INTERPc) $(PRIMITIVEc) winprim.c st.c -lm -lX # ibmturboc - IBM PC with Turbo C compiler # see installation notes for editing that must be performed first ibmturboc: tcc -I$(TINCLUDE) -L$(TLIB) -mc -C -a -w- -est $(TURBOc) st tcc -I$(TINCLUDE) -L$(TLIB) -mc -a -w- initial $(TURBOc) initial basic.st mag.st collect.st file.st mult.st tty.st # stdw.o - guidos van rossum's standard window package stdw.o: @echo to create stdw.o see installation instructions # all the dependencies on .h files filein.o : filein.c env.h memory.h names.h lex.h initial.o : initial.c env.h memory.h names.h interp.o : interp.c env.h memory.h names.h interp.h lex.o : lex.c env.h memory.h lex.h memory.o : memory.c env.h memory.h names.o : names.c env.h memory.h names.h news.o : news.c env.h memory.h names.h parser.o : parser.c env.h memory.h names.h interp.h lex.h primitive.o : primitive.c env.h memory.h names.h st.o : st.c env.h memory.h names.h tty.o : tty.c env.h memory.h unixio.o : unixio.c env.h memory.h names.h winprim.o : winprim.c stdwin.h stdevent.h stdtext.h env.h memory.h names.h # - pack - pack up the files for mailing pack: $(FILES) packmail $(FILES) # - tar - make a compressed tar file tar: $(FILES) tar cvf small.v3.tar $(FILES) compress small.v3.tar @EOF chmod 644 Makefile echo x - README cat >README <<'@EOF' this is little smalltalk version 3. Read the document install.ms (to typeset use troff -ms) for installation instruction. The document manual.ms provides the start of a manual; needs to be rewritten. Please report bugs, and one of these days I may even find time to fix them! --tim budd @EOF chmod 644 README echo x - basic.st cat >basic.st <<'@EOF' * * Little Smalltalk, version 3 * basic methods needed for execution, including * object creation * block creation, execution and return * Class Object Class Block Object context argCount argLoc bytePointer Class Boolean Object Class True Boolean Class False Boolean Class Class Object name instanceSize methods superClass variables Class Context Object linkLocation method arguments temporaries Class Integer Object Class Method Object text message bytecodes literals stackSize temporarySize class watch Class Smalltalk Object Class Switch Object const notdone Class Symbol Object Class UndefinedObject Object * Methods Block 'initialization' checkArgumentCount: count ^ (argCount = count) ifTrue: [ true ] ifFalse: [ smalltalk error: 'wrong number of arguments passed to block'. false ] | blockContext: ctx context <- ctx | value ^ (self checkArgumentCount: 0) ifTrue: [ context returnToBlock: bytePointer ] | value: x ^ (self checkArgumentCount: 1) ifTrue: [ context at: argLoc put: x. context returnToBlock: bytePointer ] | value: x value: y ^ (self checkArgumentCount: 2) ifTrue: [ context at: argLoc put: x. context at: argLoc + 1 put: y. context returnToBlock: bytePointer ] | value: x value: y value: z ^ (self checkArgumentCount: 3) ifTrue: [ context at: argLoc put: x. context at: argLoc + 1 put: y. context at: argLoc + 2 put: z. context returnToBlock: bytePointer ] | whileTrue: aBlock ( self value ) ifTrue: [ aBlock value. self whileTrue: aBlock ] | whileTrue self whileTrue: [] | whileFalse: aBlock [ self value not ] whileTrue: aBlock ] Methods Boolean 'all' ifTrue: trueBlock ^ self ifTrue: trueBlock ifFalse: [] | ifFalse: falseBlock ^ self ifTrue: [] ifFalse: falseBlock | ifFalse: falseBlock ifTrue: trueBlock ^ self ifTrue: trueBlock ifFalse: falseBlock | and: aBlock ^ self ifTrue: aBlock ifFalse: [ false ] | or: aBlock ^ self ifTrue: [ true ] ifFalse: aBlock ] Methods Class 'creation' new | newObject | newObject <- self new: instanceSize. ^ (self == Class) ifTrue: [ newObject initialize ] ifFalse: [ newObject new ] | new: size " hack out block the right size and class " "create a new block, set its class" ^ < 22 < 58 size > self > | addSubClass: aSymbol instanceVariableNames: aString | newClass | newClass <- Class new; name: aSymbol; superClass: self; variables: (aString words: [:x | x isAlphabetic ]). aSymbol assign: newClass. classes at: aSymbol put: newClass | initialize superClass <- Object. instanceSize <- 0. methods <- Dictionary new | methods ^ methods | methodNamed: name (methods includesKey: name) ifTrue: [ ^ methods at: name ]. (superClass notNil) ifTrue: [ ^ superClass methodNamed: name ]. ^ nil | name ^ name | name: aString name <- aString | instanceSize ^ instanceSize | printString ^ name asString | respondsTo | theSet | theSet <- Dictionary new. self upSuperclassChain: [:x | theSet addAll: x methods ]. ^ theSet | subClasses ^ classes inject: List new into: [:x :y | (y superClass == self) ifTrue: [ x add: y]. x ] | superClass ^ superClass | superClass: aClass superClass <- aClass | upSuperclassChain: aBlock aBlock value: self. (superClass notNil) ifTrue: [ superClass upSuperclassChain: aBlock ] | variables ^ variables | variables: nameArray variables <- nameArray. instanceSize <- superClass instanceSize + nameArray size | watch: name | m | m <- self methodNamed: name. (m notNil) ifTrue: [ ^ m watch: [:a | ('executing ', name) print. a print] ] ifFalse: [ ^ 'no such method' ] ] Methods Context 'all' at: key put: value temporaries at: key put: value | method: m method <- m | arguments: a arguments <- a | temporaries: t temporaries <- t | returnToBlock: bytePtr " change the location we will return to, to execute a block" <28 self bytePtr> | copy ^ super copy temporaries: temporaries copy | blockReturn <18 self> ifFalse: [ ^ smalltalk error: 'incorrect context for block return'] ] Methods False 'all' ifTrue: trueBlock ifFalse: falseBlock ^ falseBlock value | not ^ true | xor: aBoolean ^ aBoolean | printString ^ 'false' ] Methods Method 'all' compileWithClass: aClass ^ <39 aClass text self> | name ^ message | message: aSymbol message <- aSymbol | printString ^ message asString | signature ^ class asString,' ', message asString | text ^ (text notNil) ifTrue: [ text ] ifFalse: [ 'text not saved'] | text: aString text <- aString | display ('Method ', message) print. 'text' print. text print. 'literals' print. literals print. 'bytecodes' print. bytecodes class print. bytecodes do: [:x | (x printString, ' ', (x quo: 16), ' ', (x rem: 16)) print ] | executeWith: arguments ^ ( Context new ; method: self ; temporaries: ( Array new: temporarySize) ; arguments: arguments ) returnToBlock: 1 | watch: aBlock watch <- aBlock | watchWith: arguments " note that we are being watched " text print. watch value: arguments. ^ self executeWith: arguments ] Methods Object 'all' assign: name value: val ^ name assign: val | == aValue ^ <21 self aValue> | ~~ aValue ^ (self == aValue) not | = aValue ^ self == aValue | asString ^ self printString | basicAt: index ^ <25 self index> | basicAt: index put: value ^ <31 self index value> | basicSize ^ <12 self> | class ^ <11 self> | copy ^ self shallowCopy | deepCopy | newObj | newObj <- self class new. (1 to: self basicSize) do: [:i | newObj basicAt: i put: (self basicAt: i) copy]. ^ newObj | display ('(Class ', self class, ') ' , self printString ) print | hash ^ <13 self> | isMemberOf: aClass ^ self class == aClass | isNil ^ false | isKindOf: aClass self class upSuperclassChain: [:x | (x == aClass) ifTrue: [ ^ true ] ]. ^ false | new " default initialization protocol" ^ self | notNil ^ true | print self printString print | printString ^ self class printString | respondsTo: message self class upSuperclassChain: [:c | (c methodNamed: message) notNil ifTrue: [ ^ true ]]. ^ false | shallowCopy | newObj | newObj <- self class new. (1 to: self basicSize) do: [:i | newObj basicAt: i put: (self basicAt: i) ]. ^ newObj ] Methods Smalltalk 'all' perform: message withArguments: args ifError: aBlock | receiver method | receiver <- args at: 1 ifAbsent: [ ^ aBlock value ]. method <- receiver class methodNamed: message. ^ method notNil ifTrue: [ method executeWith: args ] ifFalse: aBlock | perform: message withArguments: args ^ self perform: message withArguments: args ifError: [ self error: 'cant perform' ] | watch ^ <5> ] Methods True 'all' ifTrue: trueBlock ifFalse: falseBlock ^ trueBlock value | not ^ false | xor: aBoolean ^ aBoolean not | printString ^ 'true' ] Methods Switch 'all' key: value const <- value. notdone <- true. | ifMatch: key do: block (notdone and: [ const = key ]) ifTrue: [ notdone <- false. block value ] | else: block notdone ifTrue: [ notdone <- false. block value ] ] Methods Symbol 'all' apply: args ^ self apply: args ifError: [ 'does not apply' ] | apply: args ifError: aBlock ^ smalltalk perform: self withArguments: args ifError: aBlock | assign: value <27 self value>. ^ value | asString " catenation makes string and copy automatically " ^ <24 self ''> | copy ^ self | printString ^ '#' , self asString | respondsTo ^ classes inject: Set new into: [:x :y | ((y methodNamed: self) notNil) ifTrue: [ x add: y]. x] | value ^ <87 self> ] Methods UndefinedObject 'all' isNil ^ true | notNil ^ false | printString ^ 'nil' ] Methods Object 'errors' message: m notRecognizedWithArguments: a ^ smalltalk error: 'not recognized ', (self class printString), ' ', (m printString) ] @EOF chmod 644 basic.st echo x - collect.st cat >collect.st <<'@EOF' * * Little Smalltalk, version 3 * Written by Tim Budd, Oregon State University, July 1988 * * methods for Collection classes * Class Link Object key value nextLink Class Collection Magnitude Class IndexedCollection Collection Class Array IndexedCollection Class ByteArray Array Class String ByteArray Class Dictionary IndexedCollection hashTable Class Interval Collection lower upper step Class List Collection links Class Set List * Methods Array 'all' < coll (coll isKindOf: Array) ifTrue: [ self with: coll do: [:x :y | (x = y) ifFalse: [ ^ x < y ]]. ^ self size < coll size ] ifFalse: [ ^ super < coll ] | = coll (coll isKindOf: Array) ifTrue: [ (self size = coll size) ifFalse: [ ^ false ]. self with: coll do: [:x :y | (x = y) ifFalse: [ ^ false ] ]. ^ true ] ifFalse: [ ^ super = coll ] | at: index put: value (self includesKey: index) ifTrue: [ self basicAt: index put: value ] ifFalse: [ smalltalk error: 'illegal index to at:put: for array' ] | binaryDo: aBlock (1 to: self size) do: [:i | aBlock value: i value: (self at: i) ] | collect: aBlock | s newArray | s <- self size. newArray <- Array new: s. (1 to: s) do: [:i | newArray at: i put: (aBlock value: (self at: i))]. ^ newArray | copyFrom: low to: high | newArray newlow newhigh | newlow <- low max: 1. newhigh <- high min: self size. newArray <- self class new: (0 max: newhigh - newlow + 1). (newlow to: newhigh) do: [:i | newArray at: ((i - newlow) + 1) put: (self at: i) ]. ^ newArray | deepCopy ^ self deepCopyFrom: 1 to: self size | deepCopyFrom: low to: high | newArray newlow newhigh | newlow <- low max: 1. newhigh <- high min: self size. newArray <- self class new: (0 max: newhigh - newlow + 1). (newlow to: newhigh) do: [:i | newArray at: ((i - newlow) + 1) put: (self at: i) copy ]. ^ newArray | do: aBlock (1 to: self size) do: [:i | aBlock value: (self at: i) ] | exchange: a and: b | temp | temp <- self at: a. self at: a put: (self at: b). self at: b put: temp | grow: aValue | s newArray | s <- self size. newArray <- Array new: s + 1. (1 to: s) do: [:i | newArray at: i put: (self at: i)]. newArray at: s+1 put: aValue. ^ newArray | includesKey: index ^ index between: 1 and: self size | new ^ smalltalk error: 'arrays and strings cannot be created using new' | reverseDo: aBlock (self size to: 1 by: -1) do: [:i | aBlock value: (self at: i) ] | select: aCond | newList | newList <- List new. self do: [:i | (aCond value: i) ifTrue: [newList addLast: i]]. ^ newList asArray | shallowCopy ^ self copyFrom: 1 to: self size | size ^ self basicSize | with: newElement | s newArray | s <- self size. newArray <- Array new: (s + 1). (1 to: s) do: [:i | newArray at: i put: (self at: i) ]. newArray at: s+1 put: newElement. ^ newArray | with: coll do: aBlock (1 to: (self size min: coll size)) do: [:i | aBlock value: (self at: i) value: (coll at: i) ] | with: coll ifAbsent: z do: aBlock | xsize ysize | xsize <- self size. ysize <- coll size. (1 to: (xsize max: ysize)) do: [:i | aBlock value: (i <= xsize ifTrue: [ self at: i ] ifFalse: [ z ]) value: (i <= ysize ifTrue: [ coll at: i ] ifFalse: [ z ])] ] Methods ByteArray 'all' asString <22 self String> | basicAt: index put: value ^ ((value isMemberOf: Integer) and: [value between: 0 and: 255]) ifTrue: [ <32 self index value > ] ifFalse: [ value print. smalltalk error: 'assign illegal value to ByteArray'] | basicAt: index ^ <26 self index> | size: value ^ <22 <59 value> ByteArray> ] Methods Collection 'all' < coll (coll respondsTo: #includes:) ifFalse: [ ^ smalltalk error: 'collection compared to non collection']. self do: [:x | ((self occurrencesOf: x) < (coll occurrencesOf: x))ifFalse: [ ^ false ]]. coll do: [:x | (self includes: x) ifFalse: [ ^ true ]]. ^ false | = coll self do: [:x | (self occurrencesOf: x) = (coll occurrencesOf: x) ifFalse: [ ^ false ] ]. ^ true | asArray | newArray i | newArray <- Array new: self size. i <- 0. self do: [:x | i <- i + 1. newArray at: i put: x]. ^ newArray | asByteArray | newArray i | newArray <- ByteArray new size: self size. i <- 0. self do: [:x | i <- i + 1. newArray at: i put: x]. ^ newArray | asSet ^ Set new addAll: self | asString ^ self asByteArray asString | display self do: [:x | x print ] | includes: value self do: [:x | (x = value) ifTrue: [ ^ true ] ]. ^ false | inject: thisValue into: binaryBlock | last | last <- thisValue. self do: [:x | last <- binaryBlock value: last value: x]. ^ last | isEmpty ^ self size == 0 | occurrencesOf: anObject ^ self inject: 0 into: [:x :y | (y = anObject) ifTrue: [x + 1] ifFalse: [x] ] | printString ^ ( self inject: self class printString , ' (' into: [:x :y | x , ' ' , y printString]), ' )' | size ^ self inject: 0 into: [:x :y | x + 1] | sort: aBlock ^ self inject: List new into: [:x :y | x add: y ordered: aBlock. x] | sort ^ self sort: [:x :y | x < y ] ] Methods Dictionary 'all' new hashTable <- Array new: 39 | hash: aKey ^ 3 * ((aKey hash) rem: ((hashTable size) quo: 3)) | at: aKey ifAbsent: exceptionBlock | hashPosition link | hashPosition <- self hash: aKey. ((hashTable at: hashPosition + 1) = aKey) ifTrue: [ ^ hashTable at: hashPosition + 2]. link <- hashTable at: hashPosition + 3. ^ (link notNil) ifTrue: [ link at: aKey ifAbsent: exceptionBlock ] ifFalse: exceptionBlock | at: aKey put: aValue | hashPosition link | hashPosition <- self hash: aKey. ((hashTable at: hashPosition + 1) isNil) ifTrue: [ hashTable at: hashPosition + 1 put: aKey ]. ((hashTable at: hashPosition + 1) = aKey) ifTrue: [ hashTable at: hashPosition + 2 put: aValue ] ifFalse: [ link <- hashTable at: hashPosition + 3. (link notNil) ifTrue: [ link at: aKey put: aValue ] ifFalse: [ hashTable at: hashPosition + 3 put: (Link new; key: aKey; value: aValue)]] | binaryDo: aBlock (1 to: hashTable size by: 3) do: [:i | (hashTable at: i) notNil ifTrue: [ aBlock value: (hashTable at: i) value: (hashTable at: i+1) ]. (hashTable at: i+2) notNil ifTrue: [ (hashTable at: i+2) binaryDo: aBlock ] ] | display self binaryDo: [:x :y | (x printString , ' -> ', y printString ) print ] | includesKey: aKey " look up, but throw away result " self at: aKey ifAbsent: [ ^ false ]. ^ true | removeKey: aKey ^ self removeKey: aKey ifAbsent: [ smalltalk error: 'remove key not found'] | removeKey: aKey ifAbsent: exceptionBlock ^ (self includesKey: aKey) ifTrue: [ self basicRemoveKey: aKey ] ifFalse: exceptionBlock | basicRemoveKey: aKey | hashPosition link | hashPosition <- self hash: aKey. ((hashTable at: hashPosition + 1) = aKey) ifTrue: [ hashTable at: hashPosition + 1 put: nil. hashTable at: hashPosition + 2 put: nil] ifFalse: [ link <- hashTable at: hashPosition + 3. (link notNil) ifTrue: [ hashTable at: hashPosition + 3 put: (link removeKey: aKey) ]] ] Methods IndexedCollection 'all' addAll: aCollection aCollection binaryDo: [:i :x | self at: i put: x ] | asArray ^ Array new: self size ; addAll: self | asDictionary ^ Dictionary new ; addAll: self | at: aKey ^ self at: aKey ifAbsent: [ smalltalk error: 'index to at: illegal' ] | at: index ifAbsent: exceptionBlock ^ (self includesKey: index) ifTrue: [ self basicAt: index ] ifFalse: exceptionBlock | binaryInject: thisValue into: aBlock | last | last <- thisValue. self binaryDo: [:i :x | last <- aBlock value: last value: i value: x]. ^ last | collect: aBlock ^ self binaryInject: Dictionary new into: [:s :i :x | s at: i put: (aBlock value: x). s] | do: aBlock self binaryDo: [:i :x | aBlock value: x ] | keys ^ self binaryInject: Set new into: [:s :i :x | s add: i ] | indexOf: aBlock ^ self indexOf: aBlock ifAbsent: [ smalltalk error: 'index not found'] | indexOf: aBlock ifAbsent: exceptionBlock self binaryDo: [:i :x | (aBlock value: x) ifTrue: [ ^ i ] ]. ^ exceptionBlock value | select: aBlock ^ self binaryInject: Dictionary new into: [:s :i :x | (aBlock value: x) ifTrue: [ s at: i put: x ]. s ] | values ^ self binaryInject: List new into: [:s :i :x | s add: x ] ] Methods Interval 'all' do: aBlock | current | current <- lower. (step > 0) ifTrue: [ [ current <= upper ] whileTrue: [ aBlock value: current. current <- current + step ] ] ifFalse: [ [ current >= upper ] whileTrue: [ aBlock value: current. current <- current + step ] ] | lower: aValue lower <- aValue | upper: aValue upper <- aValue | step: aValue step <- aValue ] Methods Link 'all' add: newValue whenFalse: aBlock (aBlock value: value value: newValue) ifTrue: [ (nextLink notNil) ifTrue: [ nextLink <- nextLink add: newValue whenFalse: aBlock ] ifFalse: [ nextLink <- Link new; value: newValue] ] ifFalse: [ ^ Link new; value: newValue; link: self ] | at: aKey ifAbsent: exceptionBlock (aKey = key) ifTrue: [ ^value ] ifFalse: [ ^ (nextLink notNil) ifTrue: [ nextLink at: aKey ifAbsent: exceptionBlock ] ifFalse: exceptionBlock ] | at: aKey put: aValue (aKey = key) ifTrue: [ value <- aValue ] ifFalse: [ (nextLink notNil) ifTrue: [ nextLink at: aKey put: aValue] ifFalse: [ nextLink <- Link new; key: aKey; value: aValue] ] | binaryDo: aBlock aBlock value: key value: value. (nextLink notNil) ifTrue: [ nextLink binaryDo: aBlock ] | key: aKey key <- aKey | includesKey: aKey (key = aKey) ifTrue: [ ^ true ]. (nextLink notNil) ifTrue: [ ^ nextLink includesKey: aKey ] ifFalse: [ ^ false ] | link: aLink nextLink <- aLink | next ^ nextLink | removeKey: aKey (aKey = key) ifTrue: [ ^ nextLink ] ifFalse: [ (nextLink notNil) ifTrue: [ nextLink <- nextLink removeKey: aKey]] | removeValue: aValue (aValue = value) ifTrue: [ ^ nextLink ] ifFalse: [ (nextLink notNil) ifTrue: [ nextLink <- nextLink removeValue: aValue]] | reverseDo: aBlock (nextLink notNil) ifTrue: [ nextLink reverseDo: aBlock ]. aBlock value: value | size (nextLink notNil) ifTrue: [ ^ 1 + nextLink size] ifFalse: [ ^ 1 ] | value: aValue value <- aValue | value ^ value ] Methods List 'all' add: aValue ^ self addLast: aValue | add: aValue ordered: aBlock (links isNil) ifTrue: [ self addFirst: aValue] ifFalse: [ links <- links add: aValue whenFalse: aBlock ] | addAll: aValue aValue do: [:x | self add: x ] | addFirst: aValue links <- Link new; value: aValue; link: links | addLast: aValue (links isNil) ifTrue: [ self addFirst: aValue ] ifFalse: [ links add: aValue whenFalse: [ :x :y | true ] ] | collect: aBlock ^ self inject: self class new into: [:x :y | x add: (aBlock value: y). x ] | links ^ links "used to walk two lists in parallel " | reject: aBlock ^ self select: [:x | (aBlock value: x) not ] | reverseDo: aBlock (links notNil) ifTrue: [ links reverseDo: aBlock ] | select: aBlock ^ self inject: self class new into: [:x :y | (aBlock value: y) ifTrue: [x add: y]. x] | do: aBlock (links notNil) ifTrue: [ links binaryDo: [:x :y | aBlock value: y]] | first ^ (links notNil) ifTrue: links ifFalse: [ smalltalk error: 'first on empty list'] | removeFirst self remove: self first | remove: value (links notNil) ifTrue: [ links <- links removeValue: value ] | size (links isNil) ifTrue: [ ^ 0 ] ifFalse: [ ^ links size ] ] Methods Set 'all' add: value (self includes: value) ifFalse: [ self addFirst: value ] ] Methods String 'all' , value (value isMemberOf: String) ifTrue: [ (self size + value size) > 2000 ifTrue: [ 'string too large' print. ^ self ] ifFalse: [ ^ <24 self value> ] ] ifFalse: [ ^ self , value asString ] | = value (value isKindOf: String) ifTrue: [ ^ super = value ] ifFalse: [ ^ false ] | < value (value isKindOf: String) ifTrue: [ ^ super < value ] ifFalse: [ ^ false ] | asByteArray | newArray i | newArray <- ByteArray new size: self size. i <- 0. self do: [:x | i <- i + 1. newArray at: i put: x asInteger]. ^ newArray | asInteger ^ self inject: 0 into: [:x :y | x * 10 + y digitValue ] | basicAt: index ^ (super basicAt: index) asCharacter | basicAt: index put: aValue (aValue isMemberOf: Char) ifTrue: [ super basicAt: index put: aValue asInteger ] ifFalse: [ smalltalk error: 'cannot put non Char into string' ] | asSymbol ^ <83 self> | copy " catenation makes copy automatically " ^ '',self | copyFrom: position1 to: position2 ^ <33 self position1 position2> | hash ^ <82 self> | printString ^ '''' , self, '''' | size ^ <81 self> | words: aBlock | text index list | list <- List new. text <- self. [ text <- text copyFrom: (text indexOf: aBlock ifAbsent: [ text size + 1]) to: text size. text size > 0 ] whileTrue: [ index <- text indexOf: [:x | (aBlock value: x) not ] ifAbsent: [ text size + 1]. list addLast: (text copyFrom: 1 to: index - 1). text <- text copyFrom: index to: text size ]. ^ list asArray | value " evaluate self as an expression " ^ ( '^ [ ', self, ' ] value' ) execute | execute | meth | " execute self as body of a method " meth <- Method new; text: 'compile ', self. (meth compileWithClass: Object) ifTrue: [ ^ meth executeWith: #(0) ]. ^ nil | unixCommand ^ <88 self> ] @EOF chmod 644 collect.st echo x - env.h cat >env.h <<'@EOF' /* Little Smalltalk, version two Written by Tim Budd, Oregon State University, July 1987 environmental factors This include file gathers together environmental factors that are likely to change from one C compiler to another, or from one system to another. Please refer to the installation notes for more information. for systems using the Make utility, the system name is set by the make script. other systems (such as the Mac) should put a define statement at the beginning of the file, as shown below */ /* systems that don't use the Make utility should do something like this: # define LIGHTC */ /*=============== rules for various systems ====================*/ # ifdef B42 /* Berkeley 4.2, 4.3 and compatible running tty interface */ /* which include: */ /* sequent balance */ /* Harris HCX-7 */ /* sun workstations */ typedef unsigned char byte; # define byteToInt(b) (b) /* this is a bit sloppy - but it works */ # define longCanBeInt(l) ((l >= -16383) && (l <= 16383)) # define STRINGS # define SIGNAL # endif # ifdef SYSV /* system V systems including: */ /* HP-UX for the HP-9000 series */ typedef unsigned char byte; # define byteToInt(b) (b) # define longCanBeInt(l) ((l >= -16383) && (l <= 16383)) # define STRING # define SIGNAL # endif # ifdef TURBOC /* IBM PC and compatiables using the TURBO C compiler */ /* there are also changes that have to be made to the smalltalk source; see installation notes for details */ typedef unsigned char byte; # define byteToInt(b) (b) # define longCanBeInt(l) ((l >= -16383) && (l <= 16383)) # define STRING # define ALLOC # define BINREADWRITE # define CTRLBRK # define PROTO # define obtalloc(x,y) (struct objectStruct huge *) farcalloc((unsigned long) x, (unsigned long) y) #endif # ifdef ATARI /* Atari st 1040 - still exprimental */ typedef unsigned char byte; # define byteToInt(b) (b) # define longCanBeInt(l) ((l >= -16383) && (l <= 16383)) # define STRING # define ALLOC # define BINREADWRITE # define obtalloc(x,y) (struct objectStruct *) calloc((unsigned) x, (unsigned) y) #endif # ifdef LIGHTC /* Macintosh using Lightspeed C compiler */ /* see install.ms for other changes */ typedef unsigned char byte; # define byteToInt(b) (b) # define longCanBeInt(l) ((l >= -16383) && (l <= 16383)) # define STRINGS # define BINREADWRITE # define STDWIN # define NOARGC # define PROTO # define NOSYSTEM # define obtalloc(x,y) (struct objectStruct *) calloc((unsigned) x, (unsigned) y) # endif # ifdef VMS /* VAX VMS */ typedef unsigned char byte; # define byteToInt(b) (b) # define longCanBeInt(l) ((l >= -16383) && (l <= 16383)) # define STRING # define NOARGC # endif /* ======== various defines that should work on all systems ==== */ # define streq(a,b) (strcmp(a,b) == 0) # define true 1 # define false 0 /* define the datatype boolean */ # ifdef NOTYPEDEF # define boolean int # endif # ifndef NOTYPEDEF typedef int boolean; # endif /* define a bit of lint silencing */ /* ignore means ``i know this function returns something, but I really, really do mean to ignore it */ # ifdef NOVOID # define ignore # define noreturn # define void int # endif # ifndef NOVOID # define ignore (void) # define noreturn void # endif /* prototypes are another problem. If they are available, they should be used; but if they are not available their use will cause compiler errors. To get around this we define a lot of symbols which become nothing if prototypes aren't available */ # ifdef PROTO # define X , # define OBJ object # define OBJP object * # define INT int # define BOOL boolean # define STR char * # define FLOAT double # define NOARGS void # define FILEP FILE * # define FUNC () # endif # ifndef PROTO # define X # define OBJ # define OBJP # define INT # define BOOL # define STR # define FLOAT # define NOARGS # define FILEP # define FUNC # endif @EOF chmod 644 env.h echo x - file.st cat >file.st <<'@EOF' * * Little Smalltalk, version 3 * Written by Tim Budd, Oregon State University, January 1989 * * methods for dealing with files * these are independent of the stdio package, * work in all systems * * a global variable "files" maintains all currently opened files * these are reopened on system initialization time * Class File Object name number mode * Methods File 'all' asString | text line | text <- ''. [ (line <- self getString) notNil ] whileTrue: [ text <- text , line ]. ^ text | name: string name <- string | name ^ name | getNumber " get a file number - called only by open" (1 to: 15) do: [:i | (files at: i) isNil ifTrue: [ files at: i put: self. number <- i. ^ nil]] | open: m self mode: m. self open | mode: m mode <- m | open number notNil ifTrue: [ self close ]. self getNumber. <120 number name mode> isNil ifTrue: [ smalltalk error: 'open failed: ', name. ^ false]. ^ true | close " close file, take entry out of global variable " number isNil ifTrue: [ ^ nil ]. files at: number put: nil. <121 number>. number <- nil. | fileIn " read code into the system " (number notNil) ifTrue: [<123 number>] | fileIn: name self name: name. self open: 'r'. self fileIn. self close. | getString ^ (number notNil) ifTrue: [<125 number>] | print: aString (number notNil) ifTrue: [<129 number aString>] ifFalse: [smalltalk error: 'file not open'] | printNoReturn: aString (number notNil) ifTrue: [<128 number aString>] ifFalse: [smalltalk error: 'file not open'] | readUntil: conditionBlock doing: actionBlock | line | [ line <- self getString. line notNil] whileTrue: [ (conditionBlock value: line) ifTrue: [ ^ line ]. actionBlock value: line ]. ^ nil | saveImage " subtle problem - when we read in image don't want image file to be open for writing, so we remove it's number from files array temporarily " (number notNil) ifTrue: [ files at: number put: nil. <127 number>. files at: number put: self] ifFalse: [smalltalk error: 'saveImage: file not open'] ] Methods File 'all' scratchFile name <- 'junk.tmp' | delete ('rm ', name) unixCommand ] Methods Smalltalk 'image' saveImage self saveImage: (self getPrompt: 'type image name: '). ^ 'done' | saveImage: name scheduler critical: [ " first get rid of our own process " scheduler removeProcess: scheduler currentProcess. File new; name: name; open: 'w'; saveImage; close ] ] Methods Class 'all' fileOut | f | " file out whole class on class.st " f <- File new; name: (name asString,'.st'); mode: 'w'; open. self fileOutOn: f. f close. | fileOutOn: aFile " file out class description " aFile printNoReturn: 'Class ', name , ' ', superClass. (variables notNil) ifTrue: [ variables do: [:v | aFile printNoReturn: ' ', v ]]. aFile print: ''. self fileOutMethodsOn: aFile. | fileOutMethodsOn: aFile " file out all methods " methods do: [:m | aFile print: 'Methods ', name. aFile print: m text. aFile print: ']' ] ] @EOF chmod 644 file.st echo x - filein.c cat >filein.c <<'@EOF' /* Little Smalltalk, version 3 Written by Tim Budd, Oregon State University, June 1988 routines used in reading in textual descriptions of classes */ # include # include "env.h" # include "memory.h" # include "names.h" # include "lex.h" # ifdef STRING # include # endif # ifdef STRINGS # include # endif # define MethodTableSize 39 /* the following are switch settings, with default values */ boolean savetext = true; /* we read the input a line at a time, putting lines into the following buffer. In addition, all methods must also fit into this buffer. */ # define TextBufferSize 1024 static char textBuffer[TextBufferSize]; /* findClass gets a class object, either by finding it already or making it in addition, it makes sure it has a size, by setting the size to zero if it is nil. */ static object findClass(name) char *name; { object newobj; newobj = globalSymbol(name); if (newobj == nilobj) newobj = newClass(name); if (basicAt(newobj, sizeInClass) == nilobj) { basicAtPut(newobj, sizeInClass, newInteger(0)); } return newobj; } /* readDeclaration reads a declaration of a class */ static readClassDeclaration() { object classObj, super, vars; int i, size, instanceTop; object instanceVariables[15]; if (nextToken() != nameconst) sysError("bad file format","no name in declaration"); classObj = findClass(tokenString); size = 0; if (nextToken() == nameconst) { /* read superclass name */ super = findClass(tokenString); basicAtPut(classObj, superClassInClass, super); size = intValue(basicAt(super, sizeInClass)); ignore nextToken(); } if (token == nameconst) { /* read instance var names */ instanceTop = 0; while (token == nameconst) { instanceVariables[instanceTop++] = newSymbol(tokenString); size++; ignore nextToken(); } vars = newArray(instanceTop); for (i = 0; i < instanceTop; i++) { basicAtPut(vars, i+1, instanceVariables[i]); } basicAtPut(classObj, variablesInClass, vars); } basicAtPut(classObj, sizeInClass, newInteger(size)); } /* readClass reads a class method description */ static readMethods(fd, printit) FILE *fd; boolean printit; { object classObj, methTable, theMethod, selector; # define LINEBUFFERSIZE 512 char *cp, *eoftest, lineBuffer[LINEBUFFERSIZE]; if (nextToken() != nameconst) sysError("missing name","following Method keyword"); classObj = findClass(tokenString); setInstanceVariables(classObj); if (printit) cp = charPtr(basicAt(classObj, nameInClass)); /* now find or create a method table */ methTable = basicAt(classObj, methodsInClass); if (methTable == nilobj) { /* must make */ methTable = newDictionary(MethodTableSize); basicAtPut(classObj, methodsInClass, methTable); } /* now go read the methods */ do { if (lineBuffer[0] == '|') /* get any left over text */ strcpy(textBuffer,&lineBuffer[1]); else textBuffer[0] = '\0'; while((eoftest = fgets(lineBuffer, LINEBUFFERSIZE, fd)) != NULL) { if ((lineBuffer[0] == '|') || (lineBuffer[0] == ']')) break; ignore strcat(textBuffer, lineBuffer); } if (eoftest == NULL) { sysError("unexpected end of file","while reading method"); break; } /* now we have a method */ theMethod = newMethod(); if (parse(theMethod, textBuffer, savetext)) { selector = basicAt(theMethod, messageInMethod); basicAtPut(theMethod, methodClassInMethod, classObj); if (printit) dspMethod(cp, charPtr(selector)); nameTableInsert(methTable, (int) selector, selector, theMethod); } else { /* get rid of unwanted method */ incr(theMethod); decr(theMethod); givepause(); } } while (lineBuffer[0] != ']'); } /* fileIn reads in a module definition */ fileIn(fd, printit) FILE *fd; boolean printit; { while(fgets(textBuffer, TextBufferSize, fd) != NULL) { lexinit(textBuffer); if (token == inputend) ; /* do nothing, get next line */ else if ((token == binary) && streq(tokenString, "*")) ; /* do nothing, its a comment */ else if ((token == nameconst) && streq(tokenString, "Class")) readClassDeclaration(); else if ((token == nameconst) && streq(tokenString,"Methods")) readMethods(fd, printit); else sysError("unrecognized line", textBuffer); } } @EOF chmod 644 filein.c echo x - graphics.st cat >graphics.st <<'@EOF' * * graphics support routines * used by the standard windows version * requires basic routines * written by tim budd, January 1989 * Class Point Magnitude x y Class Rectangle Object top left bottom right Class Circle Object center radius * Methods Number 'point' @ v ^ Point new; x: self; y: v ] Methods Object 'testing' isPoint ^ false ] Methods Point 'all' <= aPoint ^ (x <= aPoint x) and: [y <= aPoint y] | = aPoint aPoint isPoint ifTrue: [ ^ (x = aPoint x) and: [y = aPoint y] ] ifFalse: [ ^ false ] | + v v isPoint ifTrue: [ ^ Point new; x: x + v x; y: y + v y ] ifFalse: [ ^ Point new; x: x + v; y: y + v] | - v v isPoint ifTrue: [ ^ Point new; x: x - v x; y: y - v y ] ifFalse: [ ^ Point new; x: x - v; y: y - v] | * v ^ Point new; x: x * v; y: y * v | printString ^ x printString , '@', y printString | isPoint ^ true | size: aPoint ^ self to: self + aPoint | to: aPoint " return a rectangle with the given dimensions " ^ Rectangle new; upperLeft: self; bottomRight: aPoint | radius: n ^ Circle new; center: self; radius: n | x: v x <- v | y: v y <- v | x ^ x | y ^ y ] Methods Rectangle 'all' + v ^ Rectangle new; bottomRight: right@bottom + v; upperLeft: left@top + v | - v ^ Rectangle new; bottomRight: right@bottom - v; upperLeft: left@top - v | bottomRight: aPoint right <- aPoint x. bottom <- aPoint y. | contains: aPoint ^ aPoint between: left@top and: right@bottom | upperLeft: aPoint left <- aPoint x. top <- aPoint y. | inset: aPoint self upperLeft: left@top + aPoint. self bottomRight: right@bottom - aPoint | printString ^ ((left@top) printString) , ':', ((right@bottom) printString) ] Methods Circle 'all' center: c center <- c | radius: r radius <- r ] @EOF chmod 644 graphics.st echo x - initial.c cat >initial.c <<'@EOF' /* Little Smalltalk, version 3 Written by Tim Budd, June 1988 initial image maker */ # include # include "env.h" # include "memory.h" # include "names.h" int initial = 1; /* making initial image */ /* lightspeed C not using argc/argv features */ # ifdef NOARGC char *argv[] = {"initial", "basic.st","mag.st","collect.st", "file.st", "mult.st", # ifdef STDWIN "graphics.st", "stdwin.st", 0}; int argc = 8; # endif # ifndef STDWIN "tty.st", 0}; int argc = 7; # endif main() # endif # ifndef NOARGC main(argc, argv) int argc; char **argv; # endif { char methbuf[100]; int i; initMemoryManager(); makeInitialImage(); initCommonSymbols(); for (i = 1; i < argc; i++) { fprintf(stderr,"%s:\n", argv[i]); ignore sprintf(methbuf, "x <120 1 '%s' 'r'>. <123 1>. <121 1>", argv[i]); goDoIt(methbuf); } /* when we are all done looking at the arguments, do initialization */ fprintf(stderr,"initialization\n"); /*debugging = true;*/ goDoIt("x nil initialize\n"); fprintf(stderr,"finished\n"); /* exit and return - belt and suspenders, but it keeps lint happy */ exit(0); return 0; } static goDoIt(text) char *text; { object process, stack, method; method = newMethod(); incr(method); setInstanceVariables(nilobj); ignore parse(method, text, false); process = allocObject(processSize); incr(process); stack = allocObject(50); incr(stack); /* make a process */ basicAtPut(process, stackInProcess, stack); basicAtPut(process, stackTopInProcess, newInteger(10)); basicAtPut(process, linkPtrInProcess, newInteger(2)); /* put argument on stack */ basicAtPut(stack, 1, nilobj); /* argument */ /* now make a linkage area in stack */ basicAtPut(stack, 2, nilobj); /* previous link */ basicAtPut(stack, 3, nilobj); /* context object (nil = stack) */ basicAtPut(stack, 4, newInteger(1)); /* return point */ basicAtPut(stack, 5, method); /* method */ basicAtPut(stack, 6, newInteger(1)); /* byte offset */ /* now go execute it */ while (execute(process, 15000)) fprintf(stderr,".."); } /* there is a sort of chicken and egg problem with regards to making the initial image */ static makeInitialImage() { object hashTable; object symbolObj, symbolClass, classClass; /* first create the table, without class links */ symbols = allocObject(1); incr(symbols); hashTable = allocObject(3 * 53); basicAtPut(symbols, 1, hashTable); /* next create #Symbol, Symbol and Class */ symbolObj = newSymbol("Symbol"); symbolClass = newClass("Symbol"); setClass(symbolObj, symbolClass); classClass = newClass("Class"); setClass(symbolClass, classClass); setClass(classClass, classClass); /* now fix up classes for symbol table */ /* and make a couple common classes, just to hold their places */ ignore newClass("Link"); ignore newClass("ByteArray"); setClass(hashTable, newClass("Array")); setClass(symbols, newClass("Dictionary")); setClass(nilobj, newClass("UndefinedObject")); ignore newClass("String"); nameTableInsert(symbols, strHash("symbols"), newSymbol("symbols"), symbols); /* finally at least make true and false to be distinct */ trueobj = newSymbol("true"); nameTableInsert(symbols, strHash("true"), trueobj, trueobj); falseobj = newSymbol("false"); nameTableInsert(symbols, strHash("false"), falseobj, falseobj); } @EOF chmod 644 initial.c echo x - install.ms cat >install.ms <<'@EOF' .NH Installation Instructions .PP The following lists installation instructions for those systems to which Version 3 of Little Smalltalk has been ported at present. Note that installation involves the creation of two programs. The first, called ``initial'', is run once to create the initial object image (usually a filed called ``systemImage''). The second program is the smalltalk interpreter. To run smalltalk, both these files must be accessible. Systems that use the supplied Makefile run initial automatically; in some other systems you may need to do this manually. .PP If you receive the distribution on Mac or IBM disks and you want to run the system under Unix you must ``undo'' some of the changes described below. .NH 2 Atari .PP I've been told (no first hand exprience) that the code works on the atari. I've set up a minimal description in env.h - could somebody tell me if the atari supports prototypes, signals, or some of the other features? .PP You do have to make the 'rb' changes described for the IBM PC (below), however you keep the rm instruction instead of DEL, and change the editor to whatever your system has (memacs?). .NH 2 Berkeley Unix (both 4.2 and 4.3) .PP To define, simply say ``make bsdtty'' to make version with tty interface. On systems supporting version 11 of x-windows, you can say ``make bsdx11''. The environment variable ST_LIBRARY can be defined and the standard system image will be taken from there (see st.c). .NH 2 Gnu C Compiler (Sequent Balance) .PP If at all possible, \fIUse the Gnu C Compiler\fP. I have found the code to be much smaller (up to 1/3 smaller) and much faster (up to twice as fast). So far this has been used on the Sequent Balance system. .PP Note that these sources support old style prototypes, as are used in Lightspeed C and Turbo C, and not the newer ANSI prototypes as are used in the gcc compiler. So do not define PROTO when using the gcc compiler .NH 2 HP-UX .PP Simply say ``make sysvtty'' to make a version with the tty interface. (As of yet, I don't have access to a system v system with an X-window interface, so I can't test that code). .PP (Using the -O optimising flag sometimes causes some HP machines to go into an infinite loop. Turning off the -O flag seems to always fix this). .NH 2 IBM PC / Turbo C compiler .LP \fBNote:\fP If you receive the sources on 5\(12 disks containing both source and executable, the following changes have already been made to the system. .PP Define the symbol TURBOC at the beginning of the file env.h. .PP Edit the file file.st, changing the command used to delete files from rm to del (notice the space following the del): .DS I delete ('del ', name) unixCommand .DE In the file file.st change the mode on the command to save images from w to wb. .DS I saveImage: name scheduler critical: [ " first get rid of our own process " scheduler removeProcess: scheduler currentProcess. File new; name: name; open: 'wb'; saveImage; close ] .DE In a similar manner change the mode on the file open in the initialize method in file tty.st to use wb instead of w. .DS I initialize " initialize the initial object image " self createGlobals. File new; name: 'systemImage'; open: 'wb'; saveImage; close. .DE And also in tty.st change the editor from vi to me (or whatever your favorite editor happens to be). .DS I editor \(<- 'me'. .DE .PP Because of segmentation limits it is not possible to have an object table any larger than 6500 objects (the current default). This value is set by a define found in memory.h .DS I # define ObjectTableMax 6500 .DE .PP Compile in the compact mode (small code, large data). .NH 2 Macintosh Lightspeed C .PP NOTE: If you get the distribution on 3\(14 MAC Disks the source code changes described below have probably already been made for you. .PP The mac distrubtion disk contains the following. .IP (a) A folder called ``C Sources'' that contains (naturally) all the C sources. .IP (b) A folder called ``ST Sources'' that contains (also naturally) all the Smalltalk sources, plus an application called ``initial'' that can be used to create or recreate the initial object image. To make changes to the image, simply edit the appropriate smalltalk files, run initial, and move the file ``systemImage'' to the appropriate location. .IP (c) Two Lightspeed C projects called ``TextEdit'' and ``Stdwin'', containing code taken from Guido van Rossums Standard Windows package. .IP (d) A file called ``systemImage'', which is the output of the application from part (b) .IP (e) An application called ``st'', which is the smalltalk interpreter. .IP (f) A folder called ``misc'' that contains various different files, such as documentation and other things. .PP It is only necessary to recompile if you make changes to the C source. If you make changes to the Smalltalk source you only need to rerun the application called ``initial'' contained in the ``ST Sources'' folder. .PP If you get the sources from some other location (say off the net), you must make the following alterations. Change the mode on the file open in the saveImage command (in file.st) and in the initalize command (file stdwin.st). Define the symbol LIGHTC at the beginning of the file env.h (See instructions for the IBM PC above for a fuller explanation). .PP To compile you need guido van rossums Standard Windows package. Follow his instructions to create the stdwin and textedit projects (these are already on the distribution disk). To make the initial program, create a project ``initialProj'' with segments as follows. In the first segment place MacTraps. In the second segment place Stdwin. In the third place TextEdit. In the forth place the Unix library files math, stdio, storage, strings and unix. In the fifth place the sources filein.c, initial.c, interp.c, memory.c, names.c, news.c, primitives.c, unixio.c and winprims.c. In the sixth and final segment place lex.c and parser.c. To create the st program use the same structure, subsituting st.c for initial.c. You must check the ``separate STRS'' option on both projects. .PP Make sure when you run the initial object that all the smalltalk sources are in the current directory; it does not complain if it can't open a file, it simply goes on. Also when you fileIn a file, the file must be in the current directory. .PP The Mac version uses the windowing interface. It is currently very fragile. (A few known bugs; can't restore from saved image files, output sometimes goes wrong places, output often doesn't appear until you click the mouse). .PP If you want, you can use a tool like ResEdit to change ower of the ST application and the systemImage file to a unique 4-char code (I use ``l.st''). Double clicking the image will then open ST. (Anybody know how to get Lightspeed C to do this automatically?). .NH 2 Sequent Balance .PP Say ``make bsdtty'' to make a tty interface system. .NH 2 TekTronix 4315, Green Hills C Compiler .PP Say ``make bsdtty'' to make a tty interface system. Say ``make bsdx11'' to make an x-windows interface system (still somewhat buggy). .NH 2 System V .PP On most system V systems you should be able to say simply ``make sysvtty'' to make a version using the tty interface. .NH 2 VAX / VMS .PP Since VMS doesn't understand Unix Makefiles, the distribution tape supplies a command file you can use. First define the symbol VMS near the begining of the file env.h, then execute the command file called vms.com. This makes a version using the tty interface. A VMS version using the X-windows interface has not been created yet. .NH Test Cases .PP One you have a running system; the following can be used to run the standard test cases. First load the file test.st. If you are using the windowing interface select the fileIn menu item and the file ``test.st'' (from the ST Sources folder), if you are using the tty interface use the following command .DS I File new; fileIn: 'test.st' .DE Then give the command to run all test cases. .DS I Test new all .DE Messages will be displayed as test cases are performed, and if any test cases fail. .NH The Standard Window Package .PP There is an experimental windows style interface based on Guido van rossums standard window package. This permits the system to work on top of X-windows, as well as the macintosh. Information on standard windows can be obtained directly from guido at guido@mcvax.uucp, or mcvax!guido, or possibly gvr@src.dec.com. His paper mail address is Guido van Rossum, Center for Mathematics and Computer Science, P.O. Box 4079, 1009 AB Amsterdam, The Netherlands. Sources for the standard window package are not included on the Little Smalltalk distribution, but they are available public domain by ftp from DEC SRC, machine gatekeeper.dec.com (address [128.45.9.52]). The subdirectory is pub/stdwin. Contact guido for more details. .PP To make the projects for the macintosh version, follow guidos instructions. For other versions, make a file stdw.o by linking together all of guidos sources for your particular system. Here is a makefile for the X11 version, for example. .DS L # # X11 version of stdwins # x11 = caret.o draw.o font.o menu.o timer.o cutbuffer.o \ error.o general.o scroll.o window.o dialog.o event.o \ llevent.o system.o alfa = bind.o draw.o event.o keymap.o measure.o menu.o scroll.o stdwin.o syswin.o gen = askfile.o perror.o textedit = editwin.o textdbg.o textedit.o textlow.o textbrk.o tools = endian.o getopt.o glob.o monocase.o strdup.o swap.o x11files = ${x11} ${gen} ${textedit} ${tools} stdw.o: ${x11files} ld -r -o stdw.o ${x11files} .DE .PP I emphasize this interface is very fragile. .NH Possible Changes .PP There are a couple of easy changes you may want to make at your site. The default editor is vi (indicated by the value of the global variable set in the routine createGlobals in either tty.st or stdwin.st); this can be changed to any other editor you like. The system also prints the current object count prior to asking for commands from the user. This can be eliminated by removing the primitive <2> from the method initialize, class Scheduler, file tty.st. @EOF chmod 644 install.ms echo x - interp.c cat >interp.c <<'@EOF' /* Little Smalltalk version 3 Written by Tim Budd, Oregon State University, July 1988 bytecode interpreter module given a process object, execute bytecodes in a tight loop. performs subroutine calls for a) finding a non-cached method b) executing a primitive otherwise simply loops until time slice has ended */ # include # include "env.h" # include "memory.h" # include "names.h" # include "interp.h" object trueobj, falseobj; boolean watching = 0; extern object primitive( INT X OBJP ); /* the following variables are local to this module */ static object method, messageToSend; static int messTest(obj) object obj; { return obj == messageToSend; } /* a cache of recently executed methods is used for fast lookup */ # define cacheSize 211 static struct { object cacheMessage; /* the message being requested */ object lookupClass; /* the class of the receiver */ object cacheClass; /* the class of the method */ object cacheMethod; /* the method itself */ } methodCache[cacheSize]; /* flush an entry from the cache (usually when its been recompiled) */ flushCache(messageToSend, class) object messageToSend, class; { int hash; hash = (((int) messageToSend) + ((int) class)) / cacheSize; methodCache[hash].cacheMessage = nilobj; } /* findMethod given a message and a class to start looking in, find the method associated with the message */ static boolean findMethod(methodClassLocation) object *methodClassLocation; { object methodTable, methodClass; method = nilobj; methodClass = *methodClassLocation; for (; methodClass != nilobj; methodClass = basicAt(methodClass, superClassInClass)) { methodTable = basicAt(methodClass, methodsInClass); method = hashEachElement(methodTable, messageToSend, messTest); if (method != nilobj) break; } if (method == nilobj) { /* it wasn't found */ methodClass = *methodClassLocation; return false; } *methodClassLocation = methodClass; return true; } # define nextByte() *(bp + byteOffset++) # define ipush(x) incr(*++pst=(x)) # define stackTop() *pst # define stackTopPut(x) decr((*pst)); incr((*pst = x)) # define stackTopFree() decr((*pst)); *pst-- = nilobj /* note that ipop leaves x with excess reference count */ # define ipop(x) x = stackTop(); *pst-- = nilobj # define processStackTop() ((pst-psb)+1) # define receiverAt(n) *(rcv+n) # define receiverAtPut(n,x) decr(receiverAt(n)); incr(receiverAt(n)=(x)) # define argumentsAt(n) *(arg+n) # define temporaryAt(n) *(temps+n) # define temporaryAtPut(n,x) decr(temporaryAt(n)); incr(temporaryAt(n)=(x)) # define literalsAt(n) *(lits+n) # define contextAt(n) *(cntx+n) # define contextAtPut(n,x) incr(contextAt(n-1)=(x)) # define processStackAt(n) *(psb+(n-1)) /* the following are manipulated by primitives */ object processStack; int linkPointer; static object growProcessStack(top, toadd) int top, toadd; { int size, i; object newStack; if (toadd < 100) toadd = 100; size = sizeField(processStack) + toadd; newStack = newArray(size); for (i = 1; i <= top; i++) { basicAtPut(newStack, i, basicAt(processStack, i)); } return newStack; } boolean execute(aProcess, maxsteps) object aProcess; int maxsteps; { object returnedObject; int returnPoint, timeSliceCounter; object *pst, *psb, *rcv, *arg, *temps, *lits, *cntx; object contextObject, *primargs; int byteOffset; object methodClass, argarray; int i, j; register int low; int high; register object incrobj; /* speed up increments and decrements */ byte *bp; /* unpack the instance variables from the process */ processStack = basicAt(aProcess, stackInProcess); psb = sysMemPtr(processStack); j = intValue(basicAt(aProcess, stackTopInProcess)); pst = psb + (j-1); linkPointer = intValue(basicAt(aProcess, linkPtrInProcess)); /* set the process time-slice counter before entering loop */ timeSliceCounter = maxsteps; /* retrieve current values from the linkage area */ readLinkageBlock: contextObject = processStackAt(linkPointer+1); returnPoint = intValue(processStackAt(linkPointer+2)); byteOffset = intValue(processStackAt(linkPointer+4)); if (contextObject == nilobj) { contextObject = processStack; cntx = psb; arg = cntx + (returnPoint-1); method = processStackAt(linkPointer+3); temps = cntx + linkPointer + 4; } else { /* read from context object */ cntx = sysMemPtr(contextObject); method = basicAt(contextObject, methodInContext); arg = sysMemPtr(basicAt(contextObject, argumentsInContext)); temps = sysMemPtr(basicAt(contextObject, temporariesInContext)); } if (! isInteger(argumentsAt(0))) rcv = sysMemPtr(argumentsAt(0)); readMethodInfo: lits = sysMemPtr(basicAt(method, literalsInMethod)); bp = bytePtr(basicAt(method, bytecodesInMethod)) - 1; while ( --timeSliceCounter > 0 ) { low = (high = nextByte()) & 0x0F; high >>= 4; if (high == 0) { high = low; low = nextByte(); } # if 0 if (debugging) { fprintf(stderr,"method %s %d ",charPtr(basicAt(method, messageInMethod)), byteOffset); fprintf(stderr,"stack %d %d ",pst, *pst); fprintf(stderr,"executing %d %d\n", high, low); } # endif switch(high) { case PushInstance: ipush(receiverAt(low)); break; case PushArgument: ipush(argumentsAt(low)); break; case PushTemporary: ipush(temporaryAt(low)); break; case PushLiteral: ipush(literalsAt(low)); break; case PushConstant: switch(low) { case 0: case 1: case 2: ipush(newInteger(low)); break; case minusOne: ipush(newInteger(-1)); break; case contextConst: /* check to see if we have made a block context yet */ if (contextObject == processStack) { /* not yet, do it now - first get real return point */ returnPoint = intValue(processStackAt(linkPointer+2)); contextObject = newContext(linkPointer, method, copyFrom(processStack, returnPoint, linkPointer - returnPoint), copyFrom(processStack, linkPointer + 5, methodTempSize(method))); basicAtPut(processStack, linkPointer+1, contextObject); ipush(contextObject); /* save byte pointer then restore things properly */ fieldAtPut(processStack, linkPointer+4, newInteger(byteOffset)); goto readLinkageBlock; } ipush(contextObject); break; case nilConst: ipush(nilobj); break; case trueConst: ipush(trueobj); break; case falseConst: ipush(falseobj); break; default: sysError("unimplemented constant","pushConstant"); } break; case AssignInstance: receiverAtPut(low, stackTop()); break; case AssignTemporary: temporaryAtPut(low, stackTop()); break; case MarkArguments: returnPoint = (processStackTop() - low) + 1; timeSliceCounter++; /* make sure we do send */ break; case SendMessage: messageToSend = literalsAt(low); doSendMessage: arg = psb + (returnPoint-1); if (isInteger(argumentsAt(0))) /* should fix this later */ methodClass = getClass(argumentsAt(0)); else { rcv = sysMemPtr(argumentsAt(0)); methodClass = classField(argumentsAt(0)); } doFindMessage: /* look up method in cache */ i = (((int) messageToSend) + ((int) methodClass)) % cacheSize; if ((methodCache[i].cacheMessage == messageToSend) && (methodCache[i].lookupClass == methodClass)) { method = methodCache[i].cacheMethod; methodClass = methodCache[i].cacheClass; } else { methodCache[i].lookupClass = methodClass; if (! findMethod(&methodClass)) { /* not found, we invoke a smalltalk method */ /* to recover */ j = processStackTop() - returnPoint; argarray = newArray(j+1); for (; j >= 0; j--) { ipop(returnedObject); basicAtPut(argarray, j+1, returnedObject); decr(returnedObject); } ipush(basicAt(argarray, 1)); /* push receiver back */ ipush(messageToSend); messageToSend = newSymbol("message:notRecognizedWithArguments:"); ipush(argarray); /* try again - if fail really give up */ if (! findMethod(&methodClass)) { sysWarn("can't find","error recovery method"); /* just quit */ return false; } } methodCache[i].cacheMessage = messageToSend; methodCache[i].cacheMethod = method; methodCache[i].cacheClass = methodClass; } if (watching && (basicAt(method, watchInMethod) != nilobj)) { /* being watched, we send to method itself */ j = processStackTop() - returnPoint; argarray = newArray(j+1); for (; j >= 0; j--) { ipop(returnedObject); basicAtPut(argarray, j+1, returnedObject); decr(returnedObject); } ipush(method); /* push method */ ipush(argarray); messageToSend = newSymbol("watchWith:"); /* try again - if fail really give up */ methodClass = classField(method); if (! findMethod(&methodClass)) { sysWarn("can't find","watch method"); /* just quit */ return false; } } /* save the current byte pointer */ fieldAtPut(processStack, linkPointer+4, newInteger(byteOffset)); /* make sure we have enough room in current process */ /* stack, if not make stack larger */ i = 6 + methodTempSize(method) + methodStackSize(method); j = processStackTop(); if ((j + i) > sizeField(processStack)) { processStack = growProcessStack(j, i); psb = sysMemPtr(processStack); pst = (psb + j); fieldAtPut(aProcess, stackInProcess, processStack); } byteOffset = 1; /* now make linkage area */ /* position 0 : old linkage pointer */ ipush(newInteger(linkPointer)); linkPointer = processStackTop(); /* position 1 : context object (nil means stack) */ ipush(nilobj); contextObject = processStack; cntx = psb; /* position 2 : return point */ ipush(newInteger(returnPoint)); arg = cntx + (returnPoint-1); /* position 3 : method */ ipush(method); /* position 4 : bytecode counter */ ipush(newInteger(byteOffset)); /* then make space for temporaries */ temps = pst+1; pst += methodTempSize(method); /* break if we are too big and probably looping */ if (sizeField(processStack) > 1800) timeSliceCounter = 0; goto readMethodInfo; case SendUnary: /* do isNil and notNil as special cases, since */ /* they are so common */ if ((! watching) && (low <= 1)) { if (stackTop() == nilobj) { stackTopPut((low?falseobj:trueobj)); break; } } returnPoint = processStackTop(); messageToSend = unSyms[low]; goto doSendMessage; break; case SendBinary: /* optimized as long as arguments are int */ /* and conversions are not necessary */ /* and overflow does not occur */ if ((! watching) && (low <= 12)) { primargs = pst - 1; returnedObject = primitive(low+60, primargs); if (returnedObject != nilobj) { /* pop arguments off stack , push on result */ stackTopFree(); stackTopPut(returnedObject); break; } } /* else we do it the old fashion way */ returnPoint = processStackTop() - 1; messageToSend = binSyms[low]; goto doSendMessage; case DoPrimitive: /* low gives number of arguments */ /* next byte is primitive number */ primargs = (pst - low) + 1; /* next byte gives primitive number */ i = nextByte(); /* a few primitives are so common, and so easy, that they deserve special treatment */ switch(i) { case 5: /* set watch */ watching = ! watching; returnedObject = watching?trueobj:falseobj; break; case 11: /* class of object */ returnedObject = getClass(*primargs); break; case 21: /* object equality test */ if (*primargs == *(primargs+1)) returnedObject = trueobj; else returnedObject = falseobj; break; case 25: /* basicAt: */ j = intValue(*(primargs+1)); returnedObject = basicAt(*primargs, j); break; case 31: /* basicAt:Put:*/ j = intValue(*(primargs+1)); fieldAtPut(*primargs, j, *(primargs+2)); returnedObject = nilobj; break; case 53: /* set time slice */ timeSliceCounter = intValue(*primargs); returnedObject = nilobj; break; case 58: /* allocObject */ j = intValue(*primargs); returnedObject = allocObject(j); break; case 87: /* value of symbol */ returnedObject = globalSymbol(charPtr(*primargs)); break; default: returnedObject = primitive(i, primargs); break; } /* increment returned object in case pop would destroy it */ incr(returnedObject); /* pop off arguments */ while (low-- > 0) { stackTopFree(); } /* returned object has already been incremented */ ipush(returnedObject); decr(returnedObject); break; doReturn: returnPoint = intValue(basicAt(processStack, linkPointer + 2)); linkPointer = intValue(basicAt(processStack, linkPointer)); while (processStackTop() >= returnPoint) { stackTopFree(); } /* returned object has already been incremented */ ipush(returnedObject); decr(returnedObject); /* now go restart old routine */ if (linkPointer != nilobj) goto readLinkageBlock; else return false /* all done */; case DoSpecial: switch(low) { case SelfReturn: incr(returnedObject = argumentsAt(0)); goto doReturn; case StackReturn: ipop(returnedObject); goto doReturn; case Duplicate: /* avoid possible subtle bug */ returnedObject = stackTop(); ipush(returnedObject); break; case PopTop: ipop(returnedObject); decr(returnedObject); break; case Branch: /* avoid a subtle bug here */ i = nextByte(); byteOffset = i; break; case BranchIfTrue: ipop(returnedObject); i = nextByte(); if (returnedObject == trueobj) { /* leave nil on stack */ pst++; byteOffset = i; } decr(returnedObject); break; case BranchIfFalse: ipop(returnedObject); i = nextByte(); if (returnedObject == falseobj) { /* leave nil on stack */ pst++; byteOffset = i; } decr(returnedObject); break; case AndBranch: ipop(returnedObject); i = nextByte(); if (returnedObject == falseobj) { ipush(returnedObject); byteOffset = i; } decr(returnedObject); break; case OrBranch: ipop(returnedObject); i = nextByte(); if (returnedObject == trueobj) { ipush(returnedObject); byteOffset = i; } decr(returnedObject); break; case SendToSuper: i = nextByte(); messageToSend = literalsAt(i); rcv = sysMemPtr(argumentsAt(0)); methodClass = basicAt(method, methodClassInMethod); /* if there is a superclass, use it otherwise for class Object (the only class that doesn't have a superclass) use the class again */ returnedObject = basicAt(methodClass, superClassInClass); if (returnedObject != nilobj) methodClass = returnedObject; goto doFindMessage; default: sysError("invalid doSpecial",""); break; } break; default: sysError("invalid bytecode",""); break; } } /* before returning we put back the values in the current process */ /* object */ fieldAtPut(processStack, linkPointer+4, newInteger(byteOffset)); fieldAtPut(aProcess, stackTopInProcess, newInteger(processStackTop())); fieldAtPut(aProcess, linkPtrInProcess, newInteger(linkPointer)); return true; } @EOF chmod 644 interp.c echo x - interp.h cat >interp.h <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 */ /* symbolic definitions for the bytecodes */ # define Extended 0 # define PushInstance 1 # define PushArgument 2 # define PushTemporary 3 # define PushLiteral 4 # define PushConstant 5 # define AssignInstance 6 # define AssignTemporary 7 # define MarkArguments 8 # define SendMessage 9 # define SendUnary 10 # define SendBinary 11 # define DoPrimitive 13 # define DoSpecial 15 /* a few constants that can be pushed by PushConstant */ # define minusOne 3 /* the value -1 */ # define contextConst 4 /* the current context */ # define nilConst 5 /* the constant nil */ # define trueConst 6 /* the constant true */ # define falseConst 7 /* the constant false */ /* types of special instructions (opcode 15) */ # define SelfReturn 1 # define StackReturn 2 # define Duplicate 4 # define PopTop 5 # define Branch 6 # define BranchIfTrue 7 # define BranchIfFalse 8 # define AndBranch 9 # define OrBranch 10 # define SendToSuper 11 @EOF chmod 644 interp.h echo x - lex.c cat >lex.c <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 lexical analysis routines for method parser should be called only by parser */ # include # include # ifdef LIGHTC # include # include # endif # include "env.h" # include "memory.h" # include "lex.h" extern double atof(); /* global variables returned by lexical analyser */ tokentype token; /* token variety */ char tokenString[80]; /* text of current token */ int tokenInteger; /* integer (or character) value of token */ double tokenFloat; /* floating point value of token */ /* local variables used only by lexical analyser */ static char *cp; /* character pointer */ static char pushBuffer[10]; /* pushed back buffer */ static int pushindex; /* index of last pushed back char */ static char cc; /* current character */ static long longresult; /* value used when building int tokens */ /* lexinit - initialize the lexical analysis routines */ noreturn lexinit(str) char *str; { pushindex = 0; cp = str; /* get first token */ ignore nextToken(); } /* pushBack - push one character back into the input */ static pushBack(c) char c; { pushBuffer[pushindex++] = c; } /* nextChar - retrieve the next char, from buffer or input */ static char nextChar() { if (pushindex > 0) cc = pushBuffer[--pushindex]; else if (*cp) cc = *cp++; else cc = '\0'; return(cc); } /* peek - take a peek at the next character */ char peek() { pushBack(nextChar()); return (cc); } /* isClosing - characters which can close an expression */ static boolean isClosing(c) char c; { switch(c) { case '.': case ']': case ')': case ';': case '\"': case '\'': return(true); } return(false); } /* isSymbolChar - characters which can be part of symbols */ static boolean isSymbolChar(c) char c; { if (isdigit(c) || isalpha(c)) return(true); if (isspace(c) || isClosing(c)) return(false); return(true); } /* singleBinary - binary characters that cannot be continued */ static boolean singleBinary(c) char c; { switch(c) { case '[': case '(': case ')': case ']': return(true); } return(false); } /* binarySecond - return true if char can be second char in binary symbol */ static boolean binarySecond(c) char c; { if (isalpha(c) || isdigit(c) || isspace(c) || isClosing(c) || singleBinary(c)) return(false); return(true); } tokentype nextToken() { char *tp; boolean sign; /* skip over blanks and comments */ while(nextChar() && (isspace(cc) || (cc == '"'))) if (cc == '"') { /* read comment */ while (nextChar() && (cc != '"')) ; if (! cc) break; /* break if we run into eof */ } tp = tokenString; *tp++ = cc; if (! cc) /* end of input */ token = inputend; else if (isalpha(cc)) { /* identifier */ while (nextChar() && isalnum(cc)) *tp++ = cc; if (cc == ':') { *tp++ = cc; token = namecolon; } else { pushBack(cc); token = nameconst; } } else if (isdigit(cc)) { /* number */ longresult = cc - '0'; while (nextChar() && isdigit(cc)) { *tp++ = cc; longresult = (longresult * 10) + (cc - '0'); } if (longCanBeInt(longresult)) { tokenInteger = longresult; token = intconst; } else { token = floatconst; tokenFloat = (double) longresult; } if (cc == '.') { /* possible float */ if (nextChar() && isdigit(cc)) { *tp++ = '.'; do *tp++ = cc; while (nextChar() && isdigit(cc)); if (cc) pushBack(cc); token = floatconst; *tp = '\0'; tokenFloat = atof(tokenString); } else { /* nope, just an ordinary period */ if (cc) pushBack(cc); pushBack('.'); } } else pushBack(cc); if (nextChar() && cc == 'e') { /* possible float */ if (nextChar() && cc == '-') { sign = true; ignore nextChar(); } else sign = false; if (cc && isdigit(cc)) { /* yep, its a float */ *tp++ = 'e'; if (sign) *tp++ = '-'; while (cc && isdigit(cc)) { *tp++ = cc; ignore nextChar(); } if (cc) pushBack(cc); *tp = '\0'; token = floatconst; tokenFloat = atof(tokenString); } else { /* nope, wrong again */ if (cc) pushBack(cc); if (sign) pushBack('-'); pushBack('e'); } } else if (cc) pushBack(cc); } else if (cc == '$') { /* character constant */ tokenInteger = (int) nextChar(); token = charconst; } else if (cc == '#') { /* symbol */ tp--; /* erase pound sign */ if (nextChar() == '(') token = arraybegin; else { pushBack(cc); while (nextChar() && isSymbolChar(cc)) *tp++ = cc; pushBack(cc); token = symconst; } } else if (cc == '\'') { /* string constant */ tp--; /* erase pound sign */ strloop: while (nextChar() && (cc != '\'')) *tp++ = cc; /* check for nested quote marks */ if (cc && nextChar() && (cc == '\'')) { *tp++ = cc; goto strloop; } pushBack(cc); token = strconst; } else if (isClosing(cc)) /* closing expressions */ token = closing; else if (singleBinary(cc)) { /* single binary expressions */ token = binary; } else { /* anything else is binary */ if (nextChar() && binarySecond(cc)) *tp++ = cc; else pushBack(cc); token = binary; } *tp = '\0'; return(token); } @EOF chmod 644 lex.c echo x - lex.h cat >lex.h <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 */ /* values returned by the lexical analyzer */ # ifndef NOENUMS typedef enum tokensyms { nothing, nameconst, namecolon, intconst, floatconst, charconst, symconst, arraybegin, strconst, binary, closing, inputend} tokentype; # endif # ifdef NOENUMS # define tokentype int # define nothing 0 # define nameconst 1 # define namecolon 2 # define intconst 3 # define floatconst 4 # define charconst 5 # define symconst 6 # define arraybegin 7 # define strconst 8 # define binary 9 # define closing 10 # define inputend 11 # endif extern tokentype nextToken(NOARGS); extern tokentype token; /* token variety */ extern char tokenString[]; /* text of current token */ extern int tokenInteger; /* integer (or character) value of token */ extern double tokenFloat; /* floating point value of token */ extern noreturn lexinit(); /* initialization routine */ @EOF chmod 644 lex.h echo x - mag.st cat >mag.st <<'@EOF' * * Little Smalltalk, version 3 * Written by Tim Budd, Oregon State University, July 1988 * * Classes dealing with objects having Magnitude * Class Magnitude Object Class Char Magnitude value Class Number Magnitude Class Integer Number Class LongInteger Integer negative digits Class Fraction Number top bottom Class Float Number Class Random Object * Methods Object 'magnitude' isNumber ^ false | isFloat ^ false | isFraction ^ false | isInteger ^ false | isLongInteger ^ false | isShortInteger ^ false ] Methods Char 'all' < aValue " can only compare characters to characters " ^ aValue isChar ifTrue: [ value < aValue asInteger ] ifFalse: [ smalltalk error: 'char compared to nonchar'] | == aValue ^ aValue isChar ifTrue: [ value = aValue asInteger ] ifFalse: [ false ] | asInteger ^ value | asString " make ourselves into a string " ^ ' ' copy; at: 1 put: self | digitValue " return an integer representing our value " self isDigit ifTrue: [ ^ value - $0 asInteger ]. self isUppercase ifTrue: [ ^ value - $A asInteger + 10 ]. ^ smalltalk error: 'illegal conversion, char to digit' | isAlphabetic ^ (self isLowercase) or: [ self isUppercase ] | isAlphaNumeric ^ (self isAlphabetic) or: [ self isDigit ] | isBlank ^ value = $ " blank char " | isChar ^ true | isDigit ^ value between: $0 asInteger and: $9 asInteger | isLowercase ^ value between: $a asInteger and: $z asInteger | isUppercase ^ value between: $A asInteger and: $Z asInteger | value: aValue " private - used for initialization " value <- aValue | printString ^ '$', self asString ] Methods Fraction 'all' = f f isFraction ifTrue: [ ^ (top = f top) and: [ bottom = f bottom ] ] ifFalse: [ ^ super = f ] | < f f isFraction ifTrue: [ ^ (top * f bottom) < (bottom * f top) ] ifFalse:[ ^ super < f ] | + f f isFraction ifTrue: [ ^ ((top * f bottom) + (bottom * f top)) / (bottom * f bottom) ] ifFalse:[ ^ super + f ] | - f f isFraction ifTrue: [ ^ ((top * f bottom) - (bottom * f top)) / (bottom * f bottom) ] ifFalse:[ ^ super - f ] | * f f isFraction ifTrue: [ ^ (top * f top) / (bottom * f bottom) ] ifFalse: [ ^ super * f ] | / f ^ self * f reciprocal | abs ^ top abs / bottom | asFloat " convert to a floating point number " ^ top asFloat / bottom asFloat | truncated " convert to an integer rounded towards zero " ^ top quo: bottom | bottom ^ bottom | coerce: x " coerce a value into being a fraction " ^ x asFraction | generality " generality value - used in mixed type arithmetic " ^ 5 | isFraction ^ true | ln ^ (top ln) - (bottom ln) | raisedTo: x ^ (top raisedTo: x) / (bottom raisedTo: x) | reciprocal ^ bottom / top | top ^ top | with: t over: b " initialization " top <- t. bottom <- b | printString ^ top printString, '/', bottom printString ] Methods Float 'all' + value ^ value isFloat ifTrue: [ <110 self value> " floating add " ] ifFalse: [ super + value ] | - value ^ value isFloat ifTrue: [ <111 self value> " floating subtract " ] ifFalse: [ super - value ] | < value ^ value isFloat ifTrue: [ <112 self value> " floating comparison " ] ifFalse: [ super < value ] | = value ^ value isFloat ifTrue: [ <116 self value> ] ifFalse: [ super = value ] | * value ^ value isFloat ifTrue: [ <118 self value> ] ifFalse: [ super * value ] | / value ^ value isFloat ifTrue: [ (value = 0.0) ifTrue: [ smalltalk error: 'float division by zero' ] ifFalse: [ <119 self value> ]] ifFalse: [ super / value ] | isFloat ^ true | coerce: value " convert the value into a floating point number " ^ value asFloat | exp " return e raised to self " ^ <103 self> | generality " our numerical generality - used for mixed mode arithmetic" ^ 7 | integerPart | i j | i <- <106 self>. j <- i basicAt: 2. i <- i basicAt: 1. j < 0 ifTrue: [ ^ 0 ] ifFalse: [ ^ i * (2 raisedTo: j)] | ln " natural log of self " ^ <102 self> | new ^ smalltalk error: 'cannot create floats with new' | printString ^ <101 self> | quo: value ^ (self / value) truncated | rounded ^ (self + 0.5) floor | truncated | result f i | " truncate to an integer rounded towards zero" f <- self. result <- 0. [ i <- f integerPart. i > 0] whileTrue: [ result <- result + i. f <- f - i ]. ^ result ] Methods Integer 'all' + value | r | ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ r <- <60 self value>. "primitive will return nil on overflow" r notNil ifTrue: [ r ] ifFalse: [ self asLongInteger + value asLongInteger ]] ifFalse: [ super + value ] | - value | r | ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ r <- <61 self value>. "primitive will return nil on overflow" r notNil ifTrue: [ r ] ifFalse: [ self asLongInteger - value asLongInteger ]] ifFalse: [ super - value ] | < value ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ <62 self value> ] ifFalse: [ super < value ] | > value ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ <63 self value> ] ifFalse: [ super > value ] | = value ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ self == value ] ifFalse: [ super = value ] | * value | r | ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ r <- <68 self value>. "primitive will return nil on overflow" r notNil ifTrue: [ r ] ifFalse: [ self asLongInteger * value asLongInteger ]] ifFalse: [ super * value ] | / value | t b | value = 0 ifTrue: [ ^ smalltalk error: 'division by zero']. value isInteger ifTrue: [ b <- self gcd: value . t <- self quo: b. b <- value quo: b. b negative ifTrue: [ t <- t negated. b <- b negated ]. (b = 1) ifTrue: [ ^ t ]. ^ Fraction new; with: t over: b ] ifFalse: [ ^ super / value ] | , value " used to make long integer constants " ^ self * 1000 + value | allMask: value " see if all bits in argument are on" ^ value = (self bitAnd: value) | anyMask: value " see if any bits in argument are on" ^ 0 ~= (self bitAnd: value) | asCharacter ^ Char new; value: self | asDigit " return as character digit " (self >= 0) ifTrue: [ (self <= 9) ifTrue: [ ^ (self + $0 asInteger) asCharacter ]. (self < 36) ifTrue: [ ^ (self + $A asInteger - 10) asCharacter ] ]. ^ smalltalk error: 'illegal conversion, integer to digit' | asFloat " should be redefined by any subclasses " self isShortInteger ifTrue: [ ^ <51 self> ] | asFraction ^ Fraction new ; with: self over: 1 | asLongInteger | newList i | newList <- List new. i = 0 ifTrue: [ newList add: 0 ] ifFalse: [ i <- self abs. [ i ~= 0 ] whileTrue: [ newList addLast: (i rem: 100). i <- i quo: 100 ] ]. ^ LongInteger new; sign: i negative digits: newList asArray | asString ^ self radix: 10 | bitAnd: value ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ <71 self value > ] ifFalse: [ smalltalk error: 'arguments to bit operation must be short integer'] | bitAt: value ^ (self bitShift: 1 - value) bitAnd: 1 | bitInvert "invert all bits in self" ^ self bitXor: -1 | bitOr: value ^ (self bitXor: value) bitXor: (self bitAnd: value) | bitXor: value ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ <72 self value > ] ifFalse: [ smalltalk error: 'argument to bit operation must be integer'] | bitShift: value ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ <79 self value > ] ifFalse: [ smalltalk error: 'argument to bit operation must be integer'] | even ^ (self rem: 2) = 0 | factorial ^ (2 to: self) inject: 1 into: [:x :y | x * y ] | gcd: value (value = 0) ifTrue: [ ^ self ]. (self negative) ifTrue: [ ^ self negated gcd: value ]. (value negative) ifTrue: [ ^ self gcd: value negated ]. (value > self) ifTrue: [ ^ value gcd: self ]. ^ value gcd: (self rem: value) | generality " generality value - used in mixed class arithmetic " ^ 2 | isShortInteger ^ true | lcm: value ^ (self quo: (self gcd: value)) * value | new ^ smalltalk error: 'cannot create integers with new' | odd ^ (self rem: 2) ~= 0 | quo: value | r | ^ (self isShortInteger and: [value isShortInteger]) ifTrue: [ r <- <69 self value>. (r isNil) ifTrue: [ smalltalk error: 'quo: or rem: with argument 0'] ifFalse: [ r ]] ifFalse: [ ^ super quo: value ] | radix: base | sa text | " return a printed representation of self in given base" sa <- self abs. text <- (sa \\ base) asDigit asString. ^ (sa < base) ifTrue: [ (self negative) ifTrue: [ '-' , text ] ifFalse: [ text ]] ifFalse: [ ((self quo: base) radix: base), text ] | truncated ^ self | printString ^ self asString | timesRepeat: aBlock | i | " use while, which is optimized, not to:, which is not" i <- 0. [ i < self ] whileTrue: [ aBlock value. i <- i + 1] ] Methods LongInteger 'all' < n | result | n isLongInteger ifFalse: [ ^ super < n ]. (negative == n negative) ifFalse: [ ^ negative ]. " now either both positive or both negative " result <- false. self with: n bitDo: [:x :y | (x ~= y) ifTrue: [ result <- x < y]]. negative ifTrue: [ result <- result not ]. ^ result | = n n isLongInteger ifFalse: [ ^ super = n ]. (negative == n negative) ifFalse: [ ^ false ]. ^ digits = n digits | + n | newDigits z carry | n isLongInteger ifFalse: [ ^ super + n ]. negative ifTrue: [ ^ n - self negated ]. n negative ifTrue: [ ^ self - n negated ]. " reduced to positive + positive case " newDigits <- List new. carry <- 0. self with: n bitDo: [:x :y | z <- x + y + carry. (z >= 100) ifTrue: [ carry <- 1. z <- z - 100] ifFalse: [ carry <- 0 ]. newDigits addLast: z ]. carry > 0 ifTrue: [ newDigits addLast: carry ]. ^ LongInteger new; sign: false digits: newDigits asArray | - n | result newDigits z borrow | n isLongInteger ifFalse: [ ^ super - n ]. negative ifTrue: [ ^ (self negated + n) negated ]. n negative ifTrue: [ ^ self + n negated ]. (self < n) ifTrue: [ ^ (n - self) negated ]. " reduced to positive - smaller positive " newDigits <- List new. borrow <- 0. self with: n bitDo: [:x :y | z <- (x - borrow) - y. (z >= 0) ifTrue: [ borrow <- 0] ifFalse: [ z <- z + 100. borrow <- 1]. newDigits addLast: z ]. result <- 0. "now normalize result by multiplication " newDigits reverseDo: [:x | result <- result * 100 + x ]. ^ result | * n | result | n isShortInteger ifTrue: [ ^ self timesShort: n ]. n isLongInteger ifFalse: [ ^ super * n ]. result <- 0 asLongInteger. digits reverseDo: [:x | result <- (result timesShort: 100) + (n timesShort: x)]. negative ifTrue: [ result <- result negated ]. ^ result | abs negative ifTrue: [ ^ self negated] | asFloat | r | r <- 0.0 . digits reverseDo: [ :x | r <- r * 100.0 + x asFloat]. negative ifTrue: [ r <- r negated ]. ^ r. | bitShift: n (n >= 0) ifTrue: [ ^ self * (2 raisedTo: n) ] ifFalse: [ ^ self quo: (2 raisedTo: n negated)] | coerce: n ^ n asLongInteger | digits ^ digits | generality ^ 4 "generality value - used in mixed type arithmetic " | isLongInteger ^ true | isShortInteger " override method in class Integer " ^ false | negated ^ LongInteger new; sign: negative not digits: digits | negative ^ negative | new "override restriction from class Integer" ^ self | quo: value | a b quo result | result <- 0. a <- self abs. b <- value abs. [a > b] whileTrue: [ quo <- (a asFloat quo: b). result <- result + quo. a <- a - (b * quo) ]. ^ result | sign: s digits: d negative <- s. digits <- d. | printString | str | str <- negative ifTrue: [ '-' ] ifFalse: [ '' ]. digits reverseDo: [:x | str <- str , (x quo: 10) printString , (x rem: 10) printString ]. ^ str | timesShort: value | y z carry newDigits | y <- value abs. carry <- 0. newDigits <- digits collect: [:x | z <- x * y + carry. carry <- z quo: 100. z - (carry * 100)]. (carry > 0) ifTrue: [ newDigits <- newDigits grow: carry ]. ^ LongInteger new; sign: (negative xor: value negative) digits: newDigits | with: n bitDo: aBlock | d di dj | " run down two digits lists in parallel doing block " di <- digits size. d <- n digits. dj <- d size. (1 to: (di max: dj)) do: [:i | aBlock value: ((i <= di) ifTrue: [ digits at: i] ifFalse: [0]) value: ((i <= dj) ifTrue: [ d at: i] ifFalse: [0]) ] ] Methods Magnitude 'all' <= value ^ (self < value) or: [ self = value ] | < value ^ (self <= value) and: [ self ~= value ] | >= value ^ value <= self | > value ^ (value < self) | = value ^ (self == value) | ~= value ^ (self = value) not | between: low and: high ^ (low <= self) and: [ self <= high ] | isChar ^ false | max: value ^ (self < value) ifTrue: [ value ] ifFalse: [ self ] | min: value ^ (self < value) ifTrue: [ self ] ifFalse: [ value ] ] Methods Number 'all' isNumber ^ true | maxgen: value (self isNumber and: [ value isNumber ]) ifFalse: [ ^ smalltalk error: 'arithmetic on non-numbers' ]. ^ (self generality > value generality) ifTrue: [ self ] ifFalse: [ value coerce: self ] | + value ^ (self maxgen: value) + (value maxgen: self) | - value ^ (self maxgen: value) - (value maxgen: self) | < value ^ (self maxgen: value) < (value maxgen: self) | = value ^ value isNumber ifTrue: [ (self maxgen: value) = (value maxgen: self) ] ifFalse: [ false ] | * value ^ (self maxgen: value) * (value maxgen: self) | / value ^ (self maxgen: value) / (value maxgen: self) | // value " integer division, truncate towards negative infinity" " see quo: " ^ (self / value) floor | \\ value " remainder after integer division " ^ self - (self // value * value) | abs ^ (self < 0) ifTrue: [ 0 - self ] ifFalse: [ self ] | ceiling | i | i <- self truncated. ^ ((self positive) and: [ self ~= i ]) ifTrue: [ i + 1 ] ifFalse: [ i ] | copy ^ self | exp ^ self asFloat exp | floor | i | i <- self truncated. ^ ((self negative) and: [ self ~= i ]) ifTrue: [ i - 1 ] ifFalse: [ i ] | fractionalPart ^ self - self truncated | isInteger ^ self isLongInteger or: [ self isShortInteger ] | ln ^ self asFloat ln | log: value ^ self ln / value ln | negated ^ 0 - self | negative ^ self < 0 | positive ^ self >= 0 | quo: value ^ (self maxgen: value) quo: (value maxgen: self) | raisedTo: x | y | x negative ifTrue: [ ^ 1 / (self raisedTo: x negated) ]. x isShortInteger ifTrue: [ (x = 0) ifTrue: [ ^ 1 ]. y <- (self raisedTo: (x quo: 2)) squared. x odd ifTrue: [ y <- y * self ]. ^ y ] "use logrithms to do exponeneation" ifFalse: [ ^ ( x * self ln ) exp ] | reciprocal ^ 1 / self | rem: value ^ self - ((self quo: value) * value) | roundTo: value ^ (self / value ) rounded * value | sign ^ (self = 0) ifTrue: [ 0 ] ifFalse: [ self / self abs ] | sqrt ^ (self negative) ifTrue: [ smalltalk error: 'sqrt of negative'] ifFalse: [ self raisedTo: 0.5 ] | squared ^ self * self | strictlyPositive ^ self > 0 | to: value ^ Interval new; lower: self; upper: value; step: 1 | to: value by: step ^ Interval new; lower: self; upper: value; step: step | trucateTo: value ^ (self / value) trucated * value ] Methods Random 'all' between: low and: high " return random number in given range " ^ (self next * (high - low)) + low | next " convert rand integer into float between 0 and 1 " ^ (<3> rem: 1000) / 1000 | next: value | list | " return a list of random numbers of given size " list <- List new. value timesRepeat: [ list add: self next ]. ^ list | randInteger: value ^ 1 + (<3> rem: value) | set: value " set seed for random number generator " <55 value> ] @EOF chmod 644 mag.st echo x - manual.ms sed 's/^@//' >manual.ms <<'@EOF' .TL Little Smalltalk Users Manual - Version Three .AU Tim Budd .AI Department of Computer Science Oregon State University Corvallis, Oregon 97331 USA .AB .PP Version three of Little Smalltalk was designed specifically to be easy to port to new machines and operating systems. This document provides the basic information needed to use Version Three of Little Smalltalk, plus information needed by those wishing to undertake the job of porting the system to a new operating environment. .AE .PP The first version of Little Smalltalk, although simple, small and fast, was in a number of very critical ways very Unix specific. Soon after the publication of the book \fIA Little Smalltalk\fP, requests started flooding in asking if there existed a port to an amazingly large number of different machines, such as the IBM PC, the Macintosh, the Acorn, the Atari, and even such systems as DEC VMS. Clearly it was beyond our capabilities to satisfy all these requests, however in an attempt to meet them partway in the summer of 1988 I designed a second version of Little Smalltalk, which was specifically designed to be less Unix specific and more amenable to implementation of different systems. .PP This document describes is divided into two parts. In part one I describe the basic features of the user interface. This is essential information for anybody wishing to use the system. In part two we give the basic information needed by anybody wishing to undertake the task of porting version three Little Smalltalk to a new machine. .NH Getting Started .PP How you get started depends upon what kind of system you are working on. Currently there are two styles of interface supported. A line-oriented, tty style stdin interface is available, which runs under Unix and other systems. There is also a window based system which runs under X-windows and on the Mac. .NH 2 The stdin/stdout interface .PP Using the stdin/stdout interface, there is a prompt (the ``>'' caracter) typed to indicate the system is waiting for input. Expressions are read at the keyboard and evaluated following each carrage return. The result of the expression is then printed. .DS I > 5 + 7 12 .DE Global variables can be created simply by assigning to a name. The value of an assignment statement is the value of the right hand side. .DS I x <- 3 3 .DE Multiple expressions can appear on the same line separated by periods. Only the last expression is printed. .DS I y <- 17. 3 + 4 7 .DE .NH 2 The windowing interface .PP The windowing interface is built on top of guido van rossums standard window package, and runs on top of systems that support standard windows. These include X-11 and the Macintosh. .PP When you start up the system, there will be a single window titled ``workspace''. You can enter expressions in the workspace, then select either the menu items ``do it'' or ``print it''. Both will evaluate the expression; the latter, in addition, will print the result. .PP A number of other memu commands are also available. These permit you to save the current image, exit the system, or start the browser. .PP The browser is an interface permiting you to easily view system code. Selecting a class in the first pane of the browser brings up a second pane in which you can select methods, selecting a method brings up a third pane in which you can view and edit text. Selecting ``compile'' following the editing of text will attempt to compile the method. If no errors are reported, the method is then available for execution. .NH Exploring and Creating .PP This section describes how to discover information about existing objects and create new objects using the Little Smalltalk system (version three). In Smalltalk one communicates with objects by passing messages to them. Even the addition message + is treated as a message passed to the first object 5, with an argument represented by the second object. Other messages can be used to discover information about various objects. The most basic fact you can discover about an object is its class. This is given by the message \fBclass\fP, as in the following examples: .DS I > 7 class Integer > nil class UndefinedObject .DE .PP Occasionally, especially when programming, one would like to ask whether the class of an object matches some known class. One way to do this would be to use the message \fB= =\fP, which tells whether two expressions represent the same object: .DS I > ( 7 class = = Integer) True > nil class = = Object False .DE .PP An easier way is to use the message \fBisMemberOf:\fP; .DS I > 7 isMemberOf: Integer True > nil isMemberOf: Integer False .DE .PP Sometimes you want to know if an object is an instance of a particular class or one if its subclasses; in this case the appropriate message is \fBisKindOf:\fP. .DS I > 7 isMemberOf: Number False > 7 isKindOf: Number True .DE .PP All objects will respond to the message \fBdisplay\fP by telling a little about themselves. Many just give their class and their printable representation: .DS I > 7 display (Class Integer) 7 > nil display (Class UndefinedObject) nil .DE .LP Others, such as classes, are a little more verbose: .DS I > Integer display Class Name: Integer SuperClass: Number Instance Variables: no instance variables Subclasses: .DE .LP The display shows that the class \fBInteger\fP is a subclass of class \fBNumber\fP (that is, class \fBNumber\fP is the superclass of \fBInteger\fP). There are no instance variables for this class, and it currently has no subclasses. All of this information could be obtained by means of other messages, although the \fBdisplay\fP form is the easiest. [ Note: at the moment printing subclasses takes a second or two. I'm not sure why.] .DS I > List variables display links > Integer superClass Number > Collection subClasses display IndexedCollection Interval List .DE About the only bit of information that is not provided when one passes the message \fBdisplay\fP to a class is a list of methods the class responds to. There are two reasons for this omission; the first is that this list can often be quite long, and we don't want to scroll the other information off the screen before the user has seen it. The second reason is that there are really two different questions the user could be asking. The first is what methods are actually implemented in a given class. A list containing the set of methods implemented in a class can be found by passing the message \fBmethods\fP to a class. As we saw with the message \fBsubClasses\fP shown above, the command \fBdisplay\fP prints this information out one method to a line: .DS I > True methods display #ifTrue:ifFalse: #not .DE .PP A second question that one could ask is what message selectors an instance of a given class will respond to, whether they are inherited from superclasses or are defined in the given class. This set is given in response to the message \fBrespondsTo\fP. [ NOTE: again form some reason I'm not sure of this command seems to take a long time to execute ]. .DS I > True respondsTo display #class #== #hash #isNil #display #= #basicSize #isMemberOf: #notNil #print #basicAt:put: #isKindOf: #basicAt: #printString #or: #and: #ifFalse:ifTrue: #ifTrue: #ifFalse: #not #ifTrue:ifFalse: .DE .PP Alternatively, one can ask whether instances of a given class will respond to a specific message by writing the message selector as a symbol: .DS I > String respondsTo: #print True > String respondsTo: #+ False .DE .PP The inverse of this would be to ask what classes contain methods for a given message selector. Class \fBSymbol\fP defines a method to yield just this information: .DS I > #+ respondsTo display Integer Number Float .DE .PP The method that will be executed in response to a given message selector can be displayed by means of the message \fBviewMethod:\fP .DS I > Integer viewMethod: #gcd: gcd: value (value = 0) ifTrue: [ \(ua self ]. (self negative) ifTrue: [ \(ua self negated gcd: value ]. (value negative) ifTrue: [ \(ua self gcd: value negated ]. (value > self) ifTrue: [ \(ua value gcd: self ]. \(ua value gcd: (self rem: value) .DE .PP Some Smalltalk systems make it very difficult for you to discover the bytecodes that a method gets translated into. Since the primary goal of Little Smalltalk is to help the student to discover how a modern very high level language is implemented, it makes sense that the system should help you as much as possible discover everything about its internal structure. Thus a method, when presented with the message \fBdisplay\fP, will print out its bytecode representation. .DS I > Char methodNamed: #isAlphabetic ; display Method #isAlphabetic isAlphabetic \(ua (self isLowercase) or: [ self isUppercase ] literals Array ( #isLowercase #isUppercase ) bytecodes 32 2 0 129 8 1 144 9 0 250 15 10 9 0 9 32 2 0 129 8 1 145 9 1 242 15 2 245 15 5 241 15 1 .DE .PP Bytecodes are represented by four bit opcodes and four bit operands, with occasional bytes representing data (more detail can be found in the book). The three numbers written on each line for the bytecodes represent the byte value followed by the upper four bits and the lower four bits. .PP .PP If you have written a new class and want to print the class methods on a file you can use the message \fBfileOut:\fP, after first creating a file to write to. Both classes and individual methods can be filed out, and several classes and/or methods can be placed in one file. [ NOTE - file out doesn't work yet ]. .DS I > f \(<- File new > f name: 'foo.st' > f open: 'w' > Foo fileOut: f > Bar fileOut: f > Object fileOutMethod: #isFoo to: f > f close .DE .LP The file ``newfile'' will now have a printable representation of the methods for the class Foo. These can subsequently be filed back into a different smalltalk image. .DS I > f \(<- File new > f name: 'foo.st' > f open: 'r' > f fileIn > 2 isFoo False .DE .PP Finally, once the user has added classes and variables and made whatever other changes they want, the message \fBsaveImage\fP, passed to the pseudo variable \fBsmalltalk\fP, can be used to save an entire object image on a file. If the writing of the image is successful, a message will be displayed. .DS I > smalltalk saveImage Image name? newimage image newimage created > .DE .PP Typing control-D causes the interpreter to exit. .PP When the smalltalk system is restarted, an alternative image, such as the image just created, can be specified by giving its name on the argument line: .DS I st newimage .DE .PP Further information on Little Smalltalk can be found in the book. .NH New Methods, New Classes .NH 2 Stdin/Stdout Interface .PP New functionality can be added using the message \fBaddMethod\fP. When passed to an instance of \fBClass\fP, this message drops the user into a standard Unix Editor. A body for a new method can then be entered. When the user exits the editor, the method body is compiled. If it is syntactically correct, it is added to the methods for the class. If it is incorrect, the user is given the option of re-editing the method. The user is first prompted for the name of the group to which the method belongs. .DS I > Integer addMethod \& ... drop into editor and enter the following text % x \(ua ( x + ) \& ... exit editor compiler error: invalid expression start ) edit again (yn) ? \& ... .DE .PP In a similar manner, existing methods can be editing by passing their selectors, as symbols to the message \fBeditMethod:\fP. .DS I > Integer editMethod: #gcd: \& ... drop into editor working on the body of gcd: .DE .PP The name of the editor used by these methods is taken from a string pointed to by the global variable \fIeditor\fP. Different editors can be selected merely by redefining this value: .DS I editor \(<- 'emacs' .DE .PP Adding a new subclass is accomplished by sending the message \fBaddSubClass:instanceVariableNames:\fP to the superclass object. The the first argument is a symbol representing the name, the second is a string containing the names of any instance variables. .DS I > Object addSubClass: #Foo instanceVariableNames: 'x y' Object Foo display Class Name: Foo SuperClass: Object Instance Variables: x y .DE Once defined, \fBaddMethod\fP and \fBeditMethod:\fP can be used to provide functionality for the new class. .PP New classes can also be added using the fileIn mechanism. .NH 2 The Windowing Interface .PP Using the windowing interface, new classes are created by selecting the menu item \fIadd class\fP in the first browser window. New Methods are selected by choosing \fInew method\fP in a subsequent window. .NH Incompatibilities with the Book .PP It is unfortunately the case that during the transition from version 1 (the version described in the book) and version 3, certain changes to the user interface were required. I will describe these here. .PP The first incompatibility comes at the very beginning. In version 1 there were a great number of command line options. These have all been eliminated in version three. In version three the only command line option is the file name of an image file. .PP The interface to the editor has been changed. In version one this was handled by the system, and not by Smalltalk code. This required a command format that was clearly not a Smalltalk command, so that they could be distinguished. The convention adopted was to use an APL style system command: .DS I )e filename .DE In version three we have moved these functions into Smalltalk code. Now the problem is just the reverse, we need a command that is a Smalltalk command. In addition, in version one entire classes were edited at once, whereas in version three only individual methods are edited. As we have already noted, the new commands to add or edit methods are as follows: .DS I \fIclassname\fP addMethod \fIclassname\fP editMethod: \fImethodname\fP .DE .PP The only other significant syntactic change is the way primitive methods are invoked. In version one these were either named or numbered, something like the following: .DS I .DE In version three we have simply eliminated the keyword \fBprimitive\fP, so primitives now look like: .DS I <37 a b> .DE .PP There are far fewer primitives in version three, and much more of the system is now performed using Smalltalk code. .PP In addition to these syntactic changes, there are various small changes in the class structure. I hope to have a document describing these changes at some point, but as of right now the code itself is the best description. .NH Implementors Information .PP The remainder of this document contains information necessary for those wishing to examine or change the source code for the Little Smalltalk system. .NH 2 Finding Your Way Around .de Mc .IP \\\\fB\\$1\\\\fP .br @.. .PP In this section we describe the files that constitute version three of the Little Smalltalk system. .Mc memory.c This is the memory manager, the heart of the Little Smalltalk system. Although it uses a straightforward reference counting scheme, a fair amount of design effort has gone into making it as fast as possible. By modifying it's associated description file (memory.h) a number of operations can be specified either as macros or as function calls. The function calls generally perform more error checking, and should be used during initial development. Using macros, on the other hand, can improve performance dramatically. At some future date we hope to make available both reference counting and garbage collection versions of the memory manager. .Mc names.c The only data structures used internally in the Little Smalltalk system are arrays and name tables. A name table is simply an instance of class \fBDictionary\fP in which keys are symbols. Name tables are used to implement the dictionary of globally accessible values, \fBsymbols\fP, and to implement method tables. This module provides support for reading from name tables. .Mc news.c This module contains several small utility routines which create new instances of various standard classes. .Mc interp.c This module implements the actual bytecode interpreter. It is the heart of the system, where most execution time is spent. .Mc primitive.c This module contains the code that is executed to perform primitive operations. Only the standard primitives (see the section on primitives) are implemented in this module. File primitives and system specific primitives are implemented in another module, such as unixio.c for the Unix system and macio.c for the Macintosh version. .Mc unixio.c,filein.c These two modules contains I/O routines. .Mc lex.c,parser.c The files lex.c and parser.c are the lexical analyzer and parser, respectively, for compiling the textual representation of methods into bytecodes. In the current version parsing is done using a simple (although large) recursive descent parser. .Mc st.c The file st.c is the front end for the Unix version of Little Smalltalk. On the Macintosh version it is replaced by the pair of files macmain.c and macevent.c. .Mc initial.c This module contains code that reads the module form of Smalltalk code, creating an object image. This is not part of the Smalltalk bytecode interpreter, but is used in building the initial object image (see next section). .PP There are description files ( .h files, in standard C convention) which describe many of the modules described above. In addition, there is a very important file called env.h (for ``environment''). This file describes the characteristics of the operating system/machine you are running on. The general structure of this file is that the user provides one definition for their system, for example .DS I \&# define LIGHTC .DE to indicate using the Lightspeed C compiler on the macintosh, for example. Following this are block of code which, based on this one definition, define other terms representing the specific attributes of this system. Where ever possible new code should be surrounded by \fIifdef\fP directives based on words defined in this manner. The next section describes this in more detail. .NH 2 Defining System Characteristics .PP There are many ways in which compilers and operating systems differ from each other. A fair amount of work has been expanded in making sure the software will operate on most machines, which requires that different code fragments be used on different systems. In large part these are controlled by a single ``meta-define'' in the file env.h. Setting this one value then causes the expansion of another code segment, which then defines many more options. .PP In the event that you are attempting to port the software to a system that has not previously been defined, you will need to decide which set of options to enable. The next two sections contain information you may need in making this determination. .SH Define Options .PP Many options are specified merely by giving or not giving a DEFINE statement in the file env.h. The following table presents the meaning for each of these values: .Mc ALLOC Defined If there is an include file called alloc.h which defines calloc, malloc, and the like. .Mc BINREADWRITE Defined if the fopen specification for binary files must include the "b" modifier. This is true on many MS-DOS inspired systems. .Mc NOENUMS Defined if enumerated datatypes are not supported. If defined, these will be replaced by #define constants. .Mc NOTYPEDEF Defined if the typedef construct is not supported. If defined, these will be replaced by #define constructs. .Mc NOVOID Defined if the void keyword is not recognized. If defined, expect \fIlint\fP to complain a lot about functions returning values which are sometimes (or always) ignored. .Mc SIGNALS Used if \fIboth\fP the package and the package are available, and if the routine used to set signals is signal. Incompatible with \fBSSIGNALS\fP. .Mc SSIGNALS Used if \fIboth\fP the package and the package are available, and if the routine used to set signals is ssignal. Incompatible with \fBSIGNALS\fP. .Mc STRING Used if the string functions (strcpy, strcat and the like) are found in . This switch is incompatible with \fBSTRINGS\fP. .Mc STRINGS Used if the string functions (strcpy, strcat and the like) are found in . This switch is incompatible with \fBSTRING\fP. .LP In addition, several routines can optionally be replaced by macros for greater efficiency. See the file memory.h for more information. .NH 2 Building an Initial Object Image .PP There are two programs used in the Little Smalltalk system. The first is the actual bytecode interpreter. The use of this program is described in detail in other documents (see ``Exploring and Creating''). The Little Smalltalk system requires, to start, a snapshot representation of memory. This snapshot is called an object image, and the purpose of the second program, the initial object image maker, is to construct an initial object image. In theory, the this program need only be run once, by the system administrator, and thereafter all users can access the same standard object image. .PP The object image format is binary. However, since the format for binary files will undoubtedly differ from system to system, the methods which will go into the initial image are distributed in textual form, called module form. Several modules are combined to create an object image. The following describes the modules distributed on the standard tape, in the order they should be processed, and their purposes. .Mc basic.st This module contains the basic classes and methods which should be common to all implementations of Little Smalltalk. .Mc mag.st This module contains methods for those objects having magnitude, which are the basic subclasses of Magnitude. .Mc collect.st This module contains methods for the collection subclasses. .Mc file.st This module contains the classes and methods used for file operations. Although all implementations should try to support these operations, it may not always be possible on all systems. .Mc unix.st This module contains unix - specific commands, which may differ from those used under other operating systems. .Mc mult.st This module contains code for the multiprocessing scheduler. .Mc init.st This module contains code which is run to initialize the initial object image. These methods disappear after they have been executed. (or should; they don't really yet). .Mc test.st This file contains various test cases. .NH 2 Object Memory .PP There are several datatypes, not directly supported by C, that are used in the Little Smalltalk system. The first of these is the datatype byte. A byte is an eight bit unsigned (hence positive) quantity. On many systems the appropriate datatype is unsigned char, however on other systems this declaration is not recognized and other forms may be required. To aid in coverting to and from bytes the macro byteToInt() is used, which converts a byte value into an integer. In addition, the routines byteAt and byteAtPut are used to get and put bytes from byte strings. .PP The other datatype is that used to represent object points. On most machines in which a short is 16 bits, the datatype short should suffice. Much more information on the memory module can be found in the file memory.h. .NH 2 The Bottom End .PP The opposite extreme from the front end are those messages that originate within the Smalltalk bytecode interpreter and must be communicated to the user. We can divide these into two different classes of communications, editing operations and input/output operations. The following sections will treat each of these individually. .NH 3 Editing .PP We have already mentioned that commands entered by the user are converted into methods, and passed to the same method compiler as all other methods. Before the user can create a new method, however, there must be some mechanism for allowing the user to enter the method. .PP One approach would be to read the method from the standard input, just as commands are read. While easy to implement, this approach would soon prove unsatisfactory, since for every error the user would need to reenter the entire method. So some form of update, or editing, must be provided. Again, the Unix interface and the Macintosh interface solve this problem in radically different ways. .NH 4 Editing Under Unix .PP A request to edit or add a method is given by sending either the message \fBaddMethod\fP or \fBeditMethod:\fP to a class. The methods for these messages in turn call upon a common routine to perform the actual editing work. .DS I \fBaddMethod\fP self doEdit: '' \fBeditMethod:\fP name self doEdit: ( methods at: name ifAbsent: [ 'no such method ' print. \(ua nil ] ) text \fBdoEdit:\fP startingText | text | text \(<- startingText. [ text \(<- text edit. (self addMethodText: text) ifTrue: [ false ] ifFalse: [ smalltalk inquire: 'edit again (yn) ? ' ] ] whileTrue .DE .PP The Unix and MS-DOS versions of the system provide a method \fBedit\fP as part of the functionality of class \fBString\fP. When \fBedit\fP is passed to a string, an editing environment is established. The user performs editing tasks in that environment, and then exits the editing environment. Under Unix, this functionality is implemented using the file system. .DS I \fBedit\fP | file text | file \(<- File new; scratchFile; open: 'w'; print: self; close. (editor, ' ', file name) unixCommand. file open: 'r'. text \(<- file asString. file close; delete. \(ua text .DE .PP A file is created, and the contents of the string written to it. Then a standard Unix editor (given by the global variabled \fBeditor\fP) is invoked to process the file. After the user exits the editor, the contents of the file are read back as a string, the file is closed and deleted, and the string returned. The command \fBunixCommand\fP is implemented as a primitive, which invokes the system() system call: .DS I \fBunixCommand\fP \(ua <150 self> .DE .PP Although the \fBedit\fP message is used by the system only for editing methods, it is general enough for any editing application and there is no reason why the user cannot use it for other purposes. By the way, the \fBunixCommand\fP message is also used to implement file deletes. .DS I \fBdelete\fP ('rm ', name) unixCommand .DE .PP On MS-Dos systems this command should be changed to \fBDEL\fP. .PP .NH 4 Editing on the Macintosh .PP The Macintosh version takes an entirely different approach to the editing of methods. As in the Unix version, the user requests editing using the commands \fBeditMethod:\fP and \fBaddNewMethod\fP. And, as in the Unix version, these in turn invoke a common method. .DS I \fBaddMethod\fP self doEdit: ( self printString, ': new method') text: '' \fBeditMethod:\fP name self doEdit: (self printString, ': ', name) text: (methods at: name ifAbsent: ['no such method' print. \(ua nil ]) text .DE .PP Here, however, when the user asks to edit a method, a new \fIediting window\fP is created. .DS I \fBdoEdit\fP: title \fBtext\fP: text | w | w \(<- EditWindow new; acceptTask: [ self addMethodText: w getString ] ; title: title; create; print: text; showWindow .DE .PP The edit window is initialized with the current text of the method. Thereafter, the user can edit this using the standard Macintosh cut and paste conventions. The user signifies they are satisfied with the result by entering the command \fBaccept\fP, which causes the \fIacceptTask:\fP block to be executed. This block gets the text of the window (given by the message \fBgetString\fP) and passes it to \fBaddMethodText:\fP, which compiles the method, entering it in the method table if there are no errors. .NH 3 Input/Output commands .PP Under the Unix system all input/output operations are performed using the file system and the global variables stdin, stdout and stderr. Thus the message \fBerror:\fP, in class \fBSmalltalk\fP, merely prints a message to the standard error output and exits. .PP The macintosh version, although using the same file routines, does not have any notion of standard input or standard output. Thus error messages (such as from \fBerror:\fP) result in alert boxes being displayed. .PP There are also error messages that come from inside the Smalltalk interpreter itself. These are of two types, as follows: .IP 1. System errors. These are all funnelled through the routine sysError(). System errors are caused by dramatically wrong conditions, and should generally cause the system to abort after printing the message passed as argument to sysError(). .IP 2. Compiler errors. As we noted earlier, the method compiler is used to parse expressions typed directly at the keyboard, so these message can also arise in that manner. These are all funnelled through the routines compilError() and compilWarn(). These should print their arguments (two strings), in an appropriate location on the users screen. Execution continues normally after call. .NH 2 Primitives .PP Primitives are the means whereby actions that cannot be described directed in Smalltalk are performed. In version three of the Little Smalltalk system, primitives are divided into three broad categories. .IP 1. Primitives numbered less than 119 are all standard, and both the meaning and the implementation of these should be the same in all implementations of Little Smalltalk. These are largely just simple actions, such as mathematical operations. .IP 2. Primitives numbered 120-139 are reserved for file operations. Although the meaning of these primitives should remain constant across all implementations, their implementation may differ. .IP 3. Primitives number 150-255 are entirely implementation specific, and thus in porting to a new system the implementor is free to give these any meaning desired. For example under the Unix version there is, at present, only one such primitive, used to perform the system() call. On the other hand, the Macintosh version has dozens of primitives used to implement graphics functions, windowing function, editing and the like. .NH Distribution of New Implementations .PP The Little Smalltalk system is entirely public domain, and any user is free to redistribute it in any fashion they wish. As a service to the Smalltalk community, I would appreciate it if new implementors could send me a listing of changes they make, so that they can be incorporated into one standard distribution. Correspondence should be addressed to: .DS I Tim Budd Department of Computer Science Oregon State University Corvallis, Oregon 97331 USA .DE .PP Copies of the most recent distribution can also be obtained by writing to this address. In mailing out distributions, there is a small charge for media and mailing costs. .NH New Features .PP If you type ``smalltalk echo'' all input will be echoed (tty interface only). Typing smalltalk echo again undoes this. This is useful for reading from scripts. @EOF chmod 644 manual.ms echo x - memory.c cat >memory.c <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 Improved incorporating suggestions by Steve Crawley, Cambridge University, October 1987 Steven Pemberton, CWI, Amsterdam, Oct 1987 memory management module This is a rather simple, straightforward, reference counting scheme. There are no provisions for detecting cycles, nor any attempt made at compaction. Free lists of various sizes are maintained. At present only objects up to 255 bytes can be allocated, which mostly only limits the size of method (in text) you can create. reference counts are not stored as part of an object image, but are instead recreated when the object is read back in. This is accomplished using a mark-sweep algorithm, similar to those used in garbage collection. */ # include # ifdef LIGHTC # include # include # include # endif # include "env.h" # include "memory.h" # ifdef STRING # include # endif # ifdef STRINGS # include # endif # ifdef ALLOC # include # endif # ifndef ALLOC extern char *calloc(); # endif boolean debugging = false; object sysobj; /* temporary used to avoid rereference in macros */ object intobj; object symbols; /* table of all symbols created */ /* in theory the objectTable should only be accessible to the memory manager. Indeed, given the right macro definitions, this can be made so. Never the less, for efficiency sake some of the macros can also be defined to access the object table directly Some systems (e.g. the Macintosh) have static limits (e.g. 32K) which prevent the object table from being declared. In this case the object table must first be allocated via calloc during the initialization of the memory manager. */ # ifdef obtalloc struct objectStruct *objectTable; # endif # ifndef obtalloc struct objectStruct objectTable[ObjectTableMax]; # endif /* The following variables are strictly local to the memory manager module FREELISTMAX defines the maximum size of any object. */ # define FREELISTMAX 2000 static object objectFreeList[FREELISTMAX];/* free list of objects */ # ifndef mBlockAlloc # define MemoryBlockSize 6000 /* the current memory block being hacked up */ static object *memoryBlock; /* malloc'ed chunck of memory */ static int currentMemoryPosition; /* last used position in above */ # endif /* initialize the memory management module */ noreturn initMemoryManager() { int i; # ifdef obtalloc objectTable = obtalloc(ObjectTableMax, sizeof(struct objectStruct)); if (! objectTable) sysError("cannot allocate","object table"); # endif /* set all the free list pointers to zero */ for (i = 0; i < FREELISTMAX; i++) objectFreeList[i] = nilobj; /* set all the reference counts to zero */ for (i = 0; i < ObjectTableMax; i++) { objectTable[i].referenceCount = 0; objectTable[i].size = 0; } /* make up the initial free lists */ setFreeLists(); # ifndef mBlockAlloc /* force an allocation on first object assignment */ currentMemoryPosition = MemoryBlockSize + 1; # endif /* object at location 0 is the nil object, so give it nonzero ref */ objectTable[0].referenceCount = 1; objectTable[0].size = 0; } /* setFreeLists - initialise the free lists */ setFreeLists() { int i, size; register int z; register struct objectStruct *p; objectFreeList[0] = nilobj; for (z=ObjectTableMax-1; z>0; z--) { if (objectTable[z].referenceCount == 0){ /* Unreferenced, so do a sort of sysDecr: */ p= &objectTable[z]; size = p->size; if (size < 0) size = ((-size) + 1)/2; p->class = objectFreeList[size]; objectFreeList[size]= z; for (i= size; i>0; ) p->memory[--i] = nilobj; } } } /* mBlockAlloc - rip out a block (array) of object of the given size from the current malloc block */ # ifndef mBlockAlloc object *mBlockAlloc(memorySize) int memorySize; { object *objptr; if (currentMemoryPosition + memorySize >= MemoryBlockSize) { /* we toss away space here. Space-Frugal users may want to fix this by making a new object of size MemoryBlockSize - currentMemoryPositon - 1 and putting it on the free list, but I think the savings is potentially small */ memoryBlock = (object *) calloc((unsigned) MemoryBlockSize, sizeof(object)); if (! memoryBlock) sysError("out of memory","malloc failed"); currentMemoryPosition = 0; } objptr = (object *) &memoryBlock[currentMemoryPosition]; currentMemoryPosition += memorySize; return(objptr); } # endif /* allocate a new memory object */ object allocObject(memorySize) int memorySize; { int i; register int position; boolean done; if (memorySize >= FREELISTMAX) { fprintf(stderr,"size %d\n", memorySize); sysError("allocation bigger than permitted","allocObject"); } /* first try the free lists, this is fastest */ if ((position = objectFreeList[memorySize]) != 0) { objectFreeList[memorySize] = objectTable[position].class; } /* if not there, next try making a size zero object and making it bigger */ else if ((position = objectFreeList[0]) != 0) { objectFreeList[0] = objectTable[position].class; objectTable[position].size = memorySize; objectTable[position].memory = mBlockAlloc(memorySize); } else { /* not found, must work a bit harder */ done = false; /* first try making a bigger object smaller */ for (i = memorySize + 1; i < FREELISTMAX; i++) if ((position = objectFreeList[i]) != 0) { objectFreeList[i] = objectTable[position].class; /* just trim it a bit */ objectTable[position].size = memorySize; done = true; break; } /* next try making a smaller object bigger */ if (! done) for (i = 1; i < memorySize; i++) if ((position = objectFreeList[i]) != 0) { objectFreeList[i] = objectTable[position].class; objectTable[position].size = memorySize; # ifdef mBlockAlloc free(objectTable[position].memory); # endif objectTable[position].memory = mBlockAlloc(memorySize); done = true; break; } /* if we STILL don't have it then there is nothing */ /* more we can do */ if (! done) sysError("out of objects","alloc"); } /* set class and type */ objectTable[position].referenceCount = 0; objectTable[position].class = nilobj; objectTable[position].size = memorySize; return(position << 1); } object allocByte(size) int size; { object newObj; newObj = allocObject((size + 1) / 2); /* negative size fields indicate bit objects */ sizeField(newObj) = - size; return newObj; } object allocStr(str) register char *str; { register object newSym; newSym = allocByte(1 + strlen(str)); ignore strcpy(charPtr(newSym), str); return(newSym); } # ifdef incr object incrobj; /* buffer for increment macro */ # endif # ifndef incr void incr(z) object z; { if (z && ! isInteger(z)) { objectTable[z>>1].referenceCount++; } } # endif # ifndef decr void decr(z) object z; { if (z && ! isInteger(z)) { if (--objectTable[z>>1].referenceCount <= 0) { sysDecr(z); } } } # endif /* do the real work in the decr procedure */ sysDecr(z) object z; { register struct objectStruct *p; register int i; int size; p = &objectTable[z>>1]; if (p->referenceCount < 0) { fprintf(stderr,"object %d\n", z); sysError("negative reference count",""); } decr(p->class); size = p->size; if (size < 0) size = ((- size) + 1) /2; p->class = objectFreeList[size]; objectFreeList[size] = z>>1; if (size > 0) { if (p->size > 0) for (i = size; i; ) decr(p->memory[--i]); for (i = size; i > 0; ) p->memory[--i] = nilobj; } p->size = size; } # ifndef basicAt object basicAt(z, i) object z; register int i; { if (isInteger(z)) sysError("attempt to index","into integer"); else if ((i <= 0) || (i > sizeField(z))) { ignore fprintf(stderr,"index %d size %d\n", i, (int) sizeField(z)); sysError("index out of range","in basicAt"); } else return(sysMemPtr(z)[i-1]); return(0); } # endif # ifndef simpleAtPut void simpleAtPut(z, i, v) object z, v; int i; { if (isInteger(z)) sysError("assigning index to","integer value"); else if ((i <= 0) || (i > sizeField(z))) { ignore fprintf(stderr,"index %d size %d\n", i, (int) sizeField(z)); sysError("index out of range","in basicAtPut"); } else { sysMemPtr(z)[i-1] = v; } } # endif # ifndef basicAtPut void basicAtPut(z, i, v) object z, v; register int i; { simpleAtPut(z, i, v); incr(v); } # endif # ifdef fieldAtPut int f_i; # endif # ifndef fieldAtPut void fieldAtPut(z, i, v) object z, v; register int i; { decr(basicAt(z, i)); basicAtPut(z, i, v); } # endif # ifndef byteAt int byteAt(z, i) object z; register int i; { byte *bp; unsigned char t; if (isInteger(z)) sysError("indexing integer","byteAt"); else if ((i <= 0) || (i > 2 * - sizeField(z))) { fprintf(stderr,"index %d size %d\n", i, sizeField(z)); sysError("index out of range","byteAt"); } else { bp = bytePtr(z); t = bp[i-1]; fprintf(stderr,"byte at %d returning %d\n", i, (int) t); i = (int) t; } return(i); } # endif # ifndef byteAtPut void byteAtPut(z, i, x) object z; int i, x; { byte *bp; if (isInteger(z)) sysError("indexing integer","byteAtPut"); else if ((i <= 0) || (i > 2 * - sizeField(z))) { fprintf(stderr,"index %d size %d\n", i, sizeField(z)); sysError("index out of range", "byteAtPut"); } else { bp = bytePtr(z); bp[i-1] = x; } } # endif /* Written by Steven Pemberton: The following routine assures that objects read in are really referenced, eliminating junk that may be in the object file but not referenced. It is essentially a marking garbage collector algorithm using the reference counts as the mark */ visit(x) register object x; { int i, s; object *p; if (x && !isInteger(x)) { if (++(objectTable[x>>1].referenceCount) == 1) { /* then it's the first time we've visited it, so: */ visit(objectTable[x>>1].class); s = sizeField(x); if (s>0) { p = objectTable[x>>1].memory; for (i=s; i; --i) visit(*p++); } } } } int objectCount() { register int i, j; j = 0; for (i = 0; i < ObjectTableMax; i++) if (objectTable[i].referenceCount > 0) j++; return j; } @EOF chmod 644 memory.c echo x - memory.h cat >memory.h <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 */ /* The first major decision to be made in the memory manager is what an entity of type object really is. Two obvious choices are a pointer (to the actual object memory) or an index into an object table. We decided to use the latter, although either would work. Similarly, one can either define the token object using a typedef, or using a define statement. Either one will work (check this?) */ typedef short object; /* The memory module itself is defined by over a dozen routines. All of these could be defined by procedures, and indeed this was originally done. However, for efficiency reasons, many of these procedures can be replaced by macros generating in-line code. For the latter approach to work, the structure of the object table must be known. For this reason, it is given here. Note, however, that outside of the files memory.c and unixio.c (or macio.c on the macintosh) ONLY the macros described in this file make use of this structure: therefore modifications or even complete replacement is possible as long as the interface remains consistent */ struct objectStruct { object class; short referenceCount; short size; object *memory; }; # define ObjectTableMax 6500 # ifdef obtalloc extern struct objectStruct *objectTable; # endif # ifndef obtalloc extern struct objectStruct objectTable[]; # endif /* The most basic routines to the memory manager are incr and decr, which increment and decrement reference counts in objects. By separating decrement from memory freeing, we could replace these as procedure calls by using the following macros (thereby saving procedure calls):*/ extern object incrobj; # define incr(x) if ((incrobj=(x))&&!isInteger(incrobj)) \ objectTable[incrobj>>1].referenceCount++ # define decr(x) if (((incrobj=(x))&&!isInteger(incrobj))&&\ (--objectTable[incrobj>>1].referenceCount<=0)) sysDecr(incrobj); /* notice that the argument x is first assigned to a global variable; this is in case evaluation of x results in side effects (such as assignment) which should not be repeated. */ # ifndef incr extern void incr( OBJ ); # endif # ifndef decr extern void decr( OBJ ); # endif /* The next most basic routines in the memory module are those that allocate blocks of storage. There are three routines: allocObject(size) - allocate an array of objects allocByte(size) - allocate an array of bytes allocStr(str) - allocate a string and fill it in again, these may be macros, or they may be actual procedure calls */ extern object allocObject( INT ); extern object allocByte( INT ); extern object allocStr( STR ); /* integer objects are (but need not be) treated specially. In this memory manager, negative integers are just left as is, but positive integers are changed to x*2+1. Either a negative or an odd number is therefore an integer, while a nonzero even number is an object pointer (multiplied by two). Zero is reserved for the object ``nil'' Since newInteger does not fill in the class field, it can be given here. If it was required to use the class field, it would have to be deferred until names.h */ extern object intobj; # define isInteger(x) ((x) & 0x8001) # define newInteger(x) ( (intobj = x)<0 ? intobj : (intobj<<1)+1 ) # define intValue(x) ( (intobj = x)<0 ? intobj : (intobj>>1) ) /* there are four routines used to access fields within an object. Again, some of these could be replaced by macros, for efficiency basicAt(x, i) - ith field (start at 1) of object x basicAtPut(x, i, v) - put value v in object x byteAt(x, i) - ith field (start at 0) of object x byteAtPut(x, i, v) - put value v in object x*/ # define basicAt(x,i) (sysMemPtr(x)[i-1]) # define byteAt(x, i) ((int) ((bytePtr(x)[i-1]))) # ifndef basicAt extern object basicAt(OBJ X INT); # endif # define simpleAtPut(x,i,y) (sysMemPtr(x)[i-1] = y) # ifndef simpleAtPut extern void simpleAtPut(OBJ X INT X OBJ); # endif # define basicAtPut(x,i,y) incr(simpleAtPut(x, i, y)) # ifndef basicAtPut extern void basicAtPut(OBJ X INT X OBJ); # endif # define fieldAtPut(x,i,y) f_i=i; decr(basicAt(x,f_i)); basicAtPut(x,f_i,y) # ifdef fieldAtPut extern int f_i; #endif # ifndef fieldAtPut extern void fieldAtPut(OBJ X INT X OBJ); # endif # ifndef byteAt extern int byteAt(OBJ X INT); # endif # ifndef byteAtPut extern void byteAtPut(OBJ X INT X INT); # endif /* Finally, a few routines (or macros) are used to access or set class fields and size fields of objects */ # define classField(x) objectTable[x>>1].class # define setClass(x,y) incr(classField(x)=y) # define sizeField(x) objectTable[x>>1].size # define sysMemPtr(x) objectTable[x>>1].memory extern object sysobj; # define memoryPtr(x) (isInteger(sysobj = x)?(object *) 0:sysMemPtr(sysobj)) # define bytePtr(x) ((byte *) memoryPtr(x)) # define charPtr(x) ((char *) memoryPtr(x)) # define nilobj (object) 0 /* There is a large amount of differences in the qualities of malloc procedures in the Unix world. Some perform very badly when asked to allocate thousands of very small memory blocks, while others take this without any difficulty. The routine mBlockAlloc is used to allocate a small bit of memory; the version given below allocates a large block and then chops it up as needed; if desired, for versions of malloc that can handle small blocks with ease this can be replaced using the following macro: # define mBlockAlloc(size) (object *) calloc((unsigned) size, sizeof(object)) This can, and should, be replaced by a better memory management algorithm. */ # ifndef mBlockAlloc extern object *mBlockAlloc(INT); # endif /* the dictionary symbols is the source of all symbols in the system */ extern object symbols; /* finally some external declarations with prototypes */ extern noreturn sysError(STR X STR); extern noreturn dspMethod(STR X STR); extern noreturn initMemoryManager(NOARGS); extern noreturn imageWrite(FILEP); extern noreturn imageRead(FILEP); extern boolean debugging; @EOF chmod 644 memory.h echo x - mult.st cat >mult.st <<'@EOF' * * Little Smalltalk, version 3 * Written by Tim Budd, Oregon State University, July 1988 * * multiprocess scheduler * * if event driven interface (stdwin) is used the event manager sits * below the multiprocess scheduler * Class Process Object stack stackTop linkPointer Class Scheduler Object notdone processList currentProcess Class Semaphore Object count processList Methods Block 'forks' newProcess " create a new process to execute block " ^ Process new; context: context ; startAt: bytePointer. | newProcessWith: args (self checkArgumentCount: args size) ifTrue: [ (1 to: args size) do: [:i | context at: (argLoc + i - 1) put: (args at: i)]]. ^ self newProcess | fork self newProcess resume | forkWith: args (self newProcessWith: args) resume ] Methods Process 'all' execute " execute for time slice, terminating if all over " (stack size > 1500) ifTrue: [ smalltalk error: 'process stack overflow, probable loop']. <19 self> ifTrue: [] ifFalse: [ self terminate ]. | context ^ stack at: 3 | resume " resume current process " scheduler addProcess: self | terminate " kill current process " scheduler removeProcess: self. scheduler yield. | trace | link m r s | " first yield scheduler, forceing store of linkPointer" scheduler yield. link <- linkPointer. link <- stack at: link+1. " then trace back chain " [ link notNil ] whileTrue: [ m <- stack at: link+3. m notNil ifTrue: [ s <- m signature, ' ('. r <- stack at: link+2. (r to: link-1) do: [:x | s <- s, ' ', (stack at: x) class asString]. (s, ')') print ]. link <- stack at: link ] ] Methods Scheduler 'all' new "create a new scheduler with empty process list " notdone <- true. processList <- Set new. | addProcess: aProcess " add a process to the process list " processList add: aProcess | critical: aBlock "set time slice counter high to insure bytecodes are executed before continuing " <53 10000>. aBlock value. "then yield processor " <53 0>. | currentProcess " return the currently executing process " ^ currentProcess | removeProcess: aProcess " remove a given process from the process list " processList remove: aProcess. | run " run as long as process list is non empty " [ notdone ] whileTrue: [ processList size = 0 ifTrue: [ self initialize ]. processList do: [ :x | currentProcess <- x. x execute ] ] | yield " set time slice counter to zero, thereby yielding to next process " <53 0> ] Methods Process 'creation' new stack <- Array new: 50. stackTop <- 10. linkPointer <- 2. stack at: 4 put: 1. "return point" stack at: 6 put: 1. "bytecode counter" | method: x stack at: 5 put: x. | context: ctx stack at: 3 put: ctx. | startAt: x stack at: 6 put: x. "starting bytecode value" ] Methods Semaphore 'all' new count <- 0. processList <- List new | critical: aBlock self wait. aBlock value. self signal | set: aNumber count <- aNumber | signal (processList size = 0) ifTrue: [ count <- count + 1] ifFalse: [ scheduler critical: [ processList first resume. processList removeFirst ]] | wait | process | (count = 0) ifTrue: [ scheduler critical: [ process <- scheduler currentProcess. processList add: process. scheduler removeProcess: process]. scheduler yield ] ifFalse: [ count <- count - 1] ] @EOF chmod 644 mult.st echo x - names.c cat >names.c <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 Name Table module A name table is the term used for a Dictionary indexed by symbols. There are two name tables used internally by the bytecode interpreter. The first is the table, contained in the variable globalNames, that contains the names and values of all globally accessible identifiers. The second is the table of methods associated with every class. Notice that in neither of these cases does the system ever put anything INTO the tables, thus there are only routines here for reading FROM tables. One complication of instances of class Symbol is that all symbols must be unique, not only so that == will work as expected, but so that memory does not get overly clogged up with symbols. Thus all symbols are kept in a hash table, and when new symbols are created (via newSymbol(), below) they are inserted into this table, if not already there. This module also manages the definition of various symbols that are given fixed values for efficiency sake. These include the objects nil, true, false, and various classes. */ # include # include "env.h" # include "memory.h" # include "names.h" noreturn nameTableInsert(dict, hash, key, value) object dict, key, value; int hash; { object table, link, nwLink, nextLink, tablentry; /* first get the hash table */ table = basicAt(dict, 1); if (sizeField(table) < 3) sysError("attempt to insert into","too small name table"); else { hash = 3 * ( hash % (sizeField(table) / 3)); tablentry = basicAt(table, hash+1); if ((tablentry == nilobj) || (tablentry == key)) { basicAtPut(table, hash+1, key); basicAtPut(table, hash+2, value); } else { nwLink = newLink(key, value); incr(nwLink); link = basicAt(table, hash+3); if (link == nilobj) { basicAtPut(table, hash+3, nwLink); } else while(1) if (basicAt(link,1) == key) { basicAtPut(link, 2, value); break; } else if ((nextLink = basicAt(link, 3)) == nilobj) { basicAtPut(link, 3, nwLink); break; } else link = nextLink; decr(nwLink); } } } object hashEachElement(dict, hash, fun) object dict; register int hash; int (*fun)(); { object table, key, value, link; register object *hp; int tablesize; table = basicAt(dict, 1); /* now see if table is valid */ if ((tablesize = sizeField(table)) < 3) sysError("system error","lookup on null table"); else { hash = 1+ (3 * (hash % (tablesize / 3))); hp = sysMemPtr(table) + (hash-1); key = *hp++; /* table at: hash */ value = *hp++; /* table at: hash + 1 */ if ((key != nilobj) && (*fun)(key)) return value; for (link = *hp; link != nilobj; link = *hp) { hp = sysMemPtr(link); key = *hp++; /* link at: 1 */ value = *hp++; /* link at: 2 */ if ((key != nilobj) && (*fun)(key)) return value; } } return nilobj; } int strHash(str) /* compute hash value of string ---- strHash */ char *str; { register int hash; register char *p; hash = 0; for (p = str; *p; p++) hash += *p; if (hash < 0) hash = - hash; /* make sure it can be a smalltalk integer */ if (hash > 16384) hash >>= 2; return hash; } static object objBuffer; static char *charBuffer; static int strTest(key) /* test for string equality ---- strTest */ object key; { if (charPtr(key) && streq(charPtr(key), charBuffer)) { objBuffer = key; return 1; } return 0; } object globalKey(str) /* return key associated with global symbol */ char *str; { objBuffer = nilobj; charBuffer = str; ignore hashEachElement(symbols, strHash(str), strTest); return objBuffer; } object nameTableLookup(dict, str) object dict; char *str; { charBuffer = str; return hashEachElement(dict, strHash(str), strTest); } object unSyms[12]; object binSyms[30]; char *unStrs[] = {"isNil", "notNil", "value", "new", "class", "size", "basicSize", "print", "printString", 0}; char *binStrs[] = {"+", "-", "<", ">", "<=", ">=", "=", "~=", "*", "quo:", "rem:", "bitAnd:", "bitXor:", "==", ",", "at:", "basicAt:", "do:", "coerce:", "error:", "includesKey:", "isMemberOf:", "new:", "to:", "value:", "whileTrue:", "addFirst:", "addLast:", 0}; /* initialize common symbols used by the parser and interpreter */ noreturn initCommonSymbols() { int i; trueobj = globalSymbol("true"); falseobj = globalSymbol("false"); for (i = 0; unStrs[i]; i++) unSyms[i] = newSymbol(unStrs[i]); for (i = 0; binStrs[i]; i++) binSyms[i] = newSymbol(binStrs[i]); } @EOF chmod 644 names.c echo x - names.h cat >names.h <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 */ /* names and sizes of internally object used internally in the system */ # define classSize 5 # define nameInClass 1 # define sizeInClass 2 # define methodsInClass 3 # define superClassInClass 4 # define variablesInClass 5 # define methodSize 8 # define textInMethod 1 # define messageInMethod 2 # define bytecodesInMethod 3 # define literalsInMethod 4 # define stackSizeInMethod 5 # define temporarySizeInMethod 6 # define methodClassInMethod 7 # define watchInMethod 8 # define methodStackSize(x) intValue(basicAt(x, stackSizeInMethod)) # define methodTempSize(x) intValue(basicAt(x, temporarySizeInMethod)) # define contextSize 6 # define linkPtrInContext 1 # define methodInContext 2 # define argumentsInContext 3 # define temporariesInContext 4 # define blockSize 6 # define contextInBlock 1 # define argumentCountInBlock 2 # define argumentLocationInBlock 3 # define bytecountPositionInBlock 4 # define processSize 3 # define stackInProcess 1 # define stackTopInProcess 2 # define linkPtrInProcess 3 extern object trueobj; /* the pseudo variable true */ extern object falseobj; /* the pseudo variable false */ extern object getClass(OBJ); extern object copyFrom( OBJ X INT X INT); extern object newArray(INT); extern object newBlock(); extern object newByteArray(INT); extern object newClass(STR); extern object newChar(INT); extern object newContext(INT X OBJ X OBJ X OBJ); extern object newDictionary(INT); extern object newFloat(FLOAT); extern object newMethod(); extern object newLink(OBJ X OBJ); extern object newStString(STR); extern object newSymbol(STR); extern double floatValue(OBJ); extern noreturn initCommonSymbols(); /* common symbols */ extern object unSyms[], binSyms[]; extern noreturn nameTableInsert( OBJ X INT X OBJ X OBJ ); /*extern object hashEachElement( OBJ X INT X INT FUNC );*/ extern int strHash ( STR ); extern object globalKey ( STR ); extern object nameTableLookup ( OBJ X STR ); # define globalSymbol(s) nameTableLookup(symbols, s) @EOF chmod 644 names.h echo x - news.c cat >news.c <<'@EOF' /* little smalltalk, version 3.1 written by tim budd, July 1988 new object creation routines built on top of memory allocation, these routines handle the creation of various kinds of objects */ # include # include "env.h" # include "memory.h" # include "names.h" static object arrayClass = nilobj; /* the class Array */ static object intClass = nilobj; /* the class Integer */ static object stringClass = nilobj; /* the class String */ static object symbolClass = nilobj; /* the class Symbol */ ncopy(p, q, n) /* ncopy - copy exactly n bytes from place to place */ register char *p, *q; register int n; { for (; n>0; n--) *p++ = *q++; } object getClass(obj) /* getClass - get the class of an object */ register object obj; { if (isInteger(obj)) { if (intClass == nilobj) intClass = globalSymbol("Integer"); return(intClass); } return (classField(obj)); } object newArray(size) int size; { object newObj; newObj = allocObject(size); if (arrayClass == nilobj) arrayClass = globalSymbol("Array"); setClass(newObj, arrayClass); return newObj; } object newBlock() { object newObj; newObj = allocObject(blockSize); setClass(newObj, globalSymbol("Block")); return newObj; } object newByteArray(size) int size; { object newobj; newobj = allocByte(size); setClass(newobj, globalSymbol("ByteArray")); return newobj; } object newChar(value) int value; { object newobj; newobj = allocObject(1); basicAtPut(newobj, 1, newInteger(value)); setClass(newobj, globalSymbol("Char")); return(newobj); } object newClass(name) char *name; { object newObj, nameObj; newObj = allocObject(classSize); setClass(newObj, globalSymbol("Class")); /* now make name */ nameObj = newSymbol(name); basicAtPut(newObj, nameInClass, nameObj); /* now put in global symbols table */ nameTableInsert(symbols, strHash(name), nameObj, newObj); return newObj; } object copyFrom(obj, start, size) object obj; int start, size; { object newObj; int i; newObj = newArray(size); for (i = 1; i <= size; i++) { basicAtPut(newObj, i, basicAt(obj, start)); start++; } return newObj; } object newContext(link, method, args, temp) int link; object method, args, temp; { object newObj; newObj = allocObject(contextSize); setClass(newObj, globalSymbol("Context")); basicAtPut(newObj, linkPtrInContext, newInteger(link)); basicAtPut(newObj, methodInContext, method); basicAtPut(newObj, argumentsInContext, args); basicAtPut(newObj, temporariesInContext, temp); return newObj; } object newDictionary(size) int size; { object newObj; newObj = allocObject(1); setClass(newObj, globalSymbol("Dictionary")); basicAtPut(newObj, 1, newArray(size)); return newObj; } object newFloat(d) double d; { object newObj; newObj = allocByte((int) sizeof (double)); ncopy(charPtr(newObj), (char *) &d, (int) sizeof (double)); setClass(newObj, globalSymbol("Float")); return newObj; } double floatValue(o) object o; { double d; ncopy((char *) &d, charPtr(o), (int) sizeof(double)); return d; } object newLink(key, value) object key, value; { object newObj; newObj = allocObject(3); setClass(newObj, globalSymbol("Link")); basicAtPut(newObj, 1, key); basicAtPut(newObj, 2, value); return newObj; } object newMethod() { object newObj; newObj = allocObject(methodSize); setClass(newObj, globalSymbol("Method")); return newObj; } object newStString(value) char *value; { object newObj; newObj = allocStr(value); if (stringClass == nilobj) stringClass = globalSymbol("String"); setClass(newObj, stringClass); return(newObj); } object newSymbol(str) char *str; { object newObj; /* first see if it is already there */ newObj = globalKey(str); if (newObj) return newObj; /* not found, must make */ newObj = allocStr(str); if (symbolClass == nilobj) symbolClass = globalSymbol("Symbol"); setClass(newObj, symbolClass); nameTableInsert(symbols, strHash(str), newObj, nilobj); return newObj; } @EOF chmod 644 news.c echo x - parser.c cat >parser.c <<'@EOF' /* Little Smalltalk, version 2 Written by Tim Budd, Oregon State University, July 1987 Method parser - parses the textual description of a method, generating bytecodes and literals. This parser is based around a simple minded recursive descent parser. It is used both by the module that builds the initial virtual image, and by a primitive when invoked from a running Smalltalk system. The latter case could, if the bytecode interpreter were fast enough, be replaced by a parser written in Smalltalk. This would be preferable, but not if it slowed down the system too terribly. To use the parser the routine setInstanceVariables must first be called with a class object. This places the appropriate instance variables into the memory buffers, so that references to them can be correctly encoded. As this is recursive descent, you should read it SDRAWKCAB ! (from bottom to top) */ # include # include # include "env.h" # include "memory.h" # include "names.h" # include "interp.h" # include "lex.h" # ifdef STRING # include # endif # ifdef STRINGS # include # endif /* all of the following limits could be increased (up to 256) without any trouble. They are kept low to keep memory utilization down */ # define codeLimit 256 /* maximum number of bytecodes permitted */ # define literalLimit 128 /* maximum number of literals permitted */ # define temporaryLimit 32 /* maximum number of temporaries permitted */ # define argumentLimit 32 /* maximum number of arguments permitted */ # define instanceLimit 32 /* maximum number of instance vars permitted */ # define methodLimit 64 /* maximum number of methods permitted */ boolean parseok; /* parse still ok? */ extern char peek(); static int codeTop; /* top position filled in code array */ static byte codeArray[codeLimit]; /* bytecode array */ static int literalTop; /* ... etc. */ static object literalArray[literalLimit]; static int temporaryTop; static char *temporaryName[temporaryLimit]; static int argumentTop; static char *argumentName[argumentLimit]; static int instanceTop; static char *instanceName[instanceLimit]; static int maxTemporary; /* highest temporary see so far */ static char selector[80]; /* message selector */ enum blockstatus {NotInBlock, InBlock, OptimizedBlock} blockstat; setInstanceVariables(aClass) object aClass; { int i, limit; object vars; if (aClass == nilobj) instanceTop = 0; else { setInstanceVariables(basicAt(aClass, superClassInClass)); vars = basicAt(aClass, variablesInClass); if (vars != nilobj) { limit = sizeField(vars); for (i = 1; i <= limit; i++) instanceName[++instanceTop] = charPtr(basicAt(vars, i)); } } } static genCode(value) int value; { if (codeTop >= codeLimit) compilError(selector,"too many bytecode instructions in method",""); else codeArray[codeTop++] = value; } static genInstruction(high, low) int high, low; { if (low >= 16) { genInstruction(Extended, high); genCode(low); } else genCode(high * 16 + low); } static int genLiteral(aLiteral) object aLiteral; { if (literalTop >= literalLimit) compilError(selector,"too many literals in method",""); else { literalArray[++literalTop] = aLiteral; incr(aLiteral); } return(literalTop - 1); } static genInteger(val) /* generate an integer push */ int val; { if (val == -1) genInstruction(PushConstant, minusOne); else if ((val >= 0) && (val <= 2)) genInstruction(PushConstant, val); else genInstruction(PushLiteral, genLiteral(newInteger(val))); } static char *glbsyms[] = {"currentInterpreter", "nil", "true", "false", 0 }; static boolean nameTerm(name) char *name; { int i; boolean done = false; boolean isSuper = false; /* it might be self or super */ if (streq(name, "self") || streq(name, "super")) { genInstruction(PushArgument, 0); done = true; if (streq(name,"super")) isSuper = true; } /* or it might be a temporary (reverse this to get most recent first)*/ if (! done) for (i = temporaryTop; (! done) && ( i >= 1 ) ; i--) if (streq(name, temporaryName[i])) { genInstruction(PushTemporary, i-1); done = true; } /* or it might be an argument */ if (! done) for (i = 1; (! done) && (i <= argumentTop ) ; i++) if (streq(name, argumentName[i])) { genInstruction(PushArgument, i); done = true; } /* or it might be an instance variable */ if (! done) for (i = 1; (! done) && (i <= instanceTop); i++) { if (streq(name, instanceName[i])) { genInstruction(PushInstance, i-1); done = true; } } /* or it might be a global constant */ if (! done) for (i = 0; (! done) && glbsyms[i]; i++) if (streq(name, glbsyms[i])) { genInstruction(PushConstant, i+4); done = true; } /* not anything else, it must be a global */ /* must look it up at run time */ if (! done) { genInstruction(PushLiteral, genLiteral(newSymbol(name))); genMessage(false, 0, newSymbol("value")); } return(isSuper); } static int parseArray() { int i, size, base; object newLit, obj; base = literalTop; ignore nextToken(); while (parseok && (token != closing)) { switch(token) { case arraybegin: ignore parseArray(); break; case intconst: ignore genLiteral(newInteger(tokenInteger)); ignore nextToken(); break; case floatconst: ignore genLiteral(newFloat(tokenFloat)); ignore nextToken(); break; case nameconst: case namecolon: case symconst: ignore genLiteral(newSymbol(tokenString)); ignore nextToken(); break; case binary: if (streq(tokenString, "(")) { ignore parseArray(); break; } if (streq(tokenString, "-") && isdigit(peek())) { ignore nextToken(); if (token == intconst) ignore genLiteral(newInteger(- tokenInteger)); else if (token == floatconst) { ignore genLiteral(newFloat(-tokenFloat)); } else compilError(selector,"negation not followed", "by number"); ignore nextToken(); break; } ignore genLiteral(newSymbol(tokenString)); ignore nextToken(); break; case charconst: ignore genLiteral(newChar( tokenInteger)); ignore nextToken(); break; case strconst: ignore genLiteral(newStString(tokenString)); ignore nextToken(); break; default: compilError(selector,"illegal text in literal array", tokenString); ignore nextToken(); break; } } if (parseok) if (! streq(tokenString, ")")) compilError(selector,"array not terminated by right parenthesis", tokenString); else ignore nextToken(); size = literalTop - base; newLit = newArray(size); for (i = size; i >= 1; i--) { obj = literalArray[literalTop]; basicAtPut(newLit, i, obj); decr(obj); literalArray[literalTop] = nilobj; literalTop = literalTop - 1; } return(genLiteral(newLit)); } static boolean term() { boolean superTerm = false; /* true if term is pseudo var super */ if (token == nameconst) { superTerm = nameTerm(tokenString); ignore nextToken(); } else if (token == intconst) { genInteger(tokenInteger); ignore nextToken(); } else if (token == floatconst) { genInstruction(PushLiteral, genLiteral(newFloat(tokenFloat))); ignore nextToken(); } else if ((token == binary) && streq(tokenString, "-")) { ignore nextToken(); if (token == intconst) genInteger(- tokenInteger); else if (token == floatconst) { genInstruction(PushLiteral, genLiteral(newFloat(-tokenFloat))); } else compilError(selector,"negation not followed", "by number"); ignore nextToken(); } else if (token == charconst) { genInstruction(PushLiteral, genLiteral(newChar(tokenInteger))); ignore nextToken(); } else if (token == symconst) { genInstruction(PushLiteral, genLiteral(newSymbol(tokenString))); ignore nextToken(); } else if (token == strconst) { genInstruction(PushLiteral, genLiteral(newStString(tokenString))); ignore nextToken(); } else if (token == arraybegin) { genInstruction(PushLiteral, parseArray()); } else if ((token == binary) && streq(tokenString, "(")) { ignore nextToken(); expression(); if (parseok) if ((token != closing) || ! streq(tokenString, ")")) compilError(selector,"Missing Right Parenthesis",""); else ignore nextToken(); } else if ((token == binary) && streq(tokenString, "<")) parsePrimitive(); else if ((token == binary) && streq(tokenString, "[")) block(); else compilError(selector,"invalid expression start", tokenString); return(superTerm); } static parsePrimitive() { int primitiveNumber, argumentCount; if (nextToken() != intconst) compilError(selector,"primitive number missing",""); primitiveNumber = tokenInteger; ignore nextToken(); argumentCount = 0; while (parseok && ! ((token == binary) && streq(tokenString, ">"))) { ignore term(); argumentCount++; } genInstruction(DoPrimitive, argumentCount); genCode(primitiveNumber); ignore nextToken(); } static genMessage(toSuper, argumentCount, messagesym) boolean toSuper; int argumentCount; object messagesym; { boolean sent = false; int i; if ((! toSuper) && (argumentCount == 0)) for (i = 0; (! sent) && unSyms[i] ; i++) if (messagesym == unSyms[i]) { genInstruction(SendUnary, i); sent = true; } if ((! toSuper) && (argumentCount == 1)) for (i = 0; (! sent) && binSyms[i]; i++) if (messagesym == binSyms[i]) { genInstruction(SendBinary, i); sent = true; } if (! sent) { genInstruction(MarkArguments, 1 + argumentCount); if (toSuper) { genInstruction(DoSpecial, SendToSuper); genCode(genLiteral(messagesym)); } else genInstruction(SendMessage, genLiteral(messagesym)); } } static boolean unaryContinuation(superReceiver) boolean superReceiver; { int i; boolean sent; while (parseok && (token == nameconst)) { /* first check to see if it could be a temp by mistake */ for (i=1; i < temporaryTop; i++) if (streq(tokenString, temporaryName[i])) compilWarn(selector,"message same as temporary:", tokenString); for (i=1; i < argumentTop; i++) if (streq(tokenString, argumentName[i])) compilWarn(selector,"message same as argument:", tokenString); /* the next generates too many spurious messages */ /* for (i=1; i < instanceTop; i++) if (streq(tokenString, instanceName[i])) compilWarn(selector,"message same as instance", tokenString); */ sent = false; if (! sent) { genMessage(superReceiver, 0, newSymbol(tokenString)); } /* once a message is sent to super, reciever is not super */ superReceiver = false; ignore nextToken(); } return(superReceiver); } static boolean binaryContinuation(superReceiver) boolean superReceiver; { boolean superTerm; object messagesym; superReceiver = unaryContinuation(superReceiver); while (parseok && (token == binary)) { messagesym = newSymbol(tokenString); ignore nextToken(); superTerm = term(); ignore unaryContinuation(superTerm); genMessage(superReceiver, 1, messagesym); superReceiver = false; } return(superReceiver); } static int optimizeBlock(instruction, dopop) int instruction; boolean dopop; { int location; enum blockstatus savebstat; savebstat = blockstat; genInstruction(DoSpecial, instruction); location = codeTop; genCode(0); if (dopop) genInstruction(DoSpecial, PopTop); ignore nextToken(); if (streq(tokenString, "[")) { ignore nextToken(); if (blockstat == NotInBlock) blockstat = OptimizedBlock; body(); if (! streq(tokenString, "]")) compilError(selector,"missing close","after block"); ignore nextToken(); } else { ignore binaryContinuation(term()); genMessage(false, 0, newSymbol("value")); } codeArray[location] = codeTop+1; blockstat = savebstat; return(location); } static boolean keyContinuation(superReceiver) boolean superReceiver; { int i, j, argumentCount; boolean sent, superTerm; object messagesym; char pattern[80]; superReceiver = binaryContinuation(superReceiver); if (token == namecolon) { if (streq(tokenString, "ifTrue:")) { i = optimizeBlock(BranchIfFalse, false); if (streq(tokenString, "ifFalse:")) { codeArray[i] = codeTop + 3; ignore optimizeBlock(Branch, true); } } else if (streq(tokenString, "ifFalse:")) { i = optimizeBlock(BranchIfTrue, false); if (streq(tokenString, "ifTrue:")) { codeArray[i] = codeTop + 3; ignore optimizeBlock(Branch, true); } } else if (streq(tokenString, "whileTrue:")) { j = codeTop; genInstruction(DoSpecial, Duplicate); genMessage(false, 0, newSymbol("value")); i = optimizeBlock(BranchIfFalse, false); genInstruction(DoSpecial, PopTop); genInstruction(DoSpecial, Branch); genCode(j+1); codeArray[i] = codeTop+1; genInstruction(DoSpecial, PopTop); } else if (streq(tokenString, "and:")) ignore optimizeBlock(AndBranch, false); else if (streq(tokenString, "or:")) ignore optimizeBlock(OrBranch, false); else { pattern[0] = '\0'; argumentCount = 0; while (parseok && (token == namecolon)) { ignore strcat(pattern, tokenString); argumentCount++; ignore nextToken(); superTerm = term(); ignore binaryContinuation(superTerm); } sent = false; /* check for predefined messages */ messagesym = newSymbol(pattern); if (! sent) { genMessage(superReceiver, argumentCount, messagesym); } } superReceiver = false; } return(superReceiver); } static continuation(superReceiver) boolean superReceiver; { superReceiver = keyContinuation(superReceiver); while (parseok && (token == closing) && streq(tokenString, ";")) { genInstruction(DoSpecial, Duplicate); ignore nextToken(); ignore keyContinuation(superReceiver); genInstruction(DoSpecial, PopTop); } } static expression() { boolean superTerm; char assignname[60]; if (token == nameconst) { /* possible assignment */ ignore strcpy(assignname, tokenString); ignore nextToken(); if ((token == binary) && streq(tokenString, "<-")) { ignore nextToken(); assignment(assignname); } else { /* not an assignment after all */ superTerm = nameTerm(assignname); continuation(superTerm); } } else { superTerm = term(); if (parseok) continuation(superTerm); } } static assignment(name) char *name; { int i; boolean done; done = false; /* it might be a temporary */ for (i = temporaryTop; (! done) && (i > 0); i--) if (streq(name, temporaryName[i])) { expression(); genInstruction(AssignTemporary, i-1); done = true; } /* or it might be an instance variable */ for (i = 1; (! done) && (i <= instanceTop); i++) if (streq(name, instanceName[i])) { expression(); genInstruction(AssignInstance, i-1); done = true; } if (! done) { /* not known, handle at run time */ genInstruction(PushArgument, 0); genInstruction(PushLiteral, genLiteral(newSymbol(name))); expression(); genMessage(false, 2, newSymbol("assign:value:")); } } static statement() { if ((token == binary) && streq(tokenString, "^")) { ignore nextToken(); expression(); if (blockstat == InBlock) { /* change return point before returning */ genInstruction(PushConstant, contextConst); genMessage(false, 0, newSymbol("blockReturn")); genInstruction(DoSpecial, PopTop); } genInstruction(DoSpecial, StackReturn); } else { expression(); } } static body() { /* empty blocks are same as nil */ if ((blockstat == InBlock) || (blockstat == OptimizedBlock)) if ((token == closing) && streq(tokenString, "]")) { genInstruction(PushConstant, nilConst); return; } while(parseok) { statement(); if (token == closing) if (streq(tokenString,".")) { ignore nextToken(); if (token == inputend) break; else if (token == closing) break; else /* pop result, go to next statement */ genInstruction(DoSpecial, PopTop); } else break; /* leaving result on stack */ else if (token == inputend) break; /* leaving result on stack */ else { compilError(selector,"invalid statement ending; token is ", tokenString); } } } static block() { int saveTemporary, argumentCount, fixLocation; object tempsym, newBlk; enum blockstatus savebstat; saveTemporary = temporaryTop; savebstat = blockstat; argumentCount = 0; ignore nextToken(); if ((token == binary) && streq(tokenString, ":")) { while (parseok && (token == binary) && streq(tokenString,":")) { if (nextToken() != nameconst) compilError(selector,"name must follow colon", "in block argument list"); if (++temporaryTop > maxTemporary) maxTemporary = temporaryTop; argumentCount++; if (temporaryTop > temporaryLimit) compilError(selector,"too many temporaries in method",""); else { tempsym = newSymbol(tokenString); temporaryName[temporaryTop] = charPtr(tempsym); } ignore nextToken(); } if ((token != binary) || ! streq(tokenString, "|")) compilError(selector,"block argument list must be terminated", "by |"); ignore nextToken(); } newBlk = newBlock(); basicAtPut(newBlk, argumentCountInBlock, newInteger(argumentCount)); basicAtPut(newBlk, argumentLocationInBlock, newInteger(saveTemporary + 1)); genInstruction(PushLiteral, genLiteral(newBlk)); genInstruction(PushConstant, contextConst); genInstruction(DoPrimitive, 2); genCode(29); genInstruction(DoSpecial, Branch); fixLocation = codeTop; genCode(0); /*genInstruction(DoSpecial, PopTop);*/ basicAtPut(newBlk, bytecountPositionInBlock, newInteger(codeTop+1)); blockstat = InBlock; body(); if ((token == closing) && streq(tokenString, "]")) ignore nextToken(); else compilError(selector,"block not terminated by ]",""); genInstruction(DoSpecial, StackReturn); codeArray[fixLocation] = codeTop+1; temporaryTop = saveTemporary; blockstat = savebstat; } static temporaries() { object tempsym; temporaryTop = 0; if ((token == binary) && streq(tokenString, "|")) { ignore nextToken(); while (token == nameconst) { if (++temporaryTop > maxTemporary) maxTemporary = temporaryTop; if (temporaryTop > temporaryLimit) compilError(selector,"too many temporaries in method",""); else { tempsym = newSymbol(tokenString); temporaryName[temporaryTop] = charPtr(tempsym); } ignore nextToken(); } if ((token != binary) || ! streq(tokenString, "|")) compilError(selector,"temporary list not terminated by bar",""); else ignore nextToken(); } } static messagePattern() { object argsym; argumentTop = 0; ignore strcpy(selector, tokenString); if (token == nameconst) /* unary message pattern */ ignore nextToken(); else if (token == binary) { /* binary message pattern */ ignore nextToken(); if (token != nameconst) compilError(selector,"binary message pattern not followed by name",selector); argsym = newSymbol(tokenString); argumentName[++argumentTop] = charPtr(argsym); ignore nextToken(); } else if (token == namecolon) { /* keyword message pattern */ selector[0] = '\0'; while (parseok && (token == namecolon)) { ignore strcat(selector, tokenString); ignore nextToken(); if (token != nameconst) compilError(selector,"keyword message pattern", "not followed by a name"); if (++argumentTop > argumentLimit) compilError(selector,"too many arguments in method",""); argsym = newSymbol(tokenString); argumentName[argumentTop] = charPtr(argsym); ignore nextToken(); } } else compilError(selector,"illegal message selector", tokenString); } boolean parse(method, text, savetext) object method; char *text; boolean savetext; { int i; object bytecodes, theLiterals; byte *bp; lexinit(text); parseok = true; blockstat = NotInBlock; codeTop = 0; literalTop = temporaryTop = argumentTop =0; maxTemporary = 0; messagePattern(); if (parseok) temporaries(); if (parseok) body(); if (parseok) { genInstruction(DoSpecial, PopTop); genInstruction(DoSpecial, SelfReturn); } if (! parseok) { basicAtPut(method, bytecodesInMethod, nilobj); } else { bytecodes = newByteArray(codeTop); bp = bytePtr(bytecodes); for (i = 0; i < codeTop; i++) { bp[i] = codeArray[i]; } basicAtPut(method, messageInMethod, newSymbol(selector)); basicAtPut(method, bytecodesInMethod, bytecodes); if (literalTop > 0) { theLiterals = newArray(literalTop); for (i = 1; i <= literalTop; i++) { basicAtPut(theLiterals, i, literalArray[i]); decr(literalArray[i]); } basicAtPut(method, literalsInMethod, theLiterals); } else { basicAtPut(method, literalsInMethod, nilobj); } basicAtPut(method, stackSizeInMethod, newInteger(6)); basicAtPut(method, temporarySizeInMethod, newInteger(1 + maxTemporary)); if (savetext) { basicAtPut(method, textInMethod, newStString(text)); } return(true); } return(false); } @EOF chmod 644 parser.c echo x - primitive.c cat >primitive.c <<'@EOF' /* Little Smalltalk, version 3 Written by Tim Budd, Oregon State University, July 1988 Primitive processor primitives are how actions are ultimately executed in the Smalltalk system. unlike ST-80, Little Smalltalk primitives cannot fail (although they can return nil, and methods can take this as an indication of failure). In this respect primitives in Little Smalltalk are much more like traditional system calls. Primitives are combined into groups of 10 according to argument count and type, and in some cases type checking is performed. IMPORTANT NOTE: The technique used to tell if an arithmetic operation has overflowed in intBinary() depends upon integers being 16 bits. If this is not true, other techniques may be required. system specific I/O primitives are found in a different file. */ # include # include # include "env.h" # include "memory.h" # include "names.h" # ifdef STRING # include # endif # ifdef STRINGS # include # endif # ifdef SIGNAL # include # include # endif # ifdef CTRLBRK # include # include # include # endif extern object processStack; extern int linkPointer; extern double frexp(), ldexp(); extern long time(); extern object ioPrimitive(INT X OBJP); extern object sysPrimitive(INT X OBJP); # ifdef SIGNAL static jmp_buf jb; brkfun() { longjmp(jb, 1); } brkignore() {;} # endif # ifdef CTRLBRK static jmp_buf jb; brkfun() { longjmp(jb, 1); } brkignore() {;} # endif static object zeroaryPrims(number) int number; { short i; object returnedObject; int objectCount(); returnedObject = nilobj; switch(number) { case 1: fprintf(stderr,"did primitive 1\n"); break; case 2: fprintf(stderr,"object count %d\n", objectCount()); break; case 3: /* return a random number */ /* this is hacked because of the representation */ /* of integers as shorts */ i = rand() >> 8; /* strip off lower bits */ if (i < 0) i = - i; returnedObject = newInteger(i>>1); break; case 4: /* return time in seconds */ i = (short) time((long *) 0); returnedObject = newInteger(i); break; case 5: /* flip watch - done in interp */ break; case 9: exit(0); default: /* unknown primitive */ sysError("unknown primitive","zeroargPrims"); break; } return(returnedObject); } static int unaryPrims(number, firstarg) int number; object firstarg; { int i, j, saveLinkPointer; object returnedObject, saveProcessStack; returnedObject = firstarg; switch(number) { case 1: /* class of object */ returnedObject = getClass(firstarg); break; case 2: /* basic size of object */ if (isInteger(firstarg)) i = 0; else { i = sizeField(firstarg); /* byte objects have negative size */ if (i < 0) i = (-i); } returnedObject = newInteger(i); break; case 3: /* hash value of object */ if (isInteger(firstarg)) returnedObject = firstarg; else returnedObject = newInteger(firstarg); break; case 4: /* debugging print */ fprintf(stderr,"primitive 14 %d\n", firstarg); break; case 8: /* change return point - block return */ /* first get previous link pointer */ i = intValue(basicAt(processStack, linkPointer)); /* then creating context pointer */ j = intValue(basicAt(firstarg, 1)); if (basicAt(processStack, j+1) != firstarg) { returnedObject = falseobj; break; } /* first change link pointer to that of creator */ fieldAtPut(processStack, i, basicAt(processStack, j)); /* then change return point to that of creator */ fieldAtPut(processStack, i+2, basicAt(processStack, j+2)); returnedObject = trueobj; break; case 9: /* process execute */ /* first save the values we are about to clobber */ saveProcessStack = processStack; saveLinkPointer = linkPointer; # ifdef SIGNAL /* trap control-C */ signal(SIGINT, brkfun); if (setjmp(jb)) { returnedObject = falseobj; } else # endif # ifdef CRTLBRK /* trap control-C using dos ctrlbrk routine */ ctrlbrk(brkfun); if (setjmp(jb)) { returnedObject = falseobj; } else # endif if (execute(firstarg, 5000)) returnedObject = trueobj; else returnedObject = falseobj; /* then restore previous environment */ processStack = saveProcessStack; linkPointer = saveLinkPointer; # ifdef SIGNAL signal(SIGINT, brkignore); # endif # ifdef CTRLBRK ctrlbrk(brkignore); # endif break; default: /* unknown primitive */ sysError("unknown primitive","unaryPrims"); break; } return(returnedObject); } static int binaryPrims(number, firstarg, secondarg) int number; object firstarg, secondarg; { char buffer[2000]; int i; object returnedObject; returnedObject = firstarg; switch(number) { case 1: /* object identity test */ if (firstarg == secondarg) returnedObject = trueobj; else returnedObject = falseobj; break; case 2: /* set class of object */ decr(classField(firstarg)); setClass(firstarg, secondarg); returnedObject = firstarg; break; case 3: /* debugging stuff */ fprintf(stderr,"primitive 23 %d %d\n", firstarg, secondarg); break; case 4: /* string cat */ ignore strcpy(buffer, charPtr(firstarg)); ignore strcat(buffer, charPtr(secondarg)); returnedObject = newStString(buffer); break; case 5: /* basicAt: */ if (! isInteger(secondarg)) sysError("non integer index","basicAt:"); returnedObject = basicAt(firstarg, intValue(secondarg)); break; case 6: /* byteAt: */ if (! isInteger(secondarg)) sysError("non integer index","byteAt:"); i = byteAt(firstarg, intValue(secondarg)); if (i < 0) i += 256; returnedObject = newInteger(i); break; case 7: /* symbol set */ nameTableInsert(symbols, strHash(charPtr(firstarg)), firstarg, secondarg); break; case 8: /* block start */ /* first get previous link */ i = intValue(basicAt(processStack, linkPointer)); /* change context and byte pointer */ fieldAtPut(processStack, i+1, firstarg); fieldAtPut(processStack, i+4, secondarg); break; case 9: /* duplicate a block, adding a new context to it */ returnedObject = newBlock(); basicAtPut(returnedObject, 1, secondarg); basicAtPut(returnedObject, 2, basicAt(firstarg, 2)); basicAtPut(returnedObject, 3, basicAt(firstarg, 3)); basicAtPut(returnedObject, 4, basicAt(firstarg, 4)); break; default: /* unknown primitive */ sysError("unknown primitive","binaryPrims"); break; } return(returnedObject); } static int trinaryPrims(number, firstarg, secondarg, thirdarg) int number; object firstarg, secondarg, thirdarg; { char *bp, *tp, buffer[256]; int i, j; object returnedObject; returnedObject = firstarg; switch(number) { case 1: /* basicAt:Put: */ if (! isInteger(secondarg)) sysError("non integer index","basicAtPut"); fprintf(stderr,"IN BASICATPUT %d %d %d\n", firstarg, intValue(secondarg), thirdarg); fieldAtPut(firstarg, intValue(secondarg), thirdarg); break; case 2: /* basicAt:Put: for bytes */ if (! isInteger(secondarg)) sysError("non integer index","byteAtPut"); if (! isInteger(thirdarg)) sysError("assigning non int","to byte"); byteAtPut(firstarg, intValue(secondarg), intValue(thirdarg)); break; case 3: /* string copyFrom:to: */ bp = charPtr(firstarg); if ((! isInteger(secondarg)) || (! isInteger(thirdarg))) sysError("non integer index","copyFromTo"); i = intValue(secondarg); j = intValue(thirdarg); tp = buffer; if (i <= strlen(bp)) for ( ; (i <= j) && bp[i-1]; i++) *tp++ = bp[i-1]; *tp = '\0'; returnedObject = newStString(buffer); break; case 9: /* compile method */ setInstanceVariables(firstarg); if (parse(thirdarg, charPtr(secondarg), false)) { flushCache(basicAt(thirdarg, messageInMethod), firstarg); returnedObject = trueobj; } else returnedObject = falseobj; break; default: /* unknown primitive */ sysError("unknown primitive","trinaryPrims"); break; } return(returnedObject); } static int intUnary(number, firstarg) int number, firstarg; { object returnedObject; switch(number) { case 1: /* float equiv of integer */ returnedObject = newFloat((double) firstarg); break; case 2: /* print - for debugging purposes */ fprintf(stderr,"debugging print %d\n", firstarg); break; case 3: /* set time slice - done in interpreter */ break; case 5: /* set random number */ ignore srand((unsigned) firstarg); returnedObject = nilobj; break; case 8: returnedObject = allocObject(firstarg); break; case 9: returnedObject = allocByte(firstarg); break; default: sysError("intUnary primitive","not implemented yet"); } return(returnedObject); } static object intBinary(number, firstarg, secondarg) register int firstarg, secondarg; int number; { boolean binresult; long longresult; object returnedObject; switch(number) { case 0: /* addition */ longresult = firstarg; longresult += secondarg; if (longCanBeInt(longresult)) firstarg = longresult; else goto overflow; break; case 1: /* subtraction */ longresult = firstarg; longresult -= secondarg; if (longCanBeInt(longresult)) firstarg = longresult; else goto overflow; break; case 2: /* relationals */ binresult = firstarg < secondarg; break; case 3: binresult = firstarg > secondarg; break; case 4: binresult = firstarg <= secondarg; break; case 5: binresult = firstarg >= secondarg; break; case 6: case 13: binresult = firstarg == secondarg; break; case 7: binresult = firstarg != secondarg; break; case 8: /* multiplication */ longresult = firstarg; longresult *= secondarg; if (longCanBeInt(longresult)) firstarg = longresult; else goto overflow; break; case 9: /* quo: */ if (secondarg == 0) goto overflow; firstarg /= secondarg; break; case 10: /* rem: */ if (secondarg == 0) goto overflow; firstarg %= secondarg; break; case 11: /* bit operations */ firstarg &= secondarg; break; case 12: firstarg ^= secondarg; break; case 19: /* shifts */ if (secondarg < 0) firstarg >>= (- secondarg); else firstarg <<= secondarg; break; } if ((number >= 2) && (number <= 7)) if (binresult) returnedObject = trueobj; else returnedObject = falseobj; else returnedObject = newInteger(firstarg); return(returnedObject); /* on overflow, return nil and let smalltalk code */ /* figure out what to do */ overflow: returnedObject = nilobj; return(returnedObject); } static int strUnary(number, firstargument) int number; char *firstargument; { object returnedObject; switch(number) { case 1: /* length of string */ returnedObject = newInteger(strlen(firstargument)); break; case 2: /* hash value of symbol */ returnedObject = newInteger(strHash(firstargument)); break; case 3: /* string as symbol */ returnedObject = newSymbol(firstargument); break; case 7: /* value of symbol */ returnedObject = globalSymbol(firstargument); break; case 8: # ifndef NOSYSTEM returnedObject = newInteger(system(firstargument)); # endif break; case 9: sysError("fatal error", firstargument); break; default: sysError("unknown primitive", "strUnary"); break; } return(returnedObject); } static int floatUnary(number, firstarg) int number; double firstarg; { char buffer[20]; double temp; int i, j; object returnedObject; switch(number) { case 1: /* floating value asString */ ignore sprintf(buffer,"%g", firstarg); returnedObject = newStString(buffer); break; case 2: /* log */ returnedObject = newFloat(log(firstarg)); break; case 3: /* exp */ returnedObject = newFloat(exp(firstarg)); break; case 6: /* integer part */ /* return two integers n and m such that */ /* number can be written as n * 2** m */ # define ndif 12 temp = frexp(firstarg, &i); if ((i >= 0)&&(i <= ndif)) {temp=ldexp(temp, i); i=0;} else { i -= ndif; temp = ldexp(temp, ndif); } j = (int) temp; returnedObject = newArray(2); basicAtPut(returnedObject, 1, newInteger(j)); basicAtPut(returnedObject, 2, newInteger(i)); # ifdef trynew /* if number is too big it can't be integer anyway */ if (firstarg > 2e9) returnedObject = nilobj; else { ignore modf(firstarg, &temp); ltemp = (long) temp; if (longCanBeInt(ltemp)) returnedObject = newInteger((int) temp); else returnedObject = newFloat(temp); } # endif break; default: sysError("unknown primitive","floatUnary"); break; } return(returnedObject); } static object floatBinary(number, first, second) int number; double first, second; { boolean binResult; object returnedObject; switch(number) { case 0: first += second; break; case 1: first -= second; break; case 2: binResult = (first < second); break; case 3: binResult = (first > second); break; case 4: binResult = (first <= second); break; case 5: binResult = (first >= second); break; case 6: binResult = (first == second); break; case 7: binResult = (first != second); break; case 8: first *= second; break; case 9: first /= second; break; default: sysError("unknown primitive", "floatBinary"); break; } if ((number >= 2) && (number <= 7)) if (binResult) returnedObject = trueobj; else returnedObject = falseobj; else returnedObject = newFloat(first); return(returnedObject); } /* primitive - the main driver for the primitive handler */ object primitive(primitiveNumber, arguments) register int primitiveNumber; object *arguments; { register int primitiveGroup = primitiveNumber / 10; object returnedObject; if (primitiveNumber >= 150) { /* system dependent primitives, handled in separate module */ returnedObject = sysPrimitive(primitiveNumber, arguments); } else { switch(primitiveGroup) { case 0: returnedObject = zeroaryPrims(primitiveNumber); break; case 1: returnedObject = unaryPrims(primitiveNumber - 10, arguments[0]); break; case 2: returnedObject = binaryPrims(primitiveNumber-20, arguments[0], arguments[1]); break; case 3: returnedObject = trinaryPrims(primitiveNumber-30, arguments[0], arguments[1], arguments[2]); break; case 5: /* integer unary operations */ if (! isInteger(arguments[0])) returnedObject = nilobj; else returnedObject = intUnary(primitiveNumber-50, intValue(arguments[0])); break; case 6: case 7: /* integer binary operations */ if ((! isInteger(arguments[0])) || ! isInteger(arguments[1])) returnedObject = nilobj; else returnedObject = intBinary(primitiveNumber-60, intValue(arguments[0]), intValue(arguments[1])); break; case 8: /* string unary */ returnedObject = strUnary(primitiveNumber-80, charPtr(arguments[0])); break; case 10: /* float unary */ returnedObject = floatUnary(primitiveNumber-100, floatValue(arguments[0])); break; case 11: /* float binary */ returnedObject = floatBinary(primitiveNumber-110, floatValue(arguments[0]), floatValue(arguments[1])); break; case 12: case 13: /* file operations */ returnedObject = ioPrimitive(primitiveNumber-120, arguments); break; default: sysError("unknown primitive number","doPrimitive"); break; } } return (returnedObject); } @EOF chmod 644 primitive.c echo x - queen.st cat >queen.st <<'@EOF' Class NullQueen Object Class Queen Object row column neighbor Methods NullQueen 'all' first ^ true | next ^ true | checkRow: row column: column " we can't attack anything " ^ false | result ^ List new ] Methods Queen 'all' setColumn: aNumber neighbor: aQueen column <- aNumber. neighbor <- aQueen | checkRow: testRow column: testColumn | columnDifference | columnDifference <- testColumn - column. (((row = testRow) or: [ row + columnDifference = testRow]) or: [ row - columnDifference = testRow]) ifTrue: [ ^ true ]. ^ neighbor checkRow: testRow column: testColumn | first neighbor first. row <- 1. ^ self testPosition | next ^ (self advance) and: [ self testPosition ] | advance (row = 8) ifTrue: [ (neighbor next) ifFalse: [ ^ false ]. row <- 0 ]. row <- row + 1. ^ true | testPosition [neighbor checkRow: row column: column] whileTrue: [ (self advance) ifFalse: [ ^ false ]]. ^ true | result ^ neighbor result addLast: row ] Methods Test 'queen' queen | lastQueen | lastQueen <- NullQueen new. (1 to: 8) do: [:i | lastQueen <- Queen new; setColumn: i neighbor: lastQueen ]. lastQueen first. (lastQueen result asArray = #(1 5 8 6 3 7 2 4) ) ifTrue: ['8 queens test passed' print] ifFalse: [smalltalk error: '8queen test failed'] ] @EOF chmod 644 queen.st echo x - st.c cat >st.c <<'@EOF' /* Little Smalltalk, version 3 Main Driver written By Tim Budd, September 1988 Oregon State University */ # include # include "env.h" # include "memory.h" # include "names.h" # ifdef STDWIN # ifdef LIGHTC # undef NOARGC /* get arguments from stdwin's winitnew */ extern char *about_item, *about_message; # endif # endif int initial = 0; /* not making initial image */ extern int objectCount(); # ifdef NOARGC main() # endif # ifndef NOARGC main(argc, argv) int argc; char **argv; # endif { FILE *fp; object firstProcess; char *p, buffer[120]; initMemoryManager(); # ifdef BSD42 p = getenv("ST_LIBRARY"); if (p) { strcpy(buffer,p); strcat(buffer,"/"); strcat(buffer,"systemImage"); } else strcpy(buffer,"systemImage"); # endif # ifndef BSD42 strcpy(buffer,"systemImage"); # endif p = buffer; # ifdef STDWIN /* initialize the standard windows package */ # ifdef LIGHTC /* change text displayed in mac stdwin's about box */ about_item = "About Little Smalltalk ..."; about_message = "\rLittle Smalltalk, Version 3.05\r\r\ Written by Tim Budd\rOregon State University\r\r\r"; # endif winitnew(&argc, &argv); # undef NOARGC wmenusetdeflocal(1); # ifdef LIGHTC if (argc = 1) if (! waskync("use default initial object image?", 1)) waskfile("image file name", buffer, 120, 0); # endif # endif # ifndef NOARGC if (argc > 1) p = argv[1]; # endif # ifdef BINREADWRITE fp = fopen(p, "rb"); # endif # ifndef BINREADWRITE fp = fopen(p, "r"); # endif if (fp == NULL) { sysError("cannot open image", p); exit(1); } imageRead(fp); fclose(fp); initCommonSymbols(); firstProcess = globalSymbol("systemProcess"); if (firstProcess == nilobj) { sysError("no initial process","in image"); exit(1); return 1; } /* execute the main system process loop repeatedly */ /*debugging = true;*/ # ifndef STDWIN /* not using windowing interface, safe to print out message */ printf("Little Smalltalk, Version 3.05\n"); printf("Written by Tim Budd, Oregon State University\n"); # endif while (execute(firstProcess, 15000)) ; # ifdef STDWIN wdone(); # endif /* exit and return - belt and suspenders, but it keeps lint happy */ exit(0); return 0; } @EOF chmod 644 st.c echo x - stdevent.h cat >stdevent.h <<'@EOF' /* STDWIN -- EVENT STRUCT DEFINITION. */ struct event { int type; WINDOW *window; union { /* case WE_CHAR: */ int character; /* case WE_COMMAND: */ int command; /* case WE_MENU: */ struct { int id; int item; } m; /* case WE_DRAW: */ struct { int left, top, right, bottom; } area; /* case WE_MOUSE_DOWN, WE_MOUSE_MOVE, WE_MOUSE_UP: */ struct { int v; int h; int clicks; int button; int mask; } where; } u; }; #define EVENT struct event /* Event types (should be grouped differently). */ #define WE_NULL 0 /* (Used internally) */ #define WE_ACTIVATE 1 /* Window became active */ #define WE_CHAR 2 /* Character typed at keyboard */ #define WE_COMMAND 3 /* Special command, function key etc. */ #define WE_MOUSE_DOWN 4 /* Mouse button pressed */ #define WE_MOUSE_MOVE 5 /* Mouse moved with button down */ #define WE_MOUSE_UP 6 /* Mouse button released */ #define WE_MENU 7 /* Menu item selected */ #define WE_SIZE 8 /* Window size changed */ #define WE_MOVE 9 /* (Reserved) */ #define WE_DRAW 10 /* Request to redraw part of window */ #define WE_TIMER 11 /* Window's timer went off */ #define WE_DEACTIVATE 12 /* Window became inactive */ /* Command codes for WE_COMMAND. Special ways of entering these are usually available, such as clicking icons, standard menu items or special keys. Some ASCII keys are also passed back as commands since they more often than not need special processing. */ #define WC_CLOSE 1 /* Should become a separate event! */ /* The following four are arrow keys */ #define WC_LEFT 2 #define WC_RIGHT 3 #define WC_UP 4 #define WC_DOWN 5 /* ASCII keys */ #define WC_CANCEL 6 #define WC_BACKSPACE 7 #define WC_TAB 8 #define WC_RETURN 9 /* IBM-PC keys -- not in all implementations */ #define WC_HOME 10 #define WC_END 11 #define WC_CLEAR 12 #define WC_INS 13 #define WC_DEL 14 #define WC_PAGE_UP 15 #define WC_PAGE_DOWN 16 #define WC_META_LEFT 17 #define WC_META_RIGHT 18 #define WC_META_HOME 19 #define WC_META_END 20 #define WC_META_PAGE_UP 21 #define WC_META_PAGE_DOWN 22 /* Should have entries for Alt-letter and F1-F10 etc. ? */ @EOF chmod 644 stdevent.h echo x - stdtext.h cat >stdtext.h <<'@EOF' /* STDWIN -- TEXTEDIT PACKAGE DEFINITIONS */ #define TEXTEDIT struct _textedit TEXTEDIT *tealloc ARGS((WINDOW *win, int left, int top, int width)); TEXTEDIT *tecreate ARGS((WINDOW *win, int left, int top, int right, int bottom)); void tefree ARGS((TEXTEDIT *tp)); void tedestroy ARGS((TEXTEDIT *tp)); void tedraw ARGS((TEXTEDIT *tp)); void tedrawnew ARGS((TEXTEDIT *tp, int left, int top, int right, int bottom)); void temove ARGS((TEXTEDIT *tp, int left, int top, int width)); void temovenew ARGS((TEXTEDIT *tp, int left, int top, int right, int bottom)); void tesetfocus ARGS((TEXTEDIT *tp, int foc1, int foc2)); void tereplace ARGS((TEXTEDIT *tp, char *str)); void tesetbuf ARGS((TEXTEDIT *tp, char *buf, int buflen)); void tearrow ARGS((TEXTEDIT *tp, int code)); void tebackspace ARGS((TEXTEDIT *tp)); bool teclicknew ARGS((TEXTEDIT *tp, int h, int v, bool extend)); bool tedoubleclick ARGS((TEXTEDIT *tp, int h, int v)); bool teevent ARGS((TEXTEDIT *tp, EVENT *ep)); #define teclick(tp, h, v) teclicknew(tp, h, v, FALSE) #define teclickextend(tp, h, v) teclicknew(tp, h, v, TRUE) char *tegettext ARGS((TEXTEDIT *tp)); int tegetlen ARGS((TEXTEDIT *tp)); int tegetnlines ARGS((TEXTEDIT *tp)); int tegetfoc1 ARGS((TEXTEDIT *tp)); int tegetfoc2 ARGS((TEXTEDIT *tp)); int tegetleft ARGS((TEXTEDIT *tp)); int tegettop ARGS((TEXTEDIT *tp)); int tegetright ARGS((TEXTEDIT *tp)); int tegetbottom ARGS((TEXTEDIT *tp)); /* Text paragraph drawing functions: */ int wdrawpar ARGS((int h, int v, char *text, int width)); /* Returns new v coord. */ int wparheight ARGS((char *text, int width)); /* Returns height */ /* Clipboard functions; */ void wsetclip ARGS((char *p, int len)); char *wgetclip NOARGS; @EOF chmod 644 stdtext.h echo x - stdwin.h cat >stdwin.h <<'@EOF' /* GENERIC STDWIN -- INTERFACE HEADER FILE. */ #ifndef GENERIC_STDWIN #define GENERIC_STDWIN /* So this header file is skipped if included twice */ #define CURSOR_CARET /* Defined so textedit will always set the caret at the start of the focus -- useful only for ASCII terminals. */ #ifndef ARGS #define ARGS(x) () /* replace by x for ANSI C */ #endif #ifndef NOARGS #define NOARGS () /* replace by (void) for ANSI C */ #endif #ifndef bool #define bool int #endif void winit NOARGS; void winitnew ARGS((int *pargc, char ***pargv)); void wdone NOARGS; void wgetscrsize ARGS((int *pwidth, int *pheight)); void wgetscrmm ARGS((int *pmmwidth, int *pmmheight)); void wsetmaxwinsize ARGS((int width, int height)); void wsetdefwinsize ARGS((int width, int height)); void wsetdefwinpos ARGS((int h, int v)); #define MENU struct menu /* The contents of a text attributes struct are disclosed here because the interface allows the programmer to declare objects of this type. (I'm not so sure anymore that this is the right thing to do!) */ struct textattr { short font; unsigned char size; unsigned char style; }; #define TEXTATTR struct textattr #ifndef WINDOW struct window { short tag; }; #define WINDOW struct window #endif WINDOW *wopen ARGS((char *title, void (*drawproc)(/*WINDOW *win, int left, int top, int right, int bottom*/))); void wclose ARGS((WINDOW *win)); #define wgettag(win) ((win)->tag) #define wsettag(win, newtag) ((win)->tag= newtag) void wsetactive ARGS((WINDOW *win)); WINDOW *wgetactive NOARGS; void wgetwinsize ARGS((WINDOW *win, int *width, int *height)); void wsetdocsize ARGS((WINDOW *win, int width, int height)); void wsettitle ARGS((WINDOW *win, char *title)); void wsetorigin ARGS((WINDOW *win, int h, int v)); void wshow ARGS((WINDOW *win, int left, int top, int right, int bottom)); void wchange ARGS((WINDOW *win, int left, int top, int right, int bottom)); void wscroll ARGS((WINDOW *win, int left, int top, int right, int bottom, int dh, int dv)); void wfleep NOARGS; void wmessage ARGS((char *str)); void wperror ARGS((char *name)); bool waskstr ARGS((char *prompt, char *buf, int buflen)); int waskync ARGS((char *question, int dflt)); bool waskfile ARGS((char *prompt, char *buf, int buflen, bool newfile)); void wsetcaret ARGS((WINDOW *win, int h, int v)); void wnocaret ARGS((WINDOW *win)); void wsettimer ARGS((WINDOW *win, int deciseconds)); MENU *wmenucreate ARGS((int id, char *title)); void wmenudelete ARGS((MENU *mp)); int wmenuadditem ARGS((MENU *mp, char *text, int shortcut)); void wmenusetitem ARGS((MENU *mp, int i, char *text)); void wmenusetdeflocal ARGS((bool local)); void wmenuattach ARGS((WINDOW *win, MENU *mp)); void wmenudetach ARGS((WINDOW *win, MENU *mp)); void wmenuenable ARGS((MENU *mp, int item, int flag)); void wmenucheck ARGS((MENU *mp, int item, int flag)); /* The following is only available in termcap stdwin: */ void wsetshortcut ARGS((int id, int item, char *keys)); #include "stdevent.h" void wgetevent ARGS((EVENT *ep)); void wungetevent ARGS((EVENT *ep)); void wupdate ARGS((WINDOW *win)); void wbegindrawing ARGS((WINDOW *win)); void wenddrawing ARGS((WINDOW *win)); void wflush NOARGS; void wdrawline ARGS((int h1, int v1, int h2, int v2)); void wxorline ARGS((int h1, int v1, int h2, int v2)); void wdrawcircle ARGS((int h, int v, int radius)); void wdrawelarc ARGS((int h, int v, int hrad, int vrad, int ang1, int ang2)); void wdrawbox ARGS((int left, int top, int right, int bottom)); void werase ARGS((int left, int top, int right, int bottom)); void wpaint ARGS((int left, int top, int right, int bottom)); void winvert ARGS((int left, int top, int right, int bottom)); void wshade ARGS((int left, int top, int right, int bottom, int percent)); int wdrawtext ARGS((int h, int v, char *str, int len)); int wdrawchar ARGS((int h, int v, int c)); int wlineheight NOARGS; int wbaseline NOARGS; int wtextwidth ARGS((char *str, int len)); int wcharwidth ARGS((int c)); int wtextbreak ARGS((char *str, int len, int width)); void wgettextattr ARGS((TEXTATTR *attr)); void wsettextattr ARGS((TEXTATTR *attr)); void wgetwintextattr ARGS((WINDOW *win, TEXTATTR *attr)); void wsetwintextattr ARGS((WINDOW *win, TEXTATTR *attr)); void wsetplain NOARGS; void wsethilite NOARGS; void wsetinverse NOARGS; void wsetitalic NOARGS; void wsetbold NOARGS; void wsetbolditalic NOARGS; void wsetunderline NOARGS; void wsetfont ARGS((char *fontname)); void wsetsize ARGS((int pointsize)); #include "stdtext.h" #endif /* GENERIC_STDWIN */ @EOF chmod 644 stdwin.h echo x - stdwin.st cat >stdwin.st <<'@EOF' Class StandardWindows Object Class Window Object number title menus size Class TextWindow Window text Class GraphicsWindow Window Class DictionaryWindow GraphicsWindow dict select action Class BrowserWindow DictionaryWindow class method mw tw Class EventManager Process responses Class Menu Object number title itemtitles items enablestatus Methods Window 'all' new title <- ''. menus <- List new. (1 to: 15) do: [:i | (windows at: i) isNil ifTrue: [ windows at: i put: self. number <- i. ^ self ] ] | attachMenu: menu menus addLast: menu. <162 number 2 (menu number)> | activate ^ nil | deactivate ^ nil | drawEvent " overridden in subclasses " ^ nil | mouseMoveTo: mouseLocation " mouse moved with button down " ^ nil | mouseDownAt: mouseLocation " mouse down, do nothing " ^ nil | mouseUpAt: mouseLocation " mouse up " ^ nil | command: n (n = 1) ifTrue: [ self close ] | reSized size <- <161 number 6> | open " open our window, unless already opened " <160 number title 0>. menus do: [:m | <162 number 2 (m number)> ]. self reSized. | charTyped: c smalltalk beep | title: text title <- text. <164 number title> | close " close up shop " <161 number 1>. windows at: number put: nil ] Methods TextWindow 'all' open "open the window with implicit text buffer" <160 number title 1>. " now do other initialization " super open | activate super activate. printer <- self. | deactivate super deactivate. printer <- stdout. | text " read updated text and store it" ^ text <- <165 number> | print: text <166 number text> | draw "redraw window" <161 number 2>. <161 number 5>. <161 number 3> ] Methods GraphicsWindow 'all' startDrawing <161 number 2> | endDrawing <161 number 3> | drawEvent self startDrawing. self draw. self endDrawing. | draw " done by subclasses " ^ nil | at: x and: y print: text <190 x y text> ] Methods DictionaryWindow 'all' action: aBlock action <- aBlock | dictionary: d dict <- d. <163 number 2 40 (12* d size)> | draw | loc | select notNil ifTrue: [ select erase ]. loc <- 0. dict binaryDo: [:x :y | self at: 0 and: loc print: x asString. loc <- loc + 12 ]. <163 number 2 40 loc >. select notNil ifTrue: [ select invert ]. | mouseDownAt: mouseLocation | y loc | self invertSelection. y <- mouseLocation y. loc <- 0. dict binaryDo: [:a :b | loc <- loc + 12. (loc > y) ifTrue: [ select <- 0@(loc - 10) to: size x@loc. self invertSelection. action value: b. ^ nil ]] | invertSelection self startDrawing. (select notNil) ifTrue: [ select invert ]. self endDrawing. ] Methods BrowserWindow 'all' new super new. dict <- classes. action <- [:c | self selectClass: c ]. self makeBrowserMenu. | close " close all our windows " tw notNil ifTrue: [ tw close ]. mw notNil ifTrue: [ mw close ]. super close. | selectClass: c class <- c. browserMenu enableItem: 2. browserMenu disableItem: 3. browserMenu disableItem: 4. tw notNil ifTrue: [ tw close ]. mw notNil ifTrue: [ mw close ]. self openMethodWindow | openMethodWindow tw notNil ifTrue: [ tw close ]. browserMenu disableItem: 3. mw notNil ifTrue: [ mw close ]. browserMenu enableItem: 2. mw <- DictionaryWindow new; title: class printString, ' Methods'; dictionary: class methods; action: [:c | self selectMethod: c ]; attachMenu: browserMenu; open. | selectMethod: m method <- m. tw notNil ifTrue: [ tw close ]. tw <- TextWindow new; title: class printString , ' ', m asString; attachMenu: browserMenu; open. browserMenu enableItem: 3. tw print: m text | makeBrowserMenu browserMenu isNil ifTrue: [ browserMenu <- Menu new; title: 'Browser'; create. browserMenu addItem: 'add class' action: [:w | self addClass ]. browserMenu addItem: 'add method' action: [:w | self addMethod ]. browserMenu addItem: 'compile' action: [:w | self compile ]. browserMenu addItem: 'command' action: [:w | self doCommand ] ]. browserMenu disableItem: 2. browserMenu disableItem: 3. browserMenu disableItem: 4. self attachMenu: browserMenu | addClass " add a new class " tw notNil ifTrue: [ tw close ]. browserMenu enableItem: 4. tw <- TextWindow new; title: 'New Class Information'; open; attachMenu: browserMenu; print: 'superClass addSubClass: #nameOfClass ', 'instanceVariableNames: ''var1 var2'' ' | addMethod method <- Method new. tw notNil ifTrue: [ tw close ]. tw <- TextWindow new; title: class printString , ' new method'. tw open; attachMenu: browserMenu. browserMenu enableItem: 3. | compile method text: tw text. (method compileWithClass: class) ifTrue: [ class methods at: method name put: method. mw drawEvent ]. | doCommand " accept tw command " [ tw text execute. tw close. self drawEvent ] fork. ] Methods Menu 'all' new items <- Array new: 0. itemtitles <- Array new: 0. enablestatus <- Array new: 0. (1 to: 15) do: [:i | (menus at: i) isNil ifTrue: [ menus at: i put: self. number <- i. ^ self ] ] | number ^ number | addItem: name action: aBlock items <- items with: aBlock. itemtitles <- itemtitles with: name. enablestatus <- enablestatus with: true. <181 number name nil> | enableItem: n enablestatus at: n put: true. <182 number n 1 1> | disableItem: n enablestatus at: n put: false. <182 number n 1 0> | selectItem: n inWindow: w " execute the selected menu item " (items at: n) value: w | title: aString " give the title to a menu item" title <- aString | create "create menu" <180 number title>. " reinstate any old items " (1 to: items size) do: [:i | <181 number (itemtitles at: i) nil>. (enablestatus at: i) ifFalse: [ self disableItem: i]] ] Methods EventManager 'all' new responses <- Array new: 12. responses at: 1 put: [:w | w activate ]. responses at: 2 put: [:w | w charTyped: (Char new; value: <171 4>) ]. responses at: 3 put: [:w | w command: <171 9> ]. responses at: 4 put: [:w | w mouseDownAt: self mouseLocation ]. responses at: 5 put: [:w | w mouseMoveTo: self mouseLocation ]. responses at: 6 put: [:w | w mouseUpAt: self mouseLocation ]. responses at: 7 put: [:w | self eventMenu selectItem: self menuItem inWindow: w ]. responses at: 8 put: [:w | w reSized ]. responses at: 9 put: [:w | w moved ]. responses at: 10 put: [:w | w drawEvent ]. responses at: 11 put: [:w | w timer ]. responses at: 12 put: [:w | w deactivate ]. | eventWindow ^ windows at: <171 1> | eventMenu ^ menus at: <171 2> | menuItem ^ <171 3> | mouseLocation " return the current location of the mouse " ^ <172 1> | execute | i | " process one event " i <- <170>. (i = 0) ifFalse: [ (responses at: i) value: self eventWindow ] ] Methods StandardWindows 'all' makeSystemMenu systemMenu isNil ifTrue: [ systemMenu <- Menu new; title: 'System'; create. systemMenu addItem: 'browser' action: [:w | BrowserWindow new; title: 'Browser'; open ]. systemMenu addItem: 'file in' action: [:w | [ File new; fileIn: (smalltalk askFile: 'file name:')] fork ]. systemMenu addItem: 'save image' action: [:w | [ smalltalk saveImage: (smalltalk askNewFile: 'image file:') ] fork ]. systemMenu addItem: 'quit' action: [:w | scheduler quit ] ] | makeWorkspaceMenu workspaceMenu isNil ifTrue: [ workspaceMenu <- Menu new; title: 'Workspace'; create. workspaceMenu addItem: 'print it' action: [:w | [ w print: w text value asString ] fork ]. workspaceMenu addItem: 'do it' action: [:w | [ w text execute ] fork ]] | makeWorkspace TextWindow new; title: 'Workspace'; open; attachMenu: systemMenu; attachMenu: workspaceMenu. ] * * initialization code * this is executed once, by the initial image maker * * Methods Smalltalk 'doit' error: aString | ew | " print a message, and remove current process " scheduler currentProcess trace. <204 aString>. scheduler currentProcess terminate ] Methods Scheduler 'get commands' initialize stdwin makeSystemMenu. stdwin makeWorkspaceMenu. stdwin makeWorkspace. eventManager <- EventManager new. scheduler addProcess: eventManager | quit " all done - really quit " " should probably verify first " notdone <- false ] Methods UndefinedObject 'initial image' createGlobals " create global variables in initial image " true <- True new. false <- False new. smalltalk <- Smalltalk new. files <- Array new: 15. stdin <- File new; name: 'stdin'; mode: 'r'; open. stdout <- File new; name: 'stdout'; mode: 'w'; open. stderr <- File new; name: 'stderr'; mode: 'w'; open. printer <- stdout. " create a dictionary of classes " classes <- Dictionary new. symbols binaryDo: [:x :y | (y class == Class) ifTrue: [ classes at: x put: y ] ]. scheduler <- Scheduler new. stdwin <- StandardWindows new. windows <- Array new: 15. menus <- Array new: 15. windows <- Array new: 15. | initialize | aBlock | " initialize the initial object image " self createGlobals. " create the initial system process " " note the delayed recursive call " aBlock <- [ files do: [:f | f notNil ifTrue: [ f open ]]. menus do: [:m | m notNil ifTrue: [ m create ]]. windows do: [:w | w notNil ifTrue: [ w open ]]. systemProcess <- aBlock newProcess. scheduler run ]. systemProcess <- aBlock newProcess. File new; name: 'systemImage'; open: 'wb'; saveImage; close. ] Methods String 'test' print ^ printer print: self ] Methods Smalltalk 'interface' getPrompt: aString ^ <201 aString ''> | askNewFile: prompt | name | " ask for a new file name " name <- <203 prompt '' 1>. ^ name isNil ifTrue: [ '' ] ifFalse: [ name ] | askFile: prompt | name | name <- <203 prompt '' 0>. ^ name isNil ifTrue: [ '' ] ifFalse: [ name ] | inquire: aString ^ <202 aString 1> ] Methods Rectangle 'drawing' frame <194 1 left top right bottom> | paint <194 2 left top right bottom> | erase <194 3 left top right bottom> | invert <194 4 left top right bottom> | shade: aPercent <195 1 left top right bottom aPercent> ] Methods Smalltalk 'beep' beep <205> ] Methods Circle 'drawing' frame <193 1 (center x) (center y) radius> ] @EOF chmod 644 stdwin.st echo x - test.st cat >test.st <<'@EOF' * * * Little Smalltalk, version 2 * Written by Tim Budd, Oregon State University, July 1987 * * a few test cases. * * to use, first file in this file, then pas all to an instance of * class Test, for example using the messages * * File new; fileIn: 'test.st' * Test new all * Class Test Object Class One Object Class Two One Class Three Two Class Four Three Methods One 'all' test ^ 1 | result1 ^ self test ] Methods Two 'all' test ^ 2 ] Methods Three 'all' result2 ^ self result1 | result3 ^ super test ] Methods Four 'all' test ^ 4 ] Methods Test 'all' all self super. self conversions. self collections. self factorial. self filein. 'all tests completed' print | conversions " test a few conversion routines " ( (#abc == #abc asString asSymbol) and: [ ($A == $A asInteger asCharacter) and: [ (12 == 12 asDigit digitValue) and: [ (237 == 237 asString asInteger) and: [ (43 = 43 asFloat truncated) and: [ $A == ($A asString at: 1) ] ] ] ] ] ) ifFalse: [^ smalltalk error: 'conversion failure']. 'conversion test passed' print. | collections " test the collection classes a little" ( (#(1 2 3 3 2 4 2) asSet = #(1 2 3 4) asSet) and: [ (#(1 5 3 2 4) sort asArray = #(1 2 3 4 5)) and: [ (1 "(#+ respondsTo occurrencesOf: Float)" = 1) and: [ ('First' < 'last') ] ] ] ) ifFalse: [^smalltalk error: 'collection failure']. 'collection test passed' print. | factorial | t | t <- [:x | (x = 1) ifTrue: [ 1 ] ifFalse: [ x * (t value: x - 1) ] ]. ((t value: 5) = 5 factorial) ifFalse: [ smalltalk error: 'factorial failure']. 'factorial test passed' print | filein File new; name: 'queen.st'; open: 'r'; fileIn. "(globalNames includesKey: #Queen ) ifFalse: [ smalltalk error: 'fileIn failure']." 'file in test passed' print. self queen | super2 | x1 x2 x3 x4 | x1 <- One new. x2 <- Two new. x3 <- Three new. x4 <- Four new. ^ List new; addLast: x1 test; addLast: x1 result1; addLast: x2 test; addLast: x2 result1; addLast: x3 test; addLast: x4 result1; addLast: x3 result2; addLast: x4 result2; addLast: x3 result3; addLast: x4 result3 | super (self super2 asArray = #(1 1 2 2 2 4 2 4 2 2) ) ifTrue: ['super test passed' print] ifFalse: [ smalltalk error: 'super test failed'] ] @EOF chmod 644 test.st echo x - tty.c cat >tty.c <<'@EOF' /* Little Smalltalk, version 3 Written by Tim Budd, January 1989 tty interface routines this is used by those systems that have a bare tty interface systems using another interface, such as the stdwin interface will replace this file with another. */ # include # include "env.h" # include "memory.h" extern boolean parseok; /* report a fatal system error */ noreturn sysError(s1, s2) char *s1, *s2; { ignore fprintf(stderr,"%s\n%s\n", s1, s2); ignore abort(); } /* report a nonfatal system error */ noreturn sysWarn(s1, s2) char *s1, *s2; { ignore fprintf(stderr,"%s\n%s\n", s1, s2); } compilWarn(selector, str1, str2) char *selector, *str1, *str2; { ignore fprintf(stderr,"compiler warning: Method %s : %s %s\n", selector, str1, str2); } compilError(selector, str1, str2) char *selector, *str1, *str2; { ignore fprintf(stderr,"compiler error: Method %s : %s %s\n", selector, str1, str2); parseok = false; } noreturn dspMethod(cp, mp) char *cp, *mp; { /*ignore fprintf(stderr,"%s %s\n", cp, mp);*/ } givepause() { char buffer[80]; ignore fprintf(stderr,"push return to continue\n"); ignore gets(buffer); } object sysPrimitive(number, arguments) int number; object *arguments; { object returnedObject; /* someday there will be more here */ switch(number - 150) { case 0: /* do a system() call */ returnedObject = newInteger(system( charPtr(arguments[0]))); break; default: sysError("unknown primitive","sysPrimitive"); } return(returnedObject); } @EOF chmod 644 tty.c echo x - tty.st cat >tty.st <<'@EOF' * * Little Smalltalk, version 3 * Written by Tim Budd, Oregon State University, July 1988 * * methods for the unix front end - single process version * * Methods Class 'all' addMethod | m | m <- Method new; text: ''. (self doEdit: m) ifTrue: [ methods at: m name put: m ] | doEdit: method " edit a method until it compiles correctly " [ method text: method text edit. (method compileWithClass: self) ifTrue: [ ^ true ] ifFalse: [ smalltalk inquire: 'edit again (yn) ? ' ] ] whileTrue. ^ false | display ('Class name: ', name asString) print. (superClass notNil) ifTrue: [ ('Superclass: ', superClass ) print ]. 'Instance Variables:' print. variables isNil ifTrue: [ 'no instance variables ' print ] ifFalse: [ variables display ]. 'Subclasses: ' print. self subClasses display | editMethod: name | m | m <- self methodNamed: name. (m notNil) ifTrue: [ self doEdit: m ] ifFalse: [ superClass notNil ifTrue: [ superClass editMethod: name ] ifFalse: [ 'no such method' print ] ] | readInstanceVariables self variables: ((smalltalk getPrompt: 'Instance Variables? ') words: [:x | x isAlphabetic ]) | readMethods [ smalltalk inquire: 'Add a method (yn) ? ' ] whileTrue: [ self addMethod ] | viewMethod: methodName | m | m <- self methodNamed: methodName. (m notNil) ifTrue: [ m signature print. m text print ] ifFalse: [ 'no such method' print ] ] Methods Smalltalk 'all' getPrompt: aString stdout printNoReturn: aString. ^ stdin getString | inquire: aString | response | response <- self getPrompt: aString. response isNil ifTrue: [ ^ false ]. ^ 'Yy' includes: (response at: 1 ifAbsent: []) | echo " enable - disable echo input " echoInput <- echoInput not ] Methods String 'all' edit | file text | file <- File new; scratchFile; open: 'w'; print: self; close. (editor, ' ', file name) unixCommand. file open: 'r'. text <- file asString. file close; delete. ^ text | print stdout print: self ] * * initialization code * this is executed once, by the initial image maker * * Methods Smalltalk 'doit' error: aString " print a message, and remove current process " stderr print: aString. scheduler currentProcess; trace; terminate. ] Methods Scheduler 'get commands' initialize | string | <2>. string <- smalltalk getPrompt: '> '. string isNil ifTrue: [ notdone <- false ] ifFalse: [ (string size > 0) ifTrue: [ echoInput ifTrue: [ string print ]. [ string value print ] fork ] ] ] Methods UndefinedObject 'initial image' createGlobals | aBlock | " create global variables in initial image " true <- True new. false <- False new. smalltalk <- Smalltalk new. files <- Array new: 15. stdin <- File new; name: 'stdin'; mode: 'r'; open. stdout <- File new; name: 'stdout'; mode: 'w'; open. stderr <- File new; name: 'stderr'; mode: 'w'; open. editor <- 'vi'. " create a dictionary of classes " classes <- Dictionary new. symbols binaryDo: [:x :y | (y class == Class) ifTrue: [ classes at: x put: y ] ]. scheduler <- Scheduler new. " create the initial system process " " note the delayed recursive call " aBlock <- [ files do: [:f | f notNil ifTrue: [ f open ]]. systemProcess <- aBlock newProcess. echoInput <- false. scheduler run ]. systemProcess <- aBlock newProcess. | initialize " initialize the initial object image " self createGlobals. File new; name: 'systemImage'; open: 'w'; saveImage; close. ] @EOF chmod 644 tty.st echo x - unixio.c cat >unixio.c <<'@EOF' /* Little Smalltalk, version 2 Unix specific input and output routines written by tim budd, January 1988 */ # include # include "env.h" # include "memory.h" # include "names.h" struct { int di; object cl; short ds; } dummyObject; /* imageRead - read in an object image we toss out the free lists built initially, reconstruct the linkages, then rebuild the free lists around the new objects. The only objects with nonzero reference counts will be those reachable from either symbols */ static int fr(fp, p, s) FILE *fp; char *p; int s; { int r; r = fread(p, s, 1, fp); if (r && (r != 1)) sysError("imageRead count error",""); return r; } noreturn imageRead(fp) FILE *fp; { short i, size; object *mBlockAlloc(); ignore fr(fp, (char *) &symbols, sizeof(object)); i = 0; while(fr(fp, (char *) &dummyObject, sizeof(dummyObject))) { i = dummyObject.di; if ((i < 0) || (i > ObjectTableMax)) sysError("reading index out of range",""); objectTable[i].class = dummyObject.cl; if ((objectTable[i].class < 0) || ((objectTable[i].class>>1) > ObjectTableMax)) { fprintf(stderr,"index %d\n", dummyObject.cl); sysError("class out of range","imageRead"); } objectTable[i].size = size = dummyObject.ds; if (size < 0) size = ((- size) + 1) / 2; if (size != 0) { objectTable[i].memory = mBlockAlloc((int) size); ignore fr(fp, (char *) objectTable[i].memory, sizeof(object) * (int) size); } else objectTable[i].memory = (object *) 0; } /* now restore ref counts, getting rid of unneeded junk */ visit(symbols); /* toss out the old free lists, build new ones */ setFreeLists(); } /* imageWrite - write out an object image */ static fw(fp, p, s) FILE *fp; char *p; int s; { if (fwrite(p, s, 1, fp) != 1) { sysError("imageWrite size error",""); } } noreturn imageWrite(fp) FILE *fp; { short i, size; fw(fp, (char *) &symbols, sizeof(object)); for (i = 0; i < ObjectTableMax; i++) { if (objectTable[i].referenceCount > 0) { dummyObject.di = i; dummyObject.cl = objectTable[i].class; dummyObject.ds = size = objectTable[i].size; fw(fp, (char *) &dummyObject, sizeof(dummyObject)); if (size < 0) size = ((- size) + 1) / 2; if (size != 0) fw(fp, (char *) objectTable[i].memory, sizeof(object) * size); } } } /* i/o primitives - necessarily rather UNIX dependent; basically, files are all kept in a large array. File operations then just give an index into this array */ # define MAXFILES 20 /* we assume this is initialized to NULL */ static FILE *fp[MAXFILES]; object ioPrimitive(number, arguments) int number; object *arguments; { int i, j; char *p, buffer[1024]; object returnedObject; returnedObject = nilobj; i = intValue(arguments[0]); switch(number) { case 0: /* file open */ i = intValue(arguments[0]); p = charPtr(arguments[1]); if (streq(p, "stdin")) fp[i] = stdin; else if (streq(p, "stdout")) fp[i] = stdout; else if (streq(p, "stderr")) fp[i] = stderr; else { fp[i] = fopen(p, charPtr(arguments[2])); } if (fp[i] == NULL) returnedObject = nilobj; else returnedObject = newInteger(i); break; case 1: /* file close - recover slot */ if (fp[i]) ignore fclose(fp[i]); fp[i] = NULL; break; case 2: /* file size */ case 3: /* file in */ if (fp[i]) fileIn(fp[i], true); break; case 4: /* get character */ sysError("file operation not implemented yet",""); case 5: /* get string */ if (! fp[i]) break; j = 0; buffer[j] = '\0'; while (1) { if (fgets(&buffer[j], 512, fp[i]) == NULL) return(nilobj); /* end of file */ if (fp[i] == stdin) { /* delete the newline */ j = strlen(buffer); if (buffer[j-1] == '\n') buffer[j-1] = '\0'; } j = strlen(buffer)-1; if (buffer[j] != '\\') break; /* else we loop again */ } returnedObject = newStString(buffer); break; case 7: /* write an object image */ if (fp[i]) imageWrite(fp[i]); returnedObject = trueobj; break; case 8: /* print no return */ case 9: /* print string */ if (! fp[i]) break; ignore fputs(charPtr(arguments[1]), fp[i]); if (number == 8) ignore fflush(fp[i]); else ignore fputc('\n', fp[i]); break; default: sysError("unknown primitive","filePrimitive"); } return(returnedObject); } @EOF chmod 644 unixio.c echo x - vms.com cat >vms.com <<'@EOF' $SET VERIFY $CC ST,FILEIN,INITIAL,INTERP,LEX,NAMES,NEWS,PARSER,PRIMITIVE,UNIXIO,MEMORY,- TTY $LINK ST+MEMORY+NAMES+NEWS+INTERP+PRIMITIVE+FILEIN+LEX+PARSER+UNIXIO+TTY $LINK INITIAL+MEMORY+NAMES+NEWS+INTERP+PRIMITIVE+FILEIN+LEX+PARSER+UNIXIO+TTY $RUN INITIAL $SET NOVERIFY @EOF chmod 644 vms.com echo x - winprim.c cat >winprim.c <<'@EOF' /* stdwin window primitives written by tim budd, january 1989 */ # include "stdwin.h" /* undefine stdwin's NOARGS so it doesn't conflict with mine */ # undef NOARGS # include # include "env.h" # include "memory.h" # include "names.h" extern object trueobj, falseobj; extern boolean parseok; extern int initial; /* report a fatal system error */ noreturn sysError(s1, s2) char *s1, *s2; { char buffer[1024]; if (initial) { ignore fprintf(stderr,"%s\n%s\n", s1, s2); } else { ignore sprintf(buffer,"%s %s", s1, s2); wmessage(buffer); } ignore abort(); } /* report a nonfatal system error */ noreturn sysWarn(s1, s2) char *s1, *s2; { char buffer[1024]; if (initial) { ignore fprintf(stderr,"%s\n%s\n", s1, s2); } else { ignore sprintf(buffer,"%s %s", s1, s2); wmessage(buffer); } } compilWarn(selector, str1, str2) char *selector, *str1, *str2; { char buffer[1024]; if (initial) { ignore fprintf(stderr,"compiler warning: Method %s : %s %s\n", selector, str1, str2); } else { ignore sprintf(buffer,"warn: %s %s", str1, str2); wmessage(buffer); } } compilError(selector, str1, str2) char *selector, *str1, *str2; { char buffer[1024]; if (initial) { ignore fprintf(stderr,"compiler error: Method %s : %s %s\n", selector, str1, str2); } else { ignore sprintf(buffer,"error: %s %s", str1, str2); wmessage(buffer); } parseok = false; } noreturn dspMethod(cp, mp) char *cp, *mp; { /*ignore fprintf(stderr,"%s %s\n", cp, mp);*/ } givepause() { char buffer[80]; if (initial) { ignore fprintf(stderr,"push return to continue\n"); ignore gets(buffer); } else wmessage("wait to continue"); } static object newPoint(x, y) int x, y; { object newObj; newObj = allocObject(2); setClass(newObj, globalSymbol("Point")); basicAtPut(newObj, 1, newInteger(x)); basicAtPut(newObj, 2, newInteger(y)); return newObj; } /* windows and text edit buffers are maintained in a single structure */ # define WINDOWMAX 15 static struct { WINDOW *w; TEXTEDIT *tp; } ws[WINDOWMAX]; /* menus are maintained in a similar structure */ # define MENUMAX 20 static MENU *mu[MENUMAX]; /* current event record */ static EVENT evrec; static int findWindow(w) WINDOW *w; { int i; for (i = 0; i < WINDOWMAX; i++) if (w == ws[i].w) return(i); sysError("can't find window",""); return(0); } static void drawproc(w, left, top, right, bottom) WINDOW *w; int left, top, right, bottom; { int i; i = findWindow(w); if (ws[i].tp) tedraw(ws[i].tp); } object sysPrimitive(primitiveNumber, arguments) int primitiveNumber; object *arguments; { int i, j, k; int p1, p2, p3, p4; char *c; WINDOW *w; object returnedObject; returnedObject = nilobj; switch(primitiveNumber) { case 160: /* window open */ i = intValue(arguments[0]); /* win number */ if (ws[i].w) break; /* already open */ c = charPtr(arguments[1]); /* title */ j = intValue(arguments[2]); /* text or not */ if (j) { ws[i].w = w = wopen(c, drawproc); wgetwinsize(w, &j, &k); ws[i].tp = tecreate(w, 0, 0, j, k); } else { ws[i].w = wopen(c, NULL); ws[i].tp = 0; } break; case 161: /* variety of simple actions */ i = intValue(arguments[0]); /* win number */ if (! (w = ws[i].w)) break; /* return if no open */ j = intValue(arguments[1]); /* action */ switch(j) { case 1: if (ws[i].tp) {tefree(ws[i].tp); ws[i].tp = NULL;} ws[i].w = NULL; wclose(w); break; case 2: wbegindrawing(w); break; case 3: wenddrawing(w); break; case 4: wsetactive(w); break; case 5: if (ws[i].tp) tedraw(ws[i].tp); break; case 6: wgetwinsize(w, &i, &j); returnedObject = newPoint(i, j); break; } break; case 162: /* one int arg actions */ i = intValue(arguments[0]); /* win number */ if (! (w = ws[i].w)) break; /* return if no open */ i = intValue(arguments[1]); /* action */ j = intValue(arguments[2]); /* x */ switch(i) { case 1: /* set timer */ wsettimer(w, j); break; case 2: /* menu attach */ if (j >= 0 && j < MENUMAX && mu[j] != 0) wmenuattach(w, mu[j]); break; case 3: /* menu detach */ if (j >= 0 && j < MENUMAX && mu[j] != 0) wmenudetach(w, mu[j]); break; } break; case 163: /* two int arg actions */ i = intValue(arguments[0]); /* win number */ if (! (w = ws[i].w)) break; /* return if not open */ i = intValue(arguments[1]); /* action */ j = intValue(arguments[2]); /* x */ k = intValue(arguments[3]); /* y */ switch(i) { case 2: wsetdocsize(w, j, k); break; case 3: wsetorigin(w, j, k); break; } break; case 164: /* title */ i = intValue(arguments[0]); /* win number */ if (! (w = ws[i].w)) break; /* return if no open */ c = charPtr(arguments[1]); wsettitle(w, c); break; case 165: /* get text */ i = intValue(arguments[0]); if (ws[i].tp) returnedObject = newStString(tegettext(ws[i].tp)); break; case 166: /* replace text */ i = intValue(arguments[0]); if (ws[i].tp) { j = tegetlen(ws[i].tp); tesetfocus(ws[i].tp, j, j); /* add newline */ tereplace(ws[i].tp, "\n"); tereplace(ws[i].tp, charPtr(arguments[1])); wsetdocsize(ws[i].w, 0, tegetbottom(ws[i].tp)); } break; case 170: getevent: /* get next event */ wgetevent(&evrec); i = findWindow(evrec.window); if (ws[i].tp) { if (evrec.type == WE_SIZE) { /* change textedit size */ wgetwinsize(w = ws[i].w, &j, &k); temovenew(ws[i].tp, 0, 0, j, k); wsetdocsize(ws[i].w, 0, tegetbottom(ws[i].tp)); goto getevent; } if (teevent(ws[i].tp, &evrec)) goto getevent; } /*fprintf(stderr,"returning event type %d %d\n", evrec.type, evrec.u.where.clicks);*/ returnedObject = newInteger(evrec.type); break; case 171: /* integer event info */ i = intValue(arguments[0]); switch(i) { case 1: /* event window */ j = findWindow(evrec.window); break; case 2: /* event menu */ j = evrec.u.m.id - 1; break; case 3: /* menu item */ j = evrec.u.m.item + 1; break; case 4: /* char typed */ j = evrec.u.character; break; case 5: /* mouse y */ j = evrec.u.where.v; break; case 6: /* mouse button */ j = evrec.u.where.button; break; case 7: /* mouse click number */ j = evrec.u.where.clicks; case 8: /* char typed */ j = evrec.u.character; case 9: /* command typed */ j = evrec.u.command; } returnedObject = newInteger(j); break; case 172: /* more general event info */ i = intValue(arguments[0]); switch(i) { case 1: /* mouse down point */ returnedObject = newPoint(evrec.u.where.h, evrec.u.where.v); break; } break; case 180: /* new menu */ i = intValue(arguments[0]); /* menu id */ c = charPtr(arguments[1]); /* title */ mu[i] = wmenucreate(i+1, c); /* avoid meny id 0 */ break; case 181: /* menu item */ i = intValue(arguments[0]); /* menu number */ c = charPtr(arguments[1]); /* title */ if (isInteger(arguments[2])) j = intValue(arguments[2]); else j = -1; wmenuadditem(mu[i], c, j); break; case 182: /* check menu items */ i = intValue(arguments[0]); /* menu number */ j = intValue(arguments[1]); /* item number */ k = intValue(arguments[2]); /* action */ p1 = intValue(arguments[3]); /* flag */ switch(k) { case 1: /* enable/disable */ wmenuenable(mu[i],j-1,p1); break; case 2: /* check/no check */ wmenucheck(mu[i],j-1,p1); break; } break; case 190: /* print text graphics */ i = intValue(arguments[0]); /* x */ j = intValue(arguments[1]); /* y */ c = charPtr(arguments[2]); /* text */ wdrawtext(i, j, c, -1); break; case 192: /* points */ i = intValue(arguments[0]); /* action */ p1 = intValue(arguments[1]); p2 = intValue(arguments[2]); p3 = intValue(arguments[3]); p4 = intValue(arguments[4]); switch(i) { case 1: /* draw line */ wdrawline(p1, p2, p3, p4); break; } break; case 193: /* circles and the like */ i = intValue(arguments[0]); /* action */ p1 = intValue(arguments[1]); p2 = intValue(arguments[2]); p3 = intValue(arguments[3]); switch(i) { case 1: /* draw circle */ wdrawcircle(p1,p2,p3); break; case 2: /* draw char */ wdrawchar(p1,p2,p3); break; } break; case 194: /* rectangles */ i = intValue(arguments[0]); /* action */ p1 = intValue(arguments[1]); p2 = intValue(arguments[2]); p3 = intValue(arguments[3]); p4 = intValue(arguments[4]); switch(i) { case 1: /* draw box */ wdrawbox(p1,p2,p3,p4); break; case 2: /* paint */ wpaint(p1,p2,p3,p4); break; case 3: /* erase */ werase(p1,p2,p3,p4); break; case 4: /* invert */ winvert(p1,p2,p3,p4); break; } break; case 195: /* shading */ i = intValue(arguments[0]); /* action */ p1 = intValue(arguments[1]); p2 = intValue(arguments[2]); p3 = intValue(arguments[3]); p4 = intValue(arguments[4]); j = intValue(arguments[5]); switch(i) { case 1: /* shading */ wshade(p1,p2,p3,p4,j); break; } break; case 200: /* issue a message */ c = charPtr(arguments[0]); wmessage(c); break; case 201: /* ask a question */ { char replybuffer[120]; strcpy(replybuffer, charPtr(arguments[1])); if (waskstr(charPtr(arguments[0]), replybuffer, sizeof replybuffer)) returnedObject = newStString(replybuffer); } break; case 202: /* asky a binary question */ i = waskync(charPtr(arguments[0]), intValue(arguments[1])); if (i == 1) returnedObject = trueobj; else if (i == 0) returnedObject = falseobj; break; case 203: /* ask for a file */ { char replybuffer[120]; strcpy(replybuffer, charPtr(arguments[1])); if (waskfile(charPtr(arguments[0]), replybuffer, 120, intValue(arguments[2]))) returnedObject = newStString(replybuffer); } break; case 204: /* error message */ wperror(charPtr(arguments[0])); break; case 205: /* beep */ wfleep(); break; default: fprintf(stderr,"primitive not implmented yet %d\n", primitiveNumber); sysError("primitive not done",""); } return returnedObject; } @EOF chmod 644 winprim.c exit 0