v13i053: New release of little smalltalk, Part01/05
Rich Salz
rsalz at bbn.com
Sat Feb 20 08:31:10 AEST 1988
Submitted-by: Tim Budd <budd at MIST.CS.ORST.EDU>
Posting-number: Volume 13, Issue 53
Archive-name: little-st2/part01
This is a dialect of Smalltalk, described in the Addison-Wesley book
"A Little Smalltalk" written by Tim. It is not quite like ST-80 nor
Smalltalk-V, especially in that lots of features are missing.
#!/bin/sh
#
#
# This is version 2.02 of Little Smalltalk, distributed in five parts.
#
# This version is dated 12/25/87
#
# Several bugs and many features and improvements have been made since the
# first posting to comp.src.unix. See the file ``todo'' for a partial list.
#
# Comments, bug reports, and the like should be submitted to:
# Tim Budd
# Smalltalk Distribution
# Department of Computer Science
# Oregon State University
# Corvallis, Oregon
# 97330
#
# budd at cs.orst.edu
# {hp-pcd, tektronix}!orstcs!budd
#
#
echo 'Start of small.v2, part 01 of 05:'
echo 'x - basic.st'
sed 's/^X//' > basic.st << '/'
X*
X* Little Smalltalk, version 2
X* Written by Tim Budd, Oregon State University, July 1987
X*
X* basic classes common to all images
X*
XDeclare Object
XDeclare Block Object context argumentCounter argumentLocation bytecodeCounter creatingInterpreter
XDeclare Boolean Object
XDeclare True Boolean
XDeclare False Boolean
XDeclare Class Object name instanceSize methods superClass variables icon
XDeclare Context Object method methodClass arguments temporaries
XDeclare Link Object key value nextLink
XDeclare Magnitude Object
XDeclare Char Magnitude value
XDeclare Collection Magnitude
XDeclare IndexedCollection Collection
XDeclare Array IndexedCollection
XDeclare ByteArray Array
XDeclare String ByteArray
XDeclare Dictionary IndexedCollection hashTable
XDeclare Interval Collection lower upper step
XDeclare List Collection links
XDeclare Set List
XDeclare Number Magnitude
XDeclare Integer Number
XDeclare Float Number
XDeclare Method Object text message bytecodes literals stackSize temporarySize
XDeclare Random Object
XDeclare Switch Object const notdone
XDeclare Smalltalk Object
XDeclare Symbol Object
XDeclare UndefinedObject Object
X*
XInstance Smalltalk smalltalk
XInstance True true
XInstance False false
X*
XClass Object
X == aValue
X ^ <21 self aValue>
X|
X = aValue
X ^ self == aValue
X|
X basicAt: index
X ^ <25 self index>
X|
X basicAt: index put: value
X ^ <31 self index value>
X|
X basicSize
X ^ <12 self>
X|
X class
X ^ <11 self>
X|
X display
X ('(Class ', self class, ') ' , self printString ) print
X|
X hash
X ^ <13 self>
X|
X isMemberOf: aClass
X ^ self class == aClass
X|
X isNil
X ^ false
X|
X isKindOf: aClass
X self class upSuperclassChain:
X [:x | (x == aClass) ifTrue: [ ^ true ] ].
X ^ false
X|
X new
X " default initialization protocol"
X ^ self
X|
X notNil
X ^ true
X|
X print
X ^ self printString print
X|
X printString
X ^ self class printString
X]
XClass Array
X < coll
X (coll isKindOf: Array)
X ifTrue: [ self with: coll
X do: [:x :y | (x < y) ifTrue: [ ^ true ]].
X ^ self size < coll size ]
X ifFalse: [ ^ super < coll ]
X|
X = coll
X (coll isKindOf: Array)
X ifTrue: [ (self size = coll size)
X ifFalse: [ ^ false ].
X self with: coll
X do: [:x :y | (x = y)
X ifFalse: [ ^ false ] ].
X ^ true ]
X ifFalse: [ ^ super = coll ]
X|
X at: index put: value
X (self includesKey: index)
X ifTrue: [ self basicAt: index put: value ]
X ifFalse: [ smalltalk error:
X 'illegal index to at:put: for array' ]
X|
X binaryDo: aBlock
X (1 to: self size) do:
X [:i | aBlock value: i value: (self at: i) ]
X|
X copyFrom: low to: high | newArray newlow newhigh |
X newlow <- low max: 1.
X newhigh <- high min: self size.
X newArray <- self class new: (0 max: newhigh - newlow + 1).
X (newlow to: newhigh)
X do: [:i | newArray at: ((i - newlow) + 1)
X put: (self at: i) ].
X ^ newArray
X|
X do: aBlock
X (1 to: self size) do:
X [:i | aBlock value: (self at: i) ]
X|
X exchange: a and: b | temp |
X temp <- self at: a.
X self at: a put: (self at: b).
X self at: b put: temp
X|
X includesKey: index
X ^ index between: 1 and: self size
X|
X size
X ^ self basicSize
X|
X with: coll do: aBlock
X (1 to: (self size min: coll size))
X do: [:i | aBlock value: (self at: i)
X value: (coll at: i) ]
X]
XClass Block
X checkArgumentCount: count
X ^ (argumentCounter = count)
X ifTrue: [ true ]
X ifFalse: [ smalltalk error:
X 'wrong number of arguments passed to block'.
X false ]
X|
X value
X ^ (self checkArgumentCount: 0)
X ifTrue: [ context executeFrom: bytecodeCounter
X creator: creatingInterpreter ]
X|
X value: x
X ^ (self checkArgumentCount: 1)
X ifTrue: [ context temporaries at: argumentLocation
X put: x.
X context executeFrom: bytecodeCounter
X creator: creatingInterpreter ]
X|
X value: x value: y | temps |
X ^ (self checkArgumentCount: 2)
X ifTrue: [ temps <- context temporaries.
X temps at: argumentLocation put: x.
X temps at: argumentLocation + 1 put: y.
X context executeFrom: bytecodeCounter
X creator: creatingInterpreter ]
X|
X value: x value: y value: z | temps |
X ^ (self checkArgumentCount: 3)
X ifTrue: [ temps <- context temporaries.
X temps at: argumentLocation put: x.
X temps at: argumentLocation + 1 put: y.
X temps at: argumentLocation + 2 put: z.
X context executeFrom: bytecodeCounter
X creator: creatingInterpreter ]
X|
X whileTrue: aBlock
X ( self value ) ifTrue:
X [ aBlock value.
X self whileTrue: aBlock ]
X|
X whileTrue
X self whileTrue: []
X]
XClass Boolean
X ifTrue: trueBlock
X ^ self ifTrue: trueBlock ifFalse: []
X|
X ifFalse: falseBlock
X ^ self ifTrue: [] ifFalse: falseBlock
X|
X ifFalse: falseBlock ifTrue: trueBlock
X ^ self ifTrue: trueBlock
X ifFalse: falseBlock
X|
X and: aBlock
X ^ self ifTrue: aBlock ifFalse: [ false ]
X|
X or: aBlock
X ^ self ifTrue: [ true ] ifFalse: aBlock
X]
XClass ByteArray
X asString
X <22 self String>
X|
X basicAt: index put: value
X ^ <32 self index value >
X|
X basicAt: index
X ^ <26 self index>
X|
X size: value
X ^ <22 <59 value> ByteArray>
X|
X size
X ^ self basicSize * 2
X]
XClass Char
X < aValue
X ^ (aValue isMemberOf: Char)
X ifTrue: [ value < aValue asInteger ]
X ifFalse: [ smalltalk error: 'char compared to nonchar']
X|
X == aValue
X ^ (aValue isMemberOf: Char)
X ifTrue: [ value = aValue asInteger ]
X ifFalse: [ false ]
X|
X = aValue
X ^ self == aValue
X|
X asInteger
X ^ value
X|
X asString
X ^ ' ' copy; at: 1 put: self
X|
X digitValue
X self isDigit ifTrue: [ ^ value - $0 asInteger ].
X self isUppercase ifTrue: [ ^ value - $A asInteger + 10 ].
X ^ smalltalk error: 'illegal conversion, char to digit'
X|
X isAlphabetic
X ^ (self isLowercase) or: [ self isUppercase ]
X|
X isAlphaNumeric
X ^ (self isAlphabetic) or: [ self isDigit ]
X|
X isBlank
X ^ value = $ " blank char "
X|
X isDigit
X ^ value between: $0 asInteger and: $9 asInteger
X|
X isLowercase
X ^ value between: $a asInteger and: $z asInteger
X|
X isUppercase
X ^ value between: $A asInteger and: $Z asInteger
X|
X value: aValue " private - used for initialization "
X value <- aValue
X|
X printString
X ^ '$', self asString
X]
XClass Class
X new | newObject |
X newObject <- self new: instanceSize.
X ^ (self == Class)
X ifTrue: [ newObject initialize ]
X ifFalse: [ newObject new ]
X|
X new: size " hack out block the right size and class "
X ^ < 22 < 58 size > self >
X|
X initialize
X superClass <- Object.
X instanceSize <- 0.
X methods <- Dictionary new
X|
X name
X ^ name
X|
X name: aString
X name <- aString
X|
X methods
X ^ methods
X|
X instanceSize
X ^ instanceSize
X|
X printString
X ^ name asString
X|
X respondsTo | theSet |
X theSet <- Set new.
X self upSuperclassChain:
X [:x | theSet addAll: x methods keys ].
X ^ theSet
X|
X respondsTo: message
X ^ methods includesKey: message
X|
X subClasses
X ^ globalNames inject: List new
X into: [:x :y | ((y class = Class) and:
X [ y superClass = self])
X ifTrue: [ x add: y]. x ]
X|
X superClass
X ^ superClass
X|
X superClass: aClass
X superClass <- aClass
X|
X upSuperclassChain: aBlock
X aBlock value: self.
X (superClass notNil)
X ifTrue: [ superClass upSuperclassChain: aBlock ]
X|
X variables
X ^ variables
X|
X variables: nameArray
X variables <- nameArray.
X instanceSize <- superClass instanceSize + nameArray size
X]
XClass Collection
X < coll
X self do: [:x | (coll includes: x) ifFalse: [ ^ false ]].
X ^ true
X|
X = coll
X self do: [:x | (self occurrencesOf: x) =
X (coll occurrencesOf: x) ifFalse: [ ^ false ] ].
X ^ true
X|
X asArray | newArray i |
X newArray <- Array new: self size.
X i <- 0.
X self do: [:x | i <- i + 1. newArray at: i put: x].
X ^ newArray
X|
X asByteArray | newArray i |
X newArray <- ByteArray new size: self size.
X i <- 0.
X self do: [:x | i <- i + 1. newArray at: i put: x].
X ^ newArray
X|
X asSet
X ^ Set new addAll: self
X|
X asString
X ^ self asByteArray asString
X|
X display
X self do: [:x | x print ]
X|
X includes: value
X self do: [:x | (x = value) ifTrue: [ ^ true ] ].
X ^ false
X|
X inject: thisValue into: binaryBlock | last |
X last <- thisValue.
X self do: [:x | last <- binaryBlock value: last value: x].
X ^ last
X|
X isEmpty
X ^ self size == 0
X|
X occurrencesOf: anObject
X ^ self inject: 0
X into: [:x :y | (y = anObject)
X ifTrue: [x + 1]
X ifFalse: [x] ]
X|
X printString
X ^ ( self inject: self class printString , ' ('
X into: [:x :y | x , ' ' , y printString]), ' )'
X|
X size
X ^ self inject: 0 into: [:x :y | x + 1]
X|
X sort: aBlock
X ^ self inject: List new
X into: [:x :y | x add: y ordered: aBlock. x]
X|
X sort
X ^ self sort: [:x :y | x < y ]
X]
XClass Context
X executeFrom: value creator: interp
X ^ <38 self value interp>
X|
X method: value
X method <- value
X|
X arguments: value
X arguments <- value
X|
X temporaries
X ^ temporaries
X|
X temporaries: value
X temporaries <- value
X]
XClass Dictionary
X new
X hashTable <- Array new: 39
X|
X hash: aKey
X ^ 3 * ((aKey hash) rem: ((hashTable size) quo: 3))
X|
X at: aKey ifAbsent: exceptionBlock | hashPosition link |
X
X hashPosition <- self hash: aKey.
X ((hashTable at: hashPosition + 1) == aKey)
X ifTrue: [ ^ hashTable at: hashPosition + 2].
X link <- hashTable at: hashPosition + 3.
X ^ (link notNil)
X ifTrue: [ link at: aKey ifAbsent: exceptionBlock ]
X ifFalse: exceptionBlock
X|
X at: aKey put: aValue | hashPosition link |
X
X hashPosition <- self hash: aKey.
X ((hashTable at: hashPosition + 1) isNil)
X ifTrue: [ hashTable at: hashPosition + 1 put: aKey ].
X ((hashTable at: hashPosition + 1) == aKey)
X ifTrue: [ hashTable at: hashPosition + 2 put: aValue ]
X ifFalse: [ link <- hashTable at: hashPosition + 3.
X (link notNil)
X ifTrue: [ link at: aKey put: aValue ]
X ifFalse: [ hashTable at: hashPosition + 3
X put: (Link new; key: aKey; value: aValue)]]
X|
X binaryDo: aBlock
X (1 to: hashTable size by: 3) do:
X [:i | (hashTable at: i) notNil
X ifTrue: [ aBlock value: (hashTable at: i)
X value: (hashTable at: i+1) ].
X (hashTable at: i+2) notNil
X ifTrue: [ (hashTable at: i+2)
X binaryDo: aBlock ] ]
X|
X display
X self binaryDo: [:x :y | (x printString , ' -> ',
X y printString ) print ]
X|
X includesKey: aKey
X " look up, but throw away result "
X self at: aKey ifAbsent: [ ^ false ].
X ^ true
X|
X removeKey: aKey
X ^ self removeKey: aKey
X ifAbsent: [ smalltalk error: 'remove key not found']
X|
X removeKey: aKey ifAbsent: exceptionBlock
X ^ (self includesKey: aKey)
X ifTrue: [ self basicRemoveKey: aKey ]
X ifFalse: exceptionBlock
X|
X basicRemoveKey: aKey | hashPosition link |
X hashPosition <- self hash: aKey.
X ((hashTable at: hashPosition + 1) == aKey)
X ifTrue: [ hashTable at: hashPosition + 1 put: nil.
X hashTable at: hashPosition + 2 put: nil]
X ifFalse: [ link <- hashTable at: hashPosition + 3.
X (link notNil)
X ifTrue: [ hashTable at: hashPosition + 3
X put: (link removeKey: aKey) ]]
X]
XClass False
X ifTrue: trueBlock ifFalse: falseBlock
X ^ falseBlock value
X|
X not
X ^ true
X]
XClass Float
X + value
X ^ (value isMemberOf: Float)
X ifTrue: [ <110 self value> ]
X ifFalse: [ super + value ]
X|
X - value
X ^ (value isMemberOf: Float)
X ifTrue: [ <111 self value> ]
X ifFalse: [ super - value ]
X|
X < value
X ^ (value isMemberOf: Float)
X ifTrue: [ <112 self value> ]
X ifFalse: [ super < value ]
X|
X = value
X ^ (value isMemberOf: Float)
X ifTrue: [ <116 self value> ]
X ifFalse: [ super = value ]
X|
X * value
X ^ (value isMemberOf: Float)
X ifTrue: [ <118 self value> ]
X ifFalse: [ super * value ]
X|
X / value
X ^ (value isMemberOf: Float)
X ifTrue: [ (value = 0.0)
X ifTrue: [ smalltalk error:
X 'float division by zero' ]
X ifFalse: [ <119 self value> ]]
X ifFalse: [ super / value ]
X|
X ceiling | i |
X i <- self integerPart.
X ^ ((self positive) and: [ self ~= i ])
X ifTrue: [ i + 1 ]
X ifFalse: [ i ]
X|
X coerce: value
X ^ value asFloat
X|
X exp
X ^ <103 self>
X|
X floor | i |
X i <- self integerPart.
X ^ ((self negative) and: [ self ~= i ])
X ifTrue: [ i - 1 ]
X ifFalse: [ i ]
X|
X fractionalPart
X ^ self - self integerPart
X|
X generality
X ^ 7
X|
X integerPart
X ^ <106 self>
X|
X ln
X ^ <102 self>
X|
X printString
X ^ <101 self>
X|
X rounded
X ^ (self + 0.5 ) floor
X|
X sqrt
X ^ (self negative)
X ifTrue: [ smalltalk error: 'sqrt of negative']
X ifFalse: [ <104 self> ]
X|
X truncated
X ^ (self negative)
X ifTrue: [ self ceiling ]
X ifFalse: [ self floor ]
X]
XClass IndexedCollection
X addAll: aCollection
X aCollection binaryDo: [:i :x | self at: i put: x ]
X|
X asArray
X ^ Array new: self size ; addAll: self
X|
X asDictionary
X ^ Dictionary new ; addAll: self
X|
X at: aKey
X ^ self at: aKey
X ifAbsent: [ smalltalk error: 'index to at: illegal' ]
X|
X at: index ifAbsent: exceptionBlock
X ^ (self includesKey: index)
X ifTrue: [ self basicAt: index ]
X ifFalse: exceptionBlock
X|
X binaryInject: thisValue into: aBlock | last |
X last <- thisValue.
X self binaryDo: [:i :x | last <- aBlock value: last
X value: i value: x].
X ^ last
X|
X collect: aBlock
X ^ self binaryInject: Dictionary new
X into: [:s :i :x | s at: i put: (aBlock value: x). s]
X|
X do: aBlock
X self binaryDo: [:i :x | aBlock value: x ]
X|
X keys
X ^ self binaryInject: Set new
X into: [:s :i :x | s add: i ]
X|
X indexOf: aBlock
X ^ self indexOf: aBlock
X ifAbsent: [ smalltalk error: 'index not found']
X|
X indexOf: aBlock ifAbsent: exceptionBlock
X self binaryDo: [:i :x | (aBlock value: x)
X ifTrue: [ ^ i ] ].
X ^ exceptionBlock value
X|
X select: aBlock
X ^ self binaryInject: Dictionary new
X into: [:s :i :x | (aBlock value: x)
X ifTrue: [ s at: i put: x ]. s ]
X|
X values
X ^ self binaryInject: List new
X into: [:s :i :x | s add: x ]
X]
XClass Integer
X + value | r |
X ^ (value isMemberOf: Integer)
X ifTrue: [ r <- <60 self value>.
X r notNil ifTrue: [ r ]
X ifFalse: [ self asFloat + value asFloat ]]
X ifFalse: [ super + value ]
X|
X - value | r |
X ^ (value isMemberOf: Integer)
X ifTrue: [ r <- <61 self value>.
X r notNil ifTrue: [ r ]
X ifFalse: [ self asFloat - value asFloat ]]
X ifFalse: [ super - value ]
X|
X < value
X ^ (value isMemberOf: Integer)
X ifTrue: [ <62 self value> ]
X ifFalse: [ super < value ]
X|
X = value
X ^ (value isMemberOf: Integer)
X ifTrue: [ <66 self value> ]
X ifFalse: [ super = value ]
X|
X * value | r |
X ^ (value isMemberOf: Integer)
X ifTrue: [ r <- <68 self value>.
X r notNil ifTrue: [ r ]
X ifFalse: [ self asFloat * value asFloat ]]
X ifFalse: [ super * value ]
X|
X / value " do it as float "
X ^ self asFloat / value
X|
X // value | i |
X i <- self quo: value.
X ( (i < 0) and: [ (self rem: value) ~= 0] )
X ifTrue: [ i <- i - 1 ].
X ^ i
X|
X \\ value
X ^ self * self sign rem: value
X|
X allMask: value
X ^ value = (self bitAnd: value)
X|
X anyMask: value
X ^ 0 ~= (self bitAnd: value)
X|
X asCharacter
X ^ Char new; value: self
X|
X asDigit
X (self >= 0)
X ifTrue: [ (self <= 9) ifTrue:
X [ ^ (self + $0 asInteger) asCharacter ].
X (self <= 36) ifTrue:
X [ ^ (self + $A asInteger - 10) asCharacter ] ].
X ^ smalltalk error: 'illegal conversion, integer to digit'
X|
X asFloat
X ^ <51 self>
X|
X asString
X ^ self radix: 10
X|
X bitAnd: value
X ^ (value isMemberOf: Integer)
X ifTrue: [ <71 self value > ]
X ifFalse: [ smalltalk error:
X 'argument to bit operation must be integer']
X|
X bitAt: value
X ^ (self bitShift: 1 - value) bitAnd: 1
X|
X bitInvert
X ^ self bitXor: -1
X|
X bitOr: value
X ^ (self bitXor: value) bitXor: (self bitAnd: value)
X|
X bitXor: value
X ^ (value isMemberOf: Integer)
X ifTrue: [ <72 self value > ]
X ifFalse: [ smalltalk error:
X 'argument to bit operation must be integer']
X|
X bitShift: value
X ^ (value isMemberOf: Integer)
X ifTrue: [ <79 self value > ]
X ifFalse: [ smalltalk error:
X 'argument to bit operation must be integer']
X|
X even
X ^ (self rem: 2) = 0
X|
X factorial
X ^ (2 to: self) inject: 1 into: [:x :y | x * y ]
X|
X gcd: value
X (value = 0) ifTrue: [ ^ self ].
X (self negative) ifTrue: [ ^ self negated gcd: value ].
X (value negative) ifTrue: [ ^ self gcd: value negated ].
X (value > self) ifTrue: [ ^ value gcd: self ].
X ^ value gcd: (self rem: value)
X|
X generality
X ^ 2
X|
X lcm: value
X ^ (self quo: (self gcd: value)) * value
X|
X odd
X ^ (self rem: 2) ~= 0
X|
X quo: value | r |
X ^ (value isMemberOf: Integer)
X ifTrue: [ r <- <69 self value>.
X (r isNil)
X ifTrue: [ smalltalk error:
X 'quo: or rem: with argument 0']
X ifFalse: [ r ]]
X ifFalse: [ smalltalk error:
X 'argument to quo: or rem: must be integer']
X|
X radix: base | text |
X text <- (self \\ base) asDigit asString.
X ^ (self abs < base)
X ifTrue: [ (self negative)
X ifTrue: [ '-' , text ]
X ifFalse: [ text ]]
X ifFalse: [ ((self quo: base) radix: base), text ]
X|
X rem: value
X ^ self - ((self quo: value) * value)
X|
X printString
X ^ self asString
X|
X timesRepeat: aBlock | i |
X " use while, which is optimized, not to:, which is not"
X i <- 0.
X [ i < self ] whileTrue:
X [ aBlock value. i <- i + 1]
X]
XClass Interval
X do: aBlock | current |
X current <- lower.
X (step > 0)
X ifTrue: [ [ current <= upper ] whileTrue:
X [ aBlock value: current.
X current <- current + step ] ]
X ifFalse: [ [ current >= upper ] whileTrue:
X [ aBlock value: current.
X current <- current + step ] ]
X|
X lower: aValue
X lower <- aValue
X|
X upper: aValue
X upper <- aValue
X|
X step: aValue
X step <- aValue
X]
XClass Link
X add: newValue whenFalse: aBlock
X (aBlock value: value value: newValue)
X ifTrue: [ (nextLink notNil)
X ifTrue: [ nextLink <- nextLink add: newValue
X whenFalse: aBlock ]
X ifFalse: [ nextLink <- Link new; value: newValue] ]
X ifFalse: [ ^ Link new; value: newValue; link: self ]
X|
X at: aKey ifAbsent: exceptionBlock
X (aKey == key)
X ifTrue: [ ^value ]
X ifFalse: [ ^ (nextLink notNil)
X ifTrue: [ nextLink at: aKey
X ifAbsent: exceptionBlock ]
X ifFalse: exceptionBlock ]
X|
X at: aKey put: aValue
X (aKey == key)
X ifTrue: [ value <- aValue ]
X ifFalse: [ (nextLink notNil)
X ifTrue: [ nextLink at: aKey put: aValue]
X ifFalse: [ nextLink <- Link new;
X key: aKey; value: aValue] ]
X|
X binaryDo: aBlock
X aBlock value: key value: value.
X (nextLink notNil)
X ifTrue: [ nextLink binaryDo: aBlock ]
X|
X key: aKey
X key <- aKey
X|
X includesKey: aKey
X (key == aKey)
X ifTrue: [ ^ true ].
X (nextLink notNil)
X ifTrue: [ ^ nextLink includesKey: aKey ]
X ifFalse: [ ^ false ]
X|
X link: aLink
X nextLink <- aLink
X|
X removeKey: aKey
X (aKey == key)
X ifTrue: [ ^ nextLink ]
X ifFalse: [ (nextLink notNil)
X ifTrue: [ nextLink <- nextLink removeKey: aKey]]
X|
X removeValue: aValue
X (aValue == value)
X ifTrue: [ ^ nextLink ]
X ifFalse: [ (nextLink notNil)
X ifTrue: [ nextLink <- nextLink removeValue: aValue]]
X|
X size
X (nextLink notNil)
X ifTrue: [ ^ 1 + nextLink size]
X ifFalse: [ ^ 1 ]
X|
X value: aValue
X value <- aValue
X|
X value
X ^ value
X]
XClass List
X add: aValue
X ^ self addFirst: aValue
X|
X add: aValue ordered: aBlock
X (links isNil)
X ifTrue: [ self addFirst: aValue]
X ifFalse: [ links <- links add: aValue
X whenFalse: aBlock ]
X|
X addAll: aValue
X aValue do: [:x | self add: x ]
X|
X addFirst: aValue
X links <- Link new; value: aValue; link: links
X|
X addLast: aValue
X (links isNil)
X ifTrue: [ self addFirst: aValue ]
X ifFalse: [ links add: aValue whenFalse: [ :x :y | true ] ]
X|
X collect: aBlock
X ^ self inject: self class new
X into: [:x :y | x add: (aBlock value: y). x ]
X|
X reject: aBlock
X ^ self select: [:x | (aBlock value: x) not ]
X|
X select: aBlock
X ^ self inject: self class new
X into: [:x :y | (aBlock value: y)
X ifTrue: [x add: y]. x]
X|
X do: aBlock
X (links notNil)
X ifTrue: [ links binaryDo: [:x :y | aBlock value: y]]
X|
X first
X ^ (links notNil)
X ifTrue: links
X ifFalse: [ smalltalk error: 'first on empty list']
X|
X removeFirst
X self remove: self first
X|
X remove: value
X (links notNil)
X ifTrue: [ links <- links removeValue: value ]
X|
X size
X (links isNil)
X ifTrue: [ ^ 0 ]
X ifFalse: [ ^ links size ]
X]
XClass Magnitude
X <= value
X ^ (self < value) or: [ self = value ]
X|
X < value
X ^ (value > self)
X|
X >= value
X ^ (self > value) or: [ self = value ]
X|
X > value
X ^ (value < self)
X|
X = value
X ^ (self == value)
X|
X ~= value
X ^ (self = value) not
X|
X between: low and: high
X ^ (low <= self) and: [ self <= high ]
X|
X max: value
X ^ (self < value)
X ifTrue: [ value ]
X ifFalse: [ self ]
X|
X min: value
X ^ (self < value)
X ifTrue: [ self ]
X ifFalse: [ value ]
X]
XClass Method
X compileWithClass: aClass
X ^ <39 aClass text self>
X|
X name
X ^ message
X|
X message: aSymbol
X message <- aSymbol
X|
X printString
X ^ message asString
X|
X text
X ^ text
X|
X text: aString
X text <- aString
X|
X display
X ('Method ', message) print.
X 'text' print.
X text print.
X 'literals' print.
X literals print.
X 'bytecodes' print.
X bytecodes do: [:x |
X (x printString, ' ', (x quo: 16), ' ', (x rem: 16))
X print ]
X]
XClass Number
X maxgen: value
X ^ (self generality > value generality)
X ifTrue: [ self ]
X ifFalse: [ value coerce: self ]
X|
X + value
X ^ (self maxgen: value) + (value maxgen: self)
X|
X - value
X ^ (self maxgen: value) - (value maxgen: self)
X|
X < value
X ^ (self maxgen: value) < (value maxgen: self)
X|
X = value
X ^ (self maxgen: value) = (value maxgen: self)
X|
X * value
X ^ (self maxgen: value) * (value maxgen: self)
X|
X / value
X ^ (self maxgen: value) / (value maxgen: self)
X|
X abs
X ^ (self < 0)
X ifTrue: [ 0 - self ]
X ifFalse: [ self ]
X|
X exp
X ^ self asFloat exp
X|
X ln
X ^ self asFloat ln
X|
X log: value
X ^ self ln / value ln
X|
X negated
X ^ 0 - self
X|
X negative
X ^ self < 0
X|
X positive
X ^ self >= 0
X|
X raisedTo: value
X ^ ( value * self ln ) exp
X|
X reciprocal
X ^ 1.00 / self
X|
X roundTo: value
X ^ (self / value ) rounded * value
X|
X sign
X ^ self negative ifTrue: [ -1 ]
X ifFalse: [ self strictlyPositive
X ifTrue: [ 1 ] ifFalse: [ 0 ] ]
X|
X sqrt
X ^ self asFloat sqrt
X|
X squared
X ^ self * self
X|
X strictlyPositive
X ^ self > 0
X|
X to: value
X ^ Interval new; lower: self; upper: value; step: 1
X|
X to: value by: step
X ^ Interval new; lower: self; upper: value; step: step
X|
X trucateTo: value
X ^ (self / value) trucated * value
X]
XClass Random
X between: low and: high
X ^ (self next * (high - low)) + low
X|
X next
X ^ (<3> rem: 1000) / 1000
X|
X next: value | list |
X list <- List new.
X value timesRepeat: [ list add: self next ].
X ^ list
X|
X randInteger: value
X ^ 1 + (<3> rem: value)
X|
X set: value
X <55 value>
X]
XClass Set
X add: value
X (self includes: value)
X ifFalse: [ self addFirst: value ]
X]
XClass String
X , value
X ^ (value isMemberOf: String)
X ifTrue: [ (self size + value size) > 512
X ifTrue: [ 'string too large' print. self ]
X ifFalse: [ <24 self value> ] ]
X ifFalse: [ self , value printString ]
X|
X = value
X (value isKindOf: String)
X ifTrue: [ ^ super = value ]
X ifFalse: [ ^ false ]
X|
X < value
X (value isKindOf: String)
X ifTrue: [ ^ super < value ]
X ifFalse: [ ^ false ]
X|
X asInteger
X ^ self inject: 0 into: [:x :y | x * 10 + y digitValue ]
X|
X basicAt: index
X ^ (super basicAt: index) asCharacter
X|
X basicAt: index put: aValue
X (aValue isMemberOf: Char)
X ifTrue: [ super basicAt: index put: aValue asInteger ]
X ifFalse: [ smalltalk error:
X 'cannot put non Char into string' ]
X|
X asSymbol
X ^ <83 self>
X|
X copy
X " catenation makes copy automatically "
X ^ '',self
X|
X copyFrom: position1 to: position2
X ^ <33 self position1 position2>
X|
X printString
X ^ '''' , self, ''''
X|
X size
X ^ <81 self>
X|
X words: aBlock | text index list |
X list <- List new.
X text <- self.
X [ text <- text copyFrom:
X (text indexOf: aBlock ifAbsent: [ text size + 1])
X to: text size.
X text size > 0 ] whileTrue:
X [ index <- text
X indexOf: [:x | (aBlock value: x) not ]
X ifAbsent: [ text size + 1].
X list addLast: (text copyFrom: 1 to: index - 1).
X text <- text copyFrom: index to: text size ].
X ^ list asArray
X]
XClass Smalltalk
X class: aClass doesNotRespond: aMessage
X ^ self error: aClass printString ,
X ' does not respond to ' , aMessage
X|
X cantFindGlobal: name
X ^ self error: 'cannot find global symbol ' , name
X|
X flushMessageCache
X <2>
X]
XClass Switch
X key: value
X const <- value.
X notdone <- true.
X|
X ifMatch: key do: block
X (notdone and: [ const = key ])
X ifTrue: [ notdone <- false. block value ]
X|
X else: block
X notdone ifTrue: [ notdone <- false. block value ]
X]
XClass Symbol
X asString
X " catenation makes copy automatically "
X ^ <24 self ''>
X|
X printString
X ^ '#' , self asString
X|
X respondsTo
X ^ globalNames inject: Set new
X into: [:x :y | ((y class = Class) and:
X [ y respondsTo: self])
X ifTrue: [ x add: y]. x]
X]
XClass True
X ifTrue: trueBlock ifFalse: falseBlock
X ^ trueBlock value
X|
X not
X ^ false
X]
XClass UndefinedObject
X isNil
X ^ true
X|
X notNil
X ^ false
X|
X printString
X ^ 'nil'
X]
/
echo 'x - memory.h'
sed 's/^X//' > memory.h << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X*/
X
X# define streq(a,b) (strcmp(a,b) == 0)
X
X/*
X The first major decision to be made in the memory manager is what
Xan entity of type object really is. Two obvious choices are a pointer (to
Xthe actual object memory) or an index into an object table. We decided to
Xuse the latter, although either would work.
X Similarly, one can either define the token object using a typedef,
Xor using a define statement. Either one will work (check this?)
X*/
X
Xtypedef short object;
X
X/*
X The memory module itself is defined by over a dozen routines.
XAll of these could be defined by procedures, and indeed this was originally
Xdone. However, for efficiency reasons, many of these procedures can be
Xreplaced by macros generating in-line code. For the latter approach
Xto work, the structure of the object table must be known. For this reason,
Xit is given here. Note, however, that ONLY the macros described in this
Xfile make use of this structure: therefore modifications or even complete
Xreplacement is possible as long as the interface remains consistent
X
X*/
X
Xstruct objectStruct {
X object class;
X short referenceCount;
X byte size;
X byte type;
X object *memory;
X };
X
Xextern struct objectStruct objectTable[];
X
X/* types of object memory */
X# define objectMemory 0
X# define byteMemory 1
X# define charMemory 2
X# define floatMemory 3
X
X# define isString(x) ((objectTable[x>>1].type == charMemory) || (objectTable[x>>1].type == byteMemory))
X# define isFloat(x) (objectTable[x>>1].type == floatMemory)
X
X/*
X The most basic routines to the memory manager are incr and decr,
Xwhich increment and decrement reference counts in objects. By separating
Xdecrement from memory freeing, we could replace these as procedure calls
Xby using the following macros:
Xextern object incrobj;
X# define incr(x) if ((incrobj=(x))&&!isInteger(incrobj)) \
XobjectTable[incrobj>>1].referenceCount++
X# define decr(x) if (((incrobj=x)&&!isInteger(incrobj))&&\
X(--objectTable[incrobj>>1].referenceCount<=0)) sysDecr(incrobj);*/
X/*
Xnotice that the argument x is first assigned to a global variable; this is
Xin case evaluation of x results in side effects (such as assignment) which
Xshould not be repeated. */
X
Xextern noreturn sysDecr(OBJ);
X
X# ifndef incr
Xextern void incr(OBJ);
X# endif
X# ifndef decr
Xextern void decr(OBJ);
X# endif
X
X/*
X The next most basic routines in the memory module are those that
Xallocate blocks of storage. There are three routines:
X allocObject(size) - allocate an array of objects
X allocByte(size) - allocate an array of bytes
X allocChar(size) - allocate an array of character values
X allocSymbol(value) - allocate a string value
X allocInt(value) - allocate an integer value
X allocFloat(value) - allocate a floating point object
Xagain, these may be macros, or they may be actual procedure calls
X*/
X
Xextern object alcObject(INT X INT); /* the actual routine */
X# define allocObject(size) alcObject(size, objectMemory)
X# define allocByte(size) alcObject(((size)+1)/2, byteMemory)
X# define allocChar(size) alcObject(((size)+1)/2, charMemory)
Xextern object allocSymbol(STR);
X# define allocInt(value) ((value<0)?value:(value<<1)+1)
Xextern object allocFloat(FLOAT);
X
X/*
X integer objects are (but need not be) treated specially.
XIn this memory manager, negative integers are just left as is, but
Xpositive integers are changed to x*2+1. Either a negative or an odd
Xnumber is therefore an integer, while a nonzero even number is an
Xobject pointer (multiplied by two). Zero is reserved for the object ``nil''
XSince newInteger does not fill in the class field, it can be given here.
XIf it was required to use the class field, it would have to be deferred
Xuntil names.h
X*/
X
Xextern object intobj;
X# define isInteger(x) ((x) & 0x8001)
X# define newInteger(x) ( (intobj = x)<0 ? intobj : (intobj<<1)+1 )
X# define intValue(x) ( (intobj = x)<0 ? intobj : (intobj>>1) )
X
X/*
X in addition to alloc floating point routine given above,
Xanother routine must be provided to go the other way. Note that
Xthe routine newFloat, which fills in the class field as well, must
Xwait until the global name table is known, in names.h
X*/
Xextern double floatValue(OBJ);
X
X/*
X there are four routines used to access fields within an object.
XAgain, some of these could be replaced by macros, for efficiency
X basicAt(x, i) - ith field (start at 1) of object x
X basicAtPut(x, i, v) - put value v in object x
X byteAt(x, i) - ith field (start at 0) of object x
X byteAtPut(x, i, v) - put value v in object x
X
X# define basicAt(x,i) (sysMemPtr(x)[i-1])
X*/
X# define byteAt(x, i) (charPtr(x)[i-1])
X
X# ifndef basicAt
Xextern object basicAt(OBJ X INT);
X# endif
X# ifndef basicAtPut
Xextern void basicAtPut(OBJ X INT X OBJ);
X# endif
X# ifndef byteAt
Xextern int byteAt(OBJ X INT);
X# endif
X# ifndef byteAtPut
Xextern void byteAtPut(OBJ X INT X INT);
X# endif
X
X/*
X Finally, a few routines (or macros) are used to access or set
Xclass fields and size fields of objects
X*/
X
X# define classField(x) objectTable[x>>1].class
X# define setClass(x,y) incr(classField(x)=y)
X
X# define objectSize(x) byteToInt(objectTable[x>>1].size)
X
X# define sysMemPtr(x) objectTable[x>>1].memory
Xextern object sysobj;
X# define memoryPtr(x) (isInteger(sysobj = x)?(object *) 0:sysMemPtr(sysobj))
X# define bytePtr(x) ((byte *) memoryPtr(x))
X# define charPtr(x) ((char *) memoryPtr(x))
X
X# define nilobj (object) 0
X
X/*
X these two objects are the source of all objects in the system
X*/
Xextern object symbols;
Xextern object globalNames;
X
Xextern noreturn sysError (STR X STR);
Xextern boolean debugging;
Xextern noreturn initMemoryManager(NOARGS);
Xextern noreturn imageRead(FILEP);
Xextern noreturn imageWrite(FILEP);
/
echo 'x - primitive.c'
sed 's/^X//' > primitive.c << '/'
X/*
X Little Smalltalk, version 2
X Written by Tim Budd, Oregon State University, July 1987
X
X Primitive processor
X
X primitives are how actions are ultimately executed in the Smalltalk
X system.
X unlike ST-80, Little Smalltalk primitives cannot fail (although
X they can return nil, and methods can take this as an indication
X of failure). In this respect primitives in Little Smalltalk are
X much more like traditional system calls.
X
X Primitives are combined into groups of 10 according to
X argument count and type, and in some cases type checking is performed.
X
X IMPORTANT NOTE:
X The technique used to tell if an arithmetic operation
X has overflowed in intBinary() depends upon integers
X being 16 bits. If this is not true, other techniques
X may be required.
X*/
X
X# include <stdio.h>
X# include <math.h>
X# include "env.h"
X# include "memory.h"
X# include "names.h"
X# include "process.h"
X# ifdef STRING
X# include <string.h>
X# endif
X# ifdef STRINGS
X# include <strings.h>
X# endif
X
X# define normalresult 1
X# define counterror 2
X# define typeerror 3
X# define quitinterp 4
X
Xextern object doInterp(OBJ);
Xextern noreturn flushMessageCache();
Xextern double modf();
Xextern char *getenv();
X
Xstatic int zeroaryPrims(number)
Xint number;
X{ short i;
X
X returnedObject = nilobj;
X switch(number) {
X case 2:
X flushMessageCache();
X break;
X
X case 3: /* return a random number */
X /* this is hacked because of the representation */
X /* of integers as shorts */
X i = rand() >> 8; /* strip off lower bits */
X if (i < 0) i = - i;
X returnedObject = newInteger(i>>1);
X break;
X
X default: /* unknown primitive */
X sysError("unknown primitive","zeroargPrims");
X break;
X }
X return(normalresult);
X}
X
Xstatic int unaryPrims(number, firstarg)
Xint number;
Xobject firstarg;
X{
X
X returnedObject = firstarg;
X switch(number) {
X case 1: /* class of object */
X returnedObject = getClass(firstarg);
X break;
X
X case 2: /* basic size of object */
X if (isInteger(firstarg))
X returnedObject = newInteger(0);
X else
X returnedObject = newInteger(objectSize(firstarg));
X break;
X
X case 3: /* hash value of object */
X if (isInteger(firstarg))
X returnedObject = firstarg;
X else
X returnedObject = newInteger(firstarg);
X break;
X
X case 9: /* interpreter bytecodes */
X returnedObject = doInterp(firstarg);
X break;
X
X default: /* unknown primitive */
X sysError("unknown primitive","unaryPrims");
X break;
X }
X return(normalresult);
X}
X
Xstatic int binaryPrims(number, firstarg, secondarg)
Xint number;
Xobject firstarg, secondarg;
X{ char buffer[512];
X int i;
X
X returnedObject = firstarg;
X switch(number) {
X case 1: /* object identity test */
X if (firstarg == secondarg)
X returnedObject = trueobj;
X else
X returnedObject = falseobj;
X break;
X
X case 2: /* set class of object */
X decr(classField(firstarg));
X setClass(firstarg, secondarg);
X returnedObject = firstarg;
X break;
X
X case 4: /* string cat */
X ignore strcpy(buffer, charPtr(firstarg));
X ignore strcat(buffer, charPtr(secondarg));
X returnedObject = newStString(buffer);
X break;
X
X case 5: /* basicAt: */
X if (! isInteger(secondarg))
X sysError("non integer index","basicAt:");
X returnedObject = basicAt(firstarg, intValue(secondarg));
X break;
X
X case 6: /* byteAt: */
X if (! isInteger(secondarg))
X sysError("non integer index","bytAte:");
X i = byteAt(firstarg, intValue(secondarg));
X if (i < 0) i += 256;
X returnedObject = newInteger(i);
X break;
X
X default: /* unknown primitive */
X sysError("unknown primitive","binaryPrims");
X break;
X
X }
X return(normalresult);
X}
X
Xstatic int trinaryPrims(number, firstarg, secondarg, thirdarg)
Xint number;
Xobject firstarg, secondarg, thirdarg;
X{ char *bp, *tp, buffer[256];
X int i, j;
X
X returnedObject = firstarg;
X switch(number) {
X case 1: /* basicAt:Put: */
X if (! isInteger(secondarg))
X sysError("non integer index","basicAtPut");
X basicAtPut(firstarg, intValue(secondarg), thirdarg);
X break;
X
X case 2: /* basicAt:Put: for bytes */
X if (! isInteger(secondarg))
X sysError("non integer index","byteAtPut");
X if (! isInteger(thirdarg))
X sysError("assigning non int","to byte");
X byteAtPut(firstarg, intValue(secondarg),
X intValue(thirdarg));
X break;
X
X case 3: /* string copyFrom:to: */
X bp = charPtr(firstarg);
X if ((! isInteger(secondarg)) || (! isInteger(thirdarg)))
X sysError("non integer index","copyFromTo");
X i = intValue(secondarg);
X j = intValue(thirdarg);
X tp = buffer;
X if (i <= strlen(bp))
X for ( ; (i <= j) && bp[i-1]; i++)
X *tp++ = bp[i-1];
X *tp = '\0';
X returnedObject = newStString(buffer);
X break;
X
X case 8: /* execute a context */
X messageToSend = firstarg;
X if (! isInteger(secondarg))
X sysError("non integer index","executeAt:");
X argumentsOnStack = intValue(secondarg);
X creator = thirdarg;
X finalTask = ContextExecuteTask;
X return(quitinterp);
X
X case 9: /* compile method */
X setInstanceVariables(firstarg);
X if (parse(thirdarg, charPtr(secondarg)))
X returnedObject = trueobj;
X else
X returnedObject = falseobj;
X break;
X
X default: /* unknown primitive */
X sysError("unknown primitive","trinaryPrims");
X break;
X }
X return(normalresult);
X}
X
Xstatic int intUnary(number, firstarg)
Xint number, firstarg;
X{ char buffer[20];
X
X switch(number) {
X case 1: /* float equiv of integer */
X returnedObject = newFloat((double) firstarg);
X break;
X
X case 5: /* set random number */
X ignore srand((unsigned) firstarg);
X returnedObject = nilobj;
X break;
X
X case 7: /* string equiv of number */
X ignore sprintf(buffer,"%d",firstarg);
X returnedObject = newStString(buffer);
X break;
X
X case 8:
X returnedObject = allocObject(firstarg);
X break;
X
X case 9:
X returnedObject = allocByte(firstarg);
X break;
X
X default:
X sysError("intUnary primitive","not implemented yet");
X }
X return(normalresult);
X}
X
Xint intBinary(number, firstarg, secondarg)
Xregister int firstarg, secondarg;
Xint number;
X{ boolean binresult;
X long longresult;
X
X switch(number) {
X case 0: /* addition */
X longresult = firstarg;
X longresult += secondarg;
X if (longCanBeInt(longresult))
X firstarg = longresult;
X else
X goto overflow;
X break;
X case 1: /* subtraction */
X longresult = firstarg;
X longresult -= secondarg;
X if (longCanBeInt(longresult))
X firstarg = longresult;
X else
X goto overflow;
X break;
X
X case 2: /* relationals */
X binresult = firstarg < secondarg; break;
X case 3:
X binresult = firstarg > secondarg; break;
X case 4:
X binresult = firstarg <= secondarg; break;
X case 5:
X binresult = firstarg >= secondarg; break;
X case 6:
X binresult = firstarg == secondarg; break;
X case 7:
X binresult = firstarg != secondarg; break;
X
X case 8: /* multiplication */
X longresult = firstarg;
X longresult *= secondarg;
X if (longCanBeInt(longresult))
X firstarg = longresult;
X else
X goto overflow;
X break;
X
X case 9: /* quo: */
X if (secondarg == 0) goto overflow;
X firstarg /= secondarg; break;
X
X case 10: /* rem: */
X if (secondarg == 0) goto overflow;
X firstarg %= secondarg; break;
X
X case 11: /* bit operations */
X firstarg &= secondarg; break;
X case 12:
X firstarg ^= secondarg; break;
X
X case 19: /* shifts */
X if (secondarg < 0)
X firstarg >>= (- secondarg);
X else
X firstarg <<= secondarg;
X break;
X }
X if ((number >= 2) && (number <= 7))
X if (binresult)
X returnedObject = trueobj;
X else
X returnedObject = falseobj;
X else
X returnedObject = newInteger(firstarg);
X return(normalresult);
X
X /* on overflow, return nil and let smalltalk code */
X /* figure out what to do */
Xoverflow:
X returnedObject = nilobj;
X return(normalresult);
X}
X
Xstatic int strUnary(number, firstargument)
Xint number;
Xchar *firstargument;
X{
X switch(number) {
X case 1: /* length of string */
X returnedObject = newInteger(strlen(firstargument));
X break;
X
X case 3: /* string as symbol */
X returnedObject = newSymbol(firstargument);
X break;
X
X case 8: /* do a system call */
X returnedObject = newInteger(system(firstargument));
X break;
X
X default:
X sysError("unknown primitive", "strUnary");
X break;
X }
X
X return(normalresult);
X}
X
Xstatic int floatUnary(number, firstarg)
Xint number;
Xdouble firstarg;
X{ char buffer[20];
X double temp;
X
X switch(number) {
X case 1: /* asString */
X ignore sprintf(buffer,"%g", firstarg);
X returnedObject = newStString(buffer);
X break;
X
X case 2: /* log */
X returnedObject = newFloat(log(firstarg));
X break;
X
X case 3: /* exp */
X returnedObject = newFloat(exp(firstarg));
X break;
X
X case 4: /* sqrt */
X returnedObject = newFloat(sqrt(firstarg));
X break;
X
X case 6: /* integer part */
X ignore modf(firstarg, &temp);
X returnedObject = newInteger((int) temp);
X break;
X
X default:
X sysError("unknown primitive","floatUnary");
X break;
X }
X
X return(normalresult);
X}
X
Xint floatBinary(number, first, second)
Xint number;
Xdouble first, second;
X{ boolean binResult;
X
X switch(number) {
X case 0: first += second; break;
X
X case 1: first -= second; break;
X case 2: binResult = (first < second); break;
X case 3: binResult = (first > second); break;
X case 4: binResult = (first <= second); break;
X case 5: binResult = (first >= second); break;
X case 6: binResult = (first == second); break;
X case 7: binResult = (first != second); break;
X case 8: first *= second; break;
X case 9: first /= second; break;
X default:
X sysError("unknown primitive", "floatBinary");
X break;
X }
X
X if ((number >= 2) && (number <= 7))
X if (binResult)
X returnedObject = trueobj;
X else
X returnedObject = falseobj;
X else
X returnedObject = newFloat(first);
X return(normalresult);
X}
X
X/* file primitives - necessaryily rather UNIX dependent;
X basically, files are all kept in a large array.
X File operations then just give an index into this array
X*/
X# define MAXFILES 20
X/* we assume this is initialized to NULL */
Xstatic FILE *filepointers[MAXFILES];
X
Xstatic int filePrimitive(number, arguments, size)
Xint number, size;
Xobject *arguments;
X{ int i;
X char *p, buffer[512];
X
X returnedObject = nilobj;
X
X if (number) { /* not an open, we can get file number*/
X if (! isInteger(arguments[0]))
X return(typeerror);
X i = intValue(arguments[0]);
X }
X
X switch(number) {
X case 0: /* file open */
X /* first find a free slot */
X for (i = 0; i < MAXFILES; i++)
X if (filepointers[i] == NULL)
X break;
X if (i >= MAXFILES)
X sysError("too many open files","primitive");
X
X p = charPtr(arguments[0]);
X if (streq(p, "stdin"))
X filepointers[i] = stdin;
X else if (streq(p, "stdout"))
X filepointers[i] = stdout;
X else if (streq(p, "stderr"))
X filepointers[i] = stderr;
X else {
X filepointers[i] = fopen(p, charPtr(arguments[1]));
X }
X if (filepointers[i] == NULL)
X returnedObject = nilobj;
X else
X returnedObject = newInteger(i);
X break;
X
X case 1: /* file close - recover slot */
X ignore fclose(filepointers[i]);
X filepointers[i] = NULL;
X break;
X
X case 2: /* file size */
X case 3: /* file seek */
X case 4: /* get character */
X sysError("file operation not implemented yet","");
X
X case 5: /* get string */
X if (fgets(buffer, 512, filepointers[i]) != NULL) {
X if (filepointers[i] == stdin) {
X /* delete the newline */
X i = strlen(buffer);
X if (buffer[i-1] == '\n')
X buffer[i-1] = '\0';
X }
X returnedObject = newStString(buffer);
X }
X break;
X
X case 7: /* write an object image */
X imageWrite(filepointers[i]);
X returnedObject = trueobj;
X break;
X
X case 8: /* print no return */
X case 9: /* print string */
X ignore fputs(charPtr(arguments[1]), filepointers[i]);
X if (number == 8)
X ignore fflush(filepointers[i]);
X else
X ignore fputc('\n', filepointers[i]);
X break;
X
X default:
X sysError("unknown primitive","filePrimitive");
X }
X
X return(normalresult);
X}
X
X/* primitive -
X the main driver for the primitive handler
X*/
Xboolean primitive(primitiveNumber, arguments, size)
Xint primitiveNumber, size;
Xobject *arguments;
X{ int primitiveGroup;
X boolean done = false;
X int response;
X
X primitiveGroup = primitiveNumber / 10;
X response = normalresult;
X switch(primitiveGroup) {
X case 0: case 1: case 2: case 3:
X if (size != primitiveGroup)
X response = counterror;
X else {
X switch(primitiveGroup) {
X case 0:
X response = zeroaryPrims(primitiveNumber);
X break;
X case 1:
X response = unaryPrims(primitiveNumber - 10, arguments[0]);
X break;
X case 2:
X response = binaryPrims(primitiveNumber-20, arguments[0], arguments[1]);
X break;
X case 3:
X response = trinaryPrims(primitiveNumber-30, arguments[0], arguments[1], arguments[2]);
X break;
X }
X }
X break;
X
X
X case 5: /* integer unary operations */
X if (size != 1)
X response = counterror;
X else if (! isInteger(arguments[0]))
X response = typeerror;
X else
X response = intUnary(primitiveNumber-50,
X intValue(arguments[0]));
X break;
X
X case 6: case 7: /* integer binary operations */
X if (size != 2)
X response = counterror;
X else if ((! isInteger(arguments[0])) ||
X ! isInteger(arguments[1]))
X response = typeerror;
X else
X response = intBinary(primitiveNumber-60,
X intValue(arguments[0]),
X intValue(arguments[1]));
X break;
X
X case 8: /* string unary */
X if (size != 1)
X response = counterror;
X else if (! isString(arguments[0]))
X response = typeerror;
X else
X response = strUnary(primitiveNumber-80,
X charPtr(arguments[0]));
X break;
X
X case 10: /* float unary */
X if (size != 1)
X response = counterror;
X else if (! isFloat(arguments[0]))
X response = typeerror;
X else
X response = floatUnary(primitiveNumber-100,
X floatValue(arguments[0]));
X break;
X
X case 11: /* float binary */
X if (size != 2)
X response = counterror;
X else if ((! isFloat(arguments[0])) ||
X (! isFloat(arguments[1])))
X response = typeerror;
X else
X response = floatBinary(primitiveNumber-110,
X floatValue(arguments[0]),
X floatValue(arguments[1]));
X break;
X
X case 12: /* file operations */
X response = filePrimitive(primitiveNumber-120,
X arguments, size);
X break;
X }
X
X /* now check return code */
X switch(response) {
X case normalresult:
X break;
X case quitinterp:
X done = true;
X break;
X case counterror:
X sysError("count error","in primitive");
X break;
X case typeerror:
X sysError("type error","in primitive");
X returnedObject = nilobj;
X break;
X
X default:
X sysError("unknown return code","in primitive");
X returnedObject = nilobj;
X break;
X }
X return (done);
X}
X
/
echo 'x - script.ini'
sed 's/^X//' > script.ini << '/'
X globalNames at: #version put: '2.02'
X globalNames at: #editor put: 'vi'
/
echo 'x - test.ini'
sed 's/^X//' > test.ini << '/'
X test all
/
echo 'Part 01 of small.v2 complete.'
exit
--
For comp.sources.unix stuff, mail to sources at uunet.uu.net.
More information about the Comp.sources.unix
mailing list