'From Squeak3.9alpha of 4 July 2005 [latest update: #6716] on 21 January 2006 at 2:13:04 pm'! Object subclass: #Pragma instanceVariableNames: 'method keyword arguments' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !Pragma commentStamp: 'lr 1/20/2006 02:03' prior: 0! 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 retreived using one of the pragma search methods of the 'finding' protocol on the class side.! !Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:04'! method "Answer the compiled-method containing the pragma." ^ method! ! !Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:08'! methodClass "Answer the class of the method containing the pragma." ^ method methodClass! ! !Pragma methodsFor: 'accessing-method' stamp: 'lr 1/21/2006 13:10'! selector "Answer the selector of the method containing the pragma." ^ method who last.! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'! argumentAt: anInteger "Answer one of the arguments of the pragma." ^ self arguments at: anInteger.! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:54'! arguments "Answer the arguments of the recieving pragma. For a pragma defined as this will answer #(val1 val2)." ^ arguments! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:53'! keyword "Answer the keyword of the recieving pragma. For a pragma defined as this will answer #key1:key2." ^ keyword! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:55'! message "Answer the message of the recieving pragma." ^ Message selector: self keyword arguments: self arguments. ! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'! numArgs "Answer the number of arguments in the pragma." ^ self arguments size.! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'! setArguments: anArray arguments := anArray! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'! setKeyword: aSymbol keyword := aSymbol! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/19/2006 23:39'! setMethod: aCompiledMethod method := aCompiledMethod! ! !Pragma methodsFor: 'testing' stamp: 'lr 1/20/2006 19:11'! hasLiteralSuchThat: aBlock ^ (aBlock value: self keyword) or: [ self arguments hasLiteralSuchThat: aBlock ].! ! !Pragma methodsFor: 'testing' stamp: 'lr 1/20/2006 19:11'! hasLiteral: aLiteral ^ self keyword == aLiteral or: [ self arguments hasLiteral: aLiteral ].! ! Pragma class instanceVariableNames: ''! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:54'! allNamed: aSymbol from: aSubClass to: aSuperClass "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol." ^ Array streamContents: [ :stream | aSubClass withAllSuperclassesDo: [ :class | self withPragmasIn: class do: [ :pragma | pragma keyword = aSymbol ifTrue: [ stream nextPut: pragma ] ]. aSuperClass = class ifTrue: [ ^ stream contents ] ] ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'! allNamed: aSymbol from: aSubClass to: aSuperClass sortedByArgument: anInteger "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to argument anInteger." ^ self allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:12'! allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: aSortBlock "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to aSortBlock." ^ (self allNamed: aSymbol from: aSubClass to: aSuperClass) sort: aSortBlock.! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:55'! allNamed: aSymbol in: aClass "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol." ^ Array streamContents: [ :stream | self withPragmasIn: aClass do: [ :pragma | pragma keyword = aSymbol ifTrue: [ stream nextPut: pragma ] ] ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'! allNamed: aSymbol in: aClass sortedByArgument: anInteger "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to argument anInteger." ^ self allNamed: aSymbol in: aClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:06'! allNamed: aSymbol in: aClass sortedUsing: aSortBlock "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to aSortBlock." ^ (self allNamed: aSymbol in: aClass) sort: aSortBlock.! ! !Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 00:34'! keyword: aSymbol arguments: anArray ^ self new setKeyword: aSymbol; setArguments: anArray; yourself.! ! !Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 08:50'! withPragmasIn: aClass do: aBlock aClass selectorsAndMethodsDo: [ :selector :method | method pragmas do: aBlock ].! ! !CompiledMethod methodsFor: 'properties' stamp: 'lr 1/21/2006 13:09'! pragmas "Answer an array of the pragmas of the reciever." ^ self propertyAt: #pragmas ifAbsent: #().! ! !CompiledMethod methodsFor: 'private' stamp: 'lr 1/21/2006 13:15'! properties "Answer the property-dictionary of the reciever or nil. Avoid calling this method directly, use the property-protocol instead." ^ self literalAt: self numLiterals - 1.! ! !CompiledMethod methodsFor: 'private' stamp: 'lr 1/21/2006 13:57'! properties: aDictionary "Set the property dictionary to be aDictionary. Avoid calling this method directly, use the property-protocol instead." self literalAt: self numLiterals - 1 put: aDictionary.! ! !CompiledMethod methodsFor: 'properties' stamp: 'lr 1/21/2006 11:58'! propertyAt: aKey "Answer the property value associated with aKey." ^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ].! ! !CompiledMethod methodsFor: 'properties' stamp: 'lr 1/21/2006 12:15'! propertyAt: aKey ifAbsentPut: aBlock "Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value." ^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ].! ! !CompiledMethod methodsFor: 'properties' stamp: 'lr 1/21/2006 13:16'! propertyAt: aKey ifAbsent: aBlock "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." | properties | properties := self properties ifNil: [ ^ aBlock value ]. ^ properties at: aKey ifAbsent: aBlock.! ! !CompiledMethod methodsFor: 'properties' stamp: 'lr 1/21/2006 13:22'! propertyAt: aKey put: anObject "Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject." | properties | (properties := self properties) ifNil: [ self properties: (properties := IdentityDictionary new) ]. ^ properties at: aKey put: anObject.! ! !CompiledMethod methodsFor: 'properties' stamp: 'lr 1/21/2006 11:56'! propertyRemoveKey: aKey "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." ^ self propertyRemoveKey: aKey ifAbsent: [ self error: 'Property not found' ].! ! !CompiledMethod methodsFor: 'properties' stamp: 'lr 1/21/2006 13:23'! propertyRemoveKey: aKey ifAbsent: aBlock "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." | properties answer | properties := self properties ifNil: [ ^ aBlock value ]. answer := properties removeKey: aKey ifAbsent: aBlock. properties isEmpty ifTrue: [ self properties: nil ]. ^ answer.! ! !CompiledMethod methodsFor: 'literals' stamp: 'lr 1/20/2006 18:50'! 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 class == Array and: [ literal hasLiteralSuchThat: aBlock ]) ifTrue: [ ^ true ] ]. ^ false.! ! !CompiledMethod methodsFor: 'literals' stamp: 'lr 1/20/2006 18:49'! hasLiteralThorough: aLiteral "Answer true if any literal in this method is literal, even if embedded in array structure or within its pragmas." | 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 class == Array and: [ literal hasLiteral: aLiteral ]) ifTrue: [ ^ true ] ]. ^ false.! ! Scanner subclass: #Parser instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category pragmas' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !Parser methodsFor: 'pragmas' stamp: 'lr 1/21/2006 13:07'! addPragma: aPragma pragmas := pragmas isNil ifTrue: [ Array with: aPragma ] ifFalse: [ pragmas copyWith: aPragma ].! ! !Parser methodsFor: 'pragmas' stamp: 'lr 1/21/2006 12:24'! pragmaLiteral "Read a pragma literal." (hereType == #string or: [ hereType == #literal or: [ hereType == #number ] ]) ifTrue: [ ^ self advance ]. (here == $# and: [ tokenType == #word ]) ifTrue: [ ^ self advance ]. (here == #- and: [ tokenType == #number ]) ifTrue: [ ^ (self advance; advance) negated ]. (here = 'true' or: [ here = 'false' or: [ here = 'nil' ] ]) ifTrue: [ ^ Compiler evaluate: self advance ]. ^ self expected: 'Literal constant'.! ! !Parser methodsFor: 'pragmas' stamp: 'lr 1/21/2006 13:52'! pragmaPrimitives | primitives | primitives := pragmas select: [ :each | #( primitive: primitive:module: ) includes: each keyword ]. primitives isEmpty ifTrue: [ ^ 0 ]. primitives size = 1 ifFalse: [ ^ self notify: 'Ambigous primitives' ]. ^ primitives first message sendTo: self.! ! !Parser methodsFor: 'pragmas' stamp: 'lr 1/21/2006 12:54'! pragmaSequence "Parse a sequence of method pragmas." [ true ] whileTrue: [ (self matchToken: #<) ifFalse: [ ^ self ]. self pragmaStatement. (self matchToken: #>) ifFalse: [ ^ self expected: '>' ] ].! ! !Parser methodsFor: 'pragmas' stamp: 'lr 1/21/2006 13:27'! pragmaStatement "Read a single pragma statement. Parse all generic pragmas in the form of: and remember them, including primitives." | keyword arguments | keyword := String new. arguments := Array new. "This is a ugly hack into the compiler of the FFI package. FFI should be changed to use propre pragmas that can be parsed with the code here." (hereType == #keyword and: [ here = #apicall: or: [ here = #cdecl: ] ]) ifTrue: [ ^ self externalFunctionDeclaration ]. [ hereType == #word or: [ hereType == #keyword ] ] whileTrue: [ keyword := keyword , self advance. keyword last = $: ifTrue: [ arguments := arguments copyWith: self pragmaLiteral ] ]. keyword numArgs ~= arguments size ifTrue: [ ^ self notify: keyword , ' is an invalid pragma' ]. self addPragma: (Pragma keyword: keyword asSymbol arguments: arguments). ^ true.! ! !Parser methodsFor: 'primitives' stamp: 'lr 1/21/2006 13:49'! externalFunctionDeclaration "Parse the function declaration for a call to an external library." | descriptorClass callType retType externalName args argType module fn | descriptorClass _ Smalltalk at: #ExternalFunction ifAbsent:[nil]. descriptorClass == nil ifTrue:[^false]. callType _ descriptorClass callingConventionFor: here. callType == nil ifTrue:[^false]. "Parse return type" self advance. retType _ self externalType: descriptorClass. retType == nil ifTrue:[^self expected:'return type']. "Parse function name or index" externalName _ here. (self match: #string) ifTrue:[externalName _ externalName asSymbol] ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. (self matchToken:'(' asSymbol) ifFalse:[^self expected:'argument list']. args _ WriteStream on: Array new. [here == ')' asSymbol] whileFalse:[ argType _ self externalType: descriptorClass. argType == nil ifTrue:[^self expected:'argument']. argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]. ]. (self matchToken:')' asSymbol) ifFalse:[^self expected:')']. (self matchToken: 'module:') ifTrue:[ module _ here. (self match: #string) ifFalse:[^self expected: 'String']. module _ module asSymbol]. Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| fn _ xfn name: externalName module: module callType: callType returnType: retType argumentTypes: args contents. self allocateLiteral: fn. ]. self addPragma: (Pragma keyword: #primitive: arguments: #(120)). ^true! ! !Parser methodsFor: 'primitives' stamp: 'lr 1/21/2006 13:04'! primitive: anIntegerOrString "Create indexed primitive." ^ anIntegerOrString isInteger ifTrue: [ anIntegerOrString ] ifFalse: [ anIntegerOrString isString ifTrue: [ self primitive: anIntegerOrString module: nil ] ifFalse: [ self expected: 'Indexed primitive' ] ].! ! !Parser methodsFor: 'primitives' stamp: 'lr 1/21/2006 13:05'! primitive: aNameString module: aModuleStringOrNil "Create named primitive." (aNameString isString and: [ aModuleStringOrNil isNil or: [ aModuleStringOrNil isString ] ]) ifFalse: [ ^ self expected: 'Named primitive' ]. self allocateLiteral: (Array with: (aModuleStringOrNil isNil ifFalse: [ aModuleStringOrNil asSymbol ]) with: aNameString asSymbol with: 0 with: 0). ^ 117.! ! !Parser methodsFor: 'expression types' stamp: 'lr 1/21/2006 13:55'! method: doit context: ctxt encoder: encoderToUse " pattern [ | temporaries ] block => MethodNode." | sap blk prim temps messageComment methodNode | encoder _ encoderToUse. sap _ self pattern: doit inContext: ctxt. "sap={selector, arguments, precedence}" (sap at: 2) do: [:argNode | argNode isArg: true]. temps _ self temporariesIn: (sap at: 1).. messageComment _ currentComment. currentComment _ nil. prim := 0. doit ifFalse: [ self pragmaSequence. pragmas ifNotNil: [ prim := self pragmaPrimitives. properties := IdentityDictionary new. properties at: #pragmas put: pragmas ] ]. self statements: #() innerBlock: doit. blk _ parseNode. doit ifTrue: [blk returnLast] ifFalse: [blk returnSelfIfNoOther]. hereType == #doIt ifFalse: [^self expected: 'Nothing more']. self interactive ifTrue: [self removeUnusedTemps]. methodNode _ self newMethodNode comment: messageComment. ^ methodNode selector: (sap at: 1) arguments: (sap at: 2) precedence: (sap at: 3) temporaries: temps block: blk encoder: encoder primitive: prim properties: properties! ! !CompiledMethod methodsFor: 'private' stamp: 'lr 1/21/2006 13:57'! properties: aDictionary "Set the property dictionary to be aDictionary. Avoid calling this method directly, use the property-protocol instead." self literalAt: self numLiterals - 1 put: aDictionary. self pragmas do: [ :pragma | pragma setMethod: self ].! ! MethodProperties removeFromSystem! Parser removeSelector: #addProperty:value:! Parser removeSelector: #correctProperty:interval:! Parser removeSelector: #hasProperty:! Parser removeSelector: #primitiveDeclaration! Parser removeSelector: #properties! Parser removeSelector: #property! CompiledMethod removeSelector: #removeProperty:! CompiledMethod removeSelector: #setProperty:toValue:! CompiledMethod removeSelector: #valueOfProperty:! CompiledMethod removeSelector: #valueOfProperty:ifAbsent:! Compiler recompileAll!