diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..b01a886 --- /dev/null +++ b/Makefile @@ -0,0 +1,34 @@ +CC = gcc +XSOPT = +SOPT = -Wall -O2 -fno-defer-pop +CPY = cp -a +DEL = rm -f + +pdst.s: pdst.c + $(CC) $(XSOPT) $(SOPT) -S pdst.c + +pdst.o: pdst.s + $(CC) -c pdst.s + +pdst: pdst.o + $(CC) -o pdst pdst.o -lm + +systemImage: initial.st + ./pdst -c initial.st + +.PHONY: test1 +test1: + $(CPY) snapshot snapshot.1 + ./pdst -w snapshot . "primFlushCache" + self logMethod: aMethod! + instanceSize + ^ instanceSize! + logMethod: aMethod + '{' logChunk. + (self name asString , ' methods') logChunk. + aMethod trimmedText logChunk. + '}' logChunk! + methodNamed: name + (methods includesKey: name) + ifTrue: [ ^ methods at: name ]. + (superClass notNil) + ifTrue: [ ^ superClass methodNamed: name ]. + ^ nil! + methods + ^ methods! + name + ^ name! + name: aString + name <- aString! + name: nSym instanceSize: iInt methods: mDict superClass: sClass variables: vArray + name <- nSym. + instanceSize <- iInt. + methods <- mDict. + superClass <- sClass. + variables <- vArray! + new + ^ self primOrefs: instanceSize! + new: size + ^ self primOrefs: size! + newMethod: aStr | m | + (m <- self doEdit: aStr) notNil ifTrue: [ + self install: m ]! + primBytes: size + "create a new block, set its class" + ^ <22 <59 size> self>! + primOrefs: size + "create a new block, set its class" + ^ <22 <58 size> self>! + printString + ^ name asString! + readMethods + [ smalltalk inquire: 'Add a method (yn) ? ' ] + whileTrue: [ self addMethod ]! + removeMethod: name | m | + m <- self methodNamed: name. + (m notNil and: [m methodClass == self]) ifTrue: [ + methods removeKey: name. + <38 name self> ] "primFlushCache" + ifFalse: [ + 'no such method' print ]! + respondsTo | theSet | + theSet <- Dictionary new. + self upSuperclassChain: + [:x | theSet addAll: x methods ]. + ^ theSet! + 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! + viewMethod: methodName | m | + m <- self methodNamed: methodName. + (m notNil) + ifTrue: [ m signature print. m trimmedText print ] + ifFalse: [ 'no such method' print ]! + watch: name | m | + m <- self methodNamed: name. + (m notNil) + ifTrue: [ ^ m watch: + [:a | ('executing ', name) print. a print] ] + ifFalse: [ ^ 'no such method' ]! +}! +{! +Block methods! + blockContext: ctx + context <- ctx! + checkArgumentCount: count + ^ (argCount = count) + ifTrue: [ true ] + ifFalse: [ smalltalk error: + 'wrong number of arguments passed to block'. + false ]! + fork + self newProcess resume! + forkWith: args + (self newProcessWith: args) resume! + newProcess + " create a new process to execute block " + ^ Process 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! + 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 ]! + whileFalse: aBlock + [ self value not ] whileTrue: aBlock! + whileTrue + self whileTrue: []! + whileTrue: aBlock + ( self value ) ifTrue: + [ aBlock value. + self whileTrue: aBlock ]! +}! +{! +BlockNode methods! +compile: encoder block: inBlock | blk fwd | + blk <- self newBlock. "fix" + encoder genHigh: 4 low: (encoder genLiteral: blk). + encoder genHigh: 5 low: 4. "ldc thisContext" + encoder genHigh: 13 low: 2. "prim 29" + encoder genCode: 29. + encoder genHigh: 15 low: 6. "jmp " + fwd <- encoder genCode: 0. + blk basicAt: 4 put: encoder currentLocation + 1. + self compileInLine: encoder block: true. + encoder genHigh: 15 low: 2. "rtnt" + encoder hack: fwd ":" "fix?"! +compileInLine: encoder block: inBlock + | base | + temporaryCount > 0 ifTrue: [ + base <- temporaryLocation + argumentCount. + (1 to: temporaryCount) do: [ :i | + encoder genHigh: 5 low: 5. "ldc nil" + encoder genHigh: 7 low: base + (i - 1). "stt" + encoder genHigh: 15 low: 5 "pop" ] ]. + statements reverseDo: + [ :stmt | stmt compile: encoder block: inBlock. + encoder genHigh: 15 low: 5 "pop" ]. + encoder backUp! +isBlock + ^ true! +newBlock "fix" + | ans | + ans <- <22 <58 6> Block>. + ans basicAt: 2 put: argumentCount. "argCount" + ans basicAt: 3 put: temporaryLocation + 1. "argLoc" + ans basicAt: 4 put: 0. "bytePointer" + ^ ans! +statements: s temporaryLocation: t argumentCount: ac temporaryCount: tc + statements <- s. + temporaryLocation <- t. + argumentCount <- ac. + temporaryCount <- tc! +}! +{! +BodyNode methods! +compile: encoder block: inBlock + statements reverseDo: + [ :stmt | stmt compile: encoder block: inBlock. + encoder genHigh: 15 low: 5 " pop "]. + encoder genHigh: 15 low: 1 " return self "! +statements: s + statements <- s! +}! +{! +Boolean methods! + and: aBlock + ^ self ifTrue: aBlock ifFalse: [ false ]! + ifFalse: falseBlock + ^ self ifTrue: [] ifFalse: falseBlock! + ifFalse: falseBlock ifTrue: trueBlock + ^ self ifTrue: trueBlock + ifFalse: falseBlock! + ifTrue: trueBlock + ^ self ifTrue: trueBlock ifFalse: []! + or: aBlock + ^ self ifTrue: [ true ] ifFalse: aBlock! +}! +{! +ByteArrayMeta methods! + basicNew: size + ^ self primBytes: size! + new: size + ^ self primBytes: size! +}! +{! +ByteArray methods! + asByteArray + ^ self! + asString | newString i | + newString <- String new: self size. + i <- 0. + self do: [:x | i <- i + 1. newString at: i put: x asCharacter]. + ^ newString! + basicAt: index + ^ <26 self index>! + 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']! + logChunk + ^ <154 self>! + size: value + ^ <22 <59 value> ByteArray>! +}! +{! +CascadeNode methods! +compile: encoder block: inBlock + | left | + head compile: encoder block: inBlock. + left <- list size. + list reverseDo: [ :stmt | + left <- left - 1. + left > 0 ifTrue: [ + encoder genHigh: 15 low: 4 " duplicate " ]. + stmt compile: encoder block: inBlock. + left > 0 ifTrue: [ + encoder genHigh: 15 low: 5 "pop from stack " ] ]! +head: h + head <- h! +list: l + list <- l! +}! +{! +CharMeta methods! + value: aValue + ^ self new value: aValue! +}! +{! +Char methods! + < 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 yourself; at: 1 put: self; yourself! + 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'! + isAlphaNumeric + ^ (self isAlphabetic) or: [ self isDigit ]! + isAlphabetic + ^ (self isLowercase) or: [ self isUppercase ]! + isBlank + ^ value = $ asInteger " 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! + printString + ^ '$', self asString! + value: aValue " private - used for initialization " + value <- aValue! +}! +{! +Class methods! + fileOut | f | + " file out whole class on class.st " + (f <- File name: (name asString,'.st') mode: 'w') open. + self fileOutOn: f. + f close! + fileOutClassOn: aFile | dlm pad buf buf2 | + dlm <- 10 asCharacter asString. + pad <- 9 asCharacter asString. + buf <- superClass isNil ifTrue: [ + 'nil' ] + ifFalse: [ + superClass name asString ]. + buf <- buf , dlm , pad. + buf <- buf , 'subclass: ' , self name printString. + buf <- buf , dlm , pad. + buf2 <- ''. + variables notNil ifTrue: [ + variables inject: '' into: [ :p :v | + buf2 <- buf2 , p , v. + ' ' ] ]. + buf <- buf , 'instanceVariableNames: ' , buf2 printString. + aFile putChunk: buf! + fileOutOn: aFile + " file out class description " + self fileOutClassOn: aFile. + self class fileOutMethodsOn: aFile. + self fileOutMethodsOn: aFile! + subClasses + ^ classes inject: List new + into: [:x :y | (y superClass == self) + ifTrue: [ x add: y]. x ]! + subclass: aSymbol instanceVariableNames: aString + | newMeta varArray newClass | + newMeta <- Metaclass + metaName: (aSymbol asString , 'Meta') asSymbol + instanceSize: self class instanceSize + methods: Dictionary new + superClass: self class + variables: (Array primOrefs: 0). + varArray <- aString words: [ :x | x isAlphaNumeric ]. + newClass <- newMeta + instName: aSymbol + instanceSize: self instanceSize + varArray basicSize + methods: Dictionary new + superClass: self + variables: varArray. + newMeta name assign: newMeta. + aSymbol assign: newClass. + classes at: aSymbol put: newClass. + ^ newClass! +}! +{! +Collection methods! + < 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 + ^ self sort: [:x :y | x < y ]! + sort: aBlock + ^ self inject: List new + into: [:x :y | x add: y ordered: aBlock. x]! +}! +{! +ContextMeta methods! + method: aMeth arguments: aVec temporaries: tVec + ^ self new method: aMeth arguments: aVec temporaries: tVec! +}! +{! +Context methods! + arguments: a + arguments <- a! + at: key put: value + temporaries at: key put: value! + blockReturn + <18 self> + ifFalse: [ ^ smalltalk error: + 'incorrect context for block return']! + copy + ^ super copy temporaries: temporaries copy! + method: m + method <- m! + method: aMeth arguments: aVec temporaries: tVec + method <- aMeth. + arguments <- aVec. + temporaries <- tVec! + returnToBlock: bytePtr + " change the location we will return to, to execute a block" + <28 self bytePtr>! + temporaries: t + temporaries <- t! +}! +{! +DictionaryMeta methods! + new + ^ self basicNew + hashTable: (Array new: 39)! +}! +{! +Dictionary methods! + 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 key: aKey value: aValue)]]! + basicRemoveKey: aKey | hashPosition link | + hashPosition <- self hash: aKey. + ((hashTable at: hashPosition + 1) = aKey) + ifTrue: [ link <- hashTable at: hashPosition + 3. + (link notNil) ifTrue: [ + hashTable at: hashPosition + 1 put: link key. + hashTable at: hashPosition + 2 put: link value. + hashTable at: hashPosition + 3 put: link next ] + ifFalse: [ + 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) ] ]! + 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 ]! + hash: aKey + ^ 3 * ((aKey hash) rem: ((hashTable size) quo: 3))! + hashTable: hArray + hashTable <- hArray! + 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! +}! +{! +Encoder methods! +backUp + " back up one instruction " + index <- index - 1! +currentLocation + ^ index! +expandByteCodes | newarray size | + size <- byteCodes size. + newarray <- byteCodes size: size + 8. "fix" + (1 to: size) do: [:i | newarray at: i put: (byteCodes at: i)]. + byteCodes <- newarray! +genCode: byte + index = 256 ifTrue: [ + parser error: 'too many byte codes' ]. + index <- index + 1. + (index >= byteCodes size) + ifTrue: [ self expandByteCodes]. + byteCodes at: index put: byte. + ^ index! +genHigh: high low: low + (low >= 16) + ifTrue: [ self genHigh: 0 low: high. self genCode: low ] + ifFalse: [ self genCode: high * 16 + low ]! +genLiteral: aValue + literals size = 256 ifTrue: [ + parser error: 'too many literals' ]. + literals <- literals with: aValue. + ^ literals size - 1! +hack: loc "fix" + byteCodes at: loc put: index + 1! +hackByteCodes | newarray | + newarray <- byteCodes size: index. "fix" + (1 to: index) do: [:i | newarray at: i put: (byteCodes at: i)]. + byteCodes <- newarray! +hackLiterals + literals size = 0 ifTrue: [ + literals <- nil ]! +hackMaxStack + maxStack <- 6! +method: maxTemps class: c text: text + | ans | + ans <- Method new. + ans text: text. + ans message: name. + self hackByteCodes. + ans basicAt: 3 put: byteCodes. + self hackLiterals. + ans basicAt: 4 put: literals. + self hackMaxStack. + ans basicAt: 5 put: maxStack. + "self hackMaxTemps." + ans basicAt: 6 put: maxTemps + 1. + ans methodClass: c. + ^ ans! +name: n + name <- n asSymbol. + byteCodes <- '' size: 20. "fix" + index <- 0. + literals <- Array new: 0. + stackSize <- 0. + maxStack <- 1.! +parser: aParser + parser <- aParser! +patch: loc + " patch a goto from a block " + byteCodes at: loc put: index! +popArgs: n + stackSize <- stackSize - n.! +pushArgs: n + stackSize <- stackSize + n. + maxStack <- stackSize max: maxStack! +}! +{! +False methods! + ifTrue: trueBlock ifFalse: falseBlock + ^ falseBlock value! + not + ^ true! + printString + ^ 'false'! + xor: aBoolean + ^ aBoolean! +}! +{! +FileMeta methods! + name: nStr mode: mStr + ^ self new name: nStr mode: mStr! + name: nStr open: mStr + ^ self new name: nStr open: mStr! +}! +{! +File methods! + asString | text line | + text <- ''. + [ (line <- self getString) notNil ] + whileTrue: [ text <- text , line ]. + ^ text! + close + " close file, take entry out of global variable " + number isNil ifTrue: [ ^ nil ]. + files at: number put: nil. + <121 number>. + number <- nil.! + delete + ('rm ', name) unixCommand! + fileIn | str | + [ (str <- self getChunk) notNil ] whileTrue: [ + str = '{' ifTrue: [ + self fileInSet ] + ifFalse: [ + str execute ] ]! + fileIn: name + self name: name. + self open: 'r'. + self fileIn. + self close.! + fileInSet | str pos cls mth | + (str <- self getChunk) isNil ifTrue: [ + self halt ]. + str = '}' ifTrue: [ + ^ self ]. + pos <- str indexOf: [ :c | c isBlank ]. + cls <- (str copyFrom: 1 to: pos - 1) asSymbol value. + [ (str <- self getChunk) notNil ] whileTrue: [ + str = '}' ifTrue: [ + ^ self ]. + (mth <- Parser new parse: str in: cls) notNil ifTrue: [ + cls install: mth ] ]. + self halt! + getChunk + ^ (number notNil) + ifTrue: [<157 number>]! + 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]]! + getString + ^ (number notNil) + ifTrue: [<125 number>]! + mode: m + mode <- m! + name + ^ name! + name: string + name <- string! + name: nStr mode: mStr + name <- nStr. + mode <- mStr! + name: nStr open: mStr + name <- nStr. + mode <- mStr. + self open! + open + number notNil ifTrue: [ self close ]. + self getNumber. + <120 number name mode> isNil + ifTrue: [ smalltalk error: + 'open failed: ', name. ^ false]. + ^ true! + open: m + self mode: m. + self open! + 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']! + putChunk: buffer + ^ (number notNil) + ifTrue: [<158 number buffer>]! + readUntil: conditionBlock doing: actionBlock | line | + [ line <- self getString. line notNil] + whileTrue: [ (conditionBlock value: line) + ifTrue: [ ^ line ]. + actionBlock value: line ]. + ^ nil! + saveImage | saveAns | + " 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. + saveAns <- <127 number>. + files at: number put: self] + ifFalse: [smalltalk error: 'saveImage: file not open']. + ^saveAns! + scratchFile + name <- 'junk.tmp'! +}! +{! +FloatMeta methods! + new + ^ smalltalk error: 'cannot create floats with new'! +}! +{! +Float methods! + * value + ^ value isFloat + ifTrue: [ <118 self value> ] + ifFalse: [ super * value ]! + + 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: [ (value = 0.0) + ifTrue: [ smalltalk error: + 'float division by zero' ] + ifFalse: [ <119 self value> ]] + 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 ]! + 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)]! + isFloat + ^ true! + ln + " natural log of self " + ^ <102 self>! + 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! +}! +{! +FractionMeta methods! + top: tNum bottom: bNum + ^ self new top: tNum bottom: bNum! +}! +{! +Fraction methods! + * f + f isFraction + ifTrue: [ ^ (top * 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 bottom) - (bottom * f top)) / + (bottom * f bottom) ] + ifFalse:[ ^ super - f ]! + / f + ^ self * f reciprocal! + < f + f isFraction + ifTrue: [ ^ (top * f bottom) < (bottom * f top) ] + ifFalse:[ ^ super < f ]! + = f + f isFraction + ifTrue: [ ^ (top = f top) and: [ bottom = f bottom ] ] + ifFalse: [ ^ super = f ]! + abs + ^ top abs / bottom! + asFloat + " convert to a floating point number " + + ^ top asFloat / bottom asFloat! + 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)! + printString + ^ top printString, '/', bottom printString! + raisedTo: x + ^ (top raisedTo: x) / (bottom raisedTo: x)! + reciprocal + ^ bottom / top! + top + ^ top! + top: tNum bottom: bNum + top <- tNum. + bottom <- bNum! + truncated + " convert to an integer rounded towards zero " + ^ top quo: bottom! + with: t over: b + " initialization " + + top <- t. + bottom <- b! +}! +{! +IndexedCollection methods! + addAll: aCollection + aCollection binaryDo: [:i :x | self at: i put: x ]! + asArray + ^ (Array new: self size) yourself; addAll: self; yourself! + asDictionary + ^ Dictionary new yourself; addAll: self; yourself! + 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 ]! + 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! + keys + ^ self binaryInject: Set new + into: [:s :i :x | s add: i ]! + 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 ]! +}! +{! +InstNode methods! +assign: encoder + encoder genHigh: 6 low: position - 1! +assignable + ^ true! +compile: encoder block: inBlock + encoder genHigh: 1 low: position - 1! +position: p + position <- p! +}! +{! +IntegerMeta methods! + new + ^ smalltalk error: 'cannot create integers with new'! +}! +{! +Integer methods! + * 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 | 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 + " used to make long integer constants " + ^ self * 1000 + 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 | 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 top: t bottom: b ] + ifFalse: [ ^ super / value ]! + < value + ^ (self isShortInteger and: [value isShortInteger]) + ifTrue: [ <62 self value> ] + ifFalse: [ super < value ]! + = value + ^ (self isShortInteger and: [value isShortInteger]) + ifTrue: [ self == value ] + ifFalse: [ super = value ]! + > value + ^ (self isShortInteger and: [value isShortInteger]) + ifTrue: [ <63 self value> ] + ifFalse: [ super > 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 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 top: self bottom: 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 negative: 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)! + bitShift: value + ^ (self isShortInteger and: [value isShortInteger]) + ifTrue: [ <79 self value > ] + ifFalse: [ smalltalk error: + 'argument to bit operation must be integer']! + bitXor: value + ^ (self isShortInteger and: [value isShortInteger]) + ifTrue: [ <72 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! + odd + ^ (self rem: 2) ~= 0! + printString + ^ self asString! + 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 ]! + timesRepeat: aBlock | i | + " use while, which is optimized, not to:, which is not" + i <- 0. + [ i < self ] whileTrue: + [ aBlock value. i <- i + 1]! + truncated + ^ self! +}! +{! +IntervalMeta methods! + lower: lValue upper: uValue step: sValue + ^ self new lower: lValue upper: uValue step: sValue! +}! +{! +Interval methods! + 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! + lower: lValue upper: uValue step: sValue + lower <- lValue. + upper <- uValue. + step <- sValue! + step: aValue + step <- aValue! + upper: aValue + upper <- aValue! +}! +{! +LinkMeta methods! + key: aKey value: aValue + ^ self new key: aKey value: aValue! + value: aValue + ^ self new value: aValue! + value: aValue link: aLink + ^ self new value: aValue link: aLink! +}! +{! +Link methods! + add: newValue whenFalse: aBlock + (aBlock value: value value: newValue) + ifTrue: [ (nextLink notNil) + ifTrue: [ nextLink <- nextLink add: newValue + whenFalse: aBlock ] + ifFalse: [ nextLink <- Link value: newValue] ] + ifFalse: [ ^ Link 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 + key: aKey value: aValue] ]! + binaryDo: aBlock + aBlock value: key value: value. + (nextLink notNil) + ifTrue: [ nextLink binaryDo: aBlock ]! + includesKey: aKey + (key = aKey) + ifTrue: [ ^ true ]. + (nextLink notNil) + ifTrue: [ ^ nextLink includesKey: aKey ] + ifFalse: [ ^ false ]! + key + ^ key! + key: aKey + key <- aKey! + key: aKey value: aValue + key <- aKey. + value <- aValue! + 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 + ^ value! + value: aValue + value <- aValue! + value: aValue link: aLink + value <- aValue. + nextLink <- aLink! +}! +{! +List methods! + 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 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 ]! + do: aBlock + (links notNil) + ifTrue: [ links binaryDo: [:x :y | aBlock value: y]]! + first + ^ (links notNil) + ifTrue: links + ifFalse: [ smalltalk error: 'first on empty list']! + links + ^ links "used to walk two lists in parallel "! + reject: aBlock + ^ self select: [:x | (aBlock value: x) not ]! + remove: value + (links notNil) + ifTrue: [ links <- links removeValue: value ]! + removeFirst + self remove: self first! + 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]! + size + (links isNil) + ifTrue: [ ^ 0 ] + ifFalse: [ ^ links size ]! +}! +{! +LiteralNode methods! +compile: encoder block: inBlock + (value class == Integer and: [ value >= 0 and: [value <= 2] ]) + ifTrue: [ ^ encoder genHigh: 5 low: value ]. + (value class == Integer and: [ value = -1 ]) + ifTrue: [ ^ encoder genHigh: 5 low: 3 ]. + "value == #currentInterpreter ifTrue: [ ^ encoder genHigh: 5 low: 4 ]." + nil == value ifTrue: [ ^ encoder genHigh: 5 low: 5 ]. + true == value ifTrue: [ ^ encoder genHigh: 5 low: 6 ]. + false == value ifTrue: [ ^ encoder genHigh: 5 low: 7 ]. + encoder genHigh: 4 low: (encoder genLiteral: value)! +value: v + value <- v! +}! +{! +LongIntegerMeta methods! + negative: nBool digits: dArray + ^ self basicNew negative: nBool digits: dArray! + new + ^ self basicNew + negative: nil + digits: nil! +}! +{! +LongInteger methods! + * 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! + + 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 negative: 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 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! + 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 negative: negative not digits: digits! + negative + ^ negative! + negative: nBool digits: dArray + negative <- nBool. + digits <- dArray! + printString | str | + str <- negative ifTrue: [ '-' ] ifFalse: [ '' ]. + digits reverseDo: [:x | str <- str , + (x quo: 10) printString , (x rem: 10) printString ]. + ^ str! + 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.! + 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 negative: (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]) ]! +}! +{! +Magnitude methods! + < value + ^ (self <= value) and: [ self ~= value ]! + <= value + ^ (self < value) or: [ self = value ]! + = value + ^ (self == value)! + > value + ^ (value < self)! + >= value + ^ value <= self! + 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 ]! + ~= value + ^ (self = value) not! +}! +{! +MessageNode methods! +argumentsAreBlock + arguments do: [ :arg | arg isBlock ifFalse: [ ^ false ]]. + ^ true! +cascade: encoder block: inBlock + self evaluateArguments: encoder block: inBlock. + (self sent2Arg: encoder selector: name) ifTrue: [ + ^ self ]. + self sendMessage: encoder block: inBlock! +compile2: encoder block: inBlock + self argumentsAreBlock ifTrue: [ + name = #ifTrue: ifTrue: [ ^ self compile: encoder + test: 8 constant: 5 block: inBlock ]. + name = #ifFalse: ifTrue: [ ^ self compile: encoder + test: 7 constant: 5 block: inBlock ]. + name = #and: ifTrue: [ ^ self compile: encoder + test: 9 constant: 7 block: inBlock ]. + name = #or: ifTrue: [ ^ self compile: encoder + test: 10 constant: 6 block: inBlock ] + ]. + name = #ifTrue:ifFalse: + ifTrue: [ ^ self optimizeIf: encoder block: inBlock ]. + self evaluateArguments: encoder block: inBlock. + (self sent2Arg: encoder selector: name) ifTrue: [ + ^ self ]. + self sendMessage: encoder block: inBlock! +compile: encoder block: inBlock + receiver isNil + ifTrue: [ ^ self cascade: encoder block: inBlock ]. + "((receiver isBlock and: [ self argumentsAreBlock ]) + and: [name = #whileTrue: or: [ name = #whileFalse ] ] )" + (name = #whileTrue: or: [ name = #whileFalse ]) "fix" + ifTrue: [ ^ self optimizeWhile: encoder block: inBlock ]. + receiver compile: encoder block: inBlock. + receiver isSuper + ifTrue: [ ^ self sendToSuper: encoder block: inBlock ]. + #(#isNil #notNil #value #new #class #size #basicSize #print + #printString) binaryDo: [ :i :s | + name = s ifTrue: [ + ^ encoder genHigh: 10 low: i - 1 ] ]. + self compile2: encoder block: inBlock! +compile: encoder test: t constant: c block: inBlock | save | + encoder genHigh: 15 low: t. " branch test " + save <- encoder genCode: 0. + arguments first compileInLine: encoder block: inBlock. + encoder hack: save "fix?"! +evaluateArguments: encoder block: inBlock + encoder pushArgs: 1 + arguments size. + arguments reverseDo: [ :arg | + arg compile: encoder block: inBlock ]! +optimizeIf: encoder block: inBlock | flsBlk truBlk save ssave | + flsBlk <- arguments first. + arguments removeFirst. + truBlk <- arguments first. + encoder genHigh: 15 low: 8. " branch if false test " + save <- encoder genCode: 0. + truBlk isBlock ifTrue: [ + truBlk compileInLine: encoder block: inBlock ] + ifFalse: [ "fix" + truBlk compile: encoder block: inBlock. + encoder genHigh: 10 low: 2 ]. "snd1 value" + encoder genHigh: 15 low: 6. " branch " + ssave <- encoder genCode: 0. + encoder hack: save. "fix?" + encoder genHigh: 15 low: 5. " pop " + flsBlk isBlock ifTrue: [ + flsBlk compileInLine: encoder block: inBlock ] + ifFalse: [ "fix" + flsBlk compile: encoder block: inBlock. + encoder genHigh: 10 low: 2 ]. "snd1 value" + encoder hack: ssave "fix?"! +optimizeWhile: encoder block: inBlock | blk fwd top arg | + receiver isBlock ifTrue: [ + blk <- receiver newBlock. "fix" + encoder genHigh: 4 low: (encoder genLiteral: blk). + encoder genHigh: 5 low: 4. "ldc thisContext" + encoder genHigh: 13 low: 2. "prim 29" + encoder genCode: 29. + encoder genHigh: 15 low: 6. "jmp " + fwd <- encoder genCode: 0. + blk basicAt: 4 put: encoder currentLocation + 1. + receiver compileInLine: encoder block: true. + encoder genHigh: 15 low: 2. "rtnt" + encoder genHigh: 15 low: 4. "dup" + encoder patch: fwd ] ":" + ifFalse: [ "fix" + receiver compile: encoder block: inBlock. + encoder genHigh: 15 low: 4 ]. "dup" + top <- encoder currentLocation. + encoder genHigh: 10 low: 2. "snd1 value" + name = #whileTrue: "jmpf/t " + ifTrue: [ encoder genHigh: 15 low: 8 ] + ifFalse: [ encoder genHigh: 15 low: 7 ]. + fwd <- encoder genCode: 0. + (arg <- arguments first) isBlock ifTrue: [ + arg compileInLine: encoder block: inBlock ] + ifFalse: [ "fix" + arg compile: encoder block: inBlock. + encoder genHigh: 10 low: 2 ]. "snd1 value" + encoder genHigh: 15 low: 5. "pop" + encoder genHigh: 15 low: 6. "jmp " + encoder genCode: top. + encoder genHigh: 15 low: 5. "pop" "fix" + encoder patch: fwd ":"! +receiver: r name: n arguments: a + receiver <- r. + name <- n. + arguments <- a! +sendMessage: encoder block: inBlock + encoder popArgs: arguments size. + " mark arguments, then send message " + encoder genHigh: 8 low: 1 + arguments size. + encoder genHigh: 9 low: (encoder genLiteral: name)! +sendToSuper: encoder block: inBlock + self evaluateArguments: encoder block: inBlock. + encoder genHigh: 8 low: 1 + arguments size. + encoder genHigh: 15 low: 11. + encoder genCode: (encoder genLiteral: name)! +sent2Arg: encoder selector: symbol + #(#+ #- #< #> #<= #>= #= #~= #* #quo: #rem: #bitAnd: #bitXor: + #== #, #at: #basicAt: #do: #coerce: #error: #includesKey: + #isMemberOf: #new: #to: #value: #whileTrue: #addFirst: + #addLast:) binaryDo: [ :i :s | + symbol == s ifTrue: [ + encoder genHigh: 11 low: i - 1. + ^ true ] ]. + ^ false! +}! +{! +MetaclassMeta methods! + metaName: nSym instanceSize: iInt methods: mDict superClass: sClass variables: vArray + ^ self basicNew + name: nSym + instanceSize: iInt + methods: mDict + superClass: sClass + variables: vArray! +}! +{! +Metaclass methods! + instName: nSym instanceSize: iInt methods: mDict superClass: sClass variables: vArray + ^ self basicNew + name: nSym + instanceSize: iInt + methods: mDict + superClass: sClass + variables: vArray! + subClasses + ^ classes inject: List new + into: [:x :y | (y class superClass == self) + ifTrue: [ x add: y class ]. x ]! +}! +{! +Method methods! + 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 + method: self + arguments: arguments + temporaries: (Array new: temporarySize) ) + returnToBlock: 1! + message: aSymbol + message <- aSymbol! + methodClass + ^class! + methodClass: aClass + class <- aClass! + name + ^ message! + printString + ^ message asString! + signature + ^ class asString,' ', message asString! + text + ^ (text notNil) + ifTrue: [ text ] + ifFalse: [ 'text not saved']! + text: aString + text <- aString! + trimmedText | dlm ans | + dlm <- 10 asCharacter. + (ans <- self text) isEmpty ifTrue: [ + ^ans ]. + [ (ans at: 1) == dlm ] whileTrue: [ + ans <- ans copyFrom: 2 to: ans size ]. + [ (ans at: ans size) == dlm ] whileTrue: [ + ans <- ans copyFrom: 1 to: ans size - 1 ]. + ^ans! + watch: aBlock + watch <- aBlock! + watchWith: arguments + " note that we are being watched " + text print. + watch value: arguments. + ^ self executeWith: arguments! +}! +{! +Number methods! + * 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 + " integer division, truncate towards negative infinity" + " see quo: " + ^ (self / value) floor! + < value + ^ (self maxgen: value) < (value maxgen: self)! + = value + ^ value isNumber + ifTrue: [ (self maxgen: value) = (value maxgen: self) ] + ifFalse: [ false ]! + \\ 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 ]! + isNumber + ^ true! + ln + ^ self asFloat ln! + log: value + ^ self ln / value ln! + maxgen: value + (self isNumber and: [ value isNumber ]) + ifFalse: [ ^ smalltalk error: + 'arithmetic on non-numbers' ]. + ^ (self generality > value generality) + ifTrue: [ self ] + ifFalse: [ value coerce: self ]! + 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 lower: self upper: value step: 1! + to: value by: step + ^ Interval lower: self upper: value step: step! + trucateTo: value + ^ (self / value) trucated * value! +}! +{! +Object methods! + = aValue + ^ self == aValue! + == aValue + ^ <21 self aValue>! + asString + ^ self printString! + assign: name value: val + ^ name assign: val! + 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>! + isFloat + ^ false! + isFraction + ^ false! + isInteger + ^ false! + isKindOf: aClass + self class upSuperclassChain: + [:x | (x == aClass) ifTrue: [ ^ true ] ]. + ^ false! + isLongInteger + ^ false! + isMemberOf: aClass + ^ self class == aClass! + isNil + ^ false! + isNumber + ^ false! + isShortInteger + ^ false! + message: m notRecognizedWithArguments: a + ^ smalltalk error: 'not recognized ', (self class printString), + ' ', (m printString)! + 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! + yourself + ^ self! + ~= aValue + ^ self ~~ aValue! + ~~ aValue + ^ (self == aValue) not! +}! +{! +Parser methods! +addArgName: name + (argNames includes: name) + ifTrue: [ self error: 'doubly defined argument name ']. + argNames size = 256 ifTrue: [ + self error: 'too many arguments' ]. + argNames <- argNames with: name! +addTempName: name + (((argNames includes: name) + or: [ instNames includes: name ] ) + or: [ tempNames includes: name ] ) + ifTrue: [ self error: 'doubly defined name ']. + tempNames size = 256 ifTrue: [ + self error: 'too many temporaries' ]. + tempNames <- tempNames with: name. + maxTemps <- maxTemps max: tempNames size! +arrayLiteral | node value | + tokenType isAlphabetic + ifTrue: [ node <- token asSymbol. self nextLex. ^ node ]. + tokenType = $( ifTrue: [ + self nextLex. value <- Array new: 0. + [ tokenType ~= $) ] + whileTrue: [ value <- value with: self arrayLiteral ]. + self nextLex. + ^ value ]. + ^ self readLiteral! +binaryContinuation: base | receiver name | + receiver <- self unaryContinuation: base. + [ self tokenIsBinary] + whileTrue: [ name <- token asSymbol. self nextLex. + receiver <- MessageNode new + receiver: receiver name: name arguments: + (List new addFirst: + (self unaryContinuation: self readTerm)) ]. + ^ receiver! +charIsSyntax: c + ^ ('.()[]#^$;' includes: c) or: [ c = $' ]! +currentChar + ^ text at: index ifAbsent: [ nil ]! +error: aString + ('compiler error ' , aString) print. + errBlock value! +getInstanceNames: aClass + | pos ans tmp | + pos <- aClass instanceSize. + pos > 256 ifTrue: [ "fix?" + self error: 'too many instance vars' ]. + ans <- Array new: pos. + aClass upSuperclassChain: [ :c | + (tmp <- c variables) notNil ifTrue: [ + tmp reverseDo: [ :v | + ans at: pos put: v asSymbol. "fix" + pos <- pos - 1 ] ] ]. + ^ans! +keywordContinuation: base | receiver name args | + receiver <- self binaryContinuation: base. + self tokenIsKeyword + ifFalse: [ ^ receiver ]. + name <- ''. + args <- List new. + [ self tokenIsKeyword ] + whileTrue: [ name <- name , token. self nextLex. + args addFirst: + (self binaryContinuation: self readTerm) ]. + ^ MessageNode new receiver: receiver name: name asSymbol arguments: args! +lexAlphaNumeric | cc start | + start <- index. + [ (cc <- self nextChar) isAlphaNumeric ] + whileTrue: [ nil ]. + " add any trailing colons " + cc = $: ifTrue: [ self nextChar ]. + token <- text copyFrom: start to: index - 1! +lexAlphabetic | cc start | + start <- index. + [ (cc <- self nextChar) isAlphabetic ] + whileTrue: [ nil ]. + " add any trailing colons " + cc = $: ifTrue: [ self nextChar ]. + token <- text copyFrom: start to: index - 1! +lexBinary | c d | + c <- self currentChar. + token <- c asString. + d <- self nextChar. + (self charIsSyntax: c) ifTrue: [ ^ token ]. + (((d asInteger <= 32 + or: [ d isDigit]) + or: [ d isAlphabetic ]) + or: [ self charIsSyntax: d]) + ifTrue: [ ^ token ]. + token <- token , d asString. + self nextChar! +lexInteger | start | + start <- index. + [ self nextChar isDigit ] + whileTrue: [ nil ]. + token <- text copyFrom: start to: index - 1! +nameNode: name + " make a new name node " + name == #super + ifTrue: [ ^ ArgumentNode new position: 0 ]. + (1 to: tempNames size) do: [:i | + (name == (tempNames at: i)) + ifTrue: [ ^ TemporaryNode new position: i ] ]. + (1 to: argNames size) do: [:i | + (name == (argNames at: i)) + ifTrue: [ ^ ArgumentNode new position: i ] ]. + (1 to: instNames size) do: [:i | + (name == (instNames at: i)) + ifTrue: [ ^ InstNode new position: i ] ]. + (#(nil true false) includes: name) ifFalse: [ + (symbols includesKey: name) ifTrue: [ + ^ ValueNode new name: name ] ]. + ^ LiteralNode new + value: (symbols at: name "fix" + ifAbsent: [ ^ self error: + 'unrecognized name:' , name printString ])! +nextChar + index <- index + 1. + ^ text at: index ifAbsent: [ $ ]! +nextLex + self skipBlanks. + tokenType <- self currentChar. + tokenType isNil " end of input " + ifTrue: [ tokenType <- $ . token <- nil. ^ nil ]. + tokenType isDigit ifTrue: [ ^ self lexInteger ]. + tokenType isAlphabetic ifTrue: [ ^ self lexAlphaNumeric ]. + ^ self lexBinary! +parse: c | encoder | + " note -- must call text:instanceVars: first " + errBlock <- [ ^ nil ]. + self nextLex. + encoder <- Encoder new. + encoder parser: self. + encoder name: self readMethodName. + self readMethodVariables. + self readBody compile: encoder block: false. + ^ encoder method: maxTemps class: c text: text! +parse: aString in: aClass + errBlock <- [ ^ nil ]. + self text: aString instanceVars: (self getInstanceNames: aClass). + ^ self parse: aClass! +peekChar + ^ text at: index + 1 ifAbsent: [ $ ]! +readArray | value | + self nextChar. self nextLex. value <- Array new: 0. + [ tokenType ~= $) ] + whileTrue: [ value <- value with: self arrayLiteral ]. + self nextLex. + ^ value! +readBlock | stmts saveTemps argCount tmpCount | + saveTemps <- tempNames. + self nextLex. + tokenType = $: + ifTrue: [ self readBlockArguments ]. + argCount <- tempNames size - saveTemps size. + tokenType = $| + ifTrue: [ self readBlockTemporaries ]. + tmpCount <- tempNames size - saveTemps size - argCount. + (stmts <- self readStatementList) isEmpty ifTrue: [ + stmts addFirst: (self nameNode: 'nil' asSymbol) ]. + tempNames <- saveTemps. + tokenType = $] + ifTrue: [ self nextLex. + ^ BlockNode new statements: stmts + temporaryLocation: saveTemps size + argumentCount: argCount + temporaryCount: tmpCount ] + ifFalse: [ self error: 'unterminated block']! +readBlockArguments + [ tokenType = $: ] + whileTrue: [ self currentChar isAlphabetic + ifFalse: [ self error: 'ill formed block argument']. + self nextLex. + self tokenIsName + ifTrue: [ self addTempName: token asSymbol ] + ifFalse: [ self error: 'invalid block argument list ']. + self nextLex ]. + tokenType = $| + ifTrue: [ self nextLex ] + ifFalse: [ self error: 'invalid block argument list ']! +readBlockTemporaries + tokenType = $| ifFalse: [ ^ nil ]. + self nextLex. + [ self tokenIsName ] + whileTrue: [ self addTempName: token asSymbol. self nextLex ]. + tokenType = $| + ifTrue: [ self nextLex ] + ifFalse: [ self error: 'illegal block temporary declaration']! +readBody + ^ BodyNode new statements: self readStatementList! +readCascade: base | node head list | + node <- self keywordContinuation: base. + tokenType = $; + ifTrue: [ head <- node basicAt: 1. "fix" + node basicAt: 1 put: nil. "fix" + list <- List new. + list addFirst: node. + [ tokenType = $; ] + whileTrue: [ self nextLex. + list addFirst: + (self keywordContinuation: nil ) ]. + node <- CascadeNode new head: head. + node list: list ]. + ^ node! +readExpression | node | + self tokenIsName ifFalse: [ ^ self readCascade: self readTerm ]. + node <- self nameNode: token asSymbol. self nextLex. + self tokenIsAssign + ifTrue: [ node assignable + ifFalse: [ self error: 'illegal assignment']. + self nextLex. + ^ AssignNode new target: node expression: self readExpression ]. + ^ self readCascade: node! +readIntOrFlo | lpart rpart denom d value | + tokenType isDigit ifFalse: [ self error: 'integer expected' ]. + lpart <- 0. + token do: [:c | lpart <- lpart * 10 + (c asInteger - 48) ]. + (self currentChar = $. and: [self peekChar isDigit]) ifTrue: [ + rpart <- 0. + denom <- 1. + [ (d <- self nextChar) isDigit ] whileTrue: [ + rpart <- rpart * 10 + (d asInteger - 48). + denom <- denom * 10 ]. + value <- lpart asFloat + (rpart asFloat / denom asFloat) ] + ifFalse: [ + value <- lpart ]. + self nextLex. + ^ value! +readInteger | value | + tokenType isDigit ifFalse: [ self error: 'integer expected' ]. + value <- 0. + token do: [:c | value <- value * 10 + (c asInteger - 48) ]. + self nextLex. + ^ value! +readLiteral | node | + tokenType = $$ + ifTrue: [ node <- self currentChar. + self nextChar. self nextLex. ^ node ]. + tokenType isDigit + ifTrue: [ ^ self readIntOrFlo ]. + token = '-' + ifTrue: [ self nextLex. ^ self readIntOrFlo negated ]. + tokenType = $' + ifTrue: [ ^ self readString ]. + tokenType = $# + ifTrue: [ ^ self readSymbol ]. + self error: 'invalid literal:' , token! +readMethodName | name | + self tokenIsName " unary method " + ifTrue: [ name <- token. self nextLex. ^ name ]. + self tokenIsBinary " binary method " + ifTrue: [ name <- token. self nextLex. + self tokenIsName + ifFalse: [ self error: 'missing argument']. + self addArgName: token asSymbol. + self nextLex. ^ name ]. + self tokenIsKeyword + ifFalse: [ self error: 'invalid method header']. + name <- ''. + [ self tokenIsKeyword ] + whileTrue: [ name <- name , token. self nextLex. + self tokenIsName + ifFalse: [ self error: 'missing argument']. + self addArgName: token asSymbol. + self nextLex ]. + ^ name! +readMethodVariables + tokenType = $| ifFalse: [ ^ nil ]. + self nextLex. + [ self tokenIsName ] + whileTrue: [ self addTempName: token asSymbol. self nextLex ]. + tokenType = $| + ifTrue: [ self nextLex ] + ifFalse: [ self error: 'illegal method variable declaration']! +readPrimitive | num args | + self nextLex. + num <- self readInteger. + args <- List new. + [ tokenType ~= $> ] + whileTrue: [ args addFirst: self readTerm ]. + self nextLex. + ^ PrimitiveNode new number: num arguments: args! +readStatement + tokenType = $^ + ifTrue: [ self nextLex. + ^ ReturnNode new expression: self readExpression ]. + ^ self readExpression! +readStatementList | list | + list <- List new. + (token isNil or: [ tokenType = $] ] ) + ifTrue: [ ^ list ]. + [ list addFirst: self readStatement. + tokenType notNil and: [ tokenType = $. ] ] + whileTrue: [ self nextLex. + (token isNil or: [ tokenType = $] ] ) + ifTrue: [ ^ list ] ]. + ^ list! +readString | first last cc | + first <- index. + [ cc <- self currentChar. + cc isNil ifTrue: [ self error: 'unterminated string constant']. + cc ~= $' ] whileTrue: [ index <- index + 1 ]. + last <- index - 1. + self nextChar = $' + ifTrue: [ self nextChar. + ^ (text copyFrom: first to: index - 2) , self readString ]. + self nextLex. + ^ text copyFrom: first to: last! +readSymbol | cc tmp | + cc <- self currentChar. + (cc isNil or: [ cc asInteger <= 32 ]) + ifTrue: [ self error: 'invalid symbol']. + cc = $( ifTrue: [ ^ self readArray ]. + cc = $' ifTrue: [ + self nextChar. + ^ self readString asSymbol ]. + (self charIsSyntax: cc) + ifTrue: [ self error: 'invalid symbol']. + self nextLex. + self tokenIsKeyword ifTrue: [ + [ (cc <- self currentChar) notNil and: + [ cc isAlphabetic ] ] whileTrue: [ + tmp <- token. + self nextLex. + self tokenIsKeyword ifTrue: [ + token <- tmp , token ] + ifFalse: [ + self error: 'invalid keyword' ] ] ]. + cc <- token asSymbol. self nextLex. + ^ cc! +readTerm | node | + token isNil + ifTrue: [ self error: 'unexpected end of input' ]. + tokenType = $( + ifTrue: [ self nextLex. node <- self readExpression. + tokenType = $) + ifFalse: [ self error: 'unbalanced parenthesis' ]. + self nextLex. ^ node ]. + tokenType = $[ ifTrue: [ ^ self readBlock ]. + tokenType = $< ifTrue: [ ^ self readPrimitive ]. + self tokenIsName + ifTrue: [ node <- self nameNode: token asSymbol. + self nextLex. ^ node ]. + ^ LiteralNode new value: self readLiteral! +skipBlanks | cc | + [ cc <- self currentChar. + cc notNil and: [ cc asInteger <= 32 ] ] "fix" + whileTrue: [ index <- index + 1 ]. + (cc notNil and: [ cc = $" ] ) + ifTrue: [ self skipComment ]! +skipComment | cc | + [ index <- index + 1. + cc <- self currentChar. + cc isNil + ifTrue: [ ^ self error: 'unterminated comment']. + cc ~= $" ] whileTrue: [ nil ]. + self nextChar. self skipBlanks! +text: aString instanceVars: anArray + text <- aString. + index <- 1. + argNames <- Array new: 1. + argNames at: 1 put: #self. + instNames <- anArray. + tempNames <- Array new: 0. + maxTemps <- 0! +tokenIsAssign + (token isKindOf: String) ifFalse: [ ^ false ]. + ^ token = ':=' or: [ token = '<-' ]! +tokenIsBinary + (((token isNil + or: [ self tokenIsName]) + or: [ self tokenIsKeyword]) + or: [ self charIsSyntax: tokenType ]) ifTrue: [ ^ false ]. + ^ true! +tokenIsKeyword + tokenType isAlphabetic ifFalse: [ ^ false ]. + ^ (token at: token size) = $:! +tokenIsName + tokenType isAlphabetic ifFalse: [ ^ false ]. + ^ (token at: token size) isAlphaNumeric! +unaryContinuation: base | receiver | + receiver <- base. + [ self tokenIsName ] + whileTrue: [ receiver <- MessageNode new + receiver: receiver name: token asSymbol + arguments: (List new). + self nextLex ]. + ^ receiver! +}! +{! +ParserNode methods! +assignable + ^ false! +isBlock + ^ false! +isSuper + ^ false! +}! +{! +PrimitiveNode methods! +compile: encoder block: inBlock + arguments reverseDo: [ :a | a compile: encoder block: inBlock ]. + encoder genHigh: 13 low: arguments size. + encoder genCode: number! +number: n arguments: a + number <- n. + arguments <- a.! +}! +{! +ProcessMeta methods! + context: cObj startAt: sInt + ^ self new context: cObj startAt: sInt! + new + | sArray | + sArray <- Array new: 50. + sArray at: 2 put: 0. "previous link" + sArray at: 4 put: 1. "return point" + sArray at: 6 put: 1. "bytecode counter" + ^ self basicNew + stack: sArray + stackTop: 10 + linkPointer: 2! +}! +{! +Process methods! + context + ^ stack at: 3! + context: ctx + stack at: 3 put: ctx.! + context: cObj startAt: sInt + stack at: 3 put: cObj. + stack at: 6 put: sInt "starting bytecode value"! + execute + " execute for time slice, terminating if all over " + (overflowed isNil and: [(stack size > 8192)]) + ifTrue: [ + overflowed <- true. + smalltalk error: 'process stack overflowed']. + <19 self> ifTrue: [] ifFalse: [ self terminate ].! + method: x + stack at: 5 put: x.! + resume + " resume current process " + scheduler addProcess: self! + stack: sArray stackTop: sInt linkPointer: lInt + stack <- sArray. + stackTop <- sInt. + linkPointer <- lInt! + startAt: x + stack at: 6 put: x. "starting bytecode value"! + terminate + " kill current process " + scheduler removeProcess: self. scheduler yield.! + trace | more link m r s | + " first yield scheduler, forceing store of linkPointer" + overflowed notNil ifTrue: [ + ^ self ]. + scheduler yield. + more <- 8. + link <- linkPointer. + link <- stack at: link+1. + " then trace back chain " + [ more > 0 and: [link ~= 0] ] 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 ]. + more <- more - 1. + link <- stack at: link ]! +}! +{! +Random methods! + 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>! +}! +{! +ReturnNode methods! +compile: encoder block: inBlock + expression compile: encoder block: inBlock. + inBlock ifTrue: [ + encoder genHigh: 5 low: 4. "ldc thisContext" + encoder genHigh: 8 low: 1. "mark" + encoder genHigh: 9 low: (encoder genLiteral: #blockReturn). + encoder genHigh: 15 low: 5 ]. "pop" + encoder genHigh: 15 low: 2 "rtnt"! +expression: e + expression <- e! +}! +{! +SchedulerMeta methods! + new + ^ self basicNew + notdone: true + processList: Set new + currentProcess: nil! +}! +{! +Scheduler methods! + 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! + initialize | string | + <2>. + string <- smalltalk getPrompt: '> '. + string isNil ifTrue: [ + '''EOF''' logChunk. + notdone <- false ] + ifFalse: [ + (string size > 0) ifTrue: [ + string logChunk. + echoInput ifTrue: [ + string print ]. + [ string value print ] fork ] ]! + notdone: nBool processList: pSet currentProcess: cProc + notdone <- nBool. + processList <- pSet. + currentProcess <- cProc! + 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>! +}! +{! +SemaphoreMeta methods! + new + ^ self basicNew + count: 0 + processList: List new! +}! +{! +Semaphore methods! + count: cInt processList: pList + count <- cInt. + processList <- pList! + 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]! +}! +{! +Set methods! + add: value + (self includes: value) + ifFalse: [ self addFirst: value ]! +}! +{! +Smalltalk methods! + echo + " enable - disable echo input " + echoInput <- echoInput not! + error: aString + " print a message, and remove current process " + stderr print: aString. + scheduler currentProcess yourself; trace; terminate! + getPrompt: aString + stdout printNoReturn: aString. + ^ stdin getString! + inquire: aString | response | + response <- self getPrompt: aString. + response isNil + ifTrue: [ ^ false ]. + ^ 'Yy' includes: (response at: 1 ifAbsent: [])! + perform: message withArguments: args + ^ self perform: message withArguments: args + ifError: [ self error: 'cant perform' ]! + 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! + 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 name: name open: 'w') + yourself; + saveImage; + close ]! + shutDown + files do: [ :e | + e notNil ifTrue: [ + (#('stdin' 'stdout' 'stderr') includes: e name) ifFalse: [ + e close ] ] ]! + watch + ^ <5>! +}! +{! +StringMeta methods! + basicNew: size + ^ self primBytes: size + 1! + new: size + ^ self primBytes: size + 1! +}! +{! +String methods! + , value + (value isMemberOf: String) + ifTrue: [ ^ <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: 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 ]! + asString + ^ self! + asSymbol + ^ <83 self>! + 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' ]! + copy + " catenation makes copy automatically " + ^ '',self! + copyFrom: position1 to: position2 + ^ <33 self position1 position2>! + edit | file text | + (file <- File new) + yourself; + scratchFile; + open: 'w'; + print: self; + close. + (editor, ' ', file name) unixCommand. + file open: 'r'. + text <- file asString. + file yourself; close; delete. + ^ text! + execute | meth | + " execute self as body of a method " + meth <- Parser new parse: 'DoIt ' , self in: UndefinedObject. + ^ meth notNil ifTrue: [ + meth executeWith: (Array new: 1) ] "nil" + ifFalse: [ + nil ]! + hash + ^ <82 self>! + print + stdout print: self! + printString + ^ '''' , self, ''''! + size + ^ <81 self>! + trimmed | dlm ans | + dlm <- 10 asCharacter. + (ans <- self) isEmpty ifTrue: [ + ^ans ]. + [ (ans at: 1) == dlm ] whileTrue: [ + ans <- ans copyFrom: 2 to: ans size. + ans isEmpty ifTrue: [ + ^ ans ] ]. + [ (ans at: ans size) == dlm ] whileTrue: [ + ans <- ans copyFrom: 1 to: ans size - 1. + ans isEmpty ifTrue: [ + ^ ans ] ]. + ^ans! + unixCommand + ^ <88 self>! + value + " evaluate self as an expression " + ^ ( '^ [ ', self, ' ] value' ) execute! + 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! +}! +{! +Switch methods! + else: block + notdone ifTrue: [ notdone <- false. block value ]! + ifMatch: key do: block + (notdone and: [ const = key ]) + ifTrue: [ notdone <- false. block value ]! + key: value + const <- value. + notdone <- true.! +}! +{! +Symbol methods! + apply: args + ^ self apply: args ifError: [ 'does not apply' ]! + apply: args ifError: aBlock + ^ smalltalk perform: self withArguments: args ifError: aBlock! + asString + " catenation makes string and copy automatically " + ^ <24 self ''>! + asSymbol + ^ self! + assign: value + <27 self value>. ^ value! + copy + ^ self! + printString + ^ '#' , self asString! + respondsTo + ^ classes inject: Set new + into: [:x :y | ((y methodNamed: self) notNil) + ifTrue: [ x add: y]. x]! + stringHash + ^ <82 self>! + value + ^ <87 self>! +}! +{! +SymbolTable methods! + hash: aKey + ^ 3 * ((aKey stringHash) rem: ((hashTable size) quo: 3))! + printString + ^ self class printString , ' (...)'! +}! +{! +TemporaryNode methods! +assign: encoder + encoder genHigh: 7 low: position - 1! +assignable + ^ true! +compile: encoder block: inBlock + encoder genHigh: 3 low: position - 1! +position: p + position <- p! +}! +{! +True methods! + ifTrue: trueBlock ifFalse: falseBlock + ^ trueBlock value! + not + ^ false! + printString + ^ 'true'! + xor: aBoolean + ^ aBoolean not! +}! +{! +UndefinedObject methods! + initBot | aBlock saveFile saveAns | + " initialize the initial object image " + aBlock <- [ files do: [:f | f notNil ifTrue: [ f open ]]. + echoInput <- false. + scheduler run. + scheduler <- Scheduler new. + systemProcess <- aBlock newProcess ]. + scheduler <- Scheduler new. + systemProcess <- aBlock newProcess. + saveFile <- File + name: 'systemImage' + open: 'w'. + saveAns <- saveFile saveImage. + saveFile close. + stdout + yourself; + printNoReturn: 'saveImage: '; + print: saveAns printString! + initMid + " initialize the initial object image " + | metaclasses key | + metaclasses <- Dictionary new. + symbols binaryDo: [ :x :y | + (y class == Metaclass) ifTrue: [ + key <- (x asString copyFrom: 1 to: x basicSize - 5) asSymbol. + metaclasses at: key put: y ] ]. + classes <- Dictionary new. + symbols binaryDo: [ :x :y | + ((metaclasses at: x ifAbsent: [nil]) == y class) ifTrue: [ + classes at: x put: y ] ]! + initTop + " initialize the initial object image " + files <- Array new: 15. + (stdin <- File name: 'stdin' mode: 'r') open. + (stdout <- File name: 'stdout' mode: 'w') open. + (stderr <- File name: 'stderr' mode: 'w') open. + editor <- 'vi'! + initialize + " initialize the initial object image " + smalltalk <- Smalltalk new. + self initTop. + self initMid. + self initBot! + isNil + ^ true! + notNil + ^ false! + printString + ^ 'nil'! +}! +{! +ValueNode methods! +assign: encoder + "encoder genHigh: 7 low: position - 1" + self halt! +assign: encoder value: expression block: inBlock "fix" + encoder genHigh: 2 low: 0. "self" + encoder genHigh: 4 low: (encoder genLiteral: name). + expression compile: encoder block: inBlock. + encoder genHigh: 8 low: 3. "mark" + encoder genHigh: 9 low: (encoder genLiteral: #assign:value:)! +assignable + ^ true! +compile: encoder block: inBlock "fix" + encoder genHigh: 4 low: (encoder genLiteral: name). + encoder genHigh: 10 low: 2 "value"! +name: n + name <- n! +}! diff --git a/pdst.c b/pdst.c new file mode 100644 index 0000000..0831cd4 --- /dev/null +++ b/pdst.c @@ -0,0 +1,4784 @@ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define streq(a,b) (strcmp(a,b) == 0) + +typedef void* addr; + +typedef enum {false,true} bool; + +typedef unsigned char byte; + +typedef unsigned short hwrd; + +typedef unsigned int word; + +/* +Some kinds of objects are small enough and used often enough that it can +be worthwhile to tightly encode the entire representation (both a class +reference and a value). We refer to them using "encoded values" and +treat a subset of the host's signed integer range this way. +*/ +typedef struct { + bool flg: 1; /* true */ + int dat: 31; +} encVal; + +inline encVal encValueOf(int x) +{ + encVal ans = {true,x}; + return(ans); +} + +inline int intValueOf(encVal x) +{ + return(x.dat); +} + +/* +The safest and easiest way to find out if a value can be embedded +(encoded) without losing information is to try it and test whether or +not it works. +*/ +inline bool canEmbed(int x) +{ + return(intValueOf(encValueOf(x)) == x); +} + +/* +Objects which are not referenced using encoded values must be referenced +by other means. We refer to them using "encoded pointers" and treat the +datum as an index into an "object table". +*/ +typedef struct { + bool flg: 1; /* false */ + word dat: 31; +} encPtr; + +inline encPtr encIndexOf(word x) +{ + encPtr ans = {false,x}; + return(ans); +} + +inline word oteIndexOf(encPtr x) +{ + return(x.dat); +} + +/* +Any part of an object representation that isn't kept in either an +encoded value or an object table entry is kept elsewhere in the host's +main memory. We call that part of the object "von Neumann space" and +keep a pointer to it. Mapping between field counts and address units is +done using a scale factor expressed as a shift count. We distinguish +between objects whose fields do or don't contain object references. We +distinguish between objects whose fields have or haven't been traced. +We call objects which might not be transitively accessible from any root +object(s) "volatile". Within the object table, we distinguish between +entries that are or aren't available. +*/ +typedef struct { + addr vnspc; + word shift: 3; + bool orefs: 1; + bool mrked: 1; + bool voltl: 1; + bool avail: 1; + word :25; +} otbEnt; + +/* +We keep track of how large a given von Neumann space is in address +units. This "space count" is used along with the scale factor to derive +a field count, among other things. We also need to keep track of the +class of which a given object is an instance. +*/ +typedef struct { + word spcct; + encPtr class; +} ot2Ent; + +#define otbLob 0 +#define otbHib 65535 +#define otbDom ((otbHib + 1) - otbLob) + +otbEnt* objTbl = NULL; +/*otbEnt objTbl[otbDom];*/ + +ot2Ent* ob2Tbl = NULL; +/*ot2Ent ob2Tbl[otbDom];*/ + +/* +An object reference is either an encoded value or an encoded pointer. +We distinguish one from the other by means of the flag (q.v.) defined in +both. N.B.: This kind of overlay definition would be safer and easier +both to specify and to use if compilers would pack a 1-bit flag and a +-bit union (resp. field) into a -bit struct. +*/ +typedef union { + encVal val; + encPtr ptr; +} objRef; + +inline bool isValue(objRef x) +{ + return(x.val.flg == true); +} + +inline bool isIndex(objRef x) +{ + return(x.ptr.flg == false); +} + +inline bool ptrEq(objRef x, objRef y) +{ + return(x.ptr.flg == y.ptr.flg && x.ptr.dat == y.ptr.dat); +} + +inline bool ptrNe(objRef x, objRef y) +{ + return(x.ptr.flg != y.ptr.flg || x.ptr.dat != y.ptr.dat); +} + +inline addr addressOf(encPtr x) +{ + return(objTbl[oteIndexOf(x)].vnspc); +} + +inline void addressOfPut(encPtr x, addr v) +{ + objTbl[oteIndexOf(x)].vnspc = v; +} + +inline word scaleOf(encPtr x) +{ + return(objTbl[oteIndexOf(x)].shift); +} + +inline void scaleOfPut(encPtr x, word v) +{ + objTbl[oteIndexOf(x)].shift = v; +} + +inline bool isObjRefs(encPtr x) +{ + return(objTbl[oteIndexOf(x)].orefs == true); +} + +inline void isObjRefsPut(encPtr x, bool v) +{ + objTbl[oteIndexOf(x)].orefs = v; +} + +inline bool isMarked(encPtr x) +{ + return(objTbl[oteIndexOf(x)].mrked == true); +} + +inline void isMarkedPut(encPtr x, bool v) +{ + objTbl[oteIndexOf(x)].mrked = v; +} + +inline bool isVolatile(encPtr x) +{ + return(objTbl[oteIndexOf(x)].voltl == true); +} + +inline void isVolatilePut(encPtr x, bool v) +{ + objTbl[oteIndexOf(x)].voltl = v; +} + +inline bool isAvail(encPtr x) +{ + return(objTbl[oteIndexOf(x)].avail == true); +} + +inline void isAvailPut(encPtr x, bool v) +{ + objTbl[oteIndexOf(x)].avail = v; +} + +inline word spaceOf(encPtr x) +{ + return(ob2Tbl[oteIndexOf(x)].spcct); +} + +inline void spaceOfPut(encPtr x, word v) +{ + ob2Tbl[oteIndexOf(x)].spcct = v; +} + +inline encPtr classOf(encPtr x) +{ + return(ob2Tbl[oteIndexOf(x)].class); +} + +inline void classOfPut(encPtr x, encPtr v) +{ +#if 0 + assert(isIndex(v)); +#endif + isVolatilePut(v, false); + ob2Tbl[oteIndexOf(x)].class = v; +} + +inline word countOf(encPtr x) +{ + return(spaceOf(x) >> scaleOf(x)); +} + +inline objRef orefOf(encPtr x, word i) +{ + return(((objRef*) objTbl[oteIndexOf(x)].vnspc) [i-1]); +} + +inline void orefOfPut(encPtr x, word i, objRef v) +{ + if(isIndex(v)) + isVolatilePut(v.ptr, false); + ((objRef*) objTbl[oteIndexOf(x)].vnspc) [i-1] = v; +} + +inline byte byteOf(encPtr x, word i) +{ + return(((byte*) objTbl[oteIndexOf(x)].vnspc) [i-1]); +} + +inline void byteOfPut(encPtr x, word i, byte v) +{ + ((byte*) objTbl[oteIndexOf(x)].vnspc) [i-1] = v; +} + +inline hwrd hwrdOf(encPtr x, word i) +{ + return(((hwrd*) objTbl[oteIndexOf(x)].vnspc) [i-1]); +} + +inline void hwrdOfPut(encPtr x, word i, hwrd v) +{ + ((hwrd*) objTbl[oteIndexOf(x)].vnspc) [i-1] = v; +} + +inline word wordOf(encPtr x, word i) +{ + return(((word*) objTbl[oteIndexOf(x)].vnspc) [i-1]); +} + +inline void wordOfPut(encPtr x, word i, word v) +{ + ((word*) objTbl[oteIndexOf(x)].vnspc) [i-1] = v; +} + +#define pointerList encIndexOf(0) + +int availCount(void) +{ + int ans = 0; + encPtr tmp = classOf(pointerList); + while(oteIndexOf(tmp) != 0) { + ans++; + tmp = classOf(tmp); + } + return(ans); +} + +void freePointer(encPtr x) +{ +#if 0 + assert(false); +#endif + scaleOfPut(x,0); + isObjRefsPut(x,false); + isMarkedPut(x,false); + isVolatilePut(x,false); + isAvailPut(x,true); + classOfPut(x,classOf(pointerList)); + classOfPut(pointerList,x); +} + +void freeStorage(addr x) +{ +#if 0 + assert(false); +#endif + assert(x != NULL); + free(x); +} + +void visit(objRef x) +{ + if(isIndex(x)) { + if(isMarked(x.ptr) == false) { + /* then it's the first time we've visited it, so: */ + isMarkedPut(x.ptr, true); + visit((objRef) classOf(x.ptr)); + if(isObjRefs(x.ptr)) { + objRef* f = addressOf(x.ptr); + objRef* p = (void*)f + spaceOf(x.ptr); + while(p != f) + visit(*--p); + } + } + } +} + +extern encPtr symbols; + +/* +It's safe to ignore volatile objects only when all necessary object +references are stored in object memory. Currently, that's the case +only upon a successful return from the interpreter. In operation, the +interpreter does many stores directly into host memory (as opposed to +indirectly via the object table). As a result, volatile objects will +remain flagged as such. Tracing them ensures that they (and their +referents) get kept. +*/ +void reclaim(bool all) +{ + word ord; + encPtr ptr; + visit((objRef) symbols); + if(all) + for(ord = otbLob; ord <= otbHib; ord++) { + ptr = encIndexOf(ord); + if(isVolatile(ptr)) + visit((objRef) ptr); + } + classOfPut(pointerList,encIndexOf(0)); + for(ord = otbHib; ord > otbLob; ord--) { /*fix*/ + ptr = encIndexOf(ord); + if(isAvail(ptr)) { + freePointer(ptr); + continue; + } + if(isMarked(ptr)) { + if(!all) /*stored but not by orefOfPut...*/ + isVolatilePut(ptr,false); + isMarkedPut(ptr,false); + continue; + } + if(spaceOf(ptr)) { + freeStorage(addressOf(ptr)); + addressOfPut(ptr,0); + spaceOfPut(ptr,0); + } + freePointer(ptr); + } +} + +encPtr newPointer(void) +{ + encPtr ans = classOf(pointerList); + if(oteIndexOf(ans) == 0) { + reclaim(true); + ans = classOf(pointerList); + } + assert(oteIndexOf(ans) != 0); + classOfPut(pointerList,classOf(ans)); +#if 0 + classOfPut(ans,encIndexOf(0)); +#endif + isVolatilePut(ans, true); + isAvailPut(ans, false); + return(ans); +} + +addr newStorage(word bytes) +{ + addr ans; + if(bytes) { + ans = calloc(bytes,sizeof(byte)); + assert(ans != NULL); + } + else + ans = NULL; + return(ans); +} + +void coldObjectTable(void) +{ + word i; + objTbl = calloc(otbDom,sizeof(otbEnt)); + assert(objTbl != NULL); + ob2Tbl = calloc(otbDom,sizeof(ot2Ent)); + assert(ob2Tbl != NULL); + for(i=otbLob; i != otbHib; i++) { + classOfPut(encIndexOf(i),encIndexOf(i+1)); + isAvailPut(encIndexOf(i+1), true); + } +} + +void warmObjectTableOne(void) +{ + word i; + objTbl = calloc(otbDom,sizeof(otbEnt)); + assert(objTbl != NULL); + ob2Tbl = calloc(otbDom,sizeof(ot2Ent)); + assert(ob2Tbl != NULL); + for(i=otbLob; i != otbHib; i++) + isAvailPut(encIndexOf(i+1), true); +} + +void warmObjectTableTwo(void) +{ + word i; + classOfPut(pointerList,encIndexOf(0)); + for(i = otbHib; i > otbLob; i--) /*fix*/ + if(isAvail(encIndexOf(i))) + freePointer(encIndexOf(i)); +} + +extern encPtr nilObj; + +encPtr allocOrefObj(word n) +{ + encPtr ptr = newPointer(); + word num = n << 2; /*fix*/ + addr mem = newStorage(num); + addressOfPut(ptr,mem); + scaleOfPut(ptr,2); /*fix*/ + isObjRefsPut(ptr,true); + spaceOfPut(ptr,num); + classOfPut(ptr,nilObj); + while(n--) + *((encPtr*)mem)++ = nilObj; + return(ptr); +} + +encPtr allocByteObj(word n) +{ + encPtr ptr = newPointer(); + word num = n << 0; /*fix*/ + addr mem = newStorage(num); + addressOfPut(ptr,mem); + scaleOfPut(ptr,0); /*fix*/ + isObjRefsPut(ptr,false); + spaceOfPut(ptr,num); + classOfPut(ptr,nilObj); + return(ptr); +} + +encPtr allocHWrdObj(word n) +{ + encPtr ptr = newPointer(); + word num = n << 1; /*fix*/ + addr mem = newStorage(num); + addressOfPut(ptr,mem); + scaleOfPut(ptr,1); /*fix*/ + isObjRefsPut(ptr,false); + spaceOfPut(ptr,num); + classOfPut(ptr,nilObj); + return(ptr); +} + +encPtr allocWordObj(word n) +{ + encPtr ptr = newPointer(); + word num = n << 2; /*fix*/ + addr mem = newStorage(num); + addressOfPut(ptr,mem); + scaleOfPut(ptr,2); /*fix*/ + isObjRefsPut(ptr,false); + spaceOfPut(ptr,num); + classOfPut(ptr,nilObj); + return(ptr); +} + +encPtr allocZStrObj(char* zstr) +{ + encPtr ptr = newPointer(); + word num = strlen(zstr) + 1; + addr mem = newStorage(num); + addressOfPut(ptr,mem); + scaleOfPut(ptr,0); /*fix*/ + isObjRefsPut(ptr,false); + spaceOfPut(ptr,num); + classOfPut(ptr,nilObj); + (void) strcpy(addressOf(ptr), zstr); + return(ptr); +} + +#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) intValueOf(orefOf(x, stackSizeInMethod).val) +#define methodTempSize(x) intValueOf(orefOf(x, temporarySizeInMethod).val) + +#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 + +encPtr nilObj = {false,1}; /* pseudo variable nil */ + +encPtr trueObj = {false,2}; /* pseudo variable true */ +encPtr falseObj = {false,3}; /* pseudo variable false */ + +#if 0 +encPtr hashTable = {false,4}; +#endif +encPtr symbols = {false,5}; +encPtr classes = {false,1}; + +encPtr unSyms[16] = {}; +encPtr binSyms[32] = {}; + +#define globalValue(s) nameTableLookup(symbols, s) + +void sysError(char*, char*); + +encPtr newLink(encPtr key, encPtr value); + +void nameTableInsert(encPtr dict, word hash, encPtr key, encPtr value) +{ + encPtr table, + link, + nwLink, + nextLink, + tablentry; + + /* first get the hash table */ + table = orefOf(dict, 1).ptr; + + if (countOf(table) < 3) + sysError("attempt to insert into", "too small name table"); + else { + hash = 3 * (hash % (countOf(table) / 3)); + assert(hash <= countOf(table)-3); + tablentry = orefOf(table, hash + 1).ptr; + if (ptrEq((objRef) tablentry, (objRef) nilObj) || ptrEq((objRef) tablentry, (objRef) key)) { + orefOfPut(table, hash + 1, (objRef) key); + orefOfPut(table, hash + 2, (objRef) value); + } else { + nwLink = newLink(key, value); + link = orefOf(table, hash + 3).ptr; + if (ptrEq((objRef) link, (objRef) nilObj)) { + orefOfPut(table, hash + 3, (objRef) nwLink); + } else + while (1) + if (ptrEq(orefOf(link, 1), (objRef) key)) { + /* get rid of unwanted Link */ + isVolatilePut(nwLink, false); + orefOfPut(link, 2, (objRef) value); + break; + } else if (ptrEq((objRef) (nextLink = orefOf(link, 3).ptr), (objRef) nilObj)) { + orefOfPut(link, 3, (objRef) nwLink); + break; + } else + link = nextLink; + } + } +} + +encPtr hashEachElement(encPtr dict, word hash, int(*fun)(encPtr)) +{ + encPtr table, + key, + value, + link; + encPtr *hp; + word tablesize; + + table = orefOf(dict, 1).ptr; + + /* now see if table is valid */ + if ((tablesize = countOf(table)) < 3) + sysError("system error", "lookup on null table"); + else { + hash = 1 + (3 * (hash % (tablesize / 3))); + assert(hash <= tablesize-2); + hp = (encPtr*)addressOf(table) + (hash - 1); + key = *hp++; /* table at: hash */ + value = *hp++; /* table at: hash + 1 */ + if (ptrNe((objRef) key, (objRef) nilObj) && (*fun) (key)) + return value; + for (link = *hp; ptrNe((objRef) link, (objRef) nilObj); link = *hp) { + hp = addressOf(link); + key = *hp++; /* link at: 1 */ + value = *hp++; /* link at: 2 */ + if (ptrNe((objRef) key, (objRef) nilObj) && (*fun) (key)) + return value; + } + } + return nilObj; +} + +int strHash(char* str) +{ + int hash; + 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; +} + +word symHash(encPtr sym) +{ + return(oteIndexOf(sym)); +} + +char* charBuffer = 0; +encPtr objBuffer = {true,0}; + +int strTest(encPtr key) +{ + if (addressOf(key) && streq(addressOf(key), charBuffer)) { + objBuffer = key; + return 1; + } + return 0; +} + +encPtr globalKey(char* str) +{ + charBuffer = str; + objBuffer = nilObj; + (void) hashEachElement(symbols, strHash(str), strTest); + return objBuffer; +} + +encPtr nameTableLookup(encPtr dict, char* str) +{ + charBuffer = str; + return hashEachElement(dict, strHash(str), strTest); +} + +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 +}; + +encPtr newSymbol(char* str); + +void initCommonSymbols(void) +{ + int i; + + assert(ptrEq((objRef)nilObj,(objRef)globalValue("nil"))); + + assert(ptrEq((objRef)trueObj,(objRef)globalValue("true"))); + assert(ptrEq((objRef)falseObj,(objRef)globalValue("false"))); + +#if 0 + assert(ptrEq(hashTable,globalValue("hashTable"))); +#endif + assert(ptrEq((objRef)symbols,(objRef)globalValue("symbols"))); + classes = globalValue("classes"); + + for(i = 0; i != 16; i++) + unSyms[i] = nilObj; + for (i = 0; unStrs[i]; i++) + unSyms[i] = newSymbol(unStrs[i]); + for(i = 0; i != 32; i++) + binSyms[i] = nilObj; + for (i = 0; binStrs[i]; i++) + binSyms[i] = newSymbol(binStrs[i]); +} + +encPtr arrayClass = {false,1}; /* the class Array */ +encPtr intClass = {false,1}; /* the class Integer */ +encPtr stringClass = {false,1}; /* the class String */ +encPtr symbolClass = {false,1}; /* the class Symbol */ + +double floatValue(encPtr o) +{ + double d; + + (void) memcpy(&d, addressOf(o), sizeof(double)); + return d; +} + +encPtr newArray(int size) +{ + encPtr newObj; + + newObj = allocOrefObj(size); + if (ptrEq((objRef) arrayClass, (objRef) nilObj)) + arrayClass = globalValue("Array"); + classOfPut(newObj, arrayClass); + return newObj; +} + +encPtr newBlock(void) +{ + encPtr newObj; + + newObj = allocOrefObj(blockSize); + classOfPut(newObj, globalValue("Block")); + return newObj; +} + +encPtr newByteArray(int size) +{ + encPtr newobj; + + newobj = allocByteObj(size); + classOfPut(newobj, globalValue("ByteArray")); + return newobj; +} + +encPtr newChar(int value) +{ + encPtr newobj; + + newobj = allocOrefObj(1); + orefOfPut(newobj, 1, (objRef) encValueOf(value)); + classOfPut(newobj, globalValue("Char")); + return (newobj); +} + +encPtr newClass(char* name) +{ + encPtr newMeta; + encPtr newInst; + char* metaName; + encPtr nameMeta; + encPtr nameInst; + + newMeta = allocOrefObj(classSize); + classOfPut(newMeta, globalValue("Metaclass")); + orefOfPut(newMeta, sizeInClass, (objRef) encValueOf(classSize)); + newInst = allocOrefObj(classSize); + classOfPut(newInst, newMeta); + + metaName = newStorage(strlen(name) + 4 + 1); + (void) strcpy(metaName, name); + (void) strcat(metaName, "Meta"); + + /* now make names */ + nameMeta = newSymbol(metaName); + orefOfPut(newMeta, nameInClass, (objRef) nameMeta); + nameInst = newSymbol(name); + orefOfPut(newInst, nameInClass, (objRef) nameInst); + + /* now put in global symbols and classes tables */ + nameTableInsert(symbols, strHash(metaName), nameMeta, newMeta); + nameTableInsert(symbols, strHash(name), nameInst, newInst); + if(ptrNe((objRef) classes, (objRef) nilObj)) { + nameTableInsert(classes, symHash(nameMeta), nameMeta, newMeta); + nameTableInsert(classes, symHash(nameInst), nameInst, newInst); + } + + freeStorage(metaName); + + return(newInst); +} + +encPtr newContext(int link, encPtr method, encPtr args, encPtr temp) +{ + encPtr newObj; + + newObj = allocOrefObj(contextSize); + classOfPut(newObj, globalValue("Context")); + orefOfPut(newObj, linkPtrInContext, (objRef) encValueOf(link)); + orefOfPut(newObj, methodInContext, (objRef) method); + orefOfPut(newObj, argumentsInContext, (objRef) args); + orefOfPut(newObj, temporariesInContext, (objRef) temp); + return newObj; +} + +encPtr newDictionary(int size) +{ + encPtr newObj; + + newObj = allocOrefObj(1); + classOfPut(newObj, globalValue("Dictionary")); + orefOfPut(newObj, 1, (objRef) newArray(size)); + return newObj; +} + +encPtr newFloat(double d) +{ + encPtr newObj; + + newObj = allocByteObj(sizeof(double)); + (void) memcpy(addressOf(newObj), &d, sizeof(double)); + classOfPut(newObj, globalValue("Float")); + return newObj; +} + +encPtr newLink(encPtr key, encPtr value) +{ + encPtr newObj; + + newObj = allocOrefObj(3); + classOfPut(newObj, globalValue("Link")); + orefOfPut(newObj, 1, (objRef) key); + orefOfPut(newObj, 2, (objRef) value); + return newObj; +} + +encPtr newMethod(void) +{ + encPtr newObj; + + newObj = allocOrefObj(methodSize); + classOfPut(newObj, globalValue("Method")); + return newObj; +} + +encPtr newString(char* value) +{ + encPtr newObj; + + newObj = allocZStrObj(value); + if (ptrEq((objRef) stringClass, (objRef) nilObj)) + stringClass = globalValue("String"); + classOfPut(newObj, stringClass); + return (newObj); +} + +encPtr newSymbol(char* str) +{ + encPtr newObj; + + /* first see if it is already there */ + newObj = globalKey(str); + if (ptrNe((objRef) newObj, (objRef) nilObj)) + return newObj; + + /* not found, must make */ + newObj = allocZStrObj(str); + if (ptrEq((objRef) symbolClass, (objRef) nilObj)) + symbolClass = globalValue("Symbol"); + classOfPut(newObj, symbolClass); + nameTableInsert(symbols, strHash(str), newObj, nilObj); + return newObj; +} + +inline encPtr getClass(objRef obj) +{ + if (isValue(obj)) { + if (ptrEq((objRef) intClass, (objRef) nilObj)) + intClass = globalValue("Integer"); + return (intClass); + } + return (classOf(obj.ptr)); +} + +typedef enum tokensyms { + nothing, nameconst, namecolon, + intconst, floatconst, charconst, symconst, + arraybegin, strconst, binary, closing, inputend +} tokentype; + +tokentype token = nothing; +char tokenString[4096] = {}; /* text of current token */ +int tokenInteger = 0; /* or character */ +double tokenFloat = 0.0; + +char *cp = 0; +char cc = 0; + +int pushindex = 0; +char pushBuffer[16] = {}; + +long longresult = 0; /*fix*/ + +void pushBack(char c) +{ + pushBuffer[pushindex++] = c; +} + +char nextChar(void) +{ + if (pushindex > 0) + cc = pushBuffer[--pushindex]; + else if (*cp) + cc = *cp++; + else + cc = '\0'; + return (cc); +} + +char peek(void) +{ + pushBack(nextChar()); + return (cc); +} + +bool isClosing(char c) +{ + switch (c) { + case '.': + case ']': + case ')': + case ';': + case '\"': + case '\'': + return (true); + } + return (false); +} + +bool isSymbolChar(char c) +{ + if (isdigit(c) || isalpha(c)) + return (true); + if (isspace(c) || isClosing(c)) + return (false); + return (true); +} + +bool singleBinary(char c) +{ + switch (c) { + case '[': + case '(': + case ')': + case ']': + return (true); + } + return (false); +} + +bool binarySecond(char c) +{ + if (isalpha(c) || isdigit(c) || isspace(c) || isClosing(c) || + singleBinary(c)) + return (false); + return (true); +} + +tokentype nextToken(void) +{ + char *tp; + bool 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 (canEmbed(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; + (void) nextChar(); + } else + sign = false; + if (cc && isdigit(cc)) { /* yep, its a float */ + *tp++ = 'e'; + if (sign) + *tp++ = '-'; + while (cc && isdigit(cc)) { + *tp++ = cc; + (void) 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); +} + +void lexinit(char* str) +{ + pushindex = 0; + cp = str; + /* get first token */ + (void) nextToken(); +} + +#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 + +#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 */ + +#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 + +void sysWarn(char* s1, char* s2); +void compilWarn(char* selector, char* str1, char* str2); +void compilError(char* selector, char* str1, char* str2); + +#define codeLimit 256 +#define literalLimit 256 +#define temporaryLimit 256 +#define argumentLimit 256 +#define instanceLimit 256 + +bool parseOk = false; + +int codeTop = 0; +byte codeArray[codeLimit] = {}; + +int literalTop = 0; +objRef literalArray[literalLimit] = {}; + +int temporaryTop = 0; +char *temporaryName[temporaryLimit] = {}; + +int argumentTop = 0; +char *argumentName[argumentLimit] = {}; + +int instanceTop = 0; +char *instanceName[instanceLimit] = {}; + +int maxTemporary = 0; +char selector[4096] = {}; + +enum blockstatus { + NotInBlock, InBlock, OptimizedBlock +} blockstat = NotInBlock; + +void setInstanceVariables(encPtr aClass) +{ + int i, + limit; + encPtr vars; + + if (ptrEq((objRef) aClass, (objRef) nilObj)) + instanceTop = 0; + else { + setInstanceVariables(orefOf(aClass, superClassInClass).ptr); + vars = orefOf(aClass, variablesInClass).ptr; + if (ptrNe((objRef) vars, (objRef) nilObj)) { + limit = countOf(vars); + for (i = 1; i <= limit; i++) + instanceName[++instanceTop] = addressOf(orefOf(vars, i).ptr); + } + } +} + +void genMessage(bool toSuper, int argumentCount, encPtr messagesym); +void expression(void); +void parsePrimitive(void); +void block(void); +void body(void); +void assignment(char* name); + +void genCode(int value) +{ + if (codeTop >= codeLimit) + compilError(selector, "too many bytecode instructions in method", ""); + else + codeArray[codeTop++] = value; +} + +void genInstruction(int high, int low) +{ + if (low >= 16) { + genInstruction(Extended, high); + genCode(low); + } else + genCode(high * 16 + low); +} + +int genLiteral(objRef aLiteral) +{ + if (literalTop >= literalLimit) + compilError(selector, "too many literals in method", ""); + else { + literalArray[++literalTop] = aLiteral; + } + return (literalTop - 1); +} + +void genInteger(int val) +{ + if (val == -1) + genInstruction(PushConstant, minusOne); + else if ((val >= 0) && (val <= 2)) + genInstruction(PushConstant, val); + else + genInstruction(PushLiteral, + genLiteral((objRef) encValueOf(val))); +} + +char *glbsyms[] = { + "currentInterpreter", "nil", "true", "false", + 0 +}; + +bool nameTerm(char* name) +{ + int i; + bool done = false; + bool 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((objRef) newSymbol(name))); + genMessage(false, 0, newSymbol("value")); + } + return (isSuper); +} + +int parseArray(void) +{ + int i, + size, + base; + encPtr newLit; + objRef obj; + + base = literalTop; + (void) nextToken(); + while (parseOk && (token != closing)) { + switch (token) { + case arraybegin: + (void) parseArray(); + break; + + case intconst: + (void) genLiteral((objRef) encValueOf(tokenInteger)); + (void) nextToken(); + break; + + case floatconst: + (void) genLiteral((objRef) newFloat(tokenFloat)); + (void) nextToken(); + break; + + case nameconst: + case namecolon: + case symconst: + (void) genLiteral((objRef) newSymbol(tokenString)); + (void) nextToken(); + break; + + case binary: + if (streq(tokenString, "(")) { + (void) parseArray(); + break; + } + if (streq(tokenString, "-") && isdigit(peek())) { + (void) nextToken(); + if (token == intconst) + (void) genLiteral((objRef) encValueOf(-tokenInteger)); + else if (token == floatconst) { + (void) genLiteral((objRef) newFloat(-tokenFloat)); + } else + compilError(selector, "negation not followed", + "by number"); + (void) nextToken(); + break; + } + (void) genLiteral((objRef) newSymbol(tokenString)); + (void) nextToken(); + break; + + case charconst: + (void) genLiteral((objRef) newChar(tokenInteger)); + (void) nextToken(); + break; + + case strconst: + (void) genLiteral((objRef) newString(tokenString)); + (void) nextToken(); + break; + + default: + compilError(selector, "illegal text in literal array", + tokenString); + (void) nextToken(); + break; + } + } + + if (parseOk) + if (!streq(tokenString, ")")) + compilError(selector, "array not terminated by right parenthesis", + tokenString); + else + (void) nextToken(); + size = literalTop - base; + newLit = newArray(size); + for (i = size; i >= 1; i--) { + obj = literalArray[literalTop]; + orefOfPut(newLit, i, obj); + literalArray[literalTop] = (objRef) nilObj; + literalTop = literalTop - 1; + } + return (genLiteral((objRef) newLit)); +} + +bool term(void) +{ + bool superTerm = false; /* true if term is pseudo var super */ + + if (token == nameconst) { + superTerm = nameTerm(tokenString); + (void) nextToken(); + } else if (token == intconst) { + genInteger(tokenInteger); + (void) nextToken(); + } else if (token == floatconst) { + genInstruction(PushLiteral, genLiteral((objRef) newFloat(tokenFloat))); + (void) nextToken(); + } else if ((token == binary) && streq(tokenString, "-")) { + (void) nextToken(); + if (token == intconst) + genInteger(-tokenInteger); + else if (token == floatconst) { + genInstruction(PushLiteral, + genLiteral((objRef) newFloat(-tokenFloat))); + } else + compilError(selector, "negation not followed", + "by number"); + (void) nextToken(); + } else if (token == charconst) { + genInstruction(PushLiteral, + genLiteral((objRef) newChar(tokenInteger))); + (void) nextToken(); + } else if (token == symconst) { + genInstruction(PushLiteral, + genLiteral((objRef) newSymbol(tokenString))); + (void) nextToken(); + } else if (token == strconst) { + genInstruction(PushLiteral, + genLiteral((objRef) newString(tokenString))); + (void) nextToken(); + } else if (token == arraybegin) { + genInstruction(PushLiteral, parseArray()); + } else if ((token == binary) && streq(tokenString, "(")) { + (void) nextToken(); + expression(); + if (parseOk) + if ((token != closing) || !streq(tokenString, ")")) + compilError(selector, "Missing Right Parenthesis", ""); + else + (void) nextToken(); + } else if ((token == binary) && streq(tokenString, "<")) + parsePrimitive(); + else if ((token == binary) && streq(tokenString, "[")) + block(); + else + compilError(selector, "invalid expression start", tokenString); + + return (superTerm); +} + +void parsePrimitive(void) +{ + int primitiveNumber, + argumentCount; + + if (nextToken() != intconst) + compilError(selector, "primitive number missing", ""); + primitiveNumber = tokenInteger; + (void) nextToken(); + argumentCount = 0; + while (parseOk && !((token == binary) && streq(tokenString, ">"))) { + (void) term(); + argumentCount++; + } + genInstruction(DoPrimitive, argumentCount); + genCode(primitiveNumber); + (void) nextToken(); +} + +void genMessage(bool toSuper, int argumentCount, encPtr messagesym) +{ + bool sent = false; + int i; + + if ((!toSuper) && (argumentCount == 0)) + for (i = 0; (!sent) && ptrNe((objRef)unSyms[i],(objRef)nilObj); i++) + if (ptrEq((objRef) messagesym, (objRef) unSyms[i])) { + genInstruction(SendUnary, i); + sent = true; + } + if ((!toSuper) && (argumentCount == 1)) + for (i = 0; (!sent) && ptrNe((objRef)binSyms[i],(objRef)nilObj); i++) + if (ptrEq((objRef) messagesym, (objRef) binSyms[i])) { + genInstruction(SendBinary, i); + sent = true; + } + if (!sent) { + genInstruction(MarkArguments, 1 + argumentCount); + if (toSuper) { + genInstruction(DoSpecial, SendToSuper); + genCode(genLiteral((objRef) messagesym)); + } else + genInstruction(SendMessage, genLiteral((objRef) messagesym)); + } +} + +bool unaryContinuation(bool superReceiver) +{ + int i; + bool 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; + (void) nextToken(); + } + return (superReceiver); +} + +bool binaryContinuation(bool superReceiver) +{ + bool superTerm; + encPtr messagesym; + + superReceiver = unaryContinuation(superReceiver); + while (parseOk && (token == binary)) { + messagesym = newSymbol(tokenString); + (void) nextToken(); + superTerm = term(); + (void) unaryContinuation(superTerm); + genMessage(superReceiver, 1, messagesym); + superReceiver = false; + } + return (superReceiver); +} + +int optimizeBlock(int instruction, bool dopop) +{ + int location; + enum blockstatus savebstat; + + savebstat = blockstat; + genInstruction(DoSpecial, instruction); + location = codeTop; + genCode(0); + if (dopop) + genInstruction(DoSpecial, PopTop); + (void) nextToken(); + if (streq(tokenString, "[")) { + (void) nextToken(); + if (blockstat == NotInBlock) + blockstat = OptimizedBlock; + body(); + if (!streq(tokenString, "]")) + compilError(selector, "missing close", "after block"); + (void) nextToken(); + } else { + (void) binaryContinuation(term()); + genMessage(false, 0, newSymbol("value")); + } + codeArray[location] = codeTop + 1; + blockstat = savebstat; + return (location); +} + +bool keyContinuation(bool superReceiver) +{ + int i, + j, + argumentCount; + bool sent, + superTerm; + encPtr messagesym; + char pattern[4096]; + + superReceiver = binaryContinuation(superReceiver); + if (token == namecolon) { + if (streq(tokenString, "ifTrue:")) { + i = optimizeBlock(BranchIfFalse, false); + if (streq(tokenString, "ifFalse:")) { + codeArray[i] = codeTop + 3; + (void) optimizeBlock(Branch, true); + } + } else if (streq(tokenString, "ifFalse:")) { + i = optimizeBlock(BranchIfTrue, false); + if (streq(tokenString, "ifTrue:")) { + codeArray[i] = codeTop + 3; + (void) 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:")) + (void) optimizeBlock(AndBranch, false); + else if (streq(tokenString, "or:")) + (void) optimizeBlock(OrBranch, false); + else { + pattern[0] = '\0'; + argumentCount = 0; + while (parseOk && (token == namecolon)) { + (void) strcat(pattern, tokenString); + argumentCount++; + (void) nextToken(); + superTerm = term(); + (void) binaryContinuation(superTerm); + } + sent = false; + + /* check for predefined messages */ + messagesym = newSymbol(pattern); + + if (!sent) { + genMessage(superReceiver, argumentCount, messagesym); + } + } + superReceiver = false; + } + return (superReceiver); +} + +void continuation(bool superReceiver) +{ + superReceiver = keyContinuation(superReceiver); + + while (parseOk && (token == closing) && streq(tokenString, ";")) { + genInstruction(DoSpecial, Duplicate); + (void) nextToken(); + (void) keyContinuation(superReceiver); + genInstruction(DoSpecial, PopTop); + } +} + +void expression(void) +{ + bool superTerm; + char assignname[4096]; + + if (token == nameconst) { /* possible assignment */ + (void) strcpy(assignname, tokenString); + (void) nextToken(); + if ((token == binary) && streq(tokenString, "<-")) { + (void) nextToken(); + assignment(assignname); + } else { /* not an assignment after all */ + superTerm = nameTerm(assignname); + continuation(superTerm); + } + } else { + superTerm = term(); + if (parseOk) + continuation(superTerm); + } +} + +void assignment(char* name) +{ + int i; + bool 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((objRef) newSymbol(name))); + expression(); + genMessage(false, 2, newSymbol("assign:value:")); + } +} + +void statement(void) +{ + + if ((token == binary) && streq(tokenString, "^")) { + (void) 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(); + } +} + +void body(void) +{ + /* 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, ".")) { + (void) nextToken(); + if (token == inputend) + 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); + } + } +} + +void block(void) +{ + int saveTemporary, + argumentCount, + fixLocation; + encPtr tempsym, + newBlk; + enum blockstatus savebstat; + + saveTemporary = temporaryTop; + savebstat = blockstat; + argumentCount = 0; + (void) 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] = addressOf(tempsym); + } + (void) nextToken(); + } + if ((token != binary) || !streq(tokenString, "|")) + compilError(selector, "block argument list must be terminated", + "by |"); + (void) nextToken(); + } + newBlk = newBlock(); + orefOfPut(newBlk, argumentCountInBlock, (objRef) encValueOf(argumentCount)); + orefOfPut(newBlk, argumentLocationInBlock, + (objRef) encValueOf(saveTemporary + 1)); + genInstruction(PushLiteral, genLiteral((objRef) newBlk)); + genInstruction(PushConstant, contextConst); + genInstruction(DoPrimitive, 2); + genCode(29); + genInstruction(DoSpecial, Branch); + fixLocation = codeTop; + genCode(0); + /*genInstruction(DoSpecial, PopTop); */ + orefOfPut(newBlk, bytecountPositionInBlock, (objRef) encValueOf(codeTop + 1)); + blockstat = InBlock; + body(); + if ((token == closing) && streq(tokenString, "]")) + (void) nextToken(); + else + compilError(selector, "block not terminated by ]", ""); + genInstruction(DoSpecial, StackReturn); + codeArray[fixLocation] = codeTop + 1; + temporaryTop = saveTemporary; + blockstat = savebstat; +} + +void temporaries(void) +{ + encPtr tempsym; + + temporaryTop = 0; + if ((token == binary) && streq(tokenString, "|")) { + (void) 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] = addressOf(tempsym); + } + (void) nextToken(); + } + if ((token != binary) || !streq(tokenString, "|")) + compilError(selector, "temporary list not terminated by bar", ""); + else + (void) nextToken(); + } +} + +void messagePattern(void) +{ + encPtr argsym; + + argumentTop = 0; + (void) strcpy(selector, tokenString); + if (token == nameconst) /* unary message pattern */ + (void) nextToken(); + else if (token == binary) { /* binary message pattern */ + (void) nextToken(); + if (token != nameconst) + compilError(selector, "binary message pattern not followed by name", selector); + argsym = newSymbol(tokenString); + argumentName[++argumentTop] = addressOf(argsym); + (void) nextToken(); + } else if (token == namecolon) { /* keyword message pattern */ + selector[0] = '\0'; + while (parseOk && (token == namecolon)) { + (void) strcat(selector, tokenString); + (void) 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] = addressOf(argsym); + (void) nextToken(); + } + } else + compilError(selector, "illegal message selector", tokenString); +} + +bool parse(encPtr method, char* text, bool saveText) +{ + int i; + encPtr 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) { + orefOfPut(method, bytecodesInMethod, (objRef) nilObj); + } else { + bytecodes = newByteArray(codeTop); + bp = addressOf(bytecodes); + for (i = 0; i < codeTop; i++) { + bp[i] = codeArray[i]; + } + orefOfPut(method, messageInMethod, (objRef) newSymbol(selector)); + orefOfPut(method, bytecodesInMethod, (objRef) bytecodes); + if (literalTop > 0) { + theLiterals = newArray(literalTop); + for (i = 1; i <= literalTop; i++) { + orefOfPut(theLiterals, i, literalArray[i]); + } + orefOfPut(method, literalsInMethod, (objRef) theLiterals); + } else { + orefOfPut(method, literalsInMethod, (objRef) nilObj); + } + orefOfPut(method, stackSizeInMethod, (objRef) encValueOf(6)); + orefOfPut(method, temporarySizeInMethod, + (objRef) encValueOf(1 + maxTemporary)); + if (saveText) { + orefOfPut(method, textInMethod, (objRef) newString(text)); + } + return (true); + } + return (false); +} + +extern word traceVect[]; + +#define traceSize 3 +#define execTrace traceVect[0] +#define primTrace traceVect[1] +#define mselTrace traceVect[2] + +inline objRef unsupportedPrim(objRef arg[]) +{ + return((objRef) nilObj); +} + +/* +Prints the number of available object table entries. +Always fails. +Called from Scheduler>>initialize +*/ +objRef primAvailCount(objRef arg[]) +{ + fprintf(stderr, "free: %d\n", availCount()); + return((objRef) nilObj); +} + +/* +Returns a pseudo-random integer. +Called from + Random>>next + Random>>randInteger: +*/ +objRef primRandom(objRef arg[]) +{ + short i; + /* this is hacked because of the representation */ + /* of integers as shorts */ + i = rand() >> 8; /* strip off lower bits */ + if (i < 0) + i = -i; + return((objRef) encValueOf(i >> 1)); +} + +extern bool watching; + +/* +Inverts the state of a switch. The switch controls, in part, whether or +not "watchWith:" messages are sent to Methods during execution. +Returns the Boolean representation of the switch value after the invert. +Called from Smalltalk>>watch +*/ +objRef primFlipWatching(objRef arg[]) +{ + watching = !watching; + return((objRef) (watching ? trueObj : falseObj)); +} + +/* +Terminates the interpreter. +Never returns. +Not called from the image. +*/ +objRef primExit(objRef arg[]) +{ + exit(0); +} + +/* +Returns the class of which the receiver is an instance. +Called from Object>>class +*/ +objRef primClass(objRef arg[]) +{ + return((objRef) getClass(arg[0])); +} + +/* +Returns the field count of the von Neumann space of the receiver. +Called from Object>>basicSize +*/ +objRef primSize(objRef arg[]) +{ + int i; + if (isValue(arg[0])) + i = 0; + else + i = countOf(arg[0].ptr); + return((objRef) encValueOf(i)); +} + +/* +Returns a hashed representation of the receiver. +Called from Object>>hash +*/ +objRef primHash(objRef arg[]) +{ + if (isValue(arg[0])) + return(arg[0]); + else + return((objRef) encValueOf(oteIndexOf(arg[0].ptr))); +} + +extern encPtr processStack; +extern int linkPointer; +int* counterAddress = NULL; + +/* +Changes the active process stack if appropriate. The change causes +control to be returned (eventually) to the context which sent the +message which created the context which invoked this primitive. +Returns true if the change was made; false if not. +Called from Context>>blockReturn +N.B.: This involves some tricky code. The compiler generates the +message which invokes Context>>blockReturn. Context>>blockReturn is a +normal method. It processes the true/false indicator. Its result is +discarded when it returns, exposing the value to be returned from the +context which invokes this primitive. Only then is the process stack +change effective. +*/ +objRef primBlockReturn(objRef arg[]) +{ + int i; + int j; + /* first get previous link pointer */ + i = intValueOf(orefOf(processStack, linkPointer).val); + /* then creating context pointer */ + j = intValueOf(orefOf(arg[0].ptr, 1).val); + if (ptrNe(orefOf(processStack, j + 1), arg[0])) + return((objRef) falseObj); + /* first change link pointer to that of creator */ + orefOfPut(processStack, i, orefOf(processStack, j)); + /* then change return point to that of creator */ + orefOfPut(processStack, i + 2, orefOf(processStack, j + 2)); + return((objRef) trueObj); +} + +jmp_buf jb = {}; + +void brkfun(int sig) +{ + longjmp(jb, 1); +} + +void brkignore(int sig) +{ +} + +bool execute(encPtr aProcess, int maxsteps); + +/* +Executes the receiver until its time slice is ended or terminated. +Returns true in the former case; false in the latter. +Called from Process>>execute +*/ +objRef primExecute(objRef arg[]) +{ + encPtr saveProcessStack; + int saveLinkPointer; + int* saveCounterAddress; + objRef returnedObject; + /* first save the values we are about to clobber */ + saveProcessStack = processStack; + saveLinkPointer = linkPointer; + saveCounterAddress = counterAddress; + /* trap control-C */ + signal(SIGINT, brkfun); + if (setjmp(jb)) + returnedObject = (objRef) falseObj; + else + if (execute(arg[0].ptr, 1 << 12)) + returnedObject = (objRef) trueObj; + else + returnedObject = (objRef) falseObj; + signal(SIGINT, brkignore); + /* then restore previous environment */ + processStack = saveProcessStack; + linkPointer = saveLinkPointer; + counterAddress = saveCounterAddress; + return(returnedObject); +} + +/* +Returns true if the content of the receiver's objRef is equal to that +of the first argument's; false otherwise. +Called from Object>>== +*/ +objRef primIdent(objRef arg[]) +{ + if (ptrEq(arg[0], arg[1])) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Defines the receiver to be an instance of the first argument. +Returns the receiver. +Called from + BlockNode>>newBlock + ByteArray>>asString + ByteArray>>size: + Class>>new: +*/ +objRef primClassOfPut(objRef arg[]) +{ + classOfPut(arg[0].ptr, arg[1].ptr); + return(arg[0]); +} + +/* +Creates a new String. The von Neumann space of the new String is that +of the receiver, up to the left-most null, followed by that of the first +argument, up to the left-most null, followed by a null. +Returns the new String. +Called from + String>>, + Symbol>>asString +*/ +objRef primStringCat(objRef arg[]) +{ + addr src1 = addressOf(arg[0].ptr); + word len1 = strlen(src1); + addr src2 = addressOf(arg[1].ptr); + word len2 = strlen(src2); + encPtr ans = allocByteObj(len1+len2+1); + addr tgt = addressOf(ans); + (void) memcpy(tgt,src1,len1); + (void) memcpy(((byte*)tgt)+len1,src2,len2); + if (ptrEq((objRef) stringClass, (objRef) nilObj)) /*fix*/ + stringClass = globalValue("String"); + classOfPut(ans, stringClass); + return((objRef) ans); +} + +/* +Returns the objRef of the receiver denoted by the argument. +Called from Object>>basicAt: +*/ +objRef primBasicAt(objRef arg[]) +{ + int i; + if (isValue(arg[0])) + return((objRef) nilObj); + if (!isObjRefs(arg[0].ptr)) + return((objRef) nilObj); + if (isIndex(arg[1])) + return((objRef) nilObj); + i = intValueOf(arg[1].val); + if(i < 1 || i > countOf(arg[0].ptr)) + return((objRef) nilObj); + return(orefOf(arg[0].ptr, i)); +} + +/* +Returns an encoded representation of the byte of the receiver denoted by +the argument. +Called from ByteArray>>basicAt: +*/ +objRef primByteAt(objRef arg[]) /*fix*/ +{ + int i; + if (isIndex(arg[1])) + sysError("non integer index", "byteAt:"); + i = byteOf(arg[0].ptr, intValueOf(arg[1].val)); + if (i < 0) + i += 256; + return((objRef) encValueOf(i)); +} + +/* +Defines the global value of the receiver to be the first argument. +Returns the receiver. +Called from Symbol>>assign: +*/ +objRef primSymbolAssign(objRef arg[]) /*fix*/ +{ + nameTableInsert( + symbols, strHash(addressOf(arg[0].ptr)), arg[0].ptr, arg[1].ptr); + return(arg[0]); +} + +/* +Changes the active process stack. The change causes control to be +returned in the method containing the block controlled by the receiver +rather than the method which sent the message (e.g. Block>>value) which +created the context which invoked this primitive. Execution will resume +at the location denoted by the first argument. +Called from Context>>returnToBlock: +N.B.: The code involved here isn't quite as tricky as that involved +in primBlockReturn (q.v.). +*/ +objRef primBlockCall(objRef arg[]) /*fix*/ +{ + int i; + /* first get previous link */ + i = intValueOf(orefOf(processStack, linkPointer).val); + /* change context and byte pointer */ + orefOfPut(processStack, i + 1, arg[0]); + orefOfPut(processStack, i + 4, arg[1]); + return(arg[0]); +} + +/* +Returns a modified copy of the receiver. The receiver is a block. The +modification defines the controlling context of the clone to be the +argument. The argument is the current context and is the target of any +"^" return eventually invoked by the receiver. +This primitive is called by compiler-generated code. +N.B.: The code involved here isn't quite as tricky as that involved +in primBlockReturn (q.v.). +*/ +objRef primBlockClone(objRef arg[]) /*fix*/ +{ + objRef returnedObject; + returnedObject = (objRef) newBlock(); + orefOfPut(returnedObject.ptr, 1, arg[1]); + orefOfPut(returnedObject.ptr, 2, orefOf(arg[0].ptr, 2)); + orefOfPut(returnedObject.ptr, 3, orefOf(arg[0].ptr, 3)); + orefOfPut(returnedObject.ptr, 4, orefOf(arg[0].ptr, 4)); + return(returnedObject); +} + +/* +Defines the objRef of the receiver denoted by the first argument to be +the second argument. +Returns the receiver. +Called from Object>>basicAt:put: +*/ +objRef primBasicAtPut(objRef arg[]) +{ + int i; + if (isValue(arg[0])) + return((objRef) nilObj); + if (!isObjRefs(arg[0].ptr)) + return((objRef) nilObj); + if (isIndex(arg[1])) + return((objRef) nilObj); + i = intValueOf(arg[1].val); + if(i < 1 || i > countOf(arg[0].ptr)) + return((objRef) nilObj); + orefOfPut(arg[0].ptr, i, arg[2]); + return(arg[0]); +} + +/* +Defines the byte of the receiver denoted by the first argument to be a +decoded representation of the second argument. +Returns the receiver. +Called from ByteArray>>basicAt:put: +*/ +objRef primByteAtPut(objRef arg[]) /*fix*/ +{ + if (isIndex(arg[1])) + sysError("non integer index", "byteAtPut"); + if (isIndex(arg[2])) + sysError("assigning non int", "to byte"); + byteOfPut(arg[0].ptr, intValueOf(arg[1].val), intValueOf(arg[2].val)); + return(arg[0]); +} + +inline word min(word one, word two) +{ + return(one <= two ? one : two); +} + +/* +Creates a new String. The von Neumann space of the new String is +usually that of a substring of the receiver, from the byte denoted by +the first argument through the byte denoted by the second argument, +followed by a null. However, if the denoted substring is partially +outside the space of the receiver, only that portion within the space of +the receiver is used. Also, if the denoted substring includes a null, +only that portion up to the left-most null is used. Further, if the +denoted substring is entirely outside the space of the receiver or its +length is less than one, none of it is used. +Returns the new String. +Called from String>>copyFrom:to: +*/ +objRef primCopyFromTo(objRef arg[]) /*fix*/ +{ + if ((isIndex(arg[1])) || (isIndex(arg[2]))) + sysError("non integer index", "copyFromTo"); + { + addr src = addressOf(arg[0].ptr); + word len = strlen(src); + int pos1 = intValueOf(arg[1].val); + int pos2 = intValueOf(arg[2].val); + int req = pos2 + 1 - pos1; + word act; + encPtr ans; + addr tgt; + if(pos1 >= 1 && pos1 <= len && req >= 1) + act = min(req, strlen(((byte*)src)+(pos1-1))); + else + act = 0; + ans = allocByteObj(act+1); + tgt = addressOf(ans); + (void) memcpy(tgt,((byte*)src)+(pos1-1),act); + if (ptrEq((objRef) stringClass, (objRef) nilObj)) /*fix*/ + stringClass = globalValue("String"); + classOfPut(ans, stringClass); + return((objRef) ans); + } +} + +void flushCache(encPtr messageToSend, encPtr class); + +/* +Kills the cache slot denoted by the receiver and argument. The receiver +should be a message selector symbol. The argument should be a class. +Returns the receiver. +Called from Class>>install: +*/ +objRef primFlushCache(objRef arg[]) +{ + if(isValue(arg[0]) || isValue(arg[1])) + return((objRef) nilObj); + flushCache(arg[0].ptr, arg[1].ptr); + return(arg[0]); +} + +objRef primParse(objRef arg[]) /*del*/ +{ + setInstanceVariables(arg[0].ptr); + if (parse(arg[2].ptr, addressOf(arg[1].ptr), false)) { + flushCache(orefOf(arg[2].ptr, messageInMethod).ptr, arg[0].ptr); + return((objRef) trueObj); + } else + return((objRef) falseObj); +} + +/* +Returns the equivalent of the receiver's value in a floating-point +representation. +Called from Integer>>asFloat +*/ +objRef primAsFloat(objRef arg[]) +{ + if(isIndex(arg[0])) + return((objRef) nilObj); + return((objRef) newFloat((double) intValueOf(arg[0].val))); +} + +/* +Defines a counter to be the argument's value. When this counter is +less than 1, a Process time slice is finished. +Always fails. +Called from + Scheduler>>critical: + Scheduler>>yield +*/ +objRef primSetTimeSlice(objRef arg[]) +{ + if(isIndex(arg[0])) + return((objRef) nilObj); + *counterAddress = intValueOf(arg[0].val); + return((objRef) nilObj); +} + +/* +Sets the seed for a pseudo-random number generator. +Always fails. +Called from Random>>set: +*/ +objRef primSetSeed(objRef arg[]) +{ + if(isIndex(arg[0])) + return((objRef) nilObj); + (void) srand((unsigned) intValueOf(arg[0].val)); + return((objRef) nilObj); +} + +/* +Returns a new object. The von Neumann space of the new object will be +presumed to contain a number of objRefs. The number is denoted by the +receiver. +Called from + BlockNode>>newBlock + Class>>new: +*/ +objRef primAllocOrefObj(objRef arg[]) +{ + if(isIndex(arg[0])) + return((objRef) nilObj); + return((objRef) allocOrefObj(intValueOf(arg[0].val))); +} + +/* +Returns a new object. The von Neumann space of the new object will be +presumed to contain a number of bytes. The number is denoted by the +receiver. +Called from + ByteArray>>size: +*/ +objRef primAllocByteObj(objRef arg[]) +{ + if(isIndex(arg[0])) + return((objRef) nilObj); + return((objRef) allocByteObj(intValueOf(arg[0].val))); +} + +/* +Returns the result of adding the argument's value to the receiver's +value. +Called from Integer>>+ +Also called for SendBinary bytecodes. +*/ +objRef primAdd(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + longresult += intValueOf(arg[1].val); + if (canEmbed(longresult)) + return((objRef) encValueOf(longresult)); + else + return((objRef) nilObj); +} + +/* +Returns the result of subtracting the argument's value from the +receiver's value. +Called from Integer>>- +Also called for SendBinary bytecodes. +*/ +objRef primSubtract(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + longresult -= intValueOf(arg[1].val); + if (canEmbed(longresult)) + return((objRef) encValueOf(longresult)); + else + return((objRef) nilObj); +} + +/* +Returns true if the receiver's value is less than the argument's +value; false otherwise. +Called from Integer>>< +Also called for SendBinary bytecodes. +*/ +objRef primLessThan(objRef arg[]) +{ + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[0].val) < intValueOf(arg[1].val)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is greater than the argument's +value; false otherwise. +Called from Integer>>> +Also called for SendBinary bytecodes. +*/ +objRef primGreaterThan(objRef arg[]) +{ + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[0].val) > intValueOf(arg[1].val)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is less than or equal to the +argument's value; false otherwise. +Called for SendBinary bytecodes. +*/ +objRef primLessOrEqual(objRef arg[]) +{ + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[0].val) <= intValueOf(arg[1].val)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is greater than or equal to the +argument's value; false otherwise. +Called for SendBinary bytecodes. +*/ +objRef primGreaterOrEqual(objRef arg[]) +{ + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[0].val) >= intValueOf(arg[1].val)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is equal to the argument's value; +false otherwise. +Called for SendBinary bytecodes. +*/ +objRef primEqual(objRef arg[]) +{ + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[0].val) == intValueOf(arg[1].val)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is not equal to the argument's +value; false otherwise. +Called for SendBinary bytecodes. +*/ +objRef primNotEqual(objRef arg[]) +{ + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[0].val) != intValueOf(arg[1].val)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns the result of multiplying the receiver's value by the +argument's value. +Called from Integer>>* +Also called for SendBinary bytecodes. +*/ +objRef primMultiply(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + longresult *= intValueOf(arg[1].val); + if (canEmbed(longresult)) + return((objRef) encValueOf(longresult)); + else + return((objRef) nilObj); +} + +/* +Returns the quotient of the result of dividing the receiver's value by +the argument's value. +Called from Integer>>quo: +Also called for SendBinary bytecodes. +*/ +objRef primQuotient(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[1].val) == 0) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + longresult /= intValueOf(arg[1].val); + if (canEmbed(longresult)) + return((objRef) encValueOf(longresult)); + else + return((objRef) nilObj); +} + +/* +Returns the remainder of the result of dividing the receiver's value by +the argument's value. +Called for SendBinary bytecodes. +*/ +objRef primRemainder(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + if(intValueOf(arg[1].val) == 0) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + longresult %= intValueOf(arg[1].val); + if (canEmbed(longresult)) + return((objRef) encValueOf(longresult)); + else + return((objRef) nilObj); +} + +/* +Returns the bit-wise "and" of the receiver's value and the argument's +value. +Called from Integer>>bitAnd: +Also called for SendBinary bytecodes. +*/ +objRef primBitAnd(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + longresult &= intValueOf(arg[1].val); + return((objRef) encValueOf(longresult)); +} + +/* +Returns the bit-wise "exclusive or" of the receiver's value and the +argument's value. +Called from Integer>>bitXor: +Also called for SendBinary bytecodes. +*/ +objRef primBitXor(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + longresult ^= intValueOf(arg[1].val); + return((objRef) encValueOf(longresult)); +} + +/* +Returns the result of shifting the receiver's value a number of bit +positions denoted by the argument's value. Positive arguments cause +left shifts. Negative arguments cause right shifts. Note that the +result is truncated to the range of embeddable values. +Called from Integer>>bitXor: +*/ +objRef primBitShift(objRef arg[]) +{ + long longresult; + if(isIndex(arg[0]) || isIndex(arg[1])) + return((objRef) nilObj); + longresult = intValueOf(arg[0].val); + if(intValueOf(arg[1].val) < 0) + longresult >>= -intValueOf(arg[1].val); + else + longresult <<= intValueOf(arg[1].val); + return((objRef) encValueOf(longresult)); +} + +/* +Returns the field count of the von Neumann space of the receiver up to +the left-most null. +Called from String>>size +*/ +objRef primStringSize(objRef arg[]) +{ + return((objRef) encValueOf(strlen(addressOf(arg[0].ptr)))); +} + +/* +Returns a hashed representation of the von Neumann space of the receiver +up to the left-most null. +Called from + String>>hash + Symbol>>stringHash +*/ +objRef primStringHash(objRef arg[]) +{ + return((objRef) encValueOf(strHash(addressOf(arg[0].ptr)))); +} + +/* +Returns a unique object. Here, "unique" is determined by the +von Neumann space of the receiver up to the left-most null. A copy will +either be found in or added to the global symbol table. The returned +object will refer to the copy. +Called from String>>asSymbol +*/ +objRef primAsSymbol(objRef arg[]) +{ + return((objRef) newSymbol(addressOf(arg[0].ptr))); +} + +/* +Returns the object associated with the receiver in the global symbol +table. +Called from Symbol>>value +*/ +objRef primGlobalValue(objRef arg[]) +{ + return((objRef) globalValue(addressOf(arg[0].ptr))); +} + +/* +Passes the von Neumann space of the receiver to the host's "system" +function. Returns what that function returns. +Called from String>>unixCommand +*/ +objRef primHostCommand(objRef arg[]) +{ + return((objRef) encValueOf(system(addressOf(arg[0].ptr)))); +} + +/* +Returns the equivalent of the receiver's value in a printable character +representation. +Called from Float>>printString +*/ +objRef primAsString(objRef arg[]) +{ + char buffer[32]; + (void) sprintf(buffer, "%g", floatValue(arg[0].ptr)); + return((objRef) newString(buffer)); +} + +/* +Returns the natural logarithm of the receiver's value. +Called from Float>>ln +*/ +objRef primNaturalLog(objRef arg[]) +{ + return((objRef) newFloat(log(floatValue(arg[0].ptr)))); +} + +/* +Returns "e" raised to a power denoted by the receiver's value. +Called from Float>>exp +*/ +objRef primERaisedTo(objRef arg[]) +{ + return((objRef) newFloat(exp(floatValue(arg[0].ptr)))); +} + +/* +Returns a new Array containing two integers n and m such that the +receiver's value can be expressed as n * 2**m. +Called from Float>>integerPart +*/ +objRef primIntegerPart(objRef arg[]) +{ + double temp; + int i; + int j; + encPtr returnedObject = nilObj; +#define ndif 12 + temp = frexp(floatValue(arg[0].ptr), &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); + orefOfPut(returnedObject, 1, (objRef) encValueOf(j)); + orefOfPut(returnedObject, 2, (objRef) encValueOf(i)); +#ifdef trynew + /* if number is too big it can't be integer anyway */ + if (floatValue(arg[0].ptr) > 2e9) + returnedObject = nilObj; + else { + (void) modf(floatValue(arg[0].ptr), &temp); + ltemp = (long) temp; + if (canEmbed(ltemp)) + returnedObject = encValueOf((int) temp); + else + returnedObject = newFloat(temp); + } +#endif + return((objRef) returnedObject); +} + +/* +Returns the result of adding the argument's value to the receiver's +value. +Called from Float>>+ +*/ +objRef primFloatAdd(objRef arg[]) +{ + double result; + result = floatValue(arg[0].ptr); + result += floatValue(arg[1].ptr); + return((objRef) newFloat(result)); +} + +/* +Returns the result of subtracting the argument's value from the +receiver's value. +Called from Float>>- +*/ +objRef primFloatSubtract(objRef arg[]) +{ + double result; + result = floatValue(arg[0].ptr); + result -= floatValue(arg[1].ptr); + return((objRef) newFloat(result)); +} + +/* +Returns true if the receiver's value is less than the argument's +value; false otherwise. +Called from Float>>< +*/ +objRef primFloatLessThan(objRef arg[]) +{ + if(floatValue(arg[0].ptr) < floatValue(arg[1].ptr)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is greater than the argument's +value; false otherwise. +Not called from the image. +*/ +objRef primFloatGreaterThan(objRef arg[]) +{ + if(floatValue(arg[0].ptr) > floatValue(arg[1].ptr)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is less than or equal to the +argument's value; false otherwise. +Not called from the image. +*/ +objRef primFloatLessOrEqual(objRef arg[]) +{ + if(floatValue(arg[0].ptr) <= floatValue(arg[1].ptr)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is greater than or equal to the +argument's value; false otherwise. +Not called from the image. +*/ +objRef primFloatGreaterOrEqual(objRef arg[]) +{ + if(floatValue(arg[0].ptr) >= floatValue(arg[1].ptr)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is equal to the argument's value; +false otherwise. +Called from Float>>= +*/ +objRef primFloatEqual(objRef arg[]) +{ + if(floatValue(arg[0].ptr) == floatValue(arg[1].ptr)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns true if the receiver's value is not equal to the argument's +value; false otherwise. +Not called from the image. +*/ +objRef primFloatNotEqual(objRef arg[]) +{ + if(floatValue(arg[0].ptr) != floatValue(arg[1].ptr)) + return((objRef) trueObj); + else + return((objRef) falseObj); +} + +/* +Returns the result of multiplying the receiver's value by the +argument's value. +Called from Float>>* +*/ +objRef primFloatMultiply(objRef arg[]) +{ + double result; + result = floatValue(arg[0].ptr); + result *= floatValue(arg[1].ptr); + return((objRef) newFloat(result)); +} + +/* +Returns the result of dividing the receiver's value by the argument's +value. +Called from Float>>/ +*/ +objRef primFloatDivide(objRef arg[]) +{ + double result; + result = floatValue(arg[0].ptr); + result /= floatValue(arg[1].ptr); + return((objRef) newFloat(result)); +} + +#define MAXFILES 32 + +FILE *fp[MAXFILES] = {}; + +/* +Opens the file denoted by the first argument, if necessary. Some of the +characteristics of the file and/or the operations permitted on it may be +denoted by the second argument. +Returns non-nil if successful; nil otherwise. +Called from File>>open +*/ +objRef primFileOpen(objRef arg[]) +{ + int i = intValueOf(arg[0].val); + char *p = addressOf(arg[1].ptr); + if (streq(p, "stdin")) + fp[i] = stdin; + else if (streq(p, "stdout")) + fp[i] = stdout; + else if (streq(p, "stderr")) + fp[i] = stderr; + else { + char* q = addressOf(arg[2].ptr); + char* r = strchr(q,'b'); + encPtr s = {false,1}; + if(r == NULL) { + int t = strlen(q); + s = allocByteObj(t + 2); + r = addressOf(s); + memcpy(r,q,t); + *(r + t) = 'b'; + q = r; + } + fp[i] = fopen(p, q); + if(r == NULL) + isVolatilePut(s,false); + } + if (fp[i] == NULL) + return((objRef) nilObj); + else + return((objRef) encValueOf(i)); +} + +/* +Closes the file denoted by the receiver. +Always fails. +Called from File>>close +*/ +objRef primFileClose(objRef arg[]) +{ + int i = intValueOf(arg[0].val); + if (fp[i]) + (void) fclose(fp[i]); + fp[i] = NULL; + return((objRef) nilObj); +} + +void coldFileIn(encVal tagRef); + +/* +Applies the built-in "fileIn" function to the file denoted by the +receiver. +Always fails. +Not called from the image. +N.B.: The built-in function uses the built-in compiler. Both should be +used only in connection with building an initial image. +*/ +objRef primFileIn(objRef arg[]) +{ + int i = intValueOf(arg[0].val); + if (fp[i]) + coldFileIn(arg[0].val); + return((objRef) nilObj); +} + +/* +Reads the next line of characters from the file denoted by the receiver. +This line usually starts with the character at the current file position +and ends with the left-most newline. However, if reading from standard +input, the line may be continued by immediately preceding the newline +with a backslash, both of which are deleted. Creates a new String. The +von Neumann space of the new String is usually the characters of the +complete line followed by a null. However, if reading from standard +input, the trailing newline is deleted. Also, if the line includes a +null, only that portion up to the left-most null is used. +Returns the new String if successful, nil otherwise. +Called from File>>getString +*/ +objRef primGetString(objRef arg[]) +{ + int i = intValueOf(arg[0].val); + int j; + char buffer[4096]; + if (!fp[i]) + return((objRef) nilObj); + j = 0; + buffer[j] = '\0'; + while (1) { + if (fgets(&buffer[j], 512, fp[i]) == NULL) { + if (fp[i] == stdin) + (void) fputc('\n', stdout); + return ((objRef) 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 */ + } + return((objRef) newString(buffer)); +} + +inline bool irf(FILE* tag, addr dat, word len) { + return((fread(dat,len,1,tag) == 1) ? true : false); +} + +encPtr imageRead(FILE* tag) +{ + encVal ver = encValueOf(3); + encVal val; + word ord; + otbEnt* otp; + ot2Ent* o2p; + encPtr ptr; + word len; + if(irf(tag, &val, sizeof val) != true) + goto fail; + if(ptrNe((objRef)val,(objRef)ver)) + goto fail; + while(irf(tag, &val, sizeof val) == true) { + ord = intValueOf(val); + otp = &objTbl[ord]; +#if 0 + if(irf(tag, (void*)otp, sizeof(addr)) != true) + goto fail; +#endif + if(irf(tag, ((void*)otp)+sizeof(addr), sizeof(otbEnt)-sizeof(addr)) != true) + goto fail; + o2p = &ob2Tbl[ord]; + if(irf(tag, o2p, sizeof(ot2Ent)) != true) + goto fail; + ptr = encIndexOf(ord); + if((len = spaceOf(ptr))) { + addressOfPut(ptr,newStorage(len)); + if(irf(tag, addressOf(ptr), len) != true) + goto fail; + } + } + return(trueObj); +fail: + return(falseObj); +} + +inline bool iwf(FILE* tag, addr dat, word len) { + return((fwrite(dat,len,1,tag) == 1) ? true : false); +} + +encPtr imageWrite(FILE* tag) +{ + encVal val = encValueOf(3); + word ord; + encPtr ptr; + otbEnt* otp; + ot2Ent* o2p; + word len; + if(iwf(tag, &val, sizeof val) != true) + goto fail; + for(ord = otbLob; ord <= otbHib; ord++) { + ptr = encIndexOf(ord); + if(isAvail(ptr)) + continue; + val = encValueOf(ord); + if(iwf(tag, &val, sizeof val) != true) + goto fail; + otp = &objTbl[ord]; +#if 0 + if(iwf(tag, (void*)otp, sizeof(addr)) != true) + goto fail; +#endif + if(iwf(tag, ((void*)otp)+sizeof(addr), sizeof(otbEnt)-sizeof(addr)) != true) + goto fail; + o2p = &ob2Tbl[ord]; + if(iwf(tag, o2p, sizeof(ot2Ent)) != true) + goto fail; + if((len = spaceOf(ptr))) + if(iwf(tag, addressOf(ptr), len) != true) + goto fail; + } + return(trueObj); +fail: + return(falseObj); +} + +/* +Writes the currently running set of objects in binary form to the file +denoted by the receiver. +Returns true if successful; false or nil otherwise. +Called from File>>saveImage +*/ +objRef primImageWrite(objRef arg[]) +{ + int i = intValueOf(arg[0].val); + if (fp[i]) + return((objRef) imageWrite(fp[i])); + else + return((objRef) nilObj); +} + +/* +Writes the von Neumann space of the argument, up to the left-most null, +to the file denoted by the receiver. +Always fails. +Called from File>>printNoReturn: +*/ +objRef primPrintWithoutNL(objRef arg[]) +{ + int i = intValueOf(arg[0].val); + if (!fp[i]) + return((objRef) nilObj); + (void) fputs(addressOf(arg[1].ptr), fp[i]); + (void) fflush(fp[i]); + return((objRef) nilObj); +} + +/* +Writes the von Neumann space of the argument, up to the left-most null, +to the file denoted by the receiver and appends a newline. +Always fails. +Called from File>>print: +*/ +objRef primPrintWithNL(objRef arg[]) +{ + int i = intValueOf(arg[0].val); + if (!fp[i]) + return((objRef) nilObj); + (void) fputs(addressOf(arg[1].ptr), fp[i]); + (void) fputc('\n', fp[i]); + return((objRef) nilObj); +} + +/* +Defines the trace vector slot denoted by the receiver to be the value +denoted by the argument. +Returns the receiver. +Not usually called from the image. +*/ +objRef primSetTrace(objRef arg[]) +{ + traceVect[intValueOf(arg[0].val)] = intValueOf(arg[1].val); + return(arg[0]); +} + +/* +Prints the von Neumann space of the receiver, followed by a newline, and +causes an abort. +Not usually called from the image. +*/ +objRef primError(objRef arg[]) +{ + (void) fprintf(stderr,"error: '%s'\n",(char*)addressOf(arg[0].ptr)); + assert(false); + return(arg[0]); +} + +/* +Causes memory reclamation. +Returns the receiver. +Not usually called from the image. +N.B.: Do not call this primitive from the image with a receiver of +false. +*/ +objRef primReclaim(objRef arg[]) +{ + if(ptrEq(arg[0], (objRef) trueObj) || ptrEq(arg[0], (objRef) falseObj)) { + reclaim(ptrEq(arg[0], (objRef) trueObj)); + return(arg[0]); + } + else + return((objRef) nilObj); +} + +FILE* logTag = NULL; +encPtr logBuf = {false,1}; +addr logPtr = 0; +word logSiz = 0; +word logPos = 0; + +void logInit() +{ + logPos = 0; +} + +void logByte(byte val) +{ + if(logPos == logSiz) { + encPtr newBuf = allocByteObj(logSiz + 128); + addr newPtr = addressOf(newBuf); + (void) memcpy(newPtr,logPtr,logSiz); + isVolatilePut(logBuf,false); + logBuf = newBuf; + logPtr = newPtr; + logSiz = countOf(logBuf); + } + *(((byte*)logPtr)+logPos++) = val; +} + +bool logFini() +{ + if(logTag == NULL) + return(false); + if(fwrite(logPtr,logPos,1,logTag) != 1) + return(false); + if(fflush(logTag) == EOF) + return(false); + return(true); +} + +/* +Writes the von Neumann space of the receiver, except for trailing nulls, +to the transcript in "chunk" form. A chunk is usually a sequence of +non-'!' bytes followed by a '!' byte followed by a newline. To +support '!' bytes within a chunk, such bytes are written as pairs of +'!' bytes. +Returns the receiver if successful; nil otherwise. +Called from ByteArray>>logChunk +*/ +objRef primLogChunk(objRef arg[]) +{ + logInit(); + { + encPtr txtBuf = arg[0].ptr; + addr txtPtr = addressOf(txtBuf); + word txtSiz = countOf(txtBuf); + word txtPos = 0; + while(txtSiz && *(((byte*)txtPtr)+(txtSiz-1)) == '\0') + txtSiz--; + while(txtPos != txtSiz) { + byte val = *(((byte*)txtPtr)+txtPos++); + logByte(val); + if(val == '!') + logByte(val); + } + } + logByte('!'); + logByte('\n'); + if(logFini() != true) + return((objRef) nilObj); + return(arg[0]); +} + +encPtr bwsBuf = {false,1}; +addr bwsPtr = 0; +word bwsSiz = 0; +word bwsPos = 0; + +void bwsInit(void) +{ + bwsPos = 0; +} + +void bwsNextPut(byte val) +{ + if(bwsPos == bwsSiz) { + encPtr newBuf = allocByteObj(bwsSiz + 128); + addr newPtr = addressOf(newBuf); + (void) memcpy(newPtr,bwsPtr,bwsSiz); + isVolatilePut(bwsBuf,false); + bwsBuf = newBuf; + bwsPtr = newPtr; + bwsSiz = countOf(bwsBuf); + } + *(((byte*)bwsPtr)+bwsPos++) = val; +} + +encPtr bwsFiniGet(void) +{ + encPtr ans = allocByteObj(bwsPos+1); + addr tgt = addressOf(ans); + (void) memcpy(tgt,bwsPtr,bwsPos); + if (ptrEq((objRef) stringClass, (objRef) nilObj)) /*fix*/ + stringClass = globalValue("String"); + classOfPut(ans, stringClass); + return(ans); +} + +bool bwsFiniPut(FILE* tag) +{ + if(fwrite(bwsPtr,bwsPos,1,tag) != 1) + return(false); + if(fflush(tag) == EOF) + return(false); + return(true); +} + +/* +Reads the next chunk of characters from the file denoted by the +receiver. A chunk is usually a sequence of non-'!' bytes followed by +a '!' byte followed by a newline. To support '!' bytes within a +chunk, such bytes are read as pairs of '!' bytes. Creates a new +String. The von Neumann space of the new String is the bytes of the +chunk, not including the trailing '!' byte or newline, followed by a +null. +Returns the new String if successful, nil otherwise. +Called from File>>getChunk +*/ +objRef primGetChunk(objRef arg[]) +{ + int i; + FILE* tag; + int val; + i = intValueOf(arg[0].val); + if((tag = fp[i]) == NULL) + goto fail; + bwsInit(); + while((val = fgetc(tag)) != EOF) { + if(val == '!') + switch((val = fgetc(tag))) { + case '\n': + goto done; + case '!': + break; + default: + goto fail; + } + bwsNextPut(val); + } +fail: + return((objRef) nilObj); +done: + return((objRef) bwsFiniGet()); +} + +/* +Writes the von Neumann space of the argument, except for trailing nulls, +to the file denoted by the receiver in "chunk" form. A chunk is usually +a sequence of non-'!' bytes followed by a '!' byte followed by a +newline. To support '!' bytes within a chunk, such bytes are written +as pairs of '!' bytes. +Returns the receiver if successful; nil otherwise. +Called from File>>putChunk +*/ +objRef primPutChunk(objRef arg[]) +{ + int i; + FILE* tag; + i = intValueOf(arg[0].val); + if((tag = fp[i]) == NULL) + goto fail; + bwsInit(); + { + encPtr txtBuf = arg[1].ptr; + addr txtPtr = addressOf(txtBuf); + word txtSiz = countOf(txtBuf); + word txtPos = 0; + while(txtSiz && *(((byte*)txtPtr)+(txtSiz-1)) == '\0') + txtSiz--; + while(txtPos != txtSiz) { + byte val = *(((byte*)txtPtr)+txtPos++); + bwsNextPut(val); + if(val == '!') + bwsNextPut(val); + } + } + bwsNextPut('!'); + bwsNextPut('\n'); + if(bwsFiniPut(tag) == true) + goto done; +fail: + return((objRef) nilObj); +done: + return(arg[0]); +} + +typedef objRef primitiveMethod(objRef arg[]); + +#define primVectLob 0 +#define primVectHib 255 +#define primVectDom ((primVectHib + 1) - primVectLob) + +primitiveMethod* primitiveVector[primVectDom] = { +/*000*/ &unsupportedPrim, +/*001*/ &unsupportedPrim, +/*002*/ &primAvailCount, +/*003*/ &primRandom, +/*004*/ &unsupportedPrim, +/*005*/ &primFlipWatching, +/*006*/ &unsupportedPrim, +/*007*/ &unsupportedPrim, +/*008*/ &unsupportedPrim, +/*009*/ &primExit, +/*010*/ &unsupportedPrim, +/*011*/ &primClass, +/*012*/ &primSize, +/*013*/ &primHash, +/*014*/ &unsupportedPrim, +/*015*/ &unsupportedPrim, +/*016*/ &unsupportedPrim, +/*017*/ &unsupportedPrim, +/*018*/ &primBlockReturn, +/*019*/ &primExecute, +/*020*/ &unsupportedPrim, +/*021*/ &primIdent, +/*022*/ &primClassOfPut, +/*023*/ &unsupportedPrim, +/*024*/ &primStringCat, +/*025*/ &primBasicAt, +/*026*/ &primByteAt, +/*027*/ &primSymbolAssign, +/*028*/ &primBlockCall, +/*029*/ &primBlockClone, +/*030*/ &unsupportedPrim, +/*031*/ &primBasicAtPut, +/*032*/ &primByteAtPut, +/*033*/ &primCopyFromTo, +/*034*/ &unsupportedPrim, +/*035*/ &unsupportedPrim, +/*036*/ &unsupportedPrim, +/*037*/ &unsupportedPrim, +/*038*/ &primFlushCache, +/*039*/ &primParse, +/*040*/ &unsupportedPrim, +/*041*/ &unsupportedPrim, +/*042*/ &unsupportedPrim, +/*043*/ &unsupportedPrim, +/*044*/ &unsupportedPrim, +/*045*/ &unsupportedPrim, +/*046*/ &unsupportedPrim, +/*047*/ &unsupportedPrim, +/*048*/ &unsupportedPrim, +/*049*/ &unsupportedPrim, +/*050*/ &unsupportedPrim, +/*051*/ &primAsFloat, +/*052*/ &unsupportedPrim, +/*053*/ &primSetTimeSlice, +/*054*/ &unsupportedPrim, +/*055*/ &primSetSeed, +/*056*/ &unsupportedPrim, +/*057*/ &unsupportedPrim, +/*058*/ &primAllocOrefObj, +/*059*/ &primAllocByteObj, +/*060*/ &primAdd, +/*061*/ &primSubtract, +/*062*/ &primLessThan, +/*063*/ &primGreaterThan, +/*064*/ &primLessOrEqual, +/*065*/ &primGreaterOrEqual, +/*066*/ &primEqual, +/*067*/ &primNotEqual, +/*068*/ &primMultiply, +/*069*/ &primQuotient, +/*070*/ &primRemainder, +/*071*/ &primBitAnd, +/*072*/ &primBitXor, +/*073*/ &unsupportedPrim, +/*074*/ &unsupportedPrim, +/*075*/ &unsupportedPrim, +/*076*/ &unsupportedPrim, +/*077*/ &unsupportedPrim, +/*078*/ &unsupportedPrim, +/*079*/ &primBitShift, +/*080*/ &unsupportedPrim, +/*081*/ &primStringSize, +/*082*/ &primStringHash, +/*083*/ &primAsSymbol, +/*084*/ &unsupportedPrim, +/*085*/ &unsupportedPrim, +/*086*/ &unsupportedPrim, +/*087*/ &primGlobalValue, +/*088*/ &primHostCommand, +/*089*/ &unsupportedPrim, +/*090*/ &unsupportedPrim, +/*091*/ &unsupportedPrim, +/*092*/ &unsupportedPrim, +/*093*/ &unsupportedPrim, +/*094*/ &unsupportedPrim, +/*095*/ &unsupportedPrim, +/*096*/ &unsupportedPrim, +/*097*/ &unsupportedPrim, +/*098*/ &unsupportedPrim, +/*099*/ &unsupportedPrim, +/*100*/ &unsupportedPrim, +/*101*/ &primAsString, +/*102*/ &primNaturalLog, +/*103*/ &primERaisedTo, +/*104*/ &unsupportedPrim, +/*105*/ &unsupportedPrim, +/*106*/ &primIntegerPart, +/*107*/ &unsupportedPrim, +/*108*/ &unsupportedPrim, +/*109*/ &unsupportedPrim, +/*110*/ &primFloatAdd, +/*111*/ &primFloatSubtract, +/*112*/ &primFloatLessThan, +/*113*/ &primFloatGreaterThan, +/*114*/ &primFloatLessOrEqual, +/*115*/ &primFloatGreaterOrEqual, +/*116*/ &primFloatEqual, +/*117*/ &primFloatNotEqual, +/*118*/ &primFloatMultiply, +/*119*/ &primFloatDivide, +/*120*/ &primFileOpen, +/*121*/ &primFileClose, +/*122*/ &unsupportedPrim, +/*123*/ &primFileIn, +/*124*/ &unsupportedPrim, +/*125*/ &primGetString, +/*126*/ &unsupportedPrim, +/*127*/ &primImageWrite, +/*128*/ &primPrintWithoutNL, +/*129*/ &primPrintWithNL, +/*130*/ &unsupportedPrim, +/*131*/ &unsupportedPrim, +/*132*/ &unsupportedPrim, +/*133*/ &unsupportedPrim, +/*134*/ &unsupportedPrim, +/*135*/ &unsupportedPrim, +/*136*/ &unsupportedPrim, +/*137*/ &unsupportedPrim, +/*138*/ &unsupportedPrim, +/*139*/ &unsupportedPrim, +/*140*/ &unsupportedPrim, +/*141*/ &unsupportedPrim, +/*142*/ &unsupportedPrim, +/*143*/ &unsupportedPrim, +/*144*/ &unsupportedPrim, +/*145*/ &unsupportedPrim, +/*146*/ &unsupportedPrim, +/*147*/ &unsupportedPrim, +/*148*/ &unsupportedPrim, +/*149*/ &unsupportedPrim, +/*150*/ &unsupportedPrim, +/*151*/ &primSetTrace, +/*152*/ &primError, +/*153*/ &primReclaim, +/*154*/ &primLogChunk, +/*155*/ &unsupportedPrim, +/*156*/ &unsupportedPrim, +/*157*/ &primGetChunk, +/*158*/ &primPutChunk, +/*159*/ &unsupportedPrim +}; + +inline objRef primitive(int primitiveNumber, objRef* arguments) +{ + if(primitiveNumber >= primVectLob && primitiveNumber <= primVectHib) + { + primitiveMethod* primMethPtr = primitiveVector[primitiveNumber]; + if(primMethPtr) + return((*primMethPtr)(arguments)); + } + return(unsupportedPrim(arguments)); +} + +encPtr findClass(char* name) +{ + encPtr newobj; + + newobj = globalValue(name); + if (ptrEq((objRef) newobj, (objRef) nilObj)) + newobj = newClass(name); + if (ptrEq(orefOf(newobj, sizeInClass), (objRef) nilObj)) { + orefOfPut(newobj, sizeInClass, (objRef) encValueOf(0)); + } + return newobj; +} + +void coldClassDef(encPtr strRef) +{ + encPtr superStr; + encPtr classObj; + int size; + lexinit(addressOf(strRef)); + superStr = newString(tokenString); + (void) nextToken(); + (void) nextToken(); + classObj = findClass(tokenString); + if(streq(addressOf(superStr),"nil")) + size = 0; + else { + encPtr superObj; + superObj = findClass(addressOf(superStr)); + size = intValueOf(orefOf(superObj, sizeInClass).val); + orefOfPut(classObj, superClassInClass, (objRef) superObj); + { + encPtr classMeta = classOf(classObj); + encPtr superMeta = classOf(superObj); + orefOfPut(classMeta, superClassInClass, (objRef) superMeta); + } + } + (void) nextToken(); + (void) nextToken(); + if(*tokenString) { + encPtr instStr; + int instTop; + encPtr instVars[256]; + encPtr varVec; + int i; + instStr = newString(tokenString); + lexinit(addressOf(instStr)); + instTop = 0; + while(*tokenString) { + instVars[instTop++] = newSymbol(tokenString); + size++; + (void) nextToken(); + } + varVec = newArray(instTop); + for (i = 0; i < instTop; i++) + orefOfPut(varVec, i + 1, (objRef) instVars[i]); + orefOfPut(classObj, variablesInClass, (objRef) varVec); + isVolatilePut(instStr,false); + } + orefOfPut(classObj, sizeInClass, (objRef) encValueOf(size)); + isVolatilePut(superStr,false); +} + +#define MethodTableSize 39 + +void coldMethods(encVal tagRef) +{ + encPtr strRef; + encPtr classObj; + encPtr methTable; + if(ptrEq(strRef = primGetChunk((objRef *) &tagRef).ptr, (objRef) nilObj)) + return; + if(streq(addressOf(strRef),"}")) + return; + lexinit(addressOf(strRef)); + classObj = findClass(tokenString); + setInstanceVariables(classObj); + /* now find or create a method table */ + methTable = orefOf(classObj, methodsInClass).ptr; + if (ptrEq((objRef) methTable, (objRef) nilObj)) { /* must make */ + methTable = newDictionary(MethodTableSize); + orefOfPut(classObj, methodsInClass, (objRef) methTable); + } + while(ptrNe(strRef = primGetChunk((objRef *) &tagRef).ptr, (objRef) nilObj)) { + encPtr theMethod; + encPtr selector; + if(streq(addressOf(strRef),"}")) + return; + /* now we have a method */ + theMethod = newMethod(); + if (parse(theMethod, addressOf(strRef), true)) { + orefOfPut(theMethod, methodClassInMethod, (objRef) classObj); + selector = orefOf(theMethod, messageInMethod).ptr; + nameTableInsert(methTable, oteIndexOf(selector), selector, theMethod); + } else { + /* get rid of unwanted method */ + isVolatilePut(theMethod, false); + } + } +} + +void coldFileIn(encVal tagRef) +{ + encPtr strRef; + while(ptrNe(strRef = primGetChunk((objRef *) &tagRef).ptr, (objRef) nilObj)) { + if(streq(addressOf(strRef),"{")) + coldMethods(tagRef); + else + coldClassDef(strRef); + } +} + +/* +The basic scheduling unit is a Process. We keep a separate copy of its +reference. This interpreter is explicitly stack-based. We use a +separate stack for each Process and keep pointers to both its bottom and +top. Information about particular activations of a Method can be +maintained in separate Context objects. However, if a separate object +isn't needed, this information is kept within the process stack. A +returned object replaces the receiver and arguments of the message which +produced it. This occurs within the process stack at an offset called +the "return point". We treat arguments and temporaries as if they were +stored in separate spaces. However, they may actually be kept within +the process stack. Though the receiver can be thought of as the +"zeroth" argument and accessed from the argument space, we keep separate +copies of its reference and a pointer to its instance variable space. +We also keep separate pointers to the literal and bytecode spaces of a +Method. The "instruction pointer" is kept as an offset into the +bytecode space. An explicit counter supports a rudimentary multi- +programming scheme. +*/ +typedef struct { + encPtr pcso; /* process object */ +/*encPtr pso; process stack object */ + objRef* psb; /* process stack base address */ + objRef* pst; /* process stack top address */ + encPtr cxto; /* context or process stack object */ + objRef* cxtb; /* context or process stack base address */ + int rtnp; /* offset at which to store a returned object */ + objRef* argb; /* argument base address */ + objRef* tmpb; /* temporary base address */ + objRef rcvo; /* receiver object */ + objRef* rcvb; /* receiver base address */ +/*encPtr lito; literal object */ + objRef* litb; /* literal base address */ +/*encPtr byto; bytecode object */ + byte* bytb; /* bytecode base address - 1 */ + word byteOffset; + int timeSliceCounter; +} execState; +#define processObject pcso +#define contextObject cxto +#define returnPoint rtnp +#define receiverObject rcvo + +inline objRef processStackAt(execState* es, int n) +{ + return(*(es->psb+(n-1))); +} + +inline objRef stackTop(execState* es) +{ + return(*es->pst); +} + +inline void stackTopPut(execState* es, objRef x) +{ + *es->pst = x; +} + +inline void stackTopFree(execState* es) +{ + *es->pst-- = (objRef) nilObj; +} + +inline int stackInUse(execState* es) +{ + return((es->pst+1)-es->psb); +} + +inline void ipush(execState* es, objRef x) +{ + *++es->pst = x; +} + +inline objRef ipop(execState* es) +{ + objRef x = *es->pst; + *es->pst-- = (objRef) nilObj; + return(x); +} + +inline objRef argumentAt(execState* es, int n) +{ + return(*(es->argb+n)); +} + +inline objRef temporaryAt(execState* es, int n) +{ + return(*(es->tmpb+n)); +} + +inline void temporaryAtPut(execState* es, int n, objRef x) +{ + *(es->tmpb+n) = x; +} + +inline objRef receiverAt(execState* es, int n) +{ + return(*(es->rcvb+n)); +} + +inline void receiverAtPut(execState* es, int n, objRef x) +{ + *(es->rcvb+n) = x; +} + +inline objRef literalAt(execState* es, int n) +{ + return(*(es->litb+n)); +} + +inline byte nextByte(execState* es) +{ + return(*(es->bytb + es->byteOffset++)); +} + +bool unsupportedByte(execState* es, int low) +{ + sysError("invalid bytecode", ""); + return(false); +} + +/* +Pushes the value of one of the receiver's instance variables onto the +process stack. The instruction operand denotes which one. +*/ +bool bytePushInstance(execState* es, int low) +{ + ipush(es, receiverAt(es, low)); + return(true); +} + +/* +Pushes the value of one of the message's argument variables onto the +process stack. The instruction operand denotes which one. Note that +the receiver is accessed as the "zeroth" argument. +*/ +bool bytePushArgument(execState* es, int low) +{ + ipush(es, argumentAt(es, low)); + return(true); +} + +/* +Pushes the value of one of the method's temporary variables onto the +process stack. The instruction operand denotes which one. +*/ +bool bytePushTemporary(execState* es, int low) +{ + ipush(es, temporaryAt(es, low)); + return(true); +} + +/* +Pushes one of the method's literal values onto the process stack. The +instruction operand denotes which one. See also "bytePushConstant". +*/ +bool bytePushLiteral(execState* es, int low) +{ + ipush(es, literalAt(es, low)); + return(true); +} + +encPtr method = {true,0}; + +encPtr copyFrom(encPtr obj, int start, int size) +{ + encPtr newObj; + int i; + + newObj = newArray(size); + for (i = 1; i <= size; i++) { + orefOfPut(newObj, i, orefOf(obj, start)); + start++; + } + return newObj; +} + +void fetchLinkageState(execState* es) +{ + es->contextObject = processStackAt(es, linkPointer + 1).ptr; + es->returnPoint = intValueOf(processStackAt(es, linkPointer + 2).val); + es->byteOffset = intValueOf(processStackAt(es, linkPointer + 4).val); + if (ptrEq((objRef) es->contextObject, (objRef) nilObj)) { + es->contextObject = processStack; + es->cxtb = es->psb; + es->argb = es->cxtb + (es->returnPoint - 1); + method = processStackAt(es, linkPointer + 3).ptr; + es->tmpb = es->cxtb + linkPointer + 4; + } else { /* read from context object */ + es->cxtb = addressOf(es->contextObject); + method = orefOf(es->contextObject, methodInContext).ptr; + es->argb = addressOf(orefOf(es->contextObject, argumentsInContext).ptr); + es->tmpb = addressOf(orefOf(es->contextObject, temporariesInContext).ptr); + } +} + +inline void fetchReceiverState(execState* es) +{ + es->receiverObject = argumentAt(es, 0); + if (isIndex(es->receiverObject)) { + assert(ptrNe(es->receiverObject, (objRef) pointerList)); + es->rcvb = addressOf(es->receiverObject.ptr); + } + else + es->rcvb = (objRef*) 0; +} + +inline void fetchMethodState(execState* es) +{ + es->litb = addressOf(orefOf(method, literalsInMethod).ptr); + es->bytb = addressOf(orefOf(method, bytecodesInMethod).ptr) - 1; +} + +/* +Pushes one of several "constant" value onto the process stack. The +instruction operand denotes which one. Note that a given context object +is not "constant" in that the values of its instance variables may +change. However, the identity of a given context object is "constant" +in that it will not change. See also "bytePushLiteral". +*/ +bool bytePushConstant(execState* es, int low) +{ + switch (low) { + case 0: + case 1: + case 2: + ipush(es, (objRef) encValueOf(low)); + break; + case minusOne: + ipush(es, (objRef) encValueOf(-1)); + break; + case contextConst: + /* check to see if we have made a block context yet */ + if (ptrEq((objRef) es->contextObject, (objRef) processStack)) { + /* not yet, do it now - first get real return point */ + es->returnPoint = intValueOf(processStackAt(es, linkPointer + 2).val); + es->contextObject = newContext( + linkPointer, + method, + copyFrom(processStack, es->returnPoint, linkPointer - es->returnPoint), + copyFrom(processStack, linkPointer + 5, methodTempSize(method) ) ); + orefOfPut(processStack, linkPointer + 1, (objRef) es->contextObject); + ipush(es, (objRef) es->contextObject); + /* save byte pointer then restore things properly */ + orefOfPut(processStack, linkPointer + 4, (objRef) encValueOf(es->byteOffset)); + fetchLinkageState(es); + fetchReceiverState(es); + fetchMethodState(es); + break; + } + ipush(es, (objRef) es->contextObject); + break; + case nilConst: + ipush(es, (objRef) nilObj); + break; + case trueConst: + ipush(es, (objRef) trueObj); + break; + case falseConst: + ipush(es, (objRef) falseObj); + break; + default: + sysError("unimplemented constant", "pushConstant"); + return(false); + } + return(true); +} + +/* +Stores the value on the top of the process stack into of one of the +receiver's instance variables. The instruction operand denotes which +one. Note that this doesn't pop the value from the stack. +*/ +bool byteAssignInstance(execState* es, int low) +{ + receiverAtPut(es, low, stackTop(es)); + return(true); +} + +/* +Stores the value on the top of the process stack into of one of the +method's temporary variables. The instruction operand denotes which +one. Note that this doesn't pop the value from the stack. +*/ +bool byteAssignTemporary(execState* es, int low) +{ + temporaryAtPut(es, low, stackTop(es)); + return(true); +} + +/* +Computes the offset within the process stack at which a returned object +will replace the receiver and arguments of a message. +*/ +bool byteMarkArguments(execState* es, int low) +{ + es->returnPoint = (stackInUse(es) - low) + 1; + es->timeSliceCounter++; /* make sure we do send */ + return(true); +} + +inline encPtr firstLookupClass(execState* es) +{ + es->argb = es->psb + (es->returnPoint - 1); + fetchReceiverState(es); + return(getClass(es->receiverObject)); +} + +encPtr messageToSend = {true,0}; + +int messTest(encPtr obj) +{ + return(ptrEq((objRef) obj, (objRef) messageToSend)); +} + +bool findMethod(encPtr* methodClassLocation) +{ + encPtr methodTable, + methodClass; + + method = nilObj; + methodClass = *methodClassLocation; + + for (; ptrNe((objRef) methodClass, (objRef) nilObj); methodClass = + orefOf(methodClass, superClassInClass).ptr) { + methodTable = orefOf(methodClass, methodsInClass).ptr; + if (ptrEq((objRef) methodTable, (objRef) nilObj)) { /*fix*/ + methodTable = newDictionary(MethodTableSize); + orefOfPut(methodClass, methodsInClass, (objRef) methodTable); + } + method = hashEachElement(methodTable, oteIndexOf(messageToSend), messTest); + if (ptrNe((objRef) method, (objRef) nilObj)) + break; + } + + if (ptrEq((objRef) method, (objRef) nilObj)) { /* it wasn't found */ + methodClass = *methodClassLocation; + return false; + } + *methodClassLocation = methodClass; + return true; +} + +#define cacheSize 211 + +struct { + encPtr cacheMessage; /* the message being requested */ + encPtr lookupClass; /* the class of the receiver */ + encPtr cacheClass; /* the class of the method */ + encPtr cacheMethod; /* the method itself */ +} methodCache[cacheSize] = {}; + +void flushCache(encPtr messageToSend, encPtr class) +{ + int i; + for(i = 0; i != cacheSize; i++) + if(ptrEq((objRef) methodCache[i].cacheMessage, (objRef) messageToSend)) + methodCache[i].cacheMessage = nilObj; +} + +bool lookupGivenSelector(execState* es, encPtr methodClass) +{ + int hash; + int j; + encPtr argarray; + objRef returnedObject; + if(mselTrace) + fprintf(stderr, "%d: %s\n",mselTrace--,(char*)addressOf(messageToSend)); + /* look up method in cache */ + hash = (oteIndexOf(messageToSend) + oteIndexOf(methodClass)) % cacheSize; + assert(hash >= 0 && hash < cacheSize); + if (ptrEq((objRef) methodCache[hash].cacheMessage, (objRef) messageToSend) && + ptrEq((objRef) methodCache[hash].lookupClass, (objRef) methodClass)) { + method = methodCache[hash].cacheMethod; + methodClass = methodCache[hash].cacheClass; + assert(isAvail(method) == false); + } else { + methodCache[hash].lookupClass = methodClass; + if (!findMethod(&methodClass)) { + /* not found, we invoke a smalltalk method */ + /* to recover */ + j = stackInUse(es) - es->returnPoint; + argarray = newArray(j + 1); + for (; j >= 0; j--) { + returnedObject = ipop(es); + orefOfPut(argarray, j + 1, returnedObject); + } + ipush(es, orefOf(argarray, 1)); /* push receiver back */ + ipush(es, (objRef) messageToSend); + messageToSend = newSymbol("message:notRecognizedWithArguments:"); + ipush(es, (objRef) argarray); + /* try again - if fail really give up */ + if (!findMethod(&methodClass)) { + sysWarn("can't find", "error recovery method"); + /* just quit */ + return false; + } + } + methodCache[hash].cacheMessage = messageToSend; + methodCache[hash].cacheMethod = method; + methodCache[hash].cacheClass = methodClass; + } + return(true); +} + +bool watching = 0; + +bool lookupWatchSelector(execState* es) +{ + int j; + encPtr argarray; + objRef returnedObject; + encPtr methodClass; + if (watching && ptrNe(orefOf(method, watchInMethod), (objRef) nilObj)) { + /* being watched, we send to method itself */ + j = stackInUse(es) - es->returnPoint; + argarray = newArray(j + 1); + for (; j >= 0; j--) { + returnedObject = ipop(es); + orefOfPut(argarray, j + 1, returnedObject); + } + ipush(es, (objRef) method); /* push method */ + ipush(es, (objRef) argarray); + messageToSend = newSymbol("watchWith:"); + /* try again - if fail really give up */ + methodClass = classOf(method); + if (!findMethod(&methodClass)) { + sysWarn("can't find", "watch method"); + /* just quit */ + return false; + } + } + return(true); +} + +encPtr growProcessStack(int top, int toadd) +{ + int size, + i; + encPtr newStack; + + if (toadd < 128) + toadd = 128; + size = countOf(processStack) + toadd; + newStack = newArray(size); + for (i = 1; i <= top; i++) { + orefOfPut(newStack, i, orefOf(processStack, i)); + } + return newStack; +} + +void pushStateAndEnter(execState* es) +{ + int i; + int j; + /* save the current byte pointer */ + orefOfPut(processStack, linkPointer + 4, (objRef) encValueOf(es->byteOffset)); + /* make sure we have enough room in current process */ + /* stack, if not make stack larger */ + i = 6 + methodTempSize(method) + methodStackSize(method); + j = stackInUse(es); + if ((j + i) > countOf(processStack)) { + processStack = growProcessStack(j, i); + es->psb = addressOf(processStack); + es->pst = (es->psb + j); + orefOfPut(es->processObject, stackInProcess, (objRef) processStack); + } + es->byteOffset = 1; + /* now make linkage area */ + /* position 0 : old linkage pointer */ + ipush(es, (objRef) encValueOf(linkPointer)); + linkPointer = stackInUse(es); + /* position 1 : context obj (nil means stack) */ + ipush(es, (objRef) nilObj); + es->contextObject = processStack; + es->cxtb = es->psb; + /* position 2 : return point */ + ipush(es, (objRef) encValueOf(es->returnPoint)); + es->argb = es->cxtb + (es->returnPoint - 1); + /* position 3 : method */ + ipush(es, (objRef) method); + /* position 4 : bytecode counter */ + ipush(es, (objRef) encValueOf(es->byteOffset)); + /* then make space for temporaries */ + es->tmpb = es->pst + 1; + es->pst += methodTempSize(method); + fetchMethodState(es); +#if 0 + /* break if we are too big and probably looping */ + if (countOf(processStack) > 4096) + es->timeSliceCounter = 0; +#endif +} + +inline bool lookupAndEnter(execState* es, encPtr methodClass) +{ + if(!lookupGivenSelector(es, methodClass)) + return(false); + if(!lookupWatchSelector(es)) + return(false); + pushStateAndEnter(es); + return(true); +} + +/* +Looks for a Method corresponding to the combination of a prospective +receiver's class and a symbol denoting some desired behavior. The +instruction operand denotes which symbol. Changes the execution state +of the interpreter such that the next bytecode executed will be that of +the Method located, if possible, in an appropriate context. See also +"byteSendUnary", "byteSendBinary" and "byteDoSpecial". +*/ +bool byteSendMessage(execState* es, int low) +{ + encPtr methodClass; + messageToSend = literalAt(es, low).ptr; + methodClass = firstLookupClass(es); + return(lookupAndEnter(es, methodClass)); +} + +/* +Handles certain special cases of messages involving one object. See +also "byteSendMessage", "byteSendBinary" and "byteDoSpecial". +*/ +bool byteSendUnary(execState* es, int low) +{ + encPtr methodClass; + /* do isNil and notNil as special cases, since */ + /* they are so common */ + if ((!watching) && (low >= 0 && low <= 1)) { + switch(low) { + case 0: /* isNil */ + stackTopPut(es, (objRef) ( + ptrEq(stackTop(es), (objRef) nilObj) ? trueObj : falseObj ) ); + return(true); + case 1: /* notNil */ + stackTopPut(es, (objRef) ( + ptrEq(stackTop(es), (objRef) nilObj) ? falseObj : trueObj ) ); + return(true); + } + } + es->returnPoint = stackInUse(es); + messageToSend = unSyms[low]; + methodClass = firstLookupClass(es); + return(lookupAndEnter(es, methodClass)); +} + +/* +Handles certain special cases of messages involving two objects. See +also "byteSendMessage", "byteSendUnary" and "byteDoSpecial". +*/ +bool byteSendBinary(execState* es, int low) +{ + objRef* primargs; + objRef returnedObject; + encPtr methodClass; + /* optimized as long as arguments are int */ + /* and conversions are not necessary */ + /* and overflow does not occur */ + if ((!watching) && (low >= 0 && low <= 12)) { + if(primTrace) + fprintf(stderr, "%d: <%d>\n",primTrace--,low+60); + primargs = es->pst - 1; + returnedObject = primitive(low + 60, primargs); + if (ptrNe(returnedObject, (objRef) nilObj)) { + /* pop arguments off stack , push on result */ + stackTopFree(es); + stackTopPut(es, returnedObject); + return(true); + } + } + es->returnPoint = stackInUse(es) - 1; + messageToSend = binSyms[low]; + methodClass = firstLookupClass(es); + return(lookupAndEnter(es, methodClass)); +} + +/* +Calls a routine to evoke some desired behavior which is not implemented +in the form of a Method. +*/ +bool byteDoPrimitive(execState* es, int low) +{ + objRef* primargs; + int i; + objRef returnedObject; + /* low gives number of arguments */ + /* next byte is primitive number */ + primargs = (es->pst - low) + 1; + /* next byte gives primitive number */ + i = nextByte(es); + if(primTrace) + fprintf(stderr, "%d: <%d>\n",primTrace--,i); + returnedObject = primitive(i, primargs); + /* pop off arguments */ + while (low-- > 0) { + if(isIndex(stackTop(es))) + isVolatilePut(stackTop(es).ptr, false); + stackTopFree(es); + } + ipush(es, returnedObject); + return(true); +} + +bool leaveAndAnswer(execState* es, objRef returnedObject) +{ + es->returnPoint = intValueOf(orefOf(processStack, linkPointer + 2).val); + linkPointer = intValueOf(orefOf(processStack, linkPointer).val); + while (stackInUse(es) >= es->returnPoint) { + if(isIndex(stackTop(es))) + isVolatilePut(stackTop(es).ptr, false); + stackTopFree(es); + } + ipush(es, returnedObject); + /* now go restart old routine */ + if (linkPointer) { + fetchLinkageState(es); + fetchReceiverState(es); + fetchMethodState(es); + return(true); + } + else + return(false); /* all done */ +} + +/* +Handles operations which aren't handled in other ways. The instruction +operand denotes which operation. Returning objects changes the +execution state of the interpreter such that the next bytecode executed +will be that of the Method which is to process the returned object, if +possible, in an appropriate context. See also "byteSendMessage" +"byteSendUnary" and "byteSendBinary". Various facilities such as +cascaded messages and optimized control structures involve tinkering +with the top of the process stack and the "instruction counter". +Sending messages to "super" changes the first class to be searched for a +Method from that of the prospective receiver to the superclass of that +in which the executing Method is located, if possible. +*/ +bool byteDoSpecial(execState* es, int low) +{ + objRef returnedObject; + int i; + encPtr methodClass; + switch (low) { + case SelfReturn: + returnedObject = argumentAt(es, 0); + return(leaveAndAnswer(es, returnedObject)); + case StackReturn: + returnedObject = ipop(es); + return(leaveAndAnswer(es, returnedObject)); + case Duplicate: + /* avoid possible subtle bug */ + returnedObject = stackTop(es); + ipush(es, returnedObject); + return(true); + case PopTop: + returnedObject = ipop(es); + if(isIndex(returnedObject)) + isVolatilePut(returnedObject.ptr, false); + return(true); + case Branch: + /* avoid a subtle bug here */ + i = nextByte(es); + es->byteOffset = i; + return(true); + case BranchIfTrue: + returnedObject = ipop(es); + i = nextByte(es); + if (ptrEq(returnedObject, (objRef) trueObj)) { + /* leave nil on stack */ + es->pst++; + es->byteOffset = i; + } + return(true); + case BranchIfFalse: + returnedObject = ipop(es); + i = nextByte(es); + if (ptrEq(returnedObject, (objRef) falseObj)) { + /* leave nil on stack */ + es->pst++; + es->byteOffset = i; + } + return(true); + case AndBranch: + returnedObject = ipop(es); + i = nextByte(es); + if (ptrEq(returnedObject, (objRef) falseObj)) { + ipush(es, returnedObject); + es->byteOffset = i; + } + return(true); + case OrBranch: + returnedObject = ipop(es); + i = nextByte(es); + if (ptrEq(returnedObject, (objRef) trueObj)) { + ipush(es, returnedObject); + es->byteOffset = i; + } + return(true); + case SendToSuper: + i = nextByte(es); + messageToSend = literalAt(es, i).ptr; + (void) firstLookupClass(es); /* fix? */ + methodClass = orefOf(method, methodClassInMethod).ptr; + /* 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 = orefOf(methodClass, superClassInClass); + if (ptrNe(returnedObject, (objRef) nilObj)) + methodClass = returnedObject.ptr; + return(lookupAndEnter(es, methodClass)); + default: + sysError("invalid doSpecial", ""); + return(false); + } +} + +typedef bool bytecodeMethod(execState* es, int low); + +#define byteVectLob 0 +#define byteVectHib 15 +#define byteVectDom ((byteVectHib + 1) - byteVectLob) + +bytecodeMethod* bytecodeVector[byteVectDom] = { +/*00*/ &unsupportedByte, +/*01*/ &bytePushInstance, +/*02*/ &bytePushArgument, +/*03*/ &bytePushTemporary, +/*04*/ &bytePushLiteral, +/*05*/ &bytePushConstant, +/*06*/ &byteAssignInstance, +/*07*/ &byteAssignTemporary, +/*08*/ &byteMarkArguments, +/*09*/ &byteSendMessage, +/*10*/ &byteSendUnary, +/*11*/ &byteSendBinary, +/*12*/ &unsupportedByte, +/*13*/ &byteDoPrimitive, +/*14*/ &unsupportedByte, +/*15*/ &byteDoSpecial +}; + +encPtr processStack = {true,0}; + +int linkPointer = 0; + +void fetchProcessState(execState* es) +{ + int j; + processStack = orefOf(es->processObject, stackInProcess).ptr; + es->psb = addressOf(processStack); + j = intValueOf(orefOf(es->processObject, stackTopInProcess).val); + es->pst = es->psb + (j - 1); + linkPointer = intValueOf(orefOf(es->processObject, linkPtrInProcess).val); +} + +void storeProcessState(execState* es) +{ + orefOfPut(es->processObject, stackInProcess, (objRef) processStack); + orefOfPut(es->processObject, stackTopInProcess, (objRef) encValueOf(stackInUse(es))); + orefOfPut(es->processObject, linkPtrInProcess, (objRef) encValueOf(linkPointer)); +} + +word traceVect[traceSize] = {}; + +bool execute(encPtr aProcess, int maxsteps) +{ + execState es = {}; + + es.processObject = aProcess; + es.timeSliceCounter = maxsteps; + counterAddress = &es.timeSliceCounter; + + fetchProcessState(&es); + fetchLinkageState(&es); + fetchReceiverState(&es); + fetchMethodState(&es); + + while (--es.timeSliceCounter > 0) { + int low; + int high; + low = (high = nextByte(&es)) & 0x0F; + high >>= 4; + if (high == 0) { + high = low; + low = nextByte(&es); + } + if(execTrace) + fprintf(stderr, "%d: %d %d\n",execTrace--,high,low); + if(high >= byteVectLob && high <= byteVectHib) + { + bytecodeMethod* byteMethPtr = bytecodeVector[high]; + if(byteMethPtr) { + if(!(*byteMethPtr)(&es, low)) + return(false); + continue; + } + } + if(!unsupportedByte(&es, low)) + return(false); + } + + orefOfPut(processStack, linkPointer + 4, (objRef) encValueOf(es.byteOffset)); + storeProcessState(&es); + + return(true); +} + +void makeInitialImage(void) +{ + encPtr hashTable; + encPtr symbolObj; + encPtr symbolClass; /*shadows global for a reason*/ + encPtr metaclassClass; + encPtr linkClass; + + nilObj = allocOrefObj(0); + assert(oteIndexOf(nilObj) == 1); + + trueObj = allocOrefObj(0); + assert(oteIndexOf(trueObj) == 2); + falseObj = allocOrefObj(0); + assert(oteIndexOf(falseObj) == 3); + + /* create the symbol table */ + + hashTable = allocOrefObj(3 * 53); + assert(oteIndexOf(hashTable) == 4); + symbols = allocOrefObj(1); + assert(oteIndexOf(symbols) == 5); + orefOfPut(symbols, 1, (objRef) hashTable); + + /* create #Symbol, Symbol[Meta] and Metaclass[Meta] */ + + symbolObj = newSymbol("Symbol"); +#if 0 + assert(ptrEq(classOf(symbolObj),nilObj)); + assert(ptrEq(globalValue("Symbol"),nilObj)); +#endif + symbolClass = newClass("Symbol"); +#if 0 + assert(ptrNe(classOf(symbolClass),nilObj)); + assert(ptrEq(classOf(classOf(symbolClass)),nilObj)); + assert(ptrEq(globalValue("Symbol"),symbolClass)); +#endif + classOfPut(symbolObj, symbolClass); + classOfPut(newSymbol("SymbolMeta"), symbolClass); + metaclassClass = newClass("Metaclass"); +#if 0 + assert(ptrNe(classOf(metaclassClass),nilObj)); + assert(ptrEq(classOf(classOf(metaclassClass)),nilObj)); + assert(ptrEq(globalValue("Metaclass"),metaclassClass)); +#endif + classOfPut(classOf(symbolClass), metaclassClass); + classOfPut(classOf(metaclassClass), metaclassClass); + + /* patch the class fields of nil, true and false */ + /* set their global values */ + + classOfPut(nilObj, newClass("UndefinedObject")); + nameTableInsert(symbols, strHash("nil"), newSymbol("nil"), nilObj); + classOfPut(trueObj, newClass("True")); + nameTableInsert(symbols, strHash("true"), newSymbol("true"), trueObj); + classOfPut(falseObj, newClass("False")); + nameTableInsert(symbols, strHash("false"), newSymbol("false"), falseObj); + + /* patch the class fields of the symbol table links */ + /* make the symbol table refer to itself */ /*fix?*/ + + linkClass = newClass("Link"); + { + word ord = 0; + word hib = countOf(hashTable); + for( ; ord != hib; ord += 3) { + encPtr link = orefOf(hashTable, ord + 3).ptr; + while(ptrNe((objRef) link, (objRef) nilObj)) { + if(ptrEq((objRef) classOf(link), (objRef) nilObj)) + classOfPut(link, linkClass); + else + assert(ptrEq((objRef) classOf(link), (objRef) linkClass)); + link = orefOf(link, 3).ptr; + } + } + } + classOfPut(hashTable, newClass("Array")); + classOfPut(symbols, newClass("SymbolTable")); + nameTableInsert(symbols, strHash("symbols"), newSymbol("symbols"), symbols); + + /* graft a skeleton metaclass tree to a skeleton class tree */ + { + encPtr objectInst = newClass("Object"); + encPtr classInst = newClass("Class"); + orefOfPut(classOf(objectInst), superClassInClass, (objRef) classInst); + } + + /* create other skeleton classes */ + +/*(void) newClass("Array");*/ + (void) newClass("Block"); + (void) newClass("ByteArray"); + (void) newClass("Char"); + (void) newClass("Context"); + (void) newClass("Dictionary"); + (void) newClass("Float"); +/*(void) newClass("Link");*/ +/*(void) newClass("Metaclass");*/ + (void) newClass("Method"); + (void) newClass("String"); +/*(void) newClass("Symbol");*/ + +} + +void goDoIt(char* text) +{ + encPtr method; + encPtr process; + encPtr stack; + + method = newMethod(); + setInstanceVariables(nilObj); + (void) parse(method, text, false); + + process = allocOrefObj(processSize); + stack = allocOrefObj(50); + + /* make a process */ + orefOfPut(process, stackInProcess, (objRef) stack); + orefOfPut(process, stackTopInProcess, (objRef) encValueOf(10)); + orefOfPut(process, linkPtrInProcess, (objRef) encValueOf(2)); + + /* put argument on stack */ + orefOfPut(stack, 1, (objRef) nilObj); /* argument */ + /* now make a linkage area in stack */ + orefOfPut(stack, 2, (objRef) encValueOf(0)); /* previous link */ + orefOfPut(stack, 3, (objRef) nilObj); /* context object (nil => stack) */ + orefOfPut(stack, 4, (objRef) encValueOf(1)); /* return point */ + orefOfPut(stack, 5, (objRef) method); /* method */ + orefOfPut(stack, 6, (objRef) encValueOf(1)); /* byte offset */ + + /* now go execute it */ + while (execute(process, 1 << 14)) + fprintf(stderr, "."); + + /* get rid of unwanted process */ + isVolatilePut(process, false); +} + +int main_1(int argc, char* argv[]) +{ + char methbuf[4096]; + int i; + + sysWarn("\nPublic Domain Smalltalk", ""); + + coldObjectTable(); + + makeInitialImage(); + + initCommonSymbols(); + + for (i = 1; i < argc; i++) { + fprintf(stderr, "%s:\n", argv[i]); + (void) sprintf(methbuf, + "goDoIt <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"); +#if 0 + execTrace = 16; + primTrace = 16; + mselTrace = 16; +#endif + goDoIt("goDoIt nil initialize\n"); + fprintf(stderr, "finished\n"); + + return 0; +} + +int main_2(int argc, char* argv[]) +{ + FILE *fp; + encPtr firstProcess; + char *p, + buffer[4096]; + + sysWarn("\nPublic Domain Smalltalk", ""); + + warmObjectTableOne(); + + strcpy(buffer, "systemImage"); + p = buffer; + if (argc != 1) + p = argv[1]; + + fp = fopen(p, "rb"); + if (fp == NULL) { + sysError("cannot open image", p); + return(1); + } + + if(ptrNe((objRef) imageRead(fp), (objRef) trueObj)) { + sysError("cannot read image", p); + return(1); + } + + (void) fclose(fp); + + warmObjectTableTwo(); + + initCommonSymbols(); + + firstProcess = globalValue("systemProcess"); + if (ptrEq((objRef) firstProcess, (objRef) nilObj)) { + sysError("no initial process", "in image"); + return(1); + } + +/* execute the main system process loop repeatedly */ + + while (execute(firstProcess, 1 << 14)) ; + + return 0; +} + +void compilError(char* selector, char* str1, char* str2) +{ + (void) fprintf(stderr, "compiler error: Method %s : %s %s\n", + selector, str1, str2); + parseOk = false; +} + +void compilWarn(char* selector, char* str1, char* str2) +{ + (void) fprintf(stderr, "compiler warning: Method %s : %s %s\n", + selector, str1, str2); +} + +void sysError(char* s1, char* s2) +{ + (void) fprintf(stderr, "%s\n%s\n", s1, s2); + (void) abort(); +} + +void sysWarn(char* s1, char* s2) +{ + (void) fprintf(stderr, "%s\n%s\n", s1, s2); +} + +int main(int argc, char* argv[]) +{ + int ans = 1; + logTag = fopen("transcript","ab"); + if(argc > 1 && streq(argv[1],"-c")) { + argv[1] = argv[0]; + argc--; + argv++; + ans = main_1(argc, argv); + } + if(argc > 1 && streq(argv[1],"-w")) { + argv[1] = argv[0]; + argc--; + argv++; + ans = main_2(argc, argv); + } +#if 0 + fprintf(stderr,"%s?\n", + (char*)addressOf(orefOf(encIndexOf(100),nameInClass).ptr)); +#endif + if(ans == 0) { + FILE* tag; + tag = fopen("snapshot", "wb"); + if(tag != NULL) { + reclaim(false); + if(ptrNe((objRef) imageWrite(tag), (objRef) trueObj)) + ans = 2; + (void) fclose(tag); + } + else + ans = 2; + } + if(logTag != NULL) + (void) fclose(logTag); + return(ans); +} diff --git a/queen.st b/queen.st new file mode 100644 index 0000000..daeaf83 --- /dev/null +++ b/queen.st @@ -0,0 +1,50 @@ +Object + subclass: #NullQueen + instanceVariableNames: ''! +{! +NullQueen methods! + checkRow: row column: column + " we can't attack anything " + + ^ false! + first + ^ true! + next + ^ true! + result + ^ List new! +}! +Object + subclass: #Queen + instanceVariableNames: 'row column neighbor'! +{! +Queen methods! + advance + (row = 8) + ifTrue: [ (neighbor next) ifFalse: [ ^ false ]. + row <- 0 ]. + row <- row + 1. + ^ true! + 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 ]! + result + ^ neighbor result addLast: row! + setColumn: aNumber neighbor: aQueen + column <- aNumber. + neighbor <- aQueen! + testPosition + [neighbor checkRow: row column: column] + whileTrue: [ (self advance) ifFalse: [ ^ false ]]. + ^ true! +}! diff --git a/test1.kbd b/test1.kbd new file mode 100644 index 0000000..debc6ff --- /dev/null +++ b/test1.kbd @@ -0,0 +1,3 @@ +stdout print: 'echoInput <- true'. echoInput <- true +File new fileIn: 'test1.st' +Test1 new all diff --git a/test1.st b/test1.st new file mode 100644 index 0000000..2320576 --- /dev/null +++ b/test1.st @@ -0,0 +1,123 @@ +test1note <- ' +Derived from: + Little Smalltalk, version 2 + Written by Tim Budd, Oregon State University, July 1987 + +Function: + A few test cases. + +Example: + File new fileIn: ''test1.st'' + Test1 new all'! +Object + subclass: #One + instanceVariableNames: ''! +{! +One methods! + result1 + ^ self test! + test + ^ 1! +}! +One + subclass: #Two + instanceVariableNames: ''! +{! +Two methods! + test + ^ 2! +}! +Two + subclass: #Three + instanceVariableNames: ''! +{! +Three methods! + result2 + ^ self result1! + result3 + ^ super test! +}! +Three + subclass: #Four + instanceVariableNames: ''! +{! +Four methods! + test + ^ 4! +}! +Object + subclass: #Test1 + instanceVariableNames: ''! +{! +Test1 methods! + all + self super. + self conversions. + self collections. + self factorial. + self filein. + 'all tests completed' 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.! + 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.! + 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 name: 'queen.st' open: 'r') fileIn; close. + ( (#QueenMeta value class ~~ Metaclass) + or: [ (#Queen value class ~~ #QueenMeta value) + or: [#Queen value name ~~ #Queen] ] ) + ifTrue: [ smalltalk error: 'fileIn failure']. + ((classes includesKey: #Queen) and: [(classes at: #Queen) == Queen]) + ifFalse: [ smalltalk error: 'fileIn failure']. + 'file in test passed' print. + self queen! + queen | lastQueen | + lastQueen <- NullQueen new. + (1 to: 8) do: [:i | lastQueen <- Queen new + setColumn: i neighbor: lastQueen; + yourself ]. + 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']! + 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']! + 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; + yourself! +}! diff --git a/test2.kbd b/test2.kbd new file mode 100644 index 0000000..6473b84 --- /dev/null +++ b/test2.kbd @@ -0,0 +1,4 @@ +stdout print: 'echoInput <- true'. echoInput <- true +File new fileIn: 'test2.st' +Test2 new tryOne +Test2 new tryAll diff --git a/test2.st b/test2.st new file mode 100644 index 0000000..61f1cb1 --- /dev/null +++ b/test2.st @@ -0,0 +1,76 @@ +Object + subclass: #Test2 + instanceVariableNames: ''! +{! +Test2 methods! +on: s + "try all classes" + | f t k | + (f <- File name: s mode: 'w') open. + t <- 9 asCharacter asString. + k <- classes sort: [ :x :y | x name asString < y name asString ]. + k do: [ :e | self on: f tab: t put: e ]. + f close! +on: s put: c + "try one class" + | f t | + (f <- File name: s mode: 'w') open. + t <- 9 asCharacter asString. + self on: f tab: t putCN: c. + self on: f tab: t putSN: c. + self on: f tab: t putVN: c. + self on: f tab: t putCM: c. + self on: f tab: t putIM: c. + f close! +on: f tab: t put: c + "try all classes" + self on: f tab: t putCN: c. + self on: f tab: t putSN: c. + self on: f tab: t putVN: c. + self on: f tab: t putCM: c. + self on: f tab: t putIM: c! +on: f tab: t putCM: c + | n v | + n <- 10 asCharacter. + f print: 'class methods'. + v <- c class methods sort: [ :x :y | x name asString < y name asString ]. + f print: '==='. + v do: [ :e | + f print: e trimmedText. + f print: '===' ]! +on: f tab: t putCN: c + f print: 'class name' , t , c name asString! +on: f tab: t putIM: c + | n v | + n <- 10 asCharacter. + f print: 'methods'. + v <- c methods sort: [ :x :y | x name asString < y name asString ]. + f print: '==='. + v do: [ :e | + f print: e trimmedText. + f print: '===' ]! +on: f tab: t putSN: c + | v | + v <- c superClass. + v isNil ifTrue: [ + v <- '' ] + ifFalse: [ + v <- v asString ]. + f print: 'superclass name' , t , v! +on: f tab: t putVN: c + | v | + v <- c variables. + v isNil ifTrue: [ + v <- #('') ] + ifFalse: [ + v <- (v collect: [ :e | e asString ]) sort ]. + v inject: 'variable names' into: [ :x :y | + f print: x , t , y. + ' ' ]! +tryAll + "try all classes" + self on: 'test2.all.out'! +tryOne + "try one class" + self on: 'test2.one.out' put: self class! +}!