From fce0bdb74237395657f551458733876edf21ff6f Mon Sep 17 00:00:00 2001 From: Zak Yani Star Fenton Date: Tue, 10 Jun 2025 22:41:13 +1000 Subject: [PATCH] Initial commit of unchanged sources from pdst version 0004 as found in pdst_20070506_01.zip at https://github.com/kyle-github/littlesmalltalk/tree/master/archive NOTE: This version doesn't build out of the box on modern compilers, needs a couple of small fixes. --- Makefile | 34 + initial.st | 2974 ++++++++++++++++++++++++++++++++ pdst.c | 4784 ++++++++++++++++++++++++++++++++++++++++++++++++++++ queen.st | 50 + test1.kbd | 3 + test1.st | 123 ++ test2.kbd | 4 + test2.st | 76 + 8 files changed, 8048 insertions(+) create mode 100644 Makefile create mode 100644 initial.st create mode 100644 pdst.c create mode 100644 queen.st create mode 100644 test1.kbd create mode 100644 test1.st create mode 100644 test2.kbd create mode 100644 test2.st 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! +}!