--- a/Parser.st Wed May 09 11:31:50 2018 +0200
+++ b/Parser.st Wed May 09 11:49:00 2018 +0200
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -41,7 +43,8 @@
classVariableNames:'PrevClass PrevInstVarNames PrevClassVarNames
PrevClassInstVarNames LazyCompilation FoldConstants
LineNumberInfo SuppressDoItCompilation ParseErrorSignal
- AlreadyWarnedUnimplementedSelectorsPerReceiverClass'
+ AlreadyWarnedUnimplementedSelectorsPerReceiverClass
+ WarnAboutInlineObjects'
poolDictionaries:''
category:'System-Compiler'
!
@@ -813,7 +816,7 @@
|info selectorsAlready block lcSelector excludedClasses minNumArgs|
- excludedClasses := { ProtoObject . Structure . InlineObjectPrototype }.
+ excludedClasses := { ProtoObject . Structure . InlineObject prototype }.
minNumArgs := aString argumentCount.
@@ -7260,11 +7263,14 @@
].
].
- didWarnAboutSTXExtensions~~ true ifTrue:[
- didWarnAboutSTXExtensions := true.
- self
- warning:'InlineObjects are an experimental feature which is not yet supported by stc'
- position:pos1 to:tokenPosition.
+ WarnAboutInlineObjects ~~ false ifTrue:[
+ didWarnAboutSTXExtensions ~~ true ifTrue:[
+ didWarnAboutSTXExtensions := true.
+ self
+ warning:'InlineObjects are an experimental feature which is not yet supported by stc'
+ doNotShowAgainAction:[ WarnAboutInlineObjects := false ]
+ position:pos1 to:tokenPosition.
+ ].
].
self nextToken.
^ ConstantNode type:#Object value:(self literalInlineObjectFor:namesAndValues).
@@ -7434,31 +7440,46 @@
!
literalInlineObjectFor:namesAndValues
- |class instance names values inlineObjectsAreReadonly|
-
- inlineObjectsAreReadonly := true.
-
- names := namesAndValues collect:[:each | each key].
+ |existingClass class instance names values inlineObjectsAreReadonly protoClass|
+
+ inlineObjectsAreReadonly := parserFlags arraysAreImmutable.
+
+ names := namesAndValues collect:[:each | each key asSymbol].
values := namesAndValues collect:[:each | each value].
- class := InlineObjectClassDescription new.
- class setSuperclass: InlineObject.
- class setInstanceVariableString:(names asStringWith:Character space).
- class instSize: names size.
-
- names keysAndValuesDo:[:idx :instVarName |
- |m|
-
- idx <= InlineObjectPrototype instSize ifTrue:[
- class basicAddSelector:(instVarName asSymbol) withMethod:(m := InlineObjectPrototype compiledMethodAt:('i%1' bindWith:idx) asSymbol).
- inlineObjectsAreReadonly ifFalse:[
- class basicAddSelector:(instVarName asMutator) withMethod:(m := InlineObjectPrototype compiledMethodAt:('i%1:' bindWith:idx) asSymbol).
- ].
- ] ifFalse:[
- Class withoutUpdatingChangesDo:[
- Compiler compile:('%1 ^%1' bindWith:instVarName) forClass:class.
+ existingClass := InlineObjectClassDescription subclasses
+ detect:[:cls | cls instVarNames = names]
+ ifNone:[nil].
+ existingClass notNil ifTrue:[
+ class := existingClass.
+ ] ifFalse:[
+ class := InlineObjectClassDescription new.
+ class setSuperclass: InlineObject.
+ class setInstVarNames:names.
+ class instSize: names size.
+
+ protoClass := InlineObject prototype.
+ names keysAndValuesDo:[:idx :instVarName |
+ |protoMethod|
+
+ idx <= protoClass instSize ifTrue:[
+ protoMethod := protoClass compiledMethodAt:('i%1' bindWith:idx) asSymbol.
+ class basicAddSelector:instVarName withMethod:protoMethod.
+ "/ fix
+ protoMethod mclass:protoClass.
+
inlineObjectsAreReadonly ifFalse:[
- Compiler compile:('%1:something %1 := something' bindWith:instVarName) forClass:class.
+ protoMethod := protoClass compiledMethodAt:('i%1:' bindWith:idx) asSymbol.
+ class basicAddSelector:(instVarName asMutator) withMethod:protoMethod.
+ "/ fix
+ protoMethod mclass:protoClass.
+ ].
+ ] ifFalse:[
+ Class withoutUpdatingChangesDo:[
+ Compiler compile:('%1 ^%1' bindWith:instVarName) forClass:class.
+ inlineObjectsAreReadonly ifFalse:[
+ Compiler compile:('%1:something %1 := something' bindWith:instVarName) forClass:class.
+ ].
].
].
].
@@ -8936,7 +8957,7 @@
|varIndex aClass searchBlock args vars
tokenSymbol space classVarIndex holder node
- checkSharedPoolAction|
+ checkSharedPoolAction checkSharedPoolByNameAction|
"is it a block-arg or block-var ?"
searchBlock := currentBlock.
@@ -8998,6 +9019,15 @@
].
checkSharedPoolAction :=
+ [:sharedPool |
+ (sharedPool includesKey:varName) ifTrue:[
+ parseForCode ifFalse:[self rememberGlobalUsed:(sharedPool name , ':' , varName)].
+ ^ (VariableNode type:#PoolVariable class:sharedPool name:varName)
+ startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ ].
+ ].
+
+ checkSharedPoolByNameAction :=
[:eachPoolName |
|sharedPool|
@@ -9006,11 +9036,7 @@
Transcript showCR:'Parser: No such pool: ' , eachPoolName.
"/ self warning:('No such pool: ' , eachPoolName).
] ifFalse:[
- (sharedPool includesKey:varName) ifTrue:[
- parseForCode ifFalse:[self rememberGlobalUsed:(sharedPool name , ':' , varName)].
- ^ (VariableNode type:#PoolVariable class:sharedPool name:varName)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
- ].
+ checkSharedPoolAction value:sharedPool
].
].
@@ -9114,12 +9140,13 @@
].
" is it a pool-variable ?"
- classToCompileFor theNonMetaclass realSharedPoolNames do:checkSharedPoolAction.
+ "/ classToCompileFor theNonMetaclass realSharedPoolNames do:checkSharedPoolByNameAction.
+ classToCompileFor theNonMetaclass sharedPools do:checkSharedPoolAction.
].
(self isDoIt) ifTrue:[
moreSharedPools notNil ifTrue:[
- moreSharedPools do:checkSharedPoolAction.
+ moreSharedPools do:checkSharedPoolByNameAction.
].
"is it a thread local variable ?"
(Processor activeProcess environmentIncludesKey:varName asSymbol) ifTrue:[
@@ -12564,7 +12591,8 @@
^ aTypeSymbol , 'Pointer'
].
- (masterParser ? self) ignorableParseError:'missing pointer type mapping for type: ', aTypeSymbol allBold.
+ "/ (masterParser ? self) ignorableParseError:'missing pointer type mapping for type: ', aTypeSymbol allBold.
+ (masterParser ? self) warning:'missing pointer type mapping for type: ', aTypeSymbol allBold.
^ #pointer "/ aTypeSymbol asSymbol
"Created: / 01-08-2006 / 15:33:53 / cg"