rsalz@uunet.UU.NET (Rich Salz) (10/04/87)
Submitted-by: Tim Budd <budd@cs.orst.edu>
Posting-number: Volume 11, Issue 88
Archive-name: little-st/part03
The following is version two of the Little Smalltalk system, distributed
in three parts. Little Smalltalk is an interpreter for the language
Smalltalk.
Questions or comments should be sent to Tim Budd,
budd@oregon-state.csnet
budd@cs.orst.edu (128.193.32.1)
{tektronix, hp-pcd}!orstcs!budd
-----------cut here--------------------------------------------
: To unbundle, sh this file
echo unbundling basicclasses 1>&2
cat >basicclasses <<'End'
*
* Little Smalltalk, version 2
* Written by Tim Budd, Oregon State University, July 1987
*
* basic classes common to all images
*
Declare Object
Declare Block Object context argumentCounter argumentLocation bytecodeCounter creatingInterpreter
Declare Boolean Object
Declare True Boolean
Declare False Boolean
Declare Class Object name size methods superClass variables icon
Declare Context Object method methodClass arguments temporaries
Declare Link Object key value nextLink
Declare Magnitude Object
Declare Char Magnitude value
Declare Collection Magnitude
Declare IndexedCollection Collection
Declare Array IndexedCollection
Declare ByteArray Array
Declare String ByteArray
Declare Dictionary IndexedCollection
Declare Interval Collection lower upper step
Declare List Collection links
Declare Set List
Declare Number Magnitude
Declare Integer Number
Declare Float Number
Declare Method Object text message bytecodes literals stackSize temporarySize
Declare Process Object interpreter nextProcess state
Declare Random Object
Declare Smalltalk Object
Declare Symbol Object
Declare UndefinedObject Object
*
Instance Smalltalk smalltalk
Instance True true
Instance False false
*
Class Object
== aValue
^ <21 self aValue>
|
= aValue
^ self == aValue
|
basicAt: index
^ <25 self index>
|
basicAt: index put: value
^ <31 self index value>
|
basicSize
^ <12 self>
|
class
^ <11 self>
|
hash
^ <13 self>
|
isMemberOf: aClass
^ self class == aClass
|
isNil
^ false
|
isKindOf: aClass | myClass |
myClass <- self class.
[ myClass notNil ] whileTrue:
[ (myClass == aClass) ifTrue: [ ^ true ].
myClass <- myClass superClass ].
|
notNil
^ true
|
print
^ self printString print
|
printString
^ self class printString
]
Class Array
< coll
(coll isKindOf: Array)
ifTrue: [ self with: coll
do: [:x :y | (x < y) ifTrue: [ ^ true ]].
^ 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) ]
|
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
|
includesKey: index
^ index between: 1 and: self size
|
size
^ self basicSize
|
sort
^ self sort: [:a :b | a < b ]
|
sort: sortBlock
(self size to: 2 by: -1 ) do:
[:high | (1 to: high - 1) do:
[:index | (sortBlock value: (self at: index)
value: (self at: high))
ifFalse: [ self exchange: index and: high ] ] ]
|
with: coll do: aBlock
(1 to: (self size min: coll size))
do: [:i | aBlock value: (self at: i)
value: (coll at: i) ]
]
Class Block
value
^ context executeFrom: bytecodeCounter
|
value: x
context temporaries at: argumentLocation put: x.
^ context executeFrom: bytecodeCounter
|
value: x value: y | temps |
temps <- context temporaries.
temps at: argumentLocation put: x.
temps at: argumentLocation + 1 put: y.
^ context executeFrom: bytecodeCounter
|
value: x value: y value: z | temps |
temps <- context temporaries.
temps at: argumentLocation put: x.
temps at: argumentLocation + 1 put: y.
temps at: argumentLocation + 2 put: z.
^ context executeFrom: bytecodeCounter
|
whileTrue: aBlock
( self value ) ifTrue:
[ aBlock value.
[ self value ] whileTrue: [ aBlock value ] ]
]
Class Boolean
ifTrue: trueBlock
^ self ifTrue: [ trueBlock value ] ifFalse: [ nil ]
|
ifFalse: falseBlock
^ self ifTrue: [ nil ] ifFalse: [ falseBlock value ]
|
ifFalse: falseBlock ifTrue: trueBlock
^ self ifTrue: [ trueBlock value ]
ifFalse: [ falseBlock value ]
|
and: aBlock
self ifTrue: [ ^ aBlock value ].
^ false
|
or: aBlock
self ifFalse: [ ^ aBlock value ].
^ true
]
Class ByteArray
asString
<22 self String>
|
basicAt: index put: value
^ <32 self index value >
|
basicAt: index
^ <26 self index>
|
size: value
^ <22 <59 value> ByteArray>
|
size
^ self basicSize * 2
]
Class Char
< aValue
^ (aValue isMemberOf: Char)
ifTrue: [ value < aValue asciiValue ]
ifFalse: [ smalltalk error: 'char compared to nonchar']
|
== aValue
^ (aValue isMemberOf: Char)
ifTrue: [ value = aValue asciiValue ]
ifFalse: [ false ]
|
= aValue
^ self == aValue
|
asciiValue
^ value
|
asString
^ ' ' copy; at: 1 put: self
|
digitValue
^ value - 48
|
isAlphabetic
^ (self isLowercase) or: [ self isUppercase ]
|
isAlphaNumeric
^ (self isAlphabetic) or: [ self isDigit ]
|
isBlank
^ value = 32
|
isDigit
^ value between: 48 and: 57
|
isLowercase
^ value between: 97 and: 122
|
isUppercase
^ value between: 65 and: 90
|
value: aValue " private - used for initializatin "
value <- aValue
|
printString
^ '$', value asCharacter
]
Class Class
new | newObject |
newObject <- self new: size.
(self == Class)
ifTrue: [ newObject initialize ]
ifFalse: [(methods includesKey: #new )
ifTrue: [ ^ newObject new ]].
^ newObject
|
new: size " hack out block the right size and class "
^ < 22 < 58 size > self >
|
initialize
superClass <- Object.
size <- 0.
methods <- Dictionary new
|
name: aString
name <- aString
|
methods
^ methods
|
objectSize
^ size
|
printString
^ name asString
|
respondsTo: message
^ methods includesKey: message
|
superClass
^ superClass
|
superClass: aClass
superClass <- aClass
|
variables
^ variables
|
variables: nameArray
variables <- nameArray.
size <- superClass objectSize + nameArray size
]
Class Collection
< coll
self do: [:x | (coll includes: x) ifFalse: [ ^ false ]].
^ true
|
= 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
|
detect: aBlock
^ self detect: aBlock
ifAbsent: [ smalltalk error: 'no object found matching detect']
|
detect: aBlock ifAbsent: exceptionBlock
self do: [:x |
(aBlock value: x) ifTrue: [^ x ] ].
^ exceptionBlock value
|
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]
]
Class Context
executeFrom: value
^ <28 self value>
|
method: value
method <- value
|
arguments: value
arguments <- value
|
temporaries
^ temporaries
|
temporaries: value
temporaries <- value
]
Class Dictionary
new
^ Dictionary new: 39
|
hash: aKey
^ 3 * ((aKey hash) rem: ((self basicSize) quo: 3))
|
at: aKey ifAbsent: exceptionBlock | hashPosition link |
hashPosition <- self hash: aKey.
((self basicAt: hashPosition + 1) == aKey)
ifTrue: [ ^ self basicAt: hashPosition + 2].
link <- self basicAt: hashPosition + 3.
(link notNil)
ifTrue: [ ^ link at: aKey ifAbsent: exceptionBlock ]
ifFalse: [ ^ exceptionBlock value ]
|
at: aKey put: aValue | hashPosition link |
hashPosition <- self hash: aKey.
((self basicAt: hashPosition + 1) isNil)
ifTrue: [ self basicAt: hashPosition + 1 put: aKey ].
((self basicAt: hashPosition + 1) == aKey)
ifTrue: [ self basicAt: hashPosition + 2 put: aValue ]
ifFalse: [ link <- self basicAt: hashPosition + 3.
(link notNil)
ifTrue: [ link at: aKey put: aValue ]
ifFalse: [ self basicAt: hashPosition + 3
put: (Link new; key: aKey; value: aValue)]]
|
binaryDo: aBlock
(1 to: self basicSize by: 3) do:
[:i | (self basicAt: i) notNil
ifTrue: [ aBlock value: (self basicAt: i)
value: (self basicAt: i+1) ].
(self basicAt: i+2) notNil
ifTrue: [ (self basicAt: i+2)
binaryDo: aBlock ] ]
|
includesKey: aKey | hashPosition link |
hashPosition <- self hash: aKey.
((self basicAt: hashPosition + 1) == aKey)
ifTrue: [ ^ true ].
link <- self basicAt: hashPosition + 3.
(link notNil)
ifTrue: [ ^ link includesKey: aKey ].
^ false
|
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 value ]
|
basicRemoveKey: aKey | hashPosition link |
hashPosition <- self hash: aKey.
((self basicAt: hashPosition + 1) == aKey)
ifTrue: [ self basicAt: hashPosition + 1 put: nil.
self basicAt: hashPosition + 2 put: nil]
ifFalse: [ link <- self basicAt: hashPosition + 3.
(link notNil)
ifTrue: [ self basicAt: hashPosition + 3
put: (link removeKey: aKey) ]]
]
Class Float
+ value
^ (value isMemberOf: Float)
ifTrue: [ <110 self value> ]
ifFalse: [ super + value ]
|
- value
^ (value isMemberOf: Float)
ifTrue: [ <111 self value> ]
ifFalse: [ super - value ]
|
< value
^ (value isMemberOf: Float)
ifTrue: [ <112 self value> ]
ifFalse: [ super < value ]
|
= value
^ (value isMemberOf: Float)
ifTrue: [ <116 self value> ]
ifFalse: [ super = value ]
|
* value
^ (value isMemberOf: Float)
ifTrue: [ <118 self value> ]
ifFalse: [ super * value ]
|
/ value
^ (value isMemberOf: Float)
ifTrue: [ <119 self value> ]
ifFalse: [ super / value ]
|
ceiling | i |
i <- self integerPart.
^ ((self positive) and: [ self ~= i ])
ifTrue: [ i + 1 ]
ifFalse: [ i ]
|
coerce: value
^ value asFloat
|
exp
^ <103 self>
|
floor | i |
i <- self integerPart.
^ ((self negative) and: [ self ~= i ])
ifTrue: [ i - 1 ]
ifFalse: [ i ]
|
fractionalPart
^ self - self integerPart
|
logGamma
^ <105 self>
|
generality
^ 7
|
integerPart
^ <106 self>
|
ln
^ <102 self>
|
printString
^ <101 self>
|
rounded
^ (self + 0.5 ) floor
|
sqrt
^ <104 self>
|
truncated
^ (self < 0.0 )
ifTrue: [ self ceiling ]
ifFalse: [ self floor ]
]
Class IndexedCollection
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 value ]
|
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: value
^ self indexOf: value
ifAbsent: [ smalltalk error: 'index not found']
|
indexOf: value ifAbsent: exceptionBlock
self binaryDo: [:i :x | (x == value)
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 ]
]
Class Integer
+ value
^ (value isMemberOf: Integer)
ifTrue: [ <60 self value> ]
ifFalse: [ super + value ]
|
- value
^ (value isMemberOf: Integer)
ifTrue: [ <61 self value> ]
ifFalse: [ super - value ]
|
< value
^ (value isMemberOf: Integer)
ifTrue: [ <62 self value> ]
ifFalse: [ super < value ]
|
= value
^ (value isMemberOf: Integer)
ifTrue: [ <66 self value> ]
ifFalse: [ super = value ]
|
* value
^ (value isMemberOf: Integer)
ifTrue: [ <68 self value> ]
ifFalse: [ super * value ]
|
/ value " do it as float "
^ self asFloat / value
|
// value | i |
i <- self quo: value.
( (i < 0) and: [ (self rem: value) ~= 0] )
ifTrue: [ i <- i - 1 ].
^ i
|
\\ value
^ self * self sign rem: value
|
allMask: value
^ value = (self bitAnd: value)
|
anyMask: value
^ 0 ~= (self bitAnd: value)
|
asCharacter
^ <56 self>
|
asFloat
^ <51 self>
|
bitAnd: value
^ (value isMemberOf: Integer)
ifTrue: [ <71 self value > ]
ifFalse: [ smalltalk error:
'argument to bit operation must be integer']
|
bitAt: value
^ (self bitShift: 1 - value) bitAnd: 1
|
bitInvert
^ self bitXor: -1
|
bitOr: value
^ (self bitXor: value) bitXor: (self bitAnd: value)
|
bitXor: value
^ (value isMemberOf: Integer)
ifTrue: [ <72 self value > ]
ifFalse: [ smalltalk error:
'argument to bit operation must be integer']
|
bitShift: value
^ (value isMemberOf: Integer)
ifTrue: [ <79 self value > ]
ifFalse: [ smalltalk error:
'argument to bit operation must be integer']
|
even
^ (self rem: 2) = 0
|
factorial | i |
^ (self < 8)
ifTrue: [ i <- 1.
(2 to: self) do: [:x | i <- i * x].
i ]
ifFalse: [ (self + 1) asFloat logGamma exp ]
|
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
^ 2
|
lcm: value
^ (self quo: (self gcd: value)) * value
|
odd
^ (self rem: 2) ~= 0
|
quo: value
^ (value isMemberOf: Integer)
ifTrue: [ <69 self value> ]
ifFalse: [ smalltalk error:
'argument to quo: must be integer']
|
rem: aValue
^ (value isMemberOf: Integer)
ifTrue: [ <70 self value> ]
ifFalse: [ smalltalk error:
'argument to rem: must be integer']
|
printString
^ <57 self>
|
timesRepeat: aBlock | i |
" use while, which is optimized, not to:, which is not"
i <- 0.
[ i < self ] whileTrue:
[ aBlock value. i <- i + 1]
]
Class Interval
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
]
Class Link
addLast: aValue
(nextLink notNil)
ifTrue: [ nextLink addLast: aValue]
ifFalse: [ nextLink <- Link new; value: aValue]
|
at: aKey ifAbsent: exceptionBlock
(aKey == key)
ifTrue: [ ^value ]
ifFalse: [ (nextLink notNil)
ifTrue: [ ^ nextLink at: aKey
ifAbsent: exceptionBlock ]
ifFalse: [ ^ exceptionBlock value ] ]
|
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 ]
|
do: aBlock
aBlock value: value.
(nextLink notNil)
ifTrue: [ nextLink do: aBlock ]
|
key: aKey
key <- aKey
|
includesKey: aKey
(key == aKey)
ifTrue: [ ^ true ].
(nextLink notNil)
ifTrue: [ ^ nextLink includesKey: aKey ]
ifFalse: [ ^ false ]
|
link: aLink
nextLink <- aLink
|
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]]
|
size
(nextLink notNil)
ifTrue: [ ^ 1 + nextLink size]
ifFalse: [ ^ 1 ]
|
value: aValue
value <- aValue
|
value
^ value
]
Class List
add: aValue
^ self addFirst: aValue
|
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 addLast: aValue ]
|
collect: aBlock
^ self inject: self class new
into: [:x :y | x add: (aBlock value: y). x ]
|
reject: aBlock
^ self select: [:x | (aBlock value: x) not ]
|
select: aBlock
^ self inject: self class new
into: [:x :y | (aBlock value: y)
ifTrue: [x add: y]. x]
|
do: aBlock
(links notNil)
ifTrue: [ links do: aBlock ]
|
first
(links notNil)
ifTrue: [ ^ links value ]
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 ]
]
Class Magnitude
<= value
^ (self < value) or: [ self = value ]
|
< value
^ (value > self)
|
>= value
^ (self > value) or: [ self = value ]
|
> value
^ (value < self)
|
= value
^ (self == value)
|
~= value
^ (self = value) not
|
between: low and: high
^ (low <= self) and: [ self <= high ]
|
max: value
^ (self < value)
ifTrue: [ value ]
ifFalse: [ self ]
|
min: value
^ (self < value)
ifTrue: [ self ]
ifFalse: [ value ]
]
Class Method
compileWithClass: aClass
^ <39 aClass text self>
|
name
^ message
|
message: aSymbol
message <- aSymbol
|
text
^ text
|
text: aString
text <- aString
]
Class Number
maxgen: value
^ (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
^ (self maxgen: value) = (value maxgen: self)
|
* value
^ (self maxgen: value) * (value maxgen: self)
|
/ value
^ (self maxgen: value) / (value maxgen: self)
|
abs
^ (self < 0)
ifTrue: [ 0 - self ]
ifFalse: [ self ]
|
exp
^ self asFloat exp
|
gamma
^ self asFloat gamma
|
ln
^ self asFloat ln
|
log: value
^ self ln / value ln
|
negated
^ 0 - self
|
negative
^ self < 0
|
positive
^ self >= 0
|
raisedTo: value
^ ( value * self ln ) exp
|
reciprocal
^ 1.00 / self
|
roundTo: value
^ (self / value ) rounded * value
|
sign
^ self negative ifTrue: [ -1 ]
ifFalse: [ self strictlyPositive
ifTrue: [ 1 ] ifFalse: [ 0 ] ]
|
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
]
Class Random
between: low and: high
^ (self next * (high - low)) + low
|
next
^ (<3> rem: 1000) / 1000
|
next: value | list |
list <- List new.
value timesRepeat: [ list add: self next ].
^ list
|
randInteger: value
^ 1 + (<3> rem: value)
|
set: value
<55 value>
]
Class Set
add: value
(self includes: value)
ifFalse: [ self addFirst: value ]
]
Class String
, value
^ (value isMemberOf: String)
ifTrue: [ <24 self value> ]
ifFalse: [ self , value printString ]
|
= value
(value isKindOf: String)
ifTrue: [ ^ super = value ]
ifFalse: [ ^ false ]
|
< value
(value isKindOf: String)
ifTrue: [ ^ super < value ]
ifFalse: [ ^ false ]
|
asInteger | value |
value <- 0.
self do: [:x | value <- value * 10 + x digitValue ].
^ value
|
basicAt: index
^ Char new ; value: (super basicAt: index).
|
basicAt: index put: aValue
(aValue isMemberOf: Char)
ifTrue: [ super basicAt: index put: aValue asciiValue ]
ifFalse: [ smalltalk error:
'cannot put non Char into string' ]
|
asSymbol
^ <83 self>
|
size
^ <81 self>
|
copy
^ <82 self>
]
Class Smalltalk
class: aClass doesNotRespond: aMessage
^ self error: aClass printString ,
' does not respond to ' , aMessage
|
cantFindGlobal: name
^ self error: 'cant find global symbol ' , name
|
flushMessageCache
<2>
|
saveImage: file
^ <87 file>
]
Class Symbol
asString
^ <82 self>
|
printString
^ '#' , self asString
]
Class False
ifTrue: trueBlock ifFalse: falseBlock
^ falseBlock value
|
not
^ true
]
Class True
ifTrue: trueBlock ifFalse: falseBlock
^ trueBlock value
|
not
^ false
]
Class UndefinedObject
isNil
^ true
|
notNil
^ false
|
printString
^ 'nil'
]
End
echo unbundling unixclasses 1>&2
cat >unixclasses <<'End'
*
* Little Smalltalk, version 2
* Written by Tim Budd, Oregon State University, July 1987
*
* methods for the unix front end - single process version
*
* (override previous declaration, adding new instance variable)
Declare Smalltalk Object errorRecoveryBlock
* (better override instance as well )
Instance Smalltalk smalltalk
*
Class Method
executeWith: arguments
^ ( Context new ; method: self ;
temporaries: ( Array new: temporarySize) ;
arguments: arguments )
executeFrom: 0
]
Class Class
addMethod
self doEdit: ''
|
editMethod: name | theMethod |
theMethod <- methods at: name
ifAbsent: [ 'no such method ' print. ^ nil ].
self doEdit: theMethod text
|
doEdit: startingText | theMethod |
theMethod <- Method new;
text: startingText edit.
(theMethod compileWithClass: self)
ifTrue: [ methods at: theMethod name put: theMethod .
smalltalk flushMessageCache ]
|
viewMethod: name
" edit, but don't do anything with result "
(methods at: name
ifAbsent: [ 'no such method ' print. ^ nil ]) text edit
]
Class Smalltalk
error: aString
('Error: ' , aString) print.
errorRecoveryBlock value
|
getString
^ <1>
|
init | string |
[ '> ' printNoReturn.
string <- smalltalk getString. string notNil ]
whileTrue: [ (string size > 0)
ifTrue: [ smalltalk doIt: string ] ]
|
doIt: aString | method |
errorRecoveryBlock <- [ ^ nil ].
method <- Method new.
method text: ( 'proceed ', aString ).
(method compileWithClass: Smalltalk)
ifTrue: [ method executeWith: #( 1 ) ]
|
saveImage | name |
'type image name: ' printNoReturn.
name <- self getString.
(self saveImage: name)
ifTrue: [ ('image ', name, ' created') print ]
ifFalse: [ 'image not created' print ]
]
Class String
edit
^ <89 self>
|
print
^ <88 self>
|
printNoReturn
^ <86 self>
]
End
echo unbundling multclasses 1>&2
cat >multclasses <<'End'
*
* Little Smalltalk, version 2
* Written by Tim Budd, Oregon State University, July 1987
*
* multiprocess scheduler - this is optional
*
Declare Scheduler Object processList
Declare Process Object interpreter
Declare Interpreter Object context prev creating stack stackTop byteCodePointer
Instance Scheduler scheduler
Class Block
newProcess
^ (context newInterpreter: bytecodeCounter) newProcess
|
fork
self newProcess resume
]
Class Method
executeWith: arguments
( ( Context new ; method: self ;
temporaries: ( Array new: temporarySize) ;
arguments: arguments ) newInterpreter: 0 )
newProcess resume
]
Class Scheduler
new
processList <- Set new
|
addProcess: aProcess
processList add: aProcess
|
removeProcess: aProcess
processList remove: aProcess
|
run
[ processList size ~= 0 ] whileTrue:
[ processList do: [ :x | x execute ] ]
]
Class Process
execute | i |
i <- 0.
[(i < 200) and: [ interpreter notNil ]]
whileTrue: [ interpreter <- interpreter execute.
i <- i + 1 ].
(interpreter isNil)
ifTrue: [ self terminate ]
|
interpreter: value
interpreter <- value
|
resume
scheduler addProcess: self
|
terminate
scheduler removeProcess: self
]
Class Interpreter
new
stackTop <- 0.
byteCodePointer <- 0
|
execute
^ <19 self>
|
byteCounter: start
byteCodePointer <- start
|
context: value
context <- value
|
stack: value
stack <- value.
|
newProcess
^ Process new; interpreter: self
]
Class Context
newInterpreter: start
^ Interpreter new;
context: self;
byteCounter: start;
stack: (Array new: 20)
]
End
echo unbundling unix2classes 1>&2
cat >unix2classes <<'End'
*
* Little Smalltalk, version 2
* Written by Tim Budd, Oregon State University, July 1987
*
* unix specific routines for the multiprocess front end
*
* (override previous declaration, adding new instance variable)
Declare Smalltalk Object errorRecoveryBlock
* (better override instance as well )
Instance Smalltalk smalltalk
*
Class Class
addMethod
self doEdit: ''
|
editMethod: name | theMethod |
theMethod <- methods at: name
ifAbsent: [ 'no such method ' print. ^ nil ].
self doEdit: theMethod text
|
doEdit: startingText | theMethod |
theMethod <- Method new;
text: startingText edit.
(theMethod compileWithClass: self)
ifTrue: [ methods at: theMethod name put: theMethod .
smalltalk flushMessageCache ]
]
Class Smalltalk
error: aString
('Error: ' , aString) print.
errorRecoveryBlock value
|
getString
^ <1>
|
init | string |
scheduler new.
[ '> ' printNoReturn.
string <- smalltalk getString. string notNil ]
whileTrue: [ (string size > 0)
ifTrue: [ smalltalk doIt: string ] ]
|
doIt: aString | method |
errorRecoveryBlock <- [ ^ nil ].
method <- Method new.
method text: ( 'proceed ', aString ).
(method compileWithClass: Smalltalk)
ifTrue: [ method executeWith: #( 1 ).
scheduler run ]
|
saveImage | name |
'type image name: ' printNoReturn.
name <- self getString.
self saveImage: name.
('image ', name, ' created') print
]
Class String
edit
^ <89 self>
|
print
^ <88 self>
|
printNoReturn
^ <86 self>
]
End
echo unbundling testclasses 1>&2
cat >testclasses <<'End'
*
*
* Little Smalltalk, version 2
* Written by Tim Budd, Oregon State University, July 1987
*
* a few test cases.
* invoke by messages to global variable ``test'', i.e.
* test queen
*
* all test cases can be run by sending the message all to test
* test all
*
Declare Test Object
Declare Queen Object row column neighbor
Declare One Object
Declare Two One
Declare Three Two
Declare Four Three
Instance Test test
Class Queen
setColumn: aNumber neighbor: aQueen
column <- aNumber.
neighbor <- aQueen
|
first
(neighbor notNil)
ifTrue: [ neighbor first ].
row <- 1.
^ self testPosition
|
next
(row = 8)
ifTrue: [ ((neighbor isNil) or: [neighbor next isNil])
ifTrue: [ ^ nil ].
row <- 0 ].
row <- row + 1.
^ self testPosition
|
testPosition
(neighbor isNil) ifTrue: [ ^ self ].
(neighbor checkRow: row column: column)
ifTrue: [ ^ self next ]
ifFalse: [ ^ self ]
|
checkRow: testRow column: testColumn | columnDifference |
columnDifference <- testColumn - column.
(((row = testRow) or:
[ row + columnDifference = testRow]) or:
[ row - columnDifference = testRow])
ifTrue: [ ^ true ].
(neighbor notNil)
ifTrue: [ ^ neighbor checkRow: testRow
column: testColumn ]
ifFalse: [ ^ false ]
|
printBoard
(neighbor notNil)
ifTrue: [ neighbor printBoard ].
('column ', column , ' row ', row ) print.
]
Class One
test
^ 1
|
result1
^ self test
]
Class Two
test
^ 2
]
Class Three
result2
^ self result1
|
result3
^ super test
]
Class Four
test
^ 4
]
Class Test
all
self fork.
self queen.
self super.
|
fork
(Block respondsTo: #fork)
ifTrue: [ [ (1 to: 10) do: [:x | x print] ] fork.
[ (30 to: 40) do: [:y | y print] ] fork ]
|
queen | lastQueen |
lastQueen <- nil.
(1 to: 8) do: [:i | lastQueen <- Queen new;
setColumn: i neighbor: lastQueen ].
lastQueen first.
lastQueen printBoard
|
super | x1 x2 x3 x4 |
x1 <- One new.
x2 <- Two new.
x3 <- Three new.
x4 <- Four new.
x1 test print.
x1 result1 print.
x2 test print.
x2 result1 print.
x3 test print.
x4 result1 print.
x3 result2 print.
x4 result2 print.
x3 result3 print.
x4 result3 print
]
End
echo unbundling stest.out 1>&2
cat >stest.out <<'End'
initially 1778 objects
> column 1 row 1
column 2 row 5
column 3 row 8
column 4 row 6
column 5 row 3
column 6 row 7
column 7 row 2
column 8 row 4
1
1
2
2
2
4
2
4
2
2
> finally 1789 objects
End