The Trunk: Compiler-mt.437.mcz

Marcel Taeumel uploaded a new version of Compiler to project The Trunk:
http://source.squeak.org/trunk/Compiler-mt.437.mcz

==================== Summary ====================

Name: Compiler-mt.437
Author: mt
Time: 13 June 2020, 11:01:44.448351 am
UUID: ca2e1da8-da26-a840-ae3e-1822ce8ba67d
Ancestors: Compiler-mt.436

Speed-up method-based hook for custom pragma-parsing methods. Like in ShoutCore-mt.79

=============== Diff against Compiler-mt.435 ===============

Item was removed:
- ----- Method: Parser>>externalFunctionDeclaration (in category 'primitives') -----
- externalFunctionDeclaration
- "Parse the function declaration for a call to an external library."
- | descriptorClass callType modifier retType externalName args argType module fn |
- descriptorClass := cue environment
- valueOf: #ExternalFunction
- ifAbsent: [^ false].
- callType := descriptorClass callingConventionFor: here.
- callType == nil ifTrue:[^false].
- [modifier := descriptorClass callingConventionModifierFor: token.
- modifier notNil] whileTrue:
- [self advance.
- callType := callType bitOr: modifier].
- "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 match: #leftParenthesis) ifFalse:[^self expected:'argument list'].
- args := WriteStream on: Array new.
- [self match: #rightParenthesis] whileFalse:[
- argType := self externalType: descriptorClass.
- argType == nil ifTrue:[^self expected:'argument'].
- argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]].
- (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.
- encoder litIndex: fn.
- fn beWritableObject. "Undo the read-only setting in litIndex:"].
- (self matchToken: 'error:')
- ifTrue:
- [| errorCodeVariable |
- errorCodeVariable := here.
- (hereType == #string
- or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)'].
- self advance.
- self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)).
- fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]]
- ifFalse:
- [self addPragma: (Pragma keyword: #primitive: arguments: #(120))].
- ^true!

Item was removed:
- ----- Method: Parser>>externalType: (in category 'primitives') -----
- externalType: descriptorClass
- "Parse and return an external type"
- | xType typeName |
- typeName := here. "Note that pointer token is not yet parsed!!"
- (xType := descriptorClass typeNamed: typeName)
- ifNil: [
- "Raise an error if user is there"
- self interactive ifTrue: [^nil].
- "otherwise go over it silently -- use an unknown struct type"
- xType := descriptorClass newTypeNamed: here].
- self advance.
- ^ (self matchToken: #*)
- ifTrue:[xType asPointerType]
- ifFalse:[(self matchToken: #**)
- ifTrue: [xType asPointerToPointerType]
- ifFalse: [xType]]!

Item was changed:
  ----- Method: Parser>>pragmaStatement (in category 'pragmas') -----
  pragmaStatement
+ "Read a single pragma statement. Dispatch to the first available pragma parser using the current token as a simple getter to be called on self. If no pragma parser can be found, parse it as usual in the keywords form.
- "Read a single pragma statement. Parse all generic pragmas in the form of: <key1: val1 key2: val2 ...> and remember them, including primitives."
 
+ Note that custom pragma parsers need to fulfill two requirements:
+ (1) method selector must match the current token as simple getter,
+ e.g., <apicall: ...> matches #apicall or <primitive: ...> matches #primitive
+ (2) method must declare <pragmaParser> to be called.
+ This is for the protection of the parser's (message) namespace."
+
+ | parserSelector |
- | selector arguments words index keyword |
  (hereType = #keyword or: [ hereType = #word or: [ hereType = #binary ] ])
  ifFalse: [  ^ self expected: 'pragma declaration' ].
 
+ (here last == $:
+ and: [(parserSelector := Symbol lookup: here allButLast) notNil])
+ ifFalse: ["Quick exit to not break one-word pragmas such as <primitive> and <foobar>; also avoid interning new symbols for made-up pragmas such as for <my: 1 new: 2 pragma: 3> not interning #my."
+ ^ self pragmaStatementKeywords].
- " 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. "
- (here = #apicall: or: [ here = #cdecl: ])
- ifTrue: [ ^ self externalFunctionDeclaration ].
 
+ self class methodDict
+ at: parserSelector
+ ifPresent: [:parserMethod |
+ (parserMethod pragmas
+ anySatisfy: [:pragma | pragma keyword == #pragmaParser])
+ ifTrue: [^ self executeMethod: parserMethod]].
+
+ ^ self pragmaStatementKeywords!
- selector := String new.
- arguments := OrderedCollection new.
- words := OrderedCollection new.
- [ hereType = #keyword or: [ (hereType = #word or: [ hereType = #binary ]) and: [ selector isEmpty ] ] ] whileTrue: [
- index := self startOfNextToken + requestorOffset.
- selector := selector , self advance.
- words add: (index to: self endOfLastToken + requestorOffset).
- (selector last = $: or: [ selector first isLetter not ])
- ifTrue: [ arguments add: (self pragmaLiteral: selector) ] ].
- selector numArgs ~= arguments size
- ifTrue: [ ^ self expected: 'pragma argument' ].
- (Symbol hasInterned: selector
- ifTrue: [ :value | keyword := value])
- ifFalse: [
- keyword := self
- correctSelector: selector wordIntervals: words
- exprInterval: (words first first to: words last last)
- ifAbort: [ ^ self fail ] ].
- self addPragma: (Pragma keyword: keyword arguments: arguments asArray).
- ^ true!

Item was added:
+ ----- Method: Parser>>pragmaStatementKeywords (in category 'pragmas') -----
+ pragmaStatementKeywords
+ "Read a single pragma statement. Parse all generic pragmas in the form of: <key1: val1 key2: val2 ...> and remember them, including primitives."
+
+ | selector arguments words index keyword |
+ selector := String new.
+ arguments := OrderedCollection new.
+ words := OrderedCollection new.
+ [ hereType = #keyword or: [ (hereType = #word or: [ hereType = #binary ]) and: [ selector isEmpty ] ] ] whileTrue: [
+ index := self startOfNextToken + requestorOffset.
+ selector := selector , self advance.
+ words add: (index to: self endOfLastToken + requestorOffset).
+ (selector last = $: or: [ selector first isLetter not ])
+ ifTrue: [ arguments add: (self pragmaLiteral: selector) ] ].
+ selector numArgs ~= arguments size
+ ifTrue: [ ^ self expected: 'pragma argument' ].
+ (Symbol hasInterned: selector
+ ifTrue: [ :value | keyword := value])
+ ifFalse: [
+ keyword := self
+ correctSelector: selector wordIntervals: words
+ exprInterval: (words first first to: words last last)
+ ifAbort: [ ^ self fail ] ].
+ self addPragma: (Pragma keyword: keyword arguments: arguments asArray).
+ ^ true!

Item was added:
+ ----- Method: Parser>>primitive (in category 'primitives') -----
+ primitive
+ "Pragmas that encode primitive calls are parsed as normal keyword pragmas. This hook exists so that packages do not break primitive-pragma parsing by accident. Instead, this method needs to be replaced intentionally.
+
+ Note that primitive pragmas are special because they will be called back from the parser into the parser. See #pragmaPrimitives.
+
+ Examples:
+ <primitive: 42>
+ <primitive: 'primitiveDirectoryCreate' module: 'FilePlugin'>
+ <primitive: 'primitiveRegisterExternalFill' module: 'B2DPlugin' error: errorCode>"
+
+ <pragmaParser>
+ ^ self pragmaStatementKeywords!