Squeak-dev September 2009

squeak-dev@lists.squeakfoundation.org

119 participants
370 discussions

The Trunk: Compiler-ar.80.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

Andreas Raab uploaded a new version of Compiler to project The Trunk: http://source.squeak.org/trunk/Compiler-ar.80.mcz ==================== Summary ==================== Name: Compiler-ar.80 Author: ar Time: 5 September 2009, 10:06:25 am UUID: 82001507-c038-784a-a4e2-0c969b53800f Ancestors: Compiler-eem.79 Add an initialize method working around the limitations of MCDs and scripts. =============== Diff against Compiler-eem.79 =============== Item was added: + ----- Method: Compiler class>>initialize (in category 'class initialization') ----- + initialize + "For the benefit of MC running a required script in the proper order." + #('Compiler' 'Kernel' 'System') do:[:pkgName| + Transcript nextPutAll: pkgName; cr; flush. + (PackageInfo named: pkgName) methods + do: [:ea | ea actualClass recompile: ea methodSymbol] + displayingProgress: 'Recompiling ', pkgName,'...'] + + !

1 0

Re: [squeak-dev] The Trunk: Kernel-ar.238.mcz
by Michael van der Gulik 06 Sep '09

06 Sep '09

On Fri, 4 Sep 2009 04:51:35 0000, commits(a)source.squeak.org <commits(a)source.squeak.org> wrote: > Andreas Raab uploaded a new version of Kernel to project The Trunk: > http://source.squeak.org/trunk/Kernel-ar.238.mcz > > ==================== Summary ==================== > > Name: Kernel-ar.238 > Author: ar > Time: 3 September 2009, 9:50:51 am > UUID: 9896c3f8-760f-e942-ac84-5f6c9127150c > Ancestors: Kernel-ar.237 > > http://bugs.squeak.org/view.php?id=7321 > > Change Set: AtomicProcessSuspend > Date: 23 March 2009 > Author: Andreas Raab > > In-image support for atomic process suspend. > > =============== Diff against Kernel-ar.237 =============== > > Item was changed: > ----- Method: Process>>suspend (in category 'changing process state') > ----- > suspend > + "Primitive. Stop the process that the receiver represents in such a way > - "Stop the process that the receiver represents in such a way > that it can be restarted at a later time (by sending the receiver the > message resume). If the receiver represents the activeProcess, suspend > it. > + Otherwise remove the receiver from the list of waiting processes. > + The return value of this method is the list the receiver was previously > on (if any)." > + | oldList | > + <primitive: 88> > + "This is fallback code for VMs which only support the old > primitiveSuspend which > + would not accept processes that are waiting to be run." > + myList ifNil:[^nil]. "this allows us to use suspend multiple times" > + oldList := myList. > + myList := nil. > + oldList remove: self ifAbsent:[]. > + ^oldList! > - Otherwise remove the receiver from the list of waiting processes." > - > - self isActiveProcess ifTrue: [ > - myList := nil. > - self primitiveSuspend. > - ] ifFalse: [ > - myList ifNotNil: [ > - myList remove: self ifAbsent: []. > - myList := nil]. > - ] > - ! > > Item was changed: > ----- Method: Process>>offList (in category 'accessing') ----- > offList > + "OBSOLETE. Process>>suspend will atomically reset myList if the process > is suspended. > + There should never be a need to send #offList but some older users may > not be aware > + of the changed semantics to suspend and may try the old hickadidoo seen > here: > - "Inform the receiver that it has been taken off a list that it was > - suspended on. This is to break a backpointer." > > + (suspendingList := process suspendingList) == nil > + ifTrue: [process == Processor activeProcess ifTrue: [process suspend]] > + ifFalse: [suspendingList remove: process ifAbsent:[]. > + process offList]. > + > + Usages like the above should be replaced by a simple 'process suspend' " > myList := nil! > > Item was changed: > ----- Method: Process>>terminate (in category 'changing process state') > ----- > terminate > "Stop the process that the receiver represents forever. Unwind to > execute pending ensure:/ifCurtailed: blocks before terminating." > > + | ctxt unwindBlock oldList | > - | ctxt unwindBlock inSema | > self isActiveProcess ifTrue: [ > ctxt := thisContext. > [ ctxt := ctxt findNextUnwindContextUpTo: nil. > ctxt isNil > ] whileFalse: [ > unwindBlock := ctxt tempAt: 1. > unwindBlock ifNotNil: [ > ctxt tempAt: 1 put: nil. > thisContext terminateTo: ctxt. > unwindBlock value]. > ]. > thisContext terminateTo: nil. > + self suspend. > + ] ifFalse:[ > + myList ifNotNil:[oldList := self suspend]. > + suspendedContext ifNotNil:[ > - myList := nil. > - self primitiveSuspend. > - ] ifFalse: [ > - "Since the receiver is not the active process, drop its priority to > rock-bottom so that > - it doesn't accidentally preempt the process that is trying to terminate > it." > - priority := 10. I admit not fully understanding everything here, but should you perhaps have kept the priority drop here? Otherwise, by my understanding, the process that is meant to be terminated might be restarted in this line here before it gets suspended: > + myList ifNotNil:[oldList := self suspend]. Gulik. -- http://gulik.pbwiki.com/

2 1

The Trunk: Kernel-eem.243.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

Andreas Raab uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.243.mcz ==================== Summary ==================== Name: Kernel-eem.243 Author: eem Time: 5 September 2009, 5:01:43 am UUID: 951890ea-0d23-473a-b538-f518d9ba5331 Ancestors: Kernel-eem.242 Fifth package of eight in closure compiler fixes 9/5/2009. Change kernel to use closure compiler fixes: - Replace old temp names compression scheme with the new one. - restore strange selector replacement in CompiledMethod>>getSourceFor:in: - remove unused CompiledMethod>>primitiveNode (and thence PrimitiveNode) =============== Diff against Kernel-eem.242 =============== Item was changed: ----- Method: CompiledMethod>>getSourceFor:in: (in category 'source code management') ----- getSourceFor: selector in: class "Retrieve or reconstruct the source code for this method." + | flagByte source | - | flagByte | flagByte := self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" and: [((1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0])]]) ifTrue: ["No source pointer -- decompile without temp names" ^ (class decompilerClass new decompile: selector in: class method: self) decompileString]. flagByte < 252 ifTrue: ["Magic sources -- decompile with temp names" ^ ((class decompilerClass new withTempNames: self tempNamesString) decompile: selector in: class method: self) decompileString]. "Situation normal; read the sourceCode from the file" + + source := [self getSourceFromFile] + on: Error + "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." + do: [ :ex | ex return: nil]. + + ^source + ifNotNil: + [| sourceSelector | + "I think this is something to do with the traits system. It would be ncie if someone + documented this. It looks like an egregious hack to me. eem 9/5/2009 09:04" + sourceSelector := Parser parserClass new parseSelector: source. + sourceSelector = selector + ifTrue: [source] + ifFalse: [self replace: sourceSelector with: selector in: source]] + ifNil: + ["Something really wrong -- decompile blind (no temps)" + (class decompilerClass new decompile: selector in: class method: self) + decompileString]! - ^self getSourceFromFile ifNil: - ["Something really wrong -- decompile blind (no temps)" - (class decompilerClass new decompile: selector in: class method: self) - decompileString]! Item was added: + ----- Method: MethodProperties>>method: (in category 'forward compatibility') ----- + method: ignored + "For forward compatibility wth AdditionalMethodState, for decompilation"! Item was changed: ----- Method: CompiledMethod>>copyWithTempNames: (in category 'source code management') ----- copyWithTempNames: tempNames + "Minimal temp name copy that only works for methods containing no temporaries or blocks with arguments. + Used by the Traits system for creating conflict and required methdos that generate warnings. + For generic use use copyWithTempsFromMethodNode:" + | tempString | + tempString := String streamContents: + [:str| + tempNames + do: [:temp| str nextPutAll: temp] + separatedBy: [str space]. + str space]. + ^self copyWithTrailerBytes: (self qCompress: tempString)! - | tempStr compressed | - tempStr := String streamContents: - [:strm | tempNames do: [:n | strm nextPutAll: n; space]]. - compressed := self qCompress: tempStr firstTry: true. - compressed ifNil: - ["failure case (tempStr too big) will just decompile with tNN names" - ^ self copyWithTrailerBytes: #(0 0 0 0)]. - ^ self copyWithTrailerBytes: compressed! Item was changed: ----- Method: ParagraphEditor>>compileSelectionFor:in: (in category 'do-its') ----- compileSelectionFor: anObject in: evalContext | methodNode method | methodNode := [Compiler new compileNoPattern: self selectionAsStream in: anObject class context: evalContext notifying: self ifFail: [^nil]] on: OutOfScopeNotification do: [:ex | ex resume: true]. + method := methodNode generate: #(0 0 0 0). + ^method copyWithTempsFromMethodNode: methodNode! - method := methodNode generate. - ^method copyWithTempNames: methodNode tempNames! Item was changed: ----- Method: MethodProperties>>propertyKeysAndValuesDo: (in category 'properties') ----- propertyKeysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." + ^properties ifNotNil:[properties keysAndValuesDo: aBlock]! - ^self propertyKeysAndValuesDo: aBlock! Item was removed: - ----- Method: CompiledMethod>>primitiveNode (in category 'decompiling') ----- - primitiveNode - - | primNode n | - primNode := PrimitiveNode new num: (n := self primitive). - (n = 117 or: [n = 120]) ifTrue: [ - primNode spec: (self literalAt: 1)]. - ^ primNode! Item was removed: - ----- Method: CompiledMethod>>qCompress:firstTry: (in category 'source code management') ----- - qCompress: string firstTry: firstTry - "A very simple text compression routine designed for method temp names. - Most common 12 chars get values 0-11 packed in one 4-bit nibble; - others get values 12-15 (2 bits) * 16 plus next nibble. - Last char of str must be a space so it may be dropped without - consequence if output ends on odd nibble. - Normal call is with firstTry == true." - | charTable odd ix oddNibble names shorterStr maybe str temps | - str := string isOctetString - ifTrue: [string] - ifFalse: [temps := string findTokens: ' '. - String - streamContents: [:stream | 1 - to: temps size - do: [:index | - stream nextPut: $t. - stream nextPutAll: index asString. - stream space]]]. - charTable := "Character encoding table must match qDecompress:" - ' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. - ^ ByteArray streamContents: - [:strm | odd := true. "Flag for odd or even nibble out" - oddNibble := nil. - str do: - [:char | ix := (charTable indexOf: char) - 1. - (ix <= 12 ifTrue: [Array with: ix] - ifFalse: [Array with: ix//16+12 with: ix\\16]) - do: - [:nibble | (odd := odd not) - ifTrue: [strm nextPut: oddNibble*16 + nibble] - ifFalse: [oddNibble := nibble]]]. - strm position > 251 ifTrue: - ["Only values 1...251 are available for the flag byte - that signals compressed temps. See the logic in endPC." - "Before giving up completely, we attempt to encode most of - the temps, but with the last few shortened to tNN-style names." - firstTry ifFalse: [^ nil "already tried --give up now"]. - names := str findTokens: ' '. - names size < 8 ifTrue: [^ nil "weird case -- give up now"]. - 4 to: names size//2 by: 4 do: - [:i | shorterStr := String streamContents: - [:s | - 1 to: names size - i do: [:j | s nextPutAll: (names at: j); space]. - 1 to: i do: [:j | s nextPutAll: 't' , j printString; space]]. - (maybe := self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]]. - ^ nil]. - strm nextPut: strm position] - " - | m s | m := CompiledMethod new. - s := 'charTable odd ix oddNibble '. - ^ Array with: s size with: (m qCompress: s) size - with: (m qDecompress: (m qCompress: s)) - " - ! Item was removed: - ----- Method: ContextPart>>isBottomContext (in category 'query') ----- - isBottomContext - "Answer if this is the last context (the first context invoked) in my sender chain" - - ^sender isNil! Item was removed: - ----- Method: CompiledMethod>>qDecompress: (in category 'source code management') ----- - qDecompress: byteArray - "Decompress strings compressed by qCompress:. - Most common 12 chars get values 0-11 packed in one 4-bit nibble; - others get values 12-15 (2 bits) * 16 plus next nibble" - | charTable extended ext | - charTable := "Character encoding table must match qCompress:" - ' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. - ^ String streamContents: - [:strm | extended := false. "Flag for 2-nibble characters" - byteArray do: - [:byte | - (Array with: byte//16 with: byte\\16) do: - [:nibble | - extended - ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended := false] - ifFalse: [nibble < 12 - ifTrue: [strm nextPut: (charTable at: nibble + 1)] - ifFalse: [ext := nibble-12. extended := true]]]]]! Item was removed: - ----- Method: CompiledMethod>>tempNames (in category 'source code management') ----- - tempNames - - | byteCount bytes | - self holdsTempNames ifFalse: [ - ^ (1 to: self numTemps) collect: [:i | 't', i printString] - ]. - byteCount := self at: self size. - byteCount = 0 ifTrue: [^ Array new]. - bytes := (ByteArray new: byteCount) - replaceFrom: 1 to: byteCount with: self - startingAt: self size - byteCount. - ^ (self qDecompress: bytes) findTokens: ' '!

1 0

The Trunk: Compiler-eem.79.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

Andreas Raab uploaded a new version of Compiler to project The Trunk: http://source.squeak.org/trunk/Compiler-eem.79.mcz ==================== Summary ==================== Name: Compiler-eem.79 Author: eem Time: 5 September 2009, 4:42:29 am UUID: f52d0730-d744-40d2-bdd1-f7412fc1b8f1 Ancestors: Compiler-eem.78 Fourth package of eight in closure compiler fixes 9/5/2009. Second stage of the closure compiler fixes for - miscompilation of optimized blocks - bugs in statement highlighting in the debugger - storing the selector as the penultimate literal of a method directly unless it has properties, in which case it has an AdditionalMethodState. Saves significant space. Throws the switch to the new closure analysis in BlockNode>>analyseArguments:temporaries:rootNode: using in place of analyseTempsWithin:rootNode:assignmentPools: analyseTempsWithin:rootNode:. This requires Exceptions-eem.12 Kernel-eem.242 Compiler-eem.78 =============== Diff against Compiler-eem.78 =============== Item was changed: ----- Method: MethodNode>>printPropertiesOn: (in category 'printing') ----- printPropertiesOn: aStream properties ifNil: [^self]. + properties propertyKeysAndValuesDo: + [:prop :val| + aStream crtab; nextPut: $<. + prop = #on:in: + ifTrue: + [prop keywords with: val do: + [:k :v | aStream nextPutAll: k; space; nextPutAll: v; space]] + ifFalse: + [prop = #on + ifTrue: [aStream nextPutAll: prop; nextPutAll:': '; nextPutAll: val] + ifFalse: [aStream nextPutAll: prop; nextPutAll:': '; print: val]]. + aStream nextPut: $>]! - properties pragmas do: - [ :each | - "Don't decompile basic primitives that return self, i-vars, etc." - each keyword = #primitive: - ifFalse: [ aStream crtab: 1. each printOn: aStream ] - ifTrue: [ ((each argumentAt: 1) between: 255 and: 519) ifFalse: - [ aStream crtab: 1. self printPrimitiveOn: aStream ] ] ]! Item was changed: ----- Method: MethodNode>>printWithClosureAnalysisOn: (in category 'printing') ----- printWithClosureAnalysisOn: aStream precedence = 1 ifTrue: [(self selector includesSubString: '()/') ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)). arguments do: [:arg| aStream nextPutAll: arg key] separatedBy: [aStream nextPutAll: ', ']. aStream nextPut: $)] ifFalse: [aStream nextPutAll: self selector]] "no node for method selector" ifFalse: [self selector keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space. arg printDefinitionForClosureAnalysisOn: aStream. aStream space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. temporaries size > 0 ifTrue: [aStream crtab: 1; nextPut: $|. temporaries do: [:temp | aStream space. temp printDefinitionForClosureAnalysisOn: aStream]. aStream space; nextPut: $|]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" [aStream crtab: 1. self printPrimitiveOn: aStream]]. self printPropertiesOn: aStream. + self printPragmasOn: aStream. aStream crtab: 1. block printWithClosureAnalysisStatementsOn: aStream indent: 0! Item was changed: ----- Method: Compiler>>compiledMethodFor:in:to:notifying:ifFail:logged: (in category 'public access') ----- compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag + "Compiles the sourceStream into a parse tree, then generates code + into a method, and answers it. If receiver is not nil, then the text can + refer to instance variables of that receiver (the Inspector uses this). + If aContext is not nil, the text can refer to temporaries in that context + (the Debugger uses this). If aRequestor is not nil, then it will receive a + notify:at: message before the attempt to evaluate is aborted." - "Compiles the sourceStream into a parse tree, then generates code into a - method. This method is then installed in the receiver's class so that it - can be invoked. In other words, if receiver is not nil, then the text can - refer to instance variables of that receiver (the Inspector uses this). If - aContext is not nil, the text can refer to temporaries in that context (the - Debugger uses this). If aRequestor is not nil, then it will receive a - notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here as DoIt or (in the case of - evaluation in aContext) DoItIn:. The method is subsequently removed - from the class, but this will not get done if the invocation causes an - error which is terminated. Such garbage can be removed by executing: - Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: - #DoItIn:]." | methodNode method | class := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. + methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value]. - methodNode := self translate: sourceStream noPattern: true ifFail: - [^failBlock value]. method := methodNode generate: #(0 0 0 0). self interactive ifTrue: + [method := method copyWithTempsFromMethodNode: methodNode]. + logFlag ifTrue: + [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. + ^method! - [method := method copyWithTempNames: methodNode tempNames]. - - logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. - ^ method.! Item was changed: ----- Method: Decompiler>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- popIntoTemporaryVariable: offset | maybeTVTag tempVector start | maybeTVTag := stack last. ((maybeTVTag isMemberOf: Association) and: [maybeTVTag key == #pushNewArray]) ifTrue: + [blockStartsToTempVars notNil "implies we were intialized with temp names." + ifTrue: "Use the provided temps" + [self assert: ((tempVector := tempVars at: offset + 1 ifAbsent: [ParseNode basicNew]) isTemp + and: [tempVector isIndirectTempVector + and: [tempVector remoteTemps size = maybeTVTag value size]])] + ifFalse: "Synthesize some remote temps" + [tempVector := maybeTVTag value. + offset + 1 <= tempVars size + ifTrue: + [start := 2. + tempVector at: 1 put: (tempVars at: offset + 1)] + ifFalse: + [tempVars := (Array new: offset + 1) + replaceFrom: 1 + to: tempVars size + with: tempVars. + start := 1]. + start to: tempVector size do: + [:i| + tempVector + at: i + put: (constructor + codeTemp: numLocalTemps + offset + i - 1 + named: 't', (tempVarCount + i) printString)]. + tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector)]. + tempVarCount := tempVarCount + maybeTVTag value size. - [tempVector := maybeTVTag value. - offset + 1 <= tempVars size - ifTrue: - [start := 2. - tempVector at: 1 put: (tempVars at: offset + 1)] - ifFalse: - [tempVars := (Array new: offset + 1) - replaceFrom: 1 - to: tempVars size - with: tempVars. - start := 1]. - start to: tempVector size do: - [:i| - tempVector - at: i - put: (constructor codeTemp: numLocalTemps + offset + i - 1)]. - tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector). stack removeLast. ^self]. self pushTemporaryVariable: offset; doStore: statements! Item was changed: ----- Method: TempVariableNode>>addWriteWithin:at: (in category 'code generation (closures)') ----- addWriteWithin: scopeBlock "<BlockNode>" at: location "<Integer>" writingScopes ifNil: [writingScopes := Dictionary new]. + (writingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location. + remoteNode ifNotNil: + [remoteNode addReadWithin: scopeBlock at: location]! - (writingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location! Item was changed: ----- Method: BlockNode>>computeCopiedValues: (in category 'code generation (closures)') ----- computeCopiedValues: rootNode | referencedValues | referencedValues := rootNode referencedValuesWithinBlockExtent: blockExtent. + ^((referencedValues reject: [:temp| temp isDefinedWithinBlockExtent: blockExtent]) + asSortedCollection: ParseNode tempSortBlock) + asArray! - ^((referencedValues reject: - [:temp| temp isDefinedWithinBlockExtent: blockExtent]) asSortedCollection: - [:t1 :t2 | t1 index < t2 index]) asArray! Item was changed: ----- Method: MethodNode>>printOn: (in category 'printing') ----- printOn: aStream | selectorNode | selectorNode := self selectorNode. precedence = 1 ifTrue: [selectorNode isForFFICall ifTrue: [selectorNode printAsFFICallWithArguments: arguments on: aStream indent: 0] ifFalse: [aStream nextPutAll: selectorNode key]] ifFalse: [selectorNode key keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space; nextPutAll: arg key; space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. block printTemporaries: temporaries on: aStream doPrior: [aStream crtab: 1]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" [aStream crtab: 1. self printPrimitiveOn: aStream]]. self printPropertiesOn: aStream. + self printPragmasOn: aStream. aStream crtab: 1. block printStatementsOn: aStream indent: 0! Item was changed: ----- Method: MethodNode>>rawSourceRangesAndMethodDo: (in category 'source mapping') ----- rawSourceRangesAndMethodDo: aBinaryBlock "Evaluate aBinaryBlock with the rawSourceRanges and method generated from the receiver." | methNode method | + methNode := encoder classEncoding parserClass new + encoderClass: encoder class; + parse: (sourceText "If no source, use decompile string as source to map from" + ifNil: [self decompileString] + ifNotNil: [sourceText]) + class: self methodClass. - methNode := sourceText - ifNil: "No source, use decompile string as source to map from" - [self parserClass new - encoderClass: encoder class; - parse: self decompileString - class: self methodClass] - ifNotNil: [self prepareForRegeneration. - self]. method := methNode generate: #(0 0 0 0). "set bytecodes to map to" ^aBinaryBlock value: methNode encoder rawSourceRanges value: method! Item was changed: ----- Method: BlockNode>>addHoistedTemps: (in category 'code generation (closures)') ----- addHoistedTemps: additionalTemporaries "<SequenceableCollection>" additionalTemporaries do: + [:temp| + temp definingScope ifNil: + [temp definingScope: self]]. + temporaries := (temporaries isNil or: [temporaries isEmpty]) + ifTrue: [additionalTemporaries copy] + ifFalse: + [temporaries last isIndirectTempVector + ifTrue: [temporaries allButLast, additionalTemporaries, { temporaries last }] + ifFalse: [temporaries, additionalTemporaries]]! - [:temp| temp definingScope: self]. - temporaries := (temporaries == nil ifTrue: [#()] ifFalse: [temporaries]), additionalTemporaries! Item was changed: ----- Method: Parser>>addPragma: (in category 'pragmas') ----- addPragma: aPragma + properties := properties copyWith: aPragma! - self properties addPragma: aPragma! Item was changed: ----- Method: Decompiler>>jump:if: (in category 'instruction decoding') ----- jump: dist if: condition | savePc sign elsePc elseStart end cond ifExpr thenBlock elseBlock + thenJump elseJump condHasValue isIfNil saveStack blockBody | - thenJump elseJump condHasValue isIfNil saveStack | stack last == CascadeFlag ifTrue: [^ self case: dist]. elsePc := lastPc. elseStart := pc + dist. end := limit. "Check for bfp-jmp to invert condition. Don't be fooled by a loop with a null body." sign := condition. savePc := pc. self interpretJump ifNotNil: [:elseDist| (elseDist >= 0 and: [elseStart = pc]) ifTrue: [sign := sign not. elseStart := pc + elseDist]]. pc := savePc. ifExpr := stack removeLast. (isIfNil := stack size > 0 and: [stack last == IfNilFlag]) ifTrue: [stack removeLast]. saveStack := stack. stack := OrderedCollection new. thenBlock := self blockTo: elseStart. condHasValue := hasValue or: [isIfNil]. "ensure jump is within block (in case thenExpr returns)" thenJump := exit <= end ifTrue: [exit] ifFalse: [elseStart]. "if jump goes back, then it's a loop" thenJump < elseStart ifTrue: ["Must be a while loop... + thenJump will jump to the beginning of the while expr. In the case of while's + with a block in the condition, the while expr should include more than just + the last expression: find all the statements needed by re-decompiling." - thenJump will jump to the beginning of the while expr." stack := saveStack. + pc := thenJump. + blockBody := self statementsTo: elsePc. + "discard unwanted statements from block" + blockBody size - 1 timesRepeat: [statements removeLast]. statements addLast: (constructor + codeMessage: (constructor codeBlock: blockBody returns: false) - codeMessage: (constructor codeBlock: { ifExpr } returns: false) selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro) arguments: { thenBlock }). + pc := elseStart. self convertToDoLoop] ifFalse: ["Must be a conditional..." elseBlock := self blockTo: thenJump. elseJump := exit. "if elseJump is backwards, it is not part of the elseExpr" elseJump < elsePc ifTrue: [pc := lastPc]. cond := isIfNil ifTrue: [constructor codeMessage: ifExpr ifNilReceiver selector: (constructor codeSelector: (sign ifTrue: [#ifNotNil:] ifFalse: [#ifNil:]) code: #macro) arguments: (Array with: thenBlock)] ifFalse: [constructor codeMessage: ifExpr selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro) arguments: (sign ifTrue: [{elseBlock. thenBlock}] ifFalse: [{thenBlock. elseBlock}])]. stack := saveStack. condHasValue ifTrue: [stack addLast: cond] ifFalse: [statements addLast: cond]]! Item was changed: ----- Method: TempVariableNode>>printWithClosureAnalysisOn:indent: (in category 'printing') ----- printWithClosureAnalysisOn: aStream indent: level + aStream nextPutAll: name. + readingScopes notNil ifTrue: + [(readingScopes inject: Set new into: [:them :reads| them addAll: reads. them]) asSortedCollection do: + [:location| + aStream space; nextPut: $r; nextPut: $@; print: location]]. + writingScopes notNil ifTrue: + [(writingScopes inject: Set new into: [:them :writes| them addAll: writes. them]) asSortedCollection do: + [:location| + aStream space; nextPut: $w; nextPut: $@; print: location]]! - aStream nextPutAll: name! Item was changed: ----- Method: Parser>>queryUndefined (in category 'error correction') ----- queryUndefined | varStart varName | + varName := parseNode key. + varStart := self endOfLastToken + requestorOffset - varName size + 1. - varName _ parseNode key. - varStart _ self endOfLastToken + requestorOffset - varName size + 1. requestor selectFrom: varStart to: varStart + varName size - 1; select. (UndefinedVariable name: varName) ifFalse: [^ self fail]! Item was changed: ----- Method: Decompiler>>initSymbols: (in category 'initialize-release') ----- initSymbols: aClass - | nTemps namedTemps | constructor method: method class: aClass literals: method literals. constTable := constructor codeConstants. instVars := Array new: aClass instSize. + tempVarCount := method numTemps. + "(tempVars isNil + and: [method holdsTempNames]) ifTrue: + [tempVars := method tempNamesString]." + tempVars isString + ifTrue: + [blockStartsToTempVars := self mapFromBlockStartsIn: method + toTempVarsFrom: tempVars + constructor: constructor. + tempVars := blockStartsToTempVars at: method initialPC] + ifFalse: + [| namedTemps | + namedTemps := tempVars ifNil: [(1 to: tempVarCount) collect: [:i| 't', i printString]]. + tempVars := (1 to: tempVarCount) collect: + [:i | i <= namedTemps size + ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] + ifFalse: [constructor codeTemp: i - 1]]]. - nTemps := method numTemps. - namedTemps := tempVars ifNil: [method tempNames]. - tempVars := (1 to: nTemps) collect: - [:i | i <= namedTemps size - ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] - ifFalse: [constructor codeTemp: i - 1]]. 1 to: method numArgs do: [:i| (tempVars at: i) beMethodArg]! Item was changed: ----- Method: Parser>>method:context:encoder: (in category 'expression types') ----- method: doit context: ctxt encoder: encoderToUse " pattern [ | temporaries ] block => MethodNode." | sap blk prim temps messageComment methodNode | + properties := AdditionalMethodState new. - properties := MethodProperties new. encoder := encoderToUse. sap := self pattern: doit inContext: ctxt. "sap={selector, arguments, precedence}" properties selector: (sap at: 1). encoder selector: (sap at: 1). (sap at: 2) do: [:argNode | argNode beMethodArg]. + doit ifFalse: [self pragmaSequence]. - doit ifFalse: [ self pragmaSequence ]. temps := self temporaries. messageComment := currentComment. currentComment := nil. + doit ifFalse: [self pragmaSequence]. - doit ifFalse: [ self pragmaSequence ]. prim := self pragmaPrimitives. self statements: #() innerBlock: doit. blk := parseNode. doit ifTrue: [blk returnLast] ifFalse: [blk returnSelfIfNoOther: encoder]. hereType == #doIt ifFalse: [^self expected: 'Nothing more']. self interactive ifTrue: [self removeUnusedTemps]. methodNode := self newMethodNode comment: messageComment. + ^methodNode - ^ methodNode selector: (sap at: 1) arguments: (sap at: 2) precedence: (sap at: 3) temporaries: temps block: blk encoder: encoder primitive: prim properties: properties! Item was changed: ----- Method: MethodNode>>printPrimitiveOn: (in category 'printing') ----- + printPrimitiveOn: aStream - printPrimitiveOn: aStream "Print the primitive on aStream" + | primDecl | + primitive = 0 ifTrue: + [^self]. + primitive = 120 ifTrue: "External call spec" + [^aStream print: encoder literals first]. - | primIndex primDecl | - primIndex := primitive. - primIndex = 0 - ifTrue: [^ self]. - primIndex = 120 - ifTrue: ["External call spec" - ^ aStream print: encoder literals first]. aStream nextPutAll: '<primitive: '. + primitive = 117 + ifTrue: + [primDecl := encoder literals at: 1. + (primDecl at: 2) asString printOn: aStream. + (primDecl at: 1) ifNotNil: + [:moduleName| + aStream nextPutAll:' module: '. + moduleName asString printOn: aStream]] + ifFalse: + [aStream print: primitive]. + self primitiveErrorVariableName ifNotNil: + [:primitiveErrorVariableName| + aStream nextPutAll: ' error: '; nextPutAll: primitiveErrorVariableName]. - primIndex = 117 - ifTrue: [primDecl := encoder literals at: 1. - aStream nextPut: $'; - - nextPutAll: (primDecl at: 2); - nextPut: $'. - (primDecl at: 1) notNil - ifTrue: [aStream nextPutAll: ' module:'; - nextPut: $'; - - nextPutAll: (primDecl at: 1); - nextPut: $']] - ifFalse: [aStream print: primIndex]. aStream nextPut: $>. Smalltalk at: #Interpreter ifPresent:[:cls| + aStream nextPutAll: ' "', + ((cls classPool at: #PrimitiveTable) at: primitive + 1), + '" ']! - aStream nextPutAll: ' "' - , ((cls classPool at: #PrimitiveTable) - at: primIndex + 1) , '" '].! Item was changed: ----- Method: BlockNode>>addRemoteTemp:rootNode: (in category 'code generation (closures)') ----- addRemoteTemp: aTempVariableNode rootNode: rootNode "<MethodNode>" + "Add aTempVariableNode to my actualScope's sequence of + remote temps. If I am an optimized block then the actual + scope is my actualScopeIfOptimized, otherwise it is myself." temporaries isArray ifTrue: [temporaries := temporaries asOrderedCollection]. remoteTempNode == nil ifTrue: [remoteTempNode := RemoteTempVectorNode new + name: self remoteTempNodeName - name: '<', blockExtent first printString, '-', blockExtent last printString, '>' index: arguments size + temporaries size type: LdTempType scope: 0. + actualScopeIfOptimized + ifNil: + [temporaries addLast: remoteTempNode. + remoteTempNode definingScope: self] + ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]]. - temporaries addLast: remoteTempNode. - remoteTempNode definingScope: self]. remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder. + "use remove:ifAbsent: because the deferred analysis for optimized + loops can result in the temp has already been hoised into the root." + temporaries remove: aTempVariableNode ifAbsent: []. - temporaries remove: aTempVariableNode. ^remoteTempNode! Item was changed: ----- Method: BlockNode>>analyseArguments:temporaries:rootNode: (in category 'code generation (closures)') ----- analyseArguments: methodArguments temporaries: methodTemporaries rootNode: rootNode "<MethodNode>" "^<Sequence of: <TempVarNade>>" "Top level entry-point for analysing temps within the hierarchy of blocks in the receiver's method. Answer the (possibly modified) sequence of temp vars. Need to hoist temps out of macro-optimized blocks into their actual blocks. Need to note reads and writes to temps from blocks other than their actual blocks to determine whether blocks can be local (simple slots within a block/method context) or remote (slots in indirection vectors that are shared between contexts by sharing indirection vectors). The algorithm is based on numbering temporary reads and writes and block extents. The index used for numbering starts at zero and is incremented on every block entry and block exit. So the following | a b blk r1 r2 t | a := 1. b := 2. t := 0. blk := [ | s | s := a + b. t := t + s]. r1 := blk value. b := -100. r2 := blk value. r1 -> r2 -> t is numbered as method block 0 to: 6: | a b blk r1 r2 t | a w@1 := 1. b w@1 := 2. t w@1 := 0. blk w@5 := [entry@2 | s | t w@3 := t r@3 + a r@3 + b r@3 ] exit@4. r1 w@5 := blk r@5 value. b w@5 := nil. r2 w@5 := blk r@5 value. r1 r@5 -> r2 r@5 -> t r@5 So: + b and blk cannot be copied because for both there exists a write @5 that follows a - b and blk cannot be copied because fpr both there exists a write @5 that follows a read @4 within block 2 through 4 + t must be remote because there exists a write @3 within block (2 to: 4) + Complications are introduced by optimized blocks. In the following temp is written to + after it is closed over by [ temp ] since the inlined block is executed more than once. + | temp coll | + coll := OrderedCollection new. + 1 to: 5 do: [ :index | + temp := index. + coll add: [ temp ] ]. + self assert: (coll collect: [:ea| ea value]) asArray = #(5 5 5 5 5) + In the following i is local to the block and must be initialized each time around the loop + but if the block is inlined it must be declared at method level. + | col | + col := OrderedCollection new. + 1 to: 3 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. + self assert: (col collect: [ :each | each value ]) asArray = #(2 3 4)" - t must be remote because there exists a write @3 within block (2 to: 4)" self assert: (arguments isEmpty or: [arguments hasEqualElements: methodArguments]). arguments := methodArguments asArray. "won't change" self assert: (temporaries isNil or: [temporaries isEmpty or: [temporaries hasEqualElements: methodTemporaries]]). temporaries := OrderedCollection withAll: methodTemporaries. self assert: optimized not. "the top-level block should not be optimized." + self analyseTempsWithin: self rootNode: rootNode assignmentPools: Dictionary new. - self analyseTempsWithin: self rootNode: rootNode. "The top-level block needs to reindex temporaries since analysis may have rearranged them. + This happens when temps are made remote and/or a remote node is added." - This happens during sizing for nested blocks." temporaries withIndexDo: [:temp :offsetPlusOne| temp index: arguments size + offsetPlusOne - 1]. "Answer the (possibly modified) sequence of temps." ^temporaries asArray! Item was changed: ----- Method: MethodNode>>selector:arguments:precedence:temporaries:block:encoder:primitive: (in category 'initialize-release') ----- selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim + "Initialize the receiver with respect to the arguments given." + + encoder := anEncoder. + selectorOrFalse := selOrFalse. + precedence := p. + arguments := args. + temporaries := temps. + block := blk. + primitive := prim! - - self - selector: selOrFalse - arguments: args - precedence: p - temporaries: temps - block: blk encoder: - anEncoder - primitive: prim - properties: MethodProperties new.! Item was changed: ----- Method: DecompilerConstructorForClosures>>codeMethod:block:tempVars:primitive:class: (in category 'constructor') ----- codeMethod: selector block: block tempVars: vars primitive: primitive class: class + | blockNode selectorNode visibleTemps invisibleTemps arguments temporaries | + selectorNode := self codeSelector: selector code: nil. - | node visibleTemps invisibleTemps arguments temporaries | - node := self codeSelector: selector code: nil. tempVars := vars. visibleTemps := OrderedCollection new. invisibleTemps := OrderedCollection new. tempVars do: [:t| ((t isIndirectTempVector or: [t scope >= 0]) ifTrue: [visibleTemps] ifFalse: [invisibleTemps]) addLast: t]. arguments := visibleTemps copyFrom: 1 to: nArgs. temporaries := visibleTemps copyFrom: nArgs + 1 to: visibleTemps size. block arguments: arguments; temporaries: temporaries. + blockNode := BytecodeAgnosticMethodNode new + selector: selectorNode - ^BytecodeAgnosticMethodNode new - selector: node arguments: arguments precedence: selector precedence temporaries: temporaries block: block encoder: (EncoderForV3PlusClosures new initScopeAndLiteralTables temps: visibleTemps, invisibleTemps literals: literalValues class: class) primitive: primitive + properties: method properties copy. + blockNode properties method: blockNode. + ^blockNode! - properties: method properties! Item was changed: ----- Method: Decompiler>>decompile:in:method:using: (in category 'public access') ----- decompile: aSelector in: aClass method: aMethod using: aConstructor + | block node | - | block | constructor := aConstructor. method := aMethod. self initSymbols: aClass. "create symbol tables" method isQuick ifTrue: [block := self quickMethod] ifFalse: [stack := OrderedCollection new: method frameSize. caseExits := OrderedCollection new. statements := OrderedCollection new: 20. numLocalTemps := 0. super method: method pc: method initialPC. + "skip primitive error code store if necessary" + (method primitive ~= 0 and: [self willStore]) ifTrue: + [pc := pc + 2. + tempVars := tempVars asOrderedCollection]. block := self blockTo: method endPC + 1. stack isEmpty ifFalse: [self error: 'stack not empty']]. + node := constructor + codeMethod: aSelector + block: block + tempVars: tempVars + primitive: method primitive + class: aClass. + method primitive > 0 ifTrue: + [node removeAndRenameLastTempIfErrorCode]. + ^node! - ^(constructor - codeMethod: aSelector - block: block - tempVars: tempVars - primitive: method primitive - class: aClass) - accept: TempNumberNormalizingVisitor new; - yourself! Item was changed: ----- Method: Decompiler>>withTempNames: (in category 'initialize-release') ----- + withTempNames: tempNames "<Array|String>" + "Optionally initialize the temp names to be used when decompiling. + For backward-copmpatibility, if tempNames is an Array it is a single + vector of temp names, probably for a blue-book-compiled method. + If tempNames is a string it is a schematic string that encodes the + layout of temp vars in the method and any closures/blocks within it. + Decoding encoded tempNames is done in decompile:in:method:using: + which has the method from which to derive blockStarts. + See e.g. BytecodeEncoder>>schematicTempNamesString for syntax." + tempVars := tempNames! - withTempNames: tempNameArray - tempVars := tempNameArray! Item was changed: ----- Method: Decompiler class>>recompileAllTest (in category 'testing') ----- recompileAllTest + "[Decompiler recompileAllTest]" - "[self recompileAllTest]" "decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)" | decompiled ast compiled | SystemNavigation default allBehaviorsDo: [ :behavior | Utilities informUser: (behavior printString) during: [ behavior selectors do: [ :sel | decompiled := Decompiler new decompile: sel in: behavior. ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ]. compiled := ast generate: (behavior compiledMethodAt: sel) trailer. behavior addSelector: sel withMethod: compiled. ] ] ]! Item was changed: ----- Method: Decompiler>>decompileBlock: (in category 'public access') ----- decompileBlock: aBlock "Decompile aBlock, returning the result as a BlockNode. Show temp names from source if available." "Decompiler new decompileBlock: [3 + 4]" + | startpc end homeClass blockNode methodNode home source | - | startpc end homeClass blockNode tempNames home source | (home := aBlock home) ifNil: [^ nil]. method := home method. (homeClass := home who first) == #unknown ifTrue: [^ nil]. constructor := self constructorForMethod: aBlock method. + method fileIndex ~~ 0 ifTrue: "got any source code?" + [source := [method getSourceFromFile] - method fileIndex ~~ 0 - ifTrue: ["got any source code?" - source := [method getSourceFromFile] on: Error do: [:ex | ^ nil]. + methodNode := [homeClass compilerClass new + parse: source + in: homeClass + notifying: nil] + on: (Smalltalk classNamed: 'SyntaxErrorNotification') + do: [:ex | ^ nil]. + self withTempNames: methodNode schematicTempNamesString]. - tempNames := ([homeClass compilerClass new - parse: source - in: homeClass - notifying: nil] - on: (Smalltalk classNamed: 'SyntaxErrorNotification') - do: [:ex | ^ nil]) tempNames. - self withTempNames: tempNames]. self initSymbols: homeClass. startpc := aBlock startpc. end := aBlock isClosure ifTrue: [(method at: startpc - 2) * 256 + (method at: startpc - 1) + startpc - 1] ifFalse: + [(method at: startpc - 2) \\ 16 - 4 * 256 + + (method at: startpc - 1) + startpc - 1]. - [(method at: startpc - 2) - \\ 16 - 4 * 256 - + (method at: startpc - 1) + startpc - 1]. stack := OrderedCollection new: method frameSize. caseExits := OrderedCollection new. statements := OrderedCollection new: 20. super method: method pc: (aBlock isClosure ifTrue: [startpc - 4] ifFalse: [startpc - 5]). aBlock isClosure ifTrue: [numLocalTemps := #decompileBlock: "Get pushClosureCopy... to hack fake temps for copied values"]. blockNode := self blockTo: end. stack isEmpty ifFalse: [self error: 'stack not empty']. ^blockNode statements first! Item was changed: ----- Method: Parser>>pragmaPrimitives (in category 'pragmas') ----- pragmaPrimitives + | primitives | + properties isEmpty ifTrue: + [^0]. + primitives := properties pragmas select: + [:pragma| + self class primitivePragmaSelectors includes: pragma keyword]. + primitives isEmpty ifTrue: + [^0]. + primitives size > 1 ifTrue: + [^self notify: 'Ambigous primitives']. + ^self perform: primitives first keyword withArguments: primitives first arguments! - | pragmas primitives | - self properties pragmas isEmpty - ifTrue: [ ^ 0 ]. - pragmas := Pragma allNamed: #primitive from: self class to: Parser. - primitives := self properties pragmas select: [ :prim | - pragmas anySatisfy: [ :prag | - prag selector = prim keyword ] ]. - primitives isEmpty - ifTrue: [ ^ 0 ]. - primitives size = 1 - ifFalse: [ ^ self notify: 'Ambigous primitives' ]. - ^ primitives first message sendTo: self! Item was changed: ----- Method: Parser>>removeUnusedTemps (in category 'error correction') ----- removeUnusedTemps "Scan for unused temp names, and prompt the user about the prospect of removing each one found" | str end start madeChanges | + madeChanges := false. + str := requestor text asString. - madeChanges _ false. - str _ requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | (UnusedVariable name: temp) ifTrue: + [(encoder encodeVariable: temp) isUndefTemp + ifTrue: + [end := tempsMark. + ["Beginning at right temp marker..." + start := end - temp size + 1. + end < temp size or: [temp = (str copyFrom: start to: end) + and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] + whileFalse: + ["Search left for the unused temp" + end := requestor nextTokenFrom: end direction: -1]. + end < temp size ifFalse: + [(str at: start-1) = $ ifTrue: [start := start-1]. + requestor correctFrom: start to: end with: ''. + str := str copyReplaceFrom: start to: end with: ''. + madeChanges := true. + tempsMark := tempsMark - (end-start+1)]] + ifFalse: + [self inform: + 'You''ll first have to remove the\statement where it''s stored into' withCRs]]]. + madeChanges ifTrue: [ReparseAfterSourceEditing signal]! - [(encoder encodeVariable: temp) isUndefTemp - ifTrue: - [end _ tempsMark. - ["Beginning at right temp marker..." - start _ end - temp size + 1. - end < temp size or: [temp = (str copyFrom: start to: end) - and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] - whileFalse: - ["Search left for the unused temp" - end _ requestor nextTokenFrom: end direction: -1]. - end < temp size ifFalse: - [(str at: start-1) = $ ifTrue: [start _ start-1]. - requestor correctFrom: start to: end with: ''. - str _ str copyReplaceFrom: start to: end with: ''. - madeChanges _ true. - tempsMark _ tempsMark - (end-start+1)]] - ifFalse: - [self inform: - 'You''ll first have to remove the - statement where it''s stored into']]]. - madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! Item was changed: ----- Method: ParseNode>>printCommentOn:indent: (in category 'printing') ----- printCommentOn: aStream indent: indent | thisComment | self comment == nil ifTrue: [^ self]. 1 to: self comment size do: [:index | index > 1 ifTrue: [aStream crtab: indent]. aStream nextPut: $". thisComment := self comment at: index. self printSingleComment: thisComment on: aStream indent: indent. + aStream nextPut: $"]! - aStream nextPut: $"]. - self comment: nil! Item was changed: ----- Method: TempVariableNode>>isDefinedWithinBlockExtent: (in category 'code generation (closures)') ----- isDefinedWithinBlockExtent: anInterval + ^anInterval rangeIncludes: definingScope actualScope blockExtent first! - ^anInterval rangeIncludes: definingScope blockExtent first! Item was changed: ----- Method: BlockNode>>printTemporaries:on:doPrior: (in category 'printing') ----- printTemporaries: tempSequence on: aStream doPrior: aBlock "Print any in-scope temporaries. If there are any evaluate aBlock prior to printing. Answer whether any temporaries were printed." + | tempStream seen | + tempSequence ifNil: + [^false]. + tempStream := (String new: 16) writeStream. + "This is for the decompiler which canmot work out which optimized block a particular temp is + local to and hence may produce diplicates as in + expr ifTrue: [| aTemp | ...] ifFalse: [| aTemp | ...]" + seen := Set new. - (tempSequence == nil - or: [tempSequence size = 0 - or: [tempSequence allSatisfy: [:temp| - temp scope < 0 - and: [temp isIndirectTempVector not]]]]) ifTrue: - [^false]. - aBlock value. - aStream nextPut: $|. tempSequence do: [:tempNode | tempNode isIndirectTempVector ifTrue: [tempNode remoteTemps do: [:tempVariableNode| + (tempVariableNode scope >= 0 + and: [(seen includes: tempNode key) not]) ifTrue: + [tempStream space; nextPutAll: (seen add: tempVariableNode key)]]] - tempVariableNode scope >= 0 ifTrue: - [aStream space; nextPutAll: tempVariableNode key]]] ifFalse: + [(tempNode scope >= -1 + and: ["This is for the decompiler which may create a block arg when converting + a while into a to:do: but won't remove it form temporaries" + tempNode isBlockArg not + and: [(seen includes: tempNode key) not]]) ifTrue: + [tempStream space; nextPutAll: (seen add: tempNode key)]]]. + tempStream position = 0 ifTrue: + [^false]. + aBlock value. + aStream nextPut: $|; nextPutAll: tempStream contents; space; nextPut: $|. - [tempNode scope >= 0 ifTrue: - [aStream space; nextPutAll: tempNode key]]]. - aStream - space; - nextPut: $|. ^true! Item was changed: ----- Method: MethodNode>>generate: (in category 'code generation') ----- generate: trailer "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." + | literals blkSize method nArgs nLits primErrNode stack strm | - | blkSize nLits literals stack strm nArgs method | self generate: trailer ifQuick: [:m | literals := encoder allLiterals. (nLits := literals size) > 255 ifTrue: [^self error: 'Too many literals referenced']. 1 to: nLits do: [:lit | m literalAt: lit put: (literals at: lit)]. m properties: properties. ^m]. + primErrNode := self primitiveErrorVariableName ifNotNil: + [encoder fixTemp: self primitiveErrorVariableName]. nArgs := arguments size. + blkSize := (block sizeForEvaluatedValue: encoder) + + (primErrNode ifNil: [0] ifNotNil: [2 "We force store-long (129)"]). - blkSize := block sizeForEvaluatedValue: encoder. (nLits := (literals := encoder allLiterals) size) > 255 ifTrue: [^self error: 'Too many literals referenced']. method := CompiledMethod "Dummy to allocate right size" newBytes: blkSize trailerBytes: trailer nArgs: nArgs nTemps: encoder maxTemp nStack: 0 nLits: nLits primitive: primitive. strm := ReadWriteStream with: method. strm position: method initialPC - 1. stack := ParseStack new init. + primErrNode ifNotNil: [primErrNode emitStore: stack on: strm]. block emitForEvaluatedValue: stack on: strm. stack position ~= 1 ifTrue: [^self error: 'Compiler stack discrepancy']. strm position ~= (method size - trailer size) ifTrue: [^self error: 'Compiler code size discrepancy']. method needsFrameSize: stack size. 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. method properties: properties. ^method! Item was changed: ----- Method: TempVariableNode>>addReadWithin:at: (in category 'code generation (closures)') ----- addReadWithin: scopeBlock "<BlockNode>" at: location "<Integer>" readingScopes ifNil: [readingScopes := Dictionary new]. + (readingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location. + remoteNode ifNotNil: + [remoteNode addReadWithin: scopeBlock at: location]! - (readingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location! Item was changed: ----- Method: TempVariableNode>>analyseClosure: (in category 'code generation (closures)') ----- analyseClosure: rootNode "<MethodNode>" + "Analyse whether the temporary needs to be made remote + or not, and answer whether it was made remote. + A temp cannot be local if it is written to remotely, + or if it is written to after it is closed-over. An exception + is an inlined block argument that appears to be written + remotely but is actually local to a block." - "A temp cannot be local if it is written to remotely, - or if it is written to after it is closed-over." | latestWrite | + self isBlockArg ifTrue: [^false]. + remoteNode ifNotNil: [^false]. "If already remote, don't remote a second time" latestWrite := 0. ((writingScopes notNil and: [writingScopes associations anySatisfy: [:assoc| [:blockScope :refs| refs do: [:write| latestWrite := write max: latestWrite]. "A temp cannot be local if it is written to remotely." + blockScope actualScope ~~ definingScope actualScope] - blockScope ~~ definingScope] value: assoc key value: assoc value]]) or: [readingScopes notNil and: [readingScopes associations anySatisfy: [:assoc| [:blockScope :refs| "A temp cannot be local if it is written to after it is closed-over." + blockScope actualScope ~~ definingScope actualScope - blockScope ~~ definingScope and: [refs anySatisfy: [:read| read < latestWrite]]] value: assoc key value: assoc value]]]) ifTrue: + [remoteNode := definingScope addRemoteTemp: self rootNode: rootNode. + ^true]. + ^false! - [remoteNode := definingScope addRemoteTemp: self rootNode: rootNode]! Item was changed: ----- Method: Decompiler>>doClosureCopyCopiedValues:numArgs:blockSize: (in category 'control') ----- doClosureCopyCopiedValues: blockCopiedValues numArgs: numArgs blockSize: blockSize + | savedTemps savedTempVarCount savedNumLocalTemps + jump blockArgs blockTemps blockTempsOffset block | - | savedTemps savedNumLocalTemps jump blockArgs blockTemps blockTempsOffset block | savedTemps := tempVars. + savedTempVarCount := tempVarCount. savedNumLocalTemps := numLocalTemps. jump := blockSize + pc. numLocalTemps := BlockLocalTempCounter tempCountForBlockAt: pc - 4 in: method. - blockArgs := (1 to: numArgs) collect: - [:i| (constructor codeTemp: i - 1) beBlockArg]. blockTempsOffset := numArgs + blockCopiedValues size. + (blockStartsToTempVars notNil "implies we were intialized with temp names." + and: [blockStartsToTempVars includesKey: pc]) + ifTrue: + [tempVars := blockStartsToTempVars at: pc] + ifFalse: + [blockArgs := (1 to: numArgs) collect: + [:i| (constructor + codeTemp: i - 1 + named: 't', (tempVarCount + i) printString) + beBlockArg]. + blockTemps := (1 to: numLocalTemps) collect: + [:i| constructor + codeTemp: i + blockTempsOffset - 1 + named: 't', (tempVarCount + i + numArgs) printString]. + tempVars := blockArgs, blockCopiedValues, blockTemps]. - blockTemps := (1 to: numLocalTemps) collect: - [:i| constructor codeTemp: i + blockTempsOffset - 1]. - tempVars := blockArgs, blockCopiedValues, blockTemps. numLocalTemps timesRepeat: [self interpretNextInstructionFor: self. stack removeLast]. + tempVarCount := tempVarCount + numArgs + numLocalTemps. block := self blockTo: jump. stack addLast: (constructor codeArguments: (tempVars copyFrom: 1 to: numArgs) temps: (tempVars copyFrom: blockTempsOffset + 1 to: blockTempsOffset + numLocalTemps) block: block). tempVars := savedTemps. + tempVarCount := savedTempVarCount. numLocalTemps := savedNumLocalTemps! Item was changed: ----- Method: TempVariableNode>>index: (in category 'code generation (closures)') ----- index: anInteger + "For renumbering temps in the closure compiler." - "For renumbering temps in the closure compiler. - Intended to be used only in BlockNode>>postNumberingProcessTemps:" index := anInteger. code := self code: index type: LdTempType! Item was changed: ----- Method: Encoder>>doItInContextName (in category 'encoding') ----- doItInContextName + ^'ThisContext'! - ^'_thisContext'! Item was changed: ----- Method: Compiler>>evaluate:in:to:notifying:ifFail:logged: (in category 'public access') ----- evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag + "Compiles the sourceStream into a parse tree, then generates code into a + method. This method is then installed in the receiver's class so that it + can be invoked. In other words, if receiver is not nil, then the text can + refer to instance variables of that receiver (the Inspector uses this). If + aContext is not nil, the text can refer to temporaries in that context (the + Debugger uses this). If aRequestor is not nil, then it will receive a + notify:at: message before the attempt to evaluate is aborted. Finally, the + compiled method is invoked from here as DoIt or (in the case of + evaluation in aContext) DoItIn:. The method is subsequently removed + from the class, but this will not get done if the invocation causes an + error which is terminated. Such garbage can be removed by executing: + Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: + #DoItIn:]." - "Compiles the sourceStream into a parse tree, then generates code into a method. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is directly invoked without modifying the receiving-class." + | methodNode method value toLog itsSelection itsSelectionString | + class := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. - | methodNode method value toLog itsSelectionString itsSelection | - class := (aContext isNil - ifTrue: [ receiver ] - ifFalse: [ aContext receiver ]) - class. self from: textOrStream class: class context: aContext notifying: aRequestor. + methodNode := self translate: sourceStream noPattern: true ifFail: + [^failBlock value]. + method := methodNode generate: #(0 0 0 0). + self interactive ifTrue: + [method := method copyWithTempsFromMethodNode: methodNode]. + + value := receiver + withArgs: (context ifNil: [#()] ifNotNil: [{context}]) + executeMethod: method. + + logFlag ifTrue:[ + toLog := ((requestor respondsTo: #selection) + and:[(itsSelection := requestor selection) notNil + and:[(itsSelectionString := itsSelection asString) isEmptyOrNil not]]) + ifTrue:[itsSelectionString] + ifFalse:[sourceStream contents]. + SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext]. + ^ value! - methodNode := self - translate: sourceStream - noPattern: true - ifFail: [ ^ failBlock value ]. - method := methodNode generate. - method selector ifNil: [method selector: #DoIt]. - self interactive - ifTrue: [ method := method copyWithTempNames: methodNode tempNames ]. - value := receiver - withArgs: (context isNil - ifTrue: [ #() ] - ifFalse: [ Array with: aContext ]) - executeMethod: method. - logFlag ifTrue: - [toLog := ((requestor respondsTo: #selection) and: - [(itsSelection := requestor selection) notNil] and: - [(itsSelectionString := itsSelection asString) isEmptyOrNil not] ) - ifTrue: - [itsSelectionString] - ifFalse: - [sourceStream contents]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext ]. - ^ value.! Item was removed: - ----- Method: CascadeNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - { receiver }, messages do: - [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode]! Item was removed: - ----- Method: PrimitiveNode>>printPrimitiveOn: (in category 'as yet unclassified') ----- - printPrimitiveOn: aStream - "Print the primitive on aStream" - - | primIndex primDecl | - primIndex := primitiveNum. - primIndex = 0 ifTrue: [^ self]. - primIndex = 120 ifTrue: [ - "External call spec" - ^ aStream print: spec]. - aStream nextPutAll: '<primitive: '. - primIndex = 117 ifTrue: [ - primDecl := spec. - aStream nextPut: $'; - nextPutAll: (primDecl at: 2); - nextPut: $'. - (primDecl at: 1) ifNotNil: [ - aStream nextPutAll: ' module: '; - nextPut: $'; - nextPutAll: (primDecl at: 1); - nextPut: $']. - ] ifFalse: [aStream print: primIndex]. - aStream nextPut: $>. - (primIndex ~= 117 and: [primIndex ~= 120]) ifTrue: [ - Smalltalk at: #Interpreter ifPresent: [:cls | - aStream nextPutAll: ' "', - ((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" ' - ]. - ]. - ! Item was removed: - ----- Method: TempVariableNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - self addReadWithin: scopeBlock at: rootNode locationCounter! Item was removed: - ----- Method: MessageNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - special > 0 ifTrue: - [receiver ifOptimizedBlockHoistTempsInto: scopeBlock. - "caseOf: is complicated. We need to handle it specially. - The cases are within a BraceNode where each case is of the form - [guard block] -> [action block]" - (selector key beginsWith: 'caseOf:') ifTrue: - [arguments first elements do: - [:messageNode| - messageNode receiver ifOptimizedBlockHoistTempsInto: scopeBlock. - messageNode arguments first ifOptimizedBlockHoistTempsInto: scopeBlock]]. - arguments do: - [:node| - node == nil ifFalse: "last argument of optimized to:do: can be nil" - [node ifOptimizedBlockHoistTempsInto: scopeBlock]]]. - - "receiver is nil in cascades" - receiver == nil ifFalse: - [receiver analyseTempsWithin: scopeBlock rootNode: rootNode]. - arguments do: - [:node| - node == nil ifFalse: "last argument of optimized to:do: can be nil" - [node analyseTempsWithin: scopeBlock rootNode: rootNode]]! Item was removed: - ----- Method: ReturnNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "Note we could do this: - scopeBlock ~~ rootNode block ifTrue: - [scopeBlock noteNonLocalReturn]. - and pass up the flag in <BlockNode>>>analyseTempsWithin:rootNode: - which may be fast but may also screw up the debugger. For now we - consider clean blocks a premature optimization." - self flag: 'consider clean blocks'. - expr analyseTempsWithin: scopeBlock rootNode: rootNode! Item was removed: - ----- Method: BlockNode>>postNumberingProcessTemps: (in category 'code generation (closures)') ----- - postNumberingProcessTemps: rootNode "<MethodNode>" - (temporaries isNil or: [temporaries isEmpty]) ifTrue: - ["Add all arguments to the pool so that copiedValues can be computed during sizing." - rootNode addLocalsToPool: arguments. - ^self]. - - "A temp can be local (and copied if it is not written to after it is captured. - A temp cannot be local if it is written to remotely. - Need to enumerate a copy of the temporaries because any temps becoming remote - will be removed from temporaries in analyseClosure: (and a single remote temp node - will get added)" - temporaries copy do: - [:each| each analyseClosure: rootNode]. - - "Now we may have added a remoteTempNode. So we need a statement to initialize it." - remoteTempNode ~~ nil ifTrue: - ["statements isArray ifTrue: - [statements := statements asOrderedCollection]." "true for decompiled trees" - (statements notEmpty - and: [statements first isAssignmentNode - and: [statements first variable isTemp - and: [statements first variable isIndirectTempVector]]]) - ifTrue: "If this is a decompiled tree there already is a temp vector initialization node." - [statements first variable become: remoteTempNode] - ifFalse: - [statements addFirst: (remoteTempNode nodeToInitialize: rootNode encoder)]]. - - "Now add all arguments and locals to the pool so that copiedValues can be computed during sizing." - rootNode - addLocalsToPool: arguments; - addLocalsToPool: temporaries! Item was removed: - ----- Method: PrimitiveNode class>>null (in category 'as yet unclassified') ----- - null - - ^ self new num: 0! Item was removed: - ----- Method: NewArrayNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "This is a no-op except in TempVariableNode" - ^self! Item was removed: - ----- Method: RemoteTempVectorNode>>cleanUpForRegeneration (in category 'debugger access') ----- - cleanUpForRegeneration - super cleanUpForRegeneration. - remoteTemps := nil! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>initialize (in category 'initialize-release') ----- - initialize - count := 0. - temps := IdentitySet new! Item was removed: - ----- Method: BytecodeEncoder>>blockExtentsToTempRefs (in category 'temps') ----- - blockExtentsToTempRefs - | blockExtentsToTempRefs | - blockExtentsToLocals ifNil: - [^nil]. - blockExtentsToTempRefs := Dictionary new. - blockExtentsToLocals keysAndValuesDo: - [:blockExtent :locals| - blockExtentsToTempRefs - at: blockExtent - put: (locals collect: - [:local| - local isIndirectTempVector - ifTrue: [local remoteTemps collect: - [:remoteLocal| remoteLocal key]] - ifFalse: [local key]])]. - ^blockExtentsToTempRefs! Item was removed: - ----- Method: BlockNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - | blockStart | - optimized ifTrue: - [self assert: (temporaries isEmpty and: [arguments isNil or: [arguments size <= 1]]). - statements do: - [:statement| - statement analyseTempsWithin: scopeBlock rootNode: rootNode]. - ^self]. - - rootNode noteBlockEntry: - [:entryNumber| - blockStart := entryNumber. - arguments notNil ifTrue: [arguments do: [:temp| temp definingScope: self]]. - temporaries notNil ifTrue: [temporaries do: [:temp| temp definingScope: self]]]. - - statements do: - [:statement| - statement analyseTempsWithin: self rootNode: rootNode]. - - rootNode noteBlockExit: - [:exitNumber| - blockExtent := blockStart to: exitNumber]. - - self postNumberingProcessTemps: rootNode! Item was removed: - ----- Method: PrimitiveNode>>spec: (in category 'as yet unclassified') ----- - spec: literal - - spec := literal! Item was removed: - ----- Method: RegenerationPreparingVisitor>>visitTempVariableNode: (in category 'visiting') ----- - visitTempVariableNode: aTempNode - aTempNode cleanUpForRegeneration! Item was removed: - ----- Method: BlockNode>>cleanUpForRegeneration (in category 'debugger access') ----- - cleanUpForRegeneration - arguments notNil ifTrue: - [arguments do: [:temp| temp cleanUpForRegeneration]]. - temporaries notNil ifTrue: - [temporaries do: [:temp| temp cleanUpForRegeneration]]. - (temporaries notNil - and: [temporaries notEmpty - and: [temporaries last isIndirectTempVector]]) ifTrue: - [temporaries := temporaries allButLast. - (statements notEmpty - and: [statements first isAssignmentNode - and: [statements first variable isTemp - and: [statements first variable isIndirectTempVector]]]) ifTrue: - [statements removeFirst]]. - remoteTempNode := nil! Item was removed: - ----- Method: PrimitiveNode>>num (in category 'as yet unclassified') ----- - num - - ^ primitiveNum! Item was removed: - ----- Method: PrimitiveNode>>sourceText (in category 'as yet unclassified') ----- - sourceText - - ^ String streamContents: [:stream | - self printPrimitiveOn: stream]! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>visitTempVariableNode: (in category 'visiting') ----- - visitTempVariableNode: aTempVariableNode - self renumberTemp: aTempVariableNode! Item was removed: - ----- Method: BraceNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - elements do: [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode]! Item was removed: - ----- Method: RegenerationPreparingVisitor>>visitBlockNode: (in category 'visiting') ----- - visitBlockNode: aBlockNode - aBlockNode cleanUpForRegeneration. - super visitBlockNode: aBlockNode! Item was removed: - ----- Method: BlockNode>>printTemporariesOn:indent: (in category 'printing') ----- - printTemporariesOn: aStream indent: level - - (temporaries == nil or: [temporaries size = 0]) - ifFalse: - [aStream nextPut: $|. - temporaries do: - [:arg | - aStream - space; - withStyleFor: #temporaryVariable - do: [aStream nextPutAll: arg key]]. - aStream nextPutAll: ' | '. - "If >0 args and >1 statement, put all statements on separate lines" - statements size > 1 ifTrue: [aStream crtab: level]]! Item was removed: - ----- Method: Compiler class>>closureDecompilerClass (in category 'accessing') ----- - closureDecompilerClass - ^self error: 'not installed'.! Item was removed: - ----- Method: ParseNode>>ifOptimizedBlockHoistTempsInto: (in category 'code generation (closures)') ----- - ifOptimizedBlockHoistTempsInto: scopeBlock "<BlockNode>" - "This is a No-op for all nodes except non-optimized BlockNodes." - ^self! Item was removed: - ----- Method: BytecodeAgnosticMethodNode>>copiedValuesWithinBlockExtent: (in category 'code generation (closures)') ----- - copiedValuesWithinBlockExtent: anInterval - ^((localsPool select: - [:temp| - temp isReferencedWithinBlockExtent: anInterval]) collect: - [:temp| - temp isRemote ifTrue: [temp remoteNode] ifFalse: [temp]]) asSortedCollection: - [:t1 :t2 | - t1 index < t2 index]! Item was removed: - ----- Method: AssignmentNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "N.B. since assigment happens :=after:= the value is evaluated the value is sent the message :=first:=." - value analyseTempsWithin: scopeBlock rootNode: rootNode. - variable beingAssignedToAnalyseTempsWithin: scopeBlock rootNode: rootNode! Item was removed: - Object subclass: #PrimitiveNode - instanceVariableNames: 'primitiveNum spec' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - - !PrimitiveNode commentStamp: 'ajh 3/24/2003 21:35' prior: 0! - I represent a primitive. I am more than just a number if I am a named primitive. - - Structure: - - num <Integer> Primitive number. - spec <Object> Stored in first literal when num is 117 or 120. - ! Item was removed: - ----- Method: Compiler class>>closureParserClass (in category 'accessing') ----- - closureParserClass - ^self error: 'not installed'.! Item was removed: - ----- Method: BytecodeAgnosticMethodNode>>prepareForRegeneration (in category 'debugger support') ----- - prepareForRegeneration - "Closure methods need to remove any remote temps prior to being regenerated." - (temporaries notEmpty and: [temporaries last isIndirectTempVector]) ifTrue: - [temporaries := temporaries allButLast]. - self accept: RegenerationPreparingVisitor new! Item was removed: - ----- Method: PrimitiveNode>>num: (in category 'as yet unclassified') ----- - num: n - - primitiveNum := n! Item was removed: - ----- Method: VariableNode>>beingAssignedToAnalyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - beingAssignedToAnalyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "No-op overridden by TempVariableNode"! Item was removed: - ----- Method: Parser>>properties (in category 'pragmas') ----- - properties - ^ properties ifNil: [ properties := MethodProperties new ]! Item was removed: - ----- Method: PrimitiveNode>>spec (in category 'as yet unclassified') ----- - spec - - ^ spec! Item was removed: - ParseNodeVisitor subclass: #RegenerationPreparingVisitor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! - - !RegenerationPreparingVisitor commentStamp: '<historical>' prior: 0! - I arrange that BlockNodes clean out any remote temps prior to being regenerated.! Item was removed: - ----- Method: TempVariableNode>>beingAssignedToAnalyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - beingAssignedToAnalyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - self addWriteWithin: scopeBlock at: rootNode locationCounter! Item was removed: - ----- Method: BytecodeAgnosticMethodNode>>blockExtentsToTempRefs (in category 'debugger support') ----- - blockExtentsToTempRefs - | blockExtentsToTempRefs methNode | - blockExtentsToTempRefs := encoder blockExtentsToTempRefs. - blockExtentsToTempRefs ifNil: - [methNode := sourceText - ifNil: "No source, use decompile string as source to map from" - [self parserClass new - encoderClass: encoder class; - parse: self decompileString - class: self methodClass] - ifNotNil: [self prepareForRegeneration. - self]. - methNode generate: #(0 0 0 0). "set bytecodes to map to" - blockExtentsToTempRefs := methNode encoder blockExtentsToTempRefs]. - ^blockExtentsToTempRefs! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>visitBlockNode: (in category 'visiting') ----- - visitBlockNode: aBlockNode - aBlockNode arguments do: - [:tempNode| - self renumberTemp: tempNode]. - aBlockNode temporaries do: - [:tempNode| - (tempNode scope >= 0 or: [tempNode isIndirectTempVector]) ifTrue: - [self renumberTemp: tempNode]]. - super visitBlockNode: aBlockNode! Item was removed: - ----- Method: PrimitiveNode>>printOn: (in category 'as yet unclassified') ----- - printOn: aStream - - aStream nextPutAll: 'primitive '; print: primitiveNum! Item was removed: - ----- Method: LeafNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "This is a no-op except in TempVariableNode" - ^self! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>renumberTemp: (in category 'private') ----- - renumberTemp: tempNode - | name newName | - tempNode isIndirectTempVector ifTrue: - [tempNode remoteTemps do: - [:remoteTempNode| self renumberTemp: remoteTempNode]. - ^self]. - (temps includes: tempNode) ifTrue: [^self]. - name := tempNode key. - name size >= 2 ifFalse: [^self]. - name first = $t ifFalse: [^self]. - 2 to: name size do: - [:i| - (name at: i) isDigit ifFalse: [^self]]. - newName := 't', (count := count + 1) printString. - tempNode name: newName key: newName code: tempNode code. - temps add: tempNode - ! Item was removed: - ParseNodeVisitor subclass: #TempNumberNormalizingVisitor - instanceVariableNames: 'count temps' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! Item was removed: - ----- Method: MethodNode>>prepareForRegeneration (in category 'converting') ----- - prepareForRegeneration - "Nothing to do for vanilla nodes."! Item was removed: - ----- Method: BlockNode>>ifOptimizedBlockHoistTempsInto: (in category 'code generation (closures)') ----- - ifOptimizedBlockHoistTempsInto: scopeBlock "<BlockNode>" - "This is a No-op for all nodes except non-optimized BlockNodes." - "Let's assume the special > 0 guard in MessageNode>>analyseTempsWithin:forValue:encoder: is correct. - Then we can simply hoist our temps up." - self assert: (arguments isNil or: [arguments size <= 1]). - (arguments notNil and: [arguments notEmpty]) ifTrue: - [scopeBlock addHoistedTemps: arguments. - arguments := #()]. - temporaries notEmpty ifTrue: - [scopeBlock addHoistedTemps: temporaries. - temporaries := #()]!

1 0

The Trunk: Kernel-eem.242.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

Andreas Raab uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.242.mcz ==================== Summary ==================== Name: Kernel-eem.242 Author: eem Time: 5 September 2009, 4:15:59 am UUID: 4732bd13-57f5-4cf0-90fb-0f951ea37509 Ancestors: Kernel-laza.241 Second package of eight in closure compiler fixes 9/5/2009. AdditionalMethodState replaces MethodProperties. Kernel support for Compiler-eem.78 & Compiler-eem.79. Add ProtoObject>>withArgs:executeMethod: for compiler's use indtead of adding a method under #DoIt. Make doesNotUnderstand: support resume:. Requires Exceptions-eem.12. Speed up instVarNamed: et al using ClassDescription>>instVarIndexFor:ifAbsent: Speed up Object>>species by using class prim directly. =============== Diff against Kernel-laza.241 =============== Item was added: + ----- Method: CompiledMethod>>methodClassAssociation (in category 'accessing') ----- + methodClassAssociation + "answer the association to the class that I am installed in, or nil if none." + ^self literalAt: self numLiterals! Item was added: + ----- Method: AdditionalMethodState>>includesProperty: (in category 'properties') ----- + includesProperty: aKey + "Test if the property aKey is present." + + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + propertyOrPragma := self basicAt: i. + (propertyOrPragma isVariableBinding + and: [propertyOrPragma key == aKey]) ifTrue: + [^true]]. + ^false! Item was changed: + ----- Method: CompiledMethod>>pragmas (in category 'accessing-pragmas & properties') ----- - ----- Method: CompiledMethod>>pragmas (in category 'accessing') ----- pragmas + | selectorOrProperties | + ^(selectorOrProperties := self penultimateLiteral) isMethodProperties + ifTrue: [selectorOrProperties pragmas] + ifFalse: [#()]! - "Answer an array of the pragmas of the reciever." - - ^ self properties pragmas.! Item was changed: ----- Method: CompiledMethod>>methodClass (in category 'accessing') ----- methodClass "answer the class that I am installed in" - | who | - self hasNewPropertyFormat ifFalse: - [^(who := self who first) == #unknown ifFalse: [who]]. "there are some activated old methods" ^(self literalAt: self numLiterals) value.! Item was changed: ----- Method: CompiledMethod>>selector: (in category 'accessing') ----- + selector: aSelector + "Set a method's selector. This is either the penultimate literal, + or, if the method has any properties or pragmas, the selector of + the MethodProperties stored in the penultimate literal." + | penultimateLiteral nl | + (penultimateLiteral := self penultimateLiteral) isMethodProperties + ifTrue: [penultimateLiteral selector: aSelector] + ifFalse: [(nl := self numLiterals) < 2 ifTrue: + [self error: 'insufficient literals to hold selector']. + self literalAt: nl - 1 put: aSelector]! - selector: aSymbol - self properties selector: aSymbol! Item was changed: ----- Method: CompiledMethod>>methodNode (in category 'decompiling') ----- methodNode "Return the parse tree that represents self" | aClass source | aClass := self methodClass. + source := self + getSourceFor: (self selector ifNil: [self defaultSelector]) + in: aClass. + ^(aClass parserClass new + encoderClass: (self isBlueBookCompiled + ifTrue: [EncoderForV3] + ifFalse: [EncoderForV3PlusClosures]); + parse: source class: aClass) + sourceText: source; + yourself! - ^ (source := self getSourceFromFile) - ifNil: [self decompile] - ifNotNil: [aClass parserClass new - encoderClass: (self isBlueBookCompiled - ifTrue: [EncoderForV3] - ifFalse: [EncoderForV3PlusClosures]); - parse: source class: aClass]! Item was changed: ----- Method: CompiledMethod>>properties (in category 'accessing') ----- properties "Answer the method properties of the receiver." + | propertiesOrSelector | + ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties + ifTrue: [propertiesOrSelector] + ifFalse: [AdditionalMethodState forMethod: self selector: propertiesOrSelector]! - - ^ self literalAt: self numLiterals - 1.! Item was added: + ----- Method: CompiledMethod>>primitiveErrorVariableName (in category 'printing') ----- + primitiveErrorVariableName + "Answer the primitive error code temp name, or nil if none." + self primitive > 0 ifTrue: + [self pragmas do: + [:pragma| | kwds ecIndex | + ((kwds := pragma keyword keywords) first = 'primitive:' + and: [(ecIndex := kwds indexOf: 'error:') > 0]) ifTrue: + [^pragma argumentAt: ecIndex]]]. + ^nil! Item was added: + ----- Method: MethodProperties>>isEmpty (in category 'testing') ----- + isEmpty + ^(properties isNil or: [properties isEmpty]) + and: [pragmas isNil or: [pragmas isEmpty]]! Item was added: + ----- Method: AdditionalMethodState>>notEmpty (in category 'testing') ----- + notEmpty + ^self basicSize > 0! Item was changed: ----- Method: CompiledMethod>>decompilerClass (in category 'decompiling') ----- decompilerClass + ^self compilerClass decompilerClass! - ^ self isClosureCompiled - ifTrue: [self compilerClass closureDecompilerClass] - ifFalse: [self compilerClass decompilerClass]! Item was added: + ----- Method: CompiledMethod>>who (in category 'printing') ----- + who + "Answer an Array of the class in which the receiver is defined and the + selector to which it corresponds." + + self hasNewPropertyFormat ifTrue:[^{self methodClass. self selector}]. + self systemNavigation allBehaviorsDo: + [:class | + (class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: + [:sel| ^Array with: class with: sel]]. + ^Array with: #unknown with: #unknown! Item was changed: ----- Method: CompiledMethod>>setSourcePointer: (in category 'source code management') ----- setSourcePointer: srcPointer + srcPointer = 0 ifTrue: [ + self at: self size put: 0. + ^self]. + (srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [self error: 'Source pointer out of range']. + self at: self size put: (srcPointer bitShift: -24) + 251. + 1 to: 3 do: [:i | + self at: self size-i put: ((srcPointer bitShift: (i-3)*8) bitAnd: 16rFF)]! - - self setMySourcePointer: srcPointer. - self embeddedBlockMethods do: [:m | - m setSourcePointer: srcPointer]. - ! Item was changed: ----- Method: Object>>instVarNamed: (in category 'system primitives') ----- instVarNamed: aString "Return the value of the instance variable in me with that name. Slow and unclean, but very useful. " + ^ self instVarAt: (self class + instVarIndexFor: aString asString + ifAbsent: [self error: 'no such inst var']) - ^ self instVarAt: (self class allInstVarNames indexOf: aString asString) ! Item was added: + ----- Method: CompiledMethod>>tempNamesString (in category 'source code management') ----- + tempNamesString + "Decompress the encoded temp names into a schematicTempNames string." + | sz flagByte | + flagByte := self at: (sz := self size). + (flagByte = 0 or: [flagByte > 251]) ifTrue: [^self error: 'not yet implemented']. + (flagByte = 251 + and: [(1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0]]) ifTrue: + [^self error: 'not yet implemented']. + ^self qDecompressFrom: (flagByte <= 127 + ifTrue: + [ReadStream on: self from: sz - flagByte to: sz - 1] + ifFalse: + [ReadStream on: self from: sz - (flagByte - 128 * 128 + (self at: sz - 1)) - 1 to: sz - 2])! Item was changed: ----- Method: ClassDescription>>chooseClassVarName (in category 'instance variables') ----- chooseClassVarName "Present the user with a list of class variable names and answer the one selected, or nil if none" + | lines labelStream allVars index | - | lines labelStream vars allVars index | lines := OrderedCollection new. allVars := OrderedCollection new. labelStream := WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: + [:class | | vars | - [:class | vars := class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index := (UIManager default chooseFrom: (labelStream contents substrings) lines: lines). index = 0 ifTrue: [^ nil]. + ^ allVars at: index! - ^ allVars at: index - ! Item was added: + ----- Method: BlockClosure>>isDead (in category 'testing') ----- + isDead + "Has self finished" + ^false! Item was changed: ----- Method: ContextPart>>methodNode (in category 'accessing') ----- methodNode - self method isBlockMethod ifTrue: [^ self method blockNode]. ^ self method methodNode.! Item was changed: ----- Method: CompiledMethod>>parserClass (in category 'decompiling') ----- parserClass + ^self methodClass + ifNil: [Compiler parserClass] + ifNotNil: [:class | class parserClass].! - ^ self isClosureCompiled - ifTrue: [self compilerClass closureParserClass] - ifFalse: [self compilerClass parserClass]! Item was changed: ----- Method: CompiledMethod>>flag (in category 'accessing') ----- flag "Answer the user-level flag bit" + ^((self header bitShift: -29) bitAnd: 1) = 1! - ^( (self header bitShift: -29) bitAnd: 1) = 1 - ifTrue: [ true ] - ifFalse: [ false ] - ! Item was added: + ----- Method: CompiledMethod>>propertyValueAt:ifAbsent: (in category 'accessing-pragmas & properties') ----- + propertyValueAt: propName ifAbsent: aBlock + | propertiesOrSelector | + ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties + ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: aBlock] + ifFalse: [aBlock value]! Item was changed: ----- Method: MethodProperties>>analogousCodeTo: (in category 'testing') ----- analogousCodeTo: aMethodProperties pragmas ifNil: [aMethodProperties pragmas notEmpty ifTrue: [^false]] ifNotNil: + [aMethodProperties pragmas empty ifTrue: [^false]. + pragmas size ~= aMethodProperties pragmas size ifTrue: - [pragmas size ~= aMethodProperties pragmas size ifTrue: [^false]. pragmas with: aMethodProperties pragmas do: [:mine :others| (mine analogousCodeTo: others) ifFalse: [^false]]]. - (self propertiesIsNil and: [aMethodProperties propertiesIsNil]) ifTrue: [^true]. ^(self hasAtLeastTheSamePropertiesAs: aMethodProperties) and: [aMethodProperties hasAtLeastTheSamePropertiesAs: self]! Item was added: + ----- Method: CompiledMethod>>messagesSequence (in category 'scanning') ----- + messagesSequence + "Answer a Set of all the message selectors sent by this method." + + ^Array streamContents: + [:str| | scanner | + scanner := InstructionStream on: self. + scanner scanFor: + [:x | | selectorOrSelf | + (selectorOrSelf := scanner selectorToSendOrSelf) == scanner ifFalse: + [str nextPut: selectorOrSelf]. + false "keep scanning"]]! Item was added: + ----- Method: MethodContext>>hasMethodReturn (in category 'accessing') ----- + hasMethodReturn + ^closureOrNil hasMethodReturn! Item was added: + ----- Method: CompiledMethod>>propertyValueAt:put: (in category 'accessing-pragmas & properties') ----- + propertyValueAt: propName put: propValue + "Set or add the property with key propName and value propValue. + If the receiver does not yet have a method properties create one and replace + the selector with it. Otherwise, either relace propValue in the method properties + or replace method properties with one containing the new property." + | propertiesOrSelector | + (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifFalse: + [self penultimateLiteral: ((AdditionalMethodState + selector: propertiesOrSelector + with: (Association + key: propName asSymbol + value: propValue)) + setMethod: self; + yourself). + ^propValue]. + (propertiesOrSelector includesProperty: propName) ifTrue: + [^propertiesOrSelector at: propName put: propValue]. + self penultimateLiteral: (propertiesOrSelector + copyWith: (Association + key: propName asSymbol + value: propValue)). + ^propValue! Item was changed: ----- Method: CompiledMethod>>literalsDo: (in category 'literals') ----- + literalsDo: aBlock + "Evaluate aBlock for each of the literals referenced by the receiver." + 1 to: self numLiterals do: + [:index | + aBlock value: (self objectAt: index + 1)]! - literalsDo: aOneArgumentBlock - - ^self literals do:aOneArgumentBlock.! Item was added: + ----- Method: AdditionalMethodState>>pragmas (in category 'accessing') ----- + pragmas + "Answer the raw messages comprising my pragmas." + | pragmaStream | + pragmaStream := WriteStream on: (Array new: self basicSize). + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Message>" | + (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: + [pragmaStream nextPut: propertyOrPragma]]. + ^pragmaStream contents! Item was added: + ----- Method: AdditionalMethodState>>at:ifAbsentPut: (in category 'accessing') ----- + at: aKey ifAbsentPut: aBlock + "Answer the property value or pragma associated with aKey or, + if aKey isn't found, answer the result of evaluating aBlock." + + 1 to: self basicSize do: + [:i | + | propertyOrPragma "<Association|Pragma>" | + (propertyOrPragma := self basicAt: i) key == aKey ifTrue: + [^propertyOrPragma isVariableBinding + ifTrue: [propertyOrPragma value] + ifFalse: [propertyOrPragma]]]. + ^method propertyValueAt: aKey put: aBlock value! Item was added: + ----- Method: AdditionalMethodState>>method: (in category 'decompiling') ----- + method: aMethodNodeOrNil + "For decompilation" + method := aMethodNodeOrNil! Item was changed: ----- Method: BlockClosure>>simulateValueWithArguments:caller: (in category 'evaluating') ----- simulateValueWithArguments: anArray caller: aContext | newContext sz | + (anArray class ~~ Array + or: [numArgs ~= anArray size]) ifTrue: + [^ContextPart primitiveFailToken]. - numArgs ~= anArray size ifTrue: - [self numArgsError: anArray size]. newContext := (MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc. sz := self basicSize. newContext stackp: sz + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: sz do: [:i| newContext at: i + numArgs put: (self at: i)]. ^newContext! Item was added: + ----- Method: AdditionalMethodState>>selector: (in category 'accessing') ----- + selector: aSymbol + selector := aSymbol! Item was added: + ----- Method: AdditionalMethodState>>removeKey: (in category 'properties') ----- + removeKey: aKey + "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." + + ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! Item was changed: ----- Method: CompiledMethod>>getSourceFor:in: (in category 'source code management') ----- getSourceFor: selector in: class "Retrieve or reconstruct the source code for this method." + | flagByte | - | source flagByte sourceSelector | flagByte := self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" + and: [((1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0])]]) + ifTrue: + ["No source pointer -- decompile without temp names" + ^ (class decompilerClass new decompile: selector in: class method: self) + decompileString]. - and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]]) - ifTrue: ["No source pointer -- decompile without temp names" - ^ self decompileString]. flagByte < 252 ifTrue: ["Magic sources -- decompile with temp names" + ^ ((class decompilerClass new withTempNames: self tempNamesString) - ^ ((self decompilerClass new withTempNames: self tempNames) decompile: selector in: class method: self) decompileString]. "Situation normal; read the sourceCode from the file" + ^self getSourceFromFile ifNil: + ["Something really wrong -- decompile blind (no temps)" + (class decompilerClass new decompile: selector in: class method: self) + decompileString]! - - [ source := self getSourceFromFile ] on: Error do: [ :ex | - "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." - source := nil ]. - - source ifNotNil: [ - sourceSelector := Parser parserClass new parseSelector: source. - ^sourceSelector = selector - ifTrue: [source] - ifFalse: [ - self replace: sourceSelector with: selector in: source]]. - - "Something really wrong -- decompile blind (no temps)" - ^ self decompileString! Item was changed: ----- Method: CompiledMethod>>endPC (in category 'accessing') ----- endPC "Answer the index of the last bytecode." + | size flagByte | + "Can't create a zero-sized CompiledMethod so no need to use last for the errorEmptyCollection check. + We can reuse size." + size := self size. + flagByte := self at: size. - | flagByte | - flagByte := self last. flagByte = 0 ifTrue: ["If last byte = 0, may be either 0, 0, 0, 0 or just 0" + 1 to: 4 do: [:i | (self at: size - i) = 0 ifFalse: [^size - i]]]. - 1 to: 4 do: [:i | (self at: self size - i) = 0 ifFalse: [^ self size - i]]]. flagByte < 252 ifTrue: + ["Magic sources (temp names encoded in last few bytes)" + ^flagByte <= 127 + ifTrue: [size - flagByte - 1] + ifFalse: [size - (flagByte - 128 * 128) - (self at: size - 1) - 2]]. - ["Magic sources (tempnames encoded in last few bytes)" - ^ self size - self last - 1]. "Normal 4-byte source pointer" + ^size - 4! - ^ self size - 4! Item was added: + ----- Method: CompiledMethod>>clearFlag (in category 'accessing') ----- + clearFlag + "Clear the user-level flag bit" + + self objectAt: 1 put: (self header bitAnd: (1 << 29) bitInvert)! Item was changed: ----- Method: MethodProperties>>pragmas (in category 'accessing') ----- pragmas + ^pragmas ifNil:[#()]! - ^ pragmas! Item was changed: ----- Method: CompiledMethod>>hasLiteralThorough: (in category 'literals') ----- + hasLiteralThorough: literal + "Answer true if any literal in this method is literal, + even if embedded in array structure." - hasLiteralThorough: aLiteral - "Answer true if any literal in this method is literal, even if embedded in array structure or within its pragmas." + (self penultimateLiteral isMethodProperties + and: [self penultimateLiteral hasLiteralThorough: literal]) ifTrue:[^true]. + 2 to: self numLiterals - 1 "exclude superclass + selector/properties" + do:[:index | | lit | + ((lit := self objectAt: index) == literal + or: [(lit isVariableBinding and: [lit key == literal]) + or: [lit isArray and: [lit hasLiteral: literal]]]) ifTrue: + [^ true]]. + ^ false ! - | literal | - self pragmas do: [ :pragma | - (pragma hasLiteral: aLiteral) ifTrue: [ ^ true ] ]. - 2 to: self numLiterals + 1 do: [ :index | - literal := self objectAt: index. - literal == aLiteral ifTrue: [ ^ true ]. - (literal hasLiteralThorough: aLiteral) ifTrue: [ ^ true ] ]. - ^ false.! Item was added: + ----- Method: AdditionalMethodState>>copyWithout: (in category 'copying') ----- + copyWithout: aPropertyOrPragma "<Association|Pragma>" + "Answer a copy of the receiver which no longer includes aPropertyOrPragma" + | bs copy offset | + copy := self class new: (bs := self basicSize) - ((self includes: aPropertyOrPragma) + ifTrue: [1] + ifFalse: [0]). + offset := 0. + 1 to: bs do: + [:i| + (self basicAt: i) = aPropertyOrPragma + ifTrue: [offset := 1] + ifFalse: [copy basicAt: i - offset put: (self basicAt: i)]]. + ^copy + selector: selector; + setMethod: method; + yourself + ! Item was added: + ----- Method: CompiledMethod>>penultimateLiteral (in category 'private') ----- + penultimateLiteral + "Answer the penultimate literal of the receiver, which holds either + the receiver's selector or its properties (which will hold the selector)." + | pIndex | + ^(pIndex := self numLiterals - 1) > 0 + ifTrue: [self literalAt: pIndex] + ifFalse: [nil]! Item was added: + ----- Method: AdditionalMethodState>>properties (in category 'accessing') ----- + properties + + | propertyStream | + propertyStream := WriteStream on: (Array new: self basicSize * 2). + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: + [propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]]. + ^IdentityDictionary newFromPairs: propertyStream contents! Item was changed: ----- Method: Pragma>>hasLiteralSuchThat: (in category 'testing') ----- hasLiteralSuchThat: aBlock + "Answer true if litBlock returns true for any literal in the receiver, even if embedded in further array structure. + This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" + ^(aBlock value: keyword) + or: [arguments hasLiteralSuchThat: aBlock]! - ^ (aBlock value: self keyword) - or: [ self arguments hasLiteralSuchThat: aBlock ].! Item was added: + ----- Method: CompiledMethod>>blockExtentsToTempsMap (in category 'debugger support') ----- + blockExtentsToTempsMap + "If the receiver has been copied with temp names answer a + map from blockExtent to temps map in the same format as + BytecodeEncoder>>blockExtentsToTempNamesMap. if the + receiver has not been copied with temps answer nil." + ^self holdsTempNames ifTrue: + [self mapFromBlockKeys: ((self startpcsToBlockExtents associations asSortedCollection: + [:a1 :a2| a1 key < a2 key]) collect: + [:assoc| assoc value]) + toSchematicTemps: self tempNamesString]! Item was added: + ----- Method: AdditionalMethodState>>keysAndValuesDo: (in category 'accessing') ----- + keysAndValuesDo: aBlock + "Enumerate the receiver with all the keys and values." + + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + (propertyOrPragma := self basicAt: i) isVariableBinding + ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value] + ifFalse: [aBlock value: propertyOrPragma keyword value: propertyOrPragma]]! Item was changed: ----- Method: Object>>doesNotUnderstand: (in category 'error handling') ----- doesNotUnderstand: aMessage + "Handle the fact that there was an attempt to send the given + message to the receiver but the receiver does not understand + this message (typically sent from the machine when a message + is sent to the receiver and no method is defined for that selector)." + - "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." "Testing: (3 activeProcess)" + | exception resumeValue | + (Preferences autoAccessors + and: [self tryToDefineVariableAccess: aMessage]) ifTrue: + [^aMessage sentTo: self]. + + (exception := MessageNotUnderstood new) - MessageNotUnderstood new message: aMessage; + receiver: self. + resumeValue := exception signal. + ^exception reachedDefaultHandler + ifTrue: [aMessage sentTo: self] + ifFalse: [resumeValue]! - receiver: self; - signal. - ^ aMessage sentTo: self. - ! Item was added: + ----- Method: AdditionalMethodState>>propertyValueAt:ifAbsent: (in category 'properties') ----- + propertyValueAt: aKey ifAbsent: aBlock + "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." + + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + propertyOrPragma := self basicAt: i. + (propertyOrPragma isVariableBinding + and: [propertyOrPragma key == aKey]) ifTrue: + [^propertyOrPragma value]]. + ^aBlock value! Item was added: + Object variableSubclass: #AdditionalMethodState + instanceVariableNames: 'method selector' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Methods'! + + !AdditionalMethodState commentStamp: '<historical>' prior: 0! + I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. Currently I hold the selector and any pragmas or properties the compiled method has. Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association. + + I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries. Hence I answer true to isMethodProperties.! Item was changed: ----- Method: CompiledMethod>>indexOfLiteral: (in category 'literals') ----- indexOfLiteral: literal "Answer the literal index of the argument, literal, or zero if none." + 2 to: self numLiterals - 1 "exclude superclass + selector/properties" + do: - | max | - max := self numLiterals. - max := self hasNewPropertyFormat - ifTrue: [max - 1] "exclude superclass + properties" - ifFalse: [max + 1]. - 2 to: max do: [:index | literal == (self objectAt: index) ifTrue: [^index - 1]]. ^0! Item was added: + ----- Method: CompiledMethod>>propertyKeysAndValuesDo: (in category 'accessing-pragmas & properties') ----- + propertyKeysAndValuesDo: aBlock + "Enumerate the receiver with all the keys and values." + + | propertiesOrSelector | + (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: + [propertiesOrSelector propertyKeysAndValuesDo: aBlock]! Item was changed: ----- Method: CompiledMethod>>compilerClass (in category 'decompiling') ----- compilerClass ^self methodClass + ifNil: [Compiler] + ifNotNil: [:class | class compilerClass].! - ifNil: [self class compilerClass] - ifNotNilDo: [:class | class compilerClass].! Item was changed: ----- Method: CompiledMethod>>literalStrings (in category 'literals') ----- literalStrings + | litStrs | + litStrs := OrderedCollection new: self numLiterals. + self literalsDo: - | lits litStrs | - lits := self literals. - litStrs := OrderedCollection new: lits size * 3. - self literals do: [:lit | (lit isVariableBinding) ifTrue: [litStrs addLast: lit key] ifFalse: [(lit isSymbol) ifTrue: [litStrs addAll: lit keywords] ifFalse: [litStrs addLast: lit printString]]]. ^ litStrs! Item was added: + ----- Method: CompiledMethod>>penultimateLiteral: (in category 'private') ----- + penultimateLiteral: anObject + "Answer the penultimate literal of the receiver, which holds either + the receiver's selector or its properties (which will hold the selector)." + | pIndex | + (pIndex := self numLiterals - 1) > 0 + ifTrue: [self literalAt: pIndex put: anObject] + ifFalse: [self error: 'insufficient literals']! Item was added: + ----- Method: Message>>analogousCodeTo: (in category 'comparing') ----- + analogousCodeTo: anObject + "For MethodPropertires comparison." + ^self class == anObject class + and: [selector == anObject selector + and: [args = anObject arguments + and: [lookupClass == anObject lookupClass]]]! Item was added: + ----- Method: MethodProperties>>propertyValueAt:ifAbsent: (in category 'properties') ----- + propertyValueAt: aKey ifAbsent: aBlock + "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." + ^self at: aKey ifAbsent: aBlock! Item was changed: ----- Method: BlockClosure>>fixTemps (in category 'private') ----- fixTemps + "Fix the values of the temporary variables used in the block that + are ordinarily shared with the method in which the block is defined. + This is a no-op for closures, provided for backward-compatibility with + old BlockContexts that needed the fixTemps hack to persist."! - "Fix the values of the temporary variables used in the block that are - ordinarily shared with the method in which the block is defined. We - need to copy the copiedValues, copying anything looking like a remote - temp vector. if we accidentally copy an Array that isn't actually an - indirect temp vector we may break things, so this is a real hack." - - 1 to: self numCopiedValues do: - [:i| | each | - (each := self at: i) isArray ifTrue: - [self at: i put: each shallowCopy]]! Item was added: + ----- Method: CompiledMethod>>propertyValueAt: (in category 'accessing-pragmas & properties') ----- + propertyValueAt: propName + | propertiesOrSelector | + ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties + ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: [nil]] + ifFalse: [nil]! Item was changed: ----- Method: CompiledMethod>>hasLiteralSuchThat: (in category 'literals') ----- + hasLiteralSuchThat: litBlock + "Answer true if litBlock returns true for any literal in this method, even if embedded in array structure." + (self penultimateLiteral isMethodProperties + and: [self penultimateLiteral hasLiteralSuchThat: litBlock]) ifTrue: + [^true]. + 2 to: self numLiterals + 1 do: + [:index | | lit | + lit := self objectAt: index. + ((litBlock value: lit) + or: [lit isArray and: [lit hasLiteralSuchThat: litBlock]]) ifTrue: + [^true]]. + ^false! - hasLiteralSuchThat: aBlock - "Answer true if aBlock returns true for any literal in this method, even if imbedded in array structure or within its pragmas." - - | literal | - self pragmas do: [ :pragma | - (pragma hasLiteralSuchThat: aBlock) - ifTrue: [ ^ true ] ]. - 2 to: self numLiterals + 1 do: [ :index | - literal := self objectAt: index. - (aBlock value: literal) - ifTrue: [ ^ true ]. - (literal hasLiteralSuchThat: aBlock) - ifTrue: [ ^ true ] ]. - ^ false.! Item was changed: ----- Method: Pragma>>arguments (in category 'accessing-pragma') ----- arguments + "Answer the arguments of the receiving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #(val1 val2)." - "Answer the arguments of the recieving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #(val1 val2)." ^ arguments! Item was added: + ----- Method: CompiledMethod>>qCompress: (in category 'source code management') ----- + qCompress: string + "A very simple text compression routine designed for method temp names. + Most common 11 chars get values 1-11 packed in one 4-bit nibble; + the next most common get values 12-15 (2 bits) * 16 plus next nibble; + unusual ones get three nibbles, the first being the escape nibble 0. + CompiledMethod>>endPC determines the maximum length of encoded + output, which means 1 to (251 - 128) * 128 + 127, or 15871 bytes" + string isEmpty ifTrue: + [^self qCompress: ' ']. + ^ ByteArray streamContents: + [:strm | | ix oddNibble sz | + oddNibble := nil. + string do: + [:char | + ix := 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()' + indexOf: char ifAbsent: 0. + (ix = 0 + ifTrue: + [char asInteger > 255 ifTrue: [^nil]. "Could use UTF8 here; too lazy right now" + { 0. char asInteger // 16. char asInteger \\ 16 }] + ifFalse: + [ix <= 11 + ifTrue: [{ ix }] + ifFalse: [{ ix//16+12. ix\\16 }]]) + do: [:nibble | + oddNibble + ifNotNil: [strm nextPut: oddNibble*16 + nibble. oddNibble := nil] + ifNil: [oddNibble := nibble]]]. + oddNibble ifNotNil: "4 = 'ear tonsil' indexOf: Character space" + [strm nextPut: oddNibble * 16 + 4]. + (sz := strm position) > ((251 - 128) * 128 + 127) ifTrue: + [^nil]. + sz <= 127 + ifTrue: [strm nextPut: sz] + ifFalse: + [strm nextPut: sz \\ 128; nextPut: sz // 128 + 128]]! Item was changed: ----- Method: CompiledMethod>>holdsTempNames (in category 'source code management') ----- holdsTempNames "Are tempNames stored in trailer bytes" | flagByte | flagByte := self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" + and: [(1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0]]]) - and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]]) ifTrue: [^ false]. "No source pointer & no temp names" flagByte < 252 ifTrue: [^ true]. "temp names compressed" ^ false "Source pointer" ! Item was changed: ----- Method: MethodProperties>>addPragma: (in category 'private') ----- addPragma: aPragma + pragmas := self pragmas copyWith: aPragma.! - pragmas := pragmas copyWith: aPragma.! Item was added: + ----- Method: AdditionalMethodState>>hasLiteralThorough: (in category 'testing') ----- + hasLiteralThorough: literal + "Answer true if any literal in these properties is literal, + even if embedded in array structure." + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + propertyOrPragma := self basicAt: i. + (propertyOrPragma isVariableBinding + ifTrue: [propertyOrPragma key == literal + or: [propertyOrPragma value == literal + or: [propertyOrPragma value isArray + and: [propertyOrPragma value hasLiteral: literal]]]] + ifFalse: [propertyOrPragma hasLiteral: literal]) ifTrue: + [^true]]. + ^false! Item was added: + ----- Method: MessageSend>>numArgs (in category 'accessing') ----- + numArgs + "Answer the number of arguments in this message" + + ^arguments size! Item was added: + ----- Method: AdditionalMethodState>>at:put: (in category 'accessing') ----- + at: aKey put: aValue + "Replace the property value or pragma associated with aKey." + + 1 to: self basicSize do: + [:i | + | propertyOrPragma "<Association|Pragma>" | + (propertyOrPragma := self basicAt: i) key == aKey ifTrue: + [propertyOrPragma isVariableBinding + ifTrue: [propertyOrPragma value: aValue] + ifFalse: [self basicAt: i put: aValue]]]. + ^method propertyValueAt: aKey put: aValue! Item was added: + ----- Method: MethodProperties>>pragmas: (in category 'accessing') ----- + pragmas: anArray + pragmas := anArray! Item was added: + ----- Method: MethodProperties>>notEmpty (in category 'testing') ----- + notEmpty + ^(properties notNil and: [properties notEmpty]) + or: [pragmas notNil and: [pragmas notEmpty]]! Item was changed: ----- Method: CompiledMethod>>selector (in category 'accessing') ----- selector + "Answer a method's selector. This is either the penultimate literal, + or, if the method has any properties or pragmas, the selector of + the MethodProperties stored in the penultimate literal." + | penultimateLiteral | + ^(penultimateLiteral := self penultimateLiteral) isMethodProperties + ifTrue: [penultimateLiteral selector] + ifFalse: [penultimateLiteral]! - ^self properties selector.! Item was added: + ----- Method: AdditionalMethodState>>copyWith: (in category 'copying') ----- + copyWith: aPropertyOrPragma "<Association|Pragma>" + "Answer a copy of the receiver which includes aPropertyOrPragma" + | bs copy | + (Association == aPropertyOrPragma class + or: [Pragma == aPropertyOrPragma class]) ifFalse: + [self error: self class name, ' instances should hold only Associations or Pragmas.']. + copy := self class new: (bs := self basicSize) + 1. + 1 to: bs do: + [:i| + copy basicAt: i put: (self basicAt: i)]. + copy basicAt: bs + 1 put: aPropertyOrPragma. + ^copy + selector: selector; + setMethod: method; + yourself + ! Item was added: + ----- Method: ProtoObject>>withArgs:executeMethod: (in category 'debugging') ----- + withArgs: argArray executeMethod: compiledMethod + "Execute compiledMethod against the receiver and args in argArray" + + <primitive: 188> + self primitiveFailed! Item was added: + ----- Method: AdditionalMethodState>>setMethod: (in category 'accessing') ----- + setMethod: aMethod + method := aMethod. + 1 to: self basicSize do: + [:i| | propertyOrPragma "<Association|Pragma>" | + (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: + [propertyOrPragma setMethod: aMethod]]! Item was added: + ----- Method: AdditionalMethodState>>propertyKeysAndValuesDo: (in category 'properties') ----- + propertyKeysAndValuesDo: aBlock + "Enumerate the receiver with all the keys and values." + + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: + [aBlock value: propertyOrPragma key value: propertyOrPragma value]]! Item was added: + ----- Method: ContextPart>>isContext (in category 'query') ----- + isContext + ^true! Item was changed: ----- Method: CompiledMethod>>properties: (in category 'accessing') ----- properties: aMethodProperties "Set the method-properties of the receiver to aMethodProperties." + self literalAt: self numLiterals - 1 + put: (aMethodProperties isEmpty + ifTrue: [aMethodProperties selector] + ifFalse: [aMethodProperties + setMethod: self; + yourself])! - - aMethodProperties pragmas do: [ :each | each setMethod: self ]. - ^ self literalAt: self numLiterals - 1 put: aMethodProperties.! Item was changed: ----- Method: Object>>caseError (in category 'error handling') ----- caseError "Report an error from an in-line or explicit case statement." + self error: 'Case not found (', self printString, '), and no otherwise clause'! - self error: 'Case not found, and no otherwise clause'! Item was added: + ----- Method: AdditionalMethodState>>propertyValueAt: (in category 'properties') ----- + propertyValueAt: aKey + "Answer the property value associated with aKey." + + ^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].! Item was added: + ----- Method: MethodProperties>>setMethod: (in category 'forward compatibility') ----- + setMethod: ignored + "For forward compatibility wth AdditionalMethodState"! Item was added: + ----- Method: AdditionalMethodState>>hasLiteralSuchThat: (in category 'testing') ----- + hasLiteralSuchThat: aBlock + "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. + This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + propertyOrPragma := self basicAt: i. + (propertyOrPragma isVariableBinding + ifTrue: [(aBlock value: propertyOrPragma key) + or: [(aBlock value: propertyOrPragma value) + or: [propertyOrPragma value isArray + and: [propertyOrPragma value hasLiteralSuchThat: aBlock]]]] + ifFalse: [propertyOrPragma hasLiteralSuchThat: aBlock]) ifTrue: + [^true]]. + ^false! Item was changed: ----- Method: CompiledMethod>>printOn: (in category 'printing') ----- printOn: aStream "Overrides method inherited from the byte arrayed collection." self printNameOn: aStream. + aStream nextPut: $(; print: self identityHash; nextPutAll: ': '; + print: self methodClass; nextPutAll: '>>'; nextPutAll: self selector; nextPut: $). + "aStream space; nextPutAll: self identityHashPrintString" + ! - aStream space; nextPutAll: self identityHashPrintString! Item was changed: ----- Method: Pragma>>hasLiteral: (in category 'testing') ----- hasLiteral: aLiteral + ^keyword == aLiteral + or: [arguments hasLiteral: aLiteral]! - ^ self keyword == aLiteral - or: [ self arguments hasLiteral: aLiteral ].! Item was changed: ----- Method: Categorizer class>>allCategory (in category 'class initialization') ----- allCategory "Return a symbol that represents the virtual all methods category." + ^#'-- all --'! - ^ '-- all --' asSymbol! Item was changed: Object subclass: #Pragma instanceVariableNames: 'method keyword arguments' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !Pragma commentStamp: '<historical>' prior: 0! + I represent an occurrence of a pragma in a compiled method. A pragma is a literal message pattern that occurs between angle brackets at the start of a method after any temporaries. A common example is the primitive pragma: + <primitive: 123 errorCode: 'errorCode'> + but one can add one's own and use them as metadata attached to a method. Because pragmas are messages one can browsse senders and implementors and perform them. One can query a method for its pragmas by sendng it the pragmas message, which answers an Array of instances of me, one for each pragma in the method. + + I can provide information about the defining class, method, its selector, as well as the information about the pragma keyword and its arguments. See the two 'accessing' protocols for details. 'accessing-method' provides information about the method the pragma is found in, while 'accessing-pragma' is about the pragma itself. - I represent a pragma instance found in a compiled method. I can provide information about the defining class, method, its selector, as well as the information about the pragma keyword and its arguments. See the two 'accessing' protocols for details. 'accessing-method' provides information about the method the pragma is found in, while 'accessing-pragma' is about the pragma itself. + Instances are retrieved using one of the pragma search methods of the 'finding' protocol on the class side. + + To browse all methods with pragmas in the system evaluate + SystemNavigation default browseAllSelect: [:m| m pragmas notEmpty] + and to browse all nonprimitive methods with pragmas evaluate + SystemNavigation default browseAllSelect: [:m| m primitive isZero and: [m pragmas notEmpty]]! - Instances are retreived using one of the pragma search methods of the 'finding' protocol on the class side.! Item was added: + ----- Method: CompiledMethod>>removeProperty: (in category 'accessing-pragmas & properties') ----- + removeProperty: propName + "Remove the property propName if it exists. + Do _not_ raise an error if the property is missing." + | value | + value := self propertyValueAt: propName ifAbsent: [^nil]. + self penultimateLiteral: (self penultimateLiteral copyWithout: + (Association + key: propName + value: value)). + ^value! Item was changed: ----- Method: Object>>instVarNamed:put: (in category 'system primitives') ----- instVarNamed: aString put: aValue "Store into the value of the instance variable in me of that name. Slow and unclean, but very useful. " + ^self + instVarAt: (self class + instVarIndexFor: aString asString + ifAbsent: [self error: 'no such inst var']) + put: aValue - ^ self instVarAt: (self class allInstVarNames indexOf: aString asString) put: aValue ! Item was added: + ----- Method: MethodProperties>>hasLiteralSuchThat: (in category 'testing') ----- + hasLiteralSuchThat: aBlock + "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. + This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" + properties ifNil:[^false]. + properties keysAndValuesDo: [:key :value | + ((aBlock value: key) + or: [(aBlock value: value) + or: [value isArray + and: [value hasLiteralSuchThat: aBlock]]]) ifTrue: [^true]]. + ^false! Item was added: + ----- Method: AdditionalMethodState>>selector (in category 'accessing') ----- + selector + ^selector! Item was added: + ----- Method: CompiledMethod>>tempsSubSequenceFrom: (in category 'debugger support') ----- + tempsSubSequenceFrom: tempNamesStream + ^Array streamContents: + [:tsss| + [tempNamesStream skipSeparators. + tempNamesStream atEnd + or: ['[]()' includes: tempNamesStream peek]] whileFalse: + [tsss nextPut: (String streamContents: + [:s| + [s nextPut: tempNamesStream next. + tempNamesStream peek + ifNil: [true] + ifNotNil: [:peek| ' []()' includes: peek]] whileFalse])]] + + "thisContext method tempsSubSequenceFrom: 'les temps perdu(sont n''est pas la)' readStream" + "thisContext method tempsSubSequenceFrom: ('les temps perdu(sont n''est pas la)' readStream skipTo: $(; yourself)"! Item was changed: ----- Method: CompiledMethod>>isInstalled (in category 'testing') ----- isInstalled + self methodClass ifNotNil: + [:class| + self selector ifNotNil: + [:selector| + ^self == (class methodDict at: selector ifAbsent: [])]]. + ^false! - | class selector | - class := self methodClass ifNil: [^false]. - selector := self selector ifNil: [^false]. - ^self == (class methodDict at: selector ifAbsent: [^false]).! Item was added: + ----- Method: AdditionalMethodState>>isEmpty (in category 'testing') ----- + isEmpty + ^self basicSize = 0! Item was changed: ----- Method: Pragma>>selector (in category 'accessing-method') ----- selector + "Answer the selector of the method containing the pragma. + Do not confuse this with the selector of the pragma's message pattern." - "Answer the selector of the method containing the pragma." + ^method selector! - ^ method selector.! Item was added: + ----- Method: AdditionalMethodState>>at: (in category 'accessing') ----- + at: aKey + "Answer the property value or pragma associated with aKey." + + ^self at: aKey ifAbsent: [self error: 'not found']! Item was added: + ----- Method: AdditionalMethodState class>>selector:with: (in category 'instance creation') ----- + selector: aSelector with: aPropertyOrPragma + ^(self basicNew: 1) + selector: aSelector; + basicAt: 1 put: aPropertyOrPragma; + yourself! Item was changed: + ----- Method: MethodProperties>>keysAndValuesDo: (in category 'properties') ----- - ----- Method: MethodProperties>>keysAndValuesDo: (in category 'accessing') ----- keysAndValuesDo: aBlock + "Enumerate the receiver with all the keys and values." + ^properties ifNotNil:[properties keysAndValuesDo: aBlock]! - properties keysAndValuesDo: aBlock! Item was changed: ----- Method: CompiledMethod>>printPrimitiveOn: (in category 'printing') ----- printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | + (primIndex := self primitive) = 0 ifTrue: + [^self]. + primIndex = 120 ifTrue: "External call spec" + [^aStream print: (self literalAt: 1); cr]. - primIndex := self primitive. - primIndex = 0 ifTrue:[^self]. - primIndex = 120 "External call spec" - ifTrue:[^aStream print: (self literalAt: 1); cr]. aStream nextPutAll: '<primitive: '. + primIndex = 117 + ifTrue: + [primDecl := self literalAt: 1. + (primDecl at: 2) asString printOn: aStream. + (primDecl at: 1) ifNotNil: + [:moduleName| + aStream nextPutAll:' module: '. + moduleName asString printOn: aStream]] + ifFalse: + [aStream print: primIndex]. + self primitiveErrorVariableName ifNotNil: + [:primitiveErrorVariableName| + aStream nextPutAll: ' error: '; nextPutAll: primitiveErrorVariableName]. - primIndex = 117 ifTrue:[ - primDecl := self literalAt: 1. - aStream - nextPut: $'; - nextPutAll: (primDecl at: 2); - nextPut:$'. - (primDecl at: 1) notNil ifTrue:[ - aStream - nextPutAll:' module:'; - nextPut:$'; - nextPutAll: (primDecl at: 1); - nextPut:$'. - ]. - ] ifFalse:[aStream print: primIndex]. aStream nextPut: $>; cr! Item was changed: ----- Method: CompiledMethod>>hasLiteral: (in category 'literals') ----- + hasLiteral: literal - hasLiteral: literal "Answer whether the receiver references the argument, literal." + 2 to: self numLiterals - 1 "exclude superclass + selector/properties" + do:[:index | + literal == (self objectAt: index) ifTrue: [^true]]. + ^false! - - <primitive: 132> "a fast primitive operation equivalent to..." - - 2 to: self numLiterals + 1 do: - [:index | - literal == (self objectAt: index) ifTrue: [^ true]]. - ^ false! Item was added: + ----- Method: Object>>isContext (in category 'testing') ----- + isContext + ^false! Item was added: + ----- Method: AdditionalMethodState>>analogousCodeTo: (in category 'testing') ----- + analogousCodeTo: aMethodProperties + | bs | + (bs := self basicSize) ~= aMethodProperties basicSize ifTrue: + [^false]. + 1 to: bs do: + [:i| + ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: + [^false]]. + ^true! Item was changed: + ----- Method: Pragma>>analogousCodeTo: (in category 'comparing') ----- + analogousCodeTo: anObject + ^self class == anObject class + and: [keyword == anObject keyword + and: [arguments = anObject arguments]]! - ----- Method: Pragma>>analogousCodeTo: (in category 'testing') ----- - analogousCodeTo: aPragma - ^ (self arguments = aPragma arguments) & - (self keyword = aPragma keyword)! Item was changed: ----- Method: Pragma>>message (in category 'accessing-pragma') ----- message + "Answer the message of the receiving pragma." - "Answer the message of the recieving pragma." ^ Message selector: self keyword arguments: self arguments. ! Item was added: + ----- Method: Pragma class>>for:selector:arguments: (in category 'instance creation') ----- + for: aMethod selector: aSelector arguments: anArray + ^self new + setMethod: aMethod; + setKeyword: aSelector; + setArguments: anArray; + yourself! Item was changed: ----- Method: ContextPart>>stackPtr (in category 'private') ----- + stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc" - stackPtr "For use only by the SystemTracer" ^ stackp! Item was added: + ----- Method: MethodProperties>>hasLiteralThorough: (in category 'testing') ----- + hasLiteralThorough: literal + "Answer true if any literal in this method is literal, + even if embedded in array structure." + properties ifNil:[^false]. + properties keysAndValuesDo: [:key :value | + key == literal ifTrue: [^true]. + value == literal ifTrue:[^true]. + (value class == Array and: [value hasLiteral: literal]) ifTrue: [^ true]]. + ^false! Item was changed: ----- Method: Pragma>>keyword (in category 'accessing-pragma') ----- keyword + "Answer the keyword of the pragma (the selector of its message pattern). + For a pragma defined as <key1: val1 key2: val2> this will answer #key1:key2:." - "Answer the keyword of the recieving pragma. For a pragma defined as <key1: val1 key2: val2> this will answer #key1:key2." ^ keyword! Item was changed: ----- Method: CompiledMethod>>startpcsToBlockExtents (in category 'debugger support') ----- startpcsToBlockExtents "Answer a Dictionary of startpc to Interval of blockExtent, using the identical numbering scheme described in and orchestrated by BlockNode>>analyseArguments:temporaries:rootNode:. This is used in part to find the temp names for any block in a method, as needed by the debugger. The other half is to recompile the method, + obtaining the temp names for each block extent. By indirecting through - obtainign the temp names for each block extent. By indirecting through the blockExtent instead of using the startpc directly we decouple the + debugger's access to temp names from the exact bytecode; insulating - debugger's access to temp names form the exact bytecode; insulating debugging from minor changes in the compiler (e.g. changes in literal pooling, adding prefix bytecodes, adding inst vars to CompiledMethod in literals towards the end of the literal frame, etc). If the recompilation doesn't produce exactly the same bytecode at exactly the same offset no matter; the blockExtents will be the same." | index | self flag: 'belongs in DebuggerMethodMap'. index := 0. ^self blockExtentsInto: Dictionary new from: self initialPC to: self endPC scanner: (InstructionStream on: self) numberer: [| value | value := index. index := index + 2. value]! Item was changed: ----- Method: Object>>species (in category 'private') ----- species "Answer the preferred class for reconstructing the receiver. For example, collections create new collections whenever enumeration messages such as collect: or select: are invoked. The new kind of collection is determined by the species of the original collection. Species and class are not always the same. For example, the species of Interval is Array." + <primitive: 111> - ^self class! Item was added: + ----- Method: CompiledMethod>>pragmaAt: (in category 'accessing-pragmas & properties') ----- + pragmaAt: aKey + "Answer the pragma with selector aKey, or nil if none." + | propertiesOrSelector | + ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties + ifTrue: [propertiesOrSelector at: aKey ifAbsent: [nil]] + ifFalse: [nil]! Item was changed: ----- Method: MethodContext>>cannotReturn: (in category 'private-exceptions') ----- cannotReturn: result closureOrNil notNil ifTrue: + [^self cannotReturn: result to: self home sender]. - [^self cannotReturn: result to: sender]. ToolSet debugContext: thisContext label: 'computation has been terminated' contents: nil! Item was added: + ----- Method: Message>>numArgs (in category 'accessing') ----- + numArgs + "Answer the number of arguments in this message" + + ^args size! Item was added: + ----- Method: CompiledMethod>>removeProperty:ifAbsent: (in category 'accessing-pragmas & properties') ----- + removeProperty: propName ifAbsent: aBlock + "Remove the property propName if it exists. + Answer the evaluation of aBlock if the property is missing." + | value | + value := self propertyValueAt: propName ifAbsent: [^aBlock value]. + self penultimateLiteral: (self penultimateLiteral copyWithout: + (Association + key: propName + value: value)). + ^value! Item was added: + ----- Method: ClassDescription>>instVarIndexFor:ifAbsent: (in category 'instance variables') ----- + instVarIndexFor: instVarName ifAbsent: aBlock + "Answer the index of the named instance variable." + + | index | + index := instanceVariables == nil + ifTrue: [0] + ifFalse: [instanceVariables indexOf: instVarName ifAbsent: [0]]. + index == 0 ifTrue: + [^superclass == nil + ifTrue: [aBlock value] + ifFalse: [superclass instVarIndexFor: instVarName ifAbsent: aBlock]]. + ^superclass == nil + ifTrue: [index] + ifFalse: [index + superclass instSize]! Item was added: + ----- Method: CompiledMethod>>mapFromBlockKeys:toSchematicTemps: (in category 'debugger support') ----- + mapFromBlockKeys: keys toSchematicTemps: schematicTempNamesString + "Decode a schematicTempNamesString that encodes the layout of temp names + in a method and any closures/blocks within it, matching keys in keys to + vectors of temp names." + | map tempNames | + map := Dictionary new. + tempNames := schematicTempNamesString readStream. + keys do: + [:key| | tempSequence tempIndex | + tempSequence := OrderedCollection new. + tempIndex := 0. + [(tempNames skipSeparators; peek) ifNil: [true] ifNotNil: [:ch| '[]' includes: ch]] whileFalse: + [tempNames peek = $( + ifTrue: [tempSequence addAllLast: ((self tempsSubSequenceFrom: (tempNames next; yourself)) withIndexCollect: + [:temp :index| + { temp. { tempIndex + 1. index } }]). + tempNames peek ~= $) ifTrue: [self error: 'parse error']. + tempIndex := tempIndex + 1. + tempNames next] + ifFalse: [tempSequence addAllLast: ((self tempsSubSequenceFrom: tempNames) withIndexCollect: + [:temp :index| + { temp. tempIndex := tempIndex + 1 }])]]. + map at: key put: tempSequence asArray. + [tempNames peek = $]] whileTrue: [tempNames next]. + tempNames peek = $[ ifTrue: + [tempNames next]]. + ^map! Item was added: + ----- Method: AdditionalMethodState>>includesKey: (in category 'testing') ----- + includesKey: aKey + "Test if the property aKey or pragma with selector aKey is present." + + 1 to: self basicSize do: + [:i | + (self basicAt: i) key == aKey ifTrue: + [^true]]. + ^false! Item was added: + ----- Method: CompiledMethod>>copyWithTempsFromMethodNode: (in category 'source code management') ----- + copyWithTempsFromMethodNode: aMethodNode + ^self copyWithTrailerBytes: (self qCompress: aMethodNode schematicTempNamesString)! Item was added: + ----- Method: Pragma>>key (in category 'accessing-pragma') ----- + key + "Answer the keyword of the pragma (the selector of its message pattern). + This accessor provides polymorphism with Associations used for properties." + ^keyword! Item was changed: ----- Method: CompiledMethod>>scanVeryLongStore:offset: (in category 'scanning') ----- scanVeryLongStore: extension offset: offset "Answer whether the receiver contains a long load with the given offset. Note that the constant +32 is the known difference between a store and a storePop for instVars, and it will always fail on literal variables, but these only use store (followed by pop) anyway." + | scanner | - | scanner ext | scanner := InstructionStream on: self. + ^scanner scanFor: + [:instr | | ext | + (instr = 132 and: [(ext := scanner followingByte) = extension - ^ scanner scanFor: - [:instr | (instr = 132 and: [(ext := scanner followingByte) = extension or: ["might be a store/pop into rcvr" ext = (extension+32)]]) + and: [scanner thirdByte = offset]]! - and: [scanner thirdByte = offset]]! Item was changed: ----- Method: BlockClosure>>numArgsError: (in category 'error handing') ----- numArgsError: numArgsForInvocation | printNArgs | printNArgs := [:n| n printString, ' argument', (n = 1 ifTrue: [''] ifFalse:['s'])]. self error: 'This block accepts ', (printNArgs value: numArgs), + ', but was called with ', (printNArgs value: numArgsForInvocation), '.'! - ', but was called with ', (printNArgs value: numArgsForInvocation printString), '.'! Item was changed: ----- Method: CompiledMethod>>putSource:fromParseNode:inFile:withPreamble: (in category 'source code management') ----- putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock "Store the source code for the receiver on an external file. If no sources are available, i.e., SourceFile is nil, then store temp names for decompilation at the end of the method. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, in each case, storing a 4-byte source code pointer at the method end." | file remoteString | (SourceFiles == nil or: [(file := SourceFiles at: fileIndex) == nil]) ifTrue: + [^self become: (self copyWithTempsFromMethodNode: methodNode)]. - [^self become: (self copyWithTempNames: methodNode tempNames)]. SmalltalkImage current assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" remoteString := RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. file nextChunkPut: ' '. InMidstOfFileinNotification signal ifFalse: [file flush]. self checkOKToAdd: sourceStr size at: remoteString position. self setSourcePosition: remoteString position inFile: fileIndex! Item was added: + ----- Method: AdditionalMethodState>>removeKey:ifAbsent: (in category 'accessing') ----- + removeKey: aKey ifAbsent: aBlock + "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." + + 1 to: self basicSize do: [:i | + | propertyOrPragma "<Association|Pragma>" | + propertyOrPragma := self basicAt: i. + (propertyOrPragma isVariableBinding + ifTrue: [propertyOrPragma key] + ifFalse: [propertyOrPragma keyword]) + == aKey ifTrue: + [^method removeProperty: aKey]]. + ^aBlock value! Item was added: + ----- Method: AdditionalMethodState>>at:ifAbsent: (in category 'accessing') ----- + at: aKey ifAbsent: aBlock + "Answer the property value or pragma associated with aKey or, + if aKey isn't found, answer the result of evaluating aBlock." + + 1 to: self basicSize do: + [:i | + | propertyOrPragma "<Association|Pragma>" | + (propertyOrPragma := self basicAt: i) key == aKey ifTrue: + [^propertyOrPragma isVariableBinding + ifTrue: [propertyOrPragma value] + ifFalse: [propertyOrPragma]]]. + ^aBlock value! Item was added: + ----- Method: AdditionalMethodState>>includes: (in category 'testing') ----- + includes: aPropertyOrPragma "<Association|Pragma>" + "Test if the property or pragma is present." + + 1 to: self basicSize do: + [:i | + (self basicAt: i) = aPropertyOrPragma ifTrue: + [^true]]. + ^false! Item was added: + ----- Method: MethodProperties>>propertyKeysAndValuesDo: (in category 'properties') ----- + propertyKeysAndValuesDo: aBlock + "Enumerate the receiver with all the keys and values." + ^self propertyKeysAndValuesDo: aBlock! Item was added: + ----- Method: AdditionalMethodState class>>forMethod:selector: (in category 'instance creation') ----- + forMethod: aMethod selector: aSelector + ^(self basicNew: 0) + selector: aSelector; + setMethod: aMethod; + yourself! Item was added: + ----- Method: CompiledMethod>>qDecompressFrom: (in category 'source code management') ----- + qDecompressFrom: input "<ReadStream on: ByteArray> ^<String>" + "Decompress strings compressed by qCompress:. + Most common 11 chars get values 0-10 packed in one 4-bit nibble; + next most common 52 get values 12-15 (2 bits) * 16 plus next nibble; + escaped chars get three nibbles" + ^ String streamContents: + [:strm | | nextNibble nibble peek charTable char | + charTable := "Character encoding table must match qCompress:" + 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()'. + peek := true. + nextNibble := [peek + ifTrue: [peek := false. input peek ifNil: [0] ifNotNil: [:b| b // 16]] + ifFalse: [peek := true. input next ifNil: [0] ifNotNil: [:b| b \\ 16]]]. + [input atEnd] whileFalse: + [(nibble := nextNibble value) = 0 + ifTrue: [input atEnd ifFalse: + [strm nextPut: (Character value: nextNibble value * 16 + nextNibble value)]] + ifFalse: + [nibble <= 11 + ifTrue: + [strm nextPut: (charTable at: nibble)] + ifFalse: + [strm nextPut: (charTable at: nibble-12 * 16 + nextNibble value)]]]]! Item was changed: ----- Method: CompiledMethod>>hasNewPropertyFormat (in category 'testing') ----- hasNewPropertyFormat + "As of the closure compiler all methods have (or better have) the new + format where the penultimate literal is either the method's selector + or its properties and the ultimate literal is the class association." + ^true! - ^self properties isMethodProperties.! Item was added: + ----- Method: AdditionalMethodState>>isMethodProperties (in category 'testing') ----- + isMethodProperties + ^true!

1 0

The Trunk: Exceptions-eem.12.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

Andreas Raab uploaded a new version of Exceptions to project The Trunk: http://source.squeak.org/trunk/Exceptions-eem.12.mcz ==================== Summary ==================== Name: Exceptions-eem.12 Author: eem Time: 5 September 2009, 3:36:07 am UUID: 222baa54-c057-4244-8484-c4d78fb1fca1 Ancestors: Exceptions-ar.11 First package of eight in closure compiler fixes 9/5/2009. Add reachedDefaultHandler to MessageNotUnderstood so that doesNotUnderstand: can support resume:. =============== Diff against Exceptions-ar.11 =============== Item was added: + ----- Method: MessageNotUnderstood>>initialize (in category 'initialize-release') ----- + initialize + super initialize. + reachedDefaultHandler := false! Item was added: + ----- Method: MessageNotUnderstood>>defaultAction (in category 'exceptionDescription') ----- + defaultAction + reachedDefaultHandler := true. + super defaultAction! Item was added: + ----- Method: MessageNotUnderstood>>reachedDefaultHandler (in category 'accessing') ----- + reachedDefaultHandler + ^reachedDefaultHandler! Item was changed: Error subclass: #MessageNotUnderstood + instanceVariableNames: 'message receiver reachedDefaultHandler' - instanceVariableNames: 'message receiver' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !MessageNotUnderstood commentStamp: '<historical>' prior: 0! This exception is provided to support Object>>doesNotUnderstand:.!

1 0

The Inbox: Kernel-eem.243.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

A new version of Kernel was added to project The Inbox: http://source.squeak.org/inbox/Kernel-eem.243.mcz ==================== Summary ==================== Name: Kernel-eem.243 Author: eem Time: 5 September 2009, 5:01:43 am UUID: 951890ea-0d23-473a-b538-f518d9ba5331 Ancestors: Kernel-eem.242 Fifth package of eight in closure compiler fixes 9/5/2009. Change kernel to use closure compiler fixes: - Replace old temp names compression scheme with the new one. - restore strange selector replacement in CompiledMethod>>getSourceFor:in: - remove unused CompiledMethod>>primitiveNode (and thence PrimitiveNode) =============== Diff against Kernel-eem.242 =============== Item was changed: ----- Method: CompiledMethod>>getSourceFor:in: (in category 'source code management') ----- getSourceFor: selector in: class "Retrieve or reconstruct the source code for this method." + | flagByte source | - | flagByte | flagByte := self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" and: [((1 to: 3) allSatisfy: [:i | (self at: self size - i) = 0])]]) ifTrue: ["No source pointer -- decompile without temp names" ^ (class decompilerClass new decompile: selector in: class method: self) decompileString]. flagByte < 252 ifTrue: ["Magic sources -- decompile with temp names" ^ ((class decompilerClass new withTempNames: self tempNamesString) decompile: selector in: class method: self) decompileString]. "Situation normal; read the sourceCode from the file" + + source := [self getSourceFromFile] + on: Error + "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." + do: [ :ex | ex return: nil]. + + ^source + ifNotNil: + [| sourceSelector | + "I think this is something to do with the traits system. It would be ncie if someone + documented this. It looks like an egregious hack to me. eem 9/5/2009 09:04" + sourceSelector := Parser parserClass new parseSelector: source. + sourceSelector = selector + ifTrue: [source] + ifFalse: [self replace: sourceSelector with: selector in: source]] + ifNil: + ["Something really wrong -- decompile blind (no temps)" + (class decompilerClass new decompile: selector in: class method: self) + decompileString]! - ^self getSourceFromFile ifNil: - ["Something really wrong -- decompile blind (no temps)" - (class decompilerClass new decompile: selector in: class method: self) - decompileString]! Item was added: + ----- Method: MethodProperties>>method: (in category 'forward compatibility') ----- + method: ignored + "For forward compatibility wth AdditionalMethodState, for decompilation"! Item was changed: ----- Method: CompiledMethod>>copyWithTempNames: (in category 'source code management') ----- copyWithTempNames: tempNames + "Minimal temp name copy that only works for methods containing no temporaries or blocks with arguments. + Used by the Traits system for creating conflict and required methdos that generate warnings. + For generic use use copyWithTempsFromMethodNode:" + | tempString | + tempString := String streamContents: + [:str| + tempNames + do: [:temp| str nextPutAll: temp] + separatedBy: [str space]. + str space]. + ^self copyWithTrailerBytes: (self qCompress: tempString)! - | tempStr compressed | - tempStr := String streamContents: - [:strm | tempNames do: [:n | strm nextPutAll: n; space]]. - compressed := self qCompress: tempStr firstTry: true. - compressed ifNil: - ["failure case (tempStr too big) will just decompile with tNN names" - ^ self copyWithTrailerBytes: #(0 0 0 0)]. - ^ self copyWithTrailerBytes: compressed! Item was changed: ----- Method: ParagraphEditor>>compileSelectionFor:in: (in category 'do-its') ----- compileSelectionFor: anObject in: evalContext | methodNode method | methodNode := [Compiler new compileNoPattern: self selectionAsStream in: anObject class context: evalContext notifying: self ifFail: [^nil]] on: OutOfScopeNotification do: [:ex | ex resume: true]. + method := methodNode generate: #(0 0 0 0). + ^method copyWithTempsFromMethodNode: methodNode! - method := methodNode generate. - ^method copyWithTempNames: methodNode tempNames! Item was changed: ----- Method: MethodProperties>>propertyKeysAndValuesDo: (in category 'properties') ----- propertyKeysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." + ^properties ifNotNil:[properties keysAndValuesDo: aBlock]! - ^self propertyKeysAndValuesDo: aBlock! Item was removed: - ----- Method: CompiledMethod>>primitiveNode (in category 'decompiling') ----- - primitiveNode - - | primNode n | - primNode := PrimitiveNode new num: (n := self primitive). - (n = 117 or: [n = 120]) ifTrue: [ - primNode spec: (self literalAt: 1)]. - ^ primNode! Item was removed: - ----- Method: CompiledMethod>>qCompress:firstTry: (in category 'source code management') ----- - qCompress: string firstTry: firstTry - "A very simple text compression routine designed for method temp names. - Most common 12 chars get values 0-11 packed in one 4-bit nibble; - others get values 12-15 (2 bits) * 16 plus next nibble. - Last char of str must be a space so it may be dropped without - consequence if output ends on odd nibble. - Normal call is with firstTry == true." - | charTable odd ix oddNibble names shorterStr maybe str temps | - str := string isOctetString - ifTrue: [string] - ifFalse: [temps := string findTokens: ' '. - String - streamContents: [:stream | 1 - to: temps size - do: [:index | - stream nextPut: $t. - stream nextPutAll: index asString. - stream space]]]. - charTable := "Character encoding table must match qDecompress:" - ' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. - ^ ByteArray streamContents: - [:strm | odd := true. "Flag for odd or even nibble out" - oddNibble := nil. - str do: - [:char | ix := (charTable indexOf: char) - 1. - (ix <= 12 ifTrue: [Array with: ix] - ifFalse: [Array with: ix//16+12 with: ix\\16]) - do: - [:nibble | (odd := odd not) - ifTrue: [strm nextPut: oddNibble*16 + nibble] - ifFalse: [oddNibble := nibble]]]. - strm position > 251 ifTrue: - ["Only values 1...251 are available for the flag byte - that signals compressed temps. See the logic in endPC." - "Before giving up completely, we attempt to encode most of - the temps, but with the last few shortened to tNN-style names." - firstTry ifFalse: [^ nil "already tried --give up now"]. - names := str findTokens: ' '. - names size < 8 ifTrue: [^ nil "weird case -- give up now"]. - 4 to: names size//2 by: 4 do: - [:i | shorterStr := String streamContents: - [:s | - 1 to: names size - i do: [:j | s nextPutAll: (names at: j); space]. - 1 to: i do: [:j | s nextPutAll: 't' , j printString; space]]. - (maybe := self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]]. - ^ nil]. - strm nextPut: strm position] - " - | m s | m := CompiledMethod new. - s := 'charTable odd ix oddNibble '. - ^ Array with: s size with: (m qCompress: s) size - with: (m qDecompress: (m qCompress: s)) - " - ! Item was removed: - ----- Method: ContextPart>>isBottomContext (in category 'query') ----- - isBottomContext - "Answer if this is the last context (the first context invoked) in my sender chain" - - ^sender isNil! Item was removed: - ----- Method: CompiledMethod>>qDecompress: (in category 'source code management') ----- - qDecompress: byteArray - "Decompress strings compressed by qCompress:. - Most common 12 chars get values 0-11 packed in one 4-bit nibble; - others get values 12-15 (2 bits) * 16 plus next nibble" - | charTable extended ext | - charTable := "Character encoding table must match qCompress:" - ' eatrnoislcm_bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. - ^ String streamContents: - [:strm | extended := false. "Flag for 2-nibble characters" - byteArray do: - [:byte | - (Array with: byte//16 with: byte\\16) do: - [:nibble | - extended - ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended := false] - ifFalse: [nibble < 12 - ifTrue: [strm nextPut: (charTable at: nibble + 1)] - ifFalse: [ext := nibble-12. extended := true]]]]]! Item was removed: - ----- Method: CompiledMethod>>tempNames (in category 'source code management') ----- - tempNames - - | byteCount bytes | - self holdsTempNames ifFalse: [ - ^ (1 to: self numTemps) collect: [:i | 't', i printString] - ]. - byteCount := self at: self size. - byteCount = 0 ifTrue: [^ Array new]. - bytes := (ByteArray new: byteCount) - replaceFrom: 1 to: byteCount with: self - startingAt: self size - byteCount. - ^ (self qDecompress: bytes) findTokens: ' '!

1 0

The Inbox: Compiler-eem.79.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

A new version of Compiler was added to project The Inbox: http://source.squeak.org/inbox/Compiler-eem.79.mcz ==================== Summary ==================== Name: Compiler-eem.79 Author: eem Time: 5 September 2009, 4:42:29 am UUID: f52d0730-d744-40d2-bdd1-f7412fc1b8f1 Ancestors: Compiler-eem.78 Fourth package of eight in closure compiler fixes 9/5/2009. Second stage of the closure compiler fixes for - miscompilation of optimized blocks - bugs in statement highlighting in the debugger - storing the selector as the penultimate literal of a method directly unless it has properties, in which case it has an AdditionalMethodState. Saves significant space. Throws the switch to the new closure analysis in BlockNode>>analyseArguments:temporaries:rootNode: using in place of analyseTempsWithin:rootNode:assignmentPools: analyseTempsWithin:rootNode:. This requires Exceptions-eem.12 Kernel-eem.242 Compiler-eem.78 =============== Diff against Compiler-eem.78 =============== Item was changed: ----- Method: MethodNode>>printPropertiesOn: (in category 'printing') ----- printPropertiesOn: aStream properties ifNil: [^self]. + properties propertyKeysAndValuesDo: + [:prop :val| + aStream crtab; nextPut: $<. + prop = #on:in: + ifTrue: + [prop keywords with: val do: + [:k :v | aStream nextPutAll: k; space; nextPutAll: v; space]] + ifFalse: + [prop = #on + ifTrue: [aStream nextPutAll: prop; nextPutAll:': '; nextPutAll: val] + ifFalse: [aStream nextPutAll: prop; nextPutAll:': '; print: val]]. + aStream nextPut: $>]! - properties pragmas do: - [ :each | - "Don't decompile basic primitives that return self, i-vars, etc." - each keyword = #primitive: - ifFalse: [ aStream crtab: 1. each printOn: aStream ] - ifTrue: [ ((each argumentAt: 1) between: 255 and: 519) ifFalse: - [ aStream crtab: 1. self printPrimitiveOn: aStream ] ] ]! Item was changed: ----- Method: MethodNode>>printWithClosureAnalysisOn: (in category 'printing') ----- printWithClosureAnalysisOn: aStream precedence = 1 ifTrue: [(self selector includesSubString: '()/') ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)). arguments do: [:arg| aStream nextPutAll: arg key] separatedBy: [aStream nextPutAll: ', ']. aStream nextPut: $)] ifFalse: [aStream nextPutAll: self selector]] "no node for method selector" ifFalse: [self selector keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space. arg printDefinitionForClosureAnalysisOn: aStream. aStream space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. temporaries size > 0 ifTrue: [aStream crtab: 1; nextPut: $|. temporaries do: [:temp | aStream space. temp printDefinitionForClosureAnalysisOn: aStream]. aStream space; nextPut: $|]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" [aStream crtab: 1. self printPrimitiveOn: aStream]]. self printPropertiesOn: aStream. + self printPragmasOn: aStream. aStream crtab: 1. block printWithClosureAnalysisStatementsOn: aStream indent: 0! Item was changed: ----- Method: Compiler>>compiledMethodFor:in:to:notifying:ifFail:logged: (in category 'public access') ----- compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag + "Compiles the sourceStream into a parse tree, then generates code + into a method, and answers it. If receiver is not nil, then the text can + refer to instance variables of that receiver (the Inspector uses this). + If aContext is not nil, the text can refer to temporaries in that context + (the Debugger uses this). If aRequestor is not nil, then it will receive a + notify:at: message before the attempt to evaluate is aborted." - "Compiles the sourceStream into a parse tree, then generates code into a - method. This method is then installed in the receiver's class so that it - can be invoked. In other words, if receiver is not nil, then the text can - refer to instance variables of that receiver (the Inspector uses this). If - aContext is not nil, the text can refer to temporaries in that context (the - Debugger uses this). If aRequestor is not nil, then it will receive a - notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here as DoIt or (in the case of - evaluation in aContext) DoItIn:. The method is subsequently removed - from the class, but this will not get done if the invocation causes an - error which is terminated. Such garbage can be removed by executing: - Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: - #DoItIn:]." | methodNode method | class := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. + methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value]. - methodNode := self translate: sourceStream noPattern: true ifFail: - [^failBlock value]. method := methodNode generate: #(0 0 0 0). self interactive ifTrue: + [method := method copyWithTempsFromMethodNode: methodNode]. + logFlag ifTrue: + [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. + ^method! - [method := method copyWithTempNames: methodNode tempNames]. - - logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. - ^ method.! Item was changed: ----- Method: Decompiler>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- popIntoTemporaryVariable: offset | maybeTVTag tempVector start | maybeTVTag := stack last. ((maybeTVTag isMemberOf: Association) and: [maybeTVTag key == #pushNewArray]) ifTrue: + [blockStartsToTempVars notNil "implies we were intialized with temp names." + ifTrue: "Use the provided temps" + [self assert: ((tempVector := tempVars at: offset + 1 ifAbsent: [ParseNode basicNew]) isTemp + and: [tempVector isIndirectTempVector + and: [tempVector remoteTemps size = maybeTVTag value size]])] + ifFalse: "Synthesize some remote temps" + [tempVector := maybeTVTag value. + offset + 1 <= tempVars size + ifTrue: + [start := 2. + tempVector at: 1 put: (tempVars at: offset + 1)] + ifFalse: + [tempVars := (Array new: offset + 1) + replaceFrom: 1 + to: tempVars size + with: tempVars. + start := 1]. + start to: tempVector size do: + [:i| + tempVector + at: i + put: (constructor + codeTemp: numLocalTemps + offset + i - 1 + named: 't', (tempVarCount + i) printString)]. + tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector)]. + tempVarCount := tempVarCount + maybeTVTag value size. - [tempVector := maybeTVTag value. - offset + 1 <= tempVars size - ifTrue: - [start := 2. - tempVector at: 1 put: (tempVars at: offset + 1)] - ifFalse: - [tempVars := (Array new: offset + 1) - replaceFrom: 1 - to: tempVars size - with: tempVars. - start := 1]. - start to: tempVector size do: - [:i| - tempVector - at: i - put: (constructor codeTemp: numLocalTemps + offset + i - 1)]. - tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector). stack removeLast. ^self]. self pushTemporaryVariable: offset; doStore: statements! Item was changed: ----- Method: TempVariableNode>>addWriteWithin:at: (in category 'code generation (closures)') ----- addWriteWithin: scopeBlock "<BlockNode>" at: location "<Integer>" writingScopes ifNil: [writingScopes := Dictionary new]. + (writingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location. + remoteNode ifNotNil: + [remoteNode addReadWithin: scopeBlock at: location]! - (writingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location! Item was changed: ----- Method: BlockNode>>computeCopiedValues: (in category 'code generation (closures)') ----- computeCopiedValues: rootNode | referencedValues | referencedValues := rootNode referencedValuesWithinBlockExtent: blockExtent. + ^((referencedValues reject: [:temp| temp isDefinedWithinBlockExtent: blockExtent]) + asSortedCollection: ParseNode tempSortBlock) + asArray! - ^((referencedValues reject: - [:temp| temp isDefinedWithinBlockExtent: blockExtent]) asSortedCollection: - [:t1 :t2 | t1 index < t2 index]) asArray! Item was changed: ----- Method: MethodNode>>printOn: (in category 'printing') ----- printOn: aStream | selectorNode | selectorNode := self selectorNode. precedence = 1 ifTrue: [selectorNode isForFFICall ifTrue: [selectorNode printAsFFICallWithArguments: arguments on: aStream indent: 0] ifFalse: [aStream nextPutAll: selectorNode key]] ifFalse: [selectorNode key keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space; nextPutAll: arg key; space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. block printTemporaries: temporaries on: aStream doPrior: [aStream crtab: 1]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" [aStream crtab: 1. self printPrimitiveOn: aStream]]. self printPropertiesOn: aStream. + self printPragmasOn: aStream. aStream crtab: 1. block printStatementsOn: aStream indent: 0! Item was changed: ----- Method: MethodNode>>rawSourceRangesAndMethodDo: (in category 'source mapping') ----- rawSourceRangesAndMethodDo: aBinaryBlock "Evaluate aBinaryBlock with the rawSourceRanges and method generated from the receiver." | methNode method | + methNode := encoder classEncoding parserClass new + encoderClass: encoder class; + parse: (sourceText "If no source, use decompile string as source to map from" + ifNil: [self decompileString] + ifNotNil: [sourceText]) + class: self methodClass. - methNode := sourceText - ifNil: "No source, use decompile string as source to map from" - [self parserClass new - encoderClass: encoder class; - parse: self decompileString - class: self methodClass] - ifNotNil: [self prepareForRegeneration. - self]. method := methNode generate: #(0 0 0 0). "set bytecodes to map to" ^aBinaryBlock value: methNode encoder rawSourceRanges value: method! Item was changed: ----- Method: BlockNode>>addHoistedTemps: (in category 'code generation (closures)') ----- addHoistedTemps: additionalTemporaries "<SequenceableCollection>" additionalTemporaries do: + [:temp| + temp definingScope ifNil: + [temp definingScope: self]]. + temporaries := (temporaries isNil or: [temporaries isEmpty]) + ifTrue: [additionalTemporaries copy] + ifFalse: + [temporaries last isIndirectTempVector + ifTrue: [temporaries allButLast, additionalTemporaries, { temporaries last }] + ifFalse: [temporaries, additionalTemporaries]]! - [:temp| temp definingScope: self]. - temporaries := (temporaries == nil ifTrue: [#()] ifFalse: [temporaries]), additionalTemporaries! Item was changed: ----- Method: Parser>>addPragma: (in category 'pragmas') ----- addPragma: aPragma + properties := properties copyWith: aPragma! - self properties addPragma: aPragma! Item was changed: ----- Method: Decompiler>>jump:if: (in category 'instruction decoding') ----- jump: dist if: condition | savePc sign elsePc elseStart end cond ifExpr thenBlock elseBlock + thenJump elseJump condHasValue isIfNil saveStack blockBody | - thenJump elseJump condHasValue isIfNil saveStack | stack last == CascadeFlag ifTrue: [^ self case: dist]. elsePc := lastPc. elseStart := pc + dist. end := limit. "Check for bfp-jmp to invert condition. Don't be fooled by a loop with a null body." sign := condition. savePc := pc. self interpretJump ifNotNil: [:elseDist| (elseDist >= 0 and: [elseStart = pc]) ifTrue: [sign := sign not. elseStart := pc + elseDist]]. pc := savePc. ifExpr := stack removeLast. (isIfNil := stack size > 0 and: [stack last == IfNilFlag]) ifTrue: [stack removeLast]. saveStack := stack. stack := OrderedCollection new. thenBlock := self blockTo: elseStart. condHasValue := hasValue or: [isIfNil]. "ensure jump is within block (in case thenExpr returns)" thenJump := exit <= end ifTrue: [exit] ifFalse: [elseStart]. "if jump goes back, then it's a loop" thenJump < elseStart ifTrue: ["Must be a while loop... + thenJump will jump to the beginning of the while expr. In the case of while's + with a block in the condition, the while expr should include more than just + the last expression: find all the statements needed by re-decompiling." - thenJump will jump to the beginning of the while expr." stack := saveStack. + pc := thenJump. + blockBody := self statementsTo: elsePc. + "discard unwanted statements from block" + blockBody size - 1 timesRepeat: [statements removeLast]. statements addLast: (constructor + codeMessage: (constructor codeBlock: blockBody returns: false) - codeMessage: (constructor codeBlock: { ifExpr } returns: false) selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro) arguments: { thenBlock }). + pc := elseStart. self convertToDoLoop] ifFalse: ["Must be a conditional..." elseBlock := self blockTo: thenJump. elseJump := exit. "if elseJump is backwards, it is not part of the elseExpr" elseJump < elsePc ifTrue: [pc := lastPc]. cond := isIfNil ifTrue: [constructor codeMessage: ifExpr ifNilReceiver selector: (constructor codeSelector: (sign ifTrue: [#ifNotNil:] ifFalse: [#ifNil:]) code: #macro) arguments: (Array with: thenBlock)] ifFalse: [constructor codeMessage: ifExpr selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro) arguments: (sign ifTrue: [{elseBlock. thenBlock}] ifFalse: [{thenBlock. elseBlock}])]. stack := saveStack. condHasValue ifTrue: [stack addLast: cond] ifFalse: [statements addLast: cond]]! Item was changed: ----- Method: TempVariableNode>>printWithClosureAnalysisOn:indent: (in category 'printing') ----- printWithClosureAnalysisOn: aStream indent: level + aStream nextPutAll: name. + readingScopes notNil ifTrue: + [(readingScopes inject: Set new into: [:them :reads| them addAll: reads. them]) asSortedCollection do: + [:location| + aStream space; nextPut: $r; nextPut: $@; print: location]]. + writingScopes notNil ifTrue: + [(writingScopes inject: Set new into: [:them :writes| them addAll: writes. them]) asSortedCollection do: + [:location| + aStream space; nextPut: $w; nextPut: $@; print: location]]! - aStream nextPutAll: name! Item was changed: ----- Method: Parser>>queryUndefined (in category 'error correction') ----- queryUndefined | varStart varName | + varName := parseNode key. + varStart := self endOfLastToken + requestorOffset - varName size + 1. - varName _ parseNode key. - varStart _ self endOfLastToken + requestorOffset - varName size + 1. requestor selectFrom: varStart to: varStart + varName size - 1; select. (UndefinedVariable name: varName) ifFalse: [^ self fail]! Item was changed: ----- Method: Decompiler>>initSymbols: (in category 'initialize-release') ----- initSymbols: aClass - | nTemps namedTemps | constructor method: method class: aClass literals: method literals. constTable := constructor codeConstants. instVars := Array new: aClass instSize. + tempVarCount := method numTemps. + "(tempVars isNil + and: [method holdsTempNames]) ifTrue: + [tempVars := method tempNamesString]." + tempVars isString + ifTrue: + [blockStartsToTempVars := self mapFromBlockStartsIn: method + toTempVarsFrom: tempVars + constructor: constructor. + tempVars := blockStartsToTempVars at: method initialPC] + ifFalse: + [| namedTemps | + namedTemps := tempVars ifNil: [(1 to: tempVarCount) collect: [:i| 't', i printString]]. + tempVars := (1 to: tempVarCount) collect: + [:i | i <= namedTemps size + ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] + ifFalse: [constructor codeTemp: i - 1]]]. - nTemps := method numTemps. - namedTemps := tempVars ifNil: [method tempNames]. - tempVars := (1 to: nTemps) collect: - [:i | i <= namedTemps size - ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] - ifFalse: [constructor codeTemp: i - 1]]. 1 to: method numArgs do: [:i| (tempVars at: i) beMethodArg]! Item was changed: ----- Method: Parser>>method:context:encoder: (in category 'expression types') ----- method: doit context: ctxt encoder: encoderToUse " pattern [ | temporaries ] block => MethodNode." | sap blk prim temps messageComment methodNode | + properties := AdditionalMethodState new. - properties := MethodProperties new. encoder := encoderToUse. sap := self pattern: doit inContext: ctxt. "sap={selector, arguments, precedence}" properties selector: (sap at: 1). encoder selector: (sap at: 1). (sap at: 2) do: [:argNode | argNode beMethodArg]. + doit ifFalse: [self pragmaSequence]. - doit ifFalse: [ self pragmaSequence ]. temps := self temporaries. messageComment := currentComment. currentComment := nil. + doit ifFalse: [self pragmaSequence]. - doit ifFalse: [ self pragmaSequence ]. prim := self pragmaPrimitives. self statements: #() innerBlock: doit. blk := parseNode. doit ifTrue: [blk returnLast] ifFalse: [blk returnSelfIfNoOther: encoder]. hereType == #doIt ifFalse: [^self expected: 'Nothing more']. self interactive ifTrue: [self removeUnusedTemps]. methodNode := self newMethodNode comment: messageComment. + ^methodNode - ^ methodNode selector: (sap at: 1) arguments: (sap at: 2) precedence: (sap at: 3) temporaries: temps block: blk encoder: encoder primitive: prim properties: properties! Item was changed: ----- Method: MethodNode>>printPrimitiveOn: (in category 'printing') ----- + printPrimitiveOn: aStream - printPrimitiveOn: aStream "Print the primitive on aStream" + | primDecl | + primitive = 0 ifTrue: + [^self]. + primitive = 120 ifTrue: "External call spec" + [^aStream print: encoder literals first]. - | primIndex primDecl | - primIndex := primitive. - primIndex = 0 - ifTrue: [^ self]. - primIndex = 120 - ifTrue: ["External call spec" - ^ aStream print: encoder literals first]. aStream nextPutAll: '<primitive: '. + primitive = 117 + ifTrue: + [primDecl := encoder literals at: 1. + (primDecl at: 2) asString printOn: aStream. + (primDecl at: 1) ifNotNil: + [:moduleName| + aStream nextPutAll:' module: '. + moduleName asString printOn: aStream]] + ifFalse: + [aStream print: primitive]. + self primitiveErrorVariableName ifNotNil: + [:primitiveErrorVariableName| + aStream nextPutAll: ' error: '; nextPutAll: primitiveErrorVariableName]. - primIndex = 117 - ifTrue: [primDecl := encoder literals at: 1. - aStream nextPut: $'; - - nextPutAll: (primDecl at: 2); - nextPut: $'. - (primDecl at: 1) notNil - ifTrue: [aStream nextPutAll: ' module:'; - nextPut: $'; - - nextPutAll: (primDecl at: 1); - nextPut: $']] - ifFalse: [aStream print: primIndex]. aStream nextPut: $>. Smalltalk at: #Interpreter ifPresent:[:cls| + aStream nextPutAll: ' "', + ((cls classPool at: #PrimitiveTable) at: primitive + 1), + '" ']! - aStream nextPutAll: ' "' - , ((cls classPool at: #PrimitiveTable) - at: primIndex + 1) , '" '].! Item was changed: ----- Method: BlockNode>>addRemoteTemp:rootNode: (in category 'code generation (closures)') ----- addRemoteTemp: aTempVariableNode rootNode: rootNode "<MethodNode>" + "Add aTempVariableNode to my actualScope's sequence of + remote temps. If I am an optimized block then the actual + scope is my actualScopeIfOptimized, otherwise it is myself." temporaries isArray ifTrue: [temporaries := temporaries asOrderedCollection]. remoteTempNode == nil ifTrue: [remoteTempNode := RemoteTempVectorNode new + name: self remoteTempNodeName - name: '<', blockExtent first printString, '-', blockExtent last printString, '>' index: arguments size + temporaries size type: LdTempType scope: 0. + actualScopeIfOptimized + ifNil: + [temporaries addLast: remoteTempNode. + remoteTempNode definingScope: self] + ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]]. - temporaries addLast: remoteTempNode. - remoteTempNode definingScope: self]. remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder. + "use remove:ifAbsent: because the deferred analysis for optimized + loops can result in the temp has already been hoised into the root." + temporaries remove: aTempVariableNode ifAbsent: []. - temporaries remove: aTempVariableNode. ^remoteTempNode! Item was changed: ----- Method: BlockNode>>analyseArguments:temporaries:rootNode: (in category 'code generation (closures)') ----- analyseArguments: methodArguments temporaries: methodTemporaries rootNode: rootNode "<MethodNode>" "^<Sequence of: <TempVarNade>>" "Top level entry-point for analysing temps within the hierarchy of blocks in the receiver's method. Answer the (possibly modified) sequence of temp vars. Need to hoist temps out of macro-optimized blocks into their actual blocks. Need to note reads and writes to temps from blocks other than their actual blocks to determine whether blocks can be local (simple slots within a block/method context) or remote (slots in indirection vectors that are shared between contexts by sharing indirection vectors). The algorithm is based on numbering temporary reads and writes and block extents. The index used for numbering starts at zero and is incremented on every block entry and block exit. So the following | a b blk r1 r2 t | a := 1. b := 2. t := 0. blk := [ | s | s := a + b. t := t + s]. r1 := blk value. b := -100. r2 := blk value. r1 -> r2 -> t is numbered as method block 0 to: 6: | a b blk r1 r2 t | a w@1 := 1. b w@1 := 2. t w@1 := 0. blk w@5 := [entry@2 | s | t w@3 := t r@3 + a r@3 + b r@3 ] exit@4. r1 w@5 := blk r@5 value. b w@5 := nil. r2 w@5 := blk r@5 value. r1 r@5 -> r2 r@5 -> t r@5 So: + b and blk cannot be copied because for both there exists a write @5 that follows a - b and blk cannot be copied because fpr both there exists a write @5 that follows a read @4 within block 2 through 4 + t must be remote because there exists a write @3 within block (2 to: 4) + Complications are introduced by optimized blocks. In the following temp is written to + after it is closed over by [ temp ] since the inlined block is executed more than once. + | temp coll | + coll := OrderedCollection new. + 1 to: 5 do: [ :index | + temp := index. + coll add: [ temp ] ]. + self assert: (coll collect: [:ea| ea value]) asArray = #(5 5 5 5 5) + In the following i is local to the block and must be initialized each time around the loop + but if the block is inlined it must be declared at method level. + | col | + col := OrderedCollection new. + 1 to: 3 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. + self assert: (col collect: [ :each | each value ]) asArray = #(2 3 4)" - t must be remote because there exists a write @3 within block (2 to: 4)" self assert: (arguments isEmpty or: [arguments hasEqualElements: methodArguments]). arguments := methodArguments asArray. "won't change" self assert: (temporaries isNil or: [temporaries isEmpty or: [temporaries hasEqualElements: methodTemporaries]]). temporaries := OrderedCollection withAll: methodTemporaries. self assert: optimized not. "the top-level block should not be optimized." + self analyseTempsWithin: self rootNode: rootNode assignmentPools: Dictionary new. - self analyseTempsWithin: self rootNode: rootNode. "The top-level block needs to reindex temporaries since analysis may have rearranged them. + This happens when temps are made remote and/or a remote node is added." - This happens during sizing for nested blocks." temporaries withIndexDo: [:temp :offsetPlusOne| temp index: arguments size + offsetPlusOne - 1]. "Answer the (possibly modified) sequence of temps." ^temporaries asArray! Item was changed: ----- Method: MethodNode>>selector:arguments:precedence:temporaries:block:encoder:primitive: (in category 'initialize-release') ----- selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim + "Initialize the receiver with respect to the arguments given." + + encoder := anEncoder. + selectorOrFalse := selOrFalse. + precedence := p. + arguments := args. + temporaries := temps. + block := blk. + primitive := prim! - - self - selector: selOrFalse - arguments: args - precedence: p - temporaries: temps - block: blk encoder: - anEncoder - primitive: prim - properties: MethodProperties new.! Item was changed: ----- Method: DecompilerConstructorForClosures>>codeMethod:block:tempVars:primitive:class: (in category 'constructor') ----- codeMethod: selector block: block tempVars: vars primitive: primitive class: class + | blockNode selectorNode visibleTemps invisibleTemps arguments temporaries | + selectorNode := self codeSelector: selector code: nil. - | node visibleTemps invisibleTemps arguments temporaries | - node := self codeSelector: selector code: nil. tempVars := vars. visibleTemps := OrderedCollection new. invisibleTemps := OrderedCollection new. tempVars do: [:t| ((t isIndirectTempVector or: [t scope >= 0]) ifTrue: [visibleTemps] ifFalse: [invisibleTemps]) addLast: t]. arguments := visibleTemps copyFrom: 1 to: nArgs. temporaries := visibleTemps copyFrom: nArgs + 1 to: visibleTemps size. block arguments: arguments; temporaries: temporaries. + blockNode := BytecodeAgnosticMethodNode new + selector: selectorNode - ^BytecodeAgnosticMethodNode new - selector: node arguments: arguments precedence: selector precedence temporaries: temporaries block: block encoder: (EncoderForV3PlusClosures new initScopeAndLiteralTables temps: visibleTemps, invisibleTemps literals: literalValues class: class) primitive: primitive + properties: method properties copy. + blockNode properties method: blockNode. + ^blockNode! - properties: method properties! Item was changed: ----- Method: Decompiler>>decompile:in:method:using: (in category 'public access') ----- decompile: aSelector in: aClass method: aMethod using: aConstructor + | block node | - | block | constructor := aConstructor. method := aMethod. self initSymbols: aClass. "create symbol tables" method isQuick ifTrue: [block := self quickMethod] ifFalse: [stack := OrderedCollection new: method frameSize. caseExits := OrderedCollection new. statements := OrderedCollection new: 20. numLocalTemps := 0. super method: method pc: method initialPC. + "skip primitive error code store if necessary" + (method primitive ~= 0 and: [self willStore]) ifTrue: + [pc := pc + 2. + tempVars := tempVars asOrderedCollection]. block := self blockTo: method endPC + 1. stack isEmpty ifFalse: [self error: 'stack not empty']]. + node := constructor + codeMethod: aSelector + block: block + tempVars: tempVars + primitive: method primitive + class: aClass. + method primitive > 0 ifTrue: + [node removeAndRenameLastTempIfErrorCode]. + ^node! - ^(constructor - codeMethod: aSelector - block: block - tempVars: tempVars - primitive: method primitive - class: aClass) - accept: TempNumberNormalizingVisitor new; - yourself! Item was changed: ----- Method: Decompiler>>withTempNames: (in category 'initialize-release') ----- + withTempNames: tempNames "<Array|String>" + "Optionally initialize the temp names to be used when decompiling. + For backward-copmpatibility, if tempNames is an Array it is a single + vector of temp names, probably for a blue-book-compiled method. + If tempNames is a string it is a schematic string that encodes the + layout of temp vars in the method and any closures/blocks within it. + Decoding encoded tempNames is done in decompile:in:method:using: + which has the method from which to derive blockStarts. + See e.g. BytecodeEncoder>>schematicTempNamesString for syntax." + tempVars := tempNames! - withTempNames: tempNameArray - tempVars := tempNameArray! Item was changed: ----- Method: Decompiler class>>recompileAllTest (in category 'testing') ----- recompileAllTest + "[Decompiler recompileAllTest]" - "[self recompileAllTest]" "decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)" | decompiled ast compiled | SystemNavigation default allBehaviorsDo: [ :behavior | Utilities informUser: (behavior printString) during: [ behavior selectors do: [ :sel | decompiled := Decompiler new decompile: sel in: behavior. ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ]. compiled := ast generate: (behavior compiledMethodAt: sel) trailer. behavior addSelector: sel withMethod: compiled. ] ] ]! Item was changed: ----- Method: Decompiler>>decompileBlock: (in category 'public access') ----- decompileBlock: aBlock "Decompile aBlock, returning the result as a BlockNode. Show temp names from source if available." "Decompiler new decompileBlock: [3 + 4]" + | startpc end homeClass blockNode methodNode home source | - | startpc end homeClass blockNode tempNames home source | (home := aBlock home) ifNil: [^ nil]. method := home method. (homeClass := home who first) == #unknown ifTrue: [^ nil]. constructor := self constructorForMethod: aBlock method. + method fileIndex ~~ 0 ifTrue: "got any source code?" + [source := [method getSourceFromFile] - method fileIndex ~~ 0 - ifTrue: ["got any source code?" - source := [method getSourceFromFile] on: Error do: [:ex | ^ nil]. + methodNode := [homeClass compilerClass new + parse: source + in: homeClass + notifying: nil] + on: (Smalltalk classNamed: 'SyntaxErrorNotification') + do: [:ex | ^ nil]. + self withTempNames: methodNode schematicTempNamesString]. - tempNames := ([homeClass compilerClass new - parse: source - in: homeClass - notifying: nil] - on: (Smalltalk classNamed: 'SyntaxErrorNotification') - do: [:ex | ^ nil]) tempNames. - self withTempNames: tempNames]. self initSymbols: homeClass. startpc := aBlock startpc. end := aBlock isClosure ifTrue: [(method at: startpc - 2) * 256 + (method at: startpc - 1) + startpc - 1] ifFalse: + [(method at: startpc - 2) \\ 16 - 4 * 256 + + (method at: startpc - 1) + startpc - 1]. - [(method at: startpc - 2) - \\ 16 - 4 * 256 - + (method at: startpc - 1) + startpc - 1]. stack := OrderedCollection new: method frameSize. caseExits := OrderedCollection new. statements := OrderedCollection new: 20. super method: method pc: (aBlock isClosure ifTrue: [startpc - 4] ifFalse: [startpc - 5]). aBlock isClosure ifTrue: [numLocalTemps := #decompileBlock: "Get pushClosureCopy... to hack fake temps for copied values"]. blockNode := self blockTo: end. stack isEmpty ifFalse: [self error: 'stack not empty']. ^blockNode statements first! Item was changed: ----- Method: Parser>>pragmaPrimitives (in category 'pragmas') ----- pragmaPrimitives + | primitives | + properties isEmpty ifTrue: + [^0]. + primitives := properties pragmas select: + [:pragma| + self class primitivePragmaSelectors includes: pragma keyword]. + primitives isEmpty ifTrue: + [^0]. + primitives size > 1 ifTrue: + [^self notify: 'Ambigous primitives']. + ^self perform: primitives first keyword withArguments: primitives first arguments! - | pragmas primitives | - self properties pragmas isEmpty - ifTrue: [ ^ 0 ]. - pragmas := Pragma allNamed: #primitive from: self class to: Parser. - primitives := self properties pragmas select: [ :prim | - pragmas anySatisfy: [ :prag | - prag selector = prim keyword ] ]. - primitives isEmpty - ifTrue: [ ^ 0 ]. - primitives size = 1 - ifFalse: [ ^ self notify: 'Ambigous primitives' ]. - ^ primitives first message sendTo: self! Item was changed: ----- Method: Parser>>removeUnusedTemps (in category 'error correction') ----- removeUnusedTemps "Scan for unused temp names, and prompt the user about the prospect of removing each one found" | str end start madeChanges | + madeChanges := false. + str := requestor text asString. - madeChanges _ false. - str _ requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | (UnusedVariable name: temp) ifTrue: + [(encoder encodeVariable: temp) isUndefTemp + ifTrue: + [end := tempsMark. + ["Beginning at right temp marker..." + start := end - temp size + 1. + end < temp size or: [temp = (str copyFrom: start to: end) + and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] + whileFalse: + ["Search left for the unused temp" + end := requestor nextTokenFrom: end direction: -1]. + end < temp size ifFalse: + [(str at: start-1) = $ ifTrue: [start := start-1]. + requestor correctFrom: start to: end with: ''. + str := str copyReplaceFrom: start to: end with: ''. + madeChanges := true. + tempsMark := tempsMark - (end-start+1)]] + ifFalse: + [self inform: + 'You''ll first have to remove the\statement where it''s stored into' withCRs]]]. + madeChanges ifTrue: [ReparseAfterSourceEditing signal]! - [(encoder encodeVariable: temp) isUndefTemp - ifTrue: - [end _ tempsMark. - ["Beginning at right temp marker..." - start _ end - temp size + 1. - end < temp size or: [temp = (str copyFrom: start to: end) - and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] - whileFalse: - ["Search left for the unused temp" - end _ requestor nextTokenFrom: end direction: -1]. - end < temp size ifFalse: - [(str at: start-1) = $ ifTrue: [start _ start-1]. - requestor correctFrom: start to: end with: ''. - str _ str copyReplaceFrom: start to: end with: ''. - madeChanges _ true. - tempsMark _ tempsMark - (end-start+1)]] - ifFalse: - [self inform: - 'You''ll first have to remove the - statement where it''s stored into']]]. - madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! Item was changed: ----- Method: ParseNode>>printCommentOn:indent: (in category 'printing') ----- printCommentOn: aStream indent: indent | thisComment | self comment == nil ifTrue: [^ self]. 1 to: self comment size do: [:index | index > 1 ifTrue: [aStream crtab: indent]. aStream nextPut: $". thisComment := self comment at: index. self printSingleComment: thisComment on: aStream indent: indent. + aStream nextPut: $"]! - aStream nextPut: $"]. - self comment: nil! Item was changed: ----- Method: TempVariableNode>>isDefinedWithinBlockExtent: (in category 'code generation (closures)') ----- isDefinedWithinBlockExtent: anInterval + ^anInterval rangeIncludes: definingScope actualScope blockExtent first! - ^anInterval rangeIncludes: definingScope blockExtent first! Item was changed: ----- Method: BlockNode>>printTemporaries:on:doPrior: (in category 'printing') ----- printTemporaries: tempSequence on: aStream doPrior: aBlock "Print any in-scope temporaries. If there are any evaluate aBlock prior to printing. Answer whether any temporaries were printed." + | tempStream seen | + tempSequence ifNil: + [^false]. + tempStream := (String new: 16) writeStream. + "This is for the decompiler which canmot work out which optimized block a particular temp is + local to and hence may produce diplicates as in + expr ifTrue: [| aTemp | ...] ifFalse: [| aTemp | ...]" + seen := Set new. - (tempSequence == nil - or: [tempSequence size = 0 - or: [tempSequence allSatisfy: [:temp| - temp scope < 0 - and: [temp isIndirectTempVector not]]]]) ifTrue: - [^false]. - aBlock value. - aStream nextPut: $|. tempSequence do: [:tempNode | tempNode isIndirectTempVector ifTrue: [tempNode remoteTemps do: [:tempVariableNode| + (tempVariableNode scope >= 0 + and: [(seen includes: tempNode key) not]) ifTrue: + [tempStream space; nextPutAll: (seen add: tempVariableNode key)]]] - tempVariableNode scope >= 0 ifTrue: - [aStream space; nextPutAll: tempVariableNode key]]] ifFalse: + [(tempNode scope >= -1 + and: ["This is for the decompiler which may create a block arg when converting + a while into a to:do: but won't remove it form temporaries" + tempNode isBlockArg not + and: [(seen includes: tempNode key) not]]) ifTrue: + [tempStream space; nextPutAll: (seen add: tempNode key)]]]. + tempStream position = 0 ifTrue: + [^false]. + aBlock value. + aStream nextPut: $|; nextPutAll: tempStream contents; space; nextPut: $|. - [tempNode scope >= 0 ifTrue: - [aStream space; nextPutAll: tempNode key]]]. - aStream - space; - nextPut: $|. ^true! Item was changed: ----- Method: MethodNode>>generate: (in category 'code generation') ----- generate: trailer "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." + | literals blkSize method nArgs nLits primErrNode stack strm | - | blkSize nLits literals stack strm nArgs method | self generate: trailer ifQuick: [:m | literals := encoder allLiterals. (nLits := literals size) > 255 ifTrue: [^self error: 'Too many literals referenced']. 1 to: nLits do: [:lit | m literalAt: lit put: (literals at: lit)]. m properties: properties. ^m]. + primErrNode := self primitiveErrorVariableName ifNotNil: + [encoder fixTemp: self primitiveErrorVariableName]. nArgs := arguments size. + blkSize := (block sizeForEvaluatedValue: encoder) + + (primErrNode ifNil: [0] ifNotNil: [2 "We force store-long (129)"]). - blkSize := block sizeForEvaluatedValue: encoder. (nLits := (literals := encoder allLiterals) size) > 255 ifTrue: [^self error: 'Too many literals referenced']. method := CompiledMethod "Dummy to allocate right size" newBytes: blkSize trailerBytes: trailer nArgs: nArgs nTemps: encoder maxTemp nStack: 0 nLits: nLits primitive: primitive. strm := ReadWriteStream with: method. strm position: method initialPC - 1. stack := ParseStack new init. + primErrNode ifNotNil: [primErrNode emitStore: stack on: strm]. block emitForEvaluatedValue: stack on: strm. stack position ~= 1 ifTrue: [^self error: 'Compiler stack discrepancy']. strm position ~= (method size - trailer size) ifTrue: [^self error: 'Compiler code size discrepancy']. method needsFrameSize: stack size. 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. method properties: properties. ^method! Item was changed: ----- Method: TempVariableNode>>addReadWithin:at: (in category 'code generation (closures)') ----- addReadWithin: scopeBlock "<BlockNode>" at: location "<Integer>" readingScopes ifNil: [readingScopes := Dictionary new]. + (readingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location. + remoteNode ifNotNil: + [remoteNode addReadWithin: scopeBlock at: location]! - (readingScopes at: scopeBlock ifAbsentPut: [Set new]) add: location! Item was changed: ----- Method: TempVariableNode>>analyseClosure: (in category 'code generation (closures)') ----- analyseClosure: rootNode "<MethodNode>" + "Analyse whether the temporary needs to be made remote + or not, and answer whether it was made remote. + A temp cannot be local if it is written to remotely, + or if it is written to after it is closed-over. An exception + is an inlined block argument that appears to be written + remotely but is actually local to a block." - "A temp cannot be local if it is written to remotely, - or if it is written to after it is closed-over." | latestWrite | + self isBlockArg ifTrue: [^false]. + remoteNode ifNotNil: [^false]. "If already remote, don't remote a second time" latestWrite := 0. ((writingScopes notNil and: [writingScopes associations anySatisfy: [:assoc| [:blockScope :refs| refs do: [:write| latestWrite := write max: latestWrite]. "A temp cannot be local if it is written to remotely." + blockScope actualScope ~~ definingScope actualScope] - blockScope ~~ definingScope] value: assoc key value: assoc value]]) or: [readingScopes notNil and: [readingScopes associations anySatisfy: [:assoc| [:blockScope :refs| "A temp cannot be local if it is written to after it is closed-over." + blockScope actualScope ~~ definingScope actualScope - blockScope ~~ definingScope and: [refs anySatisfy: [:read| read < latestWrite]]] value: assoc key value: assoc value]]]) ifTrue: + [remoteNode := definingScope addRemoteTemp: self rootNode: rootNode. + ^true]. + ^false! - [remoteNode := definingScope addRemoteTemp: self rootNode: rootNode]! Item was changed: ----- Method: Decompiler>>doClosureCopyCopiedValues:numArgs:blockSize: (in category 'control') ----- doClosureCopyCopiedValues: blockCopiedValues numArgs: numArgs blockSize: blockSize + | savedTemps savedTempVarCount savedNumLocalTemps + jump blockArgs blockTemps blockTempsOffset block | - | savedTemps savedNumLocalTemps jump blockArgs blockTemps blockTempsOffset block | savedTemps := tempVars. + savedTempVarCount := tempVarCount. savedNumLocalTemps := numLocalTemps. jump := blockSize + pc. numLocalTemps := BlockLocalTempCounter tempCountForBlockAt: pc - 4 in: method. - blockArgs := (1 to: numArgs) collect: - [:i| (constructor codeTemp: i - 1) beBlockArg]. blockTempsOffset := numArgs + blockCopiedValues size. + (blockStartsToTempVars notNil "implies we were intialized with temp names." + and: [blockStartsToTempVars includesKey: pc]) + ifTrue: + [tempVars := blockStartsToTempVars at: pc] + ifFalse: + [blockArgs := (1 to: numArgs) collect: + [:i| (constructor + codeTemp: i - 1 + named: 't', (tempVarCount + i) printString) + beBlockArg]. + blockTemps := (1 to: numLocalTemps) collect: + [:i| constructor + codeTemp: i + blockTempsOffset - 1 + named: 't', (tempVarCount + i + numArgs) printString]. + tempVars := blockArgs, blockCopiedValues, blockTemps]. - blockTemps := (1 to: numLocalTemps) collect: - [:i| constructor codeTemp: i + blockTempsOffset - 1]. - tempVars := blockArgs, blockCopiedValues, blockTemps. numLocalTemps timesRepeat: [self interpretNextInstructionFor: self. stack removeLast]. + tempVarCount := tempVarCount + numArgs + numLocalTemps. block := self blockTo: jump. stack addLast: (constructor codeArguments: (tempVars copyFrom: 1 to: numArgs) temps: (tempVars copyFrom: blockTempsOffset + 1 to: blockTempsOffset + numLocalTemps) block: block). tempVars := savedTemps. + tempVarCount := savedTempVarCount. numLocalTemps := savedNumLocalTemps! Item was changed: ----- Method: TempVariableNode>>index: (in category 'code generation (closures)') ----- index: anInteger + "For renumbering temps in the closure compiler." - "For renumbering temps in the closure compiler. - Intended to be used only in BlockNode>>postNumberingProcessTemps:" index := anInteger. code := self code: index type: LdTempType! Item was changed: ----- Method: Encoder>>doItInContextName (in category 'encoding') ----- doItInContextName + ^'ThisContext'! - ^'_thisContext'! Item was changed: ----- Method: Compiler>>evaluate:in:to:notifying:ifFail:logged: (in category 'public access') ----- evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag + "Compiles the sourceStream into a parse tree, then generates code into a + method. This method is then installed in the receiver's class so that it + can be invoked. In other words, if receiver is not nil, then the text can + refer to instance variables of that receiver (the Inspector uses this). If + aContext is not nil, the text can refer to temporaries in that context (the + Debugger uses this). If aRequestor is not nil, then it will receive a + notify:at: message before the attempt to evaluate is aborted. Finally, the + compiled method is invoked from here as DoIt or (in the case of + evaluation in aContext) DoItIn:. The method is subsequently removed + from the class, but this will not get done if the invocation causes an + error which is terminated. Such garbage can be removed by executing: + Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: + #DoItIn:]." - "Compiles the sourceStream into a parse tree, then generates code into a method. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is directly invoked without modifying the receiving-class." + | methodNode method value toLog itsSelection itsSelectionString | + class := (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. - | methodNode method value toLog itsSelectionString itsSelection | - class := (aContext isNil - ifTrue: [ receiver ] - ifFalse: [ aContext receiver ]) - class. self from: textOrStream class: class context: aContext notifying: aRequestor. + methodNode := self translate: sourceStream noPattern: true ifFail: + [^failBlock value]. + method := methodNode generate: #(0 0 0 0). + self interactive ifTrue: + [method := method copyWithTempsFromMethodNode: methodNode]. + + value := receiver + withArgs: (context ifNil: [#()] ifNotNil: [{context}]) + executeMethod: method. + + logFlag ifTrue:[ + toLog := ((requestor respondsTo: #selection) + and:[(itsSelection := requestor selection) notNil + and:[(itsSelectionString := itsSelection asString) isEmptyOrNil not]]) + ifTrue:[itsSelectionString] + ifFalse:[sourceStream contents]. + SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext]. + ^ value! - methodNode := self - translate: sourceStream - noPattern: true - ifFail: [ ^ failBlock value ]. - method := methodNode generate. - method selector ifNil: [method selector: #DoIt]. - self interactive - ifTrue: [ method := method copyWithTempNames: methodNode tempNames ]. - value := receiver - withArgs: (context isNil - ifTrue: [ #() ] - ifFalse: [ Array with: aContext ]) - executeMethod: method. - logFlag ifTrue: - [toLog := ((requestor respondsTo: #selection) and: - [(itsSelection := requestor selection) notNil] and: - [(itsSelectionString := itsSelection asString) isEmptyOrNil not] ) - ifTrue: - [itsSelectionString] - ifFalse: - [sourceStream contents]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext ]. - ^ value.! Item was removed: - ----- Method: CascadeNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - { receiver }, messages do: - [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode]! Item was removed: - ----- Method: PrimitiveNode>>printPrimitiveOn: (in category 'as yet unclassified') ----- - printPrimitiveOn: aStream - "Print the primitive on aStream" - - | primIndex primDecl | - primIndex := primitiveNum. - primIndex = 0 ifTrue: [^ self]. - primIndex = 120 ifTrue: [ - "External call spec" - ^ aStream print: spec]. - aStream nextPutAll: '<primitive: '. - primIndex = 117 ifTrue: [ - primDecl := spec. - aStream nextPut: $'; - nextPutAll: (primDecl at: 2); - nextPut: $'. - (primDecl at: 1) ifNotNil: [ - aStream nextPutAll: ' module: '; - nextPut: $'; - nextPutAll: (primDecl at: 1); - nextPut: $']. - ] ifFalse: [aStream print: primIndex]. - aStream nextPut: $>. - (primIndex ~= 117 and: [primIndex ~= 120]) ifTrue: [ - Smalltalk at: #Interpreter ifPresent: [:cls | - aStream nextPutAll: ' "', - ((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" ' - ]. - ]. - ! Item was removed: - ----- Method: TempVariableNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - self addReadWithin: scopeBlock at: rootNode locationCounter! Item was removed: - ----- Method: MessageNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - special > 0 ifTrue: - [receiver ifOptimizedBlockHoistTempsInto: scopeBlock. - "caseOf: is complicated. We need to handle it specially. - The cases are within a BraceNode where each case is of the form - [guard block] -> [action block]" - (selector key beginsWith: 'caseOf:') ifTrue: - [arguments first elements do: - [:messageNode| - messageNode receiver ifOptimizedBlockHoistTempsInto: scopeBlock. - messageNode arguments first ifOptimizedBlockHoistTempsInto: scopeBlock]]. - arguments do: - [:node| - node == nil ifFalse: "last argument of optimized to:do: can be nil" - [node ifOptimizedBlockHoistTempsInto: scopeBlock]]]. - - "receiver is nil in cascades" - receiver == nil ifFalse: - [receiver analyseTempsWithin: scopeBlock rootNode: rootNode]. - arguments do: - [:node| - node == nil ifFalse: "last argument of optimized to:do: can be nil" - [node analyseTempsWithin: scopeBlock rootNode: rootNode]]! Item was removed: - ----- Method: ReturnNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "Note we could do this: - scopeBlock ~~ rootNode block ifTrue: - [scopeBlock noteNonLocalReturn]. - and pass up the flag in <BlockNode>>>analyseTempsWithin:rootNode: - which may be fast but may also screw up the debugger. For now we - consider clean blocks a premature optimization." - self flag: 'consider clean blocks'. - expr analyseTempsWithin: scopeBlock rootNode: rootNode! Item was removed: - ----- Method: BlockNode>>postNumberingProcessTemps: (in category 'code generation (closures)') ----- - postNumberingProcessTemps: rootNode "<MethodNode>" - (temporaries isNil or: [temporaries isEmpty]) ifTrue: - ["Add all arguments to the pool so that copiedValues can be computed during sizing." - rootNode addLocalsToPool: arguments. - ^self]. - - "A temp can be local (and copied if it is not written to after it is captured. - A temp cannot be local if it is written to remotely. - Need to enumerate a copy of the temporaries because any temps becoming remote - will be removed from temporaries in analyseClosure: (and a single remote temp node - will get added)" - temporaries copy do: - [:each| each analyseClosure: rootNode]. - - "Now we may have added a remoteTempNode. So we need a statement to initialize it." - remoteTempNode ~~ nil ifTrue: - ["statements isArray ifTrue: - [statements := statements asOrderedCollection]." "true for decompiled trees" - (statements notEmpty - and: [statements first isAssignmentNode - and: [statements first variable isTemp - and: [statements first variable isIndirectTempVector]]]) - ifTrue: "If this is a decompiled tree there already is a temp vector initialization node." - [statements first variable become: remoteTempNode] - ifFalse: - [statements addFirst: (remoteTempNode nodeToInitialize: rootNode encoder)]]. - - "Now add all arguments and locals to the pool so that copiedValues can be computed during sizing." - rootNode - addLocalsToPool: arguments; - addLocalsToPool: temporaries! Item was removed: - ----- Method: PrimitiveNode class>>null (in category 'as yet unclassified') ----- - null - - ^ self new num: 0! Item was removed: - ----- Method: NewArrayNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "This is a no-op except in TempVariableNode" - ^self! Item was removed: - ----- Method: RemoteTempVectorNode>>cleanUpForRegeneration (in category 'debugger access') ----- - cleanUpForRegeneration - super cleanUpForRegeneration. - remoteTemps := nil! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>initialize (in category 'initialize-release') ----- - initialize - count := 0. - temps := IdentitySet new! Item was removed: - ----- Method: BytecodeEncoder>>blockExtentsToTempRefs (in category 'temps') ----- - blockExtentsToTempRefs - | blockExtentsToTempRefs | - blockExtentsToLocals ifNil: - [^nil]. - blockExtentsToTempRefs := Dictionary new. - blockExtentsToLocals keysAndValuesDo: - [:blockExtent :locals| - blockExtentsToTempRefs - at: blockExtent - put: (locals collect: - [:local| - local isIndirectTempVector - ifTrue: [local remoteTemps collect: - [:remoteLocal| remoteLocal key]] - ifFalse: [local key]])]. - ^blockExtentsToTempRefs! Item was removed: - ----- Method: BlockNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - | blockStart | - optimized ifTrue: - [self assert: (temporaries isEmpty and: [arguments isNil or: [arguments size <= 1]]). - statements do: - [:statement| - statement analyseTempsWithin: scopeBlock rootNode: rootNode]. - ^self]. - - rootNode noteBlockEntry: - [:entryNumber| - blockStart := entryNumber. - arguments notNil ifTrue: [arguments do: [:temp| temp definingScope: self]]. - temporaries notNil ifTrue: [temporaries do: [:temp| temp definingScope: self]]]. - - statements do: - [:statement| - statement analyseTempsWithin: self rootNode: rootNode]. - - rootNode noteBlockExit: - [:exitNumber| - blockExtent := blockStart to: exitNumber]. - - self postNumberingProcessTemps: rootNode! Item was removed: - ----- Method: PrimitiveNode>>spec: (in category 'as yet unclassified') ----- - spec: literal - - spec := literal! Item was removed: - ----- Method: RegenerationPreparingVisitor>>visitTempVariableNode: (in category 'visiting') ----- - visitTempVariableNode: aTempNode - aTempNode cleanUpForRegeneration! Item was removed: - ----- Method: BlockNode>>cleanUpForRegeneration (in category 'debugger access') ----- - cleanUpForRegeneration - arguments notNil ifTrue: - [arguments do: [:temp| temp cleanUpForRegeneration]]. - temporaries notNil ifTrue: - [temporaries do: [:temp| temp cleanUpForRegeneration]]. - (temporaries notNil - and: [temporaries notEmpty - and: [temporaries last isIndirectTempVector]]) ifTrue: - [temporaries := temporaries allButLast. - (statements notEmpty - and: [statements first isAssignmentNode - and: [statements first variable isTemp - and: [statements first variable isIndirectTempVector]]]) ifTrue: - [statements removeFirst]]. - remoteTempNode := nil! Item was removed: - ----- Method: PrimitiveNode>>num (in category 'as yet unclassified') ----- - num - - ^ primitiveNum! Item was removed: - ----- Method: PrimitiveNode>>sourceText (in category 'as yet unclassified') ----- - sourceText - - ^ String streamContents: [:stream | - self printPrimitiveOn: stream]! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>visitTempVariableNode: (in category 'visiting') ----- - visitTempVariableNode: aTempVariableNode - self renumberTemp: aTempVariableNode! Item was removed: - ----- Method: BraceNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - elements do: [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode]! Item was removed: - ----- Method: RegenerationPreparingVisitor>>visitBlockNode: (in category 'visiting') ----- - visitBlockNode: aBlockNode - aBlockNode cleanUpForRegeneration. - super visitBlockNode: aBlockNode! Item was removed: - ----- Method: BlockNode>>printTemporariesOn:indent: (in category 'printing') ----- - printTemporariesOn: aStream indent: level - - (temporaries == nil or: [temporaries size = 0]) - ifFalse: - [aStream nextPut: $|. - temporaries do: - [:arg | - aStream - space; - withStyleFor: #temporaryVariable - do: [aStream nextPutAll: arg key]]. - aStream nextPutAll: ' | '. - "If >0 args and >1 statement, put all statements on separate lines" - statements size > 1 ifTrue: [aStream crtab: level]]! Item was removed: - ----- Method: Compiler class>>closureDecompilerClass (in category 'accessing') ----- - closureDecompilerClass - ^self error: 'not installed'.! Item was removed: - ----- Method: ParseNode>>ifOptimizedBlockHoistTempsInto: (in category 'code generation (closures)') ----- - ifOptimizedBlockHoistTempsInto: scopeBlock "<BlockNode>" - "This is a No-op for all nodes except non-optimized BlockNodes." - ^self! Item was removed: - ----- Method: BytecodeAgnosticMethodNode>>copiedValuesWithinBlockExtent: (in category 'code generation (closures)') ----- - copiedValuesWithinBlockExtent: anInterval - ^((localsPool select: - [:temp| - temp isReferencedWithinBlockExtent: anInterval]) collect: - [:temp| - temp isRemote ifTrue: [temp remoteNode] ifFalse: [temp]]) asSortedCollection: - [:t1 :t2 | - t1 index < t2 index]! Item was removed: - ----- Method: AssignmentNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "N.B. since assigment happens :=after:= the value is evaluated the value is sent the message :=first:=." - value analyseTempsWithin: scopeBlock rootNode: rootNode. - variable beingAssignedToAnalyseTempsWithin: scopeBlock rootNode: rootNode! Item was removed: - Object subclass: #PrimitiveNode - instanceVariableNames: 'primitiveNum spec' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - - !PrimitiveNode commentStamp: 'ajh 3/24/2003 21:35' prior: 0! - I represent a primitive. I am more than just a number if I am a named primitive. - - Structure: - - num <Integer> Primitive number. - spec <Object> Stored in first literal when num is 117 or 120. - ! Item was removed: - ----- Method: Compiler class>>closureParserClass (in category 'accessing') ----- - closureParserClass - ^self error: 'not installed'.! Item was removed: - ----- Method: BytecodeAgnosticMethodNode>>prepareForRegeneration (in category 'debugger support') ----- - prepareForRegeneration - "Closure methods need to remove any remote temps prior to being regenerated." - (temporaries notEmpty and: [temporaries last isIndirectTempVector]) ifTrue: - [temporaries := temporaries allButLast]. - self accept: RegenerationPreparingVisitor new! Item was removed: - ----- Method: PrimitiveNode>>num: (in category 'as yet unclassified') ----- - num: n - - primitiveNum := n! Item was removed: - ----- Method: VariableNode>>beingAssignedToAnalyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - beingAssignedToAnalyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "No-op overridden by TempVariableNode"! Item was removed: - ----- Method: Parser>>properties (in category 'pragmas') ----- - properties - ^ properties ifNil: [ properties := MethodProperties new ]! Item was removed: - ----- Method: PrimitiveNode>>spec (in category 'as yet unclassified') ----- - spec - - ^ spec! Item was removed: - ParseNodeVisitor subclass: #RegenerationPreparingVisitor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! - - !RegenerationPreparingVisitor commentStamp: '<historical>' prior: 0! - I arrange that BlockNodes clean out any remote temps prior to being regenerated.! Item was removed: - ----- Method: TempVariableNode>>beingAssignedToAnalyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - beingAssignedToAnalyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - self addWriteWithin: scopeBlock at: rootNode locationCounter! Item was removed: - ----- Method: BytecodeAgnosticMethodNode>>blockExtentsToTempRefs (in category 'debugger support') ----- - blockExtentsToTempRefs - | blockExtentsToTempRefs methNode | - blockExtentsToTempRefs := encoder blockExtentsToTempRefs. - blockExtentsToTempRefs ifNil: - [methNode := sourceText - ifNil: "No source, use decompile string as source to map from" - [self parserClass new - encoderClass: encoder class; - parse: self decompileString - class: self methodClass] - ifNotNil: [self prepareForRegeneration. - self]. - methNode generate: #(0 0 0 0). "set bytecodes to map to" - blockExtentsToTempRefs := methNode encoder blockExtentsToTempRefs]. - ^blockExtentsToTempRefs! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>visitBlockNode: (in category 'visiting') ----- - visitBlockNode: aBlockNode - aBlockNode arguments do: - [:tempNode| - self renumberTemp: tempNode]. - aBlockNode temporaries do: - [:tempNode| - (tempNode scope >= 0 or: [tempNode isIndirectTempVector]) ifTrue: - [self renumberTemp: tempNode]]. - super visitBlockNode: aBlockNode! Item was removed: - ----- Method: PrimitiveNode>>printOn: (in category 'as yet unclassified') ----- - printOn: aStream - - aStream nextPutAll: 'primitive '; print: primitiveNum! Item was removed: - ----- Method: LeafNode>>analyseTempsWithin:rootNode: (in category 'code generation (closures)') ----- - analyseTempsWithin: scopeBlock "<BlockNode>" rootNode: rootNode "<MethodNode>" - "This is a no-op except in TempVariableNode" - ^self! Item was removed: - ----- Method: TempNumberNormalizingVisitor>>renumberTemp: (in category 'private') ----- - renumberTemp: tempNode - | name newName | - tempNode isIndirectTempVector ifTrue: - [tempNode remoteTemps do: - [:remoteTempNode| self renumberTemp: remoteTempNode]. - ^self]. - (temps includes: tempNode) ifTrue: [^self]. - name := tempNode key. - name size >= 2 ifFalse: [^self]. - name first = $t ifFalse: [^self]. - 2 to: name size do: - [:i| - (name at: i) isDigit ifFalse: [^self]]. - newName := 't', (count := count + 1) printString. - tempNode name: newName key: newName code: tempNode code. - temps add: tempNode - ! Item was removed: - ParseNodeVisitor subclass: #TempNumberNormalizingVisitor - instanceVariableNames: 'count temps' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! Item was removed: - ----- Method: MethodNode>>prepareForRegeneration (in category 'converting') ----- - prepareForRegeneration - "Nothing to do for vanilla nodes."! Item was removed: - ----- Method: BlockNode>>ifOptimizedBlockHoistTempsInto: (in category 'code generation (closures)') ----- - ifOptimizedBlockHoistTempsInto: scopeBlock "<BlockNode>" - "This is a No-op for all nodes except non-optimized BlockNodes." - "Let's assume the special > 0 guard in MessageNode>>analyseTempsWithin:forValue:encoder: is correct. - Then we can simply hoist our temps up." - self assert: (arguments isNil or: [arguments size <= 1]). - (arguments notNil and: [arguments notEmpty]) ifTrue: - [scopeBlock addHoistedTemps: arguments. - arguments := #()]. - temporaries notEmpty ifTrue: - [scopeBlock addHoistedTemps: temporaries. - temporaries := #()]!

1 0

The Inbox: Exceptions-eem.12.mcz
by commits＠source.squeak.org 06 Sep '09

06 Sep '09

A new version of Exceptions was added to project The Inbox: http://source.squeak.org/inbox/Exceptions-eem.12.mcz ==================== Summary ==================== Name: Exceptions-eem.12 Author: eem Time: 5 September 2009, 3:36:07 am UUID: 222baa54-c057-4244-8484-c4d78fb1fca1 Ancestors: Exceptions-ar.11 First package of eight in closure compiler fixes 9/5/2009. Add reachedDefaultHandler to MessageNotUnderstood so that doesNotUnderstand: can support resume:. ==================== Snapshot ==================== SystemOrganization addCategory: #'Exceptions-Kernel'! SystemOrganization addCategory: #'Exceptions-Extensions'! SystemOrganization addCategory: #'Exceptions-Tests'! TestCase subclass: #ExceptionTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Tests'! ----- Method: ExceptionTests>>assertSuccess: (in category 'private') ----- assertSuccess: anExceptionTester self should: [ ( anExceptionTester suiteLog first) endsWith: 'succeeded'].! ----- Method: ExceptionTests>>testDoubleOuterPass (in category 'testing-ExceptionTester') ----- testDoubleOuterPass self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest ) ! ----- Method: ExceptionTests>>testDoublePassOuter (in category 'testing-ExceptionTester') ----- testDoublePassOuter self assertSuccess: (ExceptionTester new runTest: #doublePassOuterTest ) ! ----- Method: ExceptionTests>>testDoubleResume (in category 'testing-ExceptionTester') ----- testDoubleResume self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest ) ! ----- Method: ExceptionTests>>testNoTimeout (in category 'testing') ----- testNoTimeout self assertSuccess: (ExceptionTester new runTest: #simpleNoTimeoutTest ) ! ----- Method: ExceptionTests>>testNonResumableFallOffTheEndHandler (in category 'testing-ExceptionTester') ----- testNonResumableFallOffTheEndHandler self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler ) ! ----- Method: ExceptionTests>>testNonResumableOuter (in category 'testing-outer') ----- testNonResumableOuter self should: [ [Error signal. 4] on: Error do: [:ex | ex outer. ex return: 5] ] raise: Error ! ----- Method: ExceptionTests>>testNonResumablePass (in category 'testing-outer') ----- testNonResumablePass self should: [ [Error signal. 4] on: Error do: [:ex | ex pass. ex return: 5] ] raise: Error ! ----- Method: ExceptionTests>>testResumableFallOffTheEndHandler (in category 'testing-ExceptionTester') ----- testResumableFallOffTheEndHandler self assertSuccess: (ExceptionTester new runTest: #resumableFallOffTheEndHandler ) ! ----- Method: ExceptionTests>>testResumableOuter (in category 'testing-outer') ----- testResumableOuter | result | result := [Notification signal. 4] on: Notification do: [:ex | ex outer. ex return: 5]. self assert: result == 5 ! ----- Method: ExceptionTests>>testResumablePass (in category 'testing-outer') ----- testResumablePass | result | result := [Notification signal. 4] on: Notification do: [:ex | ex pass. ex return: 5]. self assert: result == 4 ! ----- Method: ExceptionTests>>testSignalFromHandlerActionTest (in category 'testing-ExceptionTester') ----- testSignalFromHandlerActionTest self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest ) ! ----- Method: ExceptionTests>>testSimpleEnsure (in category 'testing-ExceptionTester') ----- testSimpleEnsure self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest ) ! ----- Method: ExceptionTests>>testSimpleEnsureTestWithError (in category 'testing-ExceptionTester') ----- testSimpleEnsureTestWithError self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithError ) ! ----- Method: ExceptionTests>>testSimpleEnsureTestWithNotification (in category 'testing-ExceptionTester') ----- testSimpleEnsureTestWithNotification self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification ) ! ----- Method: ExceptionTests>>testSimpleEnsureTestWithUparrow (in category 'testing-ExceptionTester') ----- testSimpleEnsureTestWithUparrow self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithUparrow ) ! ----- Method: ExceptionTests>>testSimpleIsNested (in category 'testing-ExceptionTester') ----- testSimpleIsNested self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest ) ! ----- Method: ExceptionTests>>testSimpleOuter (in category 'testing-ExceptionTester') ----- testSimpleOuter self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest ) ! ----- Method: ExceptionTests>>testSimplePass (in category 'testing-ExceptionTester') ----- testSimplePass self assertSuccess: (ExceptionTester new runTest: #simplePassTest ) ! ----- Method: ExceptionTests>>testSimpleResignalAs (in category 'testing-ExceptionTester') ----- testSimpleResignalAs self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest ) ! ----- Method: ExceptionTests>>testSimpleResume (in category 'testing-ExceptionTester') ----- testSimpleResume self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest ) ! ----- Method: ExceptionTests>>testSimpleRetry (in category 'testing-ExceptionTester') ----- testSimpleRetry self assertSuccess: (ExceptionTester new runTest: #simpleRetryTest ) ! ----- Method: ExceptionTests>>testSimpleRetryUsing (in category 'testing-ExceptionTester') ----- testSimpleRetryUsing self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest ) ! ----- Method: ExceptionTests>>testSimpleReturn (in category 'testing-ExceptionTester') ----- testSimpleReturn self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest ) ! ----- Method: ExceptionTests>>testTimeoutWithZeroDuration (in category 'testing') ----- testTimeoutWithZeroDuration self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutWithZeroDurationTest ) ! TestCase subclass: #ProcessTerminateBug instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Tests'! ----- Method: ProcessTerminateBug>>testSchedulerTermination (in category 'tests') ----- testSchedulerTermination | process sema gotHere sema2 | gotHere := false. sema := Semaphore new. sema2 := Semaphore new. process := [ sema signal. sema2 wait. "will be suspended here" gotHere := true. "e.g., we must *never* get here" ] forkAt: Processor activeProcess priority. sema wait. "until process gets scheduled" process terminate. sema2 signal. Processor yield. "will give process a chance to continue and horribly screw up" self assert: gotHere not. ! ----- Method: ProcessTerminateBug>>testUnwindFromActiveProcess (in category 'tests') ----- testUnwindFromActiveProcess | sema process | sema := Semaphore forMutualExclusion. self assert:(sema isSignaled). process := [ sema critical:[ self deny: sema isSignaled. Processor activeProcess terminate. ] ] forkAt: Processor userInterruptPriority. self assert: sema isSignaled.! ----- Method: ProcessTerminateBug>>testUnwindFromForeignProcess (in category 'tests') ----- testUnwindFromForeignProcess | sema process | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [ sema critical:[ self deny: sema isSignaled. sema wait. "deadlock" ] ] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "This is for illustration only - the BlockCannotReturn cannot be handled here (it's truncated already)" self shouldnt: [process terminate] raise: BlockCannotReturn. self assert: sema isSignaled. ! Object subclass: #Exception instanceVariableNames: 'messageText tag signalContext handlerContext outerContext' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !Exception commentStamp: '<historical>' prior: 0! This is the main class used to implement the exception handling system (EHS). It plays two distinct roles: that of the exception, and that of the exception handler. More specifically, it implements the bulk of the protocols laid out in the ANSI specification - those protocol names are reflected in the message categories. Exception is an abstract class. Instances should neither be created nor trapped. In most cases, subclasses should inherit from Error or Notification rather than directly from Exception. In implementing this EHS, The Fourth Estate Inc. incorporated some ideas and code from Craig Latta's EHS. His insights were crucial in allowing us to implement BlockContext>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification: ContextPart>>terminateTo: ContextPart>>terminate MethodContext>>receiver: MethodContext>>answer: Thanks, Craig!!! Exception subclass: #Abort instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: Abort>>defaultAction (in category 'as yet unclassified') ----- defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! Exception subclass: #Error instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !Error commentStamp: '<historical>' prior: 0! >From the ANSI standard: This protocol describes the behavior of instances of class Error. These are used to represent error conditions that prevent the normal continuation of processing. Actual error exceptions used by an application may be subclasses of this class. As Error is explicitly specified to be subclassable, conforming implementations must implement its behavior in a non-fragile manner. Additional notes: Error>defaultAction uses an explicit test for the presence of the Debugger class to decide whether or not it is in development mode. In the future, TFEI hopes to enhance the semantics of #defaultAction to improve support for pluggable default handlers.! Error subclass: #ArithmeticError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ArithmeticError subclass: #FloatingPointException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ArithmeticError subclass: #ZeroDivide instanceVariableNames: 'dividend' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ZeroDivide commentStamp: '<historical>' prior: 0! ZeroDivide may be signaled when a mathematical division by 0 is attempted.! ----- Method: ZeroDivide class>>dividend: (in category 'exceptionInstantiator') ----- dividend: argument ^self new dividend: argument; yourself! ----- Method: ZeroDivide>>dividend (in category 'exceptionDescription') ----- dividend "Answer the number that was being divided by zero." ^dividend! ----- Method: ZeroDivide>>dividend: (in category 'exceptionBuilder') ----- dividend: argument "Specify the number that was being divided by zero." dividend := argument! ----- Method: ZeroDivide>>isResumable (in category 'exceptionDescription') ----- isResumable "Determine whether an exception is resumable." ^true! Error subclass: #AttemptToWriteReadOnlyGlobal instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !AttemptToWriteReadOnlyGlobal commentStamp: 'gh 5/2/2002 20:26' prior: 0! This is a resumable error you get if you try to assign a readonly variable a value. Name definitions in the module system can be read only and are then created using instances of ReadOnlyVariableBinding instead of Association. See also LookupKey>>beReadWriteBinding and LookupKey>>beReadOnlyBinding. ! ----- Method: AttemptToWriteReadOnlyGlobal>>description (in category 'as yet unclassified') ----- description "Return a textual description of the exception." | desc mt | desc := 'Error'. ^(mt := self messageText) == nil ifTrue: [desc] ifFalse: [desc, ': ', mt]! ----- Method: AttemptToWriteReadOnlyGlobal>>isResumable (in category 'as yet unclassified') ----- isResumable ^true! Error subclass: #BlockCannotReturn instanceVariableNames: 'result deadHome' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !BlockCannotReturn commentStamp: '<historical>' prior: 0! This class is private to the EHS implementation. Its use allows for ensured execution to survive code such as: [self doThis. ^nil] ensure: [self doThat] Signaling or handling this exception is not recommended.! ----- Method: BlockCannotReturn>>deadHome (in category 'accessing') ----- deadHome ^ deadHome! ----- Method: BlockCannotReturn>>deadHome: (in category 'accessing') ----- deadHome: context deadHome := context! ----- Method: BlockCannotReturn>>defaultAction (in category 'exceptionDescription') ----- defaultAction self messageText: 'Block cannot return'. ^super defaultAction! ----- Method: BlockCannotReturn>>isResumable (in category 'exceptionDescription') ----- isResumable ^true! ----- Method: BlockCannotReturn>>result (in category 'accessing') ----- result ^result! ----- Method: BlockCannotReturn>>result: (in category 'accessing') ----- result: r result := r! Error subclass: #EndOfStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Extensions'! !EndOfStream commentStamp: '<historical>' prior: 0! Signalled when ReadStream>>next encounters a premature end.! ----- Method: EndOfStream>>defaultAction (in category 'exceptionDescription') ----- defaultAction "Answer ReadStream>>next default reply." ^ nil! ----- Method: EndOfStream>>isResumable (in category 'description') ----- isResumable "EndOfStream is resumable, so ReadStream>>next can answer" ^ true! ----- Method: Error>>defaultAction (in category 'exceptionDescription') ----- defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ----- Method: Error>>isResumable (in category 'private') ----- isResumable "Determine whether an exception is resumable." ^ false! Error subclass: #FTPConnectionException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: FTPConnectionException>>defaultAction (in category 'as yet unclassified') ----- defaultAction self resume! ----- Method: FTPConnectionException>>isResumable (in category 'as yet unclassified') ----- isResumable ^true! Error subclass: #FileStreamException instanceVariableNames: 'fileName' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! FileStreamException subclass: #CannotDeleteFileException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! FileStreamException subclass: #FileDoesNotExistException instanceVariableNames: 'readOnly' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: FileDoesNotExistException class>>example (in category 'examples') ----- example "FileDoesNotExistException example" | result | result := [(StandardFileStream readOnlyFileNamed: 'error42.log') contentsOfEntireFile] on: FileDoesNotExistException do: [:ex | 'No error log']. Transcript show: result; cr! ----- Method: FileDoesNotExistException>>defaultAction (in category 'exceptionDescription') ----- defaultAction "The default action taken if the exception is signaled." ^self readOnly ifTrue: [StandardFileStream readOnlyFileDoesNotExistUserHandling: self fileName] ifFalse: [StandardFileStream fileDoesNotExistUserHandling: self fileName] ! ----- Method: FileDoesNotExistException>>readOnly (in category 'accessing') ----- readOnly ^readOnly == true! ----- Method: FileDoesNotExistException>>readOnly: (in category 'accessing') ----- readOnly: aBoolean readOnly := aBoolean! FileStreamException subclass: #FileExistsException instanceVariableNames: 'fileClass' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: FileExistsException class>>fileName:fileClass: (in category 'exceptionInstantiator') ----- fileName: aFileName fileClass: aClass ^ self new fileName: aFileName; fileClass: aClass! ----- Method: FileExistsException>>defaultAction (in category 'exceptionDescription') ----- defaultAction "The default action taken if the exception is signaled." ^ self fileClass fileExistsUserHandling: self fileName ! ----- Method: FileExistsException>>fileClass (in category 'accessing') ----- fileClass ^ fileClass ifNil: [StandardFileStream]! ----- Method: FileExistsException>>fileClass: (in category 'accessing') ----- fileClass: aClass fileClass := aClass! ----- Method: FileStreamException class>>fileName: (in category 'exceptionInstantiator') ----- fileName: aFileName ^self new fileName: aFileName! ----- Method: FileStreamException>>fileName (in category 'exceptionDescription') ----- fileName ^fileName! ----- Method: FileStreamException>>fileName: (in category 'exceptionBuilder') ----- fileName: aFileName fileName := aFileName! ----- Method: FileStreamException>>isResumable (in category 'exceptionDescription') ----- isResumable "Determine whether an exception is resumable." ^true! ----- Method: FileStreamException>>messageText (in category 'exceptionDescription') ----- messageText "Return an exception's message text." ^messageText == nil ifTrue: [fileName printString] ifFalse: [messageText]! Error subclass: #InvalidDirectoryError instanceVariableNames: 'pathName' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: InvalidDirectoryError class>>pathName: (in category 'exceptionInstantiator') ----- pathName: badPathName ^self new pathName: badPathName! ----- Method: InvalidDirectoryError>>defaultAction (in category 'exceptionDescription') ----- defaultAction "Return an empty list as the default action of signaling the occurance of an invalid directory." ^#()! ----- Method: InvalidDirectoryError>>pathName (in category 'accessing') ----- pathName ^pathName! ----- Method: InvalidDirectoryError>>pathName: (in category 'accessing') ----- pathName: badPathName pathName := badPathName! Error subclass: #MessageNotUnderstood instanceVariableNames: 'message receiver reachedDefaultHandler' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !MessageNotUnderstood commentStamp: '<historical>' prior: 0! This exception is provided to support Object>>doesNotUnderstand:.! ----- Method: MessageNotUnderstood>>defaultAction (in category 'exceptionDescription') ----- defaultAction reachedDefaultHandler := true. super defaultAction! ----- Method: MessageNotUnderstood>>initialize (in category 'initialize-release') ----- initialize super initialize. reachedDefaultHandler := false! ----- Method: MessageNotUnderstood>>isResumable (in category 'exceptionDescription') ----- isResumable "Determine whether an exception is resumable." ^true! ----- Method: MessageNotUnderstood>>message (in category 'exceptionDescription') ----- message "Answer the selector and arguments of the message that failed." ^message! ----- Method: MessageNotUnderstood>>message: (in category 'exceptionBuilder') ----- message: aMessage message := aMessage! ----- Method: MessageNotUnderstood>>messageText (in category 'exceptionBuilder') ----- messageText "Return an exception's message text." ^messageText == nil ifTrue: [message == nil ifTrue: [super messageText] ifFalse: [message lookupClass printString, '>>', message selector asString]] ifFalse: [messageText]! ----- Method: MessageNotUnderstood>>reachedDefaultHandler (in category 'accessing') ----- reachedDefaultHandler ^reachedDefaultHandler! ----- Method: MessageNotUnderstood>>receiver (in category 'exceptionDescription') ----- receiver "Answer the receiver that did not understand the message" ^ receiver! ----- Method: MessageNotUnderstood>>receiver: (in category 'exceptionBuilder') ----- receiver: obj receiver := obj! Error subclass: #MyResumableTestError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Tests'! ----- Method: MyResumableTestError>>isResumable (in category 'exceptionDescription') ----- isResumable ^true! Error subclass: #MyTestError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Tests'! Error subclass: #NonBooleanReceiver instanceVariableNames: 'object' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: NonBooleanReceiver>>isResumable (in category 'signaledException') ----- isResumable ^true! ----- Method: NonBooleanReceiver>>object (in category 'accessing') ----- object ^object! ----- Method: NonBooleanReceiver>>object: (in category 'accessing') ----- object: anObject object := anObject! Error subclass: #SyntaxErrorNotification instanceVariableNames: 'inClass code category doitFlag errorMessage location' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Extensions'! ----- Method: SyntaxErrorNotification class>>inClass:category:withCode:doitFlag: (in category 'exceptionInstantiator') ----- inClass: aClass category: aCategory withCode: codeString doitFlag: doitFlag ^ (self new setClass: aClass category: aCategory code: codeString doitFlag: doitFlag) signal! ----- Method: SyntaxErrorNotification class>>inClass:category:withCode:doitFlag:errorMessage:location: (in category 'exceptionInstantiator') ----- inClass: aClass category: aCategory withCode: codeString doitFlag: doitFlag errorMessage: errorString location: location ^ (self new setClass: aClass category: aCategory code: codeString doitFlag: doitFlag errorMessage: errorString location: location) signal! ----- Method: SyntaxErrorNotification>>category (in category 'accessing') ----- category ^category! ----- Method: SyntaxErrorNotification>>defaultAction (in category 'exceptionDescription') ----- defaultAction ^ToolSet debugSyntaxError: self! ----- Method: SyntaxErrorNotification>>doitFlag (in category 'accessing') ----- doitFlag ^doitFlag! ----- Method: SyntaxErrorNotification>>errorClass (in category 'accessing') ----- errorClass ^inClass! ----- Method: SyntaxErrorNotification>>errorCode (in category 'accessing') ----- errorCode ^code! ----- Method: SyntaxErrorNotification>>errorMessage (in category 'accessing') ----- errorMessage ^errorMessage! ----- Method: SyntaxErrorNotification>>location (in category 'accessing') ----- location ^location! ----- Method: SyntaxErrorNotification>>messageText (in category 'accessing') ----- messageText ^ super messageText ifNil: [messageText := code]! ----- Method: SyntaxErrorNotification>>setClass:category:code:doitFlag: (in category 'accessing') ----- setClass: aClass category: aCategory code: codeString doitFlag: aBoolean inClass := aClass. category := aCategory. code := codeString. doitFlag := aBoolean ! ----- Method: SyntaxErrorNotification>>setClass:category:code:doitFlag:errorMessage:location: (in category 'accessing') ----- setClass: aClass category: aCategory code: codeString doitFlag: aBoolean errorMessage: errorString location: anInteger inClass := aClass. category := aCategory. code := codeString. doitFlag := aBoolean. errorMessage := errorString. location := anInteger! ----- Method: Exception class>>, (in category 'exceptionSelector') ----- , anotherException "Create an exception set." ^ExceptionSet new add: self; add: anotherException; yourself! ----- Method: Exception class>>handles: (in category 'exceptionSelector') ----- handles: exception "Determine whether an exception handler will accept a signaled exception." ^ exception isKindOf: self! ----- Method: Exception class>>signal (in category 'exceptionInstantiator') ----- signal "Signal the occurrence of an exceptional condition." ^ self new signal! ----- Method: Exception class>>signal: (in category 'exceptionInstantiator') ----- signal: signalerText "Signal the occurrence of an exceptional condition with a specified textual description." ^ self new signal: signalerText! ----- Method: Exception>>defaultAction (in category 'priv handling') ----- defaultAction "The default action taken if the exception is signaled." self subclassResponsibility! ----- Method: Exception>>description (in category 'printing') ----- description "Return a textual description of the exception." | desc mt | desc := self class name asString. ^(mt := self messageText) == nil ifTrue: [desc] ifFalse: [desc, ': ', mt]! ----- Method: Exception>>isNested (in category 'handling') ----- isNested "Determine whether the current exception handler is within the scope of another handler for the same exception." ^ handlerContext nextHandlerContext canHandleSignal: self! ----- Method: Exception>>isResumable (in category 'priv handling') ----- isResumable "Determine whether an exception is resumable." ^ true! ----- Method: Exception>>messageText (in category 'printing') ----- messageText "Return an exception's message text." ^messageText! ----- Method: Exception>>messageText: (in category 'signaling') ----- messageText: signalerText "Set an exception's message text." messageText := signalerText! ----- Method: Exception>>outer (in category 'handling') ----- outer "Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)." | prevOuterContext | self isResumable ifTrue: [ prevOuterContext := outerContext. outerContext := thisContext contextTag. ]. self pass. ! ----- Method: Exception>>pass (in category 'handling') ----- pass "Yield control to the enclosing exception action for the receiver." handlerContext nextHandlerContext handleSignal: self! ----- Method: Exception>>printOn: (in category 'printing') ----- printOn: stream stream nextPutAll: self description! ----- Method: Exception>>privHandlerContext: (in category 'priv handling') ----- privHandlerContext: aContextTag handlerContext := aContextTag! ----- Method: Exception>>receiver (in category 'printing') ----- receiver ^ self signalerContext receiver! ----- Method: Exception>>resignalAs: (in category 'handling') ----- resignalAs: replacementException "Signal an alternative exception in place of the receiver." self resumeUnchecked: replacementException signal! ----- Method: Exception>>resume (in category 'handling') ----- resume "Return from the message that signaled the receiver." self resume: nil! ----- Method: Exception>>resume: (in category 'handling') ----- resume: resumptionValue "Return resumptionValue as the value of the signal message." self isResumable ifFalse: [IllegalResumeAttempt signal]. self resumeUnchecked: resumptionValue! ----- Method: Exception>>resumeUnchecked: (in category 'handling') ----- resumeUnchecked: resumptionValue "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." | ctxt | outerContext ifNil: [ signalContext return: resumptionValue ] ifNotNil: [ ctxt := outerContext. outerContext := ctxt tempAt: 1. "prevOuterContext in #outer" ctxt return: resumptionValue ]. ! ----- Method: Exception>>retry (in category 'handling') ----- retry "Abort an exception handler and re-evaluate its protected block." handlerContext restart! ----- Method: Exception>>retryUsing: (in category 'handling') ----- retryUsing: alternativeBlock "Abort an exception handler and evaluate a new block in place of the handler's protected block." handlerContext restartWithNewReceiver: alternativeBlock ! ----- Method: Exception>>return (in category 'handling') ----- return "Return nil as the value of the block protected by the active exception handler." self return: nil! ----- Method: Exception>>return: (in category 'handling') ----- return: returnValue "Return the argument as the value of the block protected by the active exception handler." handlerContext return: returnValue! ----- Method: Exception>>searchFrom: (in category 'handling') ----- searchFrom: aContext " Set the context where the handler search will start. " signalContext := aContext contextTag! ----- Method: Exception>>signal (in category 'signaling') ----- signal "Ask ContextHandlers in the sender chain to handle this signal. The default is to execute and return my defaultAction." signalContext := thisContext contextTag. ^ thisContext nextHandlerContext handleSignal: self! ----- Method: Exception>>signal: (in category 'signaling') ----- signal: signalerText "Signal the occurrence of an exceptional condition with a specified textual description." self messageText: signalerText. ^ self signal! ----- Method: Exception>>signalerContext (in category 'printing') ----- signalerContext "Find the first sender of signal(:)" ^ signalContext findContextSuchThat: [:ctxt | (ctxt receiver == self or: [ctxt receiver == self class]) not]! ----- Method: Exception>>tag (in category 'exceptionDescription') ----- tag "Return an exception's tag value." ^tag == nil ifTrue: [self messageText] ifFalse: [tag]! ----- Method: Exception>>tag: (in category 'exceptionBuilder') ----- tag: t "This message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and the spec states that the signaler may store the tag value." tag := t! Exception subclass: #Halt instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Extensions'! !Halt commentStamp: '<historical>' prior: 0! Halt is provided to support Object>>halt.! Halt subclass: #AssertionFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Extensions'! !AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! ----- Method: Halt>>defaultAction (in category 'priv handling') ----- defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ----- Method: Halt>>isResumable (in category 'description') ----- isResumable ^true! Exception subclass: #IllegalResumeAttempt instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !IllegalResumeAttempt commentStamp: '<historical>' prior: 0! This class is private to the EHS implementation. An instance of it is signaled whenever an attempt is made to resume from an exception which answers false to #isResumable.! ----- Method: IllegalResumeAttempt>>defaultAction (in category 'comment') ----- defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ----- Method: IllegalResumeAttempt>>isResumable (in category 'comment') ----- isResumable ^ false! ----- Method: IllegalResumeAttempt>>readMe (in category 'comment') ----- readMe "Never handle this exception!!"! Exception subclass: #Notification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !Notification commentStamp: '<historical>' prior: 0! A Notification is an indication that something interesting has occurred. If it is not handled, it will pass by without effect.! Notification subclass: #ExceptionAboutToReturn instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ExceptionAboutToReturn commentStamp: '<historical>' prior: 0! This class is private to the EHS implementation. Its use allows for ensured execution to survive code such as: [self doThis. ^nil] ensure: [self doThat] Signaling or handling this exception is not recommended. Not even slightly.! Notification subclass: #InMidstOfFileinNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: InMidstOfFileinNotification>>defaultAction (in category 'as yet unclassified') ----- defaultAction self resume: false! Notification subclass: #MyTestNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Tests'! ----- Method: Notification>>defaultAction (in category 'exceptionDescription') ----- defaultAction "No action is taken. The value nil is returned as the value of the message that signaled the exception." ^nil! ----- Method: Notification>>isResumable (in category 'exceptionDescription') ----- isResumable "Answer true. Notification exceptions by default are specified to be resumable." ^true! Notification subclass: #OutOfScopeNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: OutOfScopeNotification>>defaultAction (in category 'as yet unclassified') ----- defaultAction self resume: false! Notification subclass: #ParserRemovedUnusedTemps instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Tests'! Notification subclass: #PickAFileToWriteNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! Notification subclass: #ProgressNotification instanceVariableNames: 'amount done extra' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ProgressNotification commentStamp: '<historical>' prior: 0! Used to signal progress without requiring a specific receiver to notify. Caller/callee convention could be to simply count the number of signals caught or to pass more substantive information with #signal:.! ----- Method: ProgressNotification class>>signal:extra: (in category 'exceptionInstantiator') ----- signal: signalerText extra: extraParam "TFEI - Signal the occurrence of an exceptional condition with a specified textual description." | ex | ex := self new. ex extraParam: extraParam. ^ex signal: signalerText! ----- Method: ProgressNotification>>amount (in category 'accessing') ----- amount ^amount! ----- Method: ProgressNotification>>amount: (in category 'accessing') ----- amount: aNumber amount := aNumber! ----- Method: ProgressNotification>>done (in category 'accessing') ----- done ^done! ----- Method: ProgressNotification>>done: (in category 'accessing') ----- done: aNumber done := aNumber! ----- Method: ProgressNotification>>extraParam (in category 'accessing') ----- extraParam ^extra! ----- Method: ProgressNotification>>extraParam: (in category 'accessing') ----- extraParam: anObject extra := anObject! Notification subclass: #ProgressTargetRequestNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ProgressTargetRequestNotification commentStamp: '<historical>' prior: 0! I am used to allow the ComplexProgressIndicator one last chance at finding an appropriate place to display. If I am unhandled, then the cursor location and a default rectangle are used.! ----- Method: ProgressTargetRequestNotification>>defaultAction (in category 'as yet unclassified') ----- defaultAction self resume: nil! Notification subclass: #ProjectEntryNotification instanceVariableNames: 'projectToEnter' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ProjectEntryNotification commentStamp: '<historical>' prior: 0! I provide a way to override the style of Project entry (which is buried deep in several different methods). My default is a normal full-screen enter.! ----- Method: ProjectEntryNotification class>>signal: (in category 'as yet unclassified') ----- signal: aProject | ex | ex := self new. ex projectToEnter: aProject. ^ex signal: 'Entering ',aProject printString! ----- Method: ProjectEntryNotification>>defaultAction (in category 'as yet unclassified') ----- defaultAction self resume: projectToEnter enter! ----- Method: ProjectEntryNotification>>projectToEnter (in category 'as yet unclassified') ----- projectToEnter ^projectToEnter! ----- Method: ProjectEntryNotification>>projectToEnter: (in category 'as yet unclassified') ----- projectToEnter: aProject projectToEnter := aProject! Notification subclass: #ProjectPasswordNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: ProjectPasswordNotification>>defaultAction (in category 'as yet unclassified') ----- defaultAction self resume: ''! Notification subclass: #ProjectViewOpenNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ProjectViewOpenNotification commentStamp: '<historical>' prior: 0! ProjectViewOpenNotification is signalled to determine if a ProjectViewMorph is needed for a newly created project. The default answer is yes.! ----- Method: ProjectViewOpenNotification>>defaultAction (in category 'as yet unclassified') ----- defaultAction self resume: true! Notification subclass: #ProvideAnswerNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! Notification subclass: #TimedOut instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !TimedOut commentStamp: 'brp 10/21/2004 17:47' prior: 0! I am signalled by #duration:timeoutDo: if the receiving block takes too long to execute. I am signalled by a watchdog process spawned by #duration:timeoutDo: and caught in the same method. I am not intended to be used elsewhere.! Notification subclass: #Warning instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !Warning commentStamp: '<historical>' prior: 0! A Warning is a Notification which by default should be brought to the attention of the user.! Warning subclass: #Deprecation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !Deprecation commentStamp: 'dew 5/21/2003 17:46' prior: 0! This Warning is signalled by methods which are deprecated. The use of Object>>#deprecatedExplanation: aString and Object>>#deprecated: aBlock explanation: aString is recommended. Idiom: Imagine I want to deprecate the message #foo. foo ^ 'foo' I can replace it with: foo self deprecatedExplanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ^ 'foo' Or, for certain cases such as when #foo implements a primitive, #foo can be renamed to #fooDeprecated. fooDeprecated ^ <primitive> foo ^ self deprecated: [self fooDeprecated] explanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ! ----- Method: Warning>>defaultAction (in category 'exceptionDescription') ----- defaultAction "The user should be notified of the occurrence of an exceptional occurrence and given an option of continuing or aborting the computation. The description of the occurrence should include any text specified as the argument of the #signal: message." ToolSet debugContext: thisContext label: 'Warning' contents: self messageText, '\\Select Proceed to continue, or close this window to cancel the operation.' withCRs. self resume. ! Exception subclass: #ProgressInitiationException instanceVariableNames: 'workBlock maxVal minVal aPoint progressTitle' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ProgressInitiationException commentStamp: '<historical>' prior: 0! I provide a way to alter the behavior of the old-style progress notifier in String. See examples in: ProgressInitiationException testWithout. ProgressInitiationException testWith. ! ----- Method: ProgressInitiationException class>>display:at:from:to:during: (in category 'signalling') ----- display: aString at: aPoint from: minVal to: maxVal during: workBlock ^ self new display: aString at: aPoint from: minVal to: maxVal during: workBlock! ----- Method: ProgressInitiationException class>>testInnermost (in category 'examples and tests') ----- testInnermost "test the progress code WITHOUT special handling" ^'Now here''s some Real Progress' displayProgressAt: Sensor cursorPoint from: 0 to: 10 during: [ :bar | 1 to: 10 do: [ :x | bar value: x. (Delay forMilliseconds: 500) wait. x = 5 ifTrue: [1/0]. "just to make life interesting" ]. 'done' ]. ! ----- Method: ProgressInitiationException class>>testWith (in category 'examples and tests') ----- testWith "test progress code WITH special handling of progress notifications" ^[ self testWithAdditionalInfo ] on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | Transcript show: min printString,' ',max printString,' ',curr printString; cr ]. ]. ! ----- Method: ProgressInitiationException class>>testWithAdditionalInfo (in category 'examples and tests') ----- testWithAdditionalInfo ^{'starting'. self testWithout. 'really!!'}! ----- Method: ProgressInitiationException class>>testWithout (in category 'examples and tests') ----- testWithout "test the progress code WITHOUT special handling" ^[self testInnermost] on: ZeroDivide do: [ :ex | ex resume] ! ----- Method: ProgressInitiationException>>defaultAction (in category 'as yet unclassified') ----- defaultAction Smalltalk isMorphic ifTrue: [self defaultMorphicAction] ifFalse: [self defaultMVCAction]. ! ----- Method: ProgressInitiationException>>defaultMVCAction (in category 'as yet unclassified') ----- defaultMVCAction | delta savedArea captionText textFrame barFrame outerFrame result range lastW w | barFrame := aPoint - (75@10) corner: aPoint + (75@10). captionText := DisplayText text: progressTitle asText allBold. captionText foregroundColor: Color black backgroundColor: Color white. textFrame := captionText boundingBox insetBy: -4. textFrame := textFrame align: textFrame bottomCenter with: barFrame topCenter + (0@2). outerFrame := barFrame merge: textFrame. delta := outerFrame amountToTranslateWithin: Display boundingBox. barFrame := barFrame translateBy: delta. textFrame := textFrame translateBy: delta. outerFrame := outerFrame translateBy: delta. savedArea := Form fromDisplay: outerFrame. Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2). Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2). captionText displayOn: Display at: textFrame topLeft + (4@4). range := maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" lastW := 0. [result := workBlock value: "Supply the bar-update block for evaluation in the work block" [:barVal | w := ((barFrame width-4) asFloat * ((barVal-minVal) asFloat / range min: 1.0)) asInteger. w ~= lastW ifTrue: [ Display fillGray: (barFrame topLeft + (2@2) extent: w@16). lastW := w]]] ensure: [savedArea displayOn: Display at: outerFrame topLeft]. self resume: result! ----- Method: ProgressInitiationException>>defaultMorphicAction (in category 'as yet unclassified') ----- defaultMorphicAction | result progress | progress := SystemProgressMorph label: progressTitle min: minVal max: maxVal. [ [result := workBlock value: progress] on: ProgressNotification do:[:ex| ex extraParam isString ifTrue:[ SystemProgressMorph uniqueInstance labelAt: progress put: ex extraParam. ]. ex resume. ]. ] ensure: [SystemProgressMorph close: progress]. self resume: result! ----- Method: ProgressInitiationException>>display:at:from:to:during: (in category 'as yet unclassified') ----- display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock progressTitle := argString. aPoint := argPoint. minVal := argMinVal. maxVal := argMaxVal. workBlock := argWorkBlock. ^self signal! ----- Method: ProgressInitiationException>>isResumable (in category 'as yet unclassified') ----- isResumable ^true! ----- Method: ProgressInitiationException>>sendNotificationsTo: (in category 'as yet unclassified') ----- sendNotificationsTo: aNewBlock self resume: ( workBlock value: [ :barVal | aNewBlock value: minVal value: maxVal value: barVal ] ) ! Exception subclass: #UnhandledError instanceVariableNames: 'exception' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! ----- Method: UnhandledError class>>signalForException: (in category 'as yet unclassified') ----- signalForException: anError ^ self new exception: anError; signal! ----- Method: UnhandledError>>defaultAction (in category 'priv handling') ----- defaultAction "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." ^ToolSet debugError: exception.! ----- Method: UnhandledError>>exception (in category 'as yet unclassified') ----- exception ^ exception! ----- Method: UnhandledError>>exception: (in category 'as yet unclassified') ----- exception: anError exception := anError! ----- Method: UnhandledError>>isResumable (in category 'priv handling') ----- isResumable ^ false! Object subclass: #ExceptionSet instanceVariableNames: 'exceptions' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Kernel'! !ExceptionSet commentStamp: '<historical>' prior: 0! An ExceptionSet is a grouping of exception handlers which acts as a single handler. Within the group, the most recently added handler will be the last handler found during a handler search (in the case where more than one handler in the group is capable of handling a given exception). ! ----- Method: ExceptionSet>>, (in category 'exceptionSelector') ----- , anException "Return an exception set that contains the receiver and the argument exception. This is commonly used to specify a set of exception selectors for an exception handler." self add: anException. ^self! ----- Method: ExceptionSet>>add: (in category 'private') ----- add: anException exceptions add: anException! ----- Method: ExceptionSet>>handles: (in category 'exceptionSelector') ----- handles: anException "Determine whether an exception handler will accept a signaled exception." exceptions do: [:ex | (ex handles: anException) ifTrue: [^true]]. ^false! ----- Method: ExceptionSet>>initialize (in category 'private') ----- initialize exceptions := OrderedCollection new! Object subclass: #ExceptionTester instanceVariableNames: 'log suiteLog iterationsBeforeTimeout' classVariableNames: '' poolDictionaries: '' category: 'Exceptions-Tests'! ----- Method: ExceptionTester>>basicANSISignaledExceptionTestSelectors (in category 'accessing') ----- basicANSISignaledExceptionTestSelectors ^#( simpleIsNestedTest simpleOuterTest doubleOuterTest doubleOuterPassTest doublePassOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! ----- Method: ExceptionTester>>basicTestSelectors (in category 'accessing') ----- basicTestSelectors ^ #(#simpleEnsureTest #simpleEnsureTestWithNotification #simpleEnsureTestWithUparrow #simpleEnsureTestWithError #signalFromHandlerActionTest #resumableFallOffTheEndHandler #nonResumableFallOffTheEndHandler #doubleResumeTest #simpleTimeoutWithZeroDurationTest #simpleTimeoutTest simpleNoTimeoutTest)! ----- Method: ExceptionTester>>clearLog (in category 'logging') ----- clearLog log := nil! ----- Method: ExceptionTester>>contents (in category 'logging') ----- contents ^( self log inject: (WriteStream on: (String new: 80)) into: [:result :item | result cr; nextPutAll: item; yourself] ) contents! ----- Method: ExceptionTester>>doSomething (in category 'pseudo actions') ----- doSomething self log: self doSomethingString! ----- Method: ExceptionTester>>doSomethingElse (in category 'pseudo actions') ----- doSomethingElse self log: self doSomethingElseString! ----- Method: ExceptionTester>>doSomethingElseString (in category 'accessing') ----- doSomethingElseString ^'Do something else.'! ----- Method: ExceptionTester>>doSomethingExceptional (in category 'pseudo actions') ----- doSomethingExceptional self log: self doSomethingExceptionalString! ----- Method: ExceptionTester>>doSomethingExceptionalString (in category 'accessing') ----- doSomethingExceptionalString ^'Do something exceptional.'! ----- Method: ExceptionTester>>doSomethingString (in category 'accessing') ----- doSomethingString ^'Do something.'! ----- Method: ExceptionTester>>doYetAnotherThing (in category 'pseudo actions') ----- doYetAnotherThing self log: self doYetAnotherThingString! ----- Method: ExceptionTester>>doYetAnotherThingString (in category 'accessing') ----- doYetAnotherThingString ^'Do yet another thing.'! ----- Method: ExceptionTester>>doubleOuterPassTest (in category 'signaledException tests') ----- doubleOuterPassTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | ex pass. self doSomethingExceptional]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ----- Method: ExceptionTester>>doubleOuterPassTestResults (in category 'signaledException results') ----- doubleOuterPassTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ----- Method: ExceptionTester>>doubleOuterTest (in category 'signaledException tests') ----- doubleOuterTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingExceptional]] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ----- Method: ExceptionTester>>doublePassOuterTest (in category 'signaledException tests') ----- doublePassOuterTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex pass. self doSomethingExceptional]] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ----- Method: ExceptionTester>>doublePassOuterTestResults (in category 'signaledException results') ----- doublePassOuterTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ----- Method: ExceptionTester>>doubleResumeTest (in category 'tests') ----- doubleResumeTest [self doSomething. MyResumableTestError signal. self doSomethingElse. MyResumableTestError signal. self doYetAnotherThing] on: MyResumableTestError do: [:ex | ex resume].! ----- Method: ExceptionTester>>doubleResumeTestResults (in category 'results') ----- doubleResumeTestResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>iterationsBeforeTimeout (in category 'accessing') ----- iterationsBeforeTimeout ^ iterationsBeforeTimeout! ----- Method: ExceptionTester>>iterationsBeforeTimeout: (in category 'accessing') ----- iterationsBeforeTimeout: anInteger iterationsBeforeTimeout := anInteger! ----- Method: ExceptionTester>>log (in category 'accessing') ----- log log == nil ifTrue: [log := OrderedCollection new]. ^log! ----- Method: ExceptionTester>>log: (in category 'logging') ----- log: aString self log add: aString! ----- Method: ExceptionTester>>logTest: (in category 'logging') ----- logTest: aSelector self suiteLog add: aSelector! ----- Method: ExceptionTester>>logTestResult: (in category 'logging') ----- logTestResult: aString | index | index := self suiteLog size. self suiteLog at: index put: ((self suiteLog at: index), ' ', aString)! ----- Method: ExceptionTester>>methodWithError (in category 'pseudo actions') ----- methodWithError MyTestError signal: self testString! ----- Method: ExceptionTester>>methodWithNotification (in category 'pseudo actions') ----- methodWithNotification MyTestNotification signal: self testString! ----- Method: ExceptionTester>>nonResumableFallOffTheEndHandler (in category 'tests') ----- nonResumableFallOffTheEndHandler [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | self doSomethingExceptional]. self doYetAnotherThing! ----- Method: ExceptionTester>>nonResumableFallOffTheEndHandlerResults (in category 'results') ----- nonResumableFallOffTheEndHandlerResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingExceptionalString; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>resumableFallOffTheEndHandler (in category 'tests') ----- resumableFallOffTheEndHandler [self doSomething. MyTestNotification signal. self doSomethingElse] on: MyTestNotification do: [:ex | self doSomethingExceptional]. self doYetAnotherThing! ----- Method: ExceptionTester>>resumableFallOffTheEndHandlerResults (in category 'results') ----- resumableFallOffTheEndHandlerResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingExceptionalString; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>runAllTests (in category 'suites') ----- runAllTests "ExceptionTester new runAllTests" self runBasicTests; runBasicANSISignaledExceptionTests! ----- Method: ExceptionTester>>runBasicANSISignaledExceptionTests (in category 'suites') ----- runBasicANSISignaledExceptionTests self basicANSISignaledExceptionTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ----- Method: ExceptionTester>>runBasicTests (in category 'suites') ----- runBasicTests self basicTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ----- Method: ExceptionTester>>runTest: (in category 'testing') ----- runTest: aSelector | actualResult expectedResult | [ self logTest: aSelector; clearLog; perform: aSelector ] on: MyTestError do: [ :ex | self log: 'Unhandled Exception'. ex return: nil ]. actualResult := self log. expectedResult := self perform: (aSelector, #Results) asSymbol. actualResult = expectedResult ifTrue: [self logTestResult: 'succeeded'] ifFalse: [self logTestResult: 'failed' ]. ! ----- Method: ExceptionTester>>signalFromHandlerActionTest (in category 'tests') ----- signalFromHandlerActionTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [self doYetAnotherThing. MyTestError signal]! ----- Method: ExceptionTester>>signalFromHandlerActionTestResults (in category 'results') ----- signalFromHandlerActionTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: 'Unhandled Exception'; yourself! ----- Method: ExceptionTester>>simpleEnsureTest (in category 'tests') ----- simpleEnsureTest [self doSomething. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ----- Method: ExceptionTester>>simpleEnsureTestResults (in category 'results') ----- simpleEnsureTestResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>simpleEnsureTestWithError (in category 'tests') ----- simpleEnsureTestWithError [self doSomething. MyTestError signal. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ----- Method: ExceptionTester>>simpleEnsureTestWithErrorResults (in category 'results') ----- simpleEnsureTestWithErrorResults ^OrderedCollection new add: self doSomethingString; add: 'Unhandled Exception'; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>simpleEnsureTestWithNotification (in category 'tests') ----- simpleEnsureTestWithNotification [self doSomething. self methodWithNotification. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ----- Method: ExceptionTester>>simpleEnsureTestWithNotificationResults (in category 'results') ----- simpleEnsureTestWithNotificationResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>simpleEnsureTestWithUparrow (in category 'tests') ----- simpleEnsureTestWithUparrow [self doSomething. true ifTrue: [^nil]. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ----- Method: ExceptionTester>>simpleEnsureTestWithUparrowResults (in category 'results') ----- simpleEnsureTestWithUparrowResults ^OrderedCollection new add: self doSomethingString; " add: self doSomethingElseString;" add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>simpleIsNestedTest (in category 'signaledException tests') ----- simpleIsNestedTest "uses resignalAs:" [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex isNested "expecting to detect handler in #runTest:" ifTrue: [self doYetAnotherThing. ex resignalAs: MyTestNotification new]]! ----- Method: ExceptionTester>>simpleIsNestedTestResults (in category 'signaledException results') ----- simpleIsNestedTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ----- Method: ExceptionTester>>simpleNoTimeoutTest (in category 'tests') ----- simpleNoTimeoutTest [ self doSomething ] valueWithin: 1 day onTimeout: [ self doSomethingElse ]. ! ----- Method: ExceptionTester>>simpleNoTimeoutTestResults (in category 'results') ----- simpleNoTimeoutTestResults ^OrderedCollection new add: self doSomethingString; yourself! ----- Method: ExceptionTester>>simpleOuterTest (in category 'signaledException tests') ----- simpleOuterTest "uses #resume" [[self doSomething. MyTestNotification signal. "self doSomethingElse" self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ----- Method: ExceptionTester>>simpleOuterTestResults (in category 'signaledException results') ----- simpleOuterTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ----- Method: ExceptionTester>>simplePassTest (in category 'signaledException tests') ----- simplePassTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | self doYetAnotherThing. ex pass "expecting handler in #runTest:"]! ----- Method: ExceptionTester>>simplePassTestResults (in category 'signaledException results') ----- simplePassTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: 'Unhandled Exception'; yourself! ----- Method: ExceptionTester>>simpleResignalAsTest (in category 'signaledException tests') ----- simpleResignalAsTest "ExceptionTester new simpleResignalAsTest" [self doSomething. MyTestNotification signal. self doSomethingElse] on: MyTestNotification do: [:ex | ex resignalAs: MyTestError new]! ----- Method: ExceptionTester>>simpleResignalAsTestResults (in category 'signaledException results') ----- simpleResignalAsTestResults ^OrderedCollection new add: self doSomethingString; add: 'Unhandled Exception'; yourself! ----- Method: ExceptionTester>>simpleResumeTest (in category 'signaledException tests') ----- simpleResumeTest "see if we can resume twice" | it | [self doSomething. it := MyResumableTestError signal. it = 3 ifTrue: [self doSomethingElse]. it := MyResumableTestError signal. it = 3 ifTrue: [self doSomethingElse]. ] on: MyResumableTestError do: [:ex | self doYetAnotherThing. ex resume: 3]! ----- Method: ExceptionTester>>simpleResumeTestResults (in category 'signaledException results') ----- simpleResumeTestResults "see if we can resume twice" ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ----- Method: ExceptionTester>>simpleRetryTest (in category 'signaledException tests') ----- simpleRetryTest | theMeaningOfLife | theMeaningOfLife := nil. [self doSomething. theMeaningOfLife == nil ifTrue: [MyTestError signal] ifFalse: [self doSomethingElse]] on: MyTestError do: [:ex | theMeaningOfLife := 42. self doYetAnotherThing. ex retry]! ----- Method: ExceptionTester>>simpleRetryTestResults (in category 'signaledException results') ----- simpleRetryTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingString; add: self doSomethingElseString; yourself! ----- Method: ExceptionTester>>simpleRetryUsingTest (in category 'signaledException tests') ----- simpleRetryUsingTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex retryUsing: [self doYetAnotherThing]]! ----- Method: ExceptionTester>>simpleRetryUsingTestResults (in category 'signaledException results') ----- simpleRetryUsingTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>simpleReturnTest (in category 'signaledException tests') ----- simpleReturnTest | it | it := [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex return: 3]. it = 3 ifTrue: [self doYetAnotherThing]! ----- Method: ExceptionTester>>simpleReturnTestResults (in category 'signaledException results') ----- simpleReturnTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ----- Method: ExceptionTester>>simpleTimeoutTest (in category 'tests') ----- simpleTimeoutTest | n | [1 to: 1000000 do: [ :i | n := i. self doSomething ] ] valueWithin: 50 milliSeconds onTimeout: [ self iterationsBeforeTimeout: n. self doSomethingElse ]! ----- Method: ExceptionTester>>simpleTimeoutTestResults (in category 'results') ----- simpleTimeoutTestResults | things | things := OrderedCollection new: self iterationsBeforeTimeout. self iterationsBeforeTimeout timesRepeat: [ things add: self doSomethingString ]. things add: self doSomethingElseString. ^ things! ----- Method: ExceptionTester>>simpleTimeoutWithZeroDurationTest (in category 'tests') ----- simpleTimeoutWithZeroDurationTest [ self doSomething ] valueWithin: 0 seconds onTimeout: [ self doSomethingElse ]. ! ----- Method: ExceptionTester>>simpleTimeoutWithZeroDurationTestResults (in category 'results') ----- simpleTimeoutWithZeroDurationTestResults ^OrderedCollection new add: self doSomethingElseString; yourself! ----- Method: ExceptionTester>>suiteLog (in category 'accessing') ----- suiteLog suiteLog == nil ifTrue: [suiteLog := OrderedCollection new]. ^suiteLog! ----- Method: ExceptionTester>>testString (in category 'accessing') ----- testString ^'This is only a test.'! ----- Method: ExceptionTester>>warningTest (in category 'tests') ----- warningTest self log: 'About to signal warning.'. Warning signal: 'Ouch'. self log: 'Warning signal handled and resumed.'!

1 0

some thoughts on coding practices.
by John M McIntosh 06 Sep '09

06 Sep '09

Today I was faced with trying to consolidate some overrides for the iPhone work and faced the following issues: Or perhaps it just wasn't my day to do software development on the EuroStar. (a) I need really to extend or subclass InputEventSensor (1) I'm not really sure how to best add instance variables to InputEventSensor via MC. (2) I wanted to make a subclass, but then discovered RFBServer which I need actually hard codes a reference to InputEventSensor versus saying InputEventHandler defaultClass (or something) (3) RFBEventSensor then cheefully subclasses InputEventSensor which defeats my proposed subclass, not sure how in MC I could change the class hierarcy of someone else. (b) RBSpellChecker only picks between macintosh and other, so adding a subclass for iPhone means hacking startup for RBSpellChecker, versus having the more standard iteration over subclasses and having them choose who can do the work. Also if it's not macintosh that does not mean it's iPhone, or windows, risc, or unix... These both seemed hurdles to getting somthing productive done so I'll welcome comments about how to make it easier. -- = = = ======================================================================== John M. McIntosh <johnmci(a)smalltalkconsulting.com> Twitter: squeaker68882 Corporate Smalltalk Consulting Ltd. http://www.smalltalkconsulting.com = = = ========================================================================

3 2

← Newer
1
...
26
27
28
29
30
31
32
...
37
Older →

Jump to page: