--- a/.cvsignore Sat Aug 08 22:49:53 2020 +0100
+++ b/.cvsignore Tue Aug 25 12:20:06 2020 +0100
@@ -24,3 +24,5 @@
objtcc
objmingw
*.@@@
+*.res
+*.RES
--- a/.hgtags Sat Aug 08 22:49:53 2020 +0100
+++ b/.hgtags Tue Aug 25 12:20:06 2020 +0100
@@ -19,10 +19,16 @@
4d39e6a917778051f0a616fd8e0d9ebd06771160 rel3_6_4
4dde25bad190cdbaecad8774228f753aa196cc93 expecco_1_6_0
4dde25bad190cdbaecad8774228f753aa196cc93 expecco_1_6_0rc5
+570a72d914a3ef32213ced300773ca38b88b6d5d expecco_18_2_0
+570a72d914a3ef32213ced300773ca38b88b6d5d expecco_18_2_1
5740ebfeba2c92e8ef6ffe26bf08f510629ec200 expecco_1_7_0rc1
588ba3e53fd2e7798202fbb40b760aa4fa0e9021 expecco_2_2_0
588ba3e53fd2e7798202fbb40b760aa4fa0e9021 expecco_2_2_5
+60fcb6d008cf558d8ded73858f67b5b365b0720a expecco_19_2_0
+60fcb6d008cf558d8ded73858f67b5b365b0720a expecco_19_2_0_43
+60fcb6d008cf558d8ded73858f67b5b365b0720a expecco_19_2_0_44
6880b3100214c3729ab2021411998af9b858e3a7 rel5_4_6
+6c4d3c5a6f5d50637b534194f0769b3259edcd60 expeccoALM_1_12
742d1fa234fbde166d0e0ca7ad2b0932167cadd4 rel3_6_1
7583adfbb5c1793e5649a6dfb7048aa2010da740 expecco_1_9_1_iX
79147d4ab679eee258fdec62ee194feb11b637a8 expecco_2_6_0
@@ -33,6 +39,8 @@
7af603c810b7f244c59ad454d0b2d7cc54717d49 expecco_1_7_1rc2
7af603c810b7f244c59ad454d0b2d7cc54717d49 expecco_1_7_1rc3
7af603c810b7f244c59ad454d0b2d7cc54717d49 expecco_1_7_1rc4
+829203f940a3e3a7caf8b792cbb34d4296fd5ad2 expecco_18_1_0_6496
+829203f940a3e3a7caf8b792cbb34d4296fd5ad2 expecco_18_1_0_6496_v2
83a4022c2830ed53f5455b17ea4c14d3013c9950 stx_6_2_2
84144a6380fbc0c315befd8c486257f629fcbe42 expecco_2_5_1
8460eb468d036f47d36bc5cce0d871376c9f2eac expecco_1_3_4
@@ -43,6 +51,7 @@
891259e2dbe454fe006d6052c58862decd998613 rel5_1_3
891259e2dbe454fe006d6052c58862decd998613 stx_513
89d05ce2689128f452eaf72f1f9f985281442442 expeccoNET_1_5_1rc1
+8f916f02f47043035943565d7c4cda2909058a78 expecco_19_2_1
9a0b2c91b8e2526201618d37f60d806d08cd989a expecco_2_7_0
9a0b2c91b8e2526201618d37f60d806d08cd989a expecco_2_7_0_49
9a0b2c91b8e2526201618d37f60d806d08cd989a expecco_2_7_5
@@ -60,6 +69,8 @@
ab7ea489f73140eeb729f67f80f58cd3d6937a4a expecco_1_7_0b1
ab7ea489f73140eeb729f67f80f58cd3d6937a4a expecco_1_7_0b2
ab7ea489f73140eeb729f67f80f58cd3d6937a4a expecco_1_7_0b3
+bd0b9dbc30c29e5fcaacd62571830a09505c0b84 expecco_19_1_0
+bd0b9dbc30c29e5fcaacd62571830a09505c0b84 expecco_19_1_0_final1
be36d8a09396d3fc628a8686a218e7100fe59a0b expecco_2_6_1
be36d8a09396d3fc628a8686a218e7100fe59a0b expecco_2_6_2
cb311d08a486aac5d2a58df4d08e1021dec39257 expeccoNET_1_4_0rc1
@@ -71,6 +82,8 @@
cf71c91f5b7e3709e6050ba3130bd1d4dede134a expecco_2_7_1
d628e2ef289e352e625d8a27c419fabb5b3f67c8 expecco_1_7_2rc1
d69fc5970cd7ba0b81183f893a6c3fec2156fb62 rel5_1_4
+d756ed6a7120e5666d2c7c00eb937c08061ccada expecco_18_1_0
+d756ed6a7120e5666d2c7c00eb937c08061ccada expecco_18_1_0wa1
dbb46a901a8e7fa85925685db9a9b87839923247 expecco_2_9_0
dbb46a901a8e7fa85925685db9a9b87839923247 expecco_2_9_0_win75_lx36
dbb46a901a8e7fa85925685db9a9b87839923247 expecco_2_9_1
@@ -81,6 +94,10 @@
e86cf3691f8c6a0a70b938854c0faeffa22c4662 expecco_2_11_1
e94fe6b650ad9ee00d62c1d4f3030e3883c6c874 expeccoNET_1_6_8_0
ecc7580a2002e64a55098f7f973d8d041b6e0be1 rel5_2_8
+f30fb0d78836bbb87e2cee12ae2794320cc25277 expecco_20_1_0
+f30fb0d78836bbb87e2cee12ae2794320cc25277 expecco_20_1_0_final
+f30fb0d78836bbb87e2cee12ae2794320cc25277 expecco_ALM_1_16_0
+f47c5550506884fb3166a03cb93d8069250577d9 expeccoALM_1_13
f78c873edd1f7000fa723fea88c670bf5ad5722c expeccoNET_1_6_0_0
f91f6a0a56d5aa7f6d57984582b865873bd68922 rel4_1_7
f91f6a0a56d5aa7f6d57984582b865873bd68922 release
--- a/AbstractSyntaxHighlighter.st Sat Aug 08 22:49:53 2020 +0100
+++ b/AbstractSyntaxHighlighter.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2006 by eXept Software AG
COPYRIGHT (c) 2016-2017 Jan Vrany
@@ -81,26 +83,12 @@
"format (recolor) an expression in a given class.
Return the text containing font changes and color information."
- |parser tree text|
+ |parser|
aString isNil ifTrue:[^ nil].
parser := self for:(ReadStream on:aString string) in:aClass.
- parser ignoreErrors:true.
- parser ignoreWarnings:true.
- parser sourceText:(text := aString string asText).
- "/ use an array here - this can be changed much faster using #at:put:
- text emphasisCollection:(Array new:aString size).
-
- parser nextToken.
- tree := parser expression.
- "/ now, convert the emphasis-array to a runArray
- text emphasisCollection:(text emphasis asRunArray).
-
- tree == #Error ifTrue:[
- ^ self colorize:text forErrorAtPosition:parser sourceStream position withOriginal:aString.
- ].
- ^ text
+ ^ parser formatExpression:aString in:aClass
"
self
@@ -167,52 +155,9 @@
"format (recolor) a method in a given class.
Return the text containing font changes and color information."
- |highlighter tree newText|
-
aString isNil ifTrue:[^ nil].
-
- Error handle:[:ex |
- "/ Transcript showCR:ex description.
- self breakPoint:#cg.
-
- (ParseError handles:ex) ifFalse:[
- ex creator isHandled ifTrue:[
- "/ Transcript showCR:'handled' .
- ex reject.
- ].
- "Parse error may happen when re-formatting incomplete code while editing"
-"/ ('SyntaxHighlighter [info]: error during highlight: ' , ex description) infoPrintCR.
- "/ ex suspendedContext fullPrintAll.
- ].
- highlighter notNil ifTrue:[
- ^ self colorize:(newText ? aString) forErrorAtPosition:highlighter sourceStream position withOriginal:aString
- ].
- ^ aString
- ] do:[
- |sourceString|
-
- sourceString := aString string.
- newText := sourceString asUnicode16String asText.
- "/ use an array here (instead of the RunArray) - this can be changed much faster using #at:put:
- newText emphasisCollection:(Array new:sourceString size).
-
- highlighter := self for:(ReadStream on:aString string) in:aClass.
- highlighter method:methodOrNil.
- preferencesOrNil notNil ifTrue:[highlighter preferences:preferencesOrNil].
- "/ highlighter ignoreErrors:true.
- highlighter ignoreWarnings:true.
- highlighter sourceText:newText.
-
- tree := highlighter parseMethod.
- newText := highlighter sourceText. "/ might have changed identity
- "/ now, convert the emphasis-array to a runArray
- newText emphasisCollection:(newText emphasis asRunArray).
-
- tree == #Error ifTrue:[
- ^ self colorize:newText forErrorAtPosition:highlighter sourceStream position withOriginal:aString.
- ].
- ^ newText
- ]
+ ^ (self for:aString in:aClass)
+ formatMethod:methodOrNil source:aString in:aClass using:preferencesOrNil
"
self
@@ -226,6 +171,7 @@
"Created: / 28-04-2010 / 13:01:42 / cg"
"Modified: / 05-07-2011 / 11:22:20 / cg"
+ "Modified: / 22-12-2018 / 09:01:10 / Claus Gittinger"
!
formatMethodSource:aString in:aClass
@@ -408,14 +354,29 @@
These are optionally shown with another color (red)"
^ #(
- error error:
- raise raiseRequest:
- raiseErrorString: raiseRequestErrorString:
- raiseWith: raiseRequestWith:
- raiseWith:errorString: raiseRequestWith:errorString:
- subclassResponsibility
- obsoleteMethodWarning obsoleteMethodWarning:
+ error error: error:mayProceed: proceedableError:
+ raise raiseRequest:
+ raiseErrorString: raiseRequestErrorString:
+ raiseWith: raiseRequestWith:
+ raiseWith:errorString: raiseRequestWith:errorString:
+ subclassResponsibility
+ obsoleteMethodWarning obsoleteMethodWarning:
+
+ shouldNeverBeReached shouldNeverBeSent
+ shouldNotImplement shouldImplement
+ subscriptBoundsError typeCheckError
+
+ elementBoundsError errorInvalidFormat
+ elementNotCharacter elementNotInteger
+ errorKeyNotFound: errorNotFound errorNotFound:
+ indexNotInteger indexNotInteger:
+ indexNotIntegerOrOutOfBounds:
+ mustBeRectangle mustBeString notIndexed
+ notYetImplemented primitiveFailed
+
)
+
+ "Modified: / 28-05-2018 / 15:02:43 / Claus Gittinger"
!
isControlFlowSelector:aSelector
@@ -592,33 +553,142 @@
"Modified: / 28-04-2010 / 13:22:27 / cg"
! !
+!AbstractSyntaxHighlighter methodsFor:'api highlighting'!
+
+formatExpression:aString in:aClass
+ "format (recolor) an expression in a given class.
+ Return the text containing font changes and color information."
+
+ |tree text|
+
+ aString isNil ifTrue:[^ nil].
+ classToCompileFor := aClass.
+
+ self ignoreErrors:true.
+ self ignoreWarnings:true.
+ self sourceText:(text := aString string asText).
+ "/ use an array here - this can be changed much faster using #at:put:
+ text emphasisCollection:(Array new:aString size).
+
+ self nextToken.
+ tree := self expression.
+ tree notNil ifTrue:[
+ "/ now, convert the emphasis-array to a runArray
+ text emphasisCollection:(text emphasis asRunArray).
+
+ tree == #Error ifTrue:[
+ ^ self class colorize:text forErrorAtPosition:(self sourceStream position) withOriginal:aString.
+ ].
+ ].
+ ^ text
+
+ "
+ self
+ formatExpression:'(1 + 2) max:5'
+ in:UndefinedObject
+ "
+
+ "Created: / 09-04-1998 / 16:57:16 / cg"
+ "Modified: / 09-05-2020 / 17:00:01 / cg"
+!
+
+formatMethod:methodOrNil source:aString in:aClass using:preferencesOrNil
+ "format (recolor) a method in a given class.
+ Return the text containing font changes and color information."
+
+ |tree newText|
+
+ aString isNil ifTrue:[^ nil].
+ classToCompileFor := aClass.
+
+ Error handle:[:ex |
+ "/ Transcript showCR:ex description.
+ "/ self breakPoint:#cg.
+
+ (ParseError handles:ex) ifFalse:[
+ ex creator isHandled ifTrue:[
+ "/ Transcript showCR:'handled' .
+ ex reject.
+ ].
+ "Parse error may happen when re-formatting incomplete code while editing"
+"/ ('SyntaxHighlighter [info]: error during highlight: ' , ex description) infoPrintCR.
+ "/ ex suspendedContext fullPrintAll.
+ ].
+ ^ self class colorize:(newText ? aString) forErrorAtPosition:(self sourceStream position) withOriginal:aString
+ ] do:[
+ |sourceString|
+
+ sourceString := aString string.
+ source := sourceString readStream.
+ newText := sourceString asUnicode16String asText.
+ "/ use an array here (instead of the RunArray) - this can be changed much faster using #at:put:
+ newText emphasisCollection:(Array new:sourceString size).
+
+ self method:methodOrNil.
+ preferencesOrNil notNil ifTrue:[self preferences:preferencesOrNil].
+ "/ self ignoreErrors:true.
+ self ignoreWarnings:true.
+ self sourceText:newText.
+
+ tree := self parseMethod.
+ tree notNil ifTrue:[
+ newText := self sourceText. "/ might have changed identity
+ "/ now, convert the emphasis-array to a runArray
+ newText emphasisCollection:(newText emphasis asRunArray).
+
+ tree == #Error ifTrue:[
+ ^ self class colorize:newText forErrorAtPosition:source position withOriginal:aString.
+ ].
+ self postProcessTree:tree forText:newText
+ ].
+ ^ newText
+ ]
+
+ "
+ self
+ formatMethod:'foo
+ ^ self bar:''hello''.
+
+ ' , (Character doubleQuote asString) , 'some comment' , (Character doubleQuote asString) , '
+'
+ in:UndefinedObject
+ "
+
+ "Created: / 28-04-2010 / 13:01:42 / cg"
+ "Modified: / 22-12-2018 / 09:01:10 / Claus Gittinger"
+ "Modified: / 09-05-2020 / 16:29:27 / cg"
+!
+
+formatMethodSource:aString in:aClass using:preferencesOrNil
+ "format (recolor) a method in a given class.
+ Return the text containing font changes and color information."
+
+ ^ self formatMethod:nil source:aString in:aClass using:preferencesOrNil
+
+ "Created: / 09-05-2020 / 16:24:32 / cg"
+! !
+
!AbstractSyntaxHighlighter methodsFor:'error handling'!
parseError:aMessage position:position to:endPos
"/ Transcript showCR:aMessage.
super parseError:aMessage position:position to:endPos.
- self
- markFrom:position to:endPos
- withEmphasis:nil color:UserPreferences current errorColor
+ self markErrorFrom:position to:endPos
!
showErrorMessage:aMessage position:pos
"/ Transcript showCR:aMessage.
super showErrorMessage:aMessage position:pos.
- self
- markFrom:pos to:nil
- withEmphasis:nil color:UserPreferences current errorColor
+ self markErrorFrom:pos to:nil "/ to the end
!
syntaxError:aMessage position:position to:endPos
"/ Transcript showCR:aMessage.
super syntaxError:aMessage position:position to:endPos.
- self
- markFrom:position to:endPos
- withEmphasis:nil color:UserPreferences current errorColor
+ self markErrorFrom:position to:endPos
!
warning:msg position:pos1 to:pos2
@@ -719,6 +789,12 @@
"Modified: / 21-10-2017 / 14:15:48 / cg"
!
+markErrorFrom:pos1 to:pos2
+ self
+ markFrom:pos1 to:pos2
+ withEmphasis:nil color:UserPreferences current errorColor
+!
+
markFrom:pos1 length:len withEmphasis:fontEmp color:clrIn
self markFrom:pos1 to:pos1+len-1 withEmphasis:fontEmp color:clrIn
@@ -773,6 +849,14 @@
self markVariable:v from:pos to:endPos assigned:false
"Modified: / 30-11-2010 / 14:44:28 / cg"
+!
+
+postProcessTree:tree forText:text
+ "allows for additional checks to be done on the tree
+ (checking arguments to a call-node in expecco, for example)"
+
+ "/ intentionaly left blank here.
+
! !
!AbstractSyntaxHighlighter class methodsFor:'documentation'!
--- a/AssignmentNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/AssignmentNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -155,7 +155,6 @@
"Modified: / 27-07-2011 / 13:50:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
-
!AssignmentNode methodsFor:'code generation'!
checkIncDecOn:aStream
@@ -281,6 +280,11 @@
expression allNodesDo:aBlock
!
+childrenDo:aBlock
+ aBlock value:variable.
+ aBlock value:expression.
+!
+
messagesDo:aBlock
"evaluate aBlock for each message-node here and in subnodes"
@@ -293,6 +297,15 @@
^ anEnumerator doAssignment:self variable:variable value:expression
"Modified: 19.6.1997 / 16:37:50 / cg"
+!
+
+variableNodesDo:aBlock
+ "evaluate aBlock for each variable-node in this node and subnodes"
+
+ aBlock value:variable.
+ expression variableNodesDo:aBlock.
+
+ "Created: / 27-03-2020 / 12:45:37 / Stefan Vogel"
! !
!AssignmentNode methodsFor:'enumeration'!
--- a/BlockNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/BlockNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -389,7 +389,7 @@
] ifFalse:[
statements isConstant ifTrue:[
val := statements expression value.
- self numArgs == 0 ifTrue:[
+ self argumentCount == 0 ifTrue:[
val == 0 ifTrue:[
aStream nextPut:#mk0Block.
^ true.
@@ -722,6 +722,22 @@
!BlockNode methodsFor:'enumerating'!
+allMessageSelectorsDo:aBlock
+ "evaluate aBlock for each message-selector sent by this statement and all followup statements"
+
+ statements notEmptyOrNil ifTrue:[
+ statements allMessageSelectorsDo:aBlock
+ ]
+!
+
+allMessagesDo:aBlock
+ "evaluate aBlock for each message-node sent by this statement and all followup statements"
+
+ statements notEmptyOrNil ifTrue:[
+ statements allMessagesDo:aBlock
+ ].
+!
+
allSubBlocksDo:aBlock
"recursively enumerate all of my subblocks"
@@ -735,6 +751,20 @@
"Created: 2.7.1997 / 10:51:59 / cg"
!
+messageSelectorsDo:aBlock
+ "evaluate aBlock for each message-selector sent by this statement and all followup statements"
+
+ statements allMessageSelectorsDo:aBlock
+!
+
+messagesDo:aBlock
+ "evaluate aBlock for each message-node sent by this statement and all followup statements"
+
+ statements notEmptyOrNil ifTrue:[
+ statements allMessagesDo:aBlock
+ ]
+!
+
nodeDo:anEnumerator
"helper for parse tree walking"
@@ -1127,6 +1157,8 @@
!
numArgs
+ <resource: #obsolete>
+
"return the number of arguments the block represented by myself
expects for evaluation.
Please use argumentCount, which is ANSI"
@@ -1195,7 +1227,7 @@
isBlockWithArgumentCount:numArgsExpected
"a kludge, to have blocknodes mimic blocks"
- ^ self numArgs == numArgsExpected
+ ^ self argumentCount == numArgsExpected
"Created: / 11-07-2017 / 18:28:59 / cg"
!
@@ -1265,6 +1297,10 @@
"stub code automatically generated - please change if required"
^ aVisitor visitBlockNode:self
+!
+
+childrenDo:aBlock
+ self statements:statements do:aBlock
! !
!BlockNode class methodsFor:'documentation'!
--- a/Breakpoint.st Sat Aug 08 22:49:53 2020 +0100
+++ b/Breakpoint.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2006 by eXept Software AG
All Rights Reserved
@@ -40,8 +42,11 @@
"
statement breakpoint support.
Instances of me are placed into a (bytecode-) compiled method's
- literal array and are sent messages dynamically when a statement
+ literal array and are sent #break messages when a statement
with a breakpoint is about to be executed.
+ The actual control is via the breakpoint's description,
+ which contains further constraints about when the breakpoint should stop and enter the debugger
+ (for example: constraints on the reciever, the thread, the count, etc.)
"
! !
@@ -100,8 +105,12 @@
line := lineArg.
!
-method:something
- method := something.
+method
+ ^ method
+!
+
+method:aMethod
+ method := aMethod.
!
position
@@ -122,6 +131,125 @@
"Created: / 02-08-2012 / 09:26:27 / cg"
! !
+!Breakpoint methodsFor:'hitting'!
+
+break
+ "invoked by the breakPoint's code (see BreakPointNode),
+ which is compiled into the code as:
+ pushLit <theBreakpoint>
+ send0 #break
+ "
+
+ <resource: #skipInDebuggersWalkBack>
+
+ |sender message|
+
+ description isEnabled ifFalse:[^ self].
+
+ sender := thisContext sender.
+ (description shouldBreakIn:sender) ifTrue:[
+ message := self breakPointMessageForContext:sender.
+ "/ to disable this breakpoint:
+ "/ description disable.
+
+ BreakPointInterrupt basicNew
+ raiseRequestWith:self
+ errorString:message
+ "/ not in sender, because otherwise the debugger won't
+ "/ detect the break on the stack
+ "/ in:sender.
+ ].
+ (description shouldTraceIn:sender) ifTrue:[
+ sender method numArgs == 0 ifTrue:[
+ Transcript showCR:('%1 Trace: %2 [%3]'
+ bindWith:Timestamp now
+ with:sender methodPrintString
+ with:self line)
+ ] ifFalse:[
+ Transcript showCR:('%1 Trace: %2 [%3] args: %4'
+ bindWith:Timestamp now
+ with:sender methodPrintString
+ with:self line
+ with:sender argsDisplayStringShort)
+ ].
+ ].
+
+ "Created: / 15-06-2011 / 12:48:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 11-07-2011 / 18:17:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 21-10-2017 / 15:24:35 / cg"
+ "Modified: / 02-07-2019 / 23:49:17 / Claus Gittinger"
+!
+
+breakPointMessageForContext:sender
+ |mthd where lineNr message
+ source sourceLines sourceLine prevLine nextLine|
+
+ message := 'Breakpoint encountered at line %1 in %2'.
+ where := '?'.
+
+ mthd := method.
+ mthd notNil ifTrue:[
+ mthd mclass isNil ifTrue:[
+ mthd := sender method.
+ ].
+ where := mthd whoString.
+
+ (lineNr := self line) notNil ifTrue:[
+ (source := mthd source) notNil ifTrue:[
+ sourceLines := source asStringCollection.
+ sourceLine := sourceLines at:lineNr ifAbsent:[nil].
+ sourceLine notNil ifTrue:[
+ sourceLine := (sourceLine "withoutLeadingSeparators" contractAtEndTo:60) allItalic withColor:Color darkRed.
+ message := 'Breakpoint encountered at line %1 in %2\near:\%3'.
+ lineNr > 1 ifTrue:[
+ prevLine := sourceLines at:(lineNr-1) ifAbsent:[nil].
+ prevLine notEmptyOrNil ifTrue:[
+ "/ prevLine := prevLine withoutLeadingSeparators.
+ prevLine notEmpty ifTrue:[
+ prevLine := (prevLine contractAtEndTo:60) allItalic.
+ lineNr > 2 ifTrue:[
+ prevLine := '...', Character cr , prevLine.
+ ].
+ ] ifFalse:[
+ prevLine := '...'.
+ ].
+ prevLine := prevLine allGray.
+ message := 'Breakpoint encountered at line %1 in %2\near:\%4\%3'.
+ ].
+ ].
+ lineNr < (sourceLines size) ifTrue:[
+ nextLine := sourceLines at:(lineNr+1) ifAbsent:[nil].
+ nextLine notEmptyOrNil ifTrue:[
+ "/ nextLine := nextLine withoutLeadingSeparators.
+ nextLine notEmpty ifTrue:[
+ nextLine := (nextLine contractAtEndTo:60) allItalic.
+ lineNr < (sourceLines size - 1) ifTrue:[
+ nextLine := nextLine , Character cr , '...'.
+ ].
+ ] ifFalse:[
+ nextLine := '...'.
+ ].
+ nextLine := nextLine allGray.
+
+ prevLine notNil ifTrue:[
+ message := 'Breakpoint encountered at line %1 in %2\near:\%4\%3\%5'.
+ ] ifFalse:[
+ message := 'Breakpoint encountered at line %1 in %2\near:\%3\%5'.
+ ].
+ ].
+ ].
+ ].
+ ].
+ ].
+ ].
+ ^ (message withCRs
+ bindWith:self line
+ with:where
+ with:sourceLine
+ with:prevLine
+ with:nextLine)
+! !
+
!Breakpoint methodsFor:'initialization'!
initialize
@@ -140,31 +268,60 @@
!Breakpoint methodsFor:'printing & storing'!
+inspectorValueStringInListFor:anInspector
+ "returns a string to be shown in the inspector's list"
+
+ ^ self printString
+
+ "Created: / 29-05-2019 / 15:14:52 / Claus Gittinger"
+!
+
printBreakpointNrInDebuggerOn:aStream
- "to be redefined for concrete debuggers"
+ "to be redefined for concrete debuggers
+ (some require a bpnt to be registered and use a handle or id to refer to them)"
+
+ "Modified (comment): / 29-05-2019 / 15:11:55 / Claus Gittinger"
!
printOn:aStream
"append a printed representation of the receiver to the argument, aStream"
- aStream nextPutAll: 'BPNT '.
+ |info|
+
+ aStream nextPutAll: 'BPNT'.
self printBreakpointNrInDebuggerOn:aStream.
aStream nextPutAll: ' at'.
- position notNil ifTrue:[
- aStream
- nextPutAll: ' source position:';
- nextPutAll: position printString.
+ self printPositionOrLineNumberOn:aStream.
+ self isEnabled ifTrue:[
+ description condition notNil
+ ifTrue:[info := ' (conditional)']
+ ifFalse:[info := ' (enabled)']
+ ] ifFalse:[
+ info :=' (disabled)'
].
- line notNil ifTrue:[
- aStream
- nextPutAll: ' line:';
- nextPutAll: line printString.
- ].
+ aStream nextPutAll:info
+
+ "Modified: / 24-04-2013 / 20:42:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 29-05-2019 / 15:21:36 / Claus Gittinger"
+!
+
+printPositionOrLineNumberOn:aStream
(position isNil and:[line isNil]) ifTrue:[
aStream nextPutAll: ' ???'
- ]
+ ] ifFalse:[
+ position notNil ifTrue:[
+ aStream
+ nextPutAll: ' position:';
+ print: position.
+ ].
+ line notNil ifTrue:[
+ aStream
+ nextPutAll: ' line:';
+ print: line.
+ ].
+ ].
- "Modified: / 24-04-2013 / 20:42:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Created: / 29-05-2019 / 15:13:42 / Claus Gittinger"
! !
!Breakpoint methodsFor:'support'!
@@ -183,118 +340,40 @@
"Created: / 27-01-2012 / 13:56:11 / cg"
!
-break
- "invoked by the breakPoint's code (see BreakPointNode)"
-
- <resource: #skipInDebuggersWalkBack>
-
- |sender mthd where lineNr message
- source sourceLines sourceLine prevLine nextLine|
-
- description isEnabled ifFalse:[^ self].
- sender := thisContext sender.
- (description shouldBreakIn: sender) ifTrue:[
- message := 'Breakpoint encountered at line %1 in %2'.
- where := '?'.
-
- mthd := method.
- mthd notNil ifTrue:[
- mthd mclass isNil ifTrue:[
- mthd := sender method.
- ].
- where := mthd whoString.
-
- (lineNr := self line) notNil ifTrue:[
- (source := mthd source) notNil ifTrue:[
- sourceLines := source asStringCollection.
- sourceLine := sourceLines at:lineNr ifAbsent:[nil].
- sourceLine notNil ifTrue:[
- sourceLine := (sourceLine withoutLeadingSeparators contractAtEndTo:60) allItalic withColor:Color red darkened.
- message := 'Breakpoint encountered at:\\%3\\line %1 in %2'.
- lineNr > 1 ifTrue:[
- prevLine := sourceLines at:(lineNr-1) ifAbsent:[nil].
- prevLine notEmptyOrNil ifTrue:[
- prevLine := prevLine withoutLeadingSeparators.
- prevLine notEmpty ifTrue:[
- prevLine := (prevLine contractAtEndTo:60) allItalic.
- prevLine := '...', Character cr , prevLine.
- ] ifFalse:[
- prevLine := '...'.
- ].
- prevLine := prevLine withColor:Color grey.
- message := 'Breakpoint encountered at:\\%4\%3\\line %1 in %2'.
- ].
- ].
- lineNr < (sourceLines size) ifTrue:[
- nextLine := sourceLines at:(lineNr+1) ifAbsent:[nil].
- nextLine notEmptyOrNil ifTrue:[
- nextLine := nextLine withoutLeadingSeparators.
- nextLine notEmpty ifTrue:[
- nextLine := (nextLine withoutLeadingSeparators contractAtEndTo:60) allItalic.
- nextLine := nextLine , Character cr , '...'.
- ] ifFalse:[
- nextLine := '...'.
- ].
- nextLine := nextLine withColor:Color grey.
-
- prevLine notNil ifTrue:[
- message := 'Breakpoint encountered at:\\%4\%3\%5\\line %1 in %2'.
- ] ifFalse:[
- message := 'Breakpoint encountered at:\\%3\%5\\line %1 in %2'.
- ].
- ].
- ].
- ].
- ].
- ].
- ].
- BreakPointInterrupt
- raiseRequestWith: self
- errorString:(message withCRs
- bindWith:self line
- with:where
- with:sourceLine
- with:prevLine
- with:nextLine)
- "/ in:sender.
- ].
- (description shouldTraceIn: sender) ifTrue:[
- Transcript
- show:Timestamp now;
- showCR:(' Trace %1 [%2]' bindWith:sender methodPrintString with:self line)
- ].
-
- "Created: / 15-06-2011 / 12:48:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 11-07-2011 / 18:17:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 21-10-2017 / 15:24:35 / cg"
-!
-
disable
"disable this breakpoint"
"/ if there is currently an ignore on this breakpoint in the debugger, remove it
- DebugView stopIgnoringHaltsFor:method atLineNr:line.
+ Debugger notNil ifTrue:[
+ DebugView stopIgnoringHaltsFor:method atLineNr:line.
+ ].
description disable
+
+ "Modified: / 02-03-2019 / 11:30:45 / Claus Gittinger"
!
toggle
"toggle this breakpoint"
"/ if there is currently an ignore on this breakpoint in the debugger, remove it
- DebugView stopIgnoringHaltsFor:method atLineNr:line.
+ Debugger notNil ifTrue:[
+ Debugger stopIgnoringHaltsFor:method atLineNr:line.
+ ].
description toggle
"Created: / 17-06-2011 / 13:40:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 11-07-2011 / 18:18:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 27-01-2012 / 10:41:03 / cg"
+ "Modified: / 02-03-2019 / 11:30:31 / Claus Gittinger"
!
toggleTracing
- "toggle this breakpoint"
+ "toggle tracing of this breakpoint"
description toggleTracing
"Created: / 27-01-2012 / 13:56:05 / cg"
+ "Modified (comment): / 20-02-2019 / 10:46:54 / Claus Gittinger"
! !
!Breakpoint methodsFor:'testing'!
--- a/BreakpointAnalyzer.st Sat Aug 08 22:49:53 2020 +0100
+++ b/BreakpointAnalyzer.st Tue Aug 25 12:20:06 2020 +0100
@@ -48,13 +48,14 @@
"invoked whenever a message send node has been generated;
gives subclasses a chance to rewrite (instrument) it"
- (messageSendMap at: aMessageNode line ifAbsentPut:[Bag new])
- add: aMessageNode selector.
+ (messageSendMap at:(aMessageNode line) ifAbsentPut:[Bag new])
+ add:(aMessageNode selector).
^ aMessageNode
"Created: / 15-04-2013 / 15:32:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 16-04-2013 / 23:07:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 20-02-2019 / 10:49:33 / Claus Gittinger"
! !
!BreakpointAnalyzer methodsFor:'initialization'!
@@ -71,13 +72,23 @@
genMakeArrayWith:elementExpressions
"return a node to generate an array at runtime.
Will generate:
- Array with:el1 ... with:elN (if N <= 5)
+ literal shallowCopy (if all elements are literals)
+ or else:
+ Array with:el1 ... with:elN (if N <= 8)
or:
(Array new at:1 put:el1; ... at:N put:elN; yourself) (otherwise)
+
+ SIGH: duplicate code here, because the other implementation is on the class side,
+ and shared by JavaScriptParser and regular Parser.
"
|numEl arrRec sel expr|
+ (elementExpressions conform:#isConstant) ifTrue:[
+ arrRec := ConstantNode type:#Array value:(elementExpressions collect:#value as:Array) from:-1 to:-1. "/ position -1 means artifitial node
+ ^ self messageNodeRewriteHookFor:(MessageNode receiver:arrRec selector:#shallowCopy).
+ ].
+
arrRec := VariableNode globalNamed:#Array.
arrRec startPosition: -1 endPosition: -1. "/ -1 means artifitial node
@@ -134,10 +145,10 @@
!BreakpointAnalyzer class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/BreakpointAnalyzer.st,v 1.3 2013-04-24 20:26:44 vrany Exp $'
+ ^ '$Header$'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libcomp/BreakpointAnalyzer.st,v 1.3 2013-04-24 20:26:44 vrany Exp $'
+ ^ '$Header$'
! !
--- a/BreakpointDescription.st Sat Aug 08 22:49:53 2020 +0100
+++ b/BreakpointDescription.st Tue Aug 25 12:20:06 2020 +0100
@@ -72,8 +72,10 @@
^ condition
!
-condition:something
- condition := something.
+condition:aBlockCheckingItsContextArg
+ condition := aBlockCheckingItsContextArg.
+
+ "Modified (format): / 20-02-2019 / 10:58:54 / Claus Gittinger"
! !
!BreakpointDescription methodsFor:'initialization'!
@@ -81,11 +83,13 @@
initialize
"Invoked when a new instance is created."
+ "/ state is one of #hidden, #enabled, #tracing, #deleted, #disabled
state := #enabled
"/ super initialize. -- commented since inherited method does nothing
"Modified: / 17-06-2011 / 13:41:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 20-02-2019 / 10:56:18 / Claus Gittinger"
! !
!BreakpointDescription methodsFor:'support'!
@@ -109,18 +113,20 @@
shouldBreakIn: aContext
state ~~ #enabled ifTrue:[^false].
- ^ condition isNil or:[condition value: thisContext sender]
+ ^ condition isNil or:[condition value:aContext]
"Created: / 11-07-2011 / 18:16:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (format): / 27-01-2012 / 13:42:28 / cg"
+ "Modified: / 20-02-2019 / 10:57:07 / Claus Gittinger"
!
shouldTraceIn: aContext
state ~~ #tracing ifTrue:[^false].
- ^ condition isNil or:[condition value: thisContext sender]
+ ^ condition isNil or:[condition value:aContext]
"Created: / 27-01-2012 / 13:41:58 / cg"
+ "Modified: / 20-02-2019 / 10:57:14 / Claus Gittinger"
!
toggle
--- a/BreakpointNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/BreakpointNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -54,6 +54,10 @@
breakpoint := something.
!
+endPosition
+ ^ expression endPosition
+!
+
expression
^ expression
!
@@ -80,6 +84,10 @@
selectorPosition
^ expression selectorPosition
+!
+
+startPosition
+ ^ expression startPosition
! !
!BreakpointNode methodsFor:'code generation'!
@@ -117,6 +125,8 @@
codeOn:aStream inBlock:codeBlock for:aCompiler
|node|
+ "/ Transcript showCR:'**** bpCode: %1 expr: %2' with:lineNumber with:expression printString.
+
node := UnaryNode
receiver: (ConstantNode value: breakpoint)
selector: #break.
@@ -131,6 +141,12 @@
"Modified: / 26-03-2018 / 15:38:22 / stefan"
! !
+!BreakpointNode methodsFor:'enumerating'!
+
+childrenDo:aBlock
+ aBlock value:expression
+! !
+
!BreakpointNode methodsFor:'enumeration'!
allSubNodesDo:aBlock
@@ -169,6 +185,14 @@
"Created: / 08-08-2020 / 08:46:24 / Jan Vrany <jan.vrany@labware.com>"
! !
+!BreakpointNode methodsFor:'evaluation'!
+
+evaluateIn:anEnvironment
+ ^ expression evaluateIn:anEnvironment
+
+ "Created: / 20-02-2019 / 22:17:35 / Claus Gittinger"
+! !
+
!BreakpointNode methodsFor:'node protocol forwarding'!
arg1
@@ -201,7 +225,17 @@
^ expression isMessage
!
+isUnaryMessage
+ "must forward - otherwise cascades won't work"
+
+ ^ expression isUnaryMessage
+
+ "Created: / 26-07-2020 / 18:24:18 / cg"
+!
+
numArgs
+ <resource: #obsolete>
+
"must forward - otherwise checkCondition won't work.
Please use argumentCount, which is ANSI"
@@ -232,7 +266,8 @@
"append a user printed representation of the receiver to aStream.
The format is suitable for a human - not meant to be read back."
- expression printOn:aStream indent:indent
+ aStream show:'BP [%1] before: ' with:lineNumber.
+ expression printOn:aStream indent:indent.
"Created: / 06-07-2011 / 14:31:10 / cg"
! !
--- a/ByteCodeCompiler.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ByteCodeCompiler.st Tue Aug 25 12:20:06 2020 +0100
@@ -2510,7 +2510,7 @@
"
(lastStatement notNil
and:[(code := codeStream contents) notNil
- and:[code size > 0
+ and:[code size ~~ 0
and:[code last == #drop]]]) ifTrue:[
codeStream backStep.
codeStream nextPut:#retSelf
@@ -2523,6 +2523,7 @@
"Modified: / 15-08-1996 / 17:35:02 / stefan"
"Modified: / 06-08-2006 / 15:03:14 / cg"
"Modified: / 24-07-2018 / 16:06:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-03-2019 / 14:48:06 / Claus Gittinger"
!
generateVariables:varCollection on:codeStream
@@ -2701,10 +2702,12 @@
]
]
].
- self errorFlag ifTrue:[
+ self hasError ifTrue:[
self codeGeneratorError:'relocation range error'
].
^ true
+
+ "Modified: / 23-05-2019 / 09:28:03 / Claus Gittinger"
! !
!ByteCodeCompiler methodsFor:'code generation helpers'!
@@ -2973,14 +2976,14 @@
w := aWord.
(w >= 0) ifTrue:[
- (w > 16r7FFFF) ifTrue:[
- self codeGeneratorError:'word-range error'.
- ].
+ (w > 16r7FFF) ifTrue:[
+ self codeGeneratorError:'word-range error'.
+ ].
] ifFalse:[
- (w < 16r-8000) ifTrue:[
- self codeGeneratorError:'word-range error'.
- ].
- w := (16r10000 + w).
+ (w < 16r-8000) ifTrue:[
+ self codeGeneratorError:'word-range error'.
+ ].
+ w := (16r10000 + w).
].
self appendWord:w
!
@@ -3010,15 +3013,16 @@
usedSym := aSymbol.
Smalltalk hasSelectorNameSpaces ifTrue:[
- ns := self currentNameSpace.
- (ns notNil and:[ns ~~ Smalltalk]) ifTrue:[
- usedSym := (':',ns name,'::',aSymbol) asSymbol.
- Transcript showCR:'compile ',aSymbol,' as ',usedSym.
- ].
+ ns := self currentNameSpace.
+ (ns notNil and:[ns ~~ Smalltalk]) ifTrue:[
+ usedSym := (':',ns name,'::',aSymbol) asSymbol.
+ Logger info:('compile ',aSymbol,' as ',usedSym).
+ ].
].
^ usedSym.
"Created: / 05-03-2007 / 13:28:59 / cg"
+ "Modified: / 29-08-2018 / 12:52:48 / Claus Gittinger"
!
removeTempVar
@@ -3067,54 +3071,55 @@
aRequestor notNil ifTrue:[
^ self
- compile:aStringArg
- forClass:aClassArg
- inCategory:cat
+ compile:aStringArg
+ forClass:aClassArg
+ inCategory:cat
notifying:aRequestor
- install:install
- skipIfSame:skipIfSame
- silent:silent
+ install:install
+ skipIfSame:skipIfSame
+ silent:silent
foldConstants:fold
ifFail:nil
].
^ self
- compile:aStringArg
- forClass:aClassArg
- inCategory:cat
+ compile:aStringArg
+ forClass:aClassArg
+ inCategory:cat
notifying:aRequestor
- install:install
- skipIfSame:skipIfSame
- silent:silent
+ install:install
+ skipIfSame:skipIfSame
+ silent:silent
foldConstants:fold
ifFail:[:exOrNil |
+ |newMethod|
+
exOrNil notNil ifTrue:[
- ParseError new
+ exOrNil "ParseError new"
errorMessage:(exOrNil errorMessage) startPosition:(exOrNil startPosition) endPosition:(exOrNil endPosition);
parameter:exOrNil parameter;
lineNumber:exOrNil lineNumber;
raiseRequest.
] ifFalse:[
- ParseError raiseRequestErrorString:'compilation failed'. #Error
+ ParseError raiseRequestErrorString:'compilation failed'. "/ #Error
].
(install and:[selector notNil]) ifTrue:[
- |newMethod|
-
"/ if proceeded, install a trap method
- newMethod := (Method trapMethodForNumArgs:selector numArgs) copy.
+ newMethod := (Method trapMethodForNumArgs:selector argumentCount) copy.
newMethod mclass:nil; setPackage:nil.
newMethod makeInvalid.
newMethod source:aStringArg.
aClassArg basicAddSelector:selector withMethod:newMethod
].
+ newMethod
]
- "Modified: / 18-01-2011 / 11:35:21 / cg"
+ "Modified: / 09-06-2020 / 14:44:32 / cg"
!
compile:sourceCodeStringArg forClass:aClassArg inCategory:cat notifying:aRequestor
install:install skipIfSame:skipIfSame silent:silent foldConstants:fold
- ifFail:failBlock
+ ifFail:failBlockWithOptionalArgument
"the basic workhorse method for compiling:
compile a source-string for a method in classToCompileFor.
@@ -3130,7 +3135,7 @@
Returns the method, #Error or nil."
|newMethod tree symbolicCodeArray oldMethod silencio newSource primNr keptOldCode answer
- aClass sourceCodeString hasErrorInMethodHeader oldCategory newCategory oldPackage
+ aClass sourceCodeString hasErrorInMethodHeader oldCategory newCategory oldPackage
newPackage installSelector ns dialogText failureReason annotationCategory|
aClass := aClassArg.
@@ -3141,7 +3146,7 @@
or:[Smalltalk silentLoading
or:[ListCompiledMethods not]].
- "/ when a correction has been made, this signal is raised to try again
+ "/ when a correction has been made, this signal is raised to try again
self class restartCompilationSignal handle:[:ex |
"/ class could have changed ...
aClass := self classToCompileFor.
@@ -3153,19 +3158,23 @@
ex restart
] do:[
ParseError handle:[:ex |
- failBlock isNil ifTrue:[
+ ex creator isHandled ifTrue:[ex reject].
+
+ failBlockWithOptionalArgument isNil ifTrue:[
ex reject
].
self showErrorMessageForClass:aClass.
- ^ failBlock valueWithOptionalArgument:ex.
+ ^ failBlockWithOptionalArgument valueWithOptionalArgument:ex.
] do:[
"create a compiler, let it parse and create the parsetree"
- sourceCodeString isString ifTrue:[
- self source:(ReadStream on:sourceCodeString string).
- ] ifFalse:[
- self source:sourceCodeString readStream
- ].
+ self source:sourceCodeString.
+ "/ not needed - done by source:-setter
+ "/ sourceCodeString isString ifTrue:[
+ "/ self source:(ReadStream on:sourceCodeString string).
+ "/ ] ifFalse:[
+ "/ self source:sourceCodeString readStream
+ "/ ].
self nextToken.
self setClassToCompileFor:aClass.
@@ -3195,7 +3204,7 @@
hasErrorInMethodHeader ifTrue:[
self showErrorMessageForClass:aClass.
- ^ failBlock value.
+ ^ failBlockWithOptionalArgument valueWithOptionalArgument:nil.
].
(aClass notNil and:[selector notNil]) ifTrue:[
@@ -3231,7 +3240,13 @@
].
"check if same source"
- (skipIfSame and:[oldMethod notNil and:[oldMethod source = sourceCodeString]]) ifTrue:[
+ (skipIfSame
+ and:[oldMethod notNil
+ and:[ (SourceCodeManagerError
+ handle:[:ex | nil]
+ do:[oldMethod source]
+ ) = sourceCodeString
+ ]]) ifTrue:[
oldMethod isInvalid ifFalse:[
silencio ifFalse:[
Transcript showCR:(' unchanged: ',aClass name,' ',selector)
@@ -3259,10 +3274,10 @@
]
].
- (self errorFlag or:[tree == #Error]) ifTrue:[
+ (self hasError or:[tree == #Error]) ifTrue:[
"error in method body"
self showErrorMessageForClass:aClass.
- ^ failBlock value
+ ^ failBlockWithOptionalArgument valueWithOptionalArgument:nil
].
"if no error and also no selector ..."
@@ -3299,7 +3314,7 @@
newMethod == #Error ifTrue:[
self showErrorMessageForClass:aClass.
- "/^ failBlock value
+ "/^ failBlock valueWithOptionalArgument:nil
].
(newMethod == #CannotLoad or:[newMethod == #Error]) ifTrue:[
@@ -3314,7 +3329,7 @@
"/
(oldMethod notNil and:[oldMethod code ~= newMethod code]) ifTrue:[
failureReason == #Error ifTrue:[
- dialogText :=
+ dialogText :=
'STC-compilation of ''%1>>%2''
to machine code failed .
@@ -3328,7 +3343,7 @@
Close this warnBox to abort the compilation.
'
] ifFalse:[
- dialogText :=
+ dialogText :=
'installation of binary code for ''%1>>%2''
is not possible or disabled.
@@ -3347,7 +3362,7 @@
labels:#('Cancel' 'Keep Old' 'Trap Code')
default:2.
answer isNil ifTrue:[
- ^ failBlock value
+ ^ failBlockWithOptionalArgument valueWithOptionalArgument:nil
].
answer == false ifTrue:[
newMethod code:(oldMethod code).
@@ -3387,7 +3402,7 @@
symbolicCodeArray := self genSymbolicCode.
(symbolicCodeArray == #Error) ifTrue:[
self showErrorNotification:'translation error'.
- ^ failBlock value
+ ^ failBlockWithOptionalArgument valueWithOptionalArgument:nil
].
"
@@ -3396,7 +3411,7 @@
"
((self genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
self showErrorNotification:'relocation error - code must be simplified'.
- ^ failBlock value
+ ^ failBlockWithOptionalArgument valueWithOptionalArgument:nil
].
].
@@ -3467,6 +3482,8 @@
"Created: / 29-10-1995 / 19:59:36 / cg"
"Modified: / 19-03-1999 / 08:31:09 / stefan"
"Modified: / 05-07-2011 / 22:50:36 / cg"
+ "Modified: / 23-05-2019 / 09:28:00 / Claus Gittinger"
+ "Modified: / 11-02-2020 / 17:46:14 / Stefan Vogel"
!
compile:methodText forClass:aBehavior install:doInstall
--- a/ByteCodeCompilerWithBreakpointSupport.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ByteCodeCompilerWithBreakpointSupport.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2006 by eXept Software AG
All Rights Reserved
@@ -59,7 +61,7 @@
possiblyWrapABreakPointAround:aBlock
"refactored Jan's original code; changed to not wrap an already wrapped expression"
- | expr bpnt tokenPositionBefore tokenLineNrBefore |
+ | expr bpIdx bpnt tokenPositionBefore tokenLineNrBefore |
tokenPositionBefore := tokenPosition ? source position.
tokenLineNrBefore := tokenLineNr.
@@ -67,25 +69,43 @@
"/ find the very first breakpoint, which is right after the
"/ current line start, and remove it from the breakpoints collection,
"/ incl. all before. This removes breakpoints on empty lines or inside strings etc.
- [
- breakpoints notEmpty
- and:[(breakpoints first position ? 0) <= tokenPositionBefore]
- ] whileTrue:[
- bpnt := breakpoints removeFirst
- ].
+
+ "/ does not work
+"/ bpIdx := breakpoints findFirst:[:b | b line >= tokenLineNrBefore].
+"/ bpIdx > 0 ifTrue:[
+"/ bpnt := breakpoints at:bpIdx.
+"/ breakpoints removeIndex:bpIdx
+"/ ] ifFalse:[
+ [
+ breakpoints notEmpty
+ and:[(breakpoints first position ? 0) <= tokenPositionBefore]
+ ] whileTrue:[
+ bpnt := breakpoints removeFirst
+ ].
+"/ ].
+ "/ Transcript showCR:tokenLineNrBefore.
+ "/ Transcript showCR:thisContext sender.
+ "/ Transcript showCR:bpnt.
+ "/ Transcript showCR:'-----------'.
expr := aBlock value.
expr == #Error ifTrue:[^expr].
bpnt isNil ifTrue:[^expr].
- expr isBreakPointNode ifTrue:[^expr].
+
+ bpnt isReached:true.
+ expr isBreakPointNode ifTrue:[
+ expr lineNumber <= bpnt line ifTrue:[
+ "/ Transcript showCR:'bp [%1] expr already breakpointed: %2 ' with:bpnt line with:expr.
+ ^expr
+ ].
+ ].
tokenPositionBefore = tokenPosition ifTrue:[
"/ nothing scanned - happens with unaryExpression which does not find anything,
"/ but returns due to a ')' or ']' token.
+ "/ Transcript showCR:'nothing scanned'.
^expr
].
- bpnt isReached:true.
-
"/ Transcript show:'adding breakpoint '; show:bpnt; show:' before: '; showCR:expr.
^ BreakpointNode new
@@ -166,10 +186,18 @@
!ByteCodeCompilerWithBreakpointSupport methodsFor:'private'!
breakpoints:aCollection
- breakpoints := aCollection copy sort:[:a :b|a position < b position].
+ breakpoints := aCollection copy
+ sort:[:a :b|
+ (a position notNil and:[b position notNil]) ifTrue:[
+ a position < b position
+ ] ifFalse:[
+ a line < b line
+ ].
+ ].
"Created: / 16-06-2011 / 14:35:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Created: / 05-07-2011 / 21:37:28 / cg"
+ "Modified: / 20-02-2019 / 11:16:25 / Claus Gittinger"
!
methodClass
--- a/CompilationErrorHandler.st Sat Aug 08 22:49:53 2020 +0100
+++ b/CompilationErrorHandler.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1995 by Claus Gittinger
All Rights Reserved
@@ -11,6 +13,8 @@
"
"{ Package: 'stx:libcomp' }"
+"{ NameSpace: Smalltalk }"
+
Object subclass:#CompilationErrorHandler
instanceVariableNames:'myStream currentSource failBlock'
classVariableNames:''
@@ -36,8 +40,11 @@
documentation
"
- Instances of this class are created temporary during fileIn.
- They get notified about any errors. Currently, all we
+ Instances of this class (or a subclass)
+ are created temporary during fileIn.
+
+ They get notified about any errors.
+ Currently, all we
do here is to output the error on the Transcript;
eventually, we will open a box showing the position of the error.
"
@@ -145,10 +152,10 @@
!CompilationErrorHandler class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/CompilationErrorHandler.st,v 1.14 2014-02-20 15:18:45 cg Exp $'
+ ^ '$Header$'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libcomp/CompilationErrorHandler.st,v 1.14 2014-02-20 15:18:45 cg Exp $'
+ ^ '$Header$'
! !
--- a/ConstantNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ConstantNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -105,10 +105,10 @@
"Modified: / 19-07-2011 / 17:24:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-type:t value:val from: startPos to: endPos
+type:t value:val from:startPos to:endPos
- ^(self basicNew)
- type: t value: val;
+ ^ (self basicNew)
+ type:t value:val;
startPosition:startPos endPosition:endPos;
yourself
@@ -153,6 +153,14 @@
^ #Literal
! !
+!ConstantNode methodsFor:'RBParser compatibility'!
+
+token
+ "for RB compatibility, I implement some of its protocol"
+
+ ^ self
+! !
+
!ConstantNode methodsFor:'accessing'!
lineNumber:ignoredLineNumber
@@ -171,18 +179,55 @@
originalString := aString.
"Modified (comment): / 15-02-2019 / 14:35:50 / Claus Gittinger"
+!
+
+radix
+ "the constant's original radix;
+ remembered so that we can prettyprint it later in the same radix"
+
+ value isInteger ifFalse:[
+ self error.
+ ^ nil.
+ ].
+ originalString isNil ifTrue:[
+ ^ 10
+ ].
+ originalString size < 2 ifTrue:[^ 10].
+ (originalString at:2) == $r ifTrue:[
+ ^ Integer readFrom:originalString readStream.
+ ].
+ originalString size < 3 ifTrue:[^ 10].
+ (originalString at:3) == $r ifTrue:[
+ ^ Integer readFrom:originalString readStream.
+ ].
+ (originalString startsWith:'0x') ifTrue:[^ 16].
+ (originalString startsWith:'0b') ifTrue:[^ 2].
+ (originalString startsWith:'0o') ifTrue:[^ 8].
+ ^ 10
! !
!ConstantNode methodsFor:'code generation'!
codeForSideEffectOn:aStream inBlock:b for:aCompiler
"no code at all"
+ |msg|
+
+ (aCompiler parserFlags warnAboutDeadCodeAndFixMe) ifFalse:[^ self].
+
+ msg := 'Useless constant reference'.
"/ but remember symbolic literals (such as #TODO)
value isSymbol ifTrue:[
aCompiler addLiteral:value.
- ].
- ^ self
+
+ ((#fixme sameAs:value) or:[#todo sameAs:value]) ifTrue:[
+ msg := 'Reminder in code: ',value
+ ].
+ ].
+ aCompiler
+ warning:msg
+ doNotShowAgainAction:(aCompiler actionToDisableWarning:#warnAboutDeadCodeAndFixMe)
+ position:startPosition to:endPosition.
"Modified: / 04-03-2007 / 15:29:54 / cg"
!
@@ -398,6 +443,47 @@
^ value isNumber
"Created: / 16-06-2018 / 08:46:53 / Claus Gittinger"
+!
+
+isLiteralArray
+ ^ value isArray
+
+ "Created: / 16-06-2018 / 08:46:53 / Claus Gittinger"
+!
+
+isLiteralCString
+ ^ self isSTXSpecialLiteralString:$c
+
+ "Created: / 16-06-2018 / 08:46:53 / Claus Gittinger"
+!
+
+isLiteralEString
+ ^ self isSTXSpecialLiteralString:$e
+
+ "Created: / 16-06-2018 / 08:46:53 / Claus Gittinger"
+!
+
+isLiteralIString
+ ^ self isSTXSpecialLiteralString:$i
+
+ "Created: / 16-06-2018 / 08:46:53 / Claus Gittinger"
+!
+
+isLiteralRString
+ ^ self isSTXSpecialLiteralString:$r
+
+ "Created: / 16-06-2018 / 08:46:53 / Claus Gittinger"
+!
+
+isSTXSpecialLiteralString:typeChar
+ ^ value isString
+ and:[ originalString notNil
+ and:[ originalString size > 2
+ and:[ (originalString at:1) == typeChar
+ and:[ (originalString at:2) == $'
+ ]]]]
+
+ "Created: / 16-06-2018 / 08:46:53 / Claus Gittinger"
! !
!ConstantNode methodsFor:'visiting'!
--- a/Decompiler.st Sat Aug 08 22:49:53 2020 +0100
+++ b/Decompiler.st Tue Aug 25 12:20:06 2020 +0100
@@ -92,7 +92,7 @@
aStream showCR:(classToCompileFor name , '>>' , (who at:2)).
]
].
- aStream show:('nA: ' , method numArgs printString).
+ aStream show:('nA: ' , method argumentCount printString).
aStream show:(' nV: ' , method numVars printString).
aStream show:(' nT: ' , method stackSize printString).
aStream cr.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/DoEnableCompilerOptionActionQuery.st Tue Aug 25 12:20:06 2020 +0100
@@ -0,0 +1,38 @@
+"{ Package: 'stx:libcomp' }"
+
+"{ NameSpace: Smalltalk }"
+
+Query subclass:#DoEnableCompilerOptionActionQuery
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Compiler'
+!
+
+!DoEnableCompilerOptionActionQuery class methodsFor:'documentation'!
+
+documentation
+"
+ Used to ask if a parser option should be enabled.
+ When the compiler makes an error notification, it raises this query to
+ ask for an actionblock. If the query is not answered, the 'enable in compiler options' dialog
+ is not shown.
+ If it is answered, the returned value must be the block.
+ The dialog is shown, and if the user confirms (do not show again), the block is called.
+ The block is typically provided from the warning generation code, which sets/clears
+ some flag in the user preferences.
+"
+! !
+
+!DoEnableCompilerOptionActionQuery class methodsFor:'queries'!
+
+actionQuery
+ ^ self query
+! !
+
+!DoEnableCompilerOptionActionQuery class methodsFor:'documentation'!
+
+version_CVS
+ ^ '$Header$'
+! !
+
--- a/EvalScriptingErrorHandler.st Sat Aug 08 22:49:53 2020 +0100
+++ b/EvalScriptingErrorHandler.st Tue Aug 25 12:20:06 2020 +0100
@@ -63,12 +63,17 @@
Stderr nextPutLine:('[%1 %2/%3] %4' bindWith:errorOrWarning with:lineNr with:pos with:aMessage).
currentSource notNil ifTrue:[
- Stderr
- nextPutLine:currentSource;
- spaces:position?0;
- nextPutLine:'^'.
+ Error handle:[:ex |
+ ] do:[
+ Stderr
+ nextPutLine:currentSource;
+ spaces:position?0;
+ nextPutLine:'^'.
+ ].
].
^ #Error
+
+ "Modified: / 24-09-2018 / 14:18:02 / Claus Gittinger"
!
warning:aMessage position:position to:endPos from:aCompiler
@@ -90,10 +95,10 @@
!EvalScriptingErrorHandler class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/EvalScriptingErrorHandler.st,v 1.9 2015-05-22 18:37:50 cg Exp $'
+ ^ '$Header$'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libcomp/EvalScriptingErrorHandler.st,v 1.9 2015-05-22 18:37:50 cg Exp $'
+ ^ '$Header$'
! !
--- a/Explainer.st Sat Aug 08 22:49:53 2020 +0100
+++ b/Explainer.st Tue Aug 25 12:20:06 2020 +0100
@@ -51,7 +51,7 @@
This one is involved, when the 'explain' menu function is used in a
codeView (popup or via CMD-E), or if the mouse button is clicked
- on some code construct in the new browser (then a short explanaition
+ on some code construct in the new browser (then a short explanation
is shown in the lower info area).
Most of the texts returned here are heuristically motivated,
@@ -69,7 +69,8 @@
!Explainer class methodsFor:'explaining'!
explainLiteralNode:node in:code forClass:cls short:short interval:intervalIfKnown
- |expl literalValue literalsClass findInnerMost elementIndex codeOfCharacterBeforeCursor|
+ |expl literalValue literalsClass
+ findInnerMost elementIndex codeOfCharacterBeforeCursor first|
literalValue := node value.
literalsClass := literalValue class.
@@ -77,17 +78,22 @@
(literalValue isInteger) ifTrue:[
(literalValue ~~ 0 and:[literalValue ~~ 1]) ifTrue:[
+ first := true.
expl := expl , ' ('.
- #(2 10 16) with:#('binary: ' 'decimal: ' 'hex: ') do:[:base :baseExpl |
+ #(10 16 2) with:#('decimal: ' 'hex: ' 'binary: ' ) do:[:base :baseExpl |
|bStr|
base ~= (node token radix ? 10) ifTrue:[
bStr := base==10
ifTrue:[literalValue printString]
ifFalse:[(literalValue printStringRadix:base) leftPaddedTo:2 with:$0]. "/ looks better: at least a size of 2
- "/ oops - someone looks at a largeInteger
- bStr := bStr contractAtEndTo:40.
- expl := expl , ' ' , baseExpl, bStr
+ (base == 16 and:[literalValue < 10]) ifFalse:[
+ first ifFalse:[expl := expl , ' '].
+ "/ oops - maybe someone looks at a large largeInteger
+ bStr := (bStr contractAtEndTo:40).
+ expl := expl , (View resources string:baseExpl), bStr.
+ first := false.
+ ].
].
].
expl := expl , ' )'.
@@ -103,36 +109,58 @@
"/ see which element we have to explain
findInnerMost :=
[:token |
- token value keysAndValuesDo:[:index :eachToken |
+ token value keysAndValuesDo:[:index :eachTokenOrValue |
|selectorOrName selectorExplanation|
- ((eachToken start to:eachToken stop) intersect:intervalIfKnown) notEmpty ifTrue:[
- elementIndex := index. "/ see below
-
- eachToken value isArray ifTrue:[
- findInnerMost value:eachToken.
+ (eachTokenOrValue respondsTo:#start) ifTrue:[ "/ only works with RBTokens (i.e. not with JavaScript code)!!
+ ((eachTokenOrValue start to:eachTokenOrValue stop) intersect:intervalIfKnown) notEmpty ifTrue:[
+ elementIndex := index. "/ see below
+
+ eachTokenOrValue value isArray ifTrue:[
+ findInnerMost value:eachTokenOrValue.
+ ].
+ eachTokenOrValue value isSymbol ifTrue:[
+ selectorOrName := eachTokenOrValue value.
+ selectorOrName isUppercaseFirst ifTrue:[
+ (Smalltalk includesKey:selectorOrName) ifTrue:[
+ ^ expl, ' / ', (Explainer explainGlobal:selectorOrName inClass:cls short:short)
+ ].
+ ].
+ selectorExplanation := (Explainer explainSelector:selectorOrName inClass:cls short:short).
+ selectorExplanation isNil ifTrue:[^ expl].
+ ^ expl, ' / ', selectorExplanation.
+ ].
].
- eachToken value isSymbol ifTrue:[
- selectorOrName := eachToken value.
- selectorOrName isUppercaseFirst ifTrue:[
- (Smalltalk includesKey:selectorOrName) ifTrue:[
- ^ expl, ' / ', (Explainer explainGlobal:selectorOrName inClass:cls short:short)
- ].
- ].
- selectorExplanation := (Explainer explainSelector:selectorOrName inClass:cls short:short).
- selectorExplanation isNil ifTrue:[^ expl].
- ^ expl, ' / ', selectorExplanation.
- ].
- ].
+ ]
]
].
findInnerMost value:node token.
].
- (literalValue isArray or:[ literalValue isByteArray or:[ literalValue isString ]]) ifTrue:[
+ (literalValue isArray
+ or:[ literalValue isByteArray
+ or:[ literalValue isString ]]
+ ) ifTrue:[
literalValue size == 0 ifTrue:[
^ 'empty ' , expl
].
+ literalValue isString ifTrue:[
+ node token isLiteralCString ifTrue:[
+ expl := expl,' (C-syntax)'.
+ ] ifFalse:[
+ node token isLiteralEString ifTrue:[
+ expl := expl,' (expandeded String)'.
+ ] ifFalse:[
+ node token isLiteralIString ifTrue:[
+ expl := expl,' (internationalized String)'.
+ ] ifFalse:[
+ node token isLiteralRString ifTrue:[
+ expl := expl,' (regex)'.
+ ].
+ ].
+ ].
+ ].
+ ].
elementIndex notNil ifTrue:[
^ expl , (' (size=%1; element=%2)' bindWith:literalValue size with:elementIndex)
].
@@ -153,14 +181,15 @@
^ expl
"Modified (format): / 30-04-2016 / 16:00:05 / cg"
+ "Modified: / 17-02-2019 / 12:52:23 / Claus Gittinger"
!
-explainMessageNode:node in:code forClass:cls short:short interval:intervalIfKnown
+explainMessageNode:node in:code forClass:aClassOrNil short:short interval:intervalIfKnown
"answer a string which explains node"
|receiver nm srchClass selector selectorString implClass
boldSelectorString globalValue recClassSet
- implMethod implMethodComment info definer
+ implMethod implMethodComment implMethodCommentLines info definer
instances classesOfInstVars implementingClasses canBeNil
bestMatches hint redefiningClasses|
@@ -168,17 +197,21 @@
selectorString := selector printString contractTo:50.
selector := selector asSymbolIfInterned. "/ avoid creating new symbols.
selector isNil ifTrue:[
- ^ '%1 is NOWHERE impemented.' bindWith:boldSelectorString
+ ^ '%1 is NOWHERE impemented.' bindWith:selectorString
].
selectorString := self asLink:selectorString to:(self actionToBrowseImplementorsOf:selector).
boldSelectorString := selectorString "allBold".
- recClassSet := self guessPossibleClassesFor:(node receiver) in:code forClass:cls.
+ recClassSet := self guessPossibleClassesFor:(node receiver) in:code forClass:aClassOrNil.
recClassSet size == 1 ifTrue:[
srchClass := recClassSet first.
+
"take care - Set cannot store nil!!"
- implementingClasses := (recClassSet collect:[:cls | cls whichClassIncludesSelector:selector]) asArray.
+ implementingClasses := recClassSet
+ collect:[:eachImplClassOrNil |
+ eachImplClassOrNil whichClassIncludesSelector:selector]
+ as:Array.
(implementingClasses includes:nil) ifTrue:[
implementingClasses size > 1 ifTrue:[
@@ -193,7 +226,10 @@
].
hint := ''.
- (recClassSet contains:[:cls | cls isMeta not and:[cls theMetaclass canUnderstand:selector]]) ifTrue:[
+ (recClassSet contains:[:eachRecClassOrNil |
+ eachRecClassOrNil isMeta not
+ and:[eachRecClassOrNil theMetaclass canUnderstand:selector]]
+ ) ifTrue:[
hint := '. But class understands it - did you mean "rcvr class ',selector,'..." ?'.
].
bestMatches := Parser findBestSelectorsFor:selector in:srchClass.
@@ -212,52 +248,52 @@
].
implementingClasses isNil ifTrue:[
- receiver := node receiver.
- receiver isVariable ifTrue:[
- nm := receiver name.
- nm = 'self' ifTrue:[
- srchClass := cls
- ].
- nm = 'super' ifTrue:[
- srchClass := cls superclass
- ].
- definer := receiver whoDefines:nm.
- definer isNil ifTrue:[
- "/ not a local or argument
- (cls instanceVariableNames includes:nm) ifTrue:[
- "/ ok - an instVar; see what values we find...
- instances := cls allSubInstances select:[:eachInst| eachInst isProtoObject not].
- classesOfInstVars := instances collect:[:eachInst | (eachInst instVarNamed:nm) class] as:Set.
- canBeNil := (classesOfInstVars remove:UndefinedObject ifAbsent:[]) notNil.
- "take care - Set cannot store nil!!"
- implementingClasses := classesOfInstVars collect:[:cls | (cls whichClassIncludesSelector:selector) ? 0].
- implementingClasses remove:0 ifAbsent:[].
- ] ifFalse:[
- nm isUppercaseFirst ifTrue:[
- nm knownAsSymbol ifTrue:[
+ aClassOrNil notNil ifTrue:[
+ receiver := node receiver.
+ receiver isVariable ifTrue:[
+ nm := receiver name.
+ nm = 'self' ifTrue:[
+ srchClass := aClassOrNil
+ ].
+ nm = 'super' ifTrue:[
+ srchClass := aClassOrNil superclass
+ ].
+ definer := receiver whoDefines:nm.
+ definer isNil ifTrue:[
+ "/ not a local or argument
+ (aClassOrNil instanceVariableNames includes:nm) ifTrue:[
+ "/ ok - an instVar; see what values we find...
+ instances := aClassOrNil allSubInstances select:[:eachInst| eachInst isProtoObject not].
+ classesOfInstVars := instances collect:[:eachInst | (eachInst instVarNamed:nm) class] as:Set.
+ canBeNil := (classesOfInstVars remove:UndefinedObject ifAbsent:[]) notNil.
+ "take care - Set cannot store nil!!"
+ implementingClasses := classesOfInstVars collect:[:aClassOrNil | (aClassOrNil whichClassIncludesSelector:selector) ? 0].
+ implementingClasses remove:0 ifAbsent:[].
+ ] ifFalse:[
+ (nm isUppercaseFirst and:[nm knownAsSymbol]) ifTrue:[
globalValue := Smalltalk at:nm asSymbol.
globalValue isClass ifTrue:[
srchClass := globalValue class.
].
- ]
+ ].
].
].
].
- ].
-
- receiver isLiteral ifTrue:[
- srchClass := receiver value class
- ].
-
- srchClass notNil ifTrue:[
- implClass := srchClass whichClassIncludesSelector:selector.
- implClass isNil ifTrue:[
- ^ '%1 is NOT understood here.' bindWith:boldSelectorString
+
+ receiver isLiteral ifTrue:[
+ srchClass := receiver value class
].
- redefiningClasses := srchClass allSubclasses select:[:cls | cls implements:selector].
- ] ifFalse:[
- implementingClasses isNil ifTrue:[
- implementingClasses := Smalltalk allImplementorsOf:selector
+
+ srchClass notNil ifTrue:[
+ implClass := srchClass whichClassIncludesSelector:selector.
+ implClass isNil ifTrue:[
+ ^ '%1 is NOT understood here.' bindWith:boldSelectorString
+ ].
+ redefiningClasses := srchClass allSubclasses select:[:aClassOrNil | aClassOrNil implements:selector].
+ ] ifFalse:[
+ implementingClasses isNil ifTrue:[
+ implementingClasses := Smalltalk allImplementorsOf:selector
+ ].
].
].
].
@@ -273,10 +309,12 @@
implMethod := implClass compiledMethodAt:selector.
clsName := implClass name.
clsName := self asLink:clsName to:(self actionToBrowseClass:implClass selector:selector).
+ "/ info := '%1 � %2' bindWith:clsName "allBold" with:selectorString.
info := '%1 %2' bindWith:clsName "allBold" with:selectorString.
+ info := '%1 %2' bindWith:clsName with:(implMethod methodDefinitionTemplateForSelector:selector).
info := self asLink:info to:(action1 := self actionToBrowseClass:implClass selector:selector info:nil).
- redefiningClasses size > 0 ifTrue:[
+ redefiningClasses size ~~ 0 ifTrue:[
redefiningClasses size == 1 ifTrue:[
|redefiner|
redefiner := redefiningClasses first.
@@ -298,8 +336,12 @@
].
implMethodComment := self fetchDescriptionOfMethod:"fetchCommentOfMethod:"implMethod.
- implMethodComment notNil ifTrue:[
- info := info , Character cr , implMethodComment.
+ implMethodComment notEmptyOrNil ifTrue:[
+ implMethodCommentLines := implMethodComment asStringCollection.
+ implMethodCommentLines size > 1 ifTrue:[
+ implMethodCommentLines := implMethodCommentLines copyFrom:2.
+ ].
+ info := info , Character cr , (implMethodCommentLines asString).
action1 info:implMethod source.
].
^ info
@@ -308,7 +350,7 @@
"/ info := info , ' (guess)'.
"/ ].
] ifFalse:[
- info := Explainer explainSelector:selector inClass:cls short:short.
+ info := Explainer explainSelector:selector inClass:aClassOrNil short:short.
].
"/ implementingClasses notEmptyOrNil ifTrue:[
@@ -344,12 +386,16 @@
^ info
"Modified: / 30-04-2016 / 17:08:11 / cg"
+ "Modified: / 18-07-2019 / 07:51:21 / Claus Gittinger"
+ "Modified: / 24-10-2019 / 10:46:01 / Stefan Vogel"
!
explainMethodNode:node in:code forClass:cls short:short interval:intervalIfKnown
|srchClass selector selectorString implClass
"sendingMethods numSendingMethods sendingClasses" |
+ cls isNil ifTrue:[^ nil].
+
selector := node selector.
selector := selector asSymbolIfInterned. "/ avoid creating new symbols.
selectorString := selector printString contractTo:50.
@@ -442,6 +488,7 @@
^ nil
"Modified: / 09-10-2006 / 12:11:16 / cg"
+ "Modified: / 05-03-2019 / 03:30:22 / Claus Gittinger"
!
explainNode:node in:code forClass:cls short:short
@@ -450,7 +497,19 @@
explainNode:node in:code forClass:cls short:short interval:intervalIfKnown
"parsetree based explanations"
-
+
+ node isSynthetic ifTrue:[
+ ((node originalString ? '') startsWith:'i''') ifTrue:[
+ short ifTrue:[^ 'internationalized string' ].
+ ^ c'Internationalized string.\n\nA String of the form:\n i''...{expr1}...{exprN}...''\nis compiled into the message send:\n resources string:''...%1...%2...'' withArguments:{expr1 ... exprN}'
+ ].
+ ((node originalString ? '') startsWith:'e''') ifTrue:[
+ short ifTrue:[ ^ 'a string with embedded expressions' ].
+ ^ c'String with embedded expressions.\n\nA string of the form:\n e''...{expr1}...{exprN}...''\nis compiled into the message send:\n ''...%1...%2...'' bindWithArguments:{expr1 ... exprN}'
+ ].
+ self halt.
+ ].
+
node isVariable ifTrue:[
^ self explainVariableNode:node in:code forClass:cls short:short interval:intervalIfKnown.
].
@@ -471,13 +530,13 @@
"Modified (comment): / 27-11-2017 / 18:05:22 / cg"
!
-explainVariableNode:node in:code forClass:cls short:short interval:intervalIfKnown
+explainVariableNode:node in:code forClass:aClassOrNil short:short interval:intervalIfKnown
|expl nm nmBold definingNode namePart argNode argClass argClassSet|
nm := node name.
(#( 'self' 'super' 'thisContext' 'here') includes:nm) ifTrue:[
- ^ Explainer explainPseudoVariable:nm in:cls short:short
+ ^ Explainer explainPseudoVariable:nm in:aClassOrNil short:short
].
nm notNil ifTrue:[ nmBold := nm "allBold" ].
@@ -490,7 +549,7 @@
argNode notNil ifTrue:[
expl := namePart , ': a method argument.'.
- argClassSet := self guessPossibleClassesFor:argNode in:code forClass:cls.
+ argClassSet := self guessPossibleClassesFor:argNode in:code forClass:aClassOrNil.
argClassSet size == 1 ifTrue:[
argClass := argClassSet first.
].
@@ -528,27 +587,29 @@
expl isNil ifTrue:[
expl := namePart , ': temporary.'
].
- (cls allInstanceVariableNames includes:nm) ifTrue:[
- expl := expl , ' (instance variable is hidden)'
+ aClassOrNil notNil ifTrue:[
+ (aClassOrNil allInstanceVariableNames includes:nm) ifTrue:[
+ expl := expl , ' (instance variable is hidden)'
+ ].
].
^ expl.
].
- ^ Explainer explain:node name in:code forClass:cls short:short
+ ^ Explainer explain:node name in:code forClass:aClassOrNil short:short
"Modified: / 07-11-2006 / 12:22:09 / cg"
+ "Modified: / 05-03-2019 / 01:11:01 / Claus Gittinger"
!
fetchCommentOfMethod:mthd
"retrieve the comment of a method
(if possible and there is one; otherwise, return nil)"
- |methodSource methodComment lines maxNumLines|
+ |methodComment lines maxNumLines|
self withWaitCursorDo:[
SourceCodeManagerError handle:[:ex |
] do:[
- methodSource := mthd source.
methodComment := mthd comment
].
].
@@ -557,17 +618,12 @@
lines := methodComment asStringCollection.
maxNumLines := 1.
-true ifTrue:[
+
methodComment := (lines copyToMax:maxNumLines) asString.
maxNumLines := 5.
-] ifFalse:[
- methodComment := lines first.
- methodComment := methodComment withoutSeparators.
- (methodComment endsWith:',') ifTrue:[ methodComment := methodComment copyButLast:1].
- methodComment := methodComment withoutSeparators.
-].
+
(lines size > maxNumLines) ifTrue:[
- methodComment := methodComment , '\...' withCRs
+ methodComment := methodComment , c'\n...'
].
^ (methodComment) withColor:(UserPreferences current commentColor).
@@ -645,36 +701,55 @@
"Modified (format): / 20-06-2017 / 10:29:13 / cg"
!
-guessPossibleClassesFor:node in:code forClass:cls
+guessPossibleClassesFor:node in:code forClass:aClassOrNil
"given a node of some code of a method in cls,
return a collection of possible types of the node."
|nm globalValue definer instances classesOfInstVars ns|
+ node isLiteral ifTrue:[
+ ^ Array with:(node value class)
+ ].
node isVariable ifTrue:[
nm := node name.
+ (aClassOrNil isNil) ifTrue:[
+ (nm isUppercaseFirst and:[ nm knownAsSymbol ]) ifTrue:[
+ globalValue := Smalltalk at:nm asSymbol.
+ globalValue isClass ifTrue:[
+ ^ Array with:globalValue class.
+ ].
+ ].
+ ^ nil
+ ].
+
nm = #self ifTrue:[
- ^ cls withAllSubclasses
+ ^ aClassOrNil withAllSubclasses
].
nm = #here ifTrue:[
- ^ cls withAllSuperclasses
+ ^ aClassOrNil withAllSuperclasses
].
nm = #super ifTrue:[
- ^ cls allSuperclasses
+ ^ aClassOrNil allSuperclasses
].
definer := node whoDefines:nm.
definer isNil ifTrue:[
"/ not a local or argument
- (cls instanceVariableNames includes:nm) ifTrue:[
+ (aClassOrNil instanceVariableNames includes:nm) ifTrue:[
"/ ok - an instVar; see what values we find...
- instances := cls allSubInstances select:[:eachInst | eachInst isProtoObject not].
+ instances := aClassOrNil allSubInstances select:[:eachInst | eachInst isProtoObject not].
classesOfInstVars := instances collect:[:eachInst | (eachInst instVarNamed:nm) class] as:Set.
+ "/ should also look at all setters of this instvar, to see if there is sth. like
+ "/ class new/new:
+ "/ However, this will take too long, unless we implement some clever caching.
^ classesOfInstVars.
].
- (cls classVariableNames includes:nm) ifTrue:[
- ^ Array with:(cls classVarAt:nm asSymbol) class.
+ (aClassOrNil classVariableNames includes:nm) ifTrue:[
+ "/ should also look at all setters of this instvar, to see if there is sth. like
+ "/ class new/new:
+ "/ However, this will take too long, unless we implement some clever caching.
+ ^ Array with:(aClassOrNil classVarAt:nm asSymbol) class.
].
nm isUppercaseFirst ifTrue:[
nm knownAsSymbol ifTrue:[
@@ -683,7 +758,7 @@
^ Array with:globalValue class.
].
].
- ((ns := cls topNameSpace) notNil and:[ns ~~ Smalltalk]) ifTrue:[
+ ((ns := aClassOrNil topNameSpace) notNil and:[ns ~~ Smalltalk]) ifTrue:[
nm knownAsSymbol ifTrue:[
globalValue := ns at:nm asSymbol.
globalValue isClass ifTrue:[
@@ -720,10 +795,6 @@
^ nil
].
- node isLiteral ifTrue:[
- ^ Array with:(node value class)
- ].
-
"/ node isMessage ifTrue:[
"/ recClassSet := self guessPossibleImplementorClassesFor:(node receiver) in:code forClass:cls.
"/ recClassSet isNil ifTrue:[ ^ nil ].
@@ -736,6 +807,7 @@
^ nil
"Modified: / 07-02-2012 / 22:19:53 / cg"
+ "Modified: / 05-03-2019 / 01:09:49 / Claus Gittinger"
!
withWaitCursorDo:aBlock
@@ -756,7 +828,20 @@
!Explainer class methodsFor:'explaining-naive'!
-explain:someText in:source forClass:aClass
+colorForValue:val
+ val == true ifTrue:[
+ ^ Color darkGreen.
+ ].
+ val == false ifTrue:[
+ ^ Color darkRed
+ ].
+ val == nil ifTrue:[
+ ^ Color darkGrey
+ ].
+ ^ nil
+!
+
+explain:someText in:source forClass:aClassOrNil
"Given a source and a substring of it, return a string containing
an explanation.
This is just a q&d implementation - to be correct, it should use the parser,
@@ -766,12 +851,13 @@
message selector. I.e. the explanation should be context sensitive.
Also, there could be much more detailed explanations."
- ^ self explain:someText in:source forClass:aClass short:false
+ ^ self explain:someText in:source forClass:aClassOrNil short:false
"Modified: / 07-06-2007 / 11:34:05 / cg"
+ "Modified (format): / 04-03-2019 / 10:09:46 / Claus Gittinger"
!
-explain:someText in:source forClass:aClass short:shortText
+explain:someText in:source forClass:aClassOrNil short:shortText
"Given a source and a substring of it, return a string containing
an explanation.
This is just a q&d implementation - to be correct, it should use the parser,
@@ -791,10 +877,10 @@
"/ stringText := '''' , stringText , ''''.
"
- ask parser for variable names
+ ask instance for variable names
"
ParseError catch:[
- explainer := self parseMethod:source in:aClass ignoreErrors:true ignoreWarnings:true.
+ explainer := self parseMethod:source in:aClassOrNil ignoreErrors:false ignoreWarnings:true.
].
"/ bad leftover from a stupid return value from ancient times
explainer == #Error ifTrue:[ explainer := nil ].
@@ -804,131 +890,144 @@
variables := explainer methodVars.
(variables notNil and:[variables includes:string]) ifTrue:[
- ^ stringText , ' a method variable.'
+ ^ '%1: a method variable' bindWith:stringText
].
variables := explainer methodArgs.
(variables notNil and:[variables includes:string]) ifTrue:[
- ^ stringText , ' a method argument.'
+ ^ '%1: a method argument' bindWith:stringText
]
].
explainer isNil ifTrue:[
- explainer := self for:(ReadStream on:source) in:aClass
+ explainer := self for:(ReadStream on:source) in:aClassOrNil
].
- "instvars/class instVars"
- c := aClass whichClassDefinesInstVar:string.
- c notNil ifTrue:[
- c isMeta ifTrue:[
- clsName := c theNonMetaclass name.
- shortText ifTrue:[
- clsName := self asClassLink:clsName.
- stringText := stringText , ': a class instVar in ' , clsName
- ] ifFalse:[
- stringText := stringText, ': a class instance variable inherited from ' , clsName
+ aClassOrNil notNil ifTrue:[
+ "instvars/class instVars"
+ c := aClassOrNil whichClassDefinesInstVar:string.
+ c notNil ifTrue:[
+ c isMeta ifTrue:[
+ clsName := c theNonMetaclass name.
+ shortText ifTrue:[
+ clsName := self asClassLink:clsName.
+ ].
+
+ val := aClassOrNil theNonMetaclass instVarNamed:string.
+ valString := self safeValueStringFor:val.
+ (color := self colorForValue:val) notNil ifTrue:[
+ stringText := stringText withColor:color.
+ valString := valString withColor:color.
+ ].
+
+ shortText ifTrue:[
+ ^ '%1 (%2): class instVar in %3' bindWith:stringText with:valString with:clsName
+ ] ifFalse:[
+ ^ '%1 (%2): class instance variable inherited from %3' bindWith:stringText with:valString with:clsName
+ ].
].
- val := aClass theNonMetaclass instVarNamed:string.
- valString := self valueStringFor:val.
- ^ stringText , ' (' , valString , ').'
+ ^ self explainInstanceVariable:string inClass:c short:shortText.
].
- ^ self explainInstanceVariable:string inClass:c short:shortText.
].
string isWideString ifFalse:[
- "classvars"
- c := explainer inWhichClassIsClassVar:string.
- c notNil ifTrue:[
- val := c theNonMetaclass classVarAt:string. "/ Smalltalk at:(clsName , ':' , string) asSymbol.
- valString := self valueStringFor:val.
-
- val == true ifTrue:[
- color := Color green darkened.
- ] ifFalse:[
- val == false ifTrue:[
- color := Color red darkened
+ aClassOrNil notNil ifTrue:[
+ "classvars"
+ c := explainer inWhichClassIsClassVar:string.
+ c notNil ifTrue:[
+ clsName := c name.
+ shortText ifTrue:[
+ clsName := self asClassLink:clsName.
+ ].
+
+ val := c theNonMetaclass classVarAt:string. "/ Smalltalk at:(clsName , ':' , string) asSymbol.
+ valString := self safeValueStringFor:val.
+ (color := self colorForValue:val) notNil ifTrue:[
+ stringText := stringText withColor:color.
+ valString := valString withColor:color.
+ ].
+
+ shortText ifTrue:[
+ ^ '%1 (%2): classVar in %3' bindWith:stringText with:valString with:clsName
] ifFalse:[
- val == nil ifTrue:[
- color := Color darkGrey
- ].
- ].
- ].
- color notNil ifTrue:[
- stringText := stringText withColor:color.
- valString := valString withColor:color.
- ].
-
- clsName := c name.
- shortText ifTrue:[
- clsName := self asClassLink:clsName.
- stringText := stringText , ': a classVar in ' , clsName
- ] ifFalse:[
- stringText := stringText , ': a class variable in ' , clsName
- ].
-
- ^ stringText , ' (' , valString , ').'
- ].
-
- "private classes"
- c := aClass theNonMetaclass.
- c privateClasses do:[:pClass |
- (pClass name = string
- or:[pClass nameWithoutPrefix = string]) ifTrue:[
- stringText := self asClassLink:pClass name.
- stringText := stringText , ': a private class in ''' , c name , '''.'.
- shortText ifFalse:[
- stringText := (stringText , '\\It is only visible locally.') withCRs
+ ^ '%1 (%2): class variable in %3' bindWith:stringText with:valString with:clsName
].
- ^ stringText withCRs
].
].
- aClass theNonMetaclass sharedPoolNames do:[:eachPoolName |
- |sharedPool sharedPoolSym poolName|
-
- sharedPoolSym := string asSymbolIfInterned.
- sharedPoolSym notNil ifTrue:[
- sharedPool := Smalltalk classNamed:eachPoolName.
- sharedPool notNil ifTrue:[
- sharedPool isSharedPool ifFalse:[
- ^ 'oops - not a shared pool: ',eachPoolName
+ aClassOrNil notNil ifTrue:[
+ "private classes"
+ c := aClassOrNil theNonMetaclass.
+ c privateClasses do:[:pClass |
+ (pClass name = string
+ or:[pClass nameWithoutPrefix = string]) ifTrue:[
+ stringText := pClass name.
+ shortText ifTrue:[
+ stringText := self asClassLink:stringText
+ ].
+ clsName := c name. "/ owning class
+ shortText ifTrue:[
+ clsName := self asClassLink:clsName.
+ ].
+ stringText := '%1: private class in %2' bindWith:stringText with:clsName.
+ shortText ifFalse:[
+ stringText := (stringText , '\\It is only visible locally.') withCRs
].
- (sharedPool includesKey:sharedPoolSym) ifTrue:[
- poolName := sharedPool name.
- poolName := self asClassLink:eachPoolName.
- stringText := stringText , ': a pool variable in ',poolName.
- val := sharedPool at:sharedPoolSym.
- valString := self valueStringFor:val.
- ^ stringText , ' (' , valString , ').'
+ ^ stringText withCRs
+ ].
+ ].
+ ].
+
+ aClassOrNil notNil ifTrue:[
+ aClassOrNil theNonMetaclass sharedPoolNames do:[:eachPoolName |
+ |sharedPool sharedPoolSym poolName|
+
+ sharedPoolSym := string asSymbolIfInterned.
+ sharedPoolSym notNil ifTrue:[
+ sharedPool := Smalltalk classNamed:eachPoolName.
+ sharedPool notNil ifTrue:[
+ sharedPool isSharedPool ifFalse:[
+ ^ 'oops - not a shared pool: ',eachPoolName
+ ].
+ (sharedPool includesKey:sharedPoolSym) ifTrue:[
+ poolName := sharedPool name.
+ poolName := self asClassLink:eachPoolName.
+ stringText := stringText , ': a pool variable in ',poolName.
+ val := sharedPool at:sharedPoolSym.
+ valString := self safeValueStringFor:val.
+ ^ stringText , ' (' , valString , ').'
+ ].
].
].
].
].
- "namespace & global variables"
- (spc := aClass nameSpace) notNil ifTrue:[
- sym := (spc name , '::' , string) asSymbolIfInterned.
- sym notNil ifTrue:[
- (cls := Smalltalk at:sym) isBehavior ifTrue:[
- stringText := self asClassLink:sym.
- string := stringText , ': '.
- cls name = sym ifFalse:[
- string := string , 'refers to ',cls name,', '
+ aClassOrNil notNil ifTrue:[
+ "namespace & global variables"
+ (spc := aClassOrNil nameSpace) notNil ifTrue:[
+ sym := (spc name , '::' , string) asSymbolIfInterned.
+ sym notNil ifTrue:[
+ (cls := Smalltalk at:sym) isBehavior ifTrue:[
+ stringText := self asClassLink:sym.
+ string := stringText , ': '.
+ cls name = sym ifFalse:[
+ string := string , 'refers to ',cls name,', '
+ ].
+ cls isSharedPool ifTrue:[
+ string := string , 'a sharedPool'.
+ ] ifFalse:[
+ string := string , 'a class'.
+ ].
+
+ string := string , ' in the ''' , spc name , ''' nameSpace'.
+ string := string , ' {', (cls category ? '* no category *') ,'}'.
+ shortText ifFalse:[
+ string := (string
+ , '\\It is only visible within this nameSpace.'
+ , '\Access from the outside is possible'
+ , '\by the special name ''' , spc name , '::' , string , '''.') withCRs
+ ].
+ ^ string withCRs
].
- cls isSharedPool ifTrue:[
- string := string , 'a sharedPool'.
- ] ifFalse:[
- string := string , 'a class'.
- ].
-
- string := string , ' in the ''' , spc name , ''' nameSpace'.
- string := string , ' {', cls category ,'}'.
- shortText ifFalse:[
- string := (string
- , '\\It is only visible within this nameSpace.'
- , '\Access from the outside is possible'
- , '\by the special name ''' , spc name , '::' , string , '''.') withCRs
- ].
- ^ string withCRs
].
].
].
@@ -936,13 +1035,13 @@
"/ string knownAsSymbol ifTrue:[
"globals & symbols"
- explanation := self explainKnownSymbol:string inClass:aClass short:shortText.
+ explanation := self explainKnownSymbol:string inClass:aClassOrNil short:shortText.
explanation notNil ifTrue:[
string isBinarySelector ifTrue:[
"/ some are both known as syntax AND as selector (for example: #| )
tmp1 := self explainSyntax:string short:shortText.
tmp1 notNil ifTrue:[
- ^ tmp1 , '\\also:\\' withCRs , explanation
+ ^ tmp1 , c'\n\nalso:\n\n' , explanation
].
].
^ explanation
@@ -952,14 +1051,14 @@
sel := string , ':'.
Symbol allInstancesDo:[:sym |
(sym startsWith:sel) ifTrue:[
- explanation := self explainKnownSymbol:sym inClass:aClass short:shortText.
+ explanation := self explainKnownSymbol:sym inClass:aClassOrNil short:shortText.
explanation notNil ifTrue:[ ^ explanation].
]
].
"/ ].
"try for some obvious things"
- explanation := self explainPseudoVariable:string in:aClass short:true.
+ explanation := self explainPseudoVariable:string in:aClassOrNil short:true.
explanation notNil ifTrue:[ ^ explanation].
].
@@ -970,10 +1069,10 @@
shortText ifTrue:[
|selector|
-
+
(selector := SystemBrowser extractSelectorFrom:string) notNil ifTrue:[
selector ~= string string ifTrue:[
- ^ self explain:selector in:source forClass:aClass short:shortText
+ ^ self explain:selector in:source forClass:aClassOrNil short:shortText
].
].
someText size == 1 ifTrue:[
@@ -993,39 +1092,50 @@
"Created: / 03-12-1995 / 12:47:37 / cg"
"Modified: / 16-04-1997 / 12:46:11 / stefan"
"Modified: / 23-08-2017 / 12:44:12 / cg"
+ "Modified: / 08-06-2019 / 14:04:00 / Claus Gittinger"
!
-explainGlobal:string inClass:aClass short:shortText
+explainGlobal:string inClass:aClassOrNil short:shortText
"return an explanation or nil"
- ^ self explainGlobalOrPoolVariable:string inClass:aClass short:shortText
+ ^ self explainGlobalOrPoolVariable:string inClass:aClassOrNil short:shortText
"Modified: / 14-10-2010 / 11:33:17 / cg"
"Modified (comment): / 28-02-2012 / 10:45:58 / cg"
+ "Modified (format): / 04-03-2019 / 10:09:52 / Claus Gittinger"
!
-explainGlobalOrPoolVariable:varName inClass:aClass short:shortText
+explainGlobalOrPoolVariable:varName inClass:aClassOrNil short:shortText
"return an explanation or nil"
- |template bindings
+ |template shortTemplate bindings
sym explanation val pool valText doc|
"if not even known as key, it's definitely not a global"
sym := varName asSymbolIfInterned.
sym isNil ifTrue:[^ nil].
- template := nil.
+ template := shortTemplate := nil.
bindings := Dictionary new.
"a pool variable?"
- aClass notNil ifTrue:[
- aClass theNonMetaclass sharedPoolNames do:[:eachPoolName |
- pool := Smalltalk at:eachPoolName.
+ aClassOrNil notNil ifTrue:[
+ |nonMeta|
+
+ nonMeta := aClassOrNil theNonMetaclass.
+ nonMeta sharedPoolNames do:[:eachPoolName |
+ pool := nonMeta nameSpace isNameSpace
+ ifTrue:[nonMeta nameSpace at:eachPoolName]
+ ifFalse:[nonMeta topNameSpace at:eachPoolName].
+ pool isNil ifTrue:[
+ pool := Smalltalk at:eachPoolName.
+ ].
pool isNil ifTrue:[
"/ oops - on the fly we encountered a non existing pool...
] ifFalse:[
(pool classVarNames includes:varName) ifTrue:[
template := '%(varName): pool variable in "%(poolName)"'.
+ shortTemplate := '%1 in pool "%2"' bindWith:varName with:eachPoolName.
bindings at:'poolName' put:eachPoolName.
val := pool classVarAt:sym.
].
@@ -1079,7 +1189,7 @@
explanation := explanation , (val isLoaded ifTrue:['a'] ifFalse:['an autoloaded']).
explanation := explanation , (val isSharedPool ifTrue:[' sharedPool'] ifFalse:[' class']).
explanation := explanation , ' categorized as "' , val category , '"'.
- explanation := explanation , '\' withCRs , 'in the "' , val package , '" package.'.
+ explanation := explanation , c'\n' , 'in the "' , val package , '" package.'.
(doc := val commentOrDocumentationString) notEmptyOrNil ifTrue:[
doc := doc asStringCollection.
doc size > 25 ifTrue:[
@@ -1087,7 +1197,7 @@
doc add:''; add:' ... <more documentation cut off>'.
].
doc := doc asString withColor:(UserPreferences current commentColor).
- explanation := explanation,'\\' withCRs,val name,'''s documentation:\'withCRs, doc
+ explanation := explanation,'\n\n',val name,'''s documentation:\n', doc
].
^ explanation.
].
@@ -1099,10 +1209,10 @@
^ explanation.
].
- valText := self valueStringFor:val.
+ valText := self safeValueStringFor:val.
shortText ifTrue:[
- ^ '%1: a global (%2)'
+ ^ (shortTemplate ? '%1: a global (%2)')
bindWith:varName
with:(self asLink:valText to:(self actionToBrowseClass:val class selector:nil))
].
@@ -1115,19 +1225,31 @@
"Created: / 14-10-2010 / 11:33:04 / cg"
"Modified: / 16-11-2016 / 13:08:07 / cg"
"Modified: / 05-05-2016 / 00:25:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 30-06-2019 / 03:46:10 / Claus Gittinger"
!
-explainHereIn:aClass short:shortText
+explainHereIn:aClassOrNil short:shortText
"return an explanation"
|className|
- className := aClass name.
-
+ aClassOrNil isNil ifTrue:[
+ shortText ifTrue:[
+ ^ '"here" - message lookup always starts in the method''s class (always call local method).'
+ ].
+ ^ 'like "self", "','here'allBold,'" refers to the object which received the message.
+
+However, when sending a message to "here", the search for methods
+implementing this message will start in the defining class,
+instead of the receiver''s class.
+Thus, using "here", redefined methods will NOT be reached with a here-send and it is ensured,
+that the local method is called.'
+ ].
+
+ className := aClassOrNil name.
shortText ifTrue:[
^ '"here" - message lookup always starts in "%1" (always call local method).' bindWith:className
].
-
^ 'like "self", "','here'allBold,'" refers to the object which received the message.
However, when sending a message to "here", the search for methods
@@ -1137,11 +1259,14 @@
that the local method is called.'
"Created: / 28-02-2012 / 10:44:55 / cg"
+ "Modified: / 04-03-2019 / 10:14:00 / Claus Gittinger"
!
explainInstanceVariable:instVarName inClass:aClass short:shortText
|varNameInText classNameInText template stringText setOfTypes typesDescription|
+ aClass isNil ifTrue:[^ nil].
+
varNameInText := instVarName allBold.
classNameInText := aClass name.
@@ -1171,6 +1296,8 @@
stringText := stringText,' (',typesDescription,')'
].
^ stringText
+
+ "Modified: / 04-03-2019 / 10:14:32 / Claus Gittinger"
!
explainKnownSymbol:string inClass:aClass
@@ -1181,7 +1308,7 @@
"Modified (comment): / 28-02-2012 / 10:45:40 / cg"
!
-explainKnownSymbol:string inClass:aClass short:shortText
+explainKnownSymbol:string inClass:aClassOrNil short:shortText
"return an explanation or nil"
|sym expl|
@@ -1191,13 +1318,13 @@
"try globals and pools"
(Smalltalk includesKey:sym) ifTrue:[
- expl := self explainGlobalOrPoolVariable:string inClass:aClass short:shortText.
+ expl := self explainGlobalOrPoolVariable:string inClass:aClassOrNil short:shortText.
expl notNil ifTrue:[^ expl].
].
- expl := self explainSelector:string inClass:aClass short:shortText.
+ expl := self explainSelector:string inClass:aClassOrNil short:shortText.
expl notNil ifTrue:[^ expl].
- ^ self explainGlobalOrPoolVariable:string inClass:aClass short:shortText.
+ ^ self explainGlobalOrPoolVariable:string inClass:aClassOrNil short:shortText.
"Modified: / 18-01-2011 / 19:13:07 / cg"
"Modified (comment): / 28-02-2012 / 10:46:06 / cg"
@@ -1213,19 +1340,19 @@
"Modified (format): / 28-02-2012 / 10:47:17 / cg"
!
-explainPseudoVariable:string in:aClass short:shortText
+explainPseudoVariable:string in:aClassOrNil short:shortText
"return an explanation for the pseudoVariables self, super etc."
(string = 'self') ifTrue:[
- ^ self explainSelfIn:aClass short:shortText
+ ^ self explainSelfIn:aClassOrNil short:shortText
].
(string = 'super') ifTrue:[
- ^ self explainSuperIn:aClass short:shortText
+ ^ self explainSuperIn:aClassOrNil short:shortText
].
(string = 'here') ifTrue:[
- ^ self explainHereIn:aClass short:shortText
+ ^ self explainHereIn:aClassOrNil short:shortText
].
(string = 'thisContext') ifTrue:[
@@ -1271,7 +1398,7 @@
"Modified (comment): / 28-02-2012 / 10:46:18 / cg"
!
-explainSelector:string inClass:aClass short:shortText
+explainSelector:string inClass:aClassOrNil short:shortText
"return an explanation or nil"
|selector listOfImplementingClasses listOfImplementingClassNames listOfSimilarSelectors
@@ -1317,14 +1444,14 @@
].
].
- (aClass canUnderstand:selector) ifTrue:[
- s2 := ('Instances of ''' , aClass name , ''' respond to #') , selector "allBold" , '.'.
+ (aClassOrNil notNil and:[aClassOrNil canUnderstand:selector]) ifTrue:[
+ s2 := ('Instances of ''' , aClassOrNil name , ''' respond to #') , selector "allBold" , '.'.
shortText ifFalse:[
s2 := '\\' , s2
- , '\- inherited from ' withCRs
- , (aClass whichClassIncludesSelector:selector) name "allBold".
+ , c'\n- inherited from '
+ , (aClassOrNil whichClassIncludesSelector:selector) name "allBold".
].
- firstImplementingClass := (aClass whichClassIncludesSelector:selector)
+ firstImplementingClass := (aClassOrNil whichClassIncludesSelector:selector)
] ifFalse:[
s2 := ''.
].
@@ -1512,7 +1639,7 @@
].
].
cm notNil ifTrue:[
- cm := (' %1 says:\' withCRs bindWith:(self asClassLink:classProvidingComment name)),cm.
+ cm := (c'%1 says:\n' bindWith:(self asClassLink:classProvidingComment name)),cm.
"/ msg := msg,(msg last isSeparator ifTrue:[''] ifFalse:[' ']),cm
msg := msg,(Character cr),cm
@@ -1557,9 +1684,10 @@
"Created: / 23-03-1999 / 13:29:33 / cg"
"Modified: / 01-05-2016 / 15:42:24 / cg"
"Modified: / 22-05-2017 / 11:35:31 / mawalch"
+ "Modified: / 04-03-2019 / 10:16:07 / Claus Gittinger"
!
-explainSelfIn:aClass short:shortText
+explainSelfIn:aClassOrNil short:shortText
"return an explanation"
|subClasses subNames selfString className nSubClasses
@@ -1567,11 +1695,15 @@
selfString := '''' , 'self' "allBold" , ''''.
- subClasses := aClass allSubclasses.
+ aClassOrNil isNil ifTrue:[
+ ^ selfString , 'refers to the object which received the message.'
+ ].
+
+ subClasses := aClassOrNil allSubclasses.
nSubClasses := subClasses size.
- aClass isMeta ifTrue:[
- className := aClass theNonMetaclass name.
+ aClassOrNil isMeta ifTrue:[
+ className := aClassOrNil theNonMetaclass name.
subNames := subClasses collect:[:c | c theNonMetaclass name].
shortText ifTrue:[
classLink := (self asClassLink:className).
@@ -1611,9 +1743,9 @@
or one of its ' , nSubClasses printString , ' subclasses.'
].
- subClasses := aClass allSubclasses.
+ subClasses := aClassOrNil allSubclasses.
subNames := subClasses collect:[:c | c theNonMetaclass name].
- className := aClass name.
+ className := aClassOrNil name.
shortText ifTrue:[
classLink := self asClassLink:className.
nSubClasses == 0 ifTrue:[
@@ -1654,12 +1786,16 @@
"Modified (comment): / 28-02-2012 / 10:47:06 / cg"
!
-explainSuperIn:aClass short:shortText
+explainSuperIn:aClassOrNil short:shortText
"return an explanation"
|superName|
- superName := aClass superclass name.
+ aClassOrNil isNil ifTrue:[
+ ^ '"super" - message lookup starts in superclass (call redefined method).'
+ ].
+
+ superName := aClassOrNil superclass name.
shortText ifTrue:[
^ '"super" - message lookup starts in superclass "%1" (call redefined method).' bindWith:(self asClassLink:superName)
@@ -1669,10 +1805,11 @@
However, when sending a message to "super", the search for methods
implementing this message will start in the superclass (' , superName , '),
-instead of the receiver''s class (' , aClass name , ' or subclass).
+instead of the receiver''s class (' , aClassOrNil name , ' or subclass).
Thus, using "super", a redefined method can call the original (redefined) method of its superclass.'
"Modified (comment): / 28-02-2012 / 10:47:03 / cg"
+ "Modified: / 04-03-2019 / 10:17:44 / Claus Gittinger"
!
explainSyntax:string
@@ -1820,7 +1957,7 @@
defines a block.
Blocks represent pieces of executable code. The definition of a block does
-not evaluate it, instead a reference to the blocks computation is created.
+not evaluate it, instead a reference to the block''s computation is created.
The block can be evaluated later, by sending it a value/value: message
(it can be even evaluated multiple times).
Blocks are often passed as arguments to Booleans (i.e. "bool ifTrue:[...]"),
@@ -1946,6 +2083,17 @@
^ nil
"Modified: / 28-07-2017 / 10:32:11 / cg"
+ "Modified: / 13-03-2019 / 10:25:48 / Claus Gittinger"
+!
+
+safeValueStringFor:aValue
+ Error handle:[:ex |
+ ^ 'Error in storeString: ',ex description
+ ] do:[
+ ^ self valueStringFor:aValue
+ ]
+
+ "Created: / 08-06-2019 / 14:03:38 / Claus Gittinger"
!
typeDescriptionFor:setOfTypes andSelector:selectorOrNil
@@ -2008,6 +2156,10 @@
valueStringFor:aValue
|valString|
+ aValue isProtoObject ifTrue:[
+ ^ aValue printString
+ ].
+
"/ only show the value, if it is really short...
(aValue isBoolean
or:[aValue isNil
@@ -2032,11 +2184,19 @@
or:[ valString size > 50
or:[ valString includes:Character cr ]]) ifTrue:[
valString := aValue classNameWithArticle.
+ (aValue class includesBehavior:Collection) ifTrue:[
+ aValue size == 0 ifTrue:[
+ valString := valString,'; empty'
+ ] ifFalse:[
+ valString := valString,('; size=%1' bindWith:aValue size)
+ ].
+ ].
].
^ valString
- "Modified: / 14-10-2010 / 11:57:52 / cg"
+ "Modified: / 08-06-2019 / 14:02:57 / Claus Gittinger"
+ "Modified: / 27-05-2020 / 17:41:25 / cg"
! !
!Explainer class methodsFor:'naive type inferer'!
@@ -2174,6 +2334,30 @@
"Modified: / 10-10-2017 / 16:57:09 / cg"
!
+addTypesAssignedToInstvar:instVarName inClass:aClass method:methodOrNil source:code to:setOfTypes
+ "look to asssignments to an instance variable, and pick up low hanging class information.
+ This is far from being complete, but often gives a hint good enough for code completion
+ and info in the browser."
+
+ |tree parserClass lang parser|
+
+ "/ quick check (avoids expensive parse)
+ (code includesString:instVarName) ifFalse:[ ^ self ].
+ parserClass := Parser.
+ (methodOrNil notNil
+ and:[(lang := methodOrNil programmingLanguage) notNil]) ifTrue:[
+ parserClass := lang parserClass.
+ ].
+ parser := parserClass parseMethod:code in:aClass.
+ tree := parser tree.
+ "/ tree := parserClass parseMethod:code in:aClass.
+ (tree isNil or:[tree == #Error]) ifTrue:[ ^ self ]. "/ unparsable
+
+ self addTypesAssignedToInstvar:instVarName inTree:tree to:setOfTypes using:(parserClass parseNodeVisitorClass new).
+
+ "Created: / 30-04-2016 / 15:09:18 / cg"
+!
+
addTypesAssignedToInstvar:instVarName inClass:aClass method:aMethod to:setOfTypes
"look to asssignments to an instance variable, and pick up low hanging class information.
This is far from being complete, but often gives a hint good enough for code completion
@@ -2186,30 +2370,12 @@
code := aMethod source.
].
(code notNil) ifTrue:[
- self addTypesAssignedToInstvar:instVarName inClass:aClass source:code to:setOfTypes
+ self addTypesAssignedToInstvar:instVarName inClass:aClass method:aMethod source:code to:setOfTypes
]
"Created: / 30-04-2016 / 15:07:33 / cg"
!
-addTypesAssignedToInstvar:instVarName inClass:aClass source:code to:setOfTypes
- "look to asssignments to an instance variable, and pick up low hanging class information.
- This is far from being complete, but often gives a hint good enough for code completion
- and info in the browser."
-
- |tree|
-
- "/ quick check (avoids expensive parse)
- (code includesString:instVarName) ifFalse:[ ^ self ].
-
- tree := Parser parse:code class:aClass.
- (tree isNil or:[tree == #Error]) ifTrue:[ ^ self ]. "/ unparsable
-
- self addTypesAssignedToInstvar:instVarName inTree:tree to:setOfTypes.
-
- "Created: / 30-04-2016 / 15:09:18 / cg"
-!
-
addTypesAssignedToInstvar:instVarName inClass:aClass to:setOfTypes
"look to asssignments to an instance variable, and pick up low hanging class information.
This is far from being complete, but often gives a hint good enough for code completion
@@ -2222,14 +2388,11 @@
"Created: / 30-04-2016 / 14:52:56 / cg"
!
-addTypesAssignedToInstvar:instVarName inTree:tree to:setOfTypes
+addTypesAssignedToInstvar:instVarName inTree:tree to:setOfTypes using:visitor
"look to asssignments to an instance variable, and pick up low hanging class information.
This is far from being complete, but often gives a hint good enough for code completion
and info in the browser."
- |visitor|
-
- visitor := PluggableParseNodeVisitor new.
visitor
actionForNodeClass:AssignmentNode
put:[:node |
@@ -2237,11 +2400,20 @@
self addTypeOfExpressionNode:(node expression) forAssignmentTo:instVarName to:setOfTypes
].
true "/ yes - visit subnodes
- ].
+ ].
+ visitor
+ actionForNodeClass:JavaScriptParser::JavaScriptAssignmentNode
+ put:[:node |
+ (node variable isInstanceVariableNamed:instVarName) ifTrue:[
+ self addTypeOfExpressionNode:(node expression) forAssignmentTo:instVarName to:setOfTypes
+ ].
+ true "/ yes - visit subnodes
+ ].
visitor visit:tree.
!
addTypesAssignedToLocal:localName inTree:tree to:setOfTypes
+ <resource: #todo>
"look to asssignments to a local variable, and pick up low hanging class information.
This is far from being complete, but often gives a hint good enough for code completion
and info in the browser."
@@ -2249,6 +2421,8 @@
|visitor|
"/ hack, allowing to deal with both types of AST (sigh)
+ "/ ugly; TODO: unify RB-framework with STX's parser framework.
+ #TODO.
(tree isKindOf:(Smalltalk at:#RBProgramNode)) ifTrue:[
visitor := (Smalltalk at:#RBPluggableProgramNodeVisitor) new.
visitor
@@ -2264,7 +2438,7 @@
].
visitor visitNode:tree.
] ifFalse:[
- visitor := PluggableParseNodeVisitor new.
+ visitor := ParseNodeVisitor new.
visitor
actionForNodeClass:AssignmentNode
put:[:node |
@@ -2465,12 +2639,14 @@
infoStringForClasses:aCollectionOfClasses withPrefix:prefix
"get a nice user readable list for some classes.
- Up to 4 are named, otherwise the count is presented.
- The prefix can be sth like ' other', ' sub', ' super',
- ' implementing' etc. Or it can be an empty string.
- To be shown in the info line at the bottom."
-
- |nClassNames sortedByName classNames link1 link2 link3 link4|
+ Up to 4 are listed by name, otherwise the count is presented.
+ The prefix can be sth like 'other ', 'sub', 'super',
+ 'implementing ' etc.
+ Or it can be an empty string.
+ The returned string is meant to be shown in the info line at the bottom."
+
+ |nClassNames sortedByName classNames
+ commonSuperClass link1 link2 link3 link4|
aCollectionOfClasses isEmpty ifTrue:[
^ 'No %1classes' bindWith:prefix.
@@ -2509,12 +2685,32 @@
with:link4.
].
].
+ commonSuperClass := Class commonSuperclassOf:aCollectionOfClasses.
+ (aCollectionOfClasses includes:commonSuperClass) ifTrue:[
+ ^ self
+ asLink:('%1 and %2 additional %3classes'
+ bindWith:commonSuperClass theNonMetaclass name
+ with:(nClassNames - 1)
+ with:prefix)
+ info:'Browse classes'
+ to:(self actionToBrowseClasses:aCollectionOfClasses)
+ ].
+
^ self
asLink:('%1 %2classes' bindWith:nClassNames printString with:prefix)
info:'Browse classes'
to:(self actionToBrowseClasses:aCollectionOfClasses)
+ "
+ self infoStringForClasses:{ Array } withPrefix:'sub'
+ self infoStringForClasses:{ Array . Point } withPrefix:'sub'
+ self infoStringForClasses:{ Array . Point . Integer . Float} withPrefix:'sub'
+ self infoStringForClasses:{ Array . Point . Integer . Float . Fraction} withPrefix:'sub'
+ self infoStringForClasses:{ Number . Integer . Float . Fraction . SmallInteger} withPrefix:'sub'
+ "
+
"Modified: / 27-07-2006 / 10:09:02 / cg"
+ "Modified: / 27-03-2019 / 10:42:24 / Claus Gittinger"
!
infoStringForClasses:aCollectionOfClasses withPrefix:prefix actionGenerator:actionGeneratorOrNil
@@ -2789,25 +2985,33 @@
!
thisOrNewBrowserInto:aTwoArgBlock
- "if I am invoked by a browser,
- invoke the twoArgBlock withit and an #newBuffer arg.
+ "I am invoked when user clicks on a link in the info line.
+ If I am invoked by a browser, invoke the twoArgBlock with it and a #newBuffer arg.
Otherwise, create a new (invisible) browser and pass it to the block
with a #newBrowser arg."
- |windowGroupClass browserClass wg app|
+ |windowGroupClass browserClass wg app dummyBrowser|
"/ stupid: I am in libcomp; should be in libtool
+ "/ access by name, so we do not introduce new prerequisites on the package
windowGroupClass := Smalltalk at:#WindowGroup.
windowGroupClass isNil ifTrue:[^ self].
- browserClass := Smalltalk at:#'Tools::NewSystemBrowser'.
+ browserClass := Smalltalk at:#'SystemBrowser'.
+ browserClass isNil ifTrue:[^ self].
+ browserClass := browserClass default.
browserClass isNil ifTrue:[^ self].
((wg := windowGroupClass activeGroup) notNil
and:[ (app := wg application) isKindOf:browserClass ]
) ifTrue:[
^ aTwoArgBlock value:app value:#newBuffer
- ].
- ^ aTwoArgBlock value:(browserClass basicNew) value:#newBrowser
+ ].
+ "/ invoked by some other tool
+ dummyBrowser := browserClass basicNew.
+ dummyBrowser initializeResources.
+ ^ aTwoArgBlock value:dummyBrowser value:#newBrowser
+
+ "Modified (comment): / 24-05-2018 / 15:01:01 / Claus Gittinger"
! !
!Explainer::ActionWithInfo class methodsFor:'instance creation'!
@@ -2823,16 +3027,16 @@
info := infoArg.
!
+info
+ ^ info
+!
+
info:something
info := something.
! !
!Explainer::ActionWithInfo methodsFor:'evaluation'!
-info
- ^ info
-!
-
value
^ block value
!
--- a/InstrumentedMethod.st Sat Aug 08 22:49:53 2020 +0100
+++ b/InstrumentedMethod.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2010 by eXept Software AG
All Rights Reserved
@@ -147,6 +149,8 @@
!
isInstrumented
+ "return true, if this is an instrumented method."
+
^ true
"Created: / 27-04-2010 / 12:25:39 / cg"
@@ -155,6 +159,6 @@
!InstrumentedMethod class methodsFor:'documentation'!
version_CVS
- ^ '$Header: /cvs/stx/stx/libcomp/InstrumentedMethod.st,v 1.12 2015-01-29 18:17:17 cg Exp $'
+ ^ '$Header$'
! !
--- a/InstrumentingCompiler.st Sat Aug 08 22:49:53 2020 +0100
+++ b/InstrumentingCompiler.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2010 by Claus Gittinger
All Rights Reserved
@@ -150,6 +152,13 @@
"
! !
+!InstrumentingCompiler class methodsFor:'cleanup'!
+
+cleanAllInfos
+ InstrumentationInfo cleanAllInfoWithChange:false.
+ MethodInvocationInfo cleanAllInfoWithChange:false.
+! !
+
!InstrumentingCompiler class methodsFor:'compilation-public'!
compileClass:aClass
@@ -163,16 +172,26 @@
compileMethod:aMethod
"compile a single method with instrumentation"
- Class withoutUpdatingChangesDo:[
- Class packageQuerySignal answer: aMethod package do:[
- self
- compile:(aMethod source)
- forClass:(aMethod mclass)
- inCategory:(aMethod category)
+ aMethod isInstrumented ifTrue:[^ self].
+ aMethod hasPrimitiveCode ifTrue:[^ self].
+ aMethod isSubclassResponsibility ifTrue:[^ self].
+ (aMethod hasAnnotation:#noCoverage) ifTrue:[^ self].
+ ClassLoadInProgressQuery answer:true do:[
+ Error handle:[:ex |
+ Transcript showCR:'error instrumenting: %1' with:aMethod.
+ Transcript showCR:' %1' with:ex description.
+ ex reject.
+ ] do:[
+ Class withoutUpdatingChangesDo:[
+ Class packageQuerySignal answer: aMethod package do:[
+ self
+ compile:(aMethod source)
+ forClass:(aMethod mclass)
+ inCategory:(aMethod category)
+ ]
+ ]
]
]
-
- "Modified: / 28-07-2013 / 16:59:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
compilePackage:aPackageID
@@ -437,7 +456,7 @@
thisStatement isNil ifTrue:[^ firstStatementArg].
firstStatement := self statementCounterBefore:thisStatement.
statementInfo := firstStatement expression receiver value.
- statementInfo endPosition: thisStatement endPosition.
+ statementInfo endPosition:(thisStatement endPosition).
[true] whileTrue:[
@@ -469,6 +488,7 @@
"Modified (comment): / 30-09-2011 / 12:15:52 / cg"
"Modified: / 29-07-2013 / 00:11:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 15-02-2019 / 14:39:55 / Claus Gittinger"
!
variableReadRewriteHookFor:aVariableNode
@@ -479,6 +499,12 @@
"Created: / 30-09-2011 / 12:27:47 / cg"
! !
+!InstrumentingCompiler methodsFor:'ignored error handling'!
+
+undefError:varName position:pos1 to:pos2
+ ^ #continue
+! !
+
!InstrumentingCompiler methodsFor:'redefinable'!
blockExecutionInfoInstance
@@ -588,16 +614,17 @@
!InstrumentingCompiler::StatementExecutionInfo methodsFor:'debugging'!
inspector2TabSource
-
| source |
source := owningMethod source asText.
startPosition isNil ifTrue:[
- source withColor: Color red.
+ source allRed.
] ifFalse:[
endPosition isNil ifTrue:[
- source emphasizeFrom:startPosition to:source string size with: #bold.
- source emphasizeFrom:startPosition to:source string size with: #color -> Color red.
+ |end|
+ end := source string size.
+ source emphasizeFrom:startPosition to:end with: #bold.
+ source emphasizeFrom:startPosition to:end with: #color -> Color red.
] ifFalse:[
source emphasizeFrom:startPosition to: endPosition with: #bold.
source emphasizeFrom:startPosition to: endPosition with: #color -> Color blue.
@@ -657,6 +684,25 @@
"Modified: / 23-08-2011 / 21:29:39 / cg"
! !
+!InstrumentingCompiler::StatementExecutionInfo methodsFor:'printing'!
+
+printOn:aStream
+ aStream nextPutAll:'['.
+ startPosition printOn:aStream.
+ aStream nextPutAll:'...'.
+ endPosition printOn:aStream.
+ aStream nextPutAll:' | count: '.
+ count printOn:aStream.
+ aStream nextPutAll:' | code: '.
+ (owningMethod source asString
+ copyFrom:startPosition
+ to:endPosition) printOn:aStream.
+ aStream nextPutAll:']'.
+
+ "Created: / 21-08-2011 / 14:02:01 / cg"
+ "Modified: / 22-03-2019 / 08:43:56 / Claus Gittinger"
+! !
+
!InstrumentingCompiler::StatementExecutionInfo methodsFor:'private'!
changeClassToAlreadyEntered
@@ -762,8 +808,9 @@
!
invokingMethodsDo:aBlock
- infoPerReceiverClass isNil ifTrue:[ ^ self].
- ^ infoPerReceiverClass do:[:eachInfo | eachInfo invokingMethodsDo:aBlock].
+ infoPerReceiverClass notNil ifTrue:[
+ infoPerReceiverClass do:[:eachInfo | eachInfo invokingMethodsDo:aBlock].
+ ]
!
numberOfInvocations
@@ -872,6 +919,19 @@
"Modified (comment): / 26-10-2012 / 12:59:44 / cg"
! !
+!InstrumentingCompiler::MethodInvocationInfo methodsFor:'printing'!
+
+printOn:aStream
+ aStream nextPutAll:'[count: '.
+ count printOn:aStream.
+ aStream nextPutAll:' | method: '.
+ (owningMethod whoString) printOn:aStream.
+ aStream nextPutAll:']'.
+
+ "Created: / 21-08-2011 / 14:02:01 / cg"
+ "Modified: / 22-03-2019 / 08:43:56 / Claus Gittinger"
+! !
+
!InstrumentingCompiler::MethodInvocationInfo methodsFor:'private'!
changeClassToAlreadyEntered
@@ -1098,18 +1158,6 @@
].
! !
-!InstrumentingCompiler::BlockExecutionInfo methodsFor:'printing'!
-
-printOn:aStream
- aStream nextPutAll:'['.
- startPosition printOn:aStream.
- aStream nextPutAll:'...'.
- endPosition printOn:aStream.
- aStream nextPutAll:']'.
-
- "Created: / 21-08-2011 / 14:02:01 / cg"
-! !
-
!InstrumentingCompiler::BlockExecutionInfo methodsFor:'testing'!
isBlockExecutionInfo
--- a/LazyMethod.st Sat Aug 08 22:49:53 2020 +0100
+++ b/LazyMethod.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
@@ -118,14 +120,13 @@
|sender spec class selector|
+ sender := thisContext sender.
+ selector := sender selector.
+
"compile the method"
self makeRealMethod isNil ifTrue:[
- "
- compilation failed
- "
- selector := thisContext sender selector.
-
+ "/ compilation failed
class := self containingClass.
class notNil ifTrue:[
spec := class name , '>>' , selector
@@ -146,8 +147,9 @@
As a general rule: never edit autoloaded classes from anything
except the browser - to check that they work and are compilable.
"
- ^ CompilationFailedSignal raiseRequestWith:self
- errorString:('compilation of lazy method ' , spec , ' failed')
+ ^ CompilationFailedSignal
+ raiseRequestWith:self
+ errorString:('compilation of lazy method ' , spec , ' failed')
].
"
@@ -156,21 +158,24 @@
ThisContext sender is the context of the original send (the failed one)
"
- sender := thisContext sender.
ObjectMemory flushCaches.
- ^ self valueWithReceiver:(sender receiver)
- arguments:(sender args)
- selector:(sender selector)
- search:(sender searchClass)
- sender:nil
+ ^ self
+ valueWithReceiver:(sender receiver)
+ arguments:(sender args)
+ selector:selector
+ search:(sender searchClass)
+ sender:nil
"Modified (comment): / 21-11-2017 / 13:02:50 / cg"
+ "Modified (format): / 03-04-2019 / 22:39:44 / Claus Gittinger"
! !
!LazyMethod methodsFor:'queries'!
isLazyMethod
+ "return true, if this is a lazy method"
+
^ true
!
@@ -193,7 +198,8 @@
!
messagesSent
- "cannot ask a lazyMethod for messagesSent ..."
+ "cannot ask a lazyMethod for messagesSent...
+ Try to autoload, then ask that method."
|m|
--- a/Make.proto Sat Aug 08 22:49:53 2020 +0100
+++ b/Make.proto Tue Aug 25 12:20:06 2020 +0100
@@ -11,6 +11,8 @@
# make clean - clean all temp files
# make clobber - clean all
#
+# export MAKE_ARGS=-j4 ; make
+#
# This file contains definitions for Unix based platforms.
# It shares common definitions with the win32-make in Make.spec.
@@ -123,7 +125,7 @@
# build all mandatory prerequisite packages (containing superclasses) for this package
prereq:
- cd ../libbasic && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ cd ../libbasic && $(MAKE) $(MAKE_ARGS) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
@@ -136,7 +138,7 @@
-rm -f *.s *.s2
clean::
- -rm -f *.o *.H
+ -rm -f *.$(O) *.$(H)
clobber:: clean
-rm -f *.so *.dll
@@ -148,6 +150,7 @@
$(OUTDIR)BreakpointQuery.$(O) BreakpointQuery.$(C) BreakpointQuery.$(H): BreakpointQuery.st $(INCLUDE_TOP)/stx/libbasic/GenericException.$(H) $(INCLUDE_TOP)/stx/libbasic/Notification.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/Query.$(H) $(STCHDR)
$(OUTDIR)CompilationErrorHandler.$(O) CompilationErrorHandler.$(C) CompilationErrorHandler.$(H): CompilationErrorHandler.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)CompilationErrorHandlerQuery.$(O) CompilationErrorHandlerQuery.$(C) CompilationErrorHandlerQuery.$(H): CompilationErrorHandlerQuery.st $(INCLUDE_TOP)/stx/libbasic/GenericException.$(H) $(INCLUDE_TOP)/stx/libbasic/Notification.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/Query.$(H) $(STCHDR)
+$(OUTDIR)DoEnableCompilerOptionActionQuery.$(O) DoEnableCompilerOptionActionQuery.$(C) DoEnableCompilerOptionActionQuery.$(H): DoEnableCompilerOptionActionQuery.st $(INCLUDE_TOP)/stx/libbasic/GenericException.$(H) $(INCLUDE_TOP)/stx/libbasic/Notification.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/Query.$(H) $(STCHDR)
$(OUTDIR)DIEntry.$(O) DIEntry.$(C) DIEntry.$(H): DIEntry.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)DIInfoVersions.$(O) DIInfoVersions.$(C) DIInfoVersions.$(H): DIInfoVersions.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/SharedPool.$(H) $(STCHDR)
$(OUTDIR)DISectionTypes.$(O) DISectionTypes.$(C) DISectionTypes.$(H): DISectionTypes.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/SharedPool.$(H) $(STCHDR)
--- a/Make.spec Sat Aug 08 22:49:53 2020 +0100
+++ b/Make.spec Tue Aug 25 12:20:06 2020 +0100
@@ -56,6 +56,7 @@
BreakpointQuery \
CompilationErrorHandler \
CompilationErrorHandlerQuery \
+ DoEnableCompilerOptionActionQuery \
DIEntry \
DIInfoVersions \
DISectionTypes \
@@ -134,6 +135,7 @@
$(OUTDIR)BreakpointQuery.$(O) \
$(OUTDIR)CompilationErrorHandler.$(O) \
$(OUTDIR)CompilationErrorHandlerQuery.$(O) \
+ $(OUTDIR)DoEnableCompilerOptionActionQuery.$(O) \
$(OUTDIR)DIEntry.$(O) \
$(OUTDIR)DIInfoVersions.$(O) \
$(OUTDIR)DISectionTypes.$(O) \
--- a/MessageNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/MessageNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -56,6 +56,8 @@
!
receiver:recNode selector:selectorString arg1:arg1Node arg2:arg2Node
+ "return a new MessageNode for a message with 2 arguments"
+
^ self receiver:recNode selector:selectorString arg1:arg1Node arg2:arg2Node fold:nil
!
@@ -311,6 +313,14 @@
"Created: / 26-03-2018 / 15:33:29 / stefan"
! !
+!MessageNode methodsFor:'RBParser compatibility'!
+
+buildSelectorString
+ "for RBParser compat."
+
+ ^ selector
+! !
+
!MessageNode methodsFor:'accessing'!
arg1
@@ -321,6 +331,12 @@
^ argArray at:2
!
+arg3
+ ^ argArray at:3
+
+ "Created: / 30-08-2018 / 13:03:59 / Claus Gittinger"
+!
+
args
^ argArray
!
@@ -348,6 +364,12 @@
endLineNr := something.
!
+javaScriptSelector
+ ^ self selector
+
+ "Created: / 14-02-2019 / 14:38:08 / Claus Gittinger"
+!
+
lineNumber
^ lineNr
!
@@ -370,7 +392,6 @@
!
receiver:r selector:s args:a lineno:l
-
receiver notNil ifTrue:[ receiver parent: nil].
receiver := r.
receiver notNil ifTrue:[
@@ -380,12 +401,11 @@
startPosition := receiver startPosition.
-"/ create the symbol only, if the symbol is already known in the system.
-"/ otherwise a lot of partial symbols will be created by the SyntaxHighlighter
-"/ during typing
-"/ selector := s asSymbol.
-
- selector := s asSymbolIfInterned ? s.
+ "/ create the symbol only, if the symbol is already known in the system.
+ "/ otherwise a lot of partial symbols will be created by the SyntaxHighlighter
+ "/ during typing
+ "/ selector := s asSymbol.
+ selector := s asSymbolIfInternedOrSelf.
argArray notNil ifTrue:[argArray do:[:each| each parent:nil]].
argArray := a.
@@ -393,8 +413,10 @@
be lazy to create a new class - ErrorNode. Results in a mess!!"
argArray ~~ #Error ifTrue:[
argArray notEmptyOrNil ifTrue:[
- argArray do:[:each| each parent:self].
- endPosition := argArray last endPosition
+ argArray do:[:each| each isSymbol ifFalse:[each parent:self]].
+ argArray last isSymbol ifFalse:[
+ endPosition := argArray last endPosition ? endPosition.
+ ].
].
].
@@ -404,6 +426,7 @@
"Modified: / 02-07-1997 / 17:01:24 / cg"
"Modified: / 08-05-2012 / 17:07:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 19-07-2018 / 14:09:59 / Stefan Vogel"
!
selector
@@ -411,21 +434,21 @@
!
selector:s
-"/ create the symbol only, if the symbol is already known in the system.
-"/ otherwise a lot of partial symbols will be created by the SyntaxHighlighter
-"/ during typing
-"/ selector := s asSymbol.
-
- selector := s asSymbolIfInterned ? s.
-"/ selector := s asSymbol.
+ "/ create the symbol only, if the symbol is already known in the system.
+ "/ otherwise a lot of partial symbols will be created by the SyntaxHighlighter
+ "/ during typing
+ "/ selector := s asSymbol.
+ selector := s asSymbolIfInternedOrSelf.
!
selectorPartPositions
^ selectorPartPositions
!
-selectorPartPositions:something
- selectorPartPositions := something.
+selectorPartPositions:aCollectionOfIntervals
+ selectorPartPositions := aCollectionOfIntervals.
+
+ "Modified (format): / 20-03-2019 / 20:51:09 / Claus Gittinger"
!
selectorPosition
@@ -529,7 +552,7 @@
|rec arg1 arg1Value operand|
((selector == #==) or:[selector == #~~]) ifTrue:[
- (argArray size > 0) ifTrue:[
+ (argArray size ~~ 0) ifTrue:[
arg1 := argArray at:1
].
@@ -570,6 +593,7 @@
^ nil
"Modified: / 08-03-2012 / 01:07:33 / cg"
+ "Modified: / 01-03-2019 / 15:59:19 / Claus Gittinger"
!
checkInlinability
@@ -677,7 +701,7 @@
|arg1 msg|
- (argArray size > 0) ifTrue:[
+ (argArray size ~~ 0) ifTrue:[
arg1 := argArray at:1
].
@@ -762,6 +786,7 @@
"Modified: / 28-03-2007 / 14:14:28 / cg"
"Modified (format): / 08-03-2017 / 11:36:03 / cg"
+ "Modified: / 01-03-2019 / 15:59:30 / Claus Gittinger"
! !
!MessageNode methodsFor:'code generation'!
@@ -781,7 +806,7 @@
selector := selector asSymbol.
usedSelector := aCompiler nameSpaceSelectorFor:selector.
- "/ must be added for browsers-search to work on optimized nodes
+ "/ must be added for browser's-search to work on optimized nodes
usedSelector ~~ selector ifTrue:[ aCompiler addLiteral:selector ].
litIndex := aCompiler addLiteral:usedSelector.
@@ -959,9 +984,12 @@
].
].
selector == #to:do: ifTrue:[
- (arg2 isBlock
- and:[arg2 isInlinable
- and:[arg2 numArgs == 1]]) ifTrue:[
+ (receiver isConstant
+ and:[receiver type == #Integer
+ and:[arg2 isBlock
+ and:[arg2 isInlinable
+ and:[arg2 numArgs == 1]]]]
+ ) ifTrue:[
^ self codeToDoOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
]
].
@@ -975,11 +1003,14 @@
(nargs == 3) ifTrue:[
selector == #to:by:do: ifTrue:[
"/ step must be a constant (need to know how to compare)
- (arg2 isConstant
- and:[arg2 type == #Integer
- and:[arg3 isBlock
- and:[arg3 isInlinable
- and:[arg3 numArgs == 1]]]]) ifTrue:[
+ (receiver isConstant
+ and:[receiver type == #Integer
+ and:[arg2 isConstant
+ and:[arg2 type == #Integer
+ and:[arg3 isBlock
+ and:[arg3 isInlinable
+ and:[arg3 numArgs == 1]]]]]]
+ ) ifTrue:[
^ self codeToByDoOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
]
].
@@ -1144,6 +1175,7 @@
"Modified: / 03-09-1995 / 12:55:42 / claus"
"Modified: / 25-05-2012 / 11:29:47 / cg"
"Modified: / 12-04-2013 / 22:42:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 06-03-2019 / 19:40:30 / Claus Gittinger"
! !
!MessageNode methodsFor:'enumerating'!
@@ -1167,6 +1199,15 @@
"Created: / 15-07-2018 / 10:35:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+childrenDo:aBlock
+ "evaluate aBlock for each subnode"
+
+ aBlock value:receiver.
+ argArray notNil ifTrue:[
+ argArray do:aBlock.
+ ]
+!
+
messageSelectorsDo:aBlock
"evaluate aBlock for each message-selector here and in subnodes"
@@ -1208,7 +1249,6 @@
]
! !
-
!MessageNode methodsFor:'evaluation'!
evaluateForCascadeIn:anEnvironment
@@ -1294,7 +1334,6 @@
^ selector asSymbol
! !
-
!MessageNode methodsFor:'optimized code generation'!
codeAndIfElseOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
@@ -1643,9 +1682,19 @@
otherwiseArg isVariable ifFalse:[^ false]
]
].
+
"compile as a nested if"
-
- elseBlock := otherwiseArg ? (ConstantNode value:nil).
+ elseBlock := otherwiseArg.
+ elseBlock isNil ifTrue:[
+ "/ cg: wrong: must create a [ self caseError ] block.
+ "/ elseBlock := (ConstantNode value:nil).
+ elseBlock := BlockNode
+ withExpression:(
+ MessageNode
+ receiver:(receiver isVariable ifTrue:[receiver] ifFalse:[SelfNode value:nil])
+ selector:#'caseError'
+ ) in:b.
+ ].
caseValueExpressions with:caseBlocks reverseDo:[:eachCaseValueExpression :eachCaseBlock |
|cond|
@@ -1882,9 +1931,7 @@
].
needLineNr ifTrue:[
- (lineNr between:1 and:255) ifTrue:[
- aStream nextPut:#lineno; nextPut:lineNr.
- ]
+ self codeLineNumber:lineNr on:aStream for:aCompiler.
].
aStream nextPut:theByteCode.
@@ -1916,6 +1963,7 @@
"
"Modified: / 21-05-2010 / 15:39:15 / cg"
+ "Modified (format): / 19-07-2018 / 14:18:46 / Stefan Vogel"
!
codeIfNilNotNilOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
@@ -1936,20 +1984,16 @@
theReceiver codeOn:aStream inBlock:b for:aCompiler.
needLineNr := true.
- theArg isNil ifTrue:[
- theReceiver isMessage ifTrue:[
- (aCompiler hasLineNumber:(theReceiver selector)) ifTrue:[
- theReceiver lineNumber == lineNr ifTrue:[
- needLineNr := false
- ]
- ]
- ]
+ "what is theArg? It is always nil!!"
+ (theArg isNil
+ and:[theReceiver isMessage
+ and:[(aCompiler hasLineNumber:(theReceiver selector))
+ and:[theReceiver lineNumber == lineNr]]]) ifTrue:[
+ needLineNr := false
].
needLineNr ifTrue:[
- (lineNr between:1 and:255) ifTrue:[
- aStream nextPut:#lineno; nextPut:lineNr.
- ]
+ self codeLineNumber:lineNr on:aStream for:aCompiler.
].
aStream nextPut:theByteCode.
@@ -1969,7 +2013,8 @@
code := aStream contents.
code at:pos2 put:(aStream position + 1)
- "Modified: / 11.2.2000 / 12:50:36 / cg"
+ "Modified: / 11-02-2000 / 12:50:36 / cg"
+ "Modified: / 19-07-2018 / 14:11:13 / Stefan Vogel"
!
codeIfNilOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
@@ -1998,9 +2043,7 @@
].
needLineNr ifTrue:[
- (lineNr between:1 and:255) ifTrue:[
- aStream nextPut:#lineno; nextPut:lineNr.
- ]
+ self codeLineNumber:lineNr on:aStream for:aCompiler.
].
valueNeeded ifTrue:[
@@ -2018,7 +2061,8 @@
code := aStream contents.
code at:pos put:(aStream position + 1)
- "Modified: / 28.10.1997 / 18:33:42 / cg"
+ "Modified: / 28-10-1997 / 18:33:42 / cg"
+ "Modified: / 19-07-2018 / 14:06:52 / Stefan Vogel"
!
codeIfOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
@@ -2082,9 +2126,7 @@
].
needLineNr ifTrue:[
- (lineNr between:1 and:255) ifTrue:[
- aStream nextPut:#lineno; nextPut:lineNr.
- ]
+ self codeLineNumber:lineNr on:aStream for:aCompiler.
].
aStream nextPut:theByteCode.
@@ -2106,7 +2148,8 @@
code at:pos put:(aStream position + 1)
]
- "Modified: / 28.10.1997 / 18:33:42 / cg"
+ "Modified: / 28-10-1997 / 18:33:42 / cg"
+ "Modified: / 19-07-2018 / 14:07:06 / Stefan Vogel"
!
codeOrIfElseOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
@@ -2706,7 +2749,9 @@
!
codeToDoOn:aStream inBlock:b valueNeeded:valueNeeded for:aCompiler
- "generate code for n to:n do:[:unusedArg | ... ]"
+ "generate code for n to:m do:[:unusedArg | ... ]
+ This MAY ONLY be called, if the receiver is known to be an integer
+ or float."
|pos pos2 start stop lateEval theBlock loopVarIndex
stopVarIndex|
@@ -2717,7 +2762,7 @@
"/ debugging somewhat difficult (no loop-value seen in debugger).
start := receiver.
- stop := (argArray at:1).
+ stop := argArray at:1.
"/ stop isConstant ifFalse:[self halt:'should not happen'].
"/ (stop evaluate isMemberOf:SmallInteger) ifFalse:[self halt:'should not happen'].
@@ -2757,7 +2802,7 @@
pos := aStream position + 1.
- aStream nextPut:#lineno; nextPut:lineNr.
+ self codeLineNumber:lineNr on:aStream for:aCompiler.
aStream nextPut:#dup.
stopVarIndex notNil ifTrue:[
@@ -2821,8 +2866,10 @@
]
].
- "Created: 26.6.1997 / 10:58:47 / cg"
- "Modified: 19.10.1997 / 01:31:40 / cg"
+ "Created: / 26-06-1997 / 10:58:47 / cg"
+ "Modified: / 19-10-1997 / 01:31:40 / cg"
+ "Modified: / 19-07-2018 / 14:09:05 / Stefan Vogel"
+ "Modified (comment): / 06-03-2019 / 19:37:02 / Claus Gittinger"
!
codeValueSendOn:aStream for:aCompiler
@@ -3060,8 +3107,8 @@
needLineNr ifTrue:[
self codeLineNumber:lineNr on:aStream for:aCompiler.
+ needLineNr := false.
].
- needLineNr := false.
optByteCode notNil ifTrue:[
theReceiver codeOn:aStream inBlock:b for:aCompiler.
@@ -3115,10 +3162,10 @@
aStream nextPut:pos.
].
-
valueNeeded ifTrue:[aStream nextPut:#pushNil].
- "Modified: 22.10.1996 / 21:34:37 / cg"
+ "Modified: / 22-10-1996 / 21:34:37 / cg"
+ "Modified (format): / 19-07-2018 / 14:24:48 / Stefan Vogel"
!
optimizedConditionFor:aReceiver with:aByteCode for:aCompiler
@@ -3297,21 +3344,21 @@
!MessageNode methodsFor:'queries'!
argumentCount
- "VisualAge/ANSI compatibility - same as numArgs"
+ "ANSI compatibility - same as numArgs"
^ argArray size
!
collectBlocksInto:aCollection
receiver collectBlocksInto:aCollection.
- argArray size > 0 ifTrue:[
+ argArray size ~~ 0 ifTrue:[
argArray do:[:arg |
arg collectBlocksInto:aCollection.
]
].
- "Created: 23.10.1996 / 15:44:49 / cg"
- "Modified: 23.10.1996 / 16:03:46 / cg"
+ "Created: / 23-10-1996 / 15:44:49 / cg"
+ "Modified: / 01-03-2019 / 15:59:25 / Claus Gittinger"
!
containsReturn
@@ -3326,6 +3373,8 @@
!
numArgs
+ "please use argumentCount for ANSI compatibility"
+
^ argArray size
!
--- a/MethodNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/MethodNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -202,6 +202,13 @@
"Modified: / 06-02-2019 / 22:24:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
+!MethodNode methodsFor:'enumerating'!
+
+childrenDo:aBlock
+ self statements:statements do:aBlock
+
+! !
+
!MethodNode methodsFor:'enumeration'!
blockNodesDo:aBlock recursively: aBoolean
@@ -231,7 +238,7 @@
^ self.
].
- n := selector numArgs.
+ n := selector argumentCount.
n == 0 ifTrue:[
aStream nextPutAll:selector printString.
] ifFalse:[
@@ -265,7 +272,7 @@
!MethodNode class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/MethodNode.st,v 1.14 2014-03-24 12:12:59 stefan Exp $'
+ ^ '$Header$'
!
version_HG
--- a/ObjectFileHandle.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ObjectFileHandle.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1995 by Claus Gittinger
All Rights Reserved
@@ -261,7 +263,7 @@
but only if we are sure, that it is not referenced by a snapshot."
snapshot ~~ true ifTrue:[
- OperatingSystem removeFile:pathName.
+ pathName asFilename removeFile.
]
!
@@ -277,36 +279,36 @@
"my method/class object was collected - unload the underlying objectfile"
changedObject == weakMethodRef ifTrue:[
- weakMethodRef nilAllCorpsesAndDo:[:idx |].
+ weakMethodRef nilAllCorpsesAndDo:[:idx |].
].
changedObject == weakClassRefs ifTrue:[
- weakClassRefs nilAllCorpsesAndDo:[:idx |].
+ weakClassRefs nilAllCorpsesAndDo:[:idx |].
].
self isObsolete ifTrue:[
- weakFunctionRefs notNil ifTrue:[
- weakFunctionRefs removeDependent:self.
- weakFunctionRefs := nil.
- ].
- weakClassRefs notNil ifTrue:[
- weakClassRefs removeDependent:self.
- weakClassRefs := nil.
- ].
- weakMethodRef notNil ifTrue:[
- weakMethodRef removeDependent:self.
- weakMethodRef := nil.
- ].
- ('ObjectFileHandle [info]: unloading ' , pathName , ' (method/classes were garbageCollected)') infoPrintCR.
- self unload.
- self removeUnusedObjectFile.
+ weakFunctionRefs notNil ifTrue:[
+ weakFunctionRefs removeDependent:self.
+ weakFunctionRefs := nil.
+ ].
+ weakClassRefs notNil ifTrue:[
+ weakClassRefs removeDependent:self.
+ weakClassRefs := nil.
+ ].
+ weakMethodRef notNil ifTrue:[
+ weakMethodRef removeDependent:self.
+ weakMethodRef := nil.
+ ].
+ Logger info:'ObjectFileHandle: unloading %1 (method/classes were garbageCollected)' with:pathName.
+ self unload.
+ self removeUnusedObjectFile.
].
"Created: 5.12.1995 / 18:05:08 / cg"
"Modified: 30.1.1997 / 20:57:56 / cg"
! !
-!ObjectFileHandle methodsFor:'copying'!
+!ObjectFileHandle methodsFor:'copying-private'!
postCopy
"flush module handles of the copy"
@@ -326,7 +328,7 @@
printOn:aStream
"append a printed representation of the receiver to aStream"
- aStream nextPutAll:self class name; nextPutAll:'(handle=<'.
+ aStream nextPutAll:self className; nextPutAll:'(handle=<'.
sysHandle1 printOn:aStream.
aStream space.
sysHandle2 printOn:aStream.
@@ -346,6 +348,7 @@
"Modified: / 25-04-1996 / 09:44:08 / cg"
"Modified: / 17-02-2017 / 10:35:25 / stefan"
+ "Modified: / 28-06-2019 / 09:05:21 / Claus Gittinger"
! !
!ObjectFileHandle methodsFor:'queries'!
--- a/ObjectFileLoader.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ObjectFileLoader.st Tue Aug 25 12:20:06 2020 +0100
@@ -122,10 +122,6 @@
# include <errno.h>
#endif
-#ifdef BEOS_DL
-# include <be/kernel/image.h>
-#endif
-
#ifdef WIN_DL
# undef INT
# undef UINT
@@ -333,8 +329,8 @@
"/ Verbose := true.
OperatingSystem isMSDOSlike ifTrue:[
- "/ default setup for msc
ParserFlags useBorlandC ifTrue:[
+ "/ default setup for bcc
libDir := '..\lib\bc'.
libDir asFilename exists ifFalse:[
libDir := '..\lib\lib\bc'.
@@ -489,8 +485,8 @@
This makes it troublesome, to recompile a new lib while a smalltalk is being executed.
When CopyLibrariesWhenLoading is true, ddl files are copied to a tempdir before loading,
so that the original can still be recompiled.
- Makes loading a bit slower (due to copying and less sharing/caching of already loaded dlls),
- so it is of by default and must be turned on explicitly during development."
+ Makes loading a bit slower (due to the copying),
+ so it is off by default and must be turned on explicitly during development."
^ CopyLibrariesWhenLoading ? false
@@ -498,6 +494,8 @@
self copyLibrariesWhenLoading
self copyLibrariesWhenLoading:true
"
+
+ "Modified (comment): / 22-07-2018 / 18:10:15 / Stefan Vogel"
!
copyLibrariesWhenLoading:aBoolean
@@ -652,9 +650,6 @@
# if defined(WIN_DL)
RETURN ( @symbol(dll));
# endif
-# if defined(BEOS_DL)
- RETURN ( @symbol(beobj));
-# endif
# if defined(__VMS__)
RETURN ( @symbol(exe));
# endif
@@ -697,20 +692,20 @@
"Modified: / 4.5.1998 / 12:18:47 / cg"
!
-objectFileExtension
+objectFileSuffix
"return the fileName extension used for objects,
as generated by myself (output of cc).
This is very machine specific."
OperatingSystem isMSDOSlike ifTrue:[
"/ includes all of win32s, win95, winNT & os/2
- ^ '.obj'
+ ^ 'obj'
].
OperatingSystem isVMSlike ifTrue:[
- ^ '.obj'
+ ^ 'obj'
].
- ^ '.o'
+ ^ 'o'
"
ObjectFileLoader objectFileExtension
@@ -719,24 +714,6 @@
"Modified: / 4.5.1998 / 12:17:34 / cg"
!
-sharedLibraryExtension
- "return the fileName extension used for dynamic loadable objects,
- as generated by myself (output of linker).
- This is very machine specific."
-
- |suff|
-
- suff := self sharedLibrarySuffix.
- suff notNil ifTrue:[^ '.' , suff].
- ^ suff
-
- "
- ObjectFileLoader sharedLibraryExtension
- "
-
- "Modified: / 4.5.1998 / 12:17:34 / cg"
-!
-
sharedLibrarySuffix
"return the fileName suffix used for dynamic loadable objects,
(as generated by myself - output of linker/makefiles).
@@ -817,7 +794,7 @@
].
os := OperatingSystem getSystemType.
- (os = 'linux') ifTrue:[
+ (os == #linux) ifTrue:[
"/ are we really still supporting that old stuff?
self loadableBinaryObjectFormat == #aout ifTrue:[
^ #('o' 'obj' 'a')
@@ -836,7 +813,8 @@
ObjectFileLoader validBinaryExtensions
"
- "Modified: / 1.10.1998 / 12:46:03 / cg"
+ "Modified: / 01-10-1998 / 12:46:03 / cg"
+ "Modified: / 22-07-2018 / 16:14:54 / Stefan Vogel"
! !
!ObjectFileLoader class methodsFor:'dynamic object loading'!
@@ -1081,20 +1059,20 @@
loadLibrary:aLibraryFileName
"load a library; search in some standard places and using
- standard suffixes (i.e. no suffix should be given in the arg).
- Returns a handle or nil.
+ standard suffixes (i.e. suffix may be omitted from LibraryFileName).
+ Returns a handle or raise an error.
Use this to attach C-libraries."
- |s suffixes handle libFilename libPath|
+ |suffix suffixes handle libFilename libPath|
Verbose ifTrue:[
('loadLibrary:' , aLibraryFileName) errorPrintCR.
].
libFilename := aLibraryFileName asFilename.
- (s := libFilename suffix) isEmpty ifTrue:[
+ (suffix := libFilename suffix) isEmpty ifTrue:[
suffixes := self validBinaryExtensions
] ifFalse:[
- suffixes := Array with:s
+ suffixes := Array with:suffix
].
"/ try each suffix ...
@@ -1111,8 +1089,10 @@
('loadLibrary try:' , fn asString) errorPrintCR.
].
- handle := self loadObjectFile:fn asString.
- handle notNil ifTrue:[^ handle].
+ handle := self loadObjectFile:fn.
+ handle notNil ifTrue:[
+ ^ handle
+ ].
(libFilename isAbsolute
or:[(aLibraryFileName startsWith:'./')
@@ -1128,23 +1108,28 @@
libPath asCollectionOfSubCollectionsSeparatedBy:$: do:[:eachSinglePath |
f := eachSinglePath asFilename construct:fn.
f exists ifTrue:[
- handle := self loadObjectFile:f pathName.
- handle notNil ifTrue:[^ handle].
+ handle := self loadObjectFile:f.
+ handle notNil ifTrue:[
+ ^ handle
+ ].
]
]
].
]
].
- ^ nil
+ ObjectFileLoadError
+ raiseErrorString:('Cannot find or load dll/library: "%1"' bindWith:aLibraryFileName asString).
"
+ ObjectFileLoader loadLibrary:'libc.so.6'
ObjectFileLoader loadLibrary:'libjpeg'
ObjectFileLoader loadLibrary:'odbc32'
"
"Modified: / 04-05-1999 / 17:01:47 / cg"
"Modified: / 20-09-2017 / 20:10:15 / stefan"
+ "Modified: / 22-07-2018 / 16:40:34 / Stefan Vogel"
!
loadMethodObjectFile:aFileName
@@ -1171,7 +1156,7 @@
initAddr isNil ifTrue:[
initAddr := self getFunction:'_' , initName , '_Init' from:handle.
initAddr isNil ifTrue:[
- (self getListOfUndefinedSymbolsFrom:handle) size > 0 ifTrue:[
+ (self getListOfUndefinedSymbolsFrom:handle) size ~~ 0 ifTrue:[
self listUndefinedSymbolsIn:handle.
'ObjectFileLoader [info]: undefined symbols in primitive code' errorPrintCR.
] ifFalse:[
@@ -1230,13 +1215,14 @@
"Created: / 05-12-1995 / 20:59:46 / cg"
"Modified: / 15-11-2010 / 13:20:36 / cg"
+ "Modified: / 01-03-2019 / 16:03:41 / Claus Gittinger"
!
loadObjectFile:aFileName
"load an object file (.o-file) into the image;
the class name is not needed (multiple definitions may be in the file).
This may be either a smalltalk object or a C-object file.
- The object files init function (if any) is called, and the module
+ The object file's init function (if any) is called, and the module
is unloaded if it returns failure (use lowLevel load, to load a file
without automatic initialization).
Return nil on error, an objectFile handle if ok."
@@ -1244,6 +1230,9 @@
^ self
loadObjectFile:aFileName
invokeInitializeMethods:true
+
+ "Modified (comment): / 10-04-2019 / 05:47:49 / Claus Gittinger"
+ "Modified: / 17-10-2019 / 13:46:10 / Stefan Vogel"
!
loadObjectFile:pathNameOrFilename invokeInitializeMethods:invokeInitializeMethods
@@ -1263,13 +1252,13 @@
handle := self handleForDynamicObject:filename.
handle notNil ifTrue:[
- "already loaded"
- ^ handle.
+ "already loaded"
+ ^ handle.
].
handle := self loadDynamicObject:filename.
handle isNil ifTrue:[
- ^ nil
+ ^ nil
].
didInit := false.
@@ -1279,23 +1268,23 @@
are to be resolved. If that's the case, load all libraries ..."
ParserFlags searchedLibraries notEmptyOrNil ifTrue:[
- (self hasUndefinedSymbolsIn:handle) ifTrue:[
- self initializeLoader.
-
- ParserFlags searchedLibraries do:[:libName |
- (self hasUndefinedSymbolsIn:handle) ifTrue:[
- Logger info:' ... trying %1 to resolve undefined symbols ...' with:libName.
- dummyHandle := Array new:4.
- dummyHandle := self primLoadDynamicObject:libName into:dummyHandle.
+ (self hasUndefinedSymbolsIn:handle) ifTrue:[
+ self initializeLoader.
+
+ ParserFlags searchedLibraries do:[:libName |
+ (self hasUndefinedSymbolsIn:handle) ifTrue:[
+ Logger info:' ... trying %1 to resolve undefined symbols ...' with:libName.
+ dummyHandle := Array new:4.
+ dummyHandle := self primLoadDynamicObject:libName into:dummyHandle.
"/ dummyHandle isNil ifTrue:[
"/ Transcript showCR:' ... load of library ' , libName , ' failed.'.
"/ ]
- ]
- ].
- (self hasUndefinedSymbolsIn:handle) isNil ifTrue:[
- Logger info:'still undefined symbols in %1.' with:pathName.
- ].
- ]
+ ]
+ ].
+ (self hasUndefinedSymbolsIn:handle) isNil ifTrue:[
+ Logger info:'still undefined symbols in %1.' with:pathName.
+ ].
+ ]
].
"
@@ -1310,215 +1299,230 @@
This is used in ST packaged classLib object files"
(initFunctionName startsWith:'lib') ifTrue:[
- definitionClassName := initFunctionName copyFrom:4.
- definitionClass := Smalltalk classNamed:definitionClassName.
+ definitionClassName := initFunctionName copyFrom:4.
+ definitionClass := Smalltalk classNamed:definitionClassName.
].
- (definitionClass isNil or:[definitionClass isLoaded not]) ifTrue:[
- "the project definition class has not been loaded yet.
- initialize and load it"
-
- initDefinitionAddr := self findInitDefinitionFunction:initFunctionName in:handle.
- initDefinitionAddr isNil ifTrue:[
+ (definitionClass isNil or:[definitionClass isLoaded not or:[definitionClass isObsolete]]) ifTrue:[
+ "the project definition class has not been loaded yet.
+ initialize and load it"
+
+ initDefinitionAddr := self findInitDefinitionFunction:initFunctionName in:handle.
+ initDefinitionAddr isNil ifTrue:[
Logger warning: 'no init definitions for: %1' with: pathName.
- ] ifFalse:[
- Verbose ifTrue:[
+ ] ifFalse:[
+ Verbose ifTrue:[
Logger info: 'calling initDefinition at: %1' with: (initDefinitionAddr printStringRadix:16).
- ].
- info := self
- performModuleInitAt:initDefinitionAddr
- invokeInitializeMethods:false
- for:definitionClassName
- identifyAs:handle.
- status := info at:1.
- status == #ok ifTrue:[
- "/ now, we have only loaded and installed the projectDefinition class.
- "/ (but no containing classes or extensions, yet).
- "/ let the projectDefinition load any prereqs
- definitionClassName notNil ifTrue:[
- definitionClass := Smalltalk classNamed:definitionClassName.
- definitionClass notNil ifTrue:[
-"/ "if projectDefinition denies loading, unload"
-"/ self unloadDynamicObject:handle.
-
- definitionClass
- checkForLoad; "/ raise exception if not supported on platform / not licensed
- initialize;
- preLoadAction;
- loadMandatoryPreRequisitesAsAutoloaded:false.
- ].
- ].
- ]
- ].
+ ].
+ info := self
+ performModuleInitAt:initDefinitionAddr
+ invokeInitializeMethods:false
+ for:definitionClassName
+ identifyAs:handle.
+ status := info at:1.
+ status == #ok ifTrue:[
+ "/ now, we have only loaded and installed the projectDefinition class.
+ "/ (but no containing classes or extensions, yet).
+ "/ let the projectDefinition load any prereqs
+ definitionClassName notNil ifTrue:[
+ definitionClass := Smalltalk classNamed:definitionClassName.
+ definitionClass notNil ifTrue:[
+ [
+ definitionClass checkForLoad. "/ raise exception if not supported on platform / not licensed
+ ] on:PackageLoadError do:[:ex|
+ self unloadObjectFileAndRemoveClasses:pathName.
+ ex reject.
+ ^ nil.
+ ].
+ definitionClass isObsolete ifTrue:[
+ "we come here when doing a filein and a (illegal) proceed from the PackageLoadError"
+ ^ nil.
+ ].
+ definitionClass
+ initialize;
+ preLoadAction;
+ loadMandatoryPreRequisitesAsAutoloaded:false.
+ ].
+ ].
+ ]
+ ].
].
"look for explicit init (xxx_Init) function
This is used in ST object files"
initAddr := self findInitFunction:initFunctionName in:handle.
initAddr notNil ifTrue:[
- Verbose ifTrue:[
+ Verbose ifTrue:[
Logger info: ' calling init at: %1' with: (initAddr printStringRadix:16).
- ].
- info := self
- performModuleInitAt:initAddr
- invokeInitializeMethods:invokeInitializeMethods
- for:nil
- identifyAs:handle.
- status := info at:1.
- status == #ok ifTrue:[
- didInit := true.
- definitionClassName notNil ifTrue:[
- definitionClass := Smalltalk classNamed:definitionClassName.
- ]
- ]
+ ].
+ info := self
+ performModuleInitAt:initAddr
+ invokeInitializeMethods:invokeInitializeMethods
+ for:nil
+ identifyAs:handle.
+ status := info at:1.
+ status == #ok ifTrue:[
+ didInit := true.
+ definitionClassName notNil ifTrue:[
+ definitionClass := Smalltalk classNamed:definitionClassName.
+ ]
+ ]
] ifFalse:[
- "look for explicit C-init (xxx__Init) function
- This is used in C object files"
-
- initAddr := self findFunction:initFunctionName suffix:'__Init' in:handle.
- initAddr notNil ifTrue:[
- isCModule := true.
-
- OSSignalInterrupt handle:[:ex |
- Logger error:'hard error in initFunction of class-module: %1' with:pathName.
- status := #initFailed.
- ] do:[
- cRetVal := self
- saveCallInitFunctionAt:initAddr
- in:pathNameOrFilename
- specialInit:false
- forceOld:true
- interruptable:false
- argument:0
- identifyAs:handle
- returnsObject:false.
- (cRetVal < 0) ifTrue:[
- Verbose ifTrue:[
+ "look for explicit C-init (xxx__Init) function
+ This is used in C object files"
+
+ initAddr := self findFunction:initFunctionName suffix:'__Init' in:handle.
+ initAddr notNil ifTrue:[
+ isCModule := true.
+
+ OSSignalInterrupt handle:[:ex |
+ Logger error:'hard error in initFunction of class-module: %1' with:pathName.
+ status := #initFailed.
+ ] do:[
+ cRetVal := self
+ saveCallInitFunctionAt:initAddr
+ in:pathNameOrFilename
+ specialInit:false
+ forceOld:true
+ interruptable:false
+ argument:0
+ identifyAs:handle
+ returnsObject:false.
+ (cRetVal < 0) ifTrue:[
+ Verbose ifTrue:[
Logger info: 'init function returns failure ... unload'.
- ].
- status := #initFailed.
- ] ifFalse:[
- didInit := true.
- ]
- ]
- ] ifFalse:[
- status := #noInitFunction.
-
- "look for any init-function(s); call them all"
- Verbose ifTrue:[
+ ].
+ status := #initFailed.
+ ] ifFalse:[
+ didInit := true.
+ ]
+ ]
+ ] ifFalse:[
+ status := #noInitFunction.
+
+ "look for any init-function(s); call them all"
+ Verbose ifTrue:[
Logger info: 'no good init functions found; looking for candidates ...'.
- ].
- initNames := self namesMatching:'*_Init' segment:'[tT?]' in:pathName.
- initNames notNil ifTrue:[
- initNames do:[:aName |
- initAddr := self getFunction:aName from:handle.
- initAddr isNil ifTrue:[
- (aName startsWith:'_') ifTrue:[
- initAddr := self getFunction:(aName copyFrom:2) from:handle.
- ].
- ].
- initAddr isNil ifTrue:[
- Transcript showCR:('no symbol: ',aName,' in ', pathName).
- ] ifFalse:[
- Verbose ifTrue:[
+ ].
+ initNames := self namesMatching:'*_Init' segment:'[tT?]' in:pathName.
+ initNames notNil ifTrue:[
+ initNames do:[:aName |
+ initAddr := self getFunction:aName from:handle.
+ initAddr isNil ifTrue:[
+ (aName startsWith:'_') ifTrue:[
+ initAddr := self getFunction:(aName copyFrom:2) from:handle.
+ ].
+ ].
+ initAddr isNil ifTrue:[
+ Transcript showCR:('no symbol: ',aName,' in ', pathName).
+ ] ifFalse:[
+ Verbose ifTrue:[
Logger info: ' calling init at: %1' with: (initAddr printStringRadix:16)
- ].
- self
- performModuleInitAt:initAddr
- invokeInitializeMethods:invokeInitializeMethods
- for:nil
- identifyAs:handle.
- didInit := true.
- ]
- ].
- ].
- ]
+ ].
+ self
+ performModuleInitAt:initAddr
+ invokeInitializeMethods:invokeInitializeMethods
+ for:nil
+ identifyAs:handle.
+ didInit := true.
+ ]
+ ].
+ ].
+ ]
].
(invokeInitializeMethods and:[didInit not]) ifTrue:[
- status == #noInitFunction ifTrue:[
- msg := 'no classLib init function found; assume load ok'
- ] ifFalse:[
- (status ~~ #registrationFailed
- and:[status ~~ #initFailed
- and:[status ~~ #missingClass
- and:[status ~~ #versionMismatch]]])
- ifTrue:[
- self listUndefinedSymbolsIn:handle.
- ].
-
- Verbose ifTrue:[
+ status == #noInitFunction ifTrue:[
+ msg := 'no classLib init function found; assume load ok'
+ ] ifFalse:[
+ (status ~~ #registrationFailed
+ and:[status ~~ #initFailed
+ and:[status ~~ #missingClass
+ and:[status ~~ #versionMismatch]]])
+ ifTrue:[
+ self listUndefinedSymbolsIn:handle.
+ ].
+
+ Verbose ifTrue:[
Logger info: ': unloading, since init failed ...'.
- ].
-
- "/ give caller a chance to prevent unloading (to register later, when a prerequisite class comes)
- status == #missingClass ifTrue:[
- doNotUnload := (SuperClassMissingErrorNotification query ? false).
- ] ifFalse:[
- status == #registrationFailed ifTrue:[
- doNotUnload := (RegistrationFailedErrorNotification query ? false).
- ] ifFalse:[
- doNotUnload := false.
- ].
- ].
- doNotUnload ifFalse:[
- self unloadDynamicObject:handle.
- Verbose ifTrue:[
+ ].
+
+ "/ give caller a chance to prevent unloading (to register later, when a prerequisite class comes)
+ status == #missingClass ifTrue:[
+ doNotUnload := (SuperClassMissingErrorNotification query ? false).
+ ] ifFalse:[
+ status == #registrationFailed ifTrue:[
+ doNotUnload := (RegistrationFailedErrorNotification query ? false).
+ ] ifFalse:[
+ doNotUnload := false.
+ ].
+ ].
+ doNotUnload ifFalse:[
+ self unloadDynamicObject:handle.
+ Verbose ifTrue:[
Logger info: 'unloaded'.
- ].
- handle := nil.
- ].
-
- status == #initFailed ifTrue:[
- msg := 'module not loaded (init function signaled failure).'
- ] ifFalse:[
- status == #missingClass ifTrue:[
- msg := 'module not loaded (superclass missing: ' , (info at:2) , ').'
- ] ifFalse:[
- status == #registrationFailed ifTrue:[
- msg := 'module registration failed (incompatible object or missing superclass)'
- ] ifFalse:[
- status == #versionMismatch ifTrue:[
- msg := 'module registration failed (class version mismatch ' , (info at:2) printString , ')'
- ] ifFalse:[
- (self namesMatching:'*__sepInitCode__*' segment:'[tT?]' in:pathName) notNil ifTrue:[
- msg := 'module not loaded (unknown error reason).'
- ] ifFalse:[
- msg := 'module not loaded (no _Init entry in object file ?).'
- ]
- ]
- ].
- ].
- ].
- ].
- Verbose ifTrue:[
- Logger debug:'%1: %2' with:pathNameOrFilename asFilename baseName with:msg.
- ].
+ ].
+ handle := nil.
+ ].
+
+ status == #initFailed ifTrue:[
+ msg := 'module not loaded (init function signaled failure).'
+ ] ifFalse:[
+ status == #missingClass ifTrue:[
+ msg := 'module not loaded (superclass missing: ' , (info at:2) , ').'
+ ] ifFalse:[
+ status == #registrationFailed ifTrue:[
+ msg := 'module registration failed (incompatible object or missing superclass)'
+ ] ifFalse:[
+ status == #versionMismatch ifTrue:[
+ msg := 'module registration failed (class version mismatch ' , (info at:2) printString , ')'
+ ] ifFalse:[
+ (self namesMatching:'*__sepInitCode__*' segment:'[tT?]' in:pathName) notNil ifTrue:[
+ msg := 'module not loaded (unknown error reason).'
+ ] ifFalse:[
+ msg := 'module not loaded (no _Init entry in object file ?).'
+ ]
+ ]
+ ].
+ ].
+ ].
+ ].
+ Verbose ifTrue:[
+ Logger debug:'%1: %2' with:pathNameOrFilename asFilename baseName with:msg.
+ ].
].
isCModule ifFalse:[
- Smalltalk flushCachedClasses.
- Class flushSubclassInfo.
-
- (definitionClass notNil and:[definitionClass isLoaded]) ifTrue:[
- definitionClass checkForLoad. "/ raise exception if not supported on platform / not licensed
+ Smalltalk flushCachedClasses.
+ Class flushSubclassInfo.
+
+ (definitionClass notNil and:[definitionClass isLoaded and:[definitionClass isObsolete not]]) ifTrue:[
+ [
+ definitionClass checkForLoad. "/ raise exception if not supported on platform / not licensed
+ ] on:PackageLoadError do:[:ex|
+ self unloadObjectFileAndRemoveClasses:pathName.
+ ex reject.
+ ^ nil.
+ ].
Smalltalk changed: #aboutToLoadPackage with: definitionClass.
- definitionClass
- loadAllClassesAsAutoloaded:true;
- loadPreRequisitesAsAutoloaded:true; "/ load non-mandatory prerequisites
- projectIsLoaded:true. "/ this performs the postLoadAction, too.
+ definitionClass
+ initialize;
+ loadAllClassesAsAutoloaded:true;
+ loadPreRequisitesAsAutoloaded:true; "/ load non-mandatory prerequisites
+ projectIsLoaded:true. "/ this performs the postLoadAction, too.
Smalltalk changed: #packageLoaded with: definitionClass.
- ].
- Smalltalk isInitialized ifTrue:[
- "really don't know, if and what has changed ...
- ... but assume, that new classes have been installed."
- Smalltalk changed:#postLoad.
- ].
+ ].
+ Smalltalk isInitialized ifTrue:[
+ "really don't know, if and what has changed ...
+ ... but assume, that new classes have been installed."
+ Smalltalk changed:#postLoad.
+ ].
].
^ handle
"Modified: / 15-11-2010 / 13:19:26 / cg"
"Modified: / 20-09-2016 / 00:02:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 13-02-2017 / 20:27:55 / cg"
+ "Modified: / 17-10-2019 / 14:51:08 / Stefan Vogel"
!
unloadAllObsoleteObjectFiles
@@ -1540,7 +1544,7 @@
"Modified: 5.12.1995 / 18:16:52 / cg"
!
-unloadObjectFile:aFileName
+unloadObjectFile:aFilename
"unload an object file (.o-file) from the image.
DANGER ALERT: currently, you have to make sure that no references to
objects of this module exist - in future versions, the system will keep
@@ -1549,11 +1553,9 @@
|handle|
- LoadedObjects notNil ifTrue:[
- handle := LoadedObjects at:aFileName ifAbsent:nil
- ].
+ handle := self handleForDynamicObject:aFilename.
handle isNil ifTrue:[
- ('ObjectFileLoader [info]: oops - file to be unloaded was not loaded dynamically (', aFileName , ')') infoPrintCR.
+ Logger info:'oops - file to be unloaded was not loaded dynamically (%1)' with:aFilename.
^ self
].
@@ -1561,9 +1563,10 @@
self unloadDynamicObject:handle
"Modified: / 06-12-2006 / 18:19:13 / cg"
+ "Modified: / 17-10-2019 / 13:35:52 / Stefan Vogel"
!
-unloadObjectFileAndRemoveClasses:aFileName
+unloadObjectFileAndRemoveClasses:aFilename
"unload an object file (.o-file) from the image and remove all
corresponding classes from the system.
DANGER ALERT: currently, you have to make sure that no references to
@@ -1573,11 +1576,9 @@
|handle|
- LoadedObjects notNil ifTrue:[
- handle := LoadedObjects at:aFileName ifAbsent:nil
- ].
+ handle := self handleForDynamicObject:aFilename.
handle isNil ifTrue:[
- ('ObjectFileLoader [info]: oops - file to be unloaded was not loaded dynamically (', (aFileName ? 'unknown-file') , ')') infoPrintCR.
+ Logger info:'oops - file to be unloaded was not loaded dynamically (%1)' with:aFilename.
^ self
].
handle isClassLibHandle ifFalse:[
@@ -1597,6 +1598,7 @@
self unloadDynamicObject:handle
"Modified: / 06-12-2006 / 18:19:19 / cg"
+ "Modified: / 17-10-2019 / 13:38:01 / Stefan Vogel"
! !
!ObjectFileLoader class methodsFor:'dynamic object queries'!
@@ -1748,12 +1750,6 @@
*/
#endif
-#ifdef BEOS_DL
- /*
- * don't know how to do it
- */
-#endif
-
%}.
^ list
!
@@ -1893,41 +1889,6 @@
}
#endif
-#ifdef BEOS_DL
- {
- void *h;
- void *addr;
- INT val;
- void *handle;
-
- if (__bothSmallInteger(sysHandle1, sysHandle2)) {
-# if __POINTER_SIZE__ == 8
- val = (_intVal(sysHandle2) << 32) + _intVal(sysHandle1);
-# else
- val = (_intVal(sysHandle2) << 16) + _intVal(sysHandle1);
-# endif
- handle = (void *)(val);
-
- if (__isStringLike(aString)) {
- if (@global(Verbose) == true)
- console_printf("get sym <%s> handle = %"_lx_"\n", __stringVal(aString), (INT)handle);
- entry = NULL;
- get_image_symbol((image_id) handle, (char *) __stringVal(aString), B_SYMBOL_TYPE_TEXT, &entry);
- if (entry != NULL) {
- addr = (void *)entry;
- if (@global(Verbose) == true) {
- console_printf("get_image_symbol %s ok; addr = %x\n", __stringVal(aString), addr);
- }
- address = __MKUINT( (INT)addr );
- } else {
- if (@global(Verbose) == true) {
- console_printf("get_image_symbol %s error\n", __stringVal(aString));
- }
- }
- }
- }
- }
-#endif
#ifdef DL1_6
{
@@ -2178,9 +2139,10 @@
This is only possible if the system supports loading
modules with undefined things in it - most do not"
- ^ (self getListOfUndefinedSymbolsFrom:handle) size > 0
-
- "Modified: 25.4.1996 / 09:47:27 / cg"
+ ^ (self getListOfUndefinedSymbolsFrom:handle) size ~~ 0
+
+ "Modified: / 25-04-1996 / 09:47:27 / cg"
+ "Modified: / 01-03-2019 / 16:03:33 / Claus Gittinger"
!
initFunctionBasenameForFile:pathNameOrFilename
@@ -2263,14 +2225,15 @@
|undefinedNames|
undefinedNames := self getListOfUndefinedSymbolsFrom:handle.
- undefinedNames size > 0 ifTrue:[
+ undefinedNames size ~~ 0 ifTrue:[
Transcript showCR:'ObjectFileLoader [info]: undefined:'.
undefinedNames do:[:aName |
Transcript showCR:' ' , aName
]
].
- "Modified: 18.5.1996 / 15:43:45 / cg"
+ "Modified: / 18-05-1996 / 15:43:45 / cg"
+ "Modified: / 01-03-2019 / 16:03:37 / Claus Gittinger"
!
namesMatching:aPattern segment:segmentPattern in:aPathName
@@ -2683,244 +2646,247 @@
!ObjectFileLoader class methodsFor:'linking objects'!
-createLoadableObjectFor:baseFileName
+createLoadableObjectFor:baseFilenameString
"given an oFile, arrange for it to be loadable.
On ELF systems, this means that it has to be linked with the
-shared option into a .so file;
DLD based loaders (linux a.out) can directly load a .o file;
Other systems may require more ..."
- |osType oFileName soFileName expFileName librunExpFileName
- needSharedObject ld ldArg expFile ok outfile output libDir libDirBasename
+ |osType baseFilename oFileName soFileName expFileName librunExpFileName
+ needSharedObject linker ld ldArg expFile ok outfile output libDir libDirBasename
errorMessage homeDir fmt|
osType := OperatingSystem getOSType.
+ baseFilename := baseFilenameString asFilename.
+
+ linker := Filename possiblyQuotedPathname:(self linkCommand).
osType = #win32 ifTrue:[
- self activityNotification:'generating shared object'.
- ParserFlags linkArgs isNil ifTrue:[
- ld := self linkCommand , ' ' , baseFileName , '.obj'.
- ld := ld
- , ' /NOPACK /NOLOGO /DEBUG /MACHINE:I386 /DLL'
- , ' /OUT:' , baseFileName , '.dll '
+ self activityNotification:'generating shared object'.
+ ParserFlags linkArgs isNil ifTrue:[
+ ld := linker , ' ' , (Filename possiblyQuotedPathname:(baseFilenameString,'.obj')).
+ ld := ld
+ , ' /NOPACK /NOLOGO /DEBUG /MACHINE:I386 /DLL'
+ , ' /OUT:' , (Filename possiblyQuotedPathname:(baseFilenameString,'.dll'))
"/ , ' /DEF:' , baseFileName , '.def'.
- ] ifFalse:[
+ ] ifFalse:[
"/ libDir := ParserFlags libDirectory.
"/ (libDir notNil and:[libDir asFilename exists]) ifFalse:[
- ParserFlags useBorlandC ifTrue:[
- libDirBasename := 'lib\bc'
- ] ifFalse:[
- ParserFlags useVisualC ifTrue:[
- libDirBasename := 'lib\vc'
- ] ifFalse:[
- (ParserFlags useMingw32 or:[ParserFlags useMingw64]) ifTrue:[
- libDirBasename := 'lib\mingw'
- ] ifFalse:[
- libDirBasename := 'lib\vc'
- ]
- ]
- ].
- homeDir := Smalltalk packagePath detect:[:p | (p asFilename / 'stx' / libDirBasename) exists] ifNone:nil.
- homeDir notNil ifTrue:[
- libDir := (homeDir asFilename / 'stx' / libDirBasename) pathName
- ].
- libDir isNil ifTrue:[
- "/ some fallback
- libDir := #( '..'
- '..\..'
- '..\..\..'
- '..\..\stx'
- '..\..\..\stx'
- ) detect:[:p | (p asFilename / libDirBasename) exists] ifNone:nil.
-
- libDir isNil ifTrue:[
- LastError := errorMessage := 'could not locate directory where .lib files are (',libDirBasename,')'.
- ObjectFileLoadError raiseRequestErrorString:errorMessage.
- ^ nil
- ].
- ].
+ ParserFlags useBorlandC ifTrue:[
+ libDirBasename := 'lib\bc'
+ ] ifFalse:[
+ ParserFlags useVisualC ifTrue:[
+ libDirBasename := 'lib\vc'
+ ] ifFalse:[
+ (ParserFlags useMingw32 or:[ParserFlags useMingw64]) ifTrue:[
+ libDirBasename := 'lib\mingw'
+ ] ifFalse:[
+ libDirBasename := 'lib\vc'
+ ]
+ ]
+ ].
+ homeDir := Smalltalk packagePath detect:[:p | (p asFilename / 'stx' / libDirBasename) exists] ifNone:nil.
+ homeDir notNil ifTrue:[
+ libDir := (homeDir asFilename / 'stx' / libDirBasename) pathName
+ ].
+ libDir isNil ifTrue:[
+ "/ some fallback
+ libDir := #( '..'
+ '..\..'
+ '..\..\..'
+ '..\..\stx'
+ '..\..\..\stx'
+ ) detect:[:p | (p asFilename / libDirBasename) exists] ifNone:nil.
+
+ libDir isNil ifTrue:[
+ LastError := errorMessage := 'could not locate directory where .lib files are (',libDirBasename,')'.
+ ObjectFileLoadError raiseRequestErrorString:errorMessage.
+ ^ nil
+ ].
+ ].
"/ ].
- ParserFlags useBorlandC ifTrue:[
- ld := self linkCommand , ' ' , (ParserFlags linkArgs bindWith:baseFileName).
- ld := ld , ' c0d32.obj ' , baseFileName , '.obj '.
- ld := ld , ',' , baseFileName , '.dll,,',libDir,'\librun.lib '.
- ld := ld , (ParserFlags searchedLibraries asStringCollection asStringWith: $ ).
- ld := ld , ' ',libDir,'\cs32i.lib,,'.
- ] ifFalse:[
- ParserFlags useVisualC ifTrue:[
- "/ todo: fix for correct link libs
- ld := self linkCommand , ' ' , (ParserFlags linkArgs bindWith:baseFileName).
- ld := ld , ' c0d32.obj ' , baseFileName , '.obj '.
- ld := ld , ',' , baseFileName , '.dll,,',libDir,'\librun.lib '.
- ld := ld , (ParserFlags searchedLibraries asStringCollection asStringWith: $ ).
- ld := ld , ' ',libDir,'\cs32i.lib,,'.
- ] ifFalse:[
- (ParserFlags useMingw64 or:[ParserFlags useMingw32]) ifTrue:[
- ld := self linkCommand , ' ' , (ParserFlags linkArgs bindWith:baseFileName).
- ld := ld , ' -shared -o ',baseFileName,'.dll '.
- ld := ld , baseFileName,'.obj '.
- ld := ld , libDir,'\librun.lib '.
- ld := ld , (ParserFlags searchedLibraries asStringCollection asStringWith: $ ).
- ] ifFalse:[
- ObjectFileLoadError raiseRequestErrorString:'for dynamic objects, only borlandC is (currently) supported'.
- LastError := 'for dynamic objects, only borlandC is (currently) supported'.
- ^ nil
- ]
- ]
- ]
- ].
-
- outfile := (baseFileName , '.out').
- (Verbose or:[ STCCompilerInterface verbose ]) ifTrue:[
- Transcript showCR:('executing: ',ld).
- ].
-
- ok := OperatingSystem executeCommand:(ld , ' >' , outfile, ' 2>&1') showWindow:false.
- ok ifFalse:[
- output := (baseFileName , '.out') asFilename contentsOfEntireFile.
- Transcript showCR:'********************'.
- Transcript showCR:'Failed linkCommand:'.
- Transcript showCR:ld.
- Transcript showCR:'ParserFlags are:'.
- Transcript showCR:ParserFlags.
- Transcript showCR:'--------------------'.
- Transcript showCR:output; endEntry.
- Transcript showCR:'********************'.
- ].
-
- #('.obj' '.out' '.tds' '.ilc' '.ild'
- '.ilf' '.ils' '.lib' '.map' '.def' '.o') do:[:eachSuffix|
- (baseFileName , eachSuffix) asFilename remove.
- ].
-
- ok ifFalse:[
- LastError := output.
- "/ ObjectFileLoadError raiseRequestErrorString:'link failed'.
- ^ nil
- ].
- oFileName := (baseFileName , self sharedLibraryExtension) asFilename name.
- ^ oFileName
+ ParserFlags useBorlandC ifTrue:[
+ ld := linker , ' ' , (ParserFlags linkArgs bindWith:baseFilenameString).
+ ld := ld , ' c0d32.obj ' , (Filename possiblyQuotedPathname:(baseFilenameString , '.obj')).
+ ld := ld , ',' , (Filename possiblyQuotedPathname:(baseFilenameString,'.dll')),',,',libDir,'\librun.lib'.
+ ld := ld , ' ',(ParserFlags searchedLibraries asStringCollection asStringWith: $ ).
+ ld := ld , ' ',libDir,'\cs32i.lib,,'.
+ ] ifFalse:[
+ ParserFlags useVisualC ifTrue:[
+ "/ todo: fix for correct link libs
+ ld := linker , ' ' , (ParserFlags linkArgs bindWith:baseFilenameString).
+ ld := ld , ' c0d32.obj ' , (Filename possiblyQuotedPathname:(baseFilenameString,'.obj')).
+ ld := ld , ',' , (Filename possiblyQuotedPathname:(baseFilenameString,'.dll')),',,',libDir,'\librun.lib'.
+ ld := ld , ' ',(ParserFlags searchedLibraries asStringCollection asStringWith: $ ).
+ ld := ld , ' ',libDir,'\cs32i.lib,,'.
+ ] ifFalse:[
+ (ParserFlags useMingw64 or:[ParserFlags useMingw32]) ifTrue:[
+ ld := linker , ' ' , (ParserFlags linkArgs bindWith:baseFilenameString).
+ ld := ld , ' -shared -o ',(Filename possiblyQuotedPathname:(baseFilenameString,'.dll')).
+ ld := ld , ' ',(Filename possiblyQuotedPathname:(baseFilenameString,'.obj')).
+ ld := ld , ' ',libDir,'\librun.lib'.
+ ld := ld , ' ',(ParserFlags searchedLibraries asStringCollection asStringWith: $ ).
+ ] ifFalse:[
+ ObjectFileLoadError raiseRequestErrorString:'for dynamic objects, only borlandC is (currently) supported'.
+ LastError := 'for dynamic objects, only borlandC is (currently) supported'.
+ ^ nil
+ ]
+ ]
+ ]
+ ].
+
+ outfile := (Filename possiblyQuotedPathname:(baseFilenameString , '.out')).
+ (Verbose or:[ STCCompilerInterface verbose ]) ifTrue:[
+ Transcript showCR:('executing: ',ld).
+ ].
+
+ ok := OperatingSystem executeCommand:(ld , ' >' , outfile, ' 2>&1') showWindow:false.
+ ok ifFalse:[
+ output := (baseFilenameString , '.out') asFilename contentsOfEntireFile.
+ Transcript showCR:'********************'.
+ Transcript showCR:'Failed linkCommand:'.
+ Transcript showCR:ld.
+ Transcript showCR:'ParserFlags are:'.
+ Transcript showCR:ParserFlags.
+ Transcript showCR:'--------------------'.
+ Transcript showCR:output; endEntry.
+ Transcript showCR:'********************'.
+ ].
+
+ #('obj' 'out' 'tds' 'ilc' 'ild'
+ 'ilf' 'ils' 'lib' 'map' 'def' 'o') do:[:eachSuffix|
+ (baseFilename withSuffix:eachSuffix) removeFile.
+ ].
+
+ ok ifFalse:[
+ LastError := output.
+ "/ ObjectFileLoadError raiseRequestErrorString:'link failed'.
+ ^ nil
+ ].
+ oFileName := (baseFilename withSuffix:self sharedLibrarySuffix) name.
+ ^ oFileName
].
"/ UNIX systems
- ld := self linkCommand ? 'ld'.
+ ld := linker ? 'ld'.
needSharedObject := false.
fmt := self loadableBinaryObjectFormat.
- (fmt == #elf
- or:[ fmt == #macho ]) ifTrue:[
- "
- link it to a shared object with 'ld -shared'
- "
- needSharedObject := true.
- ld := self linkCommand ? 'cc'.
- ldArg := self linkSharedArgs.
- ldArg isNil ifTrue:[
- "/ some default
- ExternalAddress pointerSize == 4 ifTrue:[
- ldArg := '-m32 -shared'.
- ] ifFalse:[
- ldArg := '--shared'.
- ]
- ]
+ (fmt == #elf or:[ fmt == #macho ]) ifTrue:[
+ "
+ link it to a shared object with 'ld -shared'
+ "
+ needSharedObject := true.
+ ld := linker ? 'cc'.
+ ldArg := self linkSharedArgs.
+ ldArg isNil ifTrue:[
+ "/ some default
+ ExternalBytes sizeofPointer == 4 ifTrue:[
+ ldArg := '-m32 -shared'.
+ ] ifFalse:[
+ ldArg := '--shared'.
+ ]
+ ]
].
osType = #irix ifTrue:[
- "
- link it to a shared object with 'ld -shared'
- "
- needSharedObject := true.
- ldArg := self linkSharedArgs ? '-shared'.
+ "
+ link it to a shared object with 'ld -shared'
+ "
+ needSharedObject := true.
+ ldArg := self linkSharedArgs ? '-shared'.
].
osType = #'sys5_4' ifTrue:[
- "
- link it to a shared object with 'ld -G'
- "
- needSharedObject := true.
- ldArg := self linkSharedArgs ? '-G'.
+ "
+ link it to a shared object with 'ld -G'
+ "
+ needSharedObject := true.
+ ldArg := self linkSharedArgs ? '-G'.
].
osType = #solaris ifTrue:[
- "
- link it to a shared object with 'ld -G -B dynamic'
- "
- needSharedObject := true.
- ldArg := self linkSharedArgs ? '-G -Bdynamic'.
+ "
+ link it to a shared object with 'ld -G -B dynamic'
+ "
+ needSharedObject := true.
+ ldArg := self linkSharedArgs ? '-G -Bdynamic'.
].
osType = #hpux ifTrue:[
- "
- link it to a shared object with 'ld -b -B immediate'
- "
- needSharedObject := true.
- ldArg := self linkSharedArgs ? '-b -B immediate'.
+ "
+ link it to a shared object with 'ld -b -B immediate'
+ "
+ needSharedObject := true.
+ ldArg := self linkSharedArgs ? '-b -B immediate'.
].
osType = #aix ifTrue:[
- self activityNotification:'create export file'.
-
- "/ create an exports file.
- expFileName := './' , baseFileName , '.exp'.
- [
- expFile := expFileName asFilename writeStream.
- expFile nextPutAll:'#!! ./' , baseFileName , (self sharedLibraryExtension).
- expFile cr.
- expFile nextPutAll:'_' , baseFileName , '_Init'.
- expFile close.
- ] on:FileStream openErrorSignal do:[:ex| "do nothing"].
-
- self activityNotification:'generating shared object'.
-
- "
- link it to a shared object with 'cc -bI:...librun.exp -bE -bMSRE'
- "
- needSharedObject := true.
- ld := 'cc'.
- librunExpFileName := Smalltalk getSystemFileName:'lib/librun_aix.exp'.
- librunExpFileName isNil ifTrue:[
- LastError := 'missing exports file: ''lib/librun_aix.exp'' - cannot link'.
- ^ nil
- ].
-
- ldArg := '-bI:' , librunExpFileName ,
- ' -bE:' , baseFileName , '.exp' ,
- ' -bM:SRE -e _' , baseFileName , '_Init'.
+ self activityNotification:'create export file'.
+
+ "/ create an exports file.
+ expFileName := './' , baseFilenameString , '.exp'.
+ [
+ expFile := expFileName asFilename writeStream.
+ expFile nextPutAll:'#!! ./' , baseFilenameString , '.', self sharedLibrarySuffix.
+ expFile cr.
+ expFile nextPutAll:'_' , baseFilenameString , '_Init'.
+ expFile close.
+ ] on:OpenError do:[:ex| "do nothing"].
+
+ self activityNotification:'generating shared object'.
+
+ "
+ link it to a shared object with 'cc -bI:...librun.exp -bE -bMSRE'
+ "
+ needSharedObject := true.
+ ld := 'cc'.
+ librunExpFileName := Smalltalk getSystemFileName:'lib/librun_aix.exp'.
+ librunExpFileName isNil ifTrue:[
+ LastError := 'missing exports file: ''lib/librun_aix.exp'' - cannot link'.
+ ^ nil
+ ].
+
+ ldArg := '-bI:' , librunExpFileName ,
+ ' -bE:' , baseFilenameString , '.exp' ,
+ ' -bM:SRE -e _' , baseFilenameString , '_Init'.
].
- oFileName := baseFileName , self objectFileExtension.
+ oFileName := baseFilename withSuffix:self objectFileSuffix.
needSharedObject ifTrue:[
- self activityNotification:'generating shared object'.
-
- soFileName := baseFileName , self sharedLibraryExtension.
- OperatingSystem removeFile:soFileName.
- ld := ld , ' ' , ldArg , ' ', (ParserFlags linkArgs ? '') ,
- ' -o ' , soFileName , ' ' , oFileName , ' ',
- ((ParserFlags searchedLibraries ? #()) asStringCollection asStringWith: $ ).
-
- (Verbose or:[ STCCompilerInterface verbose ]) ifTrue:[
- Transcript showCR:('linking with: ',ld).
- ].
- ok := OperatingSystem executeCommand:(ld , ' >errorOutput 2>&1').
-
- ok ifFalse:[
- output := 'errorOutput' asFilename contentsOfEntireFile.
- Transcript showCR:'********************'.
- Transcript showCR:'linker command:'.
- Transcript showCR:ld; endEntry.
- Transcript showCR:'--------------------'.
- Transcript showCR:'linker error message:'.
- Transcript showCR:output.
- Transcript showCR:'********************'.
- ].
-
- OperatingSystem removeFile:oFileName.
- expFileName notNil ifTrue:[
- OperatingSystem removeFile:expFileName
- ].
- ^ soFileName.
+ self activityNotification:'generating shared object'.
+
+ soFileName := baseFilename withSuffix:self sharedLibrarySuffix.
+ soFileName removeFile.
+
+ ld := ld , ' ' , ldArg , ' ', (ParserFlags linkArgs ? '') ,
+ ' -o ' , soFileName name, ' ' , oFileName name , ' ',
+ ((ParserFlags searchedLibraries ? #()) asStringCollection asStringWith: $ ).
+
+ (Verbose or:[ STCCompilerInterface verbose ]) ifTrue:[
+ Transcript showCR:('linking with: ',ld).
+ ].
+ ok := OperatingSystem executeCommand:(ld , ' >errorOutput 2>&1').
+
+ ok ifFalse:[
+ output := 'errorOutput' asFilename contentsOfEntireFile.
+ Transcript showCR:'********************'.
+ Transcript showCR:'linker command:'.
+ Transcript showCR:ld; endEntry.
+ Transcript showCR:'--------------------'.
+ Transcript showCR:'linker error message:'.
+ Transcript showCR:output.
+ Transcript showCR:'********************'.
+ ].
+
+ oFileName removeFile.
+ expFileName notNil ifTrue:[
+ expFileName asFilename removeFile.
+ ].
+ ^ soFileName name.
].
"
@@ -2930,6 +2896,8 @@
"Modified: / 29-07-2004 / 17:29:44 / stefan"
"Modified: / 25-02-2017 / 09:18:42 / cg"
+ "Modified: / 28-03-2019 / 16:29:48 / Claus Gittinger"
+ "Modified (format): / 10-04-2019 / 06:18:38 / Claus Gittinger"
! !
!ObjectFileLoader class methodsFor:'lowlevel object loading'!
@@ -2995,21 +2963,21 @@
].
Verbose ifTrue:[
- ('loadDynamic: ',pathNameOrFilename asString,' (',pathName asString,')...') errorPrintCR
+ ('loadDynamic: ',pathNameOrFilename asString,' (',pathName asString,')...') errorPrintCR
].
encodedPathName := OperatingSystem encodePath:pathName.
"/ already loaded ?
handle := self handleForDynamicObject:encodedPathName.
handle notNil ifTrue:[
- Verbose ifTrue:[
+ Verbose ifTrue:[
('... ' , pathName asString , ' already loaded.') errorPrintCR.
- ].
- ^ handle
+ ].
+ ^ handle
].
Verbose ifTrue:[
- ('initializeLoader...') errorPrintCR
+ ('initializeLoader...') errorPrintCR
].
self initializeLoader.
@@ -3023,28 +2991,28 @@
buffer at:4 put:NextHandleID. NextHandleID := NextHandleID + 1.
Verbose ifTrue:[
- ('primLoadDynamicObject...') errorPrintCR
+ ('primLoadDynamicObject...') errorPrintCR
].
buffer := self primLoadDynamicObject:encodedPathName into:buffer.
Verbose ifTrue:[
- ('done') errorPrintCR
+ ('done') errorPrintCR
].
buffer isNil ifTrue:[
- LastError == #notImplemented ifTrue:[
- 'ObjectFileLoader [warning]: no dynamic load facility present.' infoPrintCR.
- ] ifFalse:[
- LastError == #linkError ifTrue:[
- LinkErrorMessage notNil ifTrue:[
- ('ObjectFileLoader [warning]: load error:' , LinkErrorMessage) infoPrintCR.
- ] ifFalse:[
- ('ObjectFileLoader [warning]: load error') infoPrintCR.
- ].
- ].
- ].
+ LastError == #notImplemented ifTrue:[
+ 'ObjectFileLoader [warning]: no dynamic load facility present.' infoPrintCR.
+ ] ifFalse:[
+ LastError == #linkError ifTrue:[
+ LinkErrorMessage notNil ifTrue:[
+ ('ObjectFileLoader [warning]: load error:' , LinkErrorMessage) infoPrintCR.
+ ] ifFalse:[
+ ('ObjectFileLoader [warning]: load error') infoPrintCR.
+ ].
+ ].
+ ].
Logger warning: 'failed to load ''%1''' with: pathName.
- ^ nil
+ ^ nil
].
"
@@ -3057,13 +3025,13 @@
handle moduleID:(buffer at:4).
LoadedObjects isNil ifTrue:[
- LoadedObjects := Dictionary new.
+ LoadedObjects := Dictionary new.
].
LoadedObjects at:pathName put:handle.
"/ Smalltalk flushCachedClasses.
Verbose ifTrue:[
- ('loadDynamic ok; handle is: ' , handle printString) errorPrintCR.
+ ('loadDynamic ok; handle is: ' , handle printString) errorPrintCR.
].
"/ ObjectMemory garbageCollect.
@@ -3179,8 +3147,8 @@
if (__isStringLike(pathName)) {
if (@global(Verbose) == true) {
- console_fprintf(stderr, "ObjectFileLoader [info]: loading dll: %s...\n", __stringVal(pathName));
- console_fflush(stderr);
+ console_fprintf(__win32_stderr(), "ObjectFileLoader [info]: loading dll: %s...\n", __stringVal(pathName));
+ console_fflush(__win32_stderr());
}
//
// LOAD_WITH_ALTERED_SEARCH_PATH causes follow-up dlls to be looked up also
@@ -3191,8 +3159,8 @@
//
handle = LoadLibraryEx(__stringVal(pathName), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
if (@global(Verbose) == true) {
- console_fprintf(stderr, "ObjectFileLoader [info]: handle: %"_lx_"\n", (INT)handle);
- console_fflush(stderr);
+ console_fprintf(__win32_stderr(), "ObjectFileLoader [info]: handle: %"_lx_"\n", (INT)handle);
+ console_fflush(__win32_stderr());
}
if (handle == NULL) {
char *msg;
@@ -3200,7 +3168,7 @@
err = GetLastError();
if ((@global(ErrorPrinting) == true)
|| (@global(Verbose) == true)) {
- console_fprintf (stderr,
+ console_fprintf (__win32_stderr(),
"ObjectFileLoader [warning]: LoadLibrary %s failed; error: %x\n",
__stringVal(pathName), err);
}
@@ -3217,11 +3185,11 @@
RETURN ( nil );
}
# if __POINTER_SIZE__ == 8
- __ArrayInstPtr(anInfoBuffer)->a_element[0] = __MKSMALLINT( (INT)handle & 0xFFFFFFFFL );
- __ArrayInstPtr(anInfoBuffer)->a_element[1] = __MKSMALLINT( ((INT)handle >> 32) & 0xFFFFFFFFL );
+ __ArrayInstPtr(anInfoBuffer)->a_element[0] = __MKSMALLINT( (UINT)handle & 0xFFFFFFFFL );
+ __ArrayInstPtr(anInfoBuffer)->a_element[1] = __MKSMALLINT( ((UINT)handle >> 32) & 0xFFFFFFFFL );
# else
- __ArrayInstPtr(anInfoBuffer)->a_element[0] = __MKSMALLINT( (INT)handle & 0xFFFF );
- __ArrayInstPtr(anInfoBuffer)->a_element[1] = __MKSMALLINT( ((INT)handle >> 16) & 0xFFFF );
+ __ArrayInstPtr(anInfoBuffer)->a_element[0] = __MKSMALLINT( (UINT)handle & 0xFFFF );
+ __ArrayInstPtr(anInfoBuffer)->a_element[1] = __MKSMALLINT( ((UINT)handle >> 16) & 0xFFFF );
# endif
RETURN ( anInfoBuffer );
}
@@ -3243,41 +3211,6 @@
}
#endif
-#ifdef BEOS_DL
- {
- void *handle;
- int err;
-
- if (__isStringLike(pathName)) {
- if (@global(Verbose) == true) {
- console_fprintf(stderr, "ObjectFileLoader [info]: loading : %s...\n", __stringVal(pathName));
- console_fflush(stderr);
- }
- handle = load_add_on(__stringVal(pathName));
- if (@global(Verbose) == true) {
- console_fprintf(stderr, "ObjectFileLoader [info]: handle: %x\n", handle);
- console_fflush(stderr);
- }
- if (handle == NULL) {
- char *msg;
-
- @global(LastError) = @symbol(linkError);
- @global(LinkErrorMessage) = __MKSTRING("unknown error");
- RETURN ( nil );
- }
-# if __POINTER_SIZE__ == 8
- __ArrayInstPtr(anInfoBuffer)->a_element[0] = __MKSMALLINT( (INT)handle & 0xFFFFFFFF );
- __ArrayInstPtr(anInfoBuffer)->a_element[1] = __MKSMALLINT( ((INT)handle >> 32) & 0xFFFFFFFF );
-# else
- __ArrayInstPtr(anInfoBuffer)->a_element[0] = __MKSMALLINT( (INT)handle & 0xFFFF );
- __ArrayInstPtr(anInfoBuffer)->a_element[1] = __MKSMALLINT( ((INT)handle >> 16) & 0xFFFF );
- RETURN ( anInfoBuffer );
-# endif
- }
- RETURN ( nil );
- }
-#endif
-
#ifdef DL1_6
{
extern char *__myName__;
@@ -3561,89 +3494,74 @@
#endif
#ifdef WIN_DL
- INT val;
- HINSTANCE handle;
- int err;
- jmp_buf exitJmpBuf;
-
+# if defined(__BORLANDC__)
+ // FreeLibrary in Borland C calls exit, catches it with setjmp()
+ // but hangs after this.
+ if (@global(Verbose) == true) {
+ console_fprintf (__win32_stderr(),
+ "ObjectFileLoader [info]: FreeLibrary is not supported in Borland C\n");
+ }
+ RETURN (true);
+# else // ! __BORLAND_C__
if (__bothSmallInteger(sysHandle1, sysHandle2)) {
+ UINT val;
+ HINSTANCE handle;
+ int err;
+ jmp_buf exitJmpBuf;
+
# if __POINTER_SIZE__ == 8
- val = (_intVal(sysHandle2) << 32) + _intVal(sysHandle1);
+ val = ((UINT)_intVal(sysHandle2) << 32) + (UINT)_intVal(sysHandle1);
# else
- val = (_intVal(sysHandle2) << 16) + _intVal(sysHandle1);
+ val = ((UINT)_intVal(sysHandle2) << 16) + (UINT)_intVal(sysHandle1);
# endif
- handle = (HINSTANCE)(val);
-
- if (setjmp(exitJmpBuf)) {
+ handle = (HINSTANCE)val;
+
+ if (!setjmp(exitJmpBuf)) {
__setAtExitLongJmp(exitJmpBuf);
if (@global(Verbose) == true) {
- console_fprintf (stderr,
- "ObjectFileLoader [info]: FreeLibrary %s handle: %"_lx_"\n",
- __stringVal(sysHandle1), (INT)handle);
+ console_fprintf (__win32_stderr(),
+ "ObjectFileLoader [info]: FreeLibrary handle: %"_lx_"\n",
+ (INT)handle);
}
if (FreeLibrary(handle) != TRUE) {
- __setAtExitLongJmp(0);
+ __setAtExitLongJmp(0);
err = GetLastError();
if (@global(Verbose) == true) {
- console_fprintf (stderr,
- "ObjectFileLoader [warning]: FreeLibrary %s failed; error: %x\n",
- __stringVal(sysHandle1), err);
+ console_fprintf (__win32_stderr(),
+ "ObjectFileLoader [warning]: FreeLibrary failed; error: %x\n",
+ err);
}
@global(LastErrorNumber) = __MKINT(__WIN32_ERR(err));
RETURN (false);
- }
- } else {
- __setAtExitLongJmp(0);
- console_fprintf(stderr, "ObjectFileLoader [warning]: FreeLibrary called exit() - ignored\n");
- }
- RETURN (true);
- }
- RETURN (false);
-#endif
-
-#ifdef BEOS_DL
- int val;
- void *handle;
- int ok, err;
- jmp_buf exitJmpBuf;
-
- if (__bothSmallInteger(sysHandle1, sysHandle2)) {
- val = (_intVal(sysHandle2) << 16) + _intVal(sysHandle1);
- handle = (HINSTANCE)(val);
-
- if (setjmp(exitJmpBuf)) {
- __setAtExitLongJmp(exitJmpBuf);
- ok = unload_add_on((image_id) handle);
- __setAtExitLongJmp(0);
- if (ok != 0) {
- @global(LastErrorNumber) = __MKSMALLINT(ok);
- RETURN (false);
+ } else {
+ __setAtExitLongJmp(0);
}
} else {
+ // arrive here if FreeLibrary does exit
__setAtExitLongJmp(0);
- console_fprintf(stderr, "ObjectFileLoader [warning]: FreeLibrary called exit() - ignored\n");
+ console_fprintf(__win32_stderr(), "ObjectFileLoader [warning]: FreeLibrary called exit() - ignored\n");
}
RETURN (true);
- }
- RETURN (false);
-#endif
+ }
+ RETURN (false);
+# endif // !defined(__BORLAND_C__)
+#endif // WIN_DL
#ifdef SYSV4_DL
{
- void *h;
- INT val;
- OBJ low = sysHandle1, hi = sysHandle2;
-
- if (__bothSmallInteger(low, hi)) {
+ if (__bothSmallInteger(sysHandle1, sysHandle2)) {
+ void *handle;
+ unsigned INT val;
+
#if __POINTER_SIZE__ == 8
- val = (__intVal(hi) << 32) + __intVal(low);
+ val = ((unsigned INT)__intVal(sysHandle2) << 32) + (unsigned INT)__intVal(sysHandle1);
#else
- val = (_intVal(hi) << 16) + _intVal(low);
+ val = ((unsigned INT)_intVal(sysHandle2) << 16) + (unsigned INT)_intVal(sysHandle1);
#endif
- h = (void *)(val);
+ handle = (void *)(val);
if (@global(Verbose) == true)
- console_printf("close handle = %"_lx_"\n", (INT)h);
- if (dlclose(h) != 0) {
+ console_printf("close handle = %p\n", handle);
+ if (dlclose(handle) != 0) {
console_fprintf(stderr, "dlclose failed with:<%s>\n", dlerror());
RETURN (false);
}
@@ -3716,6 +3634,8 @@
#endif
%}.
^ false
+
+ "Modified: / 13-02-2020 / 15:46:13 / Stefan Vogel"
!
unloadDynamicObject:handle
@@ -3726,7 +3646,7 @@
module. Calling it for still living classes will definitely
lead to some fatal conditions to occur later."
- |key fileName functionName deInitAddr m|
+ |key fileName functionName deInitAddr method|
Verbose ifTrue:[
'unload module name=' errorPrint. handle pathName errorPrintCR.
@@ -3824,19 +3744,17 @@
but make it unexecutable. Its still visible in the browser.
"
handle isMethodHandle ifTrue:[
- ((m := handle method) notNil
- and:[m ~~ 0]) ifTrue:[
- m makeUnloaded.
- ]
+ method := handle method.
+ (method notNil and:[method ~~ 0]) ifTrue:[
+ method makeUnloaded.
+ ].
+ ObjectMemory flushCaches.
].
handle isClassLibHandle ifTrue:[
Smalltalk flushCachedClasses.
Class flushSubclassInfo.
].
- handle isMethodHandle ifTrue:[
- ObjectMemory flushCaches.
- ].
handle moduleID:nil.
handle sysHandle1:nil.
@@ -3872,7 +3790,7 @@
"/ Old way: now obsolete and will wanish soon.
binaryClassLibraryFilename exists ifFalse:[
"/ mhmh - is this a good idea ? (temporary kludge)
- ExternalAddress pointerSize == 4 ifTrue:[
+ ExternalBytes sizeofPointer == 4 ifTrue:[
binaryClassLibraryFilename := dir / 'objbc' / shLibName.
binaryClassLibraryFilename exists ifFalse:[
binaryClassLibraryFilename := dir / 'objvc' / shLibName.
--- a/ParseError.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ParseError.st Tue Aug 25 12:20:06 2020 +0100
@@ -50,9 +50,13 @@
!ParseError methodsFor:'accessing'!
description
+ "construct the description from my default description (i.e. 'Parse Error:'),
+ followed by the actual parse-error-message, followed by the lineNumber (if known)"
+
|s|
s := super description.
+
s last isSeparator ifFalse:[
errorMessage notEmptyOrNil ifTrue:[
s := s , ' '
@@ -60,21 +64,32 @@
].
s := s , (errorMessage ? '').
lineNumber notNil ifTrue:[
- s := s , ' [Line ' , lineNumber asString , ']'
+ "/ avoid redundant information (in case the line number is already in the description)
+ (s includesString:'[Line:') ifFalse:[
+ s := s , ' [Line ' , lineNumber asString , ']'
+ ].
].
^ s
!
endPosition
+ "the end-tokenposition, where the error is located"
+
^ endPosition
!
+endPosition:anInteger
+ "the end-tokenposition, where the error is located"
+
+ endPosition := anInteger.
+!
+
errorMessage
^ errorMessage
!
-errorMessage:something
- errorMessage := something.
+errorMessage:aString
+ errorMessage := aString.
!
errorMessage:errorMessageArg startPosition:startPositionArg
@@ -89,11 +104,15 @@
!
lineNumber
+ "the lineNumber, where the error was detected"
+
^ lineNumber
!
-lineNumber:something
- lineNumber := something.
+lineNumber:anInteger
+ "the lineNumber, where the error was detected"
+
+ lineNumber := anInteger.
!
parser
@@ -101,7 +120,28 @@
!
startPosition
+ "the start-tokenposition, where the error is located"
+
^ startPosition
+!
+
+startPosition:anInteger
+ "the start-tokenposition, where the error is located"
+
+ startPosition := anInteger.
+!
+
+startPosition:startPositionArg endPosition:endPositionArg
+ startPosition := startPositionArg.
+ endPosition := endPositionArg.
+! !
+
+!ParseError methodsFor:'compatibility - VW'!
+
+position
+ ^ startPosition
+
+ "Created: / 03-05-2020 / 23:44:48 / cg"
! !
!ParseError class methodsFor:'documentation'!
--- a/ParseErrorNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ParseErrorNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -129,6 +129,13 @@
"Created: / 09-07-2011 / 22:29:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
+!ParseErrorNode methodsFor:'enumeration'!
+
+childrenDo:aBlock
+ children notNil ifTrue:[
+ children do:aBlock
+ ]
+! !
!ParseErrorNode methodsFor:'printing & storing'!
--- a/ParseNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ParseNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -57,6 +57,110 @@
^ (self basicNew) type:t
! !
+!ParseNode methodsFor:'RBParser compatibility'!
+
+bestNodeFor: anInterval
+ (self intersectsInterval: anInterval) ifFalse: [^nil].
+ (self containedBy: anInterval) ifTrue: [^self].
+
+ self childrenDo:[:each |
+ | node |
+ node := each bestNodeFor: anInterval.
+ node notNil ifTrue: [^node]
+ ].
+ ^ nil
+!
+
+children
+ |children|
+
+ children := OrderedCollection new.
+ self childrenDo:[:each |
+ self assert:(each notNil).
+ children add:each
+ ].
+ ^ children.
+!
+
+childrenDo:aBlock
+ ^ self
+!
+
+containedBy:anInterval
+ "true if the interval contains me completely"
+
+ startPosition isNil ifTrue:[^ false].
+ endPosition isNil ifTrue:[^ false].
+ ^ anInterval first <= startPosition and:[anInterval last >= endPosition]
+!
+
+intersectsInterval: anInterval
+ |myStart myStop ivStart ivStop|
+
+ myStart := startPosition.
+ myStop := endPosition.
+ ivStart := anInterval first.
+ ivStop := anInterval last.
+ (myStart notNil and:[ivStop < myStart]) ifTrue:[^ false].
+ (myStop notNil and:[ivStart > myStop]) ifTrue:[^ false].
+ ^ true
+!
+
+nodesDo:aBlock
+ aBlock value: self.
+ self children do: [:each | each nodesDo: aBlock]
+!
+
+start
+ "for RBToken compat."
+
+ ^ self startPosition
+!
+
+whichNodeIntersects: anInterval
+ | selectedChildren nChildren |
+
+ (self intersectsInterval: anInterval) ifFalse: [^nil].
+
+ selectedChildren := self children select:[:each |
+ each intersectsInterval: anInterval
+ ].
+
+ nChildren := selectedChildren size.
+ nChildren == 0 ifTrue:[
+ ^ self "/ I intersect
+ ].
+ nChildren == 1 ifTrue:[
+ ^ selectedChildren first whichNodeIntersects: anInterval
+ ].
+"/ self halt:'should this happen ?'.
+ ^ self "/ I intersect
+!
+
+whichNodeIsContainedBy:anInterval
+ |firstChildInInterval|
+
+ (self intersectsInterval: anInterval) ifFalse: [^nil].
+ (self containedBy: anInterval) ifTrue: [^self].
+
+ self childrenDo:[:each |
+ (each intersectsInterval:anInterval) ifTrue:[
+ firstChildInInterval notNil ifTrue:[
+ "/ ouch: multiple children in interval
+ ^ self
+ ].
+ firstChildInInterval := each
+ ].
+ ].
+
+ firstChildInInterval isNil ifTrue:[
+ "/ no children in interval; so it must be me
+ ^ self
+ ].
+ "/ look deeper
+ ^ firstChildInInterval whichNodeIsContainedBy:anInterval.
+! !
+
!ParseNode methodsFor:'accessing'!
enclosingBlock
@@ -79,6 +183,7 @@
!
endPosition:aCharacterPosition
+ self assert:aCharacterPosition > 0.
endPosition := aCharacterPosition
@@ -166,19 +271,30 @@
!
startPosition:start
-
+ self assert:start > 0.
startPosition := start
"Modified: / 08-04-2011 / 22:03:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-startPosition:start endPosition: end
-
+startPosition:start endPosition:end
+ (start == -1 and:[end == -1]) ifTrue:[
+ "/ a synthetic node
+ "/ self halt.
+ ] ifFalse:[
+ "/ nil end means: up-to-end (but only for error nodes)
+ self assert:(start notNil and:[start > 0]).
+ end isNil ifTrue:[
+ self assert:(self isErrorNode)
+ ] ifFalse:[
+ self assert:(end >= start).
+ ].
+ ].
startPosition := start.
endPosition := end.
- ^self
"Created: / 11-07-2011 / 17:44:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 15-02-2019 / 14:39:10 / Claus Gittinger"
!
type
@@ -187,14 +303,15 @@
^ type
! !
-
!ParseNode methodsFor:'attributes access'!
objectAttributes
+ "return a Collection of attributes - nil if there is none."
^attributes
"Created: / 09-07-2011 / 12:17:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 18-06-2020 / 12:20:25 / cg"
!
objectAttributes: anObject
@@ -215,8 +332,7 @@
codeForSideEffectOn:aStream inBlock:b for:aCompiler
"generate code for this statement - value not needed"
- self codeOn:aStream inBlock:b for:aCompiler.
- aStream nextPut:#drop
+ self codeThenDropOn:aStream inBlock:b for:aCompiler
!
codeForSimpleReturnOn:aStream inBlock:b lineNumber:lineNrOrNil for:aCompiler
@@ -253,6 +369,13 @@
aCompiler codeSourcePosition:nr on:codeStream
"Created: / 31-05-2015 / 03:45:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeThenDropOn:aStream inBlock:b for:aCompiler
+ "generate code for this statement - value not needed"
+
+ self codeOn:aStream inBlock:b for:aCompiler.
+ aStream nextPut:#drop
! !
!ParseNode methodsFor:'code generation helpers'!
@@ -371,6 +494,18 @@
!ParseNode methodsFor:'enumeration'!
+allMessageSelectorsDo:aBlock
+ "evaluate aBlock for each message-node here and in subnodes"
+
+ ^ self messageSelectorsDo:aBlock
+!
+
+allMessagesDo:aBlock
+ "evaluate aBlock for each message-node here and in subnodes"
+
+ ^ self messagesDo:aBlock
+!
+
allNodesDo:aBlock
"evaluate aBlock for each variable-node here and in subnodes"
@@ -433,6 +568,31 @@
^ self
!
+statements:statements do:aBlock
+ |s|
+
+ statements isNil ifTrue:[^ self].
+
+ "/ temporary hack
+ statements isCollection ifTrue:[
+ statements do:aBlock.
+ ] ifFalse:[
+ "/ bad hack
+ (statements isKindOf:StatementNode) ifTrue:[
+ s := statements.
+ [ s notNil ] whileTrue:[
+ aBlock value:s.
+ s := s nextStatement
+ ].
+ ] ifFalse:[
+ "/ an innerblock node
+ aBlock value:statements.
+ ].
+ ].
+
+ "Modified: / 10-07-2019 / 02:32:21 / Claus Gittinger"
+!
+
variableNodesDo:aBlock
"evaluate aBlock for each variable-node here and in subnodes"
@@ -463,8 +623,6 @@
"Created: / 22-02-2011 / 16:29:50 / Jakub <zelenja7@fel.cvut.cz>"
! !
-
-
!ParseNode methodsFor:'printing & storing'!
printOn:aStream
@@ -493,6 +651,10 @@
].
"Created: / 20-04-2005 / 14:21:28 / cg"
+!
+
+printStatementListOn:aStream indent:i
+ self printOn:aStream indent:i
! !
!ParseNode methodsFor:'private'!
@@ -521,6 +683,10 @@
^ false
!
+parseNodeVisitorClass
+ ^ ParseNodeVisitor
+!
+
positionToInsertPeriodForStatementSeparation
^ self endPosition + (parenthized == true ifTrue:1 ifFalse:0)
@@ -531,6 +697,25 @@
^ 9999
!
+whoDefines:aName
+ "return the node (blockNode) in which this variable is defined.
+ (nil if instvar, classvar or global)"
+
+ |p|
+
+ "/ TODO
+"/ block notNil ifTrue:[
+"/ self halt
+"/ ].
+ p := parent.
+ [p notNil and:[p isFunctionNode not and:[p isBlockNode not]]] whileTrue:[ p := p parent].
+ p notNil ifTrue:[
+ ((p arguments ? #()) contains:[:var | var name = aName]) ifTrue:[^ p].
+ ((p localVariables ? #()) contains:[:var | var name = aName]) ifTrue:[^ p].
+ ].
+ ^ nil
+!
+
withConstantValueDo:aBlock
"return true, if this evaluates to a constant value
and evaluate aBlock with it"
@@ -582,10 +767,30 @@
^ false
!
+isConstantNumber
+ "return true, if this is a node for a constant number"
+
+ ^ false
+
+ "Created: / 16-06-2018 / 08:47:03 / Claus Gittinger"
+!
+
isErrorNode
^ false
!
+isFunctionCallNode
+ ^ false
+
+ "Created: / 13-12-2018 / 22:35:28 / Claus Gittinger"
+!
+
+isFunctionNode
+ ^ false
+
+ "Created: / 08-02-2019 / 10:53:58 / Claus Gittinger"
+!
+
isGlobal
"return true, if this is a node for a global variable"
@@ -688,6 +893,18 @@
^ self isConstant
!
+isLiteralArray
+ "for compatibility with RB-AST"
+
+ ^ false
+!
+
+isLiteralCString
+ "for compatibility with RB-AST"
+
+ ^ false
+!
+
isLocalVariable
^ false
!
@@ -742,6 +959,12 @@
^ false
!
+isSequence
+ "return true, if this is a sequence node (JS)"
+
+ ^ false
+!
+
isStatementNode
"return true, if this is a statement node"
@@ -756,6 +979,12 @@
^ false
!
+isSynthetic
+ "true if I am a synthetic node (generated from embedded expression strings)"
+
+ ^ false
+!
+
isThis
"for JavaScript"
--- a/ParseNodeVisitor.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ParseNodeVisitor.st Tue Aug 25 12:20:06 2020 +0100
@@ -14,7 +14,7 @@
"{ NameSpace: Smalltalk }"
Object subclass:#ParseNodeVisitor
- instanceVariableNames:''
+ instanceVariableNames:'pluggableActionsPerNodeType'
classVariableNames:''
poolDictionaries:''
category:'System-Compiler-Support'
@@ -43,23 +43,40 @@
"
! !
+!ParseNodeVisitor methodsFor:'pluggable setup'!
+
+actionForNodeClass:aNodeClass put:aBlock
+ "setup so that for nodes of type aNodeClass, aBlock is invoked.
+ If the block returns true, subnodes (eg. right side of assignments, etc.)
+ will be enumerated as well.
+ Otherwise, no subnodes are visited."
+
+ pluggableActionsPerNodeType isNil ifTrue:[
+ pluggableActionsPerNodeType := Dictionary new.
+ ].
+ pluggableActionsPerNodeType at:aNodeClass put:aBlock
+! !
+
!ParseNodeVisitor methodsFor:'visiting'!
visit:anObject
+ |action stmt lastResult|
- | stmt |
+ action := pluggableActionsPerNodeType at:(anObject class) ifAbsent:[nil].
+ action notNil ifTrue:[
+ (action value:anObject) ifFalse:[^ self].
+ ].
- ^anObject isStatementNode
- ifTrue:[
- stmt := anObject.
- [ stmt isNil ] whileFalse:[
- stmt acceptVisitor:self.
- stmt := stmt nextStatement.
- ]
- ]
- ifFalse:[
- anObject acceptVisitor: self.
- ]
+ anObject isStatementNode ifTrue:[
+ stmt := anObject.
+ [ stmt isNil ] whileFalse:[
+ lastResult := stmt acceptVisitor:self.
+ stmt := stmt nextStatement.
+ ].
+ ^ lastResult
+ ] ifFalse:[
+ ^ anObject acceptVisitor: self.
+ ]
"Modified: / 25-07-2011 / 22:33:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
@@ -164,6 +181,19 @@
"/ to be redefined in subclasses
! !
+!ParseNodeVisitor methodsFor:'visiting - javaScript'!
+
+doesNotUnderstand:aMessage
+ "catch to prevent stupid error reports from Explainer in end-user app (expecco)"
+
+ Smalltalk isStandAloneApp ifTrue:[^ self].
+ "/ ((aMessage selector startsWith:'visit')
+ "/ and:[ aMessage selector endsWith:'Node:' ]) ifTrue:[
+ "/ ^ self.
+ "/ ].
+ ^ super doesNotUnderstand:aMessage.
+! !
+
!ParseNodeVisitor class methodsFor:'documentation'!
version
--- a/ParseWarning.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ParseWarning.st Tue Aug 25 12:20:06 2020 +0100
@@ -34,6 +34,23 @@
other person. No title to or ownership of the software is
hereby transferred.
"
+!
+
+documentation
+"
+ Warnings generated by parsers (eg. the Smalltalk code parser).
+ In unhandled, a message is sent to the Transcript and the compilation proceeds.
+
+ [author:]
+ Claus Gittinger
+
+ [instance variables:]
+
+ [class variables:]
+
+ [see also:]
+
+"
! !
!ParseWarning methodsFor:'accessing'!
@@ -68,6 +85,11 @@
startPosition:something
startPosition := something.
+!
+
+startPosition:startPositionArg endPosition:endPositionArg
+ startPosition := startPositionArg.
+ endPosition := endPositionArg.
! !
!ParseWarning methodsFor:'default action'!
--- a/Parser.st Sat Aug 08 22:49:53 2020 +0100
+++ b/Parser.st Tue Aug 25 12:20:06 2020 +0100
@@ -38,11 +38,13 @@
interactiveMode variableCorrectActionForAll annotations
variableTypeOfLastCorrectAction usedPoolVars readPoolVars
modifiedPoolVars warnings didWarnAboutSTXExtensions
- annotationStartPosition annotationEndPosition autoDefineVariables'
+ annotationStartPosition annotationEndPosition autoDefineVariables
+ initExpressionsForLocals'
classVariableNames:'PrevClass PrevInstVarNames PrevClassVarNames
PrevClassInstVarNames LazyCompilation FoldConstants
LineNumberInfo SuppressDoItCompilation ParseErrorSignal
- AlreadyWarnedUnimplementedSelectorsPerReceiverClass'
+ AlreadyWarnedUnimplementedSelectorsPerReceiverClass
+ WarnAboutInlineObjects WarnAboutPossibleNameClashes'
poolDictionaries:''
category:'System-Compiler'
!
@@ -89,8 +91,22 @@
privateIn:Parser
!
-Parser::Correction subclass:#CorrectByInsertingPeriod
- instanceVariableNames:'positionOfPeriod'
+Parser::Correction subclass:#CorrectByInserting
+ instanceVariableNames:'positionToInsert whatToInsert'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:Parser
+!
+
+Parser::CorrectByInserting subclass:#CorrectByInsertingColon
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:Parser
+!
+
+Parser::CorrectByInserting subclass:#CorrectByInsertingPeriod
+ instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
privateIn:Parser
@@ -424,7 +440,8 @@
!Parser class methodsFor:'Compatibility-ST80'!
parse:aString class:aClass
- "same as #parseMethod:in: for ST80 compatibility."
+ "parse whatever is the unit of compilation in ST/X's browser.
+ Same as #parseMethod:in: for ST80 compatibility."
|parser|
@@ -599,14 +616,16 @@
!
allowReservedWordsAsSelectors
- "return true, if self, super, thisContext, nil, true and false are to be allowed
+ "if true, 'self', 'super', 'thisContext', 'nil', 'true' and 'false' are allowed
as unary message selectors."
^ ParserFlags allowReservedWordsAsSelectors
+
+ "Modified (format): / 25-06-2019 / 11:17:09 / Claus Gittinger"
!
allowReservedWordsAsSelectors:aBoolean
- "enable/disable, if self, super, thisContext, nil, true and false are to be allowed
+ "enable/disable, if 'self', 'super', 'thisContext', 'nil', 'true' and 'false' are to be allowed
as unary message selectors."
ParserFlags allowReservedWordsAsSelectors:aBoolean.
@@ -616,6 +635,8 @@
self allowReservedWordsAsSelectors:true
self allowReservedWordsAsSelectors:false
"
+
+ "Modified (comment): / 25-06-2019 / 11:17:52 / Claus Gittinger"
!
arraysAreImmutable
@@ -813,9 +834,40 @@
The way spelling distance is computed is a heuristic which works
well in real life (i.e. offer USEFUL suggestions)"
- |info selectorsAlready block lcSelector excludedClasses minNumArgs|
-
- excludedClasses := { ProtoObject . Structure . InlineObjectPrototype }.
+ ^ self
+ findBest:nMax selectorsFor:aString
+ in:aClassOrNil forCompletion:forCompletion ignoreIfAnnotatedWith:nil
+
+ "
+ 'select:' spellAgainst:'collect' 57
+ 'collectWithIndex:' spellAgainst:'collect' 41
+
+ self findBest:20 selectorsFor:'i' in:nil forCompletion:true
+
+ self findBest:20 selectorsFor:'collect' in:Collection forCompletion:true
+ self findBest:100 selectorsFor:'collect' in:Collection forCompletion:true
+
+ self findBest:20 selectorsFor:'collect:' in:SequenceableCollection forCompletion:true
+ self findBest:100 selectorsFor:'collect:' in:SequenceableCollection forCompletion:true
+ "
+
+ "Modified (comment): / 01-05-2016 / 17:20:37 / cg"
+ "Modified: / 21-03-2019 / 18:58:52 / Claus Gittinger"
+!
+
+findBest:nMax selectorsFor:aString in:aClassOrNil forCompletion:forCompletion ignoreIfAnnotatedWith:annotationOrNil
+ "soon OBSOLETE and moved to DWIM.
+ Collect known selectors with their spelling distances to aString;
+ return the nMax best suggestions. If the argument, aClassOrNil is not nil,
+ the message is assumed to be sent to instances of that class
+ (i.e. offer corrections from that hierarchy only).
+ If forCompletion isTrue, prefix sequences are preferred.
+ The way spelling distance is computed is a heuristic which works
+ well in real life (i.e. offer USEFUL suggestions)"
+
+ |info selectorsAlready checkBlock lcSelector excludedClasses minNumArgs|
+
+ excludedClasses := { ProtoObject . Structure . InlineObject prototype }.
minNumArgs := aString argumentCount.
@@ -825,44 +877,70 @@
lcSelector := aString asLowercase.
- block := [:sym :mthd|
- |similarity lcSym keepThis nCommon fractionCommon similarityRest|
-
- (forCompletion and:[sym = aString or:[sym argumentCount < minNumArgs]]) ifFalse:[
- lcSym := sym asLowercase.
- (selectorsAlready includes:sym) ifFalse:[
- "/ (info contains:[:i | i key == sym]) ifFalse:[
-
- forCompletion ifTrue:[
- "/ OLD: similarity := 100 * (1 + (lcSelector size / lcSym size)).
-
- nCommon := (lcSelector commonPrefixWith:lcSym) size.
- nCommon > 0 ifTrue:[
- "/ the longer the common prefix...
- fractionCommon := (nCommon / lcSym size).
- "/ bump it to 100+x if lc-prefix; to 200+x if real prefix
- (sym startsWith:aString) ifTrue:[
- similarity := 200 * (1 + fractionCommon).
+ checkBlock :=
+ [:sym :mthd|
+ |similarity similarity2 lcSym keepThis nCommon fractionCommon similarityRest idx|
+
+ (forCompletion and:[sym = aString or:[sym argumentCount < minNumArgs]]) ifFalse:[
+ (selectorsAlready includes:sym) ifFalse:[
+ "/ (info contains:[:i | i key == sym]) ifFalse:[
+
+ lcSym := sym asLowercase.
+ forCompletion ifTrue:[
+ similarity := 0.
+
+ "/ substring?
+ idx := (lcSym indexOfString:lcSelector).
+ idx ~~ 0 ifTrue:[
+ "/ yes
+
+ "/ part of a keyword part?
+ (lcSym includes:$:) ifTrue:[
+ lcSym keywords do:[:each |
+ |withoutColon|
+ (each includesString:lcSelector) ifTrue:[
+ withoutColon := each copyButLast.
+ withoutColon size ~~ 0 ifTrue:[ "beware of division by zero!!"
+ fractionCommon := (lcSelector size / withoutColon size).
+ ((withoutColon startsWith:lcSelector) or:[withoutColon endsWith:lcSelector]) ifTrue:[
+ fractionCommon := fractionCommon * 1.2.
+ ].
+ similarity := similarity max:(150 * (1 + fractionCommon)).
+ ].
+ ].
+ ].
+ ].
+ "/ the longer the common substring...
+ fractionCommon := (lcSelector size / lcSym size).
+ similarity := similarity max:(150 * (1 + fractionCommon)).
+ ].
+
+ nCommon := (lcSelector commonPrefixWith:lcSym) size.
+ nCommon > 0 ifTrue:[
+ "/ the longer the common prefix...
+ fractionCommon := (nCommon / lcSym size).
+ "/ bump it to 100+x if lc-prefix; to 200+x if real prefix
+ (sym startsWith:aString) ifTrue:[
+ similarity2 := 200 * (1 + fractionCommon).
+ ] ifFalse:[
+ similarity2 := 100 * (1 + fractionCommon).
+ ].
+ similarityRest := (lcSelector copyFrom:nCommon+1) spellAgainst:(lcSym copyFrom:nCommon+1).
+ similarity2 := similarity2 + similarityRest.
+
+ "/ higher similarity for my own messages
+ ((lcSym startsWith:lcSelector) and:[ aClassOrNil == mthd mclass ]) ifTrue:[
+ similarity2 := similarity2 * 1.2.
+ ].
] ifFalse:[
- similarity := 100 * (1 + fractionCommon).
+ similarity2 := lcSelector spellAgainst:lcSym. "/ 0..100
].
- similarityRest := (lcSelector copyFrom:nCommon+1) spellAgainst:(lcSym copyFrom:nCommon+1).
- similarity := similarity + similarityRest.
-
- "/ higher similarity for my own messages
- ((lcSym startsWith:lcSelector) and:[ aClassOrNil == mthd mclass ]) ifTrue:[
- similarity := similarity * 1.2.
- ].
+ similarity := similarity max:similarity2.
] ifFalse:[
similarity := lcSelector spellAgainst:lcSym. "/ 0..100
- ]
- ] ifFalse:[
- similarity := lcSelector spellAgainst:lcSym. "/ 0..100
- ].
-
- ((similarity > 30 "40") or:[ (lcSelector size>1) and:[(lcSym startsWith:lcSelector)] ]) ifTrue:[
- (selectorsAlready includes:sym) ifFalse:[
- "/ (info contains:[:entry | entry key = sym]) ifFalse:[
+ ].
+
+ ((similarity > 30 "40") or:[ (lcSelector size>1) and:[(lcSym startsWith:lcSelector)] ]) ifTrue:[
keepThis := true.
info size >= nMax ifTrue:[
"will remove last entry anyway - so check if this one will remain..."
@@ -873,13 +951,16 @@
keepThis ifTrue:[
"expensive - therefore do this check at last"
mthd isObsolete ifFalse:[
- info add:(sym -> similarity).
- info size > nMax ifTrue:[
- |droppedSelector|
-
- droppedSelector := info last key.
- selectorsAlready remove:droppedSelector.
- info removeLast.
+ (annotationOrNil isNil
+ or:[ (mthd hasResource:annotationOrNil) not ]) ifTrue:[
+ info add:(sym -> similarity).
+ info size > nMax ifTrue:[
+ |droppedSelector|
+
+ droppedSelector := info last key.
+ selectorsAlready remove:droppedSelector.
+ info removeLast.
+ ].
].
selectorsAlready add:sym.
]
@@ -887,27 +968,26 @@
]
]
]
- ]
- ].
+ ].
(aClassOrNil isNil or:[aClassOrNil == Object]) ifTrue:[
Smalltalk allClassesDo:[:cls |
(excludedClasses includes:cls) ifFalse:[
- cls methodDictionary keysAndValuesDo:block.
- cls class methodDictionary keysAndValuesDo:block.
+ cls methodDictionary keysAndValuesDo:checkBlock.
+ cls class methodDictionary keysAndValuesDo:checkBlock.
]
]
] ifFalse:[
aClassOrNil autoload.
aClassOrNil withAllSuperclassesDo:[:cls |
"/ Transcript showCR:'try ',cls name.
- cls methodDictionary keysAndValuesDo:block.
+ cls methodDictionary keysAndValuesDo:checkBlock.
"/ cls class methodDictionary keysAndValuesDo:block.
].
- aClassOrNil withAllSubclassesDo:[:cls |
- cls methodDictionary keysAndValuesDo:block.
- "/ cls class methodDictionary keysAndValuesDo:block.
- ].
+"/ aClassOrNil withAllSubclassesDo:[:cls |
+"/ cls methodDictionary keysAndValuesDo:checkBlock.
+"/ "/ cls class methodDictionary keysAndValuesDo:block.
+"/ ].
].
^ info collect:[:a | a key] as:OrderedCollection.
@@ -925,7 +1005,8 @@
self findBest:100 selectorsFor:'collect:' in:SequenceableCollection forCompletion:true
"
- "Modified (comment): / 01-05-2016 / 17:20:37 / cg"
+ "Created: / 21-03-2019 / 18:58:06 / Claus Gittinger"
+ "Modified: / 22-10-2019 / 18:57:56 / Stefan Vogel"
!
findBestSelectorsFor:aString
@@ -1399,11 +1480,13 @@
].
tree := compiler parseMethodBody.
- ].
-
- (compiler errorFlag
- or:[tree == #Error
- or:[tree isNil]]) ifTrue:[
+ compiler checkForEndOfInput.
+ ].
+
+ (compiler hasError
+ or:[tree == #Error
+ or:[tree isNil]]
+ ) ifTrue:[
^ nil
].
@@ -1418,7 +1501,7 @@
].
nA notNil ifTrue:[
- blocks := blocks select:[:aBlock | aBlock numArgs == nA ].
+ blocks := blocks select:[:aBlock | aBlock argumentCount == nA ].
blocks size == 1 ifTrue:[
^ blocks at:1
].
@@ -1454,6 +1537,7 @@
"Created: / 11-01-1997 / 23:29:13 / cg"
"Modified: / 14-02-1997 / 16:51:25 / cg"
"Modified (format): / 23-12-2015 / 17:33:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 23-05-2019 / 09:28:18 / Claus Gittinger"
!
parseExpression:aString
@@ -1682,15 +1766,16 @@
"Modified: 24.4.1996 / 13:30:03 / cg"
!
-parseMethodArgAndVarSpecification:aString in:aClass ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings parseBody:body
- "parse a methods selector, arg and var spec in a given class;
- If parseBody is true, also parse the statements
+parseMethodArgAndVarSpecification:aString in:aClass ignoreErrors:ignoreErrors ignoreWarnings:ignoreWarnings parseBody:parseBodyBoolean
+ "parse a method's selector, arg and var spec in a given class;
+ If parseBodyBoolean is true, also parse the statements
(for primitives & resourceSpecs).
The noErrors and noWarnings arguments specify if error and warning
messages should be sent to the Transcript or suppressed.
Return a parser (if ok), nil (empty) or #Error (syntax).
- The parser can be queried for selector, receiver, args and locals"
+ The parser can be queried for selector, receiver, args and locals.
+ (and also: initializerExpressions)"
|parser|
@@ -1704,7 +1789,7 @@
"/ used to be #parseMethodBodyVarSpec
"/ - now, alternatively parse body for resource & primitive specs ..
"/
- body ifTrue:[
+ parseBodyBoolean ifTrue:[
parser parseMethodBodyOrEmpty
] ifFalse:[
parser parseMethodBodyVarSpec
@@ -1712,8 +1797,9 @@
"/ parser errorFlag ifTrue:[^ nil].
^ parser
- "Created: 24.4.1996 / 13:13:06 / cg"
- "Modified: 27.4.1996 / 16:58:02 / cg"
+ "Created: / 24-04-1996 / 13:13:06 / cg"
+ "Modified: / 27-04-1996 / 16:58:02 / cg"
+ "Modified (comment): / 23-05-2019 / 09:21:47 / Claus Gittinger"
!
parseMethodArgAndVarSpecificationSilent:aString
@@ -1855,9 +1941,7 @@
stringParsed := aString withoutSeparators.
stringParsed isEmpty ifTrue:[^ nil].
- (stringParsed startsWith:'^') ifTrue:[
- stringParsed := stringParsed copyFrom:2.
- ].
+ stringParsed := stringParsed withoutPrefix:'^'.
Error
handle:[:ex | ]
@@ -1903,6 +1987,7 @@
Parser selectorInExpression:'(foo at:1) at:1'
Parser selectorInExpression:'a + 4'
Parser selectorInExpression:'a negated'
+ Parser selectorInExpression:'^ a negated'
Parser selectorInExpression:'at:1 put:5'
Parser selectorInExpression:'at:1 put:'
Parser selectorInExpression:'a at:1 put:5'
@@ -1910,7 +1995,7 @@
Parser selectorInExpression:'a := foo at:1 put:5'
"
- "Modified (comment): / 28-02-2012 / 10:11:15 / cg"
+ "Modified: / 12-06-2020 / 16:06:33 / cg"
!
withSelf:anObject parseExpression:aString notifying:someOne
@@ -2031,15 +2116,22 @@
genMakeArrayWith:elementExpressions
"return a node to generate an array at runtime.
Will generate:
- Array with:el1 ... with:elN (if N <= 5)
- or:
+ literal shallowCopy (if all elements are literals)
+ or else:
+ Array with:el1 ... with:elN (if N <= 8)
+ or else:
(Array new at:1 put:el1; ... at:N put:elN; yourself) (otherwise)
"
|numEl arrRec sel expr|
+ (elementExpressions conform:#isConstant) ifTrue:[
+ arrRec := ConstantNode type:#Array value:(elementExpressions collect:#value as:Array) from:-1 to:-1. "/ position -1 means artifitial node
+ ^ MessageNode receiver:arrRec selector:#shallowCopy.
+ ].
+
arrRec := VariableNode globalNamed:#Array.
- arrRec startPosition: -1 endPosition: -1. "/ -1 means artifitial node
+ arrRec startPosition:-1 endPosition:-1. "/ position -1 means artifitial node
numEl := elementExpressions size.
@@ -2065,7 +2157,7 @@
expr := MessageNode
receiver:arrRec
selector:#new:
- arg:(ConstantNode type:#Integer value:numEl from: -1 to: -1). "/ -1 means artifitial node
+ arg:(ConstantNode type:#Integer value:numEl from:-1 to:-1). "/ position -1 means artifitial node
numEl == 0 ifTrue:[
^ expr.
@@ -2075,7 +2167,7 @@
expr := (idx == 1 ifTrue:[MessageNode] ifFalse:[CascadeNode])
receiver:expr
selector:#at:put:
- arg1:(ConstantNode type:#Integer value:idx from: -1 to:-1)"/ -1 means artifitial node
+ arg1:(ConstantNode type:#Integer value:idx from:-1 to:-1)"/ position -1 means artifitial node
arg2:e
fold:false.
].
@@ -2102,53 +2194,23 @@
"Modified: / 22-10-2006 / 02:25:37 / cg"
!
-make:anObject immutable:whichImmutableClass
- "helper to optionally make Arrays, ByteArrays and Strings immutable."
+makeImmutable:anObject
+ "helper to optionally make Array-, ByteArray- and String literals immutable.
+ Creates and returns an immutable copy of the object"
|newObject|
- newObject := anObject copy.
- whichImmutableClass notNil ifTrue:[
- newObject changeClassTo:whichImmutableClass.
- ].
+ newObject := anObject shallowCopy.
newObject beImmutable.
^ newObject
-!
-
-makeImmutableArray:anArray
- "helper to optionally make an array immutable."
-
- ^ self make:anArray immutable:ImmutableArray
-!
-
-makeImmutableByteArray:aByteArray
- "helper to optionally make a byte array immutable."
-
- ^ self make:aByteArray immutable:ImmutableByteArray
-!
-
-makeImmutableString:aString
- "helper to optionally make a string immutable."
-
- |width immutableStringClass|
-
- (width := aString bitsPerCharacter) > 8 ifTrue:[
- width > 16 ifTrue:[
- immutableStringClass := (Smalltalk at:#ImmutableUnicode32String)
- ] ifFalse:[
- immutableStringClass := (Smalltalk at:#ImmutableUnicode16String)
- ].
- ] ifFalse:[
- immutableStringClass := ImmutableString
- ].
-
- "/ a temporary hack, which will still work,
- "/ when the new immutable string classes are present.
- immutableStringClass isNil ifTrue:[
- "/ not yet avail: leave it as a regular, mutable string
- ^ aString
- ].
- ^ self make:aString immutable:immutableStringClass
+
+ "Created: / 09-06-2019 / 15:18:58 / Claus Gittinger"
+! !
+
+!Parser class methodsFor:'queries'!
+
+parseNodeVisitorClass
+ ^ ParseNodeVisitor
! !
!Parser class methodsFor:'unparsing'!
@@ -2160,7 +2222,7 @@
|argNames n|
- n := aSelector numArgs.
+ n := aSelector argumentCount.
n == 1 ifTrue:[
argNames := #('arg')
] ifFalse:[
@@ -2169,7 +2231,7 @@
'arg7' 'arg8' 'arg9' 'arg10' 'arg11' 'arg12'
'arg13' 'arg14' 'arg15')
] ifFalse:[
- argNames := (1 to:aSelector numArgs) collect:[:i | 'arg' , i printString].
+ argNames := (1 to:n) collect:[:i | 'arg' , i printString].
].
].
^ self methodSpecificationForSelector:aSelector argNames:argNames
@@ -2193,7 +2255,7 @@
|s nargs parts part|
s := WriteStream on:''.
- nargs := aSelector numArgs.
+ nargs := aSelector argumentCount.
nargs == 0 ifTrue:[
s nextPutAll:aSelector
] ifFalse:[
@@ -2247,12 +2309,15 @@
self nextToken.
parseTree := self parseMethodBody.
(errorFlag or:[tree == #Error]) ifTrue:[^ #Error].
+ self checkForEndOfInput.
parseTree notNil ifTrue:[
self evalExitBlock:[:value | ^ failBlock value].
value := parseTree evaluate
].
self release.
^ value
+
+ "Modified: / 10-02-2019 / 16:40:11 / Claus Gittinger"
!
parse:methodSource in:aClass notifying:aRequestor
@@ -2300,7 +2365,7 @@
!Parser methodsFor:'Compatibility-Squeak'!
parse:methodSource class:aClass
- "parse a methods source.
+ "parse a method's source.
Return the method's parseTree"
^ self parse:methodSource in:aClass notifying:nil
@@ -2344,9 +2409,13 @@
!
errorFlag
+ <resource: #obsolete>
"return true if there where any errors (valid after parsing)"
+ "/ use hasError
^ errorFlag
+
+ "Modified (comment): / 23-05-2019 / 09:27:42 / Claus Gittinger"
!
evalExitBlock:aBlock
@@ -2373,6 +2442,16 @@
parserFlags implicitSelfSends:aBoolean
!
+initializerExpressions
+ "as a side effect of parsing a methodBodyVarSpec,
+ these are remembered and returned here.
+ This is to support an ST/X extension."
+
+ ^ initExpressionsForLocals
+
+ "Created: / 23-05-2019 / 09:22:36 / Claus Gittinger"
+!
+
interactiveMode:aBoolean
"support for stx-scripting service"
@@ -2443,9 +2522,11 @@
release
methodArgs := methodVars := tree := selfNode := superNode := nilNode := nil.
+ methodVarNames := nil.
super release.
- "Modified: / 31.3.1998 / 19:45:58 / cg"
+ "Modified: / 31-03-1998 / 19:45:58 / cg"
+ "Modified: / 23-09-2018 / 02:17:08 / Claus Gittinger"
!
setNameSpace:aNameSpaceOrNameSpaceName
@@ -2608,8 +2689,7 @@
msg := ('variable "' , aVariableName , '" should be lowercase (by convention)').
self
warning:msg
- doNotShowAgainAction:[ ParserFlags warnAboutNonLowercaseLocalVariableNames:false.
- parserFlags warnAboutNonLowercaseLocalVariableNames:false.]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnPossibleIncompatibilities)
position:tokenPosition to:source position.
Tools::ToDoListBrowser notNil ifTrue:[
@@ -2665,7 +2745,7 @@
"/ O sound like a vowel, if not followed by 'ne'
('O' includes:firstCharacter) ifTrue:[
word size > 2 ifTrue:[
- (word copyTo:3) asLowercase = 'one' ifFalse:[
+ ((word copyTo:3) sameAs:'one') ifFalse:[
soundsLikeVowel := true.
].
].
@@ -2724,7 +2804,7 @@
bindWith:aVariableName with:whatShouldItBeNamed.
self
warning:msg
- doNotShowAgainAction:[ parserFlags warnAboutWrongVariableNames:false. ParserFlags warnAboutWrongVariableNames:false ]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnAboutWrongVariableNames)
doNotShowAgainForThisMethodAction: [ self disableWarningsOnCurrentMethodFor: #warnAboutWrongVariableNames ]
position:tokenPosition to:source position.
@@ -2740,6 +2820,7 @@
].
"Modified: / 16-03-2012 / 18:36:43 / cg"
+ "Modified: / 01-05-2019 / 11:26:36 / Claus Gittinger"
!
checkLocalVariableNameConventionsFor:aVariableName
@@ -2760,7 +2841,7 @@
msg := ('short variable name: "' , aVariableName , '"').
self
warning:('short variable name: "' , aVariableName , '"')
- doNotShowAgainAction:[ ParserFlags warnAboutShortLocalVariableNames:false]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnAboutShortLocalVariableNames)
position:tokenPosition to:source position.
Tools::ToDoListBrowser notNil ifTrue:[
@@ -2797,12 +2878,24 @@
!
checkPlausibilityOf:aNode from:startPosition to:endPosition
+ <resource: #todo>
|note fixes|
(ignoreErrors or:[ignoreWarnings]) ifTrue:[^ self].
parserFlags warnPlausibilityChecks ifFalse:[^ self].
(ParserFlags isFlag:#warnPlausibilityChecks enabledForClass:classToCompileFor selector:selector) ifFalse:[^ self].
+ aNode isMessage ifTrue:[
+ (#(isNil notNil notEmptyOrNil isEmptyOrNil ifNil: ifNotNil:) includes:aNode selector) ifFalse:[
+ "XXX: this warning is wrong, if the message is sent in a while loop
+ and inside a block that checks for nil."
+ self warnIfPossiblyUninitializedLocal:aNode receiver.
+ ].
+ aNode arguments do:[:eachArg |
+ self warnIfPossiblyUninitializedLocal:eachArg
+ ].
+ ].
+
note := self plausibilityCheck:aNode.
note notNil ifTrue:[
"/ this is a hack (which I don't like)
@@ -2821,7 +2914,7 @@
doNotShowAgainForThisMethodAction: [ self disableWarningsOnCurrentMethodFor: #warnPlausibilityChecks ]
position:startPosition to:endPosition.
fix isBehavior ifTrue:[
- self correctWith:(fix new positionOfPeriod:aNode receiver endPosition) from:startPosition to:endPosition.
+ self correctWith:(fix new positionToInsert:aNode receiver endPosition) from:startPosition to:endPosition.
].
].
].
@@ -2831,6 +2924,8 @@
].
"Created: / 19-01-2012 / 10:44:05 / cg"
+ "Modified: / 08-02-2019 / 17:22:07 / Claus Gittinger"
+ "Modified (format): / 04-03-2019 / 12:15:51 / Stefan Vogel"
!
checkReturnedValues
@@ -2848,7 +2943,7 @@
(returnsNonBooleanLiteral or:[returnsSelf]) ifTrue:[
self
warning:'Possible Error Warning:\\Method possibly returns both boolean and non-boolean values.' withCRs
- doNotShowAgainAction:[ ParserFlags warnInconsistentReturnValues:false ]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnInconsistentReturnValues)
position:1 to:tokenPosition
]
].
@@ -2969,16 +3064,17 @@
methodVars notNil ifTrue:[
unused := methodVars select:[:var| var used ~~ true] thenCollect:[:var| var name].
].
- unused size > 0 ifTrue:[
+ unused size ~~ 0 ifTrue:[
self warnUnused:unused.
].
"Created: / 17-11-2001 / 10:23:47 / cg"
"Modified: / 07-07-2010 / 15:48:24 / cg"
+ "Modified: / 01-03-2019 / 16:06:19 / Claus Gittinger"
!
isPossiblyUninitializedLocal:aNode
- |varName|
+ |varName scope|
aNode isLocalVariable ifFalse:[^ false].
hasPrimitiveCode ifTrue:[^ false]. "/ because I do not look into it, yet
@@ -2988,15 +3084,27 @@
and:[(alreadyWarnedUninitializedVars includes:varName)]) ifTrue:[^ false].
aNode isMethodVariable ifTrue:[
- currentBlock notNil ifTrue:[^ false].
(modifiedLocalVars notNil and:[(modifiedLocalVars includes:varName)]) ifTrue:[^ false].
+ (scope := currentBlock) notNil ifTrue:[
+ [scope notNil] whileTrue:[
+ ((scope modifiedLocalVars ? #()) includes:varName) ifTrue:[^ false].
+ scope := scope home
+ ].
+ ].
] ifFalse:[
aNode isBlockVariable ifTrue:[
- aNode block == currentBlock ifFalse:[^ false].
(currentBlock modifiedLocalVars notNil and:[(currentBlock modifiedLocalVars includes:varName)]) ifTrue:[^ false].
+ (scope := currentBlock home) notNil ifTrue:[
+ [scope notNil] whileTrue:[
+ ((scope modifiedLocalVars ? #()) includes:varName) ifTrue:[^ false].
+ scope := scope home
+ ].
+ ].
].
].
^ true.
+
+ "Modified: / 08-02-2019 / 17:18:29 / Claus Gittinger"
! !
!Parser methodsFor:'dummy-syntax detection'!
@@ -3353,7 +3461,7 @@
(msg1Ok and:[msg2Ok]) ifTrue:[
possibleSplits add:{ msg1 . msg2 }
] ifFalse:[
- self breakPoint:#cg.
+ self breakPoint:#cg.
]
] ifFalse:[
"/ self breakPoint:#cg.
@@ -3392,7 +3500,7 @@
(correctIt isBehavior or:[correctIt isKindOf:Correction]) ifTrue:[
self
correctWith:(correctIt instance
- positionOfPeriod:positionOfPeriod;
+ positionToInsert:positionOfPeriod;
receiverNode:receiverNode;
receiverClass:aClassOrNil;
selector:aSelectorString)
@@ -3635,7 +3743,8 @@
"/ ].
"/ ].
"/ ].
- ^ (VariableNode globalNamed:varName) startPosition: pos1 endPosition: pos2.
+ ^ (VariableNode globalNamed:varName)
+ startPosition: pos1 endPosition: pos2.
].
(correctIt isKindOf:ParseNode) ifTrue:[
@@ -3683,7 +3792,7 @@
"Modified: / 22-01-1998 / 16:34:01 / stefan"
"Modified: / 29-07-2013 / 23:11:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 21-06-2017 / 22:08:36 / cg"
+ "Modified: / 09-05-2020 / 13:16:45 / cg"
!
correctWith:correctionOperation from:pos1 to:pos2
@@ -3699,19 +3808,25 @@
!
declareUndefinedVariable:varName as:variableType
- |holder newClass owningClass|
+ |pos1 pos2 holder newClass owningClass|
+
+ pos1 := tokenPosition.
+ pos2 := tokenPosition+varName size-1.
variableType == #WorkspaceVariable ifTrue:[
holder := Workspace addWorkspaceVariable:varName.
- ^ VariableNode type:#WorkspaceVariable holder:holder name:varName
+ ^ (VariableNode type:#WorkspaceVariable holder:holder name:varName)
+ startPosition:pos1 endPosition:pos2
].
variableType == #DoItTemporary ifTrue:[
holder := self addDoItTemporary:varName.
- ^ VariableNode type:#DoItTemporary holder:holder name:varName
+ ^ (VariableNode type:#DoItTemporary holder:holder name:varName)
+ startPosition:pos1 endPosition:pos2
].
variableType == #GlobalVariable ifTrue:[
Smalltalk at:varName asSymbol put:nil.
- ^ VariableNode globalNamed:varName
+ ^ (VariableNode globalNamed:varName)
+ startPosition:pos1 endPosition:pos2
].
variableType == #NewClass ifTrue:[
@@ -3720,7 +3835,8 @@
classVariableNames:''
poolDictionaries:''
category:'* As yet uncategorized *'.
- ^ VariableNode globalNamed:newClass name
+ ^ (VariableNode globalNamed:newClass name)
+ startPosition:pos1 endPosition:pos2
].
variableType == #PrivateClass ifTrue:[
@@ -3730,17 +3846,20 @@
classVariableNames:''
poolDictionaries:''
privateIn:owningClass.
- ^ VariableNode type:#PrivateClass class:owningClass name:newClass name
+ ^ (VariableNode type:#PrivateClass class:owningClass name:newClass name)
+ startPosition:pos1 endPosition:pos2
].
variableType == #NameSpace ifTrue:[
NameSpace name:varName.
- ^ VariableNode globalNamed:varName
+ ^ (VariableNode globalNamed:varName)
+ startPosition:pos1 endPosition:pos2
].
variableType == #ClassVariable ifTrue:[
classToCompileFor theNonMetaclass addClassVarName:varName.
- ^ VariableNode type:#ClassVariable class:classToCompileFor theNonMetaclass name:varName
+ ^ (VariableNode type:#ClassVariable class:classToCompileFor theNonMetaclass name:varName)
+ startPosition:pos1 endPosition:pos2
].
variableType == #InstanceVariable ifTrue:[
@@ -3809,10 +3928,9 @@
varIndex := methodVarNames size.
var used:true.
- ^ VariableNode type:#MethodVariable
- name:varName
- token:var
- index:varIndex
+ ^ (VariableNode
+ type:#MethodVariable name:varName token:var index:varIndex)
+ startPosition:posToInsert endPosition:posToInsert+varName size-1
].
].
self warning:'sorry - unimplemented (adding ' , variableType , ')'.
@@ -3845,7 +3963,8 @@
parseForCode ifFalse:[self rememberGlobalUsed:aName].
- ^ VariableNode globalNamed:varName
+ ^ (VariableNode globalNamed:varName)
+ startPosition:tokenPosition endPosition:tokenPosition+varName size-1
"Modified: / 31.10.1997 / 01:16:03 / cg"
!
@@ -4065,7 +4184,7 @@
self classesClassVarNames do:spellAgainstAction.
"private classes"
- (classToCompileFor privateClasses collect:[:each | each nameWithoutPrefix]) do:spellAgainstAction.
+ classToCompileFor privateClasses collect:[:each | each nameWithoutPrefix] thenDo:spellAgainstAction.
"pools"
classToCompileFor sharedPools do:[:eachPool |
@@ -4114,7 +4233,7 @@
"if it starts with a lower case character, add all local & instvar names"
"/ do not change to isLowercase because of $_
aString isUppercaseFirst ifFalse:[
- methodVarNames size > 0 ifTrue:[
+ methodVarNames size ~~ 0 ifTrue:[
names add:'---- method locals ----'.
methodVarNames asSortedCollection do:[:methodVarName |
names add:methodVarName.
@@ -4172,6 +4291,7 @@
^ nil
"Modified: / 21-06-2017 / 22:09:22 / cg"
+ "Modified: / 01-03-2019 / 16:06:29 / Claus Gittinger"
!
selectorCheck:aSelectorString for:receiver position:pos1 to:pos2
@@ -4183,8 +4303,8 @@
has the same name as a variable, cannot be understood or is obsolete.
Simple, but catches many typos"
- |isSyntaxHighlighter err selectorSymbol rec names recType selClass newSelector nm nowhereImplemented
- pos1 pos2|
+ |isSyntaxHighlighter err selectorSymbol rec recType selClass newSelector nm nowhereImplemented
+ pos1 pos2 isDeclaredForeign|
isSyntaxHighlighter := self isSyntaxHighlighter.
"
@@ -4221,6 +4341,47 @@
^ aSelectorString
].
+ "if the selector is marked as foreign (via a resource spec), all is well"
+ "/ not really - you used a wrong syntax;
+ "/ should use <foreignSelectors: ...>
+ "/ or <resource: #foreignSelectors: ...>
+ "/ without a colon, the resource will not store an arg, and only the compiler might see it,
+ "/ but not the final method. Thus, the RBLint will not see it correctly.
+ "/ for some time, support both here, but make sure to change all those bad resource specs.
+ isDeclaredForeign := false.
+
+ "/ old (broken) style
+ primitiveResource notNil ifTrue:[
+ isDeclaredForeign := (primitiveResource at:#foreignSelectors ifAbsent:#()) includes:aSelectorString
+ ].
+ "/ new styles
+ annotations notNil ifTrue:[
+ |anno args|
+
+ (anno := annotations detect:[:anno | anno key == #foreignSelectors:] ifNone:nil) notNil ifTrue:[
+ (args := anno arguments) size > 0 ifTrue:[
+ args first isArray ifTrue:[
+ (args first includes:aSelectorString) ifTrue:[
+ isDeclaredForeign := true.
+ ]
+ ]
+ ].
+ ].
+ (anno := annotations detect:[:anno | anno key == #foreignSelector:] ifNone:nil) notNil ifTrue:[
+ (args := anno arguments) size > 0 ifTrue:[
+ (args first = aSelectorString) ifTrue:[
+ isDeclaredForeign := true.
+ ]
+ ]
+ ]
+ ].
+
+ isDeclaredForeign ifTrue:[
+ "we do not want any more warnings about this selector (like 'funny uppercase selector' for .NET selectors"
+ self alreadyWarnedUnimplementedSelectors add:aSelectorString.
+ ^ aSelectorString
+ ].
+
nowhereImplemented := false.
"
quick check if the selector is known at all
@@ -4297,7 +4458,7 @@
nowhereImplemented ifFalse:[
(receiver isConstant or:[receiver isBlock]) ifTrue:[
- err := err, ' in ' , selClass name , ' or any of its superclasses'.
+ "/ err := err, ' in ' , selClass name , ' or any of its superclasses'.
] ifFalse:[(((recType := receiver type) == #GlobalVariable)
or:[recType == #PrivateClass]) ifTrue:[
rec := receiver evaluate.
@@ -4350,7 +4511,7 @@
and:[receiver receiver isSelf]]) ifTrue:[
"it's a message to self class - can check this too ..."
classToCompileFor isMeta ifTrue:[
- err := err, ' for the classes class'.
+ err := err, ' for the class''s class'.
(self checkSelector:selectorSymbol for:receiver inClass:classToCompileFor) isNil ifTrue:[
err := err, '...\\...but its implemented for the class itself. You probably do not want the #class message here.'.
err := err withCRs.
@@ -4411,9 +4572,9 @@
((methodVarNames notNil and:[methodVarNames includes:aSelectorString])
or:[(methodArgNames notNil and:[methodArgNames includes:aSelectorString])
or:[classToCompileFor notNil
- and:[((names := self classesInstVarNames) notNil and:[names includes:aSelectorString])
- or:[((names := self classesClassInstVarNames) notNil and:[names includes:aSelectorString])
- or:[(names := self classesClassVarNames) notNil and:[names includes:aSelectorString]
+ and:[(self classesInstVarNames includes:aSelectorString)
+ or:[(self classesClassInstVarNames includes:aSelectorString)
+ or:[(self classesClassVarNames includes:aSelectorString)
]]]]]) ifTrue:[
err := err , '
.. but a variable with that name is defined.
@@ -4486,8 +4647,10 @@
^ aSelectorString
"Modified: / 05-09-1995 / 17:02:11 / claus"
- "Modified: / 16-03-2017 / 11:36:48 / cg"
+ "Modified: / 01-02-2019 / 01:01:10 / Claus Gittinger"
"Modified: / 20-12-2017 / 22:39:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 27-09-2019 / 16:24:03 / Stefan Vogel"
+ "Modified: / 24-05-2020 / 11:25:53 / cg"
!
typeOfNode:aNode
@@ -4593,9 +4756,29 @@
!
errorMessageForUndefined:variableName
- "Return a proper method for undefined variable named `variableName`"
-
- |idx implementors spaces nameBold variableNameAsSymbol |
+ "Return a proper message for undefined variable named `variableName`"
+
+ |idx implementors numImplementors spaces nameBold variableNameAsSymbol
+ fullText editedClass fullTreeParser|
+
+ self isDoIt ifTrue:[
+ "/ can provide a better error message by looking at the requestor's fullText,
+ "/ and cheching if the var is a local variable or an instance variable.
+ (requestor notNil and:[requestor isStream not]) ifTrue:[
+ fullText := requestor perform:#contents ifNotUnderstood:nil.
+ editedClass := requestor perform:#editedClass ifNotUnderstood:nil.
+ fullText notEmptyOrNil ifTrue:[
+ fullText := fullText string.
+ "/ parse it.
+ Error catch:[
+ fullTreeParser := self class parseMethod:fullText in:editedClass.
+ ].
+ fullTreeParser notNil ifTrue:[
+ methodVarNames := fullTreeParser methodVars.
+ ].
+ ]
+ ]
+ ].
nameBold := variableName allBold.
classToCompileFor notNil ifTrue:[
@@ -4609,25 +4792,36 @@
"/ is it an instance variable, while evaluating for the class ?
classToCompileFor isMeta ifTrue:[
(classToCompileFor soleInstance allInstVarNames includes:variableName) ifTrue:[
- ^ '''%1'' is an instvar\(hint: you are evaluating/compiling in the classes context)' bindWith:nameBold.
+ ^ '''%1'' is an instvar.\\Hint: you are evaluating/compiling in the class''s context.' bindWith:nameBold.
]
]
].
variableNameAsSymbol := variableName asSymbolIfInterned.
(variableNameAsSymbol notNil and:[self isDoIt]) ifTrue:[
+ (methodVarNames notNil and:[methodVarNames includes:variableName]) ifTrue:[
+ ^ '''%1'' is undefined in DoIt\(but known as a local variable in the code).\\Hint: in a DoIt, the variable is only visible inside the executed code\eg. if stopped at a breakpoint'
+ bindWith:nameBold
+ ].
+ (editedClass notNil and:[editedClass allInstVarNames includes:variableName]) ifTrue:[
+ ^ '''%1'' is undefined in DoIt\(but known as instance variable in the code).\\Hint: in a DoIt, the variable is only visible inside the executed code\eg. if stopped at a breakpoint'
+ bindWith:nameBold
+ ].
SystemBrowser notNil ifTrue:[
implementors := SystemBrowser
- findImplementorsOf:variableName
- in:(Smalltalk allClasses)
- ignoreCase:false.
- implementors size > 0 ifTrue:[
- implementors size == 1 ifTrue:[
- ^ '''%1'' is undefined but known as a message selector in %2.\(hint: did you forget to specify or select the receiver ?)'
+ findImplementorsOf:variableName
+ in:(Smalltalk allClasses)
+ ignoreCase:false.
+ numImplementors := implementors size.
+ numImplementors ~~ 0 ifTrue:[
+ numImplementors == 1 ifTrue:[
+ ^ '''%1'' is undefined\(but known as a message selector in %2).\\Hint: in a DoIt\did you forget to specify or select the receiver ?'
bindWith:nameBold
with:implementors first mclass name allBold
].
- ^ '''%1'' is undefined but known as a message selector.\(hint: did you forget to specify or select the receiver ?)' bindWith:variableName allBold.
+ ^ '''%1'' is undefined\(but known as a message selector in %2 classes).\\Hint: in a DoIt\did you forget to specify or select the receiver ?'
+ bindWith:nameBold
+ with:numImplementors
].
].
].
@@ -4648,6 +4842,7 @@
^ '"%1" is undefined' bindWith:nameBold.
"Modified: / 28-10-2014 / 12:45:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-03-2019 / 16:06:24 / Claus Gittinger"
!
exitWith:something
@@ -4801,7 +4996,7 @@
aName isUppercaseFirst ifFalse:[
self showErrorMessage:errMsg position:pos1.
].
- doCorrect := false.
+ doCorrect := #Error. "/ false.
] ifFalse:[
"
ask requestor for correct/continue/abort ...
@@ -4846,6 +5041,42 @@
"Modified: / 02-11-2010 / 13:32:21 / cg"
!
+warnIfPossiblyUninitializedLocal:expr
+ |msg|
+
+ parserFlags warnAboutPossiblyUninitializedLocals ifFalse:[
+ ^ self.
+ ].
+ (self isPossiblyUninitializedLocal:expr) ifTrue:[
+ msg := '"%1" is uninitialized here (always nil).'.
+ (expr parent notNil
+ and:[expr parent isMessage
+ and:[expr parent selector = '='
+ ]]) ifTrue:[
+ msg := msg,c'\n"=" is comparing - did you mean ":=" for assignment?'
+ ] ifFalse:[
+ "/ cg: for now: skip this check here; it has too many false positives
+ "/ TODO: this must be checked when the whole tree is present, and we can look along the
+ "/ node's parent chain for a costruct like 'foo notNil and:[...]'
+ "/ here, the parent is usually nil, due to the recursive nature of the parser.
+ ^ self.
+ ].
+
+ self
+ warning:(msg bindWith:expr name)
+ doNotShowAgainAction:(self actionToDisableWarning:#warnAboutPossiblyUninitializedLocals)
+ position:(expr startPosition) to:(expr endPosition).
+ alreadyWarnedUninitializedVars isNil ifTrue:[
+ alreadyWarnedUninitializedVars := Set new
+ ].
+ alreadyWarnedUninitializedVars add:expr name.
+ ].
+
+ "Created: / 08-02-2019 / 17:14:16 / Claus Gittinger"
+ "Modified (format): / 04-03-2019 / 12:20:01 / Stefan Vogel"
+ "Modified: / 23-04-2019 / 23:14:20 / Claus Gittinger"
+!
+
warnSTXHereExtensionUsedAt:position
ignoreWarnings ifFalse:[
didWarnAboutSTXHereExtensionUsed ifFalse:[
@@ -4866,7 +5097,7 @@
didWarnAboutSTXNameSpaceUse ifFalse:[
parserFlags warnSTXNameSpaceUse ifTrue:[
self warning:'NameSpaces are a nonstandard feature of ST/X'
- doNotShowAgainAction:[ ParserFlags warnSTXSpecials:false ]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnSTXNameSpaceUse)
position:position to:(source position + 1).
"
only warn once
@@ -4901,7 +5132,7 @@
first := true.
aNameCollection asSortedCollection do:[:name|
first ifTrue:[ first := false ] ifFalse:[msg := msg , ', '].
- msg := msg , ('"',name allBold,'"').
+ msg := msg , name allBold withDoubleQuotes.
lineLength := lineLength + 2 + name size + 1.
lineLength > 60 ifTrue:[
msg := msg , '\' withCRs.
@@ -5095,12 +5326,8 @@
than the interpretation overhead."
^ self
- evaluate:aStringOrStream
- in:aContext
- receiver:anObject
- notifying:requestor
- logged:logged
- ifFail:failBlock
+ evaluate:aStringOrStream in:aContext receiver:anObject
+ notifying:requestor logged:logged ifFail:failBlock
compile:true
!
@@ -5193,7 +5420,7 @@
self backupPosition
].
- (self errorFlag or:[tree == #Error]) ifTrue:[
+ (self hasError or:[tree == #Error]) ifTrue:[
requestor notNil ifTrue:[
requestor error:'parse error' position:1 to:(source position) from:self.
].
@@ -5346,6 +5573,7 @@
"Modified: / 22-11-2016 / 00:08:52 / cg"
"Modified (comment): / 13-02-2017 / 20:28:23 / cg"
"Modified (comment): / 19-02-2018 / 14:31:59 / mawalch"
+ "Modified: / 23-05-2019 / 09:28:11 / Claus Gittinger"
!
evaluate:aStringOrStream logged:logged
@@ -5469,7 +5697,6 @@
selector := aParser selector.
! !
-
!Parser methodsFor:'obsolete'!
correctByDeleting
@@ -5569,7 +5796,7 @@
endPos := tokenPosition.
"/ blockNode lineNumber:lno.
- blockNode startPosition:startPos; endPosition:endPos.
+ blockNode startPosition:startPos endPosition:endPos.
self markBlockFrom:startPos to:endPos.
currentBlock := blockNode home.
@@ -5579,6 +5806,7 @@
"Modified (comment): / 05-07-2011 / 23:23:08 / cg"
"Modified: / 01-08-2011 / 12:34:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 15-02-2019 / 14:41:24 / Claus Gittinger"
!
blockBody
@@ -5639,8 +5867,7 @@
parserFlags warnPossibleIncompatibilities == true ifTrue:[
self
warning:('empty local variable list (possible incompatibility)')
- doNotShowAgainAction:[ parserFlags warnPossibleIncompatibilities:false.
- ParserFlags warnPossibleIncompatibilities:false]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnPossibleIncompatibilities)
position:barPos1 to:source position.
]
].
@@ -5745,11 +5972,11 @@
endPos := tokenPosition + tokenName size - 1.
] ifFalse:[
tokenType isCharacter ifTrue:[
- what := '"' , tokenType asString allBold, '"'.
+ what := tokenType asString allBold withDoubleQuotes.
] ifFalse:[
what := tokenType printString allBold.
].
- msg := 'Nothing more expected (i.e. ',what, ' unexpected.'.
+ msg := 'Nothing more expected (i.e. ',what,' unexpected)'.
endPos := source position.
].
self parseError:msg position:tokenPosition to:endPos.
@@ -5757,6 +5984,7 @@
]
"Modified: / 22-08-2006 / 14:22:45 / cg"
+ "Modified: / 30-05-2019 / 14:50:05 / Claus Gittinger"
!
emptyStatement
@@ -5811,6 +6039,8 @@
self notifying:someOne.
self ignoreErrors:ignoreErrors.
self ignoreWarnings:ignoreWarnings.
+ foldConstants := nil.
+
tokenType isNil ifTrue:[
self nextToken.
].
@@ -5828,6 +6058,7 @@
^ tree
"Created: / 14-12-1999 / 15:11:37 / cg"
+ "Modified: / 25-05-2018 / 16:06:38 / Claus Gittinger"
!
parseLiteralArray: aStringOrStream
@@ -5838,11 +6069,13 @@
self syntaxError: '# expected, ', token printString ,'found.'.
^ ParseError raiseRequest.
].
+ self markConstantFrom:tokenPosition to:(source position).
self nextToken.
^self array.
"Created: / 06-11-2012 / 12:51:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 27-02-2013 / 11:05:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 08-06-2019 / 15:49:38 / Claus Gittinger"
!
parseMethod
@@ -5858,13 +6091,14 @@
(self parseMethodSpec == #Error) ifTrue:[^ #Error].
parseTree := self parseMethodBody.
(parseTree == #Error) ifFalse:[
+ self checkForEndOfInput.
self tree:parseTree
].
- self checkForEndOfInput.
^ parseTree
"Modified: / 20-04-1996 / 20:09:26 / cg"
"Modified: / 12-07-2010 / 10:08:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 10-02-2019 / 16:40:23 / Claus Gittinger"
!
parseMethod:aString in:aClass
@@ -5909,12 +6143,11 @@
!
parseMethodBody
- "parse a methods body (locals & statements).
- No more tokens may follow.
+ "parse a method's body (locals & statements).
Return a node-tree, or #Error
- methodBody ::= '<' st80Primitive '>' #EOF
- | '<' st80Primitive '>' methodBodyVarSpec statementList #EOF
+ methodBody ::= '<' <st80Primitive> '>' #EOF
+ | '<' <st80Primitive> '>' <methodBodyVarSpec> <statementList> #EOF
"
|stats|
@@ -5927,9 +6160,7 @@
self emptyStatement.
].
stats := self parseMethodBodyOrEmpty.
- (stats == #Error) ifFalse:[
- self checkForEndOfInput.
- ].
+
(requestor notNil and:[ignoreWarnings not]) ifTrue:[
parserFlags warnings ifTrue:[
self hasPrimitiveCode ifFalse:[
@@ -5945,27 +6176,35 @@
"Modified: / 16-07-2017 / 13:38:37 / cg"
"Modified: / 25-07-2017 / 17:09:54 / stefan"
+ "Modified (comment): / 23-05-2019 / 09:30:56 / Claus Gittinger"
!
parseMethodBodyOrEmpty
- "parse a methods body (locals & statements);
- return a node-tree, nil or #Error.
+ "parse a method's body (locals & statements);
+ return a node-tree, nil or #Error.
empty (or comment only) input is accepted and returns nil.
- methodBodyOrNil ::= '<' st80Primitive '>'
- | '<' st80Primitive '>' methodBodyVarSpec statementList
+ methodBodyOrNil ::= '<' <st80Primitive> '>'
+ | '<' <st80Primitive> '>' <methodBodyVarSpec> <statementList>
| <empty>
"
|stats|
- (self parseMethodBodyVarSpec == #Error) ifTrue:[^ #Error].
+ self parseMethodBodyVarSpec.
+ initExpressionsForLocals notEmptyOrNil ifTrue:[
+ self halt
+ ].
tokenType == $. ifTrue:[
self emptyStatement.
].
(tokenType ~~ #EOF) ifTrue:[
- stats := self statementList
+ tokenType == $] ifTrue:[
+ "treat like EOF here, to allow GST parsing"
+ ] ifFalse:[
+ stats := self statementList
+ ].
].
"/ (tokenType ~~ #EOF) ifTrue:[
"/ self parseError:'nothing more expected here' position:tokenPosition to:tokenPosition.
@@ -5985,6 +6224,7 @@
^ stats
"Modified: / 24-09-2010 / 18:03:59 / cg"
+ "Modified: / 23-05-2019 / 09:20:34 / Claus Gittinger"
!
parseMethodBodyVarSpec
@@ -5992,42 +6232,62 @@
possible primitive or resourceSpecs.
.
Leave spec of locals in methodLocals as a side effect.
- Return #Error or self.
-
- methodBodyVarSpec ::= '|' { IDENTIFIER } '|'
+ Possibly leave initializer expressions in initExpressionsForLocals
+ as a side effect.
+ Return self.
+
+ methodBodyVarSpec ::= '|' <identifier> ... '|'
+ | '|' <identifier_or_initializer> ... '|'
| <empty>
- "
-
- |var pos pos2 msg classHint whatIsHidden|
+ identifier_or_initializer ::=
+ <identifier>
+ | <identifier> ':=' <expression> '.'
+
+ "
+
+ |var pos pos2 msg classHint whatIsHidden firstVar initExprs|
((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
self parsePrimitiveOrResourceSpecOrEmpty.
].
+ methodVars := methodVarNames := nil.
(tokenType == $|) ifTrue:[
"memorize position for declaration in correction"
localVarDefPosition := Array with:tokenPosition with:nil.
self nextToken.
pos := tokenPosition.
+ firstVar := true.
[tokenType == #Identifier] whileTrue:[
pos2 := tokenPosition + tokenName size - 1.
self markLocalVariableDeclaration: tokenName from: tokenPosition to:pos2.
self checkMethodVariableNameConventionsFor:tokenName.
var := Variable name:tokenName.
- methodVars isNil ifTrue:[
+ firstVar ifTrue:[
methodVars := OrderedCollection with:var.
- methodVarNames := OrderedCollection with:tokenName
+ methodVarNames := OrderedCollection with:tokenName.
+ firstVar := false.
] ifFalse:[
(methodVarNames includes:tokenName) ifTrue:[
"/ redefinition
self isSyntaxHighlighter ifTrue:[
self markBadIdentifierFrom:tokenPosition to:pos2.
] ifFalse:[
- self
- parseError:'redefinition of ''' , tokenName , ''' in local variables.'
- position:tokenPosition to:pos2.
+ |pos1|
+
+ pos1 := tokenPosition.
+ self nextToken.
+ tokenType == #Identifier ifTrue:[
+ self
+ parseError:'redefinition of "',tokenName,'| in local variables.'
+ position:pos1 to:pos2.
+ ] ifFalse:[
+ self
+ parseError:'redefinition of "',tokenName,'" in local variables.\Probably missing "|" after local variables?' withCRs
+ position:pos1 to:pos2.
+ ]
]
] ifFalse:[
methodVars add:var.
@@ -6061,7 +6321,7 @@
fix := self
correctableWarning:(('local variable "%1" hides ',whatIsHidden,'.') bindWith:tokenName allBold)
- doNotShowAgainAction:[ parserFlags warnHiddenVariables:false. ParserFlags warnHiddenVariables:false ]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnHiddenVariables)
doNotShowAgainForThisMethodAction: [ self disableWarningsOnCurrentMethodFor: #warnHiddenVariables ]
position:tokenPosition to:pos2.
fix isBehavior ifTrue:[
@@ -6069,7 +6329,8 @@
].
"/ self breakPoint:#cg.
fix == #Error ifTrue:[
- ^ #Error
+ initExpressionsForLocals := initExprs.
+ ^ self "/ #Error
]
]
]
@@ -6085,18 +6346,31 @@
lastDirective := nil.
].
- parserFlags allowLocalVariableDeclarationWithInitializerExpression == true ifTrue:[
- ((tokenType == $_) or:[tokenType == #':=']) ifTrue:[
- self nextToken.
- "/ Q: should we allow literals only, or arbitrary expressions ?
- self shouldImplement.
- ]
- ].
parserFlags allowDomainVariables == true ifTrue:[
(tokenType == $() ifTrue:[
self variableTypeDeclarationFor:var.
].
].
+
+ parserFlags allowLocalVariableDeclarationWithInitializerExpression == true ifTrue:[
+ ((tokenType == $_) or:[tokenType == #':=']) ifTrue:[
+ |initExpr|
+
+ self nextToken.
+ "/ Q: should we allow literals only, or arbitrary expressions ?
+ initExpr := self expression.
+ initExprs isNil ifTrue:[ initExprs := OrderedCollection new ].
+ initExprs add:initExpr.
+
+ tokenType == $. ifTrue:[
+ self nextToken.
+ ] ifFalse:[
+ tokenType == $| ifFalse:[
+ self parseError:'initializers must be separated by "."'
+ ].
+ ].
+ ]
+ ].
pos := tokenPosition
].
@@ -6110,7 +6384,8 @@
msg := 'Identifier or | expected in local var declaration'
].
self syntaxError:msg position:tokenPosition to:pos2.
- ^ #Error
+ initExpressionsForLocals := initExprs.
+ ^ self
].
localVarDefPosition at:2 put:tokenPosition.
@@ -6118,11 +6393,10 @@
parserFlags warnPossibleIncompatibilities == true ifTrue:[
self
warning:('empty local variable list (possible incompatibility)')
- doNotShowAgainAction:[ parserFlags warnPossibleIncompatibilities:false.
- ParserFlags warnPossibleIncompatibilities:false]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnPossibleIncompatibilities)
position:(localVarDefPosition first) to:source position.
]
- ].
+ ].
self nextToken
].
@@ -6137,10 +6411,12 @@
]
].
+ initExpressionsForLocals := initExprs.
^ self
"Modified: / 25-02-2014 / 20:20:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 10-10-2017 / 16:58:13 / cg"
+ "Modified: / 23-05-2019 / 09:20:08 / Claus Gittinger"
!
parseMethodSpec
@@ -6153,7 +6429,7 @@
| IDENTIFIER
"
- |arg pos1 pos2 argPos1 argPos2 rawSelector|
+ |arg pos1 pos2 argPos1 argPos2 rawSelector firstArg|
tokenType isNil ifTrue:[
self nextToken.
@@ -6164,6 +6440,7 @@
"/ selectorPositions := OrderedCollection new.
(tokenType == #Keyword) ifTrue:[
+ firstArg := true.
rawSelector := ''.
[tokenType == #Keyword] whileTrue:[
"/ selectorPositions add:(tokenPosition to:(tokenPosition+tokenName size - 1)).
@@ -6181,9 +6458,10 @@
self markMethodArgumentIdentifierFrom:argPos1 to:argPos2.
self checkMethodArgumentNameConventionsFor:tokenName.
arg := Variable name:tokenName.
- methodArgs isNil ifTrue:[
+ firstArg ifTrue:[
methodArgs := Array with:arg.
- methodArgNames := Array with:tokenName
+ methodArgNames := Array with:tokenName.
+ firstArg := false.
] ifFalse:[
(methodArgNames includes:tokenName) ifTrue:[
self methodArgRedefined:tokenName from:argPos1 to:argPos2
@@ -6279,6 +6557,7 @@
"Modified: / 12-07-2010 / 09:57:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 21-08-2011 / 08:12:20 / cg"
+ "Modified: / 10-02-2019 / 18:16:09 / Claus Gittinger"
!
returnStatement
@@ -6298,8 +6577,7 @@
(expr == #Error) ifTrue:[^ #Error].
node := ReturnNode expression:expr.
- node startPosition:pos.
- node endPosition: expr endPosition.
+ node startPosition:pos endPosition:(expr endPosition ? source position).
node home:self blockHome:currentBlock.
true "(lineNumberInfo == #full)" ifTrue:[node lineNumber:lnr].
self checkPlausibilityOf:node from:pos to:node endPosition.
@@ -6312,6 +6590,7 @@
"Created: / 05-07-2011 / 21:22:05 / cg"
"Modified: / 27-07-2011 / 13:47:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 08-03-2012 / 01:03:36 / cg"
+ "Modified: / 15-02-2019 / 14:41:35 / Claus Gittinger"
!
statement
@@ -6402,8 +6681,30 @@
(prevExpr notNil
and:[prevExpr isMessage
and:[thisStatement isReturnNode not]]) ifTrue:[
- (#(#'=' #'==') includes:prevExpr selector) ifTrue:[
- self warning:'useless computation - mistyped assignment (i.e. did you mean '':='') ?' position:prevExpr selectorPosition
+ |sel pos|
+
+ sel := prevExpr selector.
+ (#(#'=' #'==') includes:sel) ifTrue:[
+ pos := prevExpr selectorPosition.
+ sel = #'=' ifTrue:[
+ PossibleCorrectionsQuery answer:{ CorrectByInsertingColon new positionToInsert:pos} do:[
+ |fix|
+
+ fix := self
+ correctableWarning:('useless computation - mistyped assignment (i.e. did you mean '':='') ?')
+ position:pos to:pos+sel size-1.
+
+ (fix isBehavior or:[fix isKindOf:Correction]) ifTrue:[
+ self correctWith:fix from:pos to:pos+sel size-1.
+ ].
+ self breakPoint:#cg.
+ fix == #Error ifTrue:[
+ ^ #Error
+ ]
+ ]
+ ] ifFalse:[
+ self warning:'useless computation - mistyped assignment (i.e. did you mean '':='') ?' position:pos.
+ ].
].
].
@@ -6413,9 +6714,9 @@
self emptyStatement.
].
(tokenType == $]) ifTrue:[
- currentBlock isNil ifTrue:[
- self parseError:''']'' unexpected (block nesting error)'.
- ].
+ "/ currentBlock isNil ifTrue:[
+ "/ self parseError:''']'' unexpected (block nesting error)'.
+ "/ ].
^ self statementListRewriteHookFor:firstStatement
].
(tokenType == #EOF) ifTrue:[
@@ -6439,6 +6740,7 @@
^ self statementListRewriteHookFor:firstStatement
"Modified: / 20-03-2012 / 12:44:12 / cg"
+ "Modified: / 23-09-2018 / 00:15:36 / Claus Gittinger"
!
variableTypeDeclarationFor:aVariable
@@ -6460,6 +6762,11 @@
self syntaxError:'''('' expected' position:tokenPosition.
^ #Error
].
+ IntegerDomain isNil ifTrue:[
+ self parseError:'Constraint extension not present/loaded'.
+ ^ #Error
+ ].
+
self nextToken.
(tokenType == #Integer) ifTrue:[
@@ -6512,6 +6819,7 @@
self nextToken.
"Modified: / 09-08-2010 / 00:27:16 / cg"
+ "Modified: / 10-02-2019 / 16:06:11 / Claus Gittinger"
!
warnAboutEmptyStatement
@@ -6536,11 +6844,13 @@
array
"parse a literal array's elements"
- |arr elements elem pos1|
+ |arr elements elem pos1 elementPos|
pos1 := tokenPosition.
elements := OrderedCollection new.
[tokenType ~~ $) ] whileTrue:[
+ elementPos := tokenPosition.
+
elem := self arrayConstant.
"/ (elem == #Error) ifTrue:[
@@ -6550,9 +6860,17 @@
"/ ].
"/ ^ #Error
"/ ].
+
+ "/ the array may still include comments;
+ "/ therefore, be careful to not mark all
elem isSymbol ifTrue:[
- self markSymbolFrom:tokenPosition to:(source position).
- ].
+ self markSymbolFrom:elementPos to:(source position).
+ ] ifFalse:[
+ elem isArray ifFalse:[
+ self markConstantFrom:elementPos to:(source position).
+ ].
+ ].
+
elements add:elem.
self nextToken.
"/ tokenType == $. ifTrue:[
@@ -6560,6 +6878,7 @@
"/ ].
].
+ self markConstantFrom:tokenPosition to:(source position).
elements size == 0 ifTrue:[
"always return the same object for an empty array,
which is also immutable by definition"
@@ -6569,11 +6888,12 @@
arr := elements asArray.
parserFlags arraysAreImmutable ifTrue:[
- ^ self makeImmutableArray:arr
+ ^ self makeImmutable:arr
].
^ arr
"Modified: / 30-07-2013 / 19:33:43 / cg"
+ "Modified: / 09-06-2019 / 15:23:27 / Claus Gittinger"
!
arrayConstant
@@ -6592,11 +6912,14 @@
^ tokenValue
].
((tokenType == #Integer)
- or:[tokenType == #Float]) ifTrue:[
+ or:[(tokenType == #Float)
+ or:[tokenType == #FixedPoint]]) ifTrue:[
^ tokenValue
].
(tokenType == #String) ifTrue:[
- parserFlags stringsAreImmutable ifTrue:[^ self makeImmutableString:tokenValue].
+ parserFlags stringsAreImmutable ifTrue:[
+ ^ self makeImmutable:tokenValue
+ ].
^ tokenValue
].
(tokenType == #Character) ifTrue:[
@@ -6640,11 +6963,13 @@
].
((tokenType == $()
or:[tokenType == #HashLeftParen]) ifTrue:[
+ self markConstantFrom:tokenPosition to:(source position).
self nextToken.
^ self array
].
((tokenType == $[)
or:[tokenType == #HashLeftBrack]) ifTrue:[
+ self markConstantFrom:tokenPosition to:(source position).
self nextToken.
^ self byteArray
].
@@ -6663,6 +6988,25 @@
].
^ tokenValue
].
+ ((tokenType == $;) or:[(tokenType == $.)]) ifTrue:[
+ parserFlags allowSqueakExtensions == true ifFalse:[
+ self parseError:'non-Standard Squeak/Pharo array elements: "." or ";". Please enable in settings.' position:tokenPosition to:tokenPosition+1.
+ ].
+ parserFlags warnAboutPossibleSTCCompilationProblems ifTrue:[
+ self
+ warning:('stc will not compile this (non-Standard Squeak/Pharo array elements: "." or ";")\\Hint last token''s value was "',tokenValue?'','"') withCRs
+ position:tokenPosition. "/ line:lineNr.
+ ].
+ self warnPossibleIncompatibility:'non-Standard Squeak/Pharo array elements: "." or ";"' position:tokenPosition to:tokenPosition+token size - 1.
+ tokenValue := tokenType asSymbol.
+ parseForCode ifFalse:[
+ self rememberSymbolUsed:tokenValue.
+ ].
+ ^ tokenValue
+ ].
+ (tokenType == $.) ifTrue:[
+ ].
+
(tokenType == #EOF) ifTrue:[
"just for the better error-hilight; let caller handle error"
self syntaxError:'EOF unexpected in array-constant'.
@@ -6674,15 +7018,28 @@
^ ParseError raiseRequest.
"Modified: / 22-08-2006 / 14:21:16 / cg"
+ "Modified (format): / 09-06-2019 / 15:23:56 / Claus Gittinger"
!
arrayIndexingExpression
"parse an array index expression; this is a squeak/stx extension.
- foo[x] is syntactic sugar for 'foo at:x'
- and foo[x] := expr is syntactic sugar for 'foo at:x put:expr';
- with commas, foo[x , y] generates foo at:x at:y.
- This syntax extension must be enabled in the parserFlags as
- allowArrayIndexSyntaxExtension (disabled by default)"
+ foo[x] is syntactic sugar for 'foo at:x'
+ and
+ foo[x] := expr is syntactic sugar for 'foo at:x put:expr'
+ With multiple dimensions,
+ foo[x . y] or foo[x][y] generates foo at:x at:y
+ and
+ foo[x . y] := expr or foo[x][y] := expr generates foo at:x at:y put:expr.
+
+ This syntax extension must be enabled
+ in the parserFlags as allowArrayIndexSyntaxExtension
+ or via a pragma <pargma: +ArrayIndexSyntaxExtension>
+ (disabled by default).
+
+ This general form of the synthetic selector is: _at:idx1 at:idx2 ...
+ or _at:idx1 at:idx2 put:expr.
+ Notice that the getters are also implemented in the SeqColl meta class,
+ as instance creators for Vectors, Matrices etc."
|receiver argList selectorStream valNode|
@@ -6707,7 +7064,9 @@
argList isEmpty ifTrue:[selectorStream nextPutAll:'_'].
selectorStream nextPutAll:'at:'.
argList add: indexNode.
- (tokenType == #BinaryOperator ) and:[ token = ',']
+ "/ rubbish: cannot use comma here
+ "/ (tokenType == #BinaryOperator ) and:[ token = ',']
+ (tokenType == $. )
] whileTrue.
tokenType == $] ifFalse:[
@@ -6716,13 +7075,14 @@
].
self nextToken.
- tokenType == $[ ifTrue:[
- receiver := MessageNode
- receiver:receiver
- selector:(selectorStream contents)
- args:argList.
- selectorStream := WriteStream on: (String new: 32).
- ].
+"/ tokenType == $[ ifTrue:[
+"/ receiver := MessageNode
+"/ receiver:receiver
+"/ selector:(selectorStream contents)
+"/ args:argList.
+"/ selectorStream := WriteStream on: (String new: 32).
+"/ argList := OrderedCollection new.
+"/ ].
tokenType == $[
] whileTrue.
@@ -6755,18 +7115,64 @@
"
"
+ <pragma: +ArrayIndexSyntaxExtension>
|foo|
foo := Array new:10 withAll:2.
- 1 + foo[1].
- "
- "
+ 1 + foo[1].
+ "
+
+ "
+ <pragma: +ArrayIndexSyntaxExtension>
+ |foo|
+
+ foo := Array new:10.
+ foo[1] := 'hello'.
+ foo[2].
+ foo[1].
+ "
+
+ "
+ <pragma: +ArrayIndexSyntaxExtension>
|foo|
foo := Array new:10.
foo[1] := 'hello'.
- foo[2].
+ foo[1][2].
+ "
+ "
+ <pragma: +ArrayIndexSyntaxExtension>
+ |foo|
+
+ foo := Array new:10.
+ foo[1] := 'hello' copy.
+ foo[1][2] := $E.
foo[1].
+ foo[1][2].
+ "
+ "
+ <pragma: +ArrayIndexSyntaxExtension>
+ |foo|
+
+ foo := Array new:10.
+ foo[1] := 'hello' copy.
+ foo[1 . 2] := $E.
+ foo[1].
+ foo[1][2].
+ foo[1 . 2].
+ "
+ "
+ <pragma: +ArrayIndexSyntaxExtension>
+ |m|
+
+ m := Array[2][3].
+ m[1][1] := 11.
+ m[1][2] := 12.
+ m[1][3] := 13.
+ m[2][1] := 21.
+ m[2][2] := 22.
+ m[2][3] := 23.
+ m.
"
"Modified: / 08-08-2017 / 16:56:33 / cg"
@@ -6843,20 +7249,15 @@
(arg == #Error) ifTrue:[^ #Error].
expr := BinaryNode receiver:receiver selector:sel arg:arg fold:foldConstants.
+ expr startPosition:(receiver startPosition ? pos1) endPosition:(arg endPosition ? tokenLastEndPosition).
expr isErrorNode ifTrue:[
- self parseError:(expr errorString) position:pos1 to:tokenPosition.
+ self parseError:(expr errorString) position:pos1 to:tokenLastEndPosition.
self clearErrorFlag. "ok, user wants it - so he'll get it"
expr := BinaryNode receiver:receiver selector:sel arg:arg fold:nil.
].
expr lineNumber:lno.
expr selectorPosition:pos1.
- (self isPossiblyUninitializedLocal:arg) ifTrue:[
- self
- warning:'"',arg name,'" is uninitialized here (always nil)'
- position:(arg startPosition) to:(arg endPosition).
- ].
-
self checkPlausibilityOf:expr from:pos1 to:pos2.
parseForCode ifFalse:[
self rememberSelectorUsed:sel receiver:receiver
@@ -6868,6 +7269,8 @@
"Modified: / 09-01-1998 / 19:05:18 / stefan"
"Modified: / 19-01-2012 / 10:44:22 / cg"
+ "Modified: / 08-02-2019 / 17:21:16 / Claus Gittinger"
+ "Modified: / 11-09-2019 / 16:04:45 / Stefan Reise"
!
byteArray
@@ -6927,17 +7330,20 @@
newArray := ByteArray uninitializedNew:index.
newArray replaceFrom:1 to:index with:bytes startingAt:1.
parserFlags arraysAreImmutable ifTrue:[
- ^ self class makeImmutableByteArray:newArray
+ ^ self makeImmutable:newArray
].
^ newArray
+
+ "Modified: / 09-06-2019 / 15:23:35 / Claus Gittinger"
!
degeneratedKeywordExpressionForSelector
"parse a keyword-expression without receiver - for the selector only.
Return the selector or nil (if it cannot be determined).
- This is not used in normal parsing, but instead to extract the selector from a code fragment.
- (for example, the system browsers 'implementors'-function uses this to extract a selector from
- the selection)"
+ This is not used in normal parsing, but instead a utility
+ to extract the selector from a code fragment.
+ (for example, the system browser's 'implementors'-function uses this
+ to extract a selector from the text selection)"
|sel arg rec|
@@ -7064,7 +7470,7 @@
args := args copyWith:arg.
pos2 := tokenEnd
].
-
+ positions := positions asArray.
self isSyntaxHighlighter ifTrue:[
positions do:[:p |
self markSelector:sel from:p start to:p stop receiverNode:realReceiver.
@@ -7075,10 +7481,10 @@
receiver := CascadeNode receiver:receiver selector:sel args:args.
receiver lineNumber:lno.
- receiver startPosition: tokenStart endPosition: args last endPosition.
+ receiver startPosition:tokenStart endPosition:(args last endPosition).
receiver := self messageNodeRewriteHookFor:receiver.
receiver lineNumber:lno.
- receiver selectorPartPositions: positions.
+ receiver selectorPartPositions:positions.
parseForCode ifFalse:[
self rememberSelectorUsed:sel receiver:realReceiver args:args
].
@@ -7129,6 +7535,7 @@
"Modified: / 01-10-2013 / 20:54:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 08-08-2017 / 17:06:12 / cg"
"Modified: / 09-08-2017 / 14:46:56 / mawalch"
+ "Modified: / 20-03-2019 / 20:53:30 / Claus Gittinger"
!
functionCallArgList
@@ -7174,6 +7581,7 @@
receiver := self primary.
tokenType == $( ifFalse:[^ receiver].
+
parserFlags allowFunctionCallSyntaxForBlockEvaluation ifFalse:[^ receiver.].
(receiver == #Error) ifTrue:[^ #Error].
@@ -7191,7 +7599,8 @@
"/ make it a block evaluation
numArgs := argList size.
numArgs == 0 ifTrue:[
- ^ UnaryNode receiver:receiver selector:#value
+ ^ (UnaryNode receiver:receiver selector:#value)
+ startPosition:(receiver startPosition) endPosition:tokenLastEndPosition
].
evalSelectors := #(#'value:'
#'value:value:'
@@ -7209,16 +7618,16 @@
receiver:receiver
selector:evalSelector
args:argList)
- startPosition: receiver startPosition
- endPosition: tokenLastEndPosition.
+ startPosition:(receiver startPosition)
+ endPosition:tokenLastEndPosition.
].
"/ gen argument vector
^ (MessageNode
receiver:receiver
selector:#valueWithArguments:
args:(self genMakeArrayWith:argList))
- startPosition: receiver startPosition
- endPosition: tokenLastEndPosition.
+ startPosition:(receiver startPosition)
+ endPosition:tokenLastEndPosition.
"
Parser allowFunctionCallSyntaxForBlockEvaluation:true.
"
@@ -7249,24 +7658,77 @@
"Modified: / 27-07-2011 / 15:39:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+inlineObjectClassFor:slotNames
+ "create an anonymous inline-object class for an object with slots given by names.
+ Reuses an existing class, if one exists."
+
+ |existingClass class inlineObjectsAreReadonly protoClass|
+
+ inlineObjectsAreReadonly := parserFlags arraysAreImmutable.
+ ^ InlineObject classForSlotNames:slotNames mutable:(inlineObjectsAreReadonly not).
+
+"/ existingClass := InlineObjectClassDescription subclasses
+"/ detect:[:cls | cls instVarNames = slotNames]
+"/ ifNone:[nil].
+"/ existingClass notNil ifTrue:[ ^ existingClass].
+"/
+"/ class := InlineObjectClassDescription new.
+"/ class setSuperclass: InlineObject.
+"/ class setInstVarNames:slotNames.
+"/ class instSize: slotNames size.
+"/
+"/ protoClass := InlineObject prototype.
+"/ slotNames keysAndValuesDo:[:idx :instVarName |
+"/ |protoMethod|
+"/
+"/ idx <= protoClass instSize ifTrue:[
+"/ protoMethod := protoClass compiledMethodAt:('i%1' bindWith:idx) asSymbol.
+"/ class basicAddSelector:instVarName withMethod:protoMethod.
+"/ "/ fixup: undo side effect of adding selector (mclass changed)
+"/ protoMethod mclass:protoClass.
+"/
+"/ inlineObjectsAreReadonly ifFalse:[
+"/ protoMethod := protoClass compiledMethodAt:('i%1:' bindWith:idx) asSymbol.
+"/ class basicAddSelector:(instVarName asMutator) withMethod:protoMethod.
+"/ "/ fixup: undo side effect of adding selector (mclass changed)
+"/ 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.
+"/ ].
+"/ ].
+"/ ].
+"/ ].
+"/ ^ class
+
+ "Created: / 30-05-2019 / 12:00:59 / Claus Gittinger"
+!
+
inlineObjectFrom:pos1
"an experimental ST/X feature.
- InlineObject as #{ name1: value1. ... nameN: valueN }
+ InlineObject as
+ #{ name1: value1. ... nameN: valueN }
creates a literal object with an anon class which provides getter/setters on all
names and is preinitialized with valueI.
- The initial #{ is supposed to be skipped and its position passed in as pos1."
+ The initial #{ is supposed to be skipped and its position passed in as pos1.
+ Notice: the values must be literals too;
+ currently the JavaScript style (using expressions) is not supported."
|namesAndValues name value|
namesAndValues := OrderedCollection new.
[ tokenType ~~ $} ] whileTrue:[
(tokenType == #Keyword) ifFalse:[
- self syntaxError:'Bad inlineObject; Keyword expected'
+ self syntaxError:('Bad inlineObject; Keyword expected (got: ',tokenType,')')
position:pos1 to:tokenPosition
].
name := tokenName copyButLast:1.
self nextToken.
value := self arrayConstant.
+ "/ value := self expression.
self nextToken.
namesAndValues add:(name -> value).
@@ -7275,14 +7737,19 @@
].
].
- didWarnAboutSTXExtensions~~ true ifTrue:[
- didWarnAboutSTXExtensions := true.
- self
- warning:'InlineObjects are an experimental feature which is not yet supported by stc'
- position:pos1 to:tokenPosition.
+ ParserFlags warnAboutInlineObjects ~~ false ifTrue:[
+ didWarnAboutSTXExtensions ~~ true ifTrue:[
+ didWarnAboutSTXExtensions := true.
+ self
+ warning:'InlineObjects are an experimental feature which is not yet supported by stc'
+ doNotShowAgainAction:(self actionToDisableWarning:#warnAboutInlineObjects)
+ position:pos1 to:tokenPosition.
+ ].
].
self nextToken.
^ ConstantNode type:#Object value:(self literalInlineObjectFor:namesAndValues).
+
+ "Modified (comment): / 21-06-2019 / 10:09:22 / Claus Gittinger"
!
keywordExpression
@@ -7327,7 +7794,7 @@
].
].
positionOfPeriod notNil ifTrue:[
- PossibleCorrectionsQuery answer:{ CorrectByInsertingPeriod new positionOfPeriod:positionOfPeriod} do:[
+ PossibleCorrectionsQuery answer:{ CorrectByInsertingPeriod new positionToInsert:positionOfPeriod} do:[
|fix|
fix := self
@@ -7337,7 +7804,7 @@
(fix isBehavior or:[fix isKindOf:Correction]) ifTrue:[
self correctWith:fix from:tokenPosition to:tokenPosition+token size-1.
].
-self breakPoint:#cg.
+ self breakPoint:#cg.
fix == #Error ifTrue:[
^ #Error
]
@@ -7381,14 +7848,7 @@
args := args copyWith:arg.
].
- args do:[:eachArg |
- (self isPossiblyUninitializedLocal:eachArg) ifTrue:[
- self
- warning:'"',eachArg name,'" is uninitialized here (always nil)'
- position:(eachArg startPosition) to:(eachArg endPosition).
- ].
- ].
-
+ selectorPartPositions := selectorPartPositions asArray.
selectorPartPositions do:[:p |
self markSelector:sel from:p start to:p stop receiverNode:receiver.
].
@@ -7446,49 +7906,32 @@
"Modified: / 19-01-2012 / 10:44:42 / cg"
"Modified: / 27-08-2013 / 10:43:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 20-03-2019 / 20:52:52 / Claus Gittinger"
!
literalInlineObjectFor:namesAndValues
- |class instance names values inlineObjectsAreReadonly|
-
- inlineObjectsAreReadonly := true.
-
- names := namesAndValues collect:[:each | each key].
+ "create an inline-object literal.
+ Reuses an existing class, if one exists."
+
+ |class instance slotNames values|
+
+ slotNames := 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.
- inlineObjectsAreReadonly ifFalse:[
- Compiler compile:('%1:something %1 := something' bindWith:instVarName) forClass:class.
- ].
- ].
- ].
- ].
+ class := self inlineObjectClassFor:slotNames.
instance := class new.
- 1 to:names size do:[:idx | instance instVarAt:idx put:(values at:idx) ].
+ 1 to:slotNames size do:[:idx | instance instVarAt:idx put:(values at:idx) ].
^ instance
+
+ "Modified: / 30-05-2019 / 12:02:02 / Claus Gittinger"
!
primary
"parse a primary-expression; return a node-tree, nil or #Error.
This also cares for namespace-access-paths."
- |val pos node eMsg endPos|
+ |val pos node eMsg endPos startPos parenStart parenStartLine|
(tokenType == #Self) ifTrue:[
^ self primary_self.
@@ -7524,7 +7967,7 @@
].
(tokenType == #FixedPoint) ifTrue:[
- parserFlags allowFixedPointLiterals == true ifFalse:[
+ parserFlags allowFixedPointLiterals ifFalse:[
self isSyntaxHighlighter ifFalse:[
self parseError:'non-Standard literal: FixedPoint. Please enable in settings.' position:pos to:pos+2.
^ #Error
@@ -7551,6 +7994,8 @@
].
(tokenType == #HashLeftParen) ifTrue:[
+ self markConstantFrom:tokenPosition to:(source position).
+
self inArrayLiteral:true.
self nextToken.
[
@@ -7575,24 +8020,29 @@
^ ConstantNode type:#ByteArray value:val from: pos to: tokenLastEndPosition.
].
- parserFlags allowSTXExtendedArrayLiterals ifTrue:[
- (tokenType == #HashTypedArrayParen) ifTrue:[
- |arrayType|
-
- arrayType := tokenValue.
- self inArrayLiteral:true.
- self nextToken.
- [
- val := self typedArray:arrayType.
- ] ensure:[
- self inArrayLiteral:false.
- ].
- self nextToken.
- (self noAssignmentAllowed:'Assignment to a constant' at:pos) ifFalse:[
- ^ #Error
- ].
- ^ ConstantNode type:#Array value:val from: pos to: tokenLastEndPosition.
- ].
+ (tokenType == #HashTypedArrayParen) ifTrue:[
+ |arrayType|
+
+ arrayType := tokenValue.
+ self inArrayLiteral:true.
+ self nextToken.
+ [
+ val := self typedArray:arrayType.
+ ] ensure:[
+ self inArrayLiteral:false.
+ ].
+ self nextToken.
+ parserFlags warnPossibleIncompatibilities ifTrue:[
+ "/ ParserFlags warnPossibleIncompatibilities:true
+ self
+ warning:('typed array literal (possible incompatibility)')
+ doNotShowAgainAction:(self actionToDisableWarning:#warnPossibleIncompatibilities)
+ position:pos to:tokenLastEndPosition.
+ ].
+ (self noAssignmentAllowed:'Assignment to a constant' at:pos) ifFalse:[
+ ^ #Error
+ ].
+ ^ ConstantNode type:#Array value:val from:pos to:tokenLastEndPosition.
].
(tokenType == #HashLeftBrace) ifTrue:[
@@ -7602,18 +8052,49 @@
(tokenType == $() ifTrue:[
parenthesisLevel := parenthesisLevel + 1.
+ parenStart := tokenPosition.
+ parenStartLine := tokenLineNr.
self markParenthesisAt:tokenPosition.
- ^ self primary_expression.
+ node :=
+ ParseError handle:[:ex |
+ ex rejected ifFalse:[
+ "/ sigh need a special MissingParenthesisError ...
+ (ex description includesString:'missing '')''') ifTrue:[
+ ex errorMessage:(ex errorMessage
+ , (' (matching ''('' in line %1)' bindWith:parenStartLine)).
+ self markErrorFrom:parenStart to:nil. "/ to the end
+ ].
+ ].
+ ex reject
+ ] do:[
+ self primary_expression.
+ ].
+ ^ node
].
(tokenType == $[ ) ifTrue:[
+ parenStart := tokenPosition.
+ parenStartLine := tokenLineNr.
self markBracketAt:tokenPosition.
- val := self block.
+ node :=
+ ParseError handle:[:ex |
+ "/ sigh need a special MissingParenthesisError ...
+ "/ Transcript showCR:ex errorMessage.
+ (ex description includesString:'missing '']''') ifTrue:[
+ ex errorMessage:(ex errorMessage
+ , (' (matching ''['' in line %1)' bindWith:parenStartLine)).
+ self markErrorFrom:parenStart to:nil. "/ to the end
+ ].
+ ex reject
+ ] do:[
+ self block.
+ ].
+
self nextToken.
(self noAssignmentAllowed:'invalid assignment' at:pos) ifFalse:[
^ #Error
].
- ^ val
+ ^ node
].
"/ EXPERIMENTAL - may be in next release
@@ -7633,18 +8114,18 @@
"/ self parseError:'non-Standard Squeak extension: Brace Computed Array. Enable in settings.' position:pos to:tokenPosition.
self
warning:('non-Standard Squeak extension: Brace Computed Array. Enable in settings.')
- doNotShowAgainAction:[ ParserFlags allowSqueakExtensions:true ]
+ doNotShowAgainAction:(self actionToDisableWarning:#allowSqueakExtensions)
position:pos to:tokenPosition.
"/ errorFlag := false.
].
].
- ^ self primary_squeakComputedArray.
+ ^ self primary_squeakComputedArrayOrComputedInlineObject.
].
(tokenType == #Primitive) ifTrue:[
node := PrimitiveNode code:tokenValue.
- node startPosition: tokenPosition endPosition: source position + 1.
+ node startPosition: tokenPosition endPosition:(source position + 1).
self nextToken.
hasNonOptionalPrimitiveCode := true.
hasPrimitiveCode := true.
@@ -7660,11 +8141,13 @@
^ self primary_dolphinComputedLiteral.
].
tokenType == #ExclaLeftBrack ifTrue:[
+ "/ !![ ... ] generates a lazy value
self nextToken.
parserFlags allowLazyValueExtension == true ifFalse:[
- self parseError:'non-Standard LazyValue extension. Enable in classVariable.' position:pos to:tokenPosition.
+ self parseError:'non-Standard LazyValue extension. Enable allowLazyValueExtension in parserFlags.' position:pos to:tokenPosition.
^ #Error
].
+ self warnPossibleIncompatibility:'non-Standard LazyValue extension used' position:pos to:tokenPosition.
^ self primary_lazyValue.
].
tokenType == #HashHash ifTrue:[
@@ -7744,31 +8227,74 @@
self parseError:'number expected after sign.' position:pos to:tokenPosition.
^ #Error.
].
- ^ ConstantNode type:(node type) value:(node value negated) from: node startPosition to: node endPosition.
- ].
-
+ ^ ConstantNode type:(node type) value:(node value negated)
+ from:(node startPosition) to:(node endPosition).
+ ].
+
+ tokenType == #IString ifTrue:[
+ |s|
+
+ self markConstantFrom:tokenPosition to:(source position).
+ s := self makeImmutable:tokenValue.
+ self nextToken.
+ ^ MessageNode
+ receiver:((UnaryNode
+ receiver:(VariableNode type:#ThisContext)
+ selector:#resources)
+ startPosition:pos endPosition:tokenLastEndPosition)
+ selector:#string:
+ arg:(ConstantNode type:#String value:s
+ from:pos to:tokenLastEndPosition)
+ ].
+ ((tokenType == #EStringFragment) or:[(tokenType == #IStringFragment)]) ifTrue:[
+ ^ self stringWithEmbeddedExpressions
+ ].
+ (tokenType == #RegexString) ifTrue:[
+ |s const expr|
+
+ self markConstantFrom:tokenPosition to:(source position).
+ s := self makeImmutable:tokenValue.
+ self nextToken.
+ const := ConstantNode type:#String value:s from:pos to:tokenLastEndPosition.
+ expr := MessageNode receiver:const selector:#asRegex.
+ ^ expr
+ ].
+
(tokenType == #Error) ifTrue:[^ #Error].
- tokenType isCharacter ifTrue:[
- eMsg := '"',tokenType printString,'" unexpected in primary.'.
+
+ startPos := tokenPosition.
+ tokenType == #EOF ifTrue:[
+ eMsg := 'unexpected EOF in primary.'.
+ startPos := tokenPosition-1.
endPos := tokenPosition.
- ] ifFalse:[
- (#(BinaryOperator Keyword) includes:tokenType) ifTrue:[
- eMsg := tokenType printString,' ("' , tokenName , '") ',' unexpected in primary. (missing receiver ?)'
+ ] ifFalse:[
+ tokenType isCharacter ifTrue:[
+ eMsg := '"',tokenType printString,'" unexpected in primary.'.
+ currentBlock notNil ifTrue:[
+ eMsg := eMsg , ' (i.e. "]" or "." expected)'
+ ].
+ endPos := tokenPosition.
] ifFalse:[
- (#(Integer Float) includes:tokenType) ifTrue:[
- eMsg := tokenType printString,' (' , tokenValue , ') ',' unexpected in primary. (missing receiver ?)'
+ (#(BinaryOperator Keyword) includes:tokenType) ifTrue:[
+ eMsg := tokenType printString,' ("' , tokenName , '") ',' unexpected in primary. (missing receiver ?)'
] ifFalse:[
- eMsg := '"',(token ? ''),'" (',tokenType printString,') unexpected in primary.'
- ]
- ].
- endPos :=source position.
- ].
- self syntaxError:eMsg position:tokenPosition to:endPos.
+ (#(Integer Float) includes:tokenType) ifTrue:[
+ eMsg := tokenType printString,' (' , tokenValue , ') ',' unexpected in primary. (missing receiver ?)'
+ ] ifFalse:[
+ eMsg := '"',(token ? ''),'" (',tokenType printString,') unexpected in primary.'
+ ]
+ ].
+ endPos :=source position.
+ ].
+ ].
+ self syntaxError:eMsg position:startPos to:endPos.
^ #Error
"Created: / 13-09-1995 / 12:50:50 / claus"
"Modified: / 01-08-2011 / 12:04:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 26-07-2012 / 11:35:46 / cg"
+ "Modified: / 21-06-2019 / 10:06:11 / Claus Gittinger"
+ "Modified: / 24-09-2019 / 11:46:31 / Stefan Vogel"
!
primary_dolphinComputedLiteral
@@ -7873,11 +8399,11 @@
(val == #Error) ifTrue:[^ #Error].
(tokenType == $) ) ifFalse:[
tokenType isCharacter ifTrue:[
- eMsg := 'missing '')'' (i.e. ''' , tokenType asString , ''' unexpected)'.
+ eMsg := 'missing ")" (i.e. "' , tokenType asString , '" unexpected) or missing "#" before "("'.
] ifFalse:[
- eMsg := 'missing '')'''.
- ].
- self syntaxError:eMsg withCRs position:pos to:tokenPosition.
+ eMsg := 'missing ")" or missing "#" before "("'.
+ ].
+ self syntaxError:eMsg withCRs position:pos to:tokenPosition-1.
^ #Error
].
self markParenthesisAt:tokenPosition.
@@ -7940,10 +8466,10 @@
|pos1 pos2 expr varName rawName var globlName nameSpace nameSpaceGlobal
t cls lnr node holder assignmentAllowed|
+ varName := tokenName.
+
pos1 := tokenPosition.
- pos2 := tokenPosition + tokenName size - 1.
-
- varName := tokenName.
+ pos2 := pos1 + varName size - 1.
autoDefineVariables isNil ifTrue:[
autoDefineVariables := false.
@@ -8040,9 +8566,17 @@
(nameSpaceGlobal privateClassesAt:varName asSymbol) isNil ifTrue:[
rawName := rawName asSymbol.
(Smalltalk at:rawName) notNil ifTrue:[
- (self isFirstWarning:(#globalVsPrivateClass -> rawName)) ifTrue:[
- self warning:('Possible name clash (global: ' , rawName , ' vs. private: ' , (nameSpace , '::', varName) , ') - assume global.')
- position:pos1 to:source position "tokenPosition-1".
+ ParserFlags warnAboutPossibleNameClashes ifTrue:[
+ (self isFirstWarning:(#globalVsPrivateClass -> rawName)) ifTrue:[
+ DoNotShowCompilerWarningAgainActionQuery handle:[:ex |
+ "/ parserFlags warnAboutPossiblyUnimplementedSelectors:false.
+ ParserFlags warnAboutPossibleNameClashes:false.
+ ex proceed.
+ ] do:[
+ self warning:('Possible name clash (global: ' , rawName , ' vs. private: ' , (nameSpace , '::', varName) , ') - assume global.')
+ position:pos1 to:source position "tokenPosition-1".
+ ].
+ ].
].
globlName := rawName.
] ifFalse:[
@@ -8060,8 +8594,7 @@
(parserFlags warnAboutReferenceToPrivateClass
and:[self isFirstWarning:(#noPrivateClass -> (nameSpace , '::', varName))]) ifTrue:[
self warning:('Referring to private class ''' , varName allBold , ''' here.')
- doNotShowAgainAction:[ ParserFlags warnAboutReferenceToPrivateClass:false.
- parserFlags warnAboutReferenceToPrivateClass:false. ]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnAboutReferenceToPrivateClass)
position:pos1 to:source position " tokenPosition-1".
].
Tools::ToDoListBrowser notNil ifTrue:[
@@ -8087,7 +8620,7 @@
var startPosition: pos1 endPosition: pos2.
parseForCode ifFalse:[self rememberGlobalUsed:globlName].
].
- self markVariable:var from:pos1 to:pos1 + rawName size - 1 assigned:false.
+ self markVariable:var from:pos1 to:(pos1 + rawName size - 1) assigned:false.
].
var == #Error ifTrue:[
@@ -8095,7 +8628,7 @@
].
"/ errorFlag ~~ true ifTrue:[
-"/ self markVariable:var from:pos1 to:pos1 + varName size - 1.
+"/ self markVariable:var from:pos1 to:pos2.
"/ ].
"/ (ignoreErrors or:[parseForCode not and:[ignoreWarnings]]) ifTrue:[
"/ errorFlag := false.
@@ -8114,7 +8647,7 @@
"/ assignment...
(usedGlobals notNil and:[usedGlobals includes:(Smalltalk undeclaredPrefix,var name)]) ifFalse:[
- self markAssignedVariable:var from:pos1 to:pos1 + var name size - 1.
+ self markAssignedVariable:var from:pos1 to:pos2.
].
"/ careful: it could already be an implicit self send
@@ -8125,7 +8658,9 @@
"/ self isSyntaxHighlighter ifFalse:[
"/ (errorFlag or:[expr == #Error]) ifTrue:[^ #Error].
"/ ].
- ^ MessageNode receiver:(self selfNode) selector:('__' , varName) asMutator arg:expr.
+ ^ (MessageNode receiver:(self selfNode) selector:('__' , varName) asMutator arg:expr)
+ startPosition:pos1 endPosition: pos2;
+ yourself.
].
].
@@ -8195,7 +8730,7 @@
ParserFlags allowAssignmentToMethodArgument:true.
ex proceed.
] do:[
- self parseError:'assignment to method argument.' withCRs position:pos1 to:pos2.
+ self parseError:'assignment to method argument.' position:pos1 to:pos2.
self clearErrorFlag. "ok, user wants it - so he'll get it"
assignmentAllowed := true. "/ if proceeded
].
@@ -8293,6 +8828,11 @@
].
assignmentAllowed ifTrue:[
node := AssignmentNode variable:var expression:expr.
+ expr == #Error ifTrue:[ "/ what a hack
+ node startPosition:pos1 endPosition:tokenLastEndPosition.
+ ] ifFalse:[
+ node startPosition:pos1 endPosition:(expr endPosition ? tokenLastEndPosition).
+ ].
parserFlags fullLineNumberInfo ifTrue:[node lineNumber:lnr].
node := self assignmentRewriteHookFor:node.
] ifFalse:[
@@ -8330,6 +8870,7 @@
receiver:(VariableNode globalNamed:#LazyValue)
selector:#'block:'
arg:blockNode.
+ expr startPosition:pos endPosition:tokenLastEndPosition.
^ expr
!
@@ -8395,7 +8936,7 @@
"/ ImmutableStrings are experimental
"/
parserFlags stringsAreImmutable ifTrue:[
- token := tokenValue := self makeImmutableString:tokenValue.
+ token := tokenValue := self makeImmutable:tokenValue.
].
].
].
@@ -8413,6 +8954,16 @@
] ifFalse:[
tokenType == #String ifTrue:[
self markStringFrom:pos to:source position.
+ source isExternalStream ifFalse:[
+ source contents isString ifTrue:[
+ "/ an expanded special string ? (not a quote at start)
+ (source contents at:pos) ~~ $' ifTrue:[
+ "/ remember the original, in case we want to rewrite the code.
+ "/ (or prettyPrint)
+ val originalString:(source contents copyFrom:pos to:source position).
+ ].
+ ].
+ ].
] ifFalse:[
self markConstantFrom:pos to:source position.
].
@@ -8426,19 +8977,47 @@
"Modified: / 21-08-2011 / 08:10:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 26-07-2012 / 11:37:44 / cg"
-!
-
-primary_squeakComputedArray
- "parse a squeak computed array literal; return a node-tree, or raise an Error.
- In squeak, these are written as: { expr1 . expr2 . ... exprN )
- and create a message to construct an Array containing the exprI values"
-
- |pos pos2 exprList|
+ "Modified: / 09-06-2019 / 15:24:17 / Claus Gittinger"
+!
+
+primary_squeakComputedArrayOrComputedInlineObject
+ "parse a squeak computed array literal;
+ return a node-tree, or raise an Error.
+ In squeak, these are written as:
+ { expr1 . expr2 . ... exprN }
+ and create a message to construct an Array containing the exprI values.
+ ST/X also supports immediate objects which are instances of anonymous classes,
+ and are written as:
+ { slotName1: expr1 . slotName2: expr2 . ... slotNameN: exprN }
+ "
+
+ |pos pos2 exprList nameExprDict line1 node isComputedArray|
pos := tokenPosition.
-
+ line1 := tokenLineNr.
+
self nextToken.
- exprList := self squeakComputedArray.
+ (tokenType == #Keyword) ifTrue:[
+ parserFlags allowInlineObjects == true ifFalse:[
+ |hadErrorBefore|
+
+ hadErrorBefore := errorFlag.
+ DoEnableCompilerOptionActionQuery handle:[:ex |
+ parserFlags allowInlineObjects:true.
+ ParserFlags allowInlineObjects:true.
+ ex proceed.
+ ] do:[
+ self parseError:c'Non-Standard ST/X inline objects extension.\nPlease enable "allowInlineObjects" in settings.' position:pos to:tokenPosition.
+ ].
+ errorFlag := hadErrorBefore.
+ ].
+ self warnPossibleIncompatibility:'ST/X inline objects extension' position:pos to:tokenPosition.
+ nameExprDict := self stxComputedInlineObject.
+ isComputedArray := false.
+ ] ifFalse:[
+ exprList := self squeakComputedArrayExpressions.
+ isComputedArray := true.
+ ].
(exprList == #Error) ifTrue:[ ^ #Error ].
tokenType ~~ $} ifTrue:[
@@ -8450,11 +9029,16 @@
(self noAssignmentAllowed:'Invalid assignment' at:pos) ifFalse:[
^ #Error
].
-
- "/ make it an array creation expression ...
- ^ (self genMakeArrayWith:exprList)
- startPosition: pos
- endPosition: pos2
+ isComputedArray ifTrue:[
+ "/ make it an array creation expression ...
+ node := self genMakeArrayWith:exprList.
+ ] ifFalse:[
+ "/ make it an inline object creation expression ...
+ node := self genMakeInlineObjectWith:nameExprDict.
+ ].
+ node startPosition:pos endPosition:pos2.
+ node lineNumber:line1.
+ ^ node
"
Compiler allowSqueakExtensions:true.
@@ -8468,8 +9052,7 @@
Compiler allowSqueakExtensions:false.
"
- "Modified: / 27-07-2011 / 15:56:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 22-08-2012 / 13:20:58 / cg"
+ "Created: / 21-06-2019 / 10:06:06 / Claus Gittinger"
!
primary_super
@@ -8542,7 +9125,14 @@
qualifiedNameFrom:pos1
"a vw3.x (and later) feature: QualifiedName is #{ id ... id }
and mapped to a global variable here.
- The initial #{ is supposed to be skipped and its position passed in as pos1."
+ The initial #{ is supposed to be skipped and its position passed in as pos1.
+
+ Notice, the VW implementation will generate a literal reference to a binding-cell,
+ which is not reified in ST/X
+ (does not exist in ST/X as Smalltalk object, but only inside the VM).
+ Thus, the generated name (a symbol) has NOT the same semantics,
+ and imported VW code may need some modifications to work.
+ "
|elements elem nm|
@@ -8620,12 +9210,15 @@
"/ ].
"/ ^ elements first.
- "Modified: / 14.4.1998 / 17:03:29 / cg"
+ "Modified: / 14-04-1998 / 17:03:29 / cg"
+ "Modified (comment): / 30-05-2019 / 11:48:01 / Claus Gittinger"
!
qualifiedNameOrInlineObject
- "either a vw3.x (and later) QualifiedName #{ id ... id }
- or an ST/X experimental inline object #{ name: value. ... name: value }
+ "either a vw3.x (and later) QualifiedName
+ #{ id ... id }
+ or an ST/X experimental inline object
+ #{ name: value. ... name: value }
The initial #{ is skipped here, but the position passed down."
|pos1|
@@ -8634,15 +9227,38 @@
self nextToken.
(tokenType == #Keyword) ifTrue:[
+ parserFlags allowInlineObjects == true ifFalse:[
+ |hadErrorBefore|
+
+ hadErrorBefore := errorFlag.
+ DoEnableCompilerOptionActionQuery handle:[:ex |
+ parserFlags allowInlineObjects:true.
+ ParserFlags allowInlineObjects:true.
+ ex proceed.
+ ] do:[
+ self parseError:c'Non-Standard ST/X inline objects extension.\nPlease enable "allowInlineObjects" in settings.' position:pos1 to:tokenPosition.
+ ].
+ errorFlag := hadErrorBefore.
+ ].
+ self warnPossibleIncompatibility:'ST/X inline objects extension' position:pos1 to:tokenPosition.
^ self inlineObjectFrom:pos1.
].
parserFlags allowQualifiedNames == true ifFalse:[
- self parseError:'non-Standard VisualWorks extension: #{..}. Please enable in settings.' position:pos1 to:tokenPosition.
+ self parseError:c'Non-Standard VisualWorks extension: #{ .. }.\nPlease enable "allowQualifiedNames" in settings.' position:pos1 to:tokenPosition.
].
^ self qualifiedNameFrom:pos1
-!
-
-squeakComputedArray
+
+ "Modified: / 30-05-2019 / 11:48:24 / Claus Gittinger"
+!
+
+squeakComputedArrayExpressions
+ "parse a squeak computed array literal;
+ return a node-tree, or raise an Error.
+ In squeak, these are written as:
+ { expr1 . expr2 . ... exprN }
+ and create a message to construct an Array containing the exprI values.
+ "
+
|expressions elem pos1|
tokenType == $} ifTrue:[
@@ -8650,7 +9266,7 @@
].
pos1 := tokenPosition.
- expressions := OrderedCollection new:20.
+ expressions := OrderedCollection new.
[
elem := self expression.
(elem == #Error) ifTrue:[
@@ -8670,14 +9286,209 @@
].
] loop.
"/ not reached
+
+ "Created: / 19-08-2018 / 11:13:42 / Claus Gittinger"
+ "Modified (comment): / 21-06-2019 / 09:50:18 / Claus Gittinger"
+!
+
+stringWithEmbeddedExpressions
+ "
+ e'...' generates
+ stringConst bindWith:....
+ and i'...' generates:
+ thisContext resources string:... with:..."
+
+ |isIString expressions collectedString pos1 pos2
+ fragPos receiver node lNr numExpressions concatenatedStringConst|
+
+ isIString := (tokenType == #IStringFragment).
+
+ pos1 := fragPos := tokenPosition.
+ lNr := tokenLineNr.
+ expressions := OrderedCollection new.
+ collectedString := ''.
+ [(tokenType == #EStringFragment) or:[(tokenType == #IStringFragment)]] whileTrue:[
+ |expr idxString|
+
+ self markStringFrom:fragPos to:source position-1.
+ parenthesisLevel := parenthesisLevel + 1.
+ self markParenthesisAt:source position.
+
+ collectedString := collectedString,tokenValue.
+ self nextToken.
+ expr := self expression.
+ expr == #Error ifTrue:[
+ self parseError:'error in embedded expression'.
+ ].
+ "/ there must be a closing brace
+ tokenType == $} ifFalse:[
+ self parseError:'"}" expected after embedded expression'.
+ ].
+ self markParenthesisAt:tokenPosition.
+ parenthesisLevel := parenthesisLevel - 1.
+
+ expressions add:expr.
+ idxString := expressions size asString.
+ expressions size >= 10 ifTrue:[
+ idxString := '(',idxString,')'
+ ].
+ collectedString := collectedString,'%',idxString.
+ fragPos := source position+1.
+ self continueEscapedString.
+ ].
+ pos2 := tokenPosition.
+
+ tokenType == #String ifFalse:[
+ self parseError:'unterminated embedded expression string'.
+ ].
+ self markStringFrom:fragPos to:source position-1.
+
+ collectedString := collectedString,tokenValue.
+ self nextToken.
+
+ "/ now make this a message send.
+
+ parserFlags stringsAreImmutable ifTrue:[
+ collectedString := self makeImmutable:collectedString.
+ ].
+ concatenatedStringConst := ConstantNode type:#String value:collectedString
+ from:pos1 to:pos2.
+
+ numExpressions := expressions size.
+ isIString ifTrue:[
+ |instIndex|
+
+ "/ generate either "thisContext resources"
+ "/ or "resources", if compiling for an application
+ (classToCompileFor notNil
+ and:[ ApplicationModel notNil
+ and:[ (classToCompileFor includesBehavior:ApplicationModel)
+ and:[ (instIndex := classToCompileFor instVarIndexFor:'resources') notNil
+ ]]]) ifTrue:[
+ receiver := VariableNode
+ type:#InstanceVariable name:'resources'
+ index:instIndex selfValue:selfValue.
+ ] ifFalse:[
+ receiver := UnaryNode
+ receiver:(VariableNode type:#ThisContext)
+ selector:#resources.
+ self rememberSelectorUsed:#resources.
+ ].
+ numExpressions == 0 ifTrue:[
+ node := MessageNode
+ receiver:receiver
+ selector:#'string:'
+ arg:concatenatedStringConst
+ ] ifFalse:[
+ numExpressions == 1 ifTrue:[
+ node := MessageNode
+ receiver:receiver
+ selector:#string:with:
+ arg1:concatenatedStringConst
+ arg2:(expressions first)
+ ] ifFalse:[
+ numExpressions == 2 ifTrue:[
+ node := MessageNode
+ receiver:receiver
+ selector:#string:with:with:
+ args:{concatenatedStringConst},expressions
+ ] ifFalse:[
+ node := MessageNode
+ receiver:receiver
+ selector:#string:withArguments:
+ arg1:concatenatedStringConst
+ arg2:(self genMakeArrayWith:expressions).
+ ]
+ ].
+ self rememberSelectorUsed:node selector.
+ ].
+ ] ifFalse:[
+ numExpressions == 0 ifTrue:[
+ node := concatenatedStringConst
+ ] ifFalse:[
+ numExpressions == 1 ifTrue:[
+ node := MessageNode
+ receiver:concatenatedStringConst
+ selector:#bindWith:
+ arg:expressions first
+ ] ifFalse:[
+ numExpressions == 2 ifTrue:[
+ node := MessageNode
+ receiver:concatenatedStringConst
+ selector:#bindWith:with:
+ args:expressions
+ ] ifFalse:[
+ node := MessageNode
+ receiver:concatenatedStringConst
+ selector:#bindWithArguments:
+ arg:(self genMakeArrayWith:expressions).
+ ].
+ ].
+ self rememberSelectorUsed:node selector.
+ ].
+ ].
+ node startPosition:pos1 endPosition:pos2.
+ node lineNumber:lNr.
+ ^ node
+
+ "Created: / 22-05-2019 / 20:58:24 / Claus Gittinger"
+ "Modified: / 09-06-2019 / 15:21:58 / Claus Gittinger"
+!
+
+stxComputedInlineObject
+ "parse an ST/X immediate object, which is an instance of an anonymous class,
+ and written as:
+ { slotName1: expr1 . slotName2: expr2 . ... slotNameN: exprN }
+ "
+
+ |nameExprDict slotName elemExpr pos1|
+
+ tokenType == $} ifTrue:[
+ ^ #()
+ ].
+
+ pos1 := tokenPosition.
+ nameExprDict := OrderedDictionary new.
+ [
+ (tokenType == #Keyword) ifFalse:[
+ self syntaxError:'slotname (keyword) expected' position:pos1 to:tokenPosition
+ ].
+ slotName := token withoutSuffix:':'.
+ self nextToken.
+ elemExpr := self expression.
+ (elemExpr == #Error) ifTrue:[
+ (tokenType == #EOF) ifTrue:[
+ self syntaxError:'unterminated inline-object; ''}'' expected'
+ position:pos1 to:tokenPosition
+ ].
+ ^ #Error
+ ].
+ nameExprDict at:slotName put:elemExpr.
+ tokenType == $. ifFalse:[
+ ^ nameExprDict
+ ].
+ self nextToken.
+ tokenType == $} ifTrue:[
+ ^ nameExprDict
+ ].
+ ] loop.
+ "/ not reached
+
+ "Created: / 21-06-2019 / 09:51:31 / Claus Gittinger"
+ "Modified: / 21-06-2019 / 12:22:13 / Claus Gittinger"
!
typedArray:typeSymbol
"parse a typed array's elements.
This is an ST/X extension, which is not supported by other Smalltalk implementations.
- For now, the support is disabled; enable with:
+ For now, the support is disabled by default;
+ enable with:
ParserFlags allowSTXExtendedArrayLiterals:true
+ or a pragma, like:
+ <pragma: +allowSTXExtendedArrayLiterals>
+
Typed literal arrays are written in scheme-style as:
+ #u1( element... ) - unsigned 1-bit bytes (i.e. a BitArray)
#u8( element... ) - unsigned 8-bit bytes (i.e. a regular ByteArray)
#u16( element... ) - unsigned 16-bit shorts (i.e. a WordArray)
#u32( element... ) - unsigned 32-bit ints (i.e. an IntegerArray)
@@ -8692,9 +9503,8 @@
#f( element... ) - same as f32(...)
#d( element... ) - same as f64(...)
- "
-
- "literal bytearrays started with ST-80 R4 - byteArray constants are written as #[ ... ]"
+ #B( element... ) - BooleanArray
+ "
|idx containerType container elStream newArray elem pos1 pos2|
@@ -8741,20 +9551,18 @@
(container isValidElement:elem) ifFalse:[
self parseError:'element is not appropriate for #',typeSymbol,'-array (',containerType,')' position:pos2 to:tokenPosition.
elem := container defaultElement.
- ] ifTrue:[
- (typeSymbol == #u8 and:[elem < 0]) ifTrue:[
- self parseError:'element is not appropriate for #',typeSymbol,'-array (',containerType,')' position:pos2 to:tokenPosition.
- elem := container defaultElement.
- ].
].
elStream nextPut:elem.
self nextToken.
].
newArray := elStream contents.
-"/ parserFlags arraysAreImmutable ifTrue:[
-"/ ^ self class makeImmutable:newArray
-"/ ].
+ parserFlags arraysAreImmutable ifTrue:[
+ ^ self makeImmutable:newArray.
+ ].
^ newArray
+
+ "Modified: / 09-06-2019 / 15:24:35 / Claus Gittinger"
+ "Modified: / 22-07-2020 / 11:55:40 / cg"
!
unaryExpression
@@ -8783,10 +9591,11 @@
unaryExpressionFor:receiverArg
"parse a unary-expression; return a node-tree, nil or #Error"
- |receiver expr sel pos pos2 lNr arguments|
+ |receiver expr sel pos pos1 pos2 lNr arguments|
receiver := receiverArg.
(receiver == #Error) ifTrue:[^ #Error].
+ pos1 := receiverArg startPosition ? tokenPosition.
[ self isValidUnarySelector:tokenType ] whileTrue:[
pos := tokenPosition.
@@ -8808,6 +9617,10 @@
arguments size - 1 timesRepeat:[ sel := sel , 'with:' ].
].
sel := self selectorCheck:sel for:receiver position:pos to:pos2.
+ self warnIfPossiblyUninitializedLocal:receiver.
+ arguments do:[:eachArg |
+ self warnIfPossiblyUninitializedLocal:eachArg
+ ].
expr := MessageNode receiver:receiver selector:sel args:arguments fold:foldConstants.
expr isErrorNode ifTrue:[
self parseError:(expr errorString) position:pos to:pos2.
@@ -8815,6 +9628,7 @@
expr := MessageNode receiver:receiver selector:sel args:arguments fold:nil.
].
expr lineNumber:lNr.
+ expr startPosition:pos1 endPosition:tokenLastEndPosition.
self checkPlausibilityOf:expr from:pos to:pos2.
parseForCode ifFalse:[
@@ -8826,7 +9640,7 @@
"/ create the expression before (corrector may need it)
expr := UnaryNode receiver:receiver selector:sel fold:foldConstants.
- expr startPosition: receiver startPosition endPosition: pos2.
+ expr startPosition:pos1 endPosition:pos2.
"/ attention: may have been optimized (Character return -> const!!
expr isMessage ifTrue:[
@@ -8839,7 +9653,7 @@
self warning:(expr errorString , '.\\If you proceed, that error may be raised at runtime.') withCRs position:pos to:pos2.
self clearErrorFlag. "ok, user wants it - so he'll get it"
expr := UnaryNode receiver:receiver selector:sel fold:nil.
- expr startPosition: receiver startPosition endPosition: pos2.
+ expr startPosition:(receiver startPosition) endPosition: pos2.
].
expr lineNumber:lNr.
@@ -8851,10 +9665,12 @@
expr := self messageNodeRewriteHookFor:expr.
receiver := expr. "/ for next message
].
+ receiver endPosition isNil ifTrue:[self halt].
^ receiver
"Modified: / 30-08-2013 / 13:02:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 03-07-2017 / 13:57:55 / cg"
+ "Modified: / 08-02-2019 / 17:19:56 / Claus Gittinger"
!
variable
@@ -8919,10 +9735,11 @@
tokenName isLowercaseFirst ifTrue:[
parserFlags implicitSelfSends ifTrue:[
- ^ UnaryNode receiver:(self selfNode) selector:('__' , tokenName) asSymbol.
- ].
- ].
- self parseError:'undeclared variable: ',tokenName.
+ ^ (UnaryNode receiver:(self selfNode) selector:('__' , tokenName) asSymbol)
+ startPosition:pos1 endPosition:pos2
+ ].
+ ].
+ self parseError:('undeclared variable: ',tokenName) as:UndefinedVariableError position:pos1 to:pos2.
] ifFalse:[
self rememberGlobalUsed:(Smalltalk undeclaredPrefix) , tokenName.
self rememberGlobalUsed:tokenName.
@@ -8930,7 +9747,7 @@
"/ self markGlobalIdentifierFrom:pos1 to:pos2.
^ (VariableNode globalNamed:tokenName)
- startPosition: pos1 endPosition: (pos1 + tokenName size - 1)
+ startPosition:pos1 endPosition:pos2
"Modified: / 25-08-2011 / 11:57:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 22-06-2017 / 06:57:11 / cg"
@@ -8951,7 +9768,10 @@
|varIndex aClass searchBlock args vars
tokenSymbol space classVarIndex holder node
- checkSharedPoolAction|
+ checkSharedPoolAction checkSharedPoolByNameAction varNameAsSymbolOrNil
+ endPosition|
+
+ endPosition := tokenPosition + varName size - 1.
"is it a block-arg or block-var ?"
searchBlock := currentBlock.
@@ -8963,7 +9783,7 @@
^ (VariableNode type:#BlockVariable name:varName
token:(vars at:varIndex) index:varIndex
block:searchBlock from:currentBlock)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition:tokenPosition endPosition:endPosition
].
].
@@ -8974,7 +9794,7 @@
^ (VariableNode type:#BlockArg name:varName
token:(args at:varIndex) index:varIndex
block:searchBlock from:currentBlock)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition: tokenPosition endPosition:endPosition
].
].
@@ -9000,12 +9820,12 @@
con := contextToEvaluateIn.
[con notNil] whileTrue:[
varNames := con argAndVarNames.
- varNames size > 0 ifTrue:[
+ varNames size ~~ 0 ifTrue:[
varIndex := varNames lastIndexOf:varName.
varIndex ~~ 0 ifTrue:[
^ (VariableNode type:#ContextVariable name:varName
context:con index:varIndex)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition:tokenPosition endPosition:endPosition
].
].
con := con home.
@@ -9013,6 +9833,15 @@
].
checkSharedPoolAction :=
+ [:sharedPool |
+ (sharedPool includesKey:varName) ifTrue:[
+ parseForCode ifFalse:[self rememberGlobalUsed:(sharedPool name , ':' , varName)].
+ ^ (VariableNode type:#PoolVariable class:sharedPool name:varName)
+ startPosition: tokenPosition endPosition:endPosition
+ ].
+ ].
+
+ checkSharedPoolByNameAction :=
[:eachPoolName |
|sharedPool|
@@ -9021,11 +9850,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
].
].
@@ -9046,7 +9871,7 @@
self
warning:('there is both a class variable and a class-instance variable named "%1" (in %2).\\Refering to the class-instance variable here.' withCRs
bindWith:varName with:(self whichClassIncludesClassVar:varName) name)
- position:tokenPosition to:tokenPosition+varName size-1.
+ position:tokenPosition to:endPosition.
alreadyWarnedClassInstVarRefs add:varName.
].
].
@@ -9054,7 +9879,7 @@
parseForCode ifFalse:[self rememberInstVarUsed:varName].
^ (VariableNode type:#InstanceVariable name:varName
index:varIndex selfValue:selfValue)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition:tokenPosition endPosition:endPosition
].
"/ see if there is a corresponding classVar (for the warning)
@@ -9067,7 +9892,7 @@
"/ from instance methods ...
"/ (used to be in previous ST/X versions)
"/
- varIndex := (self classesClassInstVarNames) lastIndexOf:varName.
+ varIndex := self classesClassInstVarNames lastIndexOf:varName.
varIndex ~~ 0 ifTrue:[
aClass := self inWhichClassIsClassInstVar:varName.
aClass notNil ifTrue:[
@@ -9080,7 +9905,7 @@
^ (VariableNode type:#ClassInstanceVariable name:varName
index:varIndex selfClass:aClass)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition:tokenPosition endPosition:endPosition
].
self parseError:'access to class-inst-var from inst method is not allowed'.
^ #Error.
@@ -9112,37 +9937,55 @@
aClass notNil ifTrue:[
parseForCode ifFalse:[self rememberClassVarUsed:varName].
^ (VariableNode type:#ClassVariable class:aClass name:varName)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition:tokenPosition endPosition:endPosition
].
"/ self halt:'oops - should not happen'.
].
"is it a private-class ?"
- aClass := self classToLookForClassVars theNonMetaclass.
- aClass isLoaded ifTrue:[
+ aClass := self classToLookForClassVars "theNonMetaclass".
+ (aClass notNil and:[aClass isLoaded]) ifTrue:[
+ aClass := aClass theNonMetaclass.
(aClass privateClassesAt:varName) notNil ifTrue:[
parseForCode ifFalse:[self rememberGlobalUsed:(aClass name , '::' , varName)].
^ (VariableNode type:#PrivateClass class:aClass name:varName)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition:tokenPosition endPosition:endPosition
].
].
" 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:[
- ^ (VariableNode type:#ThreadLocal name:varName)
- startPosition: tokenPosition endPosition: tokenPosition + varName size -1
+ (varNameAsSymbolOrNil := varName asSymbolIfInterned) notNil ifTrue:[
+ (Processor activeProcess environmentIncludesKey:varNameAsSymbolOrNil) ifTrue:[
+ ^ (VariableNode type:#ThreadLocal name:varName)
+ startPosition:tokenPosition endPosition:endPosition
+ ].
].
].
+ "/ attention: in scripting mode (stx --script),
+ "/ workspace variables must be found!!
+ "/ (autoDefineVariables ~~ false)
+ self isDoIt ifTrue:[
+ "is it a workspace variable ?"
+
+ (Workspace notNil
+ and:[(holder := Workspace workspaceVariableHolderAt:varName) notNil])
+ ifTrue:[
+ ^ (VariableNode type:#WorkspaceVariable holder:holder name:varName)
+ startPosition:tokenPosition endPosition:endPosition
+ ].
+ ].
+
"is it in a namespace ?"
space := self findNameSpaceWith:varName.
space notNil ifTrue:[
@@ -9150,13 +9993,13 @@
parseForCode ifFalse:[self rememberGlobalUsed:(space name , '::' , varName)].
space isNameSpace ifTrue:[
^ (VariableNode globalNamed:(space name , '::' , varName))
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ startPosition:tokenPosition endPosition:endPosition
].
^ (VariableNode type:#PrivateClass class:space name:varName)
- startPosition: tokenPosition endPosition: tokenPosition + varName size -1
+ startPosition:tokenPosition endPosition:endPosition
].
parseForCode ifFalse:[self rememberGlobalUsed:varName].
- ^ (VariableNode globalNamed:varName) startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
+ ^ (VariableNode globalNamed:varName) startPosition:tokenPosition endPosition:endPosition
].
"is it a global-variable ?"
@@ -9164,46 +10007,35 @@
tokenSymbol notNil ifTrue:[
(Smalltalk includesKey:tokenSymbol) ifTrue:[
parseForCode ifFalse:[self rememberGlobalUsed:varName].
- ^ (VariableNode globalNamed:tokenSymbol) startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
- ]
- ].
-
- autoDefineVariables isNil ifTrue:[
- autoDefineVariables := false.
- (requestor notNil and:[requestor isStream not]) ifTrue:[
- autoDefineVariables := (requestor perform:#autoDefineVariables ifNotUnderstood:false) ? false.
+ ^ (VariableNode globalNamed:tokenSymbol) startPosition:tokenPosition endPosition:endPosition
]
- ].
-
- "/ attention: in scripting mode (stx --script),
- "/ workspace variables must be found!!
-
- "/ (autoDefineVariables ~~ false)
- self isDoIt
- ifTrue:[
- "is it a workspace variable ?"
-
- (Workspace notNil
- and:[(holder := Workspace workspaceVariableHolderAt:varName) notNil])
- ifTrue:[
- ^ (VariableNode type:#WorkspaceVariable holder:holder name:varName)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
- ].
- "/ self isDoIt
- (autoDefineVariables ~~ false)
- ifTrue:[
+ ].
+
+ self isDoIt ifTrue:[
+ autoDefineVariables isNil ifTrue:[
+ autoDefineVariables := false.
+ (requestor notNil and:[requestor isStream not]) ifTrue:[
+ autoDefineVariables := (requestor perform:#autoDefineVariables ifNotUnderstood:false) ? false.
+ ]
+ ].
+
+ (autoDefineVariables ~~ false) ifTrue:[
"is it a doIt variable ?"
(doItTemporaries notNil
and:[(holder := doItTemporaries at:varName asSymbol ifAbsent:nil) notNil])
ifTrue:[
^ (VariableNode type:#DoItTemporary holder:holder name:varName)
- startPosition: tokenPosition endPosition: tokenPosition + varName size - 1
- ].
- ].
- ].
-
- "/ do not raise parseError here, but instead report it a the old stupid #Error token.
+ startPosition:tokenPosition endPosition:endPosition
+ ].
+ ].
+ ].
+
+ self unknownVariableResolver notNil ifTrue:[
+ ^ self unknownVariableResolver variableNodeFor:varName startPosition:tokenPosition endPosition:endPosition
+ ].
+
+ "/ do not raise parseError here, but instead report it via the old stupid #Error token.
"/ this is required here so that the caller can check for an assignment,
"/ and autodefine workspace- and doIt variables.
"/ self parseError:'undeclared variable: ',tokenName.
@@ -9211,7 +10043,9 @@
"Modified: / 25-08-2011 / 13:53:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 05-10-2011 / 15:25:20 / az"
- "Modified (comment): / 14-06-2017 / 15:11:42 / cg"
+ "Modified (format): / 04-12-2018 / 11:28:12 / Stefan Vogel"
+ "Modified: / 08-06-2019 / 18:27:36 / Claus Gittinger"
+ "Modified: / 09-05-2020 / 13:22:04 / cg"
! !
!Parser methodsFor:'parsing-primitives & pragmas'!
@@ -9240,12 +10074,12 @@
defineWellknownCTypesIn:aDictionary
"/ a few wellknown types
- aDictionary at:#'BOOL' put:(CType typedef:CType bool name:'BOOL').
- aDictionary at:#'UINT' put:(CType typedef:CType unsignedInt name:'UINT').
- aDictionary at:#'LONG' put:(CType typedef:CType long name:'LONG').
- aDictionary at:#'DWORD' put:(CType typedef:CType int name:'DWORD').
- aDictionary at:#'HANDLE' put:(CType typedef:CType voidPointer name:'HANDLE').
- aDictionary at:#'HWND' put:(CType typedef:CType voidPointer name:'HWND') .
+ aDictionary at:#'BOOL' put:(CType typedef:(CType bool) name:'BOOL').
+ aDictionary at:#'UINT' put:(CType typedef:(CType unsignedInt) name:'UINT').
+ aDictionary at:#'LONG' put:(CType typedef:(CType long) name:'LONG').
+ aDictionary at:#'DWORD' put:(CType typedef:(CType int) name:'DWORD').
+ aDictionary at:#'HANDLE' put:(CType typedef:(CType voidPointer) name:'HANDLE').
+ aDictionary at:#'HWND' put:(CType typedef:(CType voidPointer) name:'HWND') .
"/ aDictionary at:#'HPALETTE' put:(CType typedef:CType voidPointer name:'HPALETTE') .
!
@@ -9331,7 +10165,7 @@
"Created: / 21-06-2006 / 09:58:43 / cg"
!
-parseAnotationLiteral
+parseAnnotationLiteral
|value|
((tokenType == #String)
@@ -9380,11 +10214,22 @@
^value.
].
self parseError:tokenType,' unexpected in annotation'.
- ^ #Error
+ self nextToken.
+ ^ nil
+
+ "Created: / 08-06-2019 / 18:15:16 / Claus Gittinger"
+ "Modified: / 25-07-2020 / 11:13:56 / cg"
+!
+
+parseAnotationLiteral
+ "typo in selector - left in for a while for compatibility"
+
+ ^ self parseAnnotationLiteral
"Created: / 12-11-2009 / 14:08:29 / Jan Travnicek <travnja3@fel.cvut.cz>"
"Modified: / 15-12-2009 / 14:01:42 / Jan Travnicek <travnja3@fel.cvut.cz>"
"Modified: / 12-07-2010 / 10:07:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 08-06-2019 / 18:15:47 / Claus Gittinger"
!
parseExceptionOrContextPragma
@@ -9539,10 +10384,7 @@
self addAnnotationWithKey:key asSymbol andArguments:value.
^ nil.
].
- value := self parseAnotationLiteral.
- (value == #Error) ifTrue:[
- ^ #Error.
- ].
+ value := self parseAnnotationLiteral.
((tokenType == #BinaryOperator) and:[ tokenName = '>' ]) ifTrue:[
self checkForClosingAngle. "/ not really a check, but remembers endPos
self addAnnotationWithKey:key asSymbol andArguments:{ value }.
@@ -9555,7 +10397,7 @@
] whileTrue:[
key := key , tokenName.
self nextToken.
- value := self parseAnotationLiteral.
+ value := self parseAnnotationLiteral.
(value == #Error) ifTrue:[
^ #Error.
].
@@ -9573,14 +10415,20 @@
"Created: / 04-11-2009 / 08:51:48 / Jan Travnicek <travnja3@fel.cvut.cz>"
"Modified: / 19-11-2009 / 11:48:24 / Jan Travnicek <travnja3@fel.cvut.cz>"
"Modified: / 13-02-2015 / 15:46:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 08-06-2019 / 18:16:12 / Claus Gittinger"
+ "Modified: / 25-07-2020 / 11:14:19 / cg"
!
parsePragma
" '<' has already been parsed.
+ parses pragmas of the form:
<pragma: +arrayIndexSyntaxExtension>
- "
-
- |type flagValue|
+ <pragma: +STXSyntaxExtensions>
+ <pragma: +lazyValueExtension>
+ <pragma: +functionCallSyntaxForBlockEvaluation>
+ "
+
+ |type flagValue setterInParserFlags pagmaIsKnown|
type := token.
type ~= 'pragma:' ifTrue:[
@@ -9593,12 +10441,14 @@
flagValue := (token = '+').
self nextToken.
(tokenType == #Identifier) ifTrue:[
- ( #(
- 'arrayIndexSyntaxExtension'
- "possibly add more here"
- ) includes:token
- ) ifTrue:[
- parserFlags perform:('allow',token asUppercaseFirst) asMutator with:flagValue.
+ setterInParserFlags := token asMutator.
+ pagmaIsKnown := parserFlags class implements:setterInParserFlags.
+ pagmaIsKnown ifFalse:[
+ setterInParserFlags := ('allow',token asUppercaseFirst) asMutator.
+ pagmaIsKnown := parserFlags class implements:setterInParserFlags.
+ ].
+ pagmaIsKnown ifTrue:[
+ parserFlags perform:setterInParserFlags with:flagValue.
self nextToken.
self checkForClosingAngle.
^ self.
@@ -9609,8 +10459,10 @@
^ self
].
- self parseError:'+/- expected'.
+ self parseError:'"+/-"<flagName> expected'.
^ self
+
+ "Modified: / 09-06-2019 / 15:06:45 / Claus Gittinger"
!
parsePrimitive
@@ -9887,7 +10739,34 @@
self parseError:'primitive number expected (V''Age-primitives not allowed - see settings)'.
]
] ifFalse:[
- self parseError:'primitive number expected'.
+ "/ new in Pharo
+ "/ <primitive: #primitiveNativeCall module: #NativeBoostPlugin>
+ (tokenType == #Symbol) ifTrue:[
+ (parserFlags allowSqueakExtensions
+ or:[ parserFlags allowSqueakPrimitives]) ifFalse:[
+ self parseError:'Squeak primitives not allowed - see settings'.
+ ].
+ self nextToken.
+ ((tokenType == #Keyword) and:[token = 'module:']) ifFalse:[
+ (tokenType == #BinaryOperator and:[token = '>']) ifTrue:[
+ self checkForClosingAngle.
+ parserFlags allowVisualAgePrimitives ifFalse:[
+ self parseError:'V''Age-primitives not allowed - see settings'.
+ ].
+ ^ -1.
+ ].
+ self parseError:'Squeak primitives not allowed - see settings'.
+ ].
+ self nextToken.
+ (tokenType == #Symbol) ifFalse:[
+ self parseError:'Squeak primitives not allowed - see settings'.
+ ].
+ self nextToken.
+ self checkForClosingAngle.
+ ^ -1.
+ ] ifFalse:[
+ self parseError:'primitive number expected'.
+ ].
].
].
"/ (parserFlags allowSqueakExtensions
@@ -9953,7 +10832,8 @@
^ primNumber
"Modified: / 03-11-2009 / 17:14:48 / Jan Travnicek <travnja3@fel.cvut.cz>"
- "Modified: / 07-02-2012 / 17:22:52 / cg"
+ "Modified: / 04-10-2018 / 18:50:57 / Claus Gittinger"
+ "Modified: / 25-07-2020 / 11:34:30 / cg"
!
parseVWTypeOrExternalFunctionDeclarationFrom:aStream definitionType:definitionType knownDefinitions:dictionaryOfTypesOrNil lineNr:lineNr
@@ -10150,8 +11030,10 @@
genMakeArrayWith:elementExpressions
"return a node to generate an array at runtime.
Will generate:
- Array with:el1 ... with:elN (if N <= 5)
- or:
+ literal shallowCopy (if all elements are literals)
+ or else:
+ Array with:el1 ... with:elN (if N <= 8)
+ or else:
(Array new at:1 put:el1; ... at:N put:elN; yourself) (otherwise)
"
@@ -10160,6 +11042,23 @@
"Modified: / 01-08-2011 / 12:38:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+genMakeInlineObjectWith:nameExpressionDictionary
+ "return a node to generate an inline object at runtime"
+
+ |class classNode arrayNode node slotNames expressions|
+
+ slotNames := nameExpressionDictionary keys collect:#asSymbol.
+ expressions := nameExpressionDictionary values.
+
+ class := self inlineObjectClassFor:slotNames.
+ classNode := ConstantNode type:#Object value:class.
+ arrayNode := self genMakeArrayWith:expressions.
+ node := MessageNode receiver:arrayNode selector:#'changeClassTo:' arg:classNode.
+ ^ node
+
+ "Created: / 21-06-2019 / 10:08:18 / Claus Gittinger"
+!
+
inWhichClassIsClassInstVar:aString
"search class-chain for the class-instance variable named aString
- return the class or nil if not found"
@@ -10300,12 +11199,10 @@
"
!
-makeImmutableArray:anArray
- ^ self class makeImmutableArray:anArray
-!
-
-makeImmutableString:aString
- ^ self class makeImmutableString:aString
+makeImmutable:anObject
+ ^ self class makeImmutable:anObject
+
+ "Created: / 09-06-2019 / 15:21:50 / Claus Gittinger"
!
makeReferenceFor:aNode
@@ -10470,6 +11367,12 @@
"/ ^ selfNode
"Modified: / 19-07-2011 / 17:22:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+unknownVariableResolver
+ ^ nil
+
+ "Created: / 09-05-2020 / 13:16:19 / cg"
! !
!Parser methodsFor:'queries'!
@@ -10503,19 +11406,20 @@
classToLookForClassVars
"helper - return the class to look for classVars.
If there is a context in which we evaluate, the
- methods implementing class is used instead of the
+ method's implementing class is used instead of the
class of the receiver."
|m who|
contextToEvaluateIn notNil ifTrue:[
- m := contextToEvaluateIn method.
- m notNil ifTrue:[
- who := contextToEvaluateIn method who.
- who notNil ifTrue:[
- ^ who methodClass.
- ]
- ].
+ ^ contextToEvaluateIn methodClass
+"/ m := contextToEvaluateIn method.
+"/ m notNil ifTrue:[
+"/ who := contextToEvaluateIn method who.
+"/ who notNil ifTrue:[
+"/ ^ who methodClass.
+"/ ]
+"/ ].
"/ mhmh - might be a doIt ...
].
^ classToCompileFor
@@ -10527,12 +11431,12 @@
classesClassInstVarNames
"caching allInstVarNames for next compilation saves time ..."
- |names|
-
- [
- |cls|
-
- cls := self classToLookForClassVars.
+ |cls|
+
+ cls := self classToLookForClassVars.
+ cls isNil ifTrue:[^ #() ].
+
+ ^ [
(PrevClassInstVarNames isNil or:[PrevClass ~~ cls]) ifTrue:[
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
@@ -10542,23 +11446,25 @@
PrevClassInstVarNames := cls class allInstVarNames.
PrevClass addDependent:Parser.
].
- names := PrevClassInstVarNames.
+ PrevClassInstVarNames ? #().
] valueUninterruptably.
- ^ names
-
- "Created: / 14.10.1996 / 18:03:35 / cg"
- "Modified: / 18.6.1998 / 15:44:41 / cg"
+
+ "Created: / 14-10-1996 / 18:03:35 / cg"
+ "Modified: / 18-06-1998 / 15:44:41 / cg"
+ "Modified: / 04-12-2018 / 11:27:55 / Stefan Vogel"
!
classesClassVarNames
"caching allClassVarNames for next compilation saves time ..."
- |names|
-
- [
- |cls aClass|
-
- cls := self classToLookForClassVars.
+ |cls|
+
+ (cls := self classToLookForClassVars) isNil ifTrue:[
+ ^ #()
+ ].
+
+ ^ [
+ |aClass|
(PrevClassVarNames isNil or:[PrevClass ~~ cls]) ifTrue:[
PrevClass notNil ifTrue:[
@@ -10574,21 +11480,19 @@
PrevClassVarNames := aClass allClassVarNames.
PrevClass addDependent:Parser.
].
- names := PrevClassVarNames.
+ PrevClassVarNames ? #()
] valueUninterruptably.
- ^ names
-
- "Modified: / 17.6.1996 / 17:15:53 / stefan"
- "Created: / 14.10.1996 / 18:02:41 / cg"
- "Modified: / 18.6.1998 / 15:44:30 / cg"
+
+ "Modified: / 17-06-1996 / 17:15:53 / stefan"
+ "Created: / 14-10-1996 / 18:02:41 / cg"
+ "Modified: / 18-06-1998 / 15:44:30 / cg"
+ "Modified: / 04-12-2018 / 11:31:30 / Stefan Vogel"
!
classesInstVarNames
"caching allInstVarNames for next compilation saves time ..."
- |names|
-
- [
+ ^ [
(PrevInstVarNames isNil or:[PrevClass ~~ classToCompileFor]) ifTrue:[
PrevClass notNil ifTrue:[
PrevClass removeDependent:Parser
@@ -10599,12 +11503,11 @@
PrevClassVarNames := nil.
PrevClass addDependent:Parser
].
- names := PrevInstVarNames
+ PrevInstVarNames ? #()
] valueUninterruptably.
- ^ names
-
- "Created: 14.10.1996 / 18:00:26 / cg"
+ "Created: / 14-10-1996 / 18:00:26 / cg"
+ "Modified: / 04-12-2018 / 11:29:29 / Stefan Vogel"
!
contextMustBeReturnable
@@ -10761,7 +11664,7 @@
!
modifiedClassVars
- "return a collection with classvariablenames modified by method (valid after parsing)"
+ "return a collection with classvariable names modified by method (valid after parsing)"
^ modifiedClassVars ? #()
@@ -10769,7 +11672,7 @@
!
modifiedGlobals
- "return a collection with globalnames modified by method (valid after parsing)"
+ "return a collection with global names modified by method (valid after parsing)"
^ modifiedGlobals ? #()
@@ -10777,7 +11680,7 @@
!
modifiedInstVars
- "return a collection with instvariablenames modified by method (valid after parsing)"
+ "return a collection with instvariable names modified by method (valid after parsing)"
^ modifiedInstVars ? #()
@@ -10785,7 +11688,7 @@
!
modifiedPoolVars
- "return a collection with pool variable names modified by method (valid after parsing)"
+ "return a collection with poolvariable names modified by method (valid after parsing)"
^ modifiedPoolVars ? #()
@@ -10793,7 +11696,7 @@
!
readClassVars
- "return a collection with classvariablenames read by method (valid after parsing)"
+ "return a collection with classvariable names read by method (valid after parsing)"
^ readClassVars ? #()
@@ -10801,7 +11704,7 @@
!
readGlobals
- "return a collection with global varNames read by method (valid after parsing)"
+ "return a collection with global names read by method (valid after parsing)"
^ readGlobals ? #()
@@ -10809,7 +11712,7 @@
!
readInstVars
- "return a collection with instvariablenames read by method (valid after parsing)"
+ "return a collection with instvariable names read by method (valid after parsing)"
^ readInstVars ? #()
@@ -10817,7 +11720,7 @@
!
readPoolVars
- "return a collection with pool var names read by method (valid after parsing)"
+ "return a collection with poolvariable names read by method (valid after parsing)"
^ readPoolVars ? #()
@@ -10831,7 +11734,7 @@
!
usedClassVars
- "return a collection with classvariablenames refd by method (valid after parsing)"
+ "return a collection with classvariable names refd by method (valid after parsing)"
^ usedClassVars ? #()
@@ -10839,7 +11742,7 @@
!
usedGlobals
- "return a collection with globalnames refd by method (valid after parsing)"
+ "return a collection with global names refd by method (valid after parsing)"
^ usedGlobals ? #()
@@ -10847,7 +11750,7 @@
!
usedInstVars
- "return a collection with instvariablenames refd by method (valid after parsing)"
+ "return a collection with instvariable names refd by method (valid after parsing)"
^ usedInstVars ? #()
@@ -10855,7 +11758,7 @@
!
usedPoolVars
- "return a collection with pool variable names refd by method (valid after parsing)"
+ "return a collection with poolvariable names refd by method (valid after parsing)"
^ usedPoolVars ? #()
@@ -10869,7 +11772,7 @@
!
usedVars
- "return a collection with variablenames refd by method (valid after parsing)"
+ "return a collection with variable names refd by method (valid after parsing)"
^ usedVars ? #()
@@ -10915,7 +11818,7 @@
hasPrimitiveCode := hasNonOptionalPrimitiveCode := false.
usesSuper := false.
parseForCode := false.
- allowUndeclaredVariables := true.
+ allowUndeclaredVariables := false.
foldConstants := FoldConstants.
parenthesisLevel := 0.
@@ -10940,6 +11843,9 @@
"set the class to be used for parsing/evaluating"
classToCompileFor := aClass.
+ classToCompileFor isBehavior ifFalse:[
+ classToCompileFor := nil
+ ].
(classToCompileFor ~~ PrevClass) ifTrue:[
PrevClass notNil ifTrue:[
Parser update:PrevClass
@@ -10957,12 +11863,7 @@
"set the value to be used for self while evaluating"
selfValue := anObject.
- classToCompileFor := anObject class.
- (classToCompileFor ~~ PrevClass) ifTrue:[
- PrevClass notNil ifTrue:[
- Parser update:PrevClass
- ]
- ]
+ self setClassToCompileFor:(anObject class).
!
stringsAreImmutable
@@ -11147,7 +12048,7 @@
|sel|
self isSyntaxHighlighter ifTrue:[
- sel := selectorArg asSymbolIfInterned ? selectorArg.
+ sel := selectorArg asSymbolIfInternedOrSelf.
] ifFalse:[
"/ cg: thought this was a good idea;
"/ but currently breaks changesBrowser.
@@ -11475,7 +12376,7 @@
!Parser::Correction class methodsFor:'queries'!
buttonLabel
- self subclassResponsibility
+ ^ 'Correct'
! !
!Parser::Correction methodsFor:'accessing'!
@@ -11498,15 +12399,27 @@
!Parser::Correction methodsFor:'ignored accessing'!
positionOfPeriod:ignored
+ "/ intentionally ignore here
+!
+
+positionToInsert:charPosition
+ "/ intentionally ignore here
+
!
receiverClass:ignoredClass
+ "/ intentionally ignore here
+
!
receiverNode:ignoredNode
+ "/ intentionally ignore here
+
!
selector:ignoredSelector
+ "/ intentionally ignore here
+
! !
!Parser::Correction methodsFor:'instance creation'!
@@ -11585,18 +12498,18 @@
"an method needs to be defined"
|classToGenerateCode suggestedClassToCompileFor privateClass
- className varName codeGeneratorClass codeGenerator|
+ className varName codeGeneratorClass codeGenerator classToCompileFor|
"/ todo: look for variables first and ask if setter/getter first,
"/ so we can reduce the set of offered classes. Left as an excercise...
- suggestedClassToCompileFor := aCompiler classToCompileFor.
+ suggestedClassToCompileFor := classToCompileFor := aCompiler classToCompileFor.
receiverNode isSelf ifTrue:[
- classToGenerateCode := aCompiler classToCompileFor
+ classToGenerateCode := classToCompileFor
] ifFalse:[
receiverNode isSuper ifTrue:[
- classToGenerateCode := aCompiler classToCompileFor superclass
+ classToGenerateCode := classToCompileFor superclass
] ifFalse:[
receiverNode isVariable ifTrue:[
receiverNode name isUppercaseFirst ifTrue:[
@@ -11608,7 +12521,7 @@
classToGenerateCode := nil
].
] ifFalse:[
- (privateClass := aCompiler classToCompileFor privateClassesAt:receiverNode name) notNil ifTrue:[
+ (privateClass := classToCompileFor privateClassesAt:receiverNode name) notNil ifTrue:[
classToGenerateCode := privateClass theMetaclass.
].
]
@@ -11617,7 +12530,7 @@
(receiverNode isMessage
and:[ receiverNode receiver isSelf
and:[ receiverNode selector == #class]]) ifTrue:[
- suggestedClassToCompileFor := aCompiler classToCompileFor theMetaclass
+ suggestedClassToCompileFor := classToCompileFor theMetaclass
].
]
]
@@ -11663,27 +12576,24 @@
lcVarNames := varNames collect:[:nm | nm asLowercaseFirst].
(selector isKeywordSelector
- and:[selector numArgs == 1
+ and:[selector argumentCount == 1
and:[lcVarNames includes:(selector copyButLast:1)]]) ifTrue:[
"/ want a setter ?
varName := varNames at:(lcVarNames indexOf:(selector copyButLast:1)).
- wantSetter := Dialog confirmWithCancel:('Generate as setter for %1 ?' bindWith:varName allBold) default:true.
- wantSetter isNil ifTrue:[ AbortOperationRequest raise. "^ selector"].
+ wantSetter := Dialog confirmWithRaiseAbortOnCancel:('Generate as setter for %1 ?' bindWith:varName allBold).
] ifFalse:[
(selector isUnarySelector
and:[lcVarNames includes:selector]) ifTrue:[
"/ want a getter ?
varName := varNames at:(lcVarNames indexOf:selector).
- wantGetter := Dialog confirmWithCancel:('Generate as getter for %1 ?' bindWith:varName allBold) default:true.
- wantGetter isNil ifTrue:[AbortOperationRequest raise "^ selector"].
+ wantGetter := Dialog confirmWithRaiseAbortOnCancel:('Generate as getter for %1 ?' bindWith:varName allBold).
] ifFalse:[
(selector isKeywordSelector
and:[ selector numArgs == 1
and:[ classToGenerateCode isMeta
and:[ classToGenerateCode theNonMetaclass instVarNames includes:(varName := selector copyButLast:1) ]]]
) ifTrue:[
- wantInstCreator := Dialog confirmWithCancel:('Generate as initialized instance creator for %1?' bindWith:varName).
- wantInstCreator isNil ifTrue:[AbortOperationRequest raise "^ selector"].
+ wantInstCreator := Dialog confirmWithRaiseAbortOnCancel:('Generate as initialized instance creator for %1?' bindWith:varName).
].
].
].
@@ -11708,6 +12618,8 @@
"/ return nil, so nothing is done in the compiler
^ nil
+
+ "Modified: / 15-02-2019 / 10:10:33 / Claus Gittinger"
! !
!Parser::CorrectByGroupingMessage methodsFor:'accessing'!
@@ -11766,6 +12678,58 @@
^ newSource
! !
+!Parser::CorrectByInserting methodsFor:'accessing'!
+
+positionToInsert:charPosition
+ positionToInsert := charPosition.
+
+!
+
+positionToInsert:charPosition whatToInsert:whatToInsertArg
+ self positionToInsert:charPosition.
+ whatToInsert := whatToInsertArg.
+!
+
+whatToInsert
+ ^ whatToInsert
+! !
+
+!Parser::CorrectByInserting methodsFor:'fixing'!
+
+fixFrom:pos1 to:pos2 for:aCompiler
+ "whatToInsert needs to be inserted AFTER positionToInsert"
+
+ |source newSource|
+
+ source := aCompiler currentSource.
+ newSource := source copyWithAll:self whatToInsert insertedAfterIndex:positionToInsert.
+ ^ newSource
+! !
+
+!Parser::CorrectByInserting methodsFor:'queries'!
+
+buttonLabel
+ ^ 'Insert "',self whatToInsert,'"'.
+! !
+
+!Parser::CorrectByInsertingColon class methodsFor:'queries'!
+
+buttonLabel
+ ^ 'Insert ":"'
+! !
+
+!Parser::CorrectByInsertingColon methodsFor:'accessing'!
+
+positionToInsert:charPosition
+ "because the FIX inserts AFTER positionToInsert"
+
+ positionToInsert := charPosition-1.
+!
+
+whatToInsert
+ ^ ':'.
+! !
+
!Parser::CorrectByInsertingPeriod class methodsFor:'queries'!
buttonLabel
@@ -11774,20 +12738,12 @@
!Parser::CorrectByInsertingPeriod methodsFor:'accessing'!
-positionOfPeriod:something
- positionOfPeriod := something.
-! !
-
-!Parser::CorrectByInsertingPeriod methodsFor:'fixing'!
-
-fixFrom:pos1 to:pos2 for:aCompiler
- "a period (full stop) needs to be inserted"
-
- |source newSource|
-
- source := aCompiler currentSource.
- newSource := source copyWithAll:'.' insertedAfterIndex:positionOfPeriod.
- ^ newSource
+positionOfPeriod:charPos
+ positionToInsert := charPos.
+!
+
+whatToInsert
+ ^ '.'.
! !
!Parser::CorrectByInteractiveCorrection class methodsFor:'documentation'!
@@ -12480,12 +13436,16 @@
aStream reset.
CParser isNil ifTrue:[
- self generateTrapCodeForUnavailableCParser.
- ^ nil.
+ "/ try to load
+ Smalltalk loadPackage:'exept:ctypes'.
+ CParser isNil ifTrue:[
+ self generateTrapCodeForUnavailableCParser.
+ ^ nil.
+ ].
].
cParser := CParser new.
- cParser knownDefinitions:dictionaryOfTypesOrNil.
+ dictionaryOfTypesOrNil notNil ifTrue:[ cParser addDefinitions:dictionaryOfTypesOrNil ].
cParser allowRedefinitions:true.
cParser source:aStream scannerClass:CDeclScanner.
cParser nextToken.
@@ -12532,6 +13492,7 @@
"Created: / 01-08-2006 / 16:18:05 / cg"
"Modified: / 07-06-2007 / 13:14:06 / cg"
+ "Modified: / 04-03-2019 / 10:34:11 / Claus Gittinger"
! !
!Parser::PrimitiveSpecParser methodsFor:'parsing-primitives & pragmas'!
@@ -12592,13 +13553,17 @@
(cls isSubclassOf:ExternalStructure) ifTrue:[
^ #pointer
].
+ (cls = ExternalStructure) ifTrue:[
+ ^ #pointer
+ ].
].
(aTypeSymbol endsWith:'Pointer') ifTrue:[
^ 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"
@@ -12635,6 +13600,7 @@
(sword int16 )
(handle voidPointer )
(lpstr charPointer )
+ (lpwstr wcharPointer )
(hresult hresult ) "/ preserved !!
(ulongReturn ulongReturn )
(none void )
@@ -12643,11 +13609,15 @@
(structOut voidPointer )
(Win32Handle voidPointer )
+ (INT int32 )
+ (UINT uint32 )
+ (BYTE uint8 )
(DWORD uint32 )
(SDWORD int32 )
(WORD uint16 )
(SWORD int16 )
(LPSTR charPointer )
+ (LPWSTR wcharPointer )
(HANDLE voidPointer )
(HRESULT hresult )
(CALLBACK voidFunctionPointer )
--- a/ParserFlags.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ParserFlags.st Tue Aug 25 12:20:06 2020 +0100
@@ -30,12 +30,12 @@
warnAboutReferenceToPrivateClass warnAboutShortLocalVariableNames
warnAboutPossiblyUnimplementedSelectors
warnAboutUnknownCharacterEscapesInJavaScriptStringConstant
- warnPlausibilityChecks allowLiteralNameSpaceSymbols
- allowUnderscoreInIdentifier allowDollarInIdentifier
- allowParagraphInIdentifier allowOldStyleAssignment
- allowSqueakExtensions allowDolphinExtensions
- allowExtendedBinarySelectors allowQualifiedNames
- allowFunctionCallSyntaxForBlockEvaluation
+ warnPlausibilityChecks warnAboutDeadCodeAndFixMe
+ allowLiteralNameSpaceSymbols allowUnderscoreInIdentifier
+ allowDollarInIdentifier allowParagraphInIdentifier
+ allowOldStyleAssignment allowSqueakExtensions
+ allowDolphinExtensions allowExtendedBinarySelectors
+ allowQualifiedNames allowFunctionCallSyntaxForBlockEvaluation
allowLocalVariableDeclarationWithInitializerExpression
allowDomainVariables allowArrayIndexSyntaxExtension
allowReservedWordsAsSelectors allowVariableReferences
@@ -60,7 +60,11 @@
allowSTXExtendedArrayLiterals warnAssignmentToBlockArgument
warnAssignmentToMethodArgument warnAssignmentToPoolVariable
allowSignedByteArrayElements allowSymbolsStartingWithDigit
- allowJavaScriptConst'
+ allowJavaScriptConst allowPeriodAsNameSpaceSeparator
+ allowCStrings warnAboutPossiblyUninitializedLocals allowEStrings
+ singlePrecisionFloatF allowRStrings
+ allowGreekCharactersInIdentifier allowCIntegers
+ allowInlineObjects allowSTXExtensions allowIStrings'
classVariableNames:'AllowArrayIndexSyntaxExtension AllowAssignmentToBlockArgument
AllowAssignmentToMethodArgument AllowAssignmentToPoolVariable
AllowCaretAsBinop AllowCharacterEscapes AllowDollarInIdentifier
@@ -104,9 +108,15 @@
WarnParagraphInIdentifier WarnPlausibilityChecks
WarnPossibleIncompatibilities WarnST80Directives WarnSTXSpecials
WarnUndeclared WarnUnderscoreInIdentifier WarnUnusedVars Warnings
+ WarnAboutDeadCodeAndFixMe WarnAboutInlineObjects
AutoDefineVariables AllowSignedByteArrayElements
AllowSymbolsStartingWithDigit AllowJavaScriptConst
- AllowJavaScriptLet'
+ AllowJavaScriptLet AllowPeriodAsNameSpaceSeparator AllowCStrings
+ WarnAboutPossiblyUninitializedLocals AllowEStrings
+ SinglePrecisionFloatF AllowRStrings
+ AllowGreekCharactersInIdentifier WarnAboutPossibleNameClashes
+ AllowCIntegers AllowInlineObjects AllowSTXExtensions
+ AllowIStrings'
poolDictionaries:''
category:'System-Compiler'
!
@@ -145,6 +155,89 @@
for stx debugging:
STCKeepCIntermediate := true
+ the flags control:
+ Warnings -- enable/disable any warnings from the compiler
+ WarnUndeclared -- warn about undeclared variables
+ WarnUnusedVars -- warn about unused variables
+ WarnST80Directives -- warn when ST80 (visualworks) directives (primitives) are used
+ WarnAboutWrongVariableNames -- conventions / style
+ WarnAboutVariableNameConventions
+ WarnAboutNonLowercaseLocalVariableNames
+ WarnAboutShortLocalVariableNames
+ WarnAboutBadComments
+ WarnCommonMistakes
+ WarnAboutReferenceToPrivateClass
+ WarnPossibleIncompatibilities
+ WarnSTXSpecials -- warn when special ST/X syntax extensions are used
+ WarnUnderscoreInIdentifier -- underscores in identifier (not all Smalltalk dialects support this)
+ WarnDollarInIdentifier -- dollar in identifier (not all Smalltalk dialects support this)
+ WarnParagraphInIdentifier -- paragraph character in identifier
+ WarnOldStyleAssignment -- assignment with _ - character
+ WarnHiddenVariables -- locals shadowing outer/instvars
+ WarnInconsistentReturnValues -- boolean/non-boolean return values
+ WarnAboutPeriodInSymbol
+ WarnAboutPossibleSTCCompilationProblems
+ WarnAboutUnknownCharacterEscapesInJavaScriptStringConstant
+ WarnAssignmentToBlockArgument
+ WarnAssignmentToMethodArgument
+ WarnAssignmentToPoolVariable
+ WarnPlausibilityChecks
+ WarnAboutPossiblyUnimplementedSelectors
+
+ AllowReservedWordsAsSelectors
+ AllowUnderscoreInIdentifier
+ AllowParagraphInIdentifier
+ AllowDollarInIdentifier -- st80-vms dollars in identifiers
+ AllowOldStyleAssignment -- st80 underscore as assignment
+ AllowDolphinExtensions -- dolphin computed literal
+ AllowQualifiedNames -- vw3 qualified names
+ AllowExtendedBinarySelectors -- vw5.4 extended binary selectors (plus/minus, center-dot etc.)
+ AllowCaretAsBinop -- too dangerous
+ AllowLiteralNameSpaceSymbols -- st/x literal nameSpace-symbols (#foo::bar)
+ AllowArrayIndexSyntaxExtension
+ AllowFunctionCallSyntaxForBlockEvaluation
+ AllowLocalVariableDeclarationWithInitializerExpression
+ AllowDomainVariables
+ AllowArrayIndexSyntaxExtension
+ AllowReservedWordsAsSelectors
+ AllowVariableReferences
+ AllowLazyValueExtension
+ AllowFixedPointLiterals
+ AllowExtendedSTXSyntax
+ AllowVisualAgeESSymbolLiterals
+ AllowExtensionsToPrivateClasses
+ AllowVisualAgePrimitives
+ AllowSqueakExtensions -- squeak computed array
+ AllowSqueakPrimitives
+ AllowSTVPrimitives -- number-sign syntax
+ AllowSTVExtensions
+ AllowNationalCharactersInIdentifier
+ AllowHashAsBinarySelector
+ AllowSTXEOLComments -- DQuote/ EOL comments
+ AllowSTXDelimiterComments -- DQuote<<END delimiter comments
+ AllowVisualWorksMethodAnnotations
+ AllowPossibleSTCCompilationProblems -- must be true, to allow fileIn
+ AllowEmptyStatements
+ AllowPeriodInSymbol
+ AllowPeriodAsNameSpaceSeparator
+
+ AllowCStrings -- c'....' is a string with C-escapes
+ AllowUnicodeStrings
+ AllowUnicodeCharacters
+ AllowCharacterEscapes
+ AllowStringEscapes
+ AllowAssignmentToBlockArgument
+ AllowAssignmentToMethodArgument
+ AllowAssignmentToPoolVariable
+ AllowSignedByteArrayElements
+ AllowSymbolsStartingWithDigit
+
+ AllowJavaScriptConst
+
+ ArraysAreImmutable -- still care for ST-80 compatibility
+ StringsAreImmutable -- still care for ST-80 compatibility
+ ImplicitSelfSends
+
"
! !
@@ -239,6 +332,34 @@
"Created: / 26-09-2012 / 13:27:54 / cg"
!
+singlePrecisionFloatF
+ "by default, the 'f'-character in a float literal will generate
+ double-precision Float literals.
+ With allowSinglePrecisionFloats, it will generate single precision ShortFloat literals.
+ The default is false.
+ Notice, that there is some confusion among Smalltalk systems, whether a float has
+ single or double precision (VW vs. V'age).
+ In ST/X, floats have double-precision by default."
+
+ ^ SinglePrecisionFloatF
+
+ "Created: / 26-05-2019 / 11:32:38 / Claus Gittinger"
+!
+
+singlePrecisionFloatF:aBoolean
+ "by default, the 'f'-character in a float literal will generate
+ double-precision Float literals.
+ With allowSinglePrecisionFloats, it will generate single precision ShortFloat literals.
+ The default is false.
+ Notice, that there is some confusion among Smalltalk systems, whether a float has
+ single or double precision (VW vs. V'age).
+ In ST/X, floats have double-precision by default."
+
+ SinglePrecisionFloatF := aBoolean
+
+ "Created: / 26-05-2019 / 11:32:29 / Claus Gittinger"
+!
+
stringsAreImmutable
"return true if strings are immutable literals"
@@ -341,7 +462,7 @@
!
ccPath
- ^ CCPath
+ ^ CCPath ? 'cc'
!
ccPath:aSymbol
@@ -377,7 +498,7 @@
!
linkCommand
- ^ LinkCommand
+ ^ LinkCommand ? self ccPath
!
linkCommand:aString
@@ -631,12 +752,8 @@
"return the define to be used for the compiler toolchain.
By default, the toolchain with which stx itself was compiled is used (getCCDefine);
can be overwritten by setting ForcedCompiler"
-
- |dfn|
-
- dfn := ForcedCompiler.
- dfn isNil ifTrue:[ dfn := STCCompilerInterface getCCDefine].
- ^ dfn
+
+ ^ ForcedCompiler ? STCCompilerInterface getCCDefine.
"
ForcedCompiler := DefineForCLANG.
@@ -645,8 +762,9 @@
ForcedCompiler := nil.
self usedCompilerDefine.
"
-
+
"Created: / 20-07-2012 / 13:11:22 / cg"
+ "Modified: / 11-05-2018 / 09:44:34 / stefan"
!
vcTop:aPath
@@ -670,7 +788,7 @@
!ParserFlags class methodsFor:'accessing-syntax-control'!
allowArrayIndexSyntaxExtension
- "experimental"
+ "experimental syntax: var[idx-expr]"
^ AllowArrayIndexSyntaxExtension ? false
@@ -679,10 +797,12 @@
self allowArrayIndexSyntaxExtension:false
self allowArrayIndexSyntaxExtension
"
+
+ "Modified (comment): / 23-09-2018 / 00:42:11 / Claus Gittinger"
!
allowArrayIndexSyntaxExtension:aBoolean
- "experimental"
+ "experimental syntax: var[idx-expr]"
AllowArrayIndexSyntaxExtension := aBoolean.
@@ -690,6 +810,8 @@
self allowArrayIndexSyntaxExtension:true
self allowArrayIndexSyntaxExtension:false
"
+
+ "Modified (comment): / 23-09-2018 / 00:42:15 / Claus Gittinger"
!
allowAssignmentToBlockArgument
@@ -728,15 +850,81 @@
"Created: / 08-09-2011 / 14:50:48 / cg"
!
+allowCIntegers
+ "allow c-style integers of the form: 0xHHH, 0bBBB and 0oOOO"
+
+ ^ AllowCIntegers
+!
+
+allowCIntegers:aBoolean
+ "allow c-style integers of the form: 0xHHH, 0bBBB and 0oOOO"
+
+ AllowCIntegers := aBoolean
+
+ "
+ ParserFlags allowCIntegers:true
+ ParserFlags allowCIntegers
+ "
+!
+
+allowCStrings
+ "allow c-style strings of the form:
+ c'...' containing c-language character escapes"
+
+ ^ AllowCStrings
+
+ "
+ self allowCStrings
+ "
+
+ "Created: / 08-02-2019 / 18:42:15 / Claus Gittinger"
+ "Modified (comment): / 23-05-2019 / 08:57:46 / Claus Gittinger"
+!
+
+allowCStrings:aBoolean
+ "allow c-style strings of the form:
+ c'...' containing c-language character escapes"
+
+ AllowCStrings := aBoolean.
+
+ "
+ ParserFlags allowCStrings:true
+ ParserFlags allowCStrings
+ "
+
+ "Created: / 08-02-2019 / 18:42:30 / Claus Gittinger"
+ "Modified (comment): / 23-05-2019 / 08:57:50 / Claus Gittinger"
+!
+
+allowCaretAsBinop
+ "allow '^' to be used as a binary operator"
+
+ ^ AllowCaretAsBinop
+
+ "Created: / 08-02-2019 / 18:49:12 / Claus Gittinger"
+ "Modified (comment): / 23-05-2019 / 08:58:11 / Claus Gittinger"
+!
+
+allowCaretAsBinop:aBoolean
+ "allow '^' to be used as a binary operator"
+
+ AllowCaretAsBinop := aBoolean
+
+ "Created: / 08-02-2019 / 18:49:21 / Claus Gittinger"
+ "Modified (comment): / 23-05-2019 / 08:58:14 / Claus Gittinger"
+!
+
allowDollarInIdentifier
"return true, if $-characters are allowed in identifiers.
Notice, that dollars are NEVER allowed as the first character in an identifier
- (because they are interpreted as character-constant then)."
+ (because they are interpreted as character-constant then).
+ Dollars in identifiers were used in VMS versions of VW-Smalltalk"
^ AllowDollarInIdentifier
"Created: / 07-09-1997 / 01:32:18 / cg"
"Modified (comment): / 16-11-2016 / 22:25:59 / cg"
+ "Modified (comment): / 23-05-2019 / 08:59:03 / Claus Gittinger"
!
allowDollarInIdentifier:aBoolean
@@ -749,12 +937,14 @@
If you have to fileIn old VW-Vsn2.x classes, turn this off
before filing them in; i.e.:
Compiler allowDollarInIdentifiers:false
+ Dollars in identifiers were used in VMS versions of VW-Smalltalk.
"
AllowDollarInIdentifier := aBoolean.
"Created: / 07-09-1997 / 01:34:49 / cg"
"Modified (comment): / 16-11-2016 / 22:26:38 / cg"
+ "Modified (comment): / 23-05-2019 / 09:00:00 / Claus Gittinger"
!
allowDolphinExtensions
@@ -776,6 +966,30 @@
"
!
+allowEStrings
+ "allow extended strings with embedded expressions of the form:
+ e'...' containing c-language character escapes
+ and embedded expressions {expr} which are sliced in"
+
+ ^ AllowEStrings
+
+ "
+ self allowEStrings
+ "
+
+ "Created: / 23-05-2019 / 10:28:17 / Claus Gittinger"
+!
+
+allowEStrings:aBoolean
+ "allow extended strings with embedded expressions of the form:
+ e'...' containing c-language character escapes
+ and embedded expressions {expr} which are sliced in"
+
+ AllowEStrings := aBoolean
+
+ "Created: / 23-05-2019 / 10:28:29 / Claus Gittinger"
+!
+
allowEmptyStatements
"return true, if empty statements are allowed (two .'s in a row).
Notice, that stc cannot (yet) handle those."
@@ -797,7 +1011,7 @@
allowExtendedBinarySelectors
"experimental extended selectors extensions"
- ^ AllowExtendedBinarySelectors
+ ^ AllowExtendedBinarySelectors ? false
"
ParserFlags allowExtendedBinarySelectors
@@ -807,19 +1021,25 @@
!
allowExtendedBinarySelectors:aBoolean
- "experimental syntay extensions"
+ "experimental syntax extensions"
AllowExtendedBinarySelectors := aBoolean
+
+ "Modified (comment): / 23-05-2019 / 10:40:47 / Claus Gittinger"
!
allowExtendedSTXSyntax
- "experimental syntay extensions"
+ "Enables ALL of the ST/X extensions.
+ Do not use for now, as stc does not support all of them"
^ AllowExtendedSTXSyntax
+
+ "Modified (comment): / 23-05-2019 / 10:41:53 / Claus Gittinger"
!
allowExtendedSTXSyntax:aBoolean
- "experimental syntay extensions"
+ "Enables ALL of the ST/X extensions.
+ Do not use for now, as stc does not support all of them"
AllowExtendedSTXSyntax := aBoolean
@@ -829,18 +1049,26 @@
'a\u1616b' inspect.
self allowExtendedSTXSyntax:false
"
+
+ "Modified (comment): / 23-05-2019 / 10:41:57 / Claus Gittinger"
!
allowFixedPointLiterals
- "return true, if nnnsn (FixedPoint) literals are allowed"
-
- ^ AllowFixedPointLiterals
+ "return true, if nnnsn (FixedPoint / ScaledDecimal) literals are allowed.
+ The default is true."
+
+ ^ AllowFixedPointLiterals ? true
+
+ "Modified (comment): / 23-05-2019 / 09:00:40 / Claus Gittinger"
!
allowFixedPointLiterals:aBoolean
- "enable/disable, if nnnsn (FixedPoint) literals are allowed"
+ "enable/disable, if nnnsn (FixedPoint) literals are allowed.
+ The default is true."
AllowFixedPointLiterals := aBoolean
+
+ "Modified (comment): / 23-05-2019 / 09:00:44 / Claus Gittinger"
!
allowFunctionCallSyntaxForBlockEvaluation
@@ -859,17 +1087,87 @@
AllowFunctionCallSyntaxForBlockEvaluation := aBoolean.
!
+allowGreekCharactersInIdentifier
+ "return true, if greek characters (alpha, beta etc.) are allowed in identifiers"
+
+ ^ AllowGreekCharactersInIdentifier
+
+ "Created: / 08-06-2019 / 14:52:29 / Claus Gittinger"
+!
+
+allowGreekCharactersInIdentifier:aBoolean
+ "are greek characters (alpha, beta etc.) are allowed in identifiers.
+ Use this ONLY to file in some non-ANSI ST code"
+
+ AllowGreekCharactersInIdentifier := aBoolean
+
+ "Created: / 08-06-2019 / 14:54:04 / Claus Gittinger"
+!
+
allowHashAsBinarySelector
+ "if true, a free-standing single '#' is allowed as a binary selector.
+ The default is true."
+
^ AllowHashAsBinarySelector
+
+ "Modified (comment): / 23-05-2019 / 09:01:57 / Claus Gittinger"
!
allowHashAsBinarySelector:aBoolean
+ "if true, a free-standing single '#' is allowed as a binary selector.
+ The default is true."
+
AllowHashAsBinarySelector := aBoolean
"
self allowHashAsBinarySelector:true
self allowHashAsBinarySelector:false
+ 123 # 234
"
+
+ "Modified (comment): / 23-05-2019 / 09:01:54 / Claus Gittinger"
+!
+
+allowIStrings
+ "allow i-style strings of the form:
+ i'...' containing c-language character escapes
+ and embedded expressions {expr} which are sliced in
+ and to be xlated (internationalization)"
+
+ ^ AllowIStrings
+
+ "
+ self allowIStrings
+ "
+!
+
+allowIStrings:aBoolean
+ "allow i-style strings of the form:
+ i'...' containing c-language character escapes
+ and embedded expressions {expr} which are sliced in
+ and to be xlated (internationalization)"
+
+ AllowIStrings := true
+
+ "
+ self allowIStrings:true
+ "
+!
+
+allowInlineObjects
+ "return true, if inline objects are allowed"
+
+ ^ AllowInlineObjects
+
+ "Created: / 08-08-2017 / 23:48:48 / cg"
+!
+
+allowInlineObjects:aBoolean
+ "if true, inline objects are allowed"
+
+ AllowInlineObjects := aBoolean
+
+ "Created: / 08-08-2017 / 23:48:48 / cg"
!
allowJavaScriptConst
@@ -888,28 +1186,72 @@
"Created: / 08-08-2017 / 23:49:07 / cg"
!
+allowLazyValueExtension
+ "allow !![...] to generate a lazy value"
+
+ ^ AllowLazyValueExtension
+
+ "Created: / 03-06-2019 / 10:57:42 / Claus Gittinger"
+!
+
+allowLazyValueExtension:aBoolean
+ "allow !![...] to generate a lazy value"
+
+ AllowLazyValueExtension := aBoolean
+
+ "Created: / 03-06-2019 / 10:57:50 / Claus Gittinger"
+!
+
allowLiteralNameSpaceSymbols
"return true, if literal nameSpace symbols are allowed (#foo::bar) are allowed"
^ AllowLiteralNameSpaceSymbols
+
+ "
+ #foo - ok
+ #foo::bar - ok
+ #foo.bar - not allowed
+ "
+
+ "Modified (comment): / 23-05-2019 / 09:03:47 / Claus Gittinger"
!
allowLiteralNameSpaceSymbols:aBoolean
"controls, if literal nameSpace symbols are allowed (#foo::bar) are allowed"
AllowLiteralNameSpaceSymbols := aBoolean
+
+ "
+ #foo - ok
+ #foo::bar - ok
+ #foo.bar - not allowed
+ "
+
+ "Modified (comment): / 23-05-2019 / 09:03:43 / Claus Gittinger"
!
allowLocalVariableDeclarationWithInitializerExpression
- "experimental"
+ "experimental: | var := expr |"
^ AllowLocalVariableDeclarationWithInitializerExpression
+
+ "
+ self allowLocalVariableDeclarationWithInitializerExpression:true
+ self allowLocalVariableDeclarationWithInitializerExpression:false
+
+ |a := 0 . b := 1 |
+ Transcript showCR:'a is',a,' b is ',b
+ "
+
+ "Modified (comment): / 23-05-2019 / 09:07:42 / Claus Gittinger"
!
allowLocalVariableDeclarationWithInitializerExpression:aBoolean
- "experimental"
+ "experimental: | var := expr |"
AllowLocalVariableDeclarationWithInitializerExpression := aBoolean.
+
+ "Modified (comment): / 23-09-2018 / 00:44:04 / Claus Gittinger"
!
allowNationalCharactersInIdentifier
@@ -981,9 +1323,11 @@
!
allowQualifiedNames
- "return true, if #{..} qualified names are allowed"
+ "return true, if '#{..}' and 'namespace.varName' qualified names are allowed"
^ AllowQualifiedNames
+
+ "Modified (comment): / 23-09-2018 / 01:08:29 / Claus Gittinger"
!
allowQualifiedNames:aBoolean
@@ -1002,15 +1346,37 @@
"
!
+allowRStrings
+ "rstrings have the syntax:
+ r'...'
+ which generates a regex"
+
+ ^ AllowRStrings
+
+ "Created: / 03-06-2019 / 11:12:11 / Claus Gittinger"
+!
+
+allowRStrings:aBoolean
+ "rstrings have the syntax:
+ r'...'
+ which generates a regex"
+
+ AllowRStrings := aBoolean
+
+ "Created: / 03-06-2019 / 11:12:37 / Claus Gittinger"
+!
+
allowReservedWordsAsSelectors
- "return true, if self, super, thisContext, nil, true and false are to be allowed
+ "if true, 'self', 'super', 'thisContext', 'nil', 'true' and 'false' are allowed
as unary message selectors."
^ AllowReservedWordsAsSelectors ? false
+
+ "Modified (format): / 25-06-2019 / 11:17:15 / Claus Gittinger"
!
allowReservedWordsAsSelectors:aBoolean
- "enable/disable, if self, super, thisContext, nil, true and false are to be allowed
+ "enable/disable, if 'self', 'super', 'thisContext', 'nil', 'true' and 'false' are to be allowed
as unary message selectors."
AllowReservedWordsAsSelectors := aBoolean.
@@ -1019,6 +1385,8 @@
self allowReservedWordsAsSelectors:true
self allowReservedWordsAsSelectors:false
"
+
+ "Modified (comment): / 25-06-2019 / 11:18:13 / Claus Gittinger"
!
allowSTVExtensions
@@ -1129,6 +1497,20 @@
"
!
+allowSTXExtensions
+ "if false, support for ST/X extensions is generally disabled.
+ if true, individual control flags may apply"
+
+ ^ AllowSTXExtensions
+!
+
+allowSTXExtensions:aBoolean
+ "if false, support for ST/X extensions is generally disabled.
+ if true, individual control flags may apply"
+
+ AllowSTXExtensions := aBoolean
+!
+
allowSignedByteArrayElements
"return true, if byteArray elements are allowed to be negative."
@@ -1320,6 +1702,32 @@
WarnAboutBadComments := aBoolean
!
+warnAboutDeadCodeAndFixMe
+ "controls generation of warning messages about useless symbol references
+ #fixme / #todo in the code"
+
+ ^ WarnAboutDeadCodeAndFixMe
+!
+
+warnAboutDeadCodeAndFixMe:aBoolean
+ "controls generation of warning messages about useless symbol references
+ #fixme / #todo in the code"
+
+ WarnAboutDeadCodeAndFixMe := aBoolean
+!
+
+warnAboutInlineObjects
+ "return true, if compiler should warn about this ST/X extension"
+
+ ^ WarnAboutInlineObjects
+!
+
+warnAboutInlineObjects:aBoolean
+ "controls, if compiler should warn about this ST/X extension"
+
+ WarnAboutInlineObjects := aBoolean.
+!
+
warnAboutNonLowercaseLocalVariableNames
"controls generation of warning messages about wrong variable names"
@@ -1340,6 +1748,18 @@
WarnAboutPeriodInSymbol := aBoolean
!
+warnAboutPossibleNameClashes
+ ^ WarnAboutPossibleNameClashes
+
+ "Created: / 16-11-2006 / 14:31:52 / cg"
+!
+
+warnAboutPossibleNameClashes:aBoolean
+ WarnAboutPossibleNameClashes := aBoolean
+
+ "Created: / 16-11-2006 / 14:31:57 / cg"
+!
+
warnAboutPossibleSTCCompilationProblems
^ WarnAboutPossibleSTCCompilationProblems
@@ -1360,6 +1780,18 @@
WarnAboutPossiblyUnimplementedSelectors := aBoolean
!
+warnAboutPossiblyUninitializedLocals
+ ^ WarnAboutPossiblyUninitializedLocals
+
+ "Created: / 23-04-2019 / 23:09:08 / Claus Gittinger"
+!
+
+warnAboutPossiblyUninitializedLocals:aBoolean
+ WarnAboutPossiblyUninitializedLocals := aBoolean
+
+ "Created: / 23-04-2019 / 23:09:20 / Claus Gittinger"
+!
+
warnAboutReferenceToPrivateClass
"controls generation of warning messages when a private class is referenced"
@@ -1651,6 +2083,8 @@
initialize
| executablePath topDirectory |
+ SinglePrecisionFloatF := false.
+
Warnings := true.
WarnUndeclared := true.
WarnUnusedVars := true.
@@ -1659,6 +2093,7 @@
WarnAboutWrongVariableNames := true.
WarnAboutVariableNameConventions := true.
WarnAboutBadComments := true.
+ WarnAboutPossiblyUninitializedLocals := true.
WarnUnderscoreInIdentifier := false.
WarnDollarInIdentifier := true.
WarnParagraphInIdentifier := true.
@@ -1670,6 +2105,7 @@
WarnAboutNonLowercaseLocalVariableNames := true.
WarnAboutShortLocalVariableNames := false.
WarnAboutPossibleSTCCompilationProblems := true.
+ WarnAboutPossibleNameClashes := true.
WarnAboutReferenceToPrivateClass := true.
WarnAboutPossiblyUnimplementedSelectors := true.
WarnAboutPeriodInSymbol := true.
@@ -1678,7 +2114,10 @@
WarnAssignmentToBlockArgument := true.
WarnAssignmentToMethodArgument := true.
WarnAssignmentToPoolVariable := true.
-
+ WarnAboutDeadCodeAndFixMe := true.
+ WarnAboutInlineObjects := true.
+
+ AllowSTXExtensions := true.
AllowReservedWordsAsSelectors := false.
AllowUnderscoreInIdentifier := true.
AllowParagraphInIdentifier := false.
@@ -1689,11 +2128,10 @@
AllowExtendedBinarySelectors := false. "/ vw5.4 extended binary selectors (plus/minus, center-dot etc.)
AllowCaretAsBinop := false. "/ too dangerous
AllowLiteralNameSpaceSymbols := true. "/ st/x literal nameSpace-symbols (#foo::bar)
- AllowArrayIndexSyntaxExtension := false.
+ AllowArrayIndexSyntaxExtension := true.
AllowFunctionCallSyntaxForBlockEvaluation := false.
AllowLocalVariableDeclarationWithInitializerExpression := false.
AllowDomainVariables := false.
- AllowArrayIndexSyntaxExtension := false.
AllowReservedWordsAsSelectors := true.
AllowVariableReferences := false.
AllowLazyValueExtension := false.
@@ -1707,6 +2145,7 @@
AllowSTVPrimitives := false. "/ number-sign syntax
AllowSTVExtensions := false.
AllowNationalCharactersInIdentifier := false.
+ AllowGreekCharactersInIdentifier := false.
AllowHashAsBinarySelector := true.
AllowSTXEOLComments := true.
AllowSTXDelimiterComments := true. "/ until stc and RBScanner support it also
@@ -1714,7 +2153,15 @@
AllowPossibleSTCCompilationProblems := true. "/ must be true, to allow fileIn!!
AllowEmptyStatements := false.
AllowPeriodInSymbol := false.
+ AllowPeriodAsNameSpaceSeparator := false.
+
"/ these are only used by the new compiler
+ AllowSTXExtendedArrayLiterals := true. "/ #u16(...)
+ AllowCIntegers := true. "/ 0xXXX, 0bBBB and 0oOOO syntax
+ AllowCStrings := true. "/ c'...' syntax (c-language escapes)
+ AllowEStrings := true. "/ e'...' syntax (embedded args strings)
+ AllowRStrings := true. "/ r'...' syntax (regex strings)
+ AllowIStrings := true. "/ i'...' syntax (international strings)
AllowUnicodeStrings := false.
AllowUnicodeCharacters := false.
AllowCharacterEscapes := false.
@@ -1725,6 +2172,7 @@
"/ AllowAssignmentToPoolVariable := true.
AllowSignedByteArrayElements := false.
AllowSymbolsStartingWithDigit := false.
+ AllowInlineObjects := false. "/ { keyword: value . ... } and #{ keyword: value ... }
AllowJavaScriptConst := true.
@@ -1742,7 +2190,11 @@
DefineForBorlandC := '__BORLANDC__'.
DefineForVisualC := '__VISUALC__'.
DefineForMSC := '__MSC__'.
- DefineForGNUC := '__GNUC__'.
+ "/ https://expeccoalm.exept.de/D252306
+ "/ must not redefine __GNUC__, because gcc defines this anyway with the gcc version
+ "/ contained in this macro (which is used by glibc includes).
+ "/ also defined in STCCompilerInterface class >> #getCCDefine
+ DefineForGNUC := 'STX__GNUC__'.
DefineForMINGW := '__MINGW__'.
DefineForMINGW32 := '__MINGW32__'.
DefineForMINGW64 := '__MINGW64__'.
@@ -1783,7 +2235,9 @@
"Modified: / 09-08-2006 / 18:47:18 / fm"
"Modified: / 08-08-2017 / 23:49:41 / cg"
- "Modified: / 06-01-2016 / 22:25:30 / jv"
+ "Modified: / 06-01-2016 / 22:25:30 / jv"
+ "Modified (comment): / 11-05-2018 / 10:12:29 / stefan"
+ "Modified: / 08-06-2019 / 14:53:27 / Claus Gittinger"
"Modified: / 22-05-2020 / 22:42:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
@@ -1960,7 +2414,11 @@
!
allowExtensionsToPrivateClasses:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowExtensionsToPrivateClasses := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:52:10 / Claus Gittinger"
!
allowPossibleSTCCompilationProblems
@@ -1970,9 +2428,12 @@
!
allowPossibleSTCCompilationProblems:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowPossibleSTCCompilationProblems := aBoolean
"Created: / 16-11-2006 / 14:24:56 / cg"
+ "Modified (comment): / 09-02-2019 / 15:53:08 / Claus Gittinger"
!
arraysAreImmutable
@@ -1987,6 +2448,36 @@
^ true
!
+singlePrecisionFloatF
+ "by default, the 'f'-character in a float literal will generate
+ double-precision Float literals.
+ With singlePrecisionFloats, it will generate single precision ShortFloat literals.
+ The default is false.
+ Notice, that there is some confusion among Smalltalk systems, whether a float has
+ single or double precision (VW vs. V'age).
+ In ST/X, floats have double-precision by default."
+
+ ^ singlePrecisionFloatF
+
+ "Created: / 26-05-2019 / 11:31:37 / Claus Gittinger"
+ "Modified (comment): / 08-06-2019 / 15:02:20 / Claus Gittinger"
+!
+
+singlePrecisionFloatF:aBoolean
+ "by default, the 'f'-character in a float literal will generate
+ double-precision Float literals.
+ With singlePrecisionFloats, it will generate single precision ShortFloat literals.
+ The default is false.
+ Notice, that there is some confusion among Smalltalk systems, whether a float has
+ single or double precision (VW vs. V'age).
+ In ST/X, floats have double-precision by default."
+
+ singlePrecisionFloatF := aBoolean
+
+ "Created: / 26-05-2019 / 11:32:11 / Claus Gittinger"
+ "Modified (comment): / 08-06-2019 / 15:02:14 / Claus Gittinger"
+!
+
stringsAreImmutable
^ stringsAreImmutable
!
@@ -2062,10 +2553,10 @@
!
linkCommand
- ^ linkCommand
+ ^ linkCommand ? self class linkCommand
"
- self linkCommand
+ self new linkCommand
"
"Modified (comment): / 17-11-2016 / 15:41:16 / cg"
@@ -2188,13 +2679,21 @@
!ParserFlags methodsFor:'accessing-syntax-control'!
allowArrayIndexSyntaxExtension
+ "experimental syntax: var[idx-expr]"
+
^ allowArrayIndexSyntaxExtension ? false
"Modified: / 08-08-2017 / 16:57:03 / cg"
+ "Modified (comment): / 08-06-2019 / 15:00:13 / Claus Gittinger"
!
allowArrayIndexSyntaxExtension:aBoolean
+ "experimental syntax: var[idx-expr]"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowArrayIndexSyntaxExtension := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:18 / Claus Gittinger"
!
allowAssignmentToBlockArgument
@@ -2202,7 +2701,11 @@
!
allowAssignmentToBlockArgument:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowAssignmentToBlockArgument := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:22 / Claus Gittinger"
!
allowAssignmentToMethodArgument
@@ -2210,7 +2713,11 @@
!
allowAssignmentToMethodArgument:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowAssignmentToMethodArgument := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:27 / Claus Gittinger"
!
allowAssignmentToPoolVariable
@@ -2218,7 +2725,49 @@
!
allowAssignmentToPoolVariable:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowAssignmentToPoolVariable := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:29 / Claus Gittinger"
+!
+
+allowCIntegers
+ "allow c-style integers of the form: 0xHHH, 0bBBB and 0oOOO"
+
+ ^ allowCIntegers ? false.
+!
+
+allowCIntegers:aBoolean
+ "allow c-style integers of the form: 0xHHH, 0bBBB and 0oOOO"
+
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowCIntegers := aBoolean
+!
+
+allowCStrings
+ "cstrings have the syntax:
+ c'...'
+ where inside the string, c-language escapes are recognized"
+
+ ^ allowCStrings ? false.
+
+ "Created: / 08-02-2019 / 18:28:33 / Claus Gittinger"
+ "Modified (comment): / 23-05-2019 / 10:26:31 / Claus Gittinger"
+!
+
+allowCStrings:aBoolean
+ "cstrings have the syntax:
+ c'...'
+ where inside the string, c-language escapes are recognized"
+
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowCStrings := aBoolean
+
+ "Created: / 08-02-2019 / 18:28:47 / Claus Gittinger"
+ "Modified (comment): / 23-05-2019 / 10:26:36 / Claus Gittinger"
!
allowCaretAsBinop
@@ -2226,7 +2775,11 @@
!
allowCaretAsBinop:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowCaretAsBinop := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:38 / Claus Gittinger"
!
allowCharacterEscapes
@@ -2234,7 +2787,11 @@
!
allowCharacterEscapes:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowCharacterEscapes := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:41 / Claus Gittinger"
!
allowDollarInIdentifier
@@ -2242,7 +2799,11 @@
!
allowDollarInIdentifier:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowDollarInIdentifier := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:47 / Claus Gittinger"
!
allowDolphinExtensions
@@ -2250,7 +2811,11 @@
!
allowDolphinExtensions:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowDolphinExtensions := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:51:50 / Claus Gittinger"
!
allowDomainVariables
@@ -2258,7 +2823,35 @@
!
allowDomainVariables:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowDomainVariables := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:51:55 / Claus Gittinger"
+!
+
+allowEStrings
+ "estrings have the syntax:
+ e'...'
+ where inside the string, c-language escapes are recognized
+ AND embedded expressions {expr} are sliced into the string."
+
+ ^ allowEStrings ? false.
+
+ "Created: / 23-05-2019 / 10:25:50 / Claus Gittinger"
+!
+
+allowEStrings:aBoolean
+ "estrings have the syntax:
+ e'...'
+ where inside the string, c-language escapes are recognized
+ AND embedded expressions {expr} are sliced into the string."
+
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowEStrings := aBoolean
+
+ "Created: / 23-05-2019 / 10:26:02 / Claus Gittinger"
!
allowEmptyStatements
@@ -2268,33 +2861,59 @@
!
allowEmptyStatements:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowEmptyStatements := aBoolean.
"Created: / 20-11-2006 / 14:26:48 / cg"
+ "Modified (comment): / 09-02-2019 / 15:51:58 / Claus Gittinger"
!
allowExtendedBinarySelectors
- ^ allowExtendedBinarySelectors
+ ^ allowExtendedBinarySelectors ? false
!
allowExtendedBinarySelectors:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowExtendedBinarySelectors := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:52:01 / Claus Gittinger"
!
allowExtendedSTXSyntax
+ "enables ALL of the ST/X extensions.
+ Do not use for now, as stc does not support all of them"
+
^ allowExtendedSTXSyntax
+
+ "Modified (comment): / 23-05-2019 / 10:36:04 / Claus Gittinger"
!
allowExtendedSTXSyntax:aBoolean
+ "enables ALL of the ST/X extensions.
+ Do not use for now, as stc does not support all of them"
+
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowExtendedSTXSyntax := aBoolean.
+
+ "Modified (comment): / 23-05-2019 / 10:41:41 / Claus Gittinger"
!
allowFixedPointLiterals
- ^ allowFixedPointLiterals
+ "return true, if nnnsn (FixedPoint / ScaledDecimal) literals are allowed.
+ The default is true."
+
+ ^ allowFixedPointLiterals ? true
!
allowFixedPointLiterals:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowFixedPointLiterals := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:52:13 / Claus Gittinger"
!
allowFunctionCallSyntaxForBlockEvaluation
@@ -2304,17 +2923,78 @@
!
allowFunctionCallSyntaxForBlockEvaluation:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowFunctionCallSyntaxForBlockEvaluation := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:52:19 / Claus Gittinger"
+!
+
+allowGreekCharactersInIdentifier
+ ^ allowGreekCharactersInIdentifier
+
+ "Created: / 08-06-2019 / 14:52:42 / Claus Gittinger"
+!
+
+allowGreekCharactersInIdentifier:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowGreekCharactersInIdentifier := aBoolean
+
+ "Created: / 08-06-2019 / 14:54:55 / Claus Gittinger"
!
allowHashAsBinarySelector
^ allowHashAsBinarySelector
!
+allowIStrings
+ "istrings have the syntax:
+ i'...'
+ where inside the string, c-language escapes are recognized
+ AND embedded expressions {expr} are sliced into the string
+ AND the string is translated (internationalization)."
+
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ ^ allowIStrings ? false.
+!
+
+allowIStrings:aBoolean
+ "istrings have the syntax:
+ i'...'
+ where inside the string, c-language escapes are recognized
+ AND embedded expressions {expr} are sliced into the string
+ AND the string is translated (internationalization)."
+
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowIStrings := aBoolean
+
+
+!
+
+allowInlineObjects
+ "return true, if inline objects are allowed"
+
+ ^ allowInlineObjects
+
+
+!
+
+allowInlineObjects:aBoolean
+ "if true, inline objects are allowed"
+
+ allowInlineObjects := aBoolean
+!
+
allowJavaScriptConst
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
^ allowJavaScriptConst
"Created: / 08-08-2017 / 23:50:12 / cg"
+ "Modified (comment): / 08-06-2019 / 15:00:52 / Claus Gittinger"
!
allowJavaScriptConst:aBoolean
@@ -2324,11 +3004,20 @@
!
allowLazyValueExtension
+ "allow !![...] to generate a lazy value"
+
^ allowLazyValueExtension
+
+ "Modified (comment): / 03-06-2019 / 10:57:32 / Claus Gittinger"
!
allowLazyValueExtension:aBoolean
+ "allow !![...] to generate a lazy value"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowLazyValueExtension := aBoolean.
+
+ "Modified (comment): / 03-06-2019 / 10:57:58 / Claus Gittinger"
!
allowLiteralNameSpaceSymbols
@@ -2336,7 +3025,11 @@
!
allowLiteralNameSpaceSymbols:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowLiteralNameSpaceSymbols := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:52:36 / Claus Gittinger"
!
allowLocalVariableDeclarationWithInitializerExpression
@@ -2344,7 +3037,11 @@
!
allowLocalVariableDeclarationWithInitializerExpression:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowLocalVariableDeclarationWithInitializerExpression := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:52:43 / Claus Gittinger"
!
allowNationalCharactersInIdentifier
@@ -2352,7 +3049,11 @@
!
allowNationalCharactersInIdentifier:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowNationalCharactersInIdentifier := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:52:46 / Claus Gittinger"
!
allowOldStyleAssignment
@@ -2363,20 +3064,48 @@
allowOldStyleAssignment:aBoolean
"return true, if underscore-assignment (pre ST-80v4 syntax) are to be allowed"
-
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowOldStyleAssignment := aBoolean
+
+ "Modified (format): / 09-02-2019 / 15:52:52 / Claus Gittinger"
!
allowParagraphInIdentifier
+ "return true, if §-characters are allowed in identifiers (treated as letter)"
+
^ allowParagraphInIdentifier
"Created: / 16-11-2016 / 22:29:06 / cg"
+ "Modified (comment): / 08-06-2019 / 14:59:39 / Claus Gittinger"
!
allowParagraphInIdentifier:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowParagraphInIdentifier := aBoolean.
"Created: / 16-11-2016 / 22:29:14 / cg"
+ "Modified (comment): / 09-02-2019 / 15:52:54 / Claus Gittinger"
+!
+
+allowPeriodAsNameSpaceSeparator
+ "experimental syntax: foo.bar"
+
+ ^ allowPeriodAsNameSpaceSeparator ? false
+
+ "Created: / 23-09-2018 / 00:48:59 / Claus Gittinger"
+!
+
+allowPeriodAsNameSpaceSeparator:aBoolean
+ "experimental syntax: foo.bar"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+
+ allowPeriodAsNameSpaceSeparator := aBoolean
+
+ "Created: / 23-09-2018 / 00:49:09 / Claus Gittinger"
+ "Modified (comment): / 09-02-2019 / 15:53:00 / Claus Gittinger"
!
allowPeriodInSymbol
@@ -2384,23 +3113,69 @@
!
allowPeriodInSymbol:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowPeriodInSymbol := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:53:02 / Claus Gittinger"
!
allowQualifiedNames
+ "return true, if '#{..}' and 'namespace.varName' qualified names are allowed"
+
^ allowQualifiedNames
+
+ "Modified (comment): / 23-09-2018 / 01:08:34 / Claus Gittinger"
!
allowQualifiedNames:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowQualifiedNames := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:53:11 / Claus Gittinger"
+!
+
+allowRStrings
+ "rstrings have the syntax:
+ r'...'
+ which generates a regex"
+
+ ^ allowRStrings ? false.
+
+ "Created: / 03-06-2019 / 11:11:25 / Claus Gittinger"
+!
+
+allowRStrings:aBoolean
+ "rstrings have the syntax:
+ r'...'
+ which generates a regex"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowRStrings := aBoolean
+
+ "Created: / 03-06-2019 / 11:11:51 / Claus Gittinger"
+ "Modified (comment): / 08-06-2019 / 15:01:17 / Claus Gittinger"
!
allowReservedWordsAsSelectors
+ "if true, 'self', 'super', 'thisContext', 'nil', 'true' and 'false' are allowed
+ as unary message selectors."
+
^ allowReservedWordsAsSelectors
+
+ "Modified (comment): / 25-06-2019 / 11:16:52 / Claus Gittinger"
!
allowReservedWordsAsSelectors:aBoolean
+ "enable/disable, if 'self', 'super', 'thisContext', 'nil', 'true' and 'false' are to be allowed
+ as unary message selectors."
+
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowReservedWordsAsSelectors := aBoolean.
+
+ "Modified (comment): / 25-06-2019 / 11:18:06 / Claus Gittinger"
!
allowSTVExtensions
@@ -2409,12 +3184,30 @@
^ allowSTVExtensions
!
+allowSTVExtensions:aBoolean
+ "if support for ST/V extensions is enabled."
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowSTVExtensions := aBoolean
+
+ "Created: / 09-02-2019 / 15:53:32 / Claus Gittinger"
+!
+
allowSTVPrimitives
"return true, if support for ST/V primitives is enabled."
^ allowSTVPrimitives
!
+allowSTVPrimitives:aBoolean
+ "if support for ST/V primitives is enabled."
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
+ allowSTVPrimitives := aBoolean
+
+ "Created: / 09-02-2019 / 15:53:53 / Claus Gittinger"
+!
+
allowSTXDelimiterComments
"are ST/X token-delimited comments allowed?
(see comment on class side)"
@@ -2423,8 +3216,9 @@
!
allowSTXDelimiterComments:aBoolean
- "are ST/X token-delimited comments allowed?
+ "are ST/X token-delimited comments allowed? (default is true)
(see comment on class side)"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
allowSTXDelimiterComments := aBoolean.
@@ -2432,6 +3226,8 @@
ParserFlags allowSTXDelimiterComments:false
ParserFlags allowSTXDelimiterComments:true
"
+
+ "Modified (comment): / 09-02-2019 / 15:54:26 / Claus Gittinger"
!
allowSTXEOLComments
@@ -2441,7 +3237,8 @@
!
allowSTXEOLComments:aBoolean
- "are ST/X end-of-line comments allowed?"
+ "are ST/X end-of-line comments allowed? (default is true)"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
allowSTXEOLComments := aBoolean.
@@ -2449,6 +3246,8 @@
ParserFlags allowSTXEOLComments:false
ParserFlags allowSTXEOLComments:true
"
+
+ "Modified (comment): / 09-02-2019 / 15:54:21 / Claus Gittinger"
!
allowSTXExtendedArrayLiterals
@@ -2459,8 +3258,25 @@
allowSTXExtendedArrayLiterals:aBoolean
"are scheme-style typed literal arrays allowed?"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
allowSTXExtendedArrayLiterals := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:54:33 / Claus Gittinger"
+!
+
+allowSTXExtensions
+ "if false, support for ST/X extensions is generally disabled.
+ if true, individual control flags may apply"
+
+ ^ allowSTXExtensions
+!
+
+allowSTXExtensions:aBoolean
+ "if false, support for ST/X extensions is generally disabled.
+ if true, individual control flags may apply"
+
+ allowSTXExtensions := aBoolean
!
allowSTXFunctions
@@ -2474,7 +3290,11 @@
!
allowSignedByteArrayElements:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowSignedByteArrayElements := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:54:39 / Claus Gittinger"
!
allowSqueakExtensions
@@ -2488,11 +3308,14 @@
allowSqueakExtensions:aBoolean
"this allows turning on/off support for squeak extensions:
- computed arrays { .., }
- c/java style arguments in message sends rec foo(arg1, ... argN)
+ computed arrays { .., }
+ c/java style arguments in message sends rec foo(arg1, ... argN)
+ attn: possibly sent via perform (Parser >> parsePragma)
"
allowSqueakExtensions := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:54:53 / Claus Gittinger"
!
allowSqueakPrimitives
@@ -2503,8 +3326,11 @@
allowSqueakPrimitives:aBoolean
"this allows turning on/off support for squeak primitives"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
allowSqueakPrimitives := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:55:01 / Claus Gittinger"
!
allowStringEscapes
@@ -2512,7 +3338,11 @@
!
allowStringEscapes:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowStringEscapes := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:55:04 / Claus Gittinger"
!
allowSymbolsStartingWithDigit
@@ -2528,11 +3358,13 @@
allowSymbolsStartingWithDigit:aBoolean
"control if a symbol is allowed to start with a digit
i.e. as in #2D.
- This seems to be ok in new Squeak/Pharo versions"
+ This seems to be ok in new Squeak/Pharo versions.
+ attn: possibly sent via perform (Parser >> parsePragma)"
allowSymbolsStartingWithDigit := aBoolean
"Created: / 18-06-2017 / 16:26:23 / cg"
+ "Modified (comment): / 09-02-2019 / 15:55:14 / Claus Gittinger"
!
allowUnderscoreInIdentifier
@@ -2540,7 +3372,11 @@
!
allowUnderscoreInIdentifier:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowUnderscoreInIdentifier := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:55:21 / Claus Gittinger"
!
allowUnicodeCharacters
@@ -2548,7 +3384,11 @@
!
allowUnicodeCharacters:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowUnicodeCharacters := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:55:25 / Claus Gittinger"
!
allowUnicodeStrings
@@ -2556,7 +3396,11 @@
!
allowUnicodeStrings:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowUnicodeStrings := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:55:28 / Claus Gittinger"
!
allowVariableReferences
@@ -2564,7 +3408,11 @@
!
allowVariableReferences:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowVariableReferences := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:55:32 / Claus Gittinger"
!
allowVisualAgeESSymbolLiterals
@@ -2572,7 +3420,11 @@
!
allowVisualAgeESSymbolLiterals:aBoolean
+ "attn: possibly sent via perform (Parser >> parsePragma)"
+
allowVisualAgeESSymbolLiterals := aBoolean.
+
+ "Modified (comment): / 09-02-2019 / 15:55:35 / Claus Gittinger"
!
allowVisualAgePrimitives
@@ -2583,8 +3435,11 @@
allowVisualAgePrimitives:aBoolean
"this allows turning on/off support for V'Age primitives"
+ "attn: possibly sent via perform (Parser >> parsePragma)"
allowVisualAgePrimitives := aBoolean
+
+ "Modified (comment): / 09-02-2019 / 15:55:39 / Claus Gittinger"
!
allowVisualWorksMethodAnnotations
@@ -2597,34 +3452,12 @@
allowVisualWorksMethodAnnotations:aBoolean
"turn on/off support for V'Works extended primitive syntax for method annotations."
+ "attn: possibly sent via perform (Parser >> parsePragma)"
allowVisualWorksMethodAnnotations := aBoolean
"Created: / 07-07-2006 / 15:49:03 / cg"
-!
-
-warnAssignmentToBlockArgument
- ^ warnAssignmentToBlockArgument
-!
-
-warnAssignmentToBlockArgument:aBoolean
- warnAssignmentToBlockArgument := aBoolean.
-!
-
-warnAssignmentToMethodArgument
- ^ warnAssignmentToMethodArgument
-!
-
-warnAssignmentToMethodArgument:aBoolean
- warnAssignmentToMethodArgument := aBoolean.
-!
-
-warnAssignmentToPoolVariable
- ^ warnAssignmentToPoolVariable
-!
-
-warnAssignmentToPoolVariable:aBoolean
- warnAssignmentToPoolVariable := aBoolean.
+ "Modified (comment): / 09-02-2019 / 15:55:42 / Claus Gittinger"
! !
!ParserFlags methodsFor:'accessing-warning-control'!
@@ -2637,6 +3470,14 @@
warnAboutBadComments := aBoolean.
!
+warnAboutDeadCodeAndFixMe
+ ^ warnAboutDeadCodeAndFixMe
+!
+
+warnAboutDeadCodeAndFixMe:aBoolean
+ warnAboutDeadCodeAndFixMe := aBoolean.
+!
+
warnAboutNonLowercaseLocalVariableNames
^ warnAboutNonLowercaseLocalVariableNames
!
@@ -2673,6 +3514,18 @@
warnAboutPossiblyUnimplementedSelectors := aBoolean.
!
+warnAboutPossiblyUninitializedLocals
+ ^ warnAboutPossiblyUninitializedLocals
+
+ "Created: / 23-04-2019 / 23:09:55 / Claus Gittinger"
+!
+
+warnAboutPossiblyUninitializedLocals:aBoolean
+ warnAboutPossiblyUninitializedLocals := aBoolean.
+
+ "Created: / 23-04-2019 / 23:10:01 / Claus Gittinger"
+!
+
warnAboutReferenceToPrivateClass
"controls generation of warning messages when a private class is referenced"
@@ -2721,6 +3574,30 @@
warnAboutWrongVariableNames := aBoolean.
!
+warnAssignmentToBlockArgument
+ ^ warnAssignmentToBlockArgument
+!
+
+warnAssignmentToBlockArgument:aBoolean
+ warnAssignmentToBlockArgument := aBoolean.
+!
+
+warnAssignmentToMethodArgument
+ ^ warnAssignmentToMethodArgument
+!
+
+warnAssignmentToMethodArgument:aBoolean
+ warnAssignmentToMethodArgument := aBoolean.
+!
+
+warnAssignmentToPoolVariable
+ ^ warnAssignmentToPoolVariable
+!
+
+warnAssignmentToPoolVariable:aBoolean
+ warnAssignmentToPoolVariable := aBoolean.
+!
+
warnCommonMistakes
^ warnCommonMistakes
!
@@ -2841,6 +3718,12 @@
warnSTXSpecialComment := aBoolean.
!
+warnSTXSpecials:aBoolean
+ warnSTXSpecialComment := aBoolean.
+ warnSTXNameSpaceUse := aBoolean.
+ warnSTXHereExtensionUsed := aBoolean.
+!
+
warnUndeclared
^ warnUndeclared
!
@@ -2883,6 +3766,8 @@
"each instance is initially setup from the classes global defaults.
(but can be changed as required for an individual compilation run"
+ singlePrecisionFloatF := SinglePrecisionFloatF.
+
warnings := Warnings.
warnUndeclared := WarnUndeclared.
warnUnusedVars := WarnUnusedVars.
@@ -2900,6 +3785,7 @@
warnAboutWrongVariableNames := WarnAboutWrongVariableNames.
warnAboutBadComments := WarnAboutBadComments.
warnAboutReferenceToPrivateClass := WarnAboutReferenceToPrivateClass.
+ warnAboutPossiblyUninitializedLocals := WarnAboutPossiblyUninitializedLocals.
warnHiddenVariables := WarnHiddenVariables.
warnInconsistentReturnValues := WarnInconsistentReturnValues.
warnAboutNonLowercaseLocalVariableNames := WarnAboutNonLowercaseLocalVariableNames.
@@ -2912,7 +3798,9 @@
warnAssignmentToBlockArgument := WarnAssignmentToBlockArgument.
warnAssignmentToMethodArgument := WarnAssignmentToMethodArgument.
warnAssignmentToPoolVariable := WarnAssignmentToPoolVariable.
-
+ warnAboutDeadCodeAndFixMe := WarnAboutDeadCodeAndFixMe.
+
+ allowSTXExtensions := AllowSTXExtensions.
allowUnderscoreInIdentifier := AllowUnderscoreInIdentifier.
allowDollarInIdentifier := AllowDollarInIdentifier.
allowParagraphInIdentifier := AllowParagraphInIdentifier.
@@ -2939,6 +3827,7 @@
allowSTVPrimitives := AllowSTVPrimitives.
allowSTVExtensions := AllowSTVExtensions.
allowNationalCharactersInIdentifier := AllowNationalCharactersInIdentifier.
+ allowGreekCharactersInIdentifier := AllowGreekCharactersInIdentifier.
allowHashAsBinarySelector := AllowHashAsBinarySelector.
allowSTXEOLComments := AllowSTXEOLComments.
allowSTXDelimiterComments := AllowSTXDelimiterComments.
@@ -2947,7 +3836,14 @@
allowPossibleSTCCompilationProblems := AllowPossibleSTCCompilationProblems.
allowEmptyStatements := AllowEmptyStatements.
allowPeriodInSymbol := AllowPeriodInSymbol.
+ allowPeriodAsNameSpaceSeparator := AllowPeriodAsNameSpaceSeparator.
+
"/ these are only supported in the new compiler
+ allowCIntegers := AllowCIntegers.
+ allowCStrings := AllowCStrings.
+ allowEStrings := AllowEStrings.
+ allowRStrings := AllowRStrings.
+ allowIStrings := AllowIStrings.
allowUnicodeStrings := AllowUnicodeStrings.
allowUnicodeCharacters := AllowUnicodeCharacters.
allowCharacterEscapes := AllowCharacterEscapes.
@@ -2957,6 +3853,7 @@
allowAssignmentToPoolVariable := AllowAssignmentToPoolVariable.
allowSignedByteArrayElements := AllowSignedByteArrayElements.
allowSymbolsStartingWithDigit := AllowSymbolsStartingWithDigit.
+ allowInlineObjects := AllowInlineObjects.
allowJavaScriptConst := AllowJavaScriptConst.
@@ -2987,6 +3884,7 @@
"
"Modified: / 08-08-2017 / 23:50:01 / cg"
+ "Modified: / 08-06-2019 / 14:53:04 / Claus Gittinger"
! !
!ParserFlags class methodsFor:'documentation'!
--- a/PluggableParseNodeVisitor.st Sat Aug 08 22:49:53 2020 +0100
+++ b/PluggableParseNodeVisitor.st Tue Aug 25 12:20:06 2020 +0100
@@ -38,6 +38,9 @@
documentation
"
+ obsolete not, because the superclass is now pluggable.
+ left in the system for a while for backward compatibility.
+
a pluggable node visitor.
setup with:
actionForNodeClass:aClass put:aBlock
@@ -51,33 +54,10 @@
"
! !
-!PluggableParseNodeVisitor methodsFor:'setup'!
-
-actionForNodeClass:aNodeClass put:aBlock
- "setup so that for nodes of type aNodeClass, aBlock is invoked.
- If the block returns true, subnodes (eg. right side of assignments, etc.)
- will be enumerated as well.
- Otherwise, no subnodes are visited."
-
- actionsPerNodeType isNil ifTrue:[
- actionsPerNodeType := Dictionary new.
- ].
- actionsPerNodeType at:aNodeClass put:aBlock
-! !
+!PluggableParseNodeVisitor class methodsFor:'queries'!
-!PluggableParseNodeVisitor methodsFor:'visiting'!
-
-visit:aNodeObject
- "redefined to look for an action for this node's class.
- If there is one, it can specify if subnodes are to be visited too"
-
- |action|
-
- action := actionsPerNodeType at:aNodeObject class ifAbsent:[nil].
- action notNil ifTrue:[
- (action value:aNodeObject) ifFalse:[^ self].
- ].
- super visit:aNodeObject
+isObsolete
+ ^ true
! !
!PluggableParseNodeVisitor class methodsFor:'documentation'!
--- a/PrimaryNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/PrimaryNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -49,10 +49,12 @@
!PrimaryNode methodsFor:'accessing'!
charIndex
+ <resource: #obsolete>
^ charIndex
!
charIndex:something
+ <resource: #obsolete>
charIndex := something.
!
@@ -79,11 +81,6 @@
!PrimaryNode methodsFor:'code generation'!
-codeForSideEffectOn:aStream inBlock:b for:aCompiler
- "no code at all"
- ^ self
-!
-
codeStoreOn:aStream inBlock:codeBlock valueNeeded:valueNeeded for:aCompiler
^ self subclassResponsibility
! !
--- a/ProgramNodeEnumerator.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ProgramNodeEnumerator.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2004 by eXept Software AG
All Rights Reserved
@@ -144,6 +146,7 @@
!
doNodes:nodeList
+ "cg: is it required to return the nodeList, or just sloppy programming?"
^ nodeList do:[:node | self doNode:node]
"Created: 19.6.1997 / 16:51:41 / cg"
--- a/ReturnNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/ReturnNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -11,6 +13,8 @@
"
"{ Package: 'stx:libcomp' }"
+"{ NameSpace: Smalltalk }"
+
StatementNode subclass:#ReturnNode
instanceVariableNames:'myHome blockHome'
classVariableNames:''
@@ -112,6 +116,8 @@
!ReturnNode methodsFor:'code generation'!
basicCodeOn:aStream inBlock:b for:aCompiler
+ "/ Transcript showCR:'====> %1 [%2]' with:lineNr with:expression printString.
+
b isNil ifTrue:[
self codeLocalReturnOn:aStream inBlock:b for:aCompiler.
^ self.
@@ -121,6 +127,7 @@
expression isNil ifTrue:[
"/ nil-expression is not possible in smalltalk;
"/ however, it might be in a subclass (i.e. JavaScript)
+ "/ TODO: add a pushVoid instruction
aStream nextPut:#pushNil.
] ifFalse:[
expression codeOn:aStream inBlock:b for:aCompiler.
@@ -191,6 +198,14 @@
"Modified: 19.6.1997 / 16:42:40 / cg"
! !
+!ReturnNode methodsFor:'enumeration'!
+
+childrenDo:aBlock
+ aBlock value:expression.
+
+
+! !
+
!ReturnNode methodsFor:'evaluation'!
evaluateExpressionIn:anEnvironment
@@ -256,6 +271,6 @@
!ReturnNode class methodsFor:'documentation'!
version_CVS
- ^ '$Header: /cvs/stx/stx/libcomp/ReturnNode.st,v 1.45 2014-06-13 10:24:03 cg Exp $'
+ ^ '$Header$'
! !
--- a/STCCompilerInterface.st Sat Aug 08 22:49:53 2020 +0100
+++ b/STCCompilerInterface.st Tue Aug 25 12:20:06 2020 +0100
@@ -142,7 +142,11 @@
# define CC_DEFINE "__CLANG__"
# else
# ifdef __GNUC__
-# define CC_DEFINE "__GNUC__"
+ // https://expeccoalm.exept.de/D252306
+ // must not redefine __GNUC__, because gcc defines this anyway with the gcc version
+ // contained in this macro (which is used by glibc includes).
+ // also defined in STCCompilerInterface class >> #getCCDefine
+# define CC_DEFINE "STX__GNUC__"
# else
# define CC_DEFINE "__CC__"
# endif
@@ -154,6 +158,8 @@
"
STCCompilerInterface getCCDefine
"
+
+ "Modified: / 11-05-2018 / 10:12:47 / stefan"
!
getCPUDefine
@@ -161,7 +167,7 @@
compiled, and which should be passed down when compiling methods.
For example, on a 386 (and successors), this may be '-D__x86__';
on a vax, this would be '-D__vax__'.
- This is normally not of interest to 'normal' users; however, it is passed
+ This is normally not of interest to 'normal' users; however, it is passed
down to the c-compiler when methods are incrementally compiled to machine code.
Do not use this for CPU determination; only to pass on to stc for compilation.
(see OperatingSystem getCPUType for this)"
@@ -274,6 +280,9 @@
initialize
Verbose := false.
+ KeepIntermediateFiles := false.
+
+ "Modified: / 11-05-2018 / 09:34:34 / stefan"
! !
!STCCompilerInterface methodsFor:'accessing'!
@@ -296,7 +305,7 @@
]
].
(cmd notNil and:[cmd includes:Character space]) ifTrue:[
- cmd := '"' , cmd , '"'.
+ cmd := cmd withDoubleQuotes.
].
^ cmd
@@ -319,8 +328,10 @@
!STCCompilerInterface methodsFor:'error raising'!
parseError:messageText position:position
- originator parseError:messageText position:position.
- "not normally reached"
+ originator notNil ifTrue:[
+ originator parseError:messageText position:position.
+ "not normally reached"
+ ].
ParseError raiseErrorString:messageText.
! !
@@ -334,9 +345,64 @@
As you already see, this takes some time and is therefore ONLY done for code containing prims;
all pure smalltalk code is compiled to bytecode and jitted by the VM."
+ ^ self
+ compileToMachineCode:aString forClass:aClass selector:selector inCategory:categoryArg
+ notifying:requestorArg install:install skipIfSame:skipIfSame silent:silent
+ generateCOnly:false
+
+ "
+ |m|
+
+ Object subclass:#Test
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'tests'.
+ m := ByteCodeCompiler
+ compile:'foo ^ ''hello'''
+ forClass:Test
+ inCategory:'tests'
+ notifying:nil
+ install:false
+ skipIfSame:false.
+ m inspect
+ "
+ "
+ |m|
+
+ Object subclass:#Test
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'tests'.
+ m := ByteCodeCompiler
+ compileToMachineCode:'foo %{ RETURN (_MKSMALLINT(1)); %}'
+ forClass:Test
+ inCategory:'tests'
+ notifying:nil
+ install:false
+ skipIfSame:false
+ silent:false.
+ m inspect
+ "
+
+ "Modified: / 14-09-1995 / 22:33:04 / claus"
+ "Modified: / 17-09-2011 / 10:39:25 / cg"
+ "Modified: / 16-05-2018 / 13:48:25 / stefan"
+!
+
+compileToMachineCode:aString forClass:aClass selector:selector inCategory:categoryArg
+ notifying:requestorArg install:install skipIfSame:skipIfSame silent:silent
+ generateCOnly:generateCOnly
+ "this is called to compile primitive code.
+ It saves the code to a tmporary, calls stc to create C-code, compiles it, links
+ it to a tiny little dll and loads it.
+ As you already see, this takes some time and is therefore ONLY done for code containing prims;
+ all pure smalltalk code is compiled to bytecode and jitted by the VM."
+
|handle oldMethod newMethod ok dllFileName|
- install ifFalse:[
+ (install not and:[generateCOnly not]) ifTrue:[
"/ cannot do it uninstalled. reason:
"/ if it is loaded twice, the first version could be unloaded by
"/ finalization, which would also unload the second version
@@ -382,13 +448,17 @@
self reportCompilationErrorFor:stcPath fromFile:errorFile
].
- parserFlags stcKeepSIntermediate ifTrue:[
+ (generateCOnly or:[parserFlags stcKeepSIntermediate]) ifTrue:[
self compileToS_onError:[:errorFile | ]
].
+ generateCOnly ifTrue:[
+ ^ cFileName asFilename
+ ].
+
"/ now compile to machine code
ok := self
compileToObj_onError:[:errorFile |
- self reportCompilationErrorFor:ccPath fromFile:errorFile.
+ self reportCompilationErrorFor:ccPath, cFlags fromFile:errorFile.
].
originator activityNotification:''.
@@ -424,7 +494,7 @@
originator activityNotification:''.
handle isNil ifTrue:[
- KeepIntermediateFiles ~~ true ifTrue:[ OperatingSystem removeFile:dllFileName ].
+ KeepIntermediateFiles ifFalse:[ dllFileName asFilename remove ].
"catch, so that #CannotLoad processing is done"
ParseError catch:[
originator parseError:'dynamic load of machine code failed' position:1.
@@ -498,40 +568,41 @@
^ newMethod.
].
- "/ OperatingSystem removeFile:moduleFileName.
+ "/ moduleFileName asFilename remove.
self parseError:'dynamic load failed' position:1.
] ensure:[
- KeepIntermediateFiles == true ifTrue:[
- Transcript showCR:'keeping files'
- ] ifFalse:[
- parserFlags stcKeepSTIntermediate ifTrue:[
- Transcript showCR:'keeping st file: ', stFileName asFilename pathName
+ generateCOnly ifFalse:[
+ KeepIntermediateFiles ifTrue:[
+ Transcript showCR:'keeping files'
] ifFalse:[
- OperatingSystem removeFile:stFileName.
- OperatingSystem removeFile:'errorOutput'.
- ].
- cFileName notNil ifTrue:[
- parserFlags stcKeepCIntermediate == true ifTrue:[
- Transcript showCR:'keeping c file: ', cFileName asFilename pathName
+ parserFlags stcKeepSTIntermediate ifTrue:[
+ Transcript showCR:'keeping st file: ', stFileName asFilename pathName
] ifFalse:[
- OperatingSystem removeFile:cFileName.
- ]
- ].
- oFileName notNil ifTrue:[
- parserFlags stcKeepOIntermediate == true ifTrue:[
- Transcript showCR:'keeping o file: ', oFileName asFilename pathName
- ] ifFalse:[
- OperatingSystem removeFile:oFileName.
+ stFileName asFilename remove.
+ ].
+ cFileName notNil ifTrue:[
+ parserFlags stcKeepCIntermediate == true ifTrue:[
+ Transcript showCR:'keeping c file: ', cFileName asFilename pathName
+ ] ifFalse:[
+ cFileName asFilename remove.
+ ]
].
- ].
-"/ OperatingSystem isMSDOSlike ifTrue:[
-"/ mapFileName notNil ifTrue:[
-"/ OperatingSystem removeFile:mapFileName.
-"/ ].
-"/ libFileName notNil ifTrue:[
-"/ OperatingSystem removeFile:libFileName.
-"/ ].
-"/ ].
+ oFileName notNil ifTrue:[
+ parserFlags stcKeepOIntermediate == true ifTrue:[
+ Transcript showCR:'keeping o file: ', oFileName asFilename pathName
+ ] ifFalse:[
+ oFileName asFilename remove.
+ ].
+ ].
+ "/ OperatingSystem isMSDOSlike ifTrue:[
+ "/ mapFileName notNil ifTrue:[
+ "/ mapFileName asFilename remove.
+ "/ ].
+ "/ libFileName notNil ifTrue:[
+ "/ libFileName asFilename remove.
+ "/ ].
+ "/ ].
+ ]
]
].
@@ -572,8 +643,8 @@
"
"Modified: / 14-09-1995 / 22:33:04 / claus"
- "Modified: / 19-03-1999 / 08:31:42 / stefan"
"Modified: / 17-09-2011 / 10:39:25 / cg"
+ "Modified: / 16-05-2018 / 13:48:25 / stefan"
! !
!STCCompilerInterface methodsFor:'machine code generation-helpers'!
@@ -584,13 +655,13 @@
|command ok errorOutputFile|
- command := (self possiblyQuotedPath:stcPath) , ' ' , stcFlags
- , ' -E:',(self possiblyQuotedPath:(Filename tempDirectory / 'lastIncrStcErrorOutput') pathName)
- , ' -defdir=', (self possiblyQuotedPath:cFileName asFilename directory pathName).
+ command := (Filename possiblyQuotedPathname:stcPath) , ' '
+ , stcFlags
+ , ' -defdir=', (Filename possiblyQuotedPathname:cFileName asFilename directory pathName).
cFileName asFilename suffix ~= 'c' ifTrue:[
command := command , ' -cSuffix=',cFileName asFilename suffix.
].
- command := command , ' -C ' , (self possiblyQuotedPath:stFileName asFilename pathName).
+ command := command , ' -C ' , (Filename possiblyQuotedPathname:stFileName asFilename pathName).
Verbose == true ifTrue:[
Transcript show:'executing: '; showCR:command.
@@ -600,6 +671,7 @@
errorOutputFile := Filename tempDirectory / 'stcErrorOutput'.
errorOutputFile writingFileDo:[:errorStream |
+ errorStream nextPutAll:'Command: '; nextPutLine:command; cr; flush.
ok := OperatingSystem
executeCommand:command
inputFrom:nil
@@ -635,7 +707,9 @@
^ ok
"Created: / 07-11-2006 / 12:11:24 / cg"
- "Modified: / 08-08-2011 / 22:12:01 / cg"
+ "Modified: / 16-05-2018 / 13:49:01 / stefan"
+ "Modified: / 28-03-2019 / 16:17:03 / Claus Gittinger"
+ "Modified: / 16-06-2020 / 19:08:12 / cg"
!
compileToExe_onError:aBlock
@@ -644,7 +718,7 @@
|command errorOutputFile ok|
- command := (self possiblyQuotedPath:ccPath) , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ ' , (self possiblyQuotedPath:cFileName).
+ command := (Filename possiblyQuotedPathname:ccPath) , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ ' , (Filename possiblyQuotedPathname:cFileName).
Verbose == true ifTrue:[
Transcript show:'executing: ' showCR:command.
@@ -673,6 +747,8 @@
errorOutputFile remove.
].
^ ok
+
+ "Modified: / 28-03-2019 / 16:17:06 / Claus Gittinger"
!
compileToObj_onError:aBlock
@@ -695,11 +771,11 @@
commandTemplate := '%1 %2%3 -D__INCREMENTAL_COMPILE__ -o %4 -c %5'.
].
command := commandTemplate
- bindWith:(self possiblyQuotedPath:ccPath)
+ bindWith:(Filename possiblyQuotedPathname:ccPath)
with:cFlags
with:ccDefine
- with:(self possiblyQuotedPath:oFileName)
- with:(self possiblyQuotedPath:cFileName).
+ with:(Filename possiblyQuotedPathname:oFileName)
+ with:(Filename possiblyQuotedPathname:cFileName).
Verbose == true ifTrue:[
Transcript show:'executing: '; showCR:command.
@@ -765,6 +841,7 @@
"Created: / 07-11-2006 / 12:14:51 / cg"
"Modified: / 04-01-2016 / 21:12:56 / jv"
+ "Modified: / 28-03-2019 / 16:17:10 / Claus Gittinger"
!
compileToS_onError:aBlock
@@ -773,7 +850,7 @@
|command errorOutputFile ok|
- command := (self possiblyQuotedPath:ccPath) , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ -S ' , (self possiblyQuotedPath:cFileName).
+ command := (Filename possiblyQuotedPathname:ccPath) , ' ' , cFlags , ' -D__INCREMENTAL_COMPILE__ -S ' , (Filename possiblyQuotedPathname:cFileName).
Verbose == true ifTrue:[
Transcript show:'executing: '; showCR:command.
@@ -801,6 +878,8 @@
errorOutputFile remove.
].
^ ok
+
+ "Modified: / 28-03-2019 / 16:17:13 / Claus Gittinger"
!
ensureExternalToolsArePresent
@@ -929,7 +1008,7 @@
[
stream := stFileName asFilename writeStream.
- ] on:FileStream openErrorSignal do:[:ex|
+ ] on:OpenError do:[:ex|
self parseError:'cannot create temporary sourcefile for compilation' position:1.
^ #CannotLoad
].
@@ -975,7 +1054,12 @@
className := theNonMetaclassToCompileFor name.
ns := theNonMetaclassToCompileFor topNameSpace.
- (ns notNil and:[ns ~= Smalltalk and:[nsName := ns name. className startsWith:(nsName,'::')]]) ifTrue:[
+
+ (ns notNil
+ and:[ns ~= Smalltalk
+ and:[nsName := ns name.
+ className startsWith:(nsName,'::')
+ ]]) ifTrue:[
className := className copyFrom:nsName size+2+1.
"/ split to avoid being regognized as a directive
stream nextPutLine:('"','{ NameSpace: ',nsName,' }"').
@@ -996,35 +1080,74 @@
stream close.
"Modified: / 08-08-2011 / 23:23:10 / cg"
-!
-
-possiblyQuotedPath:aPath
- (aPath includes:Character space) ifTrue:[
- (aPath startsWith:$") ifFalse:[
- ^ '"',aPath,'"'
- ]
- ].
- ^ aPath
+ "Modified (format): / 08-08-2018 / 08:58:35 / Claus Gittinger"
!
reportCompilationErrorFor:aCommand
- |eMsg errorMessages lNr|
+ <resource: #obsolete>
+ self obsoleteMethodWarning.
+ ^ self reportCompilationErrorFor:aCommand fromFile:'errorOutput' asFilename.
+
+ "Created: / 07-11-2006 / 12:29:04 / cg"
+ "Modified: / 21-12-2013 / 00:08:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 11-05-2018 / 09:29:20 / stefan"
+!
+
+reportCompilationErrorFor:aCommand fromFile:anErrorFilename
+ |eMsg errorMessages errorMessagesColorized lNr cFile stFile|
(executionStatus notNil and:[executionStatus couldNotExecute]) ifTrue:[
eMsg := 'oops, no %1 - cannot create machine code' bindWith:aCommand.
] ifFalse:[
- errorMessages := 'errorOutput' asFilename contents collect:[:l | OperatingSystem decodePathOrCommandOutput: l ].
- OperatingSystem removeFile:'errorOutput'.
+ errorMessages := anErrorFilename contents
+ collect:[:l | OperatingSystem decodePathOrCommandOutput: l ].
+
+ "/ replace the filename string
+ cFile := cFileName asFilename name.
+ stFile := stFileName asFilename name.
+ errorMessages := errorMessages
+ collect:[:line |
+ (line startsWith:cFile) ifTrue:[
+ cFileName asFilename baseName,(line copyFrom:cFile size+1)
+ ] ifFalse:[
+ (line startsWith:stFile) ifTrue:[
+ stFileName asFilename baseName,(line copyFrom:stFile size+1)
+ ] ifFalse:[
+ line
+ ].
+ ].
+ ].
+
+ errorMessagesColorized :=
+ errorMessages collect:[:line |
+ (line includesString:'warning:' caseSensitive:false) ifTrue:[
+ line withColor:Color orange
+ ] ifFalse:[
+ (line includesString:'error:' caseSensitive:false) ifTrue:[
+ line allRed
+ ] ifFalse:[
+ line
+ ]
+ ]
+ ].
+ Transcript showCR:errorMessagesColorized asString.
errorMessages notNil ifTrue:[
- errorMessages := errorMessages reject:[:line | line includesString:'Warning:'].
-
+ errorMessages := errorMessages reject:[:line | line includesString:'Note:' caseSensitive:false].
+ errorMessages size > 20 ifTrue:[
+ errorMessages := errorMessages reject:[:line | line startsWith:'Note ' caseSensitive:false].
+ ].
errorMessages size > 20 ifTrue:[
- errorMessages := errorMessages select:[:line | line asLowercase startsWith:'error'].
+ errorMessages := errorMessages reject:[:line | line includesString:'Warning:' caseSensitive:false].
+ errorMessages size > 20 ifTrue:[
+ errorMessages := errorMessages reject:[:line | line startsWith:'Warning ' caseSensitive:false].
+ ].
errorMessages size > 20 ifTrue:[
- errorMessages := (errorMessages copyTo:20) copyWith:'... more messages skipped'
+ "/ errorMessages := errorMessages select:[:line | line asLowercase startsWith:'error'].
+ errorMessages size > 20 ifTrue:[
+ errorMessages := (errorMessages copyTo:20) copyWith:'... more messages skipped'
+ ].
].
- ].
"/ errorMessages := errorMessages collect:[:line |
"/ (line startsWith:(stFileName , ':')) ifTrue:[
"/ 'Line: ' , (line copyFrom:(stFileName size + 2))
@@ -1032,74 +1155,8 @@
"/ line
"/ ]
"/ ].
- ].
- errorMessages isNil ifTrue:[
- errorMessages := #('')
- ].
- errorMessages := (Array with:'Failed to execute: "', aCommand,'"') , errorMessages.
-
- "/ try to extract a line number"
- (errorMessages contains:[:line | line includesString:'Borland']) ifTrue:[
- |i i2 s|
- i := errorMessages findFirst:[:l | l startsWith:(cFileName,':')].
- i ~~ 0 ifTrue:[
- ((errorMessages at:i+1) startsWith:'Error') ifTrue:[
- i2 := (errorMessages at:i+1) indexOfSubCollection:(stFileName).
- i2 ~~ 0 ifTrue:[
- s := (errorMessages at:i+1) copyFrom:(i2+stFileName size+1).
- s := s readStream.
- lNr := Integer readFrom:s.
- s skipSeparators.
- ].
- ]
].
].
-
- errorMessages isEmpty ifTrue:[
- eMsg := 'Error during compilation:\\Unspecified error (no output)' withCRs
- ] ifFalse:[
- eMsg := 'Error during compilation:\\' withCRs ,
- (errorMessages asStringCollection asString).
- ].
- ].
-
- originator activityNotification:''.
-
- ParseError new
- lineNumber:lNr;
- errorMessage:eMsg;
- raise.
-
- "Created: / 07-11-2006 / 12:29:04 / cg"
- "Modified: / 21-12-2013 / 00:08:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-reportCompilationErrorFor:aCommand fromFile:anErrorFilename
- |eMsg errorMessages lNr|
-
- (executionStatus notNil and:[executionStatus couldNotExecute]) ifTrue:[
- eMsg := 'oops, no %1 - cannot create machine code' bindWith:aCommand.
- ] ifFalse:[
- errorMessages := anErrorFilename contents
- collect:[:l | OperatingSystem decodePathOrCommandOutput: l ].
- Transcript showCR:errorMessages asString.
- errorMessages notNil ifTrue:[
- errorMessages := errorMessages reject:[:line | line includesString:'Warning:'].
-
- errorMessages size > 20 ifTrue:[
- "/ errorMessages := errorMessages select:[:line | line asLowercase startsWith:'error'].
- errorMessages size > 20 ifTrue:[
- errorMessages := (errorMessages copyTo:20) copyWith:'... more messages skipped'
- ].
- ].
-"/ errorMessages := errorMessages collect:[:line |
-"/ (line startsWith:(stFileName , ':')) ifTrue:[
-"/ 'Line: ' , (line copyFrom:(stFileName size + 2))
-"/ ] ifFalse:[
-"/ line
-"/ ]
-"/ ].
- ].
errorMessages isNil ifTrue:[
errorMessages := #('')
].
@@ -1141,6 +1198,7 @@
"Modified: / 21-12-2013 / 00:08:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 25-02-2017 / 09:58:18 / cg"
"Modified (format): / 25-02-2017 / 19:33:58 / cg"
+ "Modified: / 01-10-2018 / 09:18:53 / Claus Gittinger"
!
setupCompilationCommandArguments
@@ -1149,7 +1207,7 @@
parserFlags isNil ifTrue:[ parserFlags := ParserFlags new].
stFn := stFileName asFilename.
- oFileName := stFn nameWithoutSuffix , (ObjectFileLoader objectFileExtension).
+ oFileName := (stFn withSuffix:(ObjectFileLoader objectFileSuffix)) name.
cFileName := (stFn withSuffix:'c') name.
"/ ParserFlags useBorlandC ifTrue:[
"/ cFileName := (stFn withSuffix:'sc') name.
@@ -1158,6 +1216,7 @@
cFileName asFilename remove.
"/ stcFlags := '-commonSymbols +sharedLibCode +newIncremental -E:errorOutput -N' , initName .
+ stcFlags := '+newIncremental +opt +optInline'.
stcFlags := '+newIncremental'.
initName notEmptyOrNil ifTrue:[
stcFlags := stcFlags,' -N' , initName .
@@ -1197,7 +1256,7 @@
].
"Created: / 07-11-2006 / 12:24:47 / cg"
- "Modified: / 07-11-2006 / 13:58:54 / cg"
+ "Modified: / 16-06-2020 / 19:07:43 / cg"
"Modified: / 09-12-2015 / 17:00:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
--- a/Scanner.st Sat Aug 08 22:49:53 2020 +0100
+++ b/Scanner.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -25,8 +23,8 @@
didWarnAboutUnderscoreInIdentifier didWarnAboutOldStyleAssignment
didWarnAboutDollarInIdentifier didWarnAboutPeriodInSymbol
unicodeActions'
- classVariableNames:'DefaultTypeArray DefaultActionArray EmptySourceNotificationSignal
- DefaultUnicodeActions'
+ classVariableNames:'DefaultActionArray DefaultTypeArray DefaultUnicodeActions
+ EmptySourceNotificationSignal'
poolDictionaries:''
category:'System-Compiler'
!
@@ -110,27 +108,34 @@
instance variables as a side effect.
TODO:
- some testers noticed that ST-80's scanner methods are called
- xLetter, xDigit etc. For code using these (internals), the nextNumber,
- nextIdentifier etc. methods should be renamed.
- (to me, these seem to be internal private methods;
- their public use is not a good idea ..)
-
- Scanner is typically subclassed for parsing and #nextToken
- invoked via #self-sends.
- This should be changed and scanner ought to be an instance variable
- of Parser - this allows more flexible use of the scanner/parser
- framework (i.e. changing the scanner without affecting the parser).
+ some testers noticed that ST-80's scanner methods are called
+ xLetter, xDigit etc. For code using these (internals), the nextNumber,
+ nextIdentifier etc. methods should be renamed.
+ (to me, these seem to be internal private methods;
+ their public use is not a good idea ..)
+
+ Scanner is typically subclassed for parsing and #nextToken
+ invoked via #self-sends.
+ This should be changed and scanner ought to be an instance variable
+ of Parser - this allows more flexible use of the scanner/parser
+ framework (i.e. changing the scanner without affecting the parser).
Extensions:
- this scanner allows for 3-character binary selectors.
- also, # is a valid selector. (however, ## is currently scanned as a symbol literal).
+ selectors:
+ this scanner allows for 3-character binary selectors.
+ also, # is a valid selector. (however, ## is currently scanned as a symbol literal).
+
+ special strings:
+ c'...' a string with c escapes
+ e'...' a string with c escapes and embedded expressions
+ i'...' a string with c escapes and embedded expressions and internationalization
+ r'...' a regex
[author:]
- Claus Gittinger
+ Claus Gittinger
[see also:]
- Parser
+ Parser
"
! !
@@ -145,7 +150,7 @@
extendedBinarySelectorCharacters
"return a collection of characters which are optionally allowed in binary selectors"
- "/ ^ '±×·÷«»'.
+ "/ ^ '±×·÷«»'.
^ String
with:(Character value:16rB1) "/ plus-minus
with:(Character value:16rD7) "/ times
@@ -220,13 +225,15 @@
"kludge: action is nextColonOrAssign, but type is special"
typeArray at:($: codePoint) put:#special.
- actionArray at:($' codePoint) put:[:s :char | s nextString:char].
+ actionArray at:($' codePoint) put:[:s :char | s nextString:char escapeStyle:nil].
actionArray at:($$ codePoint) put:[:s :char | s nextCharacter].
actionArray at:($# codePoint) put:[:s :char | s nextHash].
actionArray at:($!! codePoint) put:[:s :char | s nextExcla].
actionArray at:($% codePoint) put:[:s :char | s nextPrimitive].
actionArray at:($: codePoint) put:[:s :char | s nextColonOrAssign].
actionArray at:($_ codePoint) put:[:s :char | s nextUnderline].
+ "/ an experiment to allow 'special' identifiers (in backticks, allowing arbitrary characters inside)
+ "/ actionArray at:($` codePoint) put:[:s :char | s nextBacktickIdentifier].
unicodeActions at:2190 "<- left arrow" put:[:s :char | s nextAssignmentArrow].
@@ -240,6 +247,7 @@
"
"Modified: / 02-07-2017 / 01:11:27 / cg"
+ "Modified: / 08-02-2019 / 19:13:32 / Claus Gittinger"
! !
!Scanner class methodsFor:'instance creation'!
@@ -285,6 +293,7 @@
flushActionArray
ActionArray := DefaultActionArray := nil.
TypeArray := DefaultTypeArray := nil.
+ UnicodeActions := DefaultUnicodeActions := nil.
"
Scanner flushActionArray
@@ -292,6 +301,8 @@
ByteCodeCompiler flushActionArray
Explainer flushActionArray
"
+
+ "Modified: / 11-12-2018 / 11:25:53 / Claus Gittinger"
!
typeArray
@@ -332,6 +343,7 @@
!Scanner class methodsFor:'defaults'!
allowDollarInIdentifier
+ <resource: #obsolete>
"return true, if $-characters are allowed in identifiers.
Notice, that dollars are NEVER allowed as the first character in an identifier."
@@ -378,6 +390,7 @@
!
allowLiteralNameSpaceSymbols
+ <resource: #obsolete>
"return true, if literal nameSpace symbols are allowed (#foo::bar) are allowed"
^ ParserFlags allowLiteralNameSpaceSymbols
@@ -397,9 +410,12 @@
!
allowQualifiedNames
- "return true, if #{..} qualified names are allowed"
+ <resource: #obsolete>
+ "return true, if '#{..}' and 'namespace.varName' qualified names are allowed"
^ ParserFlags allowQualifiedNames
+
+ "Modified (comment): / 23-09-2018 / 01:08:26 / Claus Gittinger"
!
allowQualifiedNames:aBoolean
@@ -419,6 +435,7 @@
!
allowSqueakExtensions
+ <resource: #obsolete>
"return true, if support for squeak extensions
computed arrays { .., }
c/java style arguments in message sends rec foo(arg1, ... argN)
@@ -444,6 +461,7 @@
!
allowUnderscoreInIdentifier
+ <resource: #obsolete>
"return true, if underscores are allowed in identifiers"
^ ParserFlags allowUnderscoreInIdentifier
@@ -469,6 +487,7 @@
!
warnCommonMistakes
+ <resource: #obsolete>
"return true, if common beginners mistakes are to be warned about"
^ ParserFlags warnCommonMistakes
@@ -488,6 +507,7 @@
!
warnDollarInIdentifier
+ <resource: #obsolete>
"return true, if $-characters in identifiers are to be warned about"
^ ParserFlags warnDollarInIdentifier
@@ -513,6 +533,7 @@
!
warnOldStyleAssignment
+ <resource: #obsolete>
"return true, if underscore-assignment (pre ST-80v4 syntax) are to be warned about"
^ ParserFlags warnOldStyleAssignment
@@ -529,6 +550,7 @@
!
warnPossibleIncompatibilities
+ <resource: #obsolete>
"return true, if possible incompatibilities (with other ST systems)
are to be warned about"
@@ -551,6 +573,7 @@
!
warnSTXSpecials
+ <resource: #obsolete>
"return true, if ST/X specials are to be warned about"
^ ParserFlags warnSTXSpecials
@@ -567,6 +590,7 @@
!
warnUnderscoreInIdentifier
+ <resource: #obsolete>
"return true, if underscores in identifiers are to be warned about"
^ ParserFlags warnUnderscoreInIdentifier
@@ -763,6 +787,17 @@
exitBlock := aBlock
!
+expectToken:expectedToken
+ token = expectedToken ifFalse:[
+ self parseError:('expected "',expectedToken asString,'"').
+ ^ false.
+ ].
+ self nextToken.
+ ^ true.
+
+ "Created: / 25-05-2019 / 23:32:54 / Claus Gittinger"
+!
+
getCollectedComments
"retrieve the so far collected comments, reset comment collection"
@@ -775,6 +810,14 @@
"Created: / 05-10-2011 / 10:09:01 / cg"
!
+hasError
+ "return true if there where any errors (valid after parsing)"
+
+ ^ errorFlag
+
+ "Created: / 23-05-2019 / 09:26:39 / Claus Gittinger"
+!
+
inArrayLiteral:aBoolean
inArrayLiteral := aBoolean
!
@@ -791,8 +834,13 @@
!
outStream:aStream
+ "if set, this stream gets the parsed comments as it is read.
+ Useful to collect comments while reading"
+
outStream := aStream.
outCol := outCol ? 1.
+
+ "Modified (comment): / 25-05-2019 / 23:45:57 / Claus Gittinger"
!
requestor
@@ -812,8 +860,8 @@
!
sourcePositionWithoutPeeks
-
| pos |
+
pos := self sourcePosition.
peekChar2 notNil ifTrue:[^ pos - 2].
peekChar notNil ifTrue:[^ pos - 1].
@@ -866,6 +914,7 @@
!Scanner methodsFor:'accessing-flags'!
allowDollarInIdentifier
+ <resource: #obsolete>
^ parserFlags allowDollarInIdentifier
!
@@ -874,6 +923,7 @@
!
allowLiteralNameSpaceSymbols
+ <resource: #obsolete>
^ parserFlags allowLiteralNameSpaceSymbols
!
@@ -882,6 +932,7 @@
!
allowOldStyleAssignment
+ <resource: #obsolete>
^ parserFlags allowOldStyleAssignment
!
@@ -890,6 +941,7 @@
!
allowSqueakExtensions
+ <resource: #obsolete>
"return true, if support for squeak extensions
computed arrays { .., }
c/java style arguments in message sends rec foo(arg1, ... argN)
@@ -908,6 +960,7 @@
!
allowUnderscoreInIdentifier
+ <resource: #obsolete>
^ parserFlags allowUnderscoreInIdentifier
!
@@ -933,6 +986,7 @@
!
warnCommonMistakes
+ <resource: #obsolete>
^ parserFlags warnCommonMistakes
!
@@ -941,6 +995,7 @@
!
warnDollarInIdentifier
+ <resource: #obsolete>
^ parserFlags warnDollarInIdentifier
!
@@ -949,6 +1004,7 @@
!
warnOldStyleAssignment
+ <resource: #obsolete>
^ parserFlags warnOldStyleAssignment
!
@@ -957,6 +1013,7 @@
!
warnPossibleIncompatibilities
+ <resource: #obsolete>
"return true, if possible incompatibilities (with other ST systems)
are to be warned about"
@@ -984,6 +1041,7 @@
!
warnUnderscoreInIdentifier
+ <resource: #obsolete>
^ parserFlags warnUnderscoreInIdentifier
!
@@ -1309,6 +1367,11 @@
"Created: / 1.4.1998 / 13:02:56 / cg"
!
+markErrorFrom:pos1 to:pos2
+
+ "Created: / 31.3.1998 / 13:34:45 / cg"
+!
+
markStringFrom:pos1 to:pos2
"Created: / 31.3.1998 / 16:37:18 / cg"
@@ -1321,6 +1384,22 @@
!Scanner methodsFor:'error handling'!
+actionToDisableWarning:warningSelector
+ "return an action for the do-not-show-again dialogs"
+
+ ^ [
+ |sel|
+
+ sel := warningSelector asMutator.
+ ParserFlags perform:sel with:false.
+ parserFlags perform:sel with:false ifNotUnderstood:[].
+ ]
+
+ "
+ self basicNew actionToDisableWarning:#warnAboutDeadCodeAndFixMe
+ "
+!
+
clearErrorFlag
errorFlag := false.
!
@@ -1333,10 +1412,15 @@
|correctIt|
requestor isNil ifTrue:[
-"/ self showErrorMessage:message position:pos1.
+ "/ self showErrorMessage:message position:pos1.
correctIt := false
] ifFalse:[
- correctIt := requestor correctableError:message position:pos1 to:pos2 from:self
+ self isDoIt ifTrue:[
+ requestor warning:message position:pos1 to:pos2 from:self.
+ correctIt := false.
+ ] ifFalse:[
+ correctIt := requestor correctableError:message position:pos1 to:pos2 from:self
+ ].
].
("correctIt == false or:["correctIt == #Error"]") ifTrue:[
@@ -1346,6 +1430,8 @@
^ correctIt
"Created: / 13-05-1998 / 16:45:56 / cg"
+ "Modified: / 13-06-2018 / 12:46:32 / Claus Gittinger"
+ "Modified: / 15-06-2018 / 14:55:26 / Stefan Vogel"
!
correctableSelectorWarning:message position:pos1 to:pos2
@@ -1457,20 +1543,44 @@
!
invalidCharacter:ch
- |errMsg v|
-
- v := ch codePoint.
- ch isPrintable ifTrue:[
- errMsg := 'Invalid character: ''' , ch asString , ''' ', '(' , (v radixPrintStringRadix:16) , ').'.
+ |errMsg codePoint|
+
+ codePoint := ch codePoint.
+ codePoint = 16r2190 "back arrow" ifTrue:[
+ errMsg := 'old style arrow for assignment: "' , ch asString , '" (' , (codePoint radixPrintStringRadix:16) , '). Please change this to ":="'.
] ifFalse:[
- errMsg := 'Invalid character: ' , (v radixPrintStringRadix:16) , '.'.
- ].
- v > 16r7F ifTrue:[
- errMsg := errMsg , '
-
-Notice:
- Only 7-bit ascii allowed (for compatibility with other Smalltalk dialects).
- You can enable some of the special characters via the compiler-settings dialog.'.
+
+ ch isPrintable ifTrue:[
+ errMsg := 'Invalid character: ''' , ch asString , ''' ', '(' , (codePoint radixPrintStringRadix:16) , ').'.
+ ] ifFalse:[
+ errMsg := 'Invalid character: ' , (codePoint radixPrintStringRadix:16) , '.'.
+ ].
+ codePoint > 16r7F ifTrue:[
+ errMsg := errMsg , '
+
+ Notice:
+ Only 7-bit ascii allowed (for compatibility with other Smalltalk dialects).
+ You can enable some of the special characters via the ',
+ ('compiler-settings dialog'
+ asActionLinkTo:[
+ |list|
+
+ list := #(
+ #('Tools/Compiler' #'AbstractSettingsApplication::GeneralCompilerSettingsAppl' )
+ #('Tools/Compiler/ByteCode' #'AbstractSettingsApplication::ByteCodeCompilerSettingsAppl' )
+ #('Tools/Compiler/STC' #'AbstractSettingsApplication::STCCompilerSettingsAppl' )
+ ).
+ SettingsDialog
+ openWithList:list
+ label:(i'Compiler Settings')
+ initialSettingsClass:AbstractSettingsApplication::ByteCodeCompilerSettingsAppl
+ ]
+ info:'Click to open settings'
+ ),'
+ or by setting "allowNationalCharactersInIdentifier" / "allowGreekCharactersInIdentifier"
+ in the ParserFlags.
+ Be aware, that the stc compiler does not currently support this.'.
+ ].
].
self syntaxError:errMsg position:tokenPosition to:tokenPosition.
source next.
@@ -1479,6 +1589,7 @@
^ #Error
"Modified: / 17-11-2016 / 09:37:52 / cg"
+ "Modified: / 08-06-2019 / 18:14:06 / Claus Gittinger"
!
lastTokenLineNumber
@@ -1490,7 +1601,7 @@
"Modified: 23.5.1997 / 12:16:12 / cg"
!
-notifyError:aMessage position:position to:endPos
+notifyError:aMessage as:errorClassOrNil position:position to:endPos lineNr:lineNrOrNil
"notify requestor of an error - if there is no requestor
put it on the transcript. Requestor is typically the CodeView
in which the accept/doIt was triggered, or the PositionableStream
@@ -1499,42 +1610,64 @@
Return the result passed back by the requestor."
(Smalltalk isInitialized not and:[Smalltalk isDebuggableApp]) ifTrue:[
- "/ error during startup, but sometimes we expect an error and want to suppress it
- Parser parseWarningSignal query ~~ #ignore ifTrue:[
- (self class name,' [error]: error during initialization:') errorPrint.
- aMessage errorPrintCR.
- thisContext fullPrintAll.
- ].
+ "/ error during startup, but sometimes we expect an error and want to suppress it
+ Parser parseWarningSignal query ~~ #ignore ifTrue:[
+ (self className,' [error]: error during initialization:') errorPrint.
+ aMessage errorPrintCR.
+ thisContext fullPrintAll.
+ ].
].
ignoreErrors ifTrue:[
- "/ usually done, when syntax highlighting or looking for used variables
- "/ self halt.
+ "/ usually done, when syntax highlighting or looking for used variables
+ "/ self halt.
] ifFalse:[
- "/ Raise an error.
- "/ For backward compatibility, if error IS NOT handled and requestor
- "/ IS set, then dispatch to requestor.
-
- "/ backward compatibility - will vanish eventually (use a handler, Luke)
- ("ParseError isHandled not and: ["requestor notNil"]") ifTrue:[
- requestor error:aMessage position:position to:endPos from:self.
- ^ self
- ].
- true "ParseError isHandled" ifTrue:[
- ParseError new
- errorMessage:aMessage startPosition:position endPosition:endPos;
- parameter:self;
- lineNumber:tokenLineNr; "lineNr"
- raiseRequest.
- ^ self
- ].
- self showErrorMessage:aMessage position:position.
+ "/ Raise an error.
+ "/ For backward compatibility, if requestor
+ "/ IS set, then dispatch to requestor.
+
+ "/ backward compatibility - will vanish eventually (use a handler, Luke)
+ requestor notNil ifTrue:[
+ requestor error:aMessage position:position to:endPos from:self.
+ ^ self
+ ].
+ (errorClassOrNil ? ParseError) new
+ errorMessage:aMessage startPosition:position endPosition:endPos;
+ parameter:self;
+ lineNumber:(lineNrOrNil ? tokenLineNr); "lineNr"
+ raiseRequest.
].
+ "Created: / 08-02-2019 / 11:15:37 / Claus Gittinger"
+ "Modified: / 28-06-2019 / 09:11:44 / Claus Gittinger"
+!
+
+notifyError:aMessage position:position to:endPos
+ "notify requestor of an error - if there is no requestor
+ put it on the transcript. Requestor is typically the CodeView
+ in which the accept/doIt was triggered, or the PositionableStream
+ which does the fileIn. The requestor may decide how to highlight the
+ error (and/or to abort the compile).
+ Return the result passed back by the requestor."
+
+ ^ self notifyError:aMessage position:position to:endPos lineNr:nil
+
"Modified: / 18-01-2012 / 14:54:22 / Alexander Zottnick"
"Modified: / 19-01-2012 / 10:18:36 / cg"
"Modified: / 02-05-2014 / 14:51:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 19-04-2018 / 10:39:56 / stefan"
+ "Modified: / 08-02-2019 / 11:15:59 / Claus Gittinger"
+!
+
+notifyError:aMessage position:position to:endPos lineNr:lineNrOrNil
+ "notify requestor of an error - if there is no requestor
+ put it on the transcript. Requestor is typically the CodeView
+ in which the accept/doIt was triggered, or the PositionableStream
+ which does the fileIn. The requestor may decide how to highlight the
+ error (and/or to abort the compile).
+ Return the result passed back by the requestor."
+
+ self notifyError:aMessage as:nil position:position to:endPos lineNr:lineNrOrNil
!
notifyWarning:aMessage doNotShowAgainAction:doNotShowAgainAction doNotShowAgainForThisMethodAction:doNotShowAgainForThisMethodAction position:position to:endPos
@@ -1612,6 +1745,29 @@
"Created: / 13.5.1998 / 16:45:13 / cg"
!
+parseError:aMessage as:errorClassOrNil position:position to:endPos
+ "report an error"
+
+ |fullMessage|
+
+ Smalltalk isInitialized ifFalse:[
+ (self className,' [error]: error during initialization:') errorPrint.
+ aMessage errorPrintCR.
+ thisContext fullPrintAll.
+ ].
+
+ "/ fullMessage := (self errorMessagePrefix) , ' ' , (aMessage ? '???').
+ fullMessage := (aMessage ? 'Unspecified error').
+ self setErrorFlag.
+ self notifyError:fullMessage as:errorClassOrNil position:position to:endPos lineNr:nil.
+ exitBlock value.
+ ^ false
+
+ "Created: / 13-05-1998 / 16:44:55 / cg"
+ "Modified: / 22-08-2006 / 14:13:11 / cg"
+ "Modified: / 28-06-2019 / 09:11:48 / Claus Gittinger"
+!
+
parseError:aMessage line:lNr
"report an error"
@@ -1636,23 +1792,7 @@
parseError:aMessage position:position to:endPos
"report an error"
- |fullMessage|
-
- Smalltalk isInitialized ifFalse:[
- (self class name,' [error]: error during initialization:') errorPrint.
- aMessage errorPrintCR.
- thisContext fullPrintAll.
- ].
-
- "/ fullMessage := (self errorMessagePrefix) , ' ' , (aMessage ? '???').
- fullMessage := (aMessage ? 'Unspecified error').
- self setErrorFlag.
- self notifyError:fullMessage position:position to:endPos.
- exitBlock value.
- ^ false
-
- "Created: / 13-05-1998 / 16:44:55 / cg"
- "Modified: / 22-08-2006 / 14:13:11 / cg"
+ self parseError:aMessage as:nil position:position to:endPos
!
positionFromLineNumber:lNr
@@ -1673,10 +1813,12 @@
(ignoreErrors or:[Smalltalk silentLoading]) ifFalse:[
Transcript showCR:('Scanner [<4p> line:<1p> off:<2p>]: <3p>'
- expandMacrosWith:tokenLineNr with:pos with:aMessage with:source).
+ expandMacrosWith:tokenLineNr
+ with:pos with:aMessage with:source).
]
- "Modified: 18.5.1996 / 15:44:35 / cg"
+ "Modified: / 18-05-1996 / 15:44:35 / cg"
+ "Modified (format): / 08-02-2019 / 11:05:35 / Claus Gittinger"
!
syntaxError:aMessage
@@ -1737,18 +1879,18 @@
"warn about $-character in an identifier"
ignoreWarnings ifFalse:[
- didWarnAboutDollarInIdentifier ifFalse:[
- parserFlags warnDollarInIdentifier ifTrue:[
- self
- warning:'$-characters in identifiers/symbols are nonportable'
- doNotShowAgainAction:[ ParserFlags warnDollarInIdentifier:false ]
- position:position to:position.
- "
- only warn once (per method)
- "
- didWarnAboutDollarInIdentifier := true
- ]
- ]
+ didWarnAboutDollarInIdentifier ifFalse:[
+ parserFlags warnDollarInIdentifier ifTrue:[
+ self
+ warning:'$-characters in identifiers/symbols are nonportable'
+ doNotShowAgainAction:(self actionToDisableWarning:#warnDollarInIdentifier)
+ position:position to:position.
+ "
+ only warn once (per method)
+ "
+ didWarnAboutDollarInIdentifier := true
+ ]
+ ]
]
"Created: 7.9.1997 / 01:50:24 / cg"
@@ -1759,41 +1901,41 @@
"warn about an oldStyle assignment"
ignoreWarnings ifFalse:[
- didWarnAboutOldStyleAssignment ifFalse:[
- parserFlags warnOldStyleAssignment ifTrue:[
- self
- warning:'Old style assignment - please change to use '':='''
- doNotShowAgainAction:[ ParserFlags warnOldStyleAssignment:false ]
- position:position to:position.
- ].
- "
- only warn once (per method)
- "
- didWarnAboutOldStyleAssignment := true
- ]
+ didWarnAboutOldStyleAssignment ifFalse:[
+ parserFlags warnOldStyleAssignment ifTrue:[
+ self
+ warning:'Old style assignment - please change to use '':='''
+ doNotShowAgainAction:(self actionToDisableWarning:#warnOldStyleAssignment)
+ position:position to:position.
+ ].
+ "
+ only warn once (per method)
+ "
+ didWarnAboutOldStyleAssignment := true
+ ]
]
"Modified: 23.5.1997 / 12:16:48 / cg"
!
warnParagraphAt:position
- "warn about §-character in an identifier"
+ "warn about §-character in an identifier"
ignoreWarnings ifFalse:[
- "/ didWarnAboutParagraphInIdentifier ifFalse:[
- parserFlags warnParagraphInIdentifier ifTrue:[
- self
- warning:'§-characters in identifiers/symbols are nonportable'
- doNotShowAgainAction:[ ParserFlags warnParagraphInIdentifier:false ]
- position:position to:position.
- "
- only warn once (per method)
- "
- parserFlags := parserFlags copy.
- parserFlags warnParagraphInIdentifier:false.
- "/ didWarnAboutParagraphInIdentifier := true
- ]
- "/ ]
+ "/ didWarnAboutParagraphInIdentifier ifFalse:[
+ parserFlags warnParagraphInIdentifier ifTrue:[
+ self
+ warning:'§-characters in identifiers/symbols are nonportable'
+ doNotShowAgainAction:(self actionToDisableWarning:#warnParagraphInIdentifier)
+ position:position to:position.
+ "
+ only warn once (per method)
+ "
+ parserFlags := parserFlags copy.
+ parserFlags warnParagraphInIdentifier:false.
+ "/ didWarnAboutParagraphInIdentifier := true
+ ]
+ "/ ]
]
"Created: / 17-11-2016 / 09:16:22 / cg"
@@ -1803,18 +1945,18 @@
"warn about a period in an identifier"
ignoreWarnings ifFalse:[
- didWarnAboutPeriodInSymbol ifFalse:[
- parserFlags warnAboutPeriodInSymbol ifTrue:[
- self
- warning:'Period in symbols are nonportable'
- doNotShowAgainAction:[ ParserFlags warnAboutPeriodInSymbol:false ]
- position:position to:position.
- "
- only warn once (per method)
- "
- didWarnAboutPeriodInSymbol := true
- ]
- ]
+ didWarnAboutPeriodInSymbol ifFalse:[
+ parserFlags warnAboutPeriodInSymbol ifTrue:[
+ self
+ warning:'Period in symbols are nonportable'
+ doNotShowAgainAction:(self actionToDisableWarning:#warnAboutPeriodInSymbol)
+ position:position to:position.
+ "
+ only warn once (per method)
+ "
+ didWarnAboutPeriodInSymbol := true
+ ]
+ ]
]
!
@@ -1822,13 +1964,12 @@
"warn about a possible incompatibility with other ST systems"
ignoreWarnings ifFalse:[
- parserFlags warnPossibleIncompatibilities ifTrue:[
- self
- warning:('Possible incompatibility.\\' , msg) withCRs
- doNotShowAgainAction:[ ParserFlags warnPossibleIncompatibilities:false.
- parserFlags warnPossibleIncompatibilities:false ]
- position:pos1 to:pos2.
- ]
+ parserFlags warnPossibleIncompatibilities ifTrue:[
+ self
+ warning:('Possible incompatibility.\\' , msg) withCRs
+ doNotShowAgainAction:(self actionToDisableWarning:#warnPossibleIncompatibilities)
+ position:pos1 to:pos2.
+ ]
]
"Created: 23.5.1997 / 12:17:54 / cg"
@@ -1837,20 +1978,19 @@
warnSTXSpecialCommentAt:position to:endPosition
ignoreWarnings ifFalse:[
- "/ dfo
- didWarnAboutSTXSpecialComment ifFalse:[
- parserFlags warnSTXSpecialComment ifTrue:[
- self
- warning:'End-of-line comments are a nonstandard feature of ST/X'
- doNotShowAgainAction:[ parserFlags warnSTXSpecialComment:false. ParserFlags warnSTXSpecials:false. ]
- doNotShowAgainForThisMethodAction: [ self disableWarningsOnCurrentMethodFor: #warnSTXSpecials ]
- position:position to:endPosition.
- "
- only warn once
- "
- didWarnAboutSTXSpecialComment := true
- ]
- ]
+ didWarnAboutSTXSpecialComment ifFalse:[
+ parserFlags warnSTXSpecialComment ifTrue:[
+ self
+ warning:'End-of-line comments are a nonstandard feature of ST/X'
+ doNotShowAgainAction:(self actionToDisableWarning:#warnSTXSpecials)
+ doNotShowAgainForThisMethodAction: [ self disableWarningsOnCurrentMethodFor: #warnSTXSpecials ]
+ position:position to:endPosition.
+ "
+ only warn once
+ "
+ didWarnAboutSTXSpecialComment := true
+ ]
+ ]
].
"Modified: / 16-03-2012 / 18:37:11 / cg"
@@ -1860,18 +2000,18 @@
"warn about an underscore in an identifier"
ignoreWarnings ifFalse:[
- didWarnAboutUnderscoreInIdentifier ifFalse:[
- parserFlags warnUnderscoreInIdentifier ifTrue:[
- self
- warning:'Underscores in identifiers/symbols are nonportable'
- doNotShowAgainAction:[ ParserFlags warnUnderscoreInIdentifier:false ]
- position:position to:position.
- "
- only warn once (per method)
- "
- didWarnAboutUnderscoreInIdentifier := true
- ]
- ]
+ didWarnAboutUnderscoreInIdentifier ifFalse:[
+ parserFlags warnUnderscoreInIdentifier ifTrue:[
+ self
+ warning:'Underscores in identifiers/symbols are nonportable'
+ doNotShowAgainAction:(self actionToDisableWarning:#warnUnderscoreInIdentifier)
+ position:position to:position.
+ "
+ only warn once (per method)
+ "
+ didWarnAboutUnderscoreInIdentifier := true
+ ]
+ ]
]
"Modified: 23.5.1997 / 12:17:06 / cg"
@@ -1944,7 +2084,7 @@
Return the number or nil. Leave the position of the stream after the number
or unchanged (if no number is coming)
Extension:
- since contant fractions (int/int) are treated like lexical tokens (not messages)
+ since constant fractions (int/int) are treated like lexical tokens (not messages)
in Smalltalk/X, this also reads fractions."
|oldPos posAfter denominator numerator parentized sign|
@@ -1989,8 +2129,7 @@
posAfter := posAfter - 1
].
tokenValue isInteger ifTrue:[
- source skipSeparators.
- source peekOrNil == $/ ifTrue:[
+ source skipSeparators == $/ ifTrue:[
numerator := tokenValue.
self nextToken. "/ skip /
"/ oops - must check for //
@@ -2043,8 +2182,10 @@
source position:oldPos.
^ nil.
- "Created: / 18.6.1998 / 23:05:22 / cg"
- "Modified: / 19.11.1999 / 18:25:52 / cg"
+ "Created: / 18-06-1998 / 23:05:22 / cg"
+ "Modified: / 19-11-1999 / 18:25:52 / cg"
+ "Modified (comment): / 23-05-2019 / 11:06:51 / Claus Gittinger"
+ "Modified: / 28-09-2019 / 15:21:32 / Stefan Vogel"
!
scanPositionsFor:aTokenString inString:aSourceString
@@ -2159,9 +2300,11 @@
"Created: / 07-12-2006 / 18:13:13 / cg"
!
-setSource:newSource
- source := newSource
-
+setSource:newSourceStream
+ source := newSourceStream
+
+ "Modified: / 07-08-2018 / 07:46:57 / Claus Gittinger"
+ "Modified (format): / 25-05-2019 / 23:47:16 / Claus Gittinger"
!
source:aStringOrStream
@@ -2175,13 +2318,14 @@
currentComments := nil.
aStringOrStream isStream ifFalse:[
- source := ReadStream on:aStringOrStream
+ source := ReadStream on:aStringOrStream string
] ifTrue:[
source := aStringOrStream.
].
"Modified: / 26-05-1999 / 12:02:16 / stefan"
"Modified: / 06-12-2011 / 00:45:50 / cg"
+ "Modified: / 10-02-2019 / 15:49:28 / Claus Gittinger"
! !
!Scanner methodsFor:'parser interface'!
@@ -2213,6 +2357,23 @@
^ self
!
+characterNamed:name
+ |idx|
+
+ idx := #(
+ 'nul' 'soh' 'stx' 'etx' 'eot' 'enq' 'ack' 'bel'
+ 'bs' 'ht' 'lf' 'vt' 'ff' 'cr' 'so' 'si'
+ 'dle' 'dc1' 'dc2' 'dc3' 'dc4' 'nak' 'syn' 'etb'
+ 'can' 'em' 'sub' 'esc' 'fs' 'gs' 'rs' 'us' ) indexOf:name.
+ idx == 0 ifTrue:[
+ name = 'tab' ifTrue:[ ^ Character tab ].
+ ^ nil
+ ].
+ ^ Character value:idx-1
+
+ "Created: / 08-02-2019 / 19:12:23 / Claus Gittinger"
+!
+
checkForKeyword:string
"check if string is a keyword (as opposed to an identifier).
That is, its one of 'self', 'super', 'nil', 'true', 'false',
@@ -2295,9 +2456,12 @@
"Created: / 14-03-2011 / 14:11:46 / cg"
!
-escapeCharacterFor:aCharacter
- "only if AllowExtendedSTXSyntax is true
- For now: do not use, since stc does not support it.
+escapeCharacterFor:aCharacter escapeStyle:escapeStyle
+ "only if AllowExtendedSTXSyntax or AllowCStrings
+ or AllowEStrings is true
+ For now: only use c-style, since stc does not support others.
+ 'c' - C-style escapes:
+ \n,\t,\r,\b,\xXX,\uXXXX,\UXXXXXX,
much like character escapes in C-literals;
expands:
@@ -2307,14 +2471,17 @@
\b backspace
\f formfeed
\g bell
-
- \\ backSlash
- \ ...\ (backslash-separator) ignored up to next backslash
- \xNN hexCharacter
- \uNNNN hex UnicodeCharacter
+ \0 nul
+
+ \\ backSlash
+ \ ...\ (backslash-separator) ignored up to next backslash
+ \xNN hexCharacter
+ \uNNNN hex UnicodeCharacter
+ \UNNNNNN hex UnicodeCharacter
+ \<name> named character
"
- |ascii nextChar fetchNext|
+ |ascii nextChar fetchNext name pos1|
aCharacter == $n ifTrue:[^ Character nl].
aCharacter == $r ifTrue:[^ Character return].
@@ -2322,7 +2489,33 @@
aCharacter == $b ifTrue:[^ Character backspace].
aCharacter == $f ifTrue:[^ Character ff].
aCharacter == $g ifTrue:[^ Character bell].
+ aCharacter == $0 ifTrue:[^ Character null].
aCharacter == $\ ifTrue:[^ aCharacter].
+
+ aCharacter == $< ifTrue:[
+ pos1 := source position.
+ name := ''.
+ nextChar := source next.
+ [nextChar notNil and:[nextChar ~~ $>]] whileTrue:[
+ nextChar isLetter ifFalse:[
+ self syntaxError:'letter expected in character name escape in string literal'
+ position:pos1 to:(source position).
+ ].
+ name size > 10 ifTrue:[
+ self syntaxError:'long character name escape in string literal'
+ position:pos1 to:(source position).
+ ].
+ name := name , nextChar.
+ nextChar := source next.
+ ].
+ nextChar := self characterNamed:name.
+ nextChar isNil ifTrue:[
+ self syntaxError:'invalid character name escape in string literal'
+ position:pos1 to:(source position).
+ ].
+ ^ nextChar
+ ].
+
aCharacter isSeparator ifTrue:[
nextChar := source next.
[nextChar notNil and:[nextChar ~~ $\]] whileTrue:[
@@ -2334,23 +2527,34 @@
^ nil
].
- (aCharacter == $x or:[ aCharacter == $u ]) ifTrue:[
+ (aCharacter == $x
+ or:[ (aCharacter == $u)
+ or:[ (aCharacter == $U) ]]
+ ) ifTrue:[
+ pos1 := source position.
+
fetchNext :=
[
nextChar := source next.
(nextChar notNil and:[nextChar isDigitRadix:16]) ifFalse:[
self syntaxError:'hex digit expected in string literal'
- position:(source position) to:(source position).
+ position:pos1 to:(source position).
+ 0
+ ] ifTrue:[
+ nextChar digitValue
].
- nextChar digitValue
].
ascii := fetchNext value.
ascii := (ascii bitShift:4) bitOr:(fetchNext value).
- (aCharacter == $u ) ifTrue:[
+ ((aCharacter == $u ) or:[(aCharacter == $U )]) ifTrue:[
ascii := (ascii bitShift:4) bitOr:(fetchNext value).
ascii := (ascii bitShift:4) bitOr:(fetchNext value).
+ (aCharacter == $U) ifTrue:[
+ ascii := (ascii bitShift:4) bitOr:(fetchNext value).
+ ascii := (ascii bitShift:4) bitOr:(fetchNext value).
+ ].
].
^ Character value:ascii.
].
@@ -2369,6 +2573,9 @@
"
ParserFlags allowExtendedSTXSyntax:false
"
+
+ "Created: / 11-02-2019 / 12:27:25 / Claus Gittinger"
+ "Modified: / 21-07-2019 / 08:20:08 / Claus Gittinger"
!
ignoreErrors
@@ -2447,6 +2654,16 @@
!Scanner methodsFor:'reading next token'!
+continueEscapedString
+ "after escaping out of a string with \{,
+ an expression was read by the parser and it found the terminating $}.
+ It calls this to continue reading the string..."
+
+ ^ self xnextString:$' escapeStyle:'e'
+
+ "Created: / 22-05-2019 / 20:24:51 / Claus Gittinger"
+!
+
nextAssignmentArrow
"return a left-arrow"
@@ -2455,6 +2672,19 @@
"Created: / 25-03-2011 / 13:58:50 / cg"
!
+nextBacktickIdentifier
+ "a single back-quote has been scanned;
+ scan up to the next back-tick, and return it as an identifier"
+
+ self nextString:$`.
+
+ tokenName := tokenValue.
+ tokenType := #Identifier.
+ ^ tokenType
+
+ "Created: / 07-08-2018 / 07:37:51 / Claus Gittinger"
+!
+
nextCharacter
"a $ has been read - return a character token"
@@ -2575,12 +2805,13 @@
a symbol,
HashLeftParen (for '#('),
HashLeftBrack (for '#['),
- HashLeftBrace (for '#{' and AllowQualifiedNames)
+ HashLeftBrace (for '#{' and AllowQualifiedNames/inline objects)
HashHashLeftParen (for '##(' and AllowDolphinExtensions)
HashHashLeftBrack (for '##[' )
HashHash (for '##' )
extended syntax (scheme-style literal arrays):
+ (requires ParserFlags allowSTXExtendedArrayLiterals:true)
HashTypedArrayParen (for '#u8(', '#s8(' , '#u16(' ...)
type in tokenValue: u1, u8, u16, u32, u64, s8, s16, s32, s64,
f16, f32, f64, f, d, b, B
@@ -2600,7 +2831,8 @@
].
(nextChar == $[ ) ifTrue:[
- "ST-80 & ST/X support Constant ByteArrays as #[...]"
+ "ST-80 & ST/X support Constant ByteArrays as #[...]
+ now all Smalltalk dialects do."
source next.
token := '#['.
tokenType := #HashLeftBrack.
@@ -2612,6 +2844,7 @@
#{ Foo.Bar.Baz } VW3 and later qualified name
#{ xx-xx-xx-xx-...-xx } StAgents UUID
#{ URL } url object qualifier
+ #{ key: value ... } inline literal object
"
source next.
token := '#{'.
@@ -2620,7 +2853,8 @@
].
(nextChar == $' ) ifTrue:[
- "ST-80 and ST/X support arbitrary symbols as #'...'"
+ "ST-80 and ST/X support arbitrary symbols as #'...'
+ now all dialects do"
self nextString:nextChar.
self markSymbolFrom:tokenPosition to:(source position).
tokenType == #EOF ifFalse:[
@@ -2638,7 +2872,7 @@
nextChar := source nextPeek.
nextChar == $( ifTrue:[
parserFlags allowDolphinExtensions == true ifTrue:[
- "dolphin does computed literals as ##( ... )"
+ "dolphin does computed literals as ##( expression )"
source next.
token := '##('.
tokenType := #HashHashLeftParen.
@@ -2654,6 +2888,7 @@
].
parserFlags allowVisualAgeESSymbolLiterals == true ifTrue:[
+ "V'age has special ESsymbols as ##name or ##'name'"
(self nextSymbolAfterHash) notNil ifTrue:[
tokenType := #ESSymbol.
^ #ESSymbol
@@ -2671,36 +2906,46 @@
^ tokenType
].
- parserFlags allowSTXExtendedArrayLiterals ifTrue:[
- "/ scheme-style typed literal array extension
- ('usfdbB' includes:nextChar) ifTrue:[
- |prefix|
-
- prefix := String with:nextChar.
+ "/ scheme-style typed literal arrays:
+ "/ #uXX( ... ) XX = { 1, 8, 16, 32, 64 } - bit, uint8, uint16, uint32 or uint64 array
+ "/ #iXX( ... ) XX = { 8, 16, 32, 64 } - int8, int16, int32 or int64 array
+ "/ #fXX( ... ) XX = { 16, 32, 64 } - IEEE half, single or double array
+ "/ #f( ... ) - IEEE single float array (same as #f32)
+ "/ #d( ... ) - IEEE double array (same as #f64)
+ "/ #b( ... ) - bit array (same as #u1)
+ "/ #B( ... ) - boolean array
+ ('usfdbB' includes:nextChar) ifTrue:[
+ |prefix|
+
+ "/ collec tuntil we know what we get...
+ prefix := String with:nextChar.
+ nextChar := source nextPeek.
+ [nextChar notNil and:[nextChar isDigit]] whileTrue:[
+ prefix := prefix copyWith:nextChar.
nextChar := source nextPeek.
- [nextChar notNil and:[nextChar isDigit]] whileTrue:[
- prefix := prefix copyWith:nextChar.
- nextChar := source nextPeek.
+ ].
+ nextChar == $( ifTrue:[
+ parserFlags allowSTXExtendedArrayLiterals ifFalse:[
+ self parseError:c'Non-Standard ST/X extension used: #XXX( .. ) unboxed array literal.\nPlease enable "allowSTXExtendedArrayLiterals" in the ParserFlags'
+ position:tokenPosition to:source position
].
- nextChar == $( ifTrue:[
- source next.
- (
- #( 'f' 'd' 'b' 'B'
- 'u1' 'u8' 'u16' 'u32' 'u64'
- 's8' 's16' 's32' 's64'
- 'f16' 'f32' 'f64'
- ) includes:prefix
- ) ifTrue:[
- tokenType := #HashTypedArrayParen.
- tokenValue := prefix asSymbol.
- ^ tokenType
- ].
- self parseError:'unsupported literal array type: ',prefix.
- tokenType := #HashLeftParen.
- ^ #HashLeftParen
+ source next.
+ (
+ #( 'f' 'd' 'b' 'B'
+ 'u1' 'u8' 'u16' 'u32' 'u64'
+ 's8' 's16' 's32' 's64'
+ 'f16' 'f32' 'f64'
+ ) includes:prefix
+ ) ifTrue:[
+ tokenType := #HashTypedArrayParen.
+ tokenValue := prefix asSymbol.
+ ^ tokenType
].
- ^ self nextSymbolAfterHash:prefix.
+ self parseError:'unsupported literal array type: ',prefix.
+ tokenType := #HashLeftParen.
+ ^ #HashLeftParen
].
+ ^ self nextSymbolAfterHash:prefix.
].
(self nextSymbolAfterHash) notNil ifTrue:[
@@ -2731,6 +2976,7 @@
"Modified: / 01-08-2006 / 14:57:19 / cg"
"Modified (format): / 30-09-2011 / 12:23:04 / cg"
+ "Modified: / 30-05-2019 / 19:06:36 / Claus Gittinger"
!
nextId
@@ -2764,148 +3010,172 @@
!
nextIdentifier
- "an alpha character (or underscore if AllowUnderscore) has been read.
+ "an alpha character
+ (or underscore if AllowUnderscore,
+ or greek if allowGreekCharactersInIdentifier
+ or national letter if allowNationalCharactersInIdentifier)
+ has been read.
Return the next identifier."
|nextChar string ok pos ch2
allowUnderscoreInIdentifier allowDollarInIdentifier
- allowNationalCharactersInIdentifier|
+ allowParagraphInIdentifier
+ allowNationalCharactersInIdentifier allowGreekCharactersInIdentifier|
allowUnderscoreInIdentifier := parserFlags allowUnderscoreInIdentifier.
allowDollarInIdentifier := parserFlags allowDollarInIdentifier.
+ allowParagraphInIdentifier := parserFlags allowParagraphInIdentifier.
allowNationalCharactersInIdentifier := parserFlags allowNationalCharactersInIdentifier.
+ allowGreekCharactersInIdentifier := parserFlags allowGreekCharactersInIdentifier.
hereChar == $_ ifTrue:[
- "/
- "/ no need to check for allowUnderscoreInIdentifier here;
- "/ could not arrive here if it was off
- "/
- nextChar := source nextPeek.
- parserFlags allowOldStyleAssignment ifTrue:[
- (nextChar notNil and:[ nextChar isLetterOrDigit or:[nextChar == $_]]) ifFalse:[
- "oops: a single underscore is an old-style assignement"
- nextChar == $: ifFalse:[
- self warnOldStyleAssignmentAt:tokenPosition.
- tokenType := token := $_.
- ^ tokenType
- ]
- ].
- ].
- string := '_'.
- self warnUnderscoreAt:tokenPosition.
- [nextChar == $_] whileTrue:[
- string := string copyWith:$_.
- nextChar := source nextPeek.
- ].
- (nextChar notNil and:[nextChar isLetterOrDigit]) ifTrue:[
- string := string , source nextAlphaNumericWord.
- ]
+ "/
+ "/ no need to check for allowUnderscoreInIdentifier here;
+ "/ could not arrive here if it was off
+ "/
+ nextChar := source nextPeek.
+ parserFlags allowOldStyleAssignment ifTrue:[
+ (nextChar notNil and:[ nextChar isLetterOrDigitOrUnderline]) ifFalse:[
+ "oops: a single underscore is an old-style assignement"
+ nextChar == $: ifFalse:[
+ self warnOldStyleAssignmentAt:tokenPosition.
+ tokenType := token := $_.
+ ^ tokenType
+ ]
+ ].
+ ].
+ string := '_'.
+ self warnUnderscoreAt:tokenPosition.
+ [nextChar == $_] whileTrue:[
+ string := string copyWith:$_.
+ nextChar := source nextPeek.
+ ].
+ (nextChar notNil and:[nextChar isLetterOrDigit]) ifTrue:[
+ string := string , source nextAlphaNumericWord.
+ ]
] ifFalse:[
- nextChar := source peekOrNil.
- (nextChar notNil and:[nextChar isLetterOrDigit]) ifTrue:[
- string := source nextAlphaNumericWord "self nextId".
- ] ifFalse:[
- string := ''
- ]
+ nextChar := source peekOrNil.
+ (nextChar notNil and:[nextChar isLetterOrDigit]) ifTrue:[
+ string := source nextAlphaNumericWord "self nextId".
+ ] ifFalse:[
+ string := ''
+ ]
].
nextChar := source peekOrNil.
+ ((nextChar == $')
+ and:[ (string size == 1)
+ and:[ ((parserFlags allowCStrings and:[string = 'c'])
+ or:[(parserFlags allowEStrings and:[string = 'e'])
+ or:[(parserFlags allowRStrings and:[string = 'r'])
+ or:[(parserFlags allowIStrings and:[string = 'i'])
+ or:[parserFlags allowExtendedSTXSyntax ]]]]) ]]
+ ) ifTrue:[
+ source next.
+ ^ self xnextString:$' escapeStyle:string
+ ].
+
(((nextChar == $_) and:[allowUnderscoreInIdentifier])
- or:[ (allowDollarInIdentifier and:[nextChar == $$ ])
- or:[ (nextChar == $§ and:[ parserFlags allowParagraphInIdentifier])
- or:[ allowNationalCharactersInIdentifier and:[ nextChar notNil and:[nextChar isNationalLetter]]]]]) ifTrue:[
- pos := source position + 1.
- nextChar == $_ ifTrue:[
- self warnUnderscoreAt:pos.
- ] ifFalse:[
- nextChar == $$ ifTrue:[
- self warnDollarAt:pos.
- ] ifFalse:[
- nextChar == $§ ifTrue:[
- self warnParagraphAt:pos.
- ] ifFalse:[
- "/ self warnNationalCharacterAt:pos.
- ]
- ]
- ].
- ok := true.
- [ok] whileTrue:[
- string := string copyWith:nextChar.
- nextChar := source nextPeek.
- nextChar isNil ifTrue:[
- ok := false
- ] ifFalse:[
- (nextChar isLetterOrDigit) ifTrue:[
- string := string , source nextAlphaNumericWord.
- nextChar := source peekOrNil.
- ].
- ok := ((nextChar == $_) and:[allowUnderscoreInIdentifier])
- or:[((nextChar == $$ ) and:[allowDollarInIdentifier])
- or:[((nextChar == $§ ) and:[parserFlags allowParagraphInIdentifier])
- or:[(nextChar notNil and:[nextChar isNationalLetter]) and:[allowNationalCharactersInIdentifier]]]].
- ]
- ].
+ or:[ (allowDollarInIdentifier and:[nextChar == $$ ])
+ or:[ (nextChar == $§ and:[ allowParagraphInIdentifier])
+ or:[ (allowNationalCharactersInIdentifier and:[ nextChar notNil and:[nextChar isNationalLetter]])
+ or:[ (allowGreekCharactersInIdentifier and:[ nextChar notNil and:[nextChar isNationalLetter]])
+ ]]]]) ifTrue:[
+ pos := source position + 1.
+ nextChar == $_ ifTrue:[
+ self warnUnderscoreAt:pos.
+ ] ifFalse:[
+ nextChar == $$ ifTrue:[
+ self warnDollarAt:pos.
+ ] ifFalse:[
+ nextChar == $§ ifTrue:[
+ self warnParagraphAt:pos.
+ ] ifFalse:[
+ "/ self warnNationalCharacterAt:pos.
+ ]
+ ]
+ ].
+ ok := true.
+ [ok] whileTrue:[
+ string := string copyWith:nextChar.
+ nextChar := source nextPeek.
+ nextChar isNil ifTrue:[
+ ok := false
+ ] ifFalse:[
+ (nextChar isLetterOrDigit) ifTrue:[
+ string := string , source nextAlphaNumericWord.
+ nextChar := source peekOrNil.
+ ].
+ ok := ((nextChar == $_) and:[allowUnderscoreInIdentifier])
+ or:[((nextChar == $$ ) and:[allowDollarInIdentifier])
+ or:[((nextChar == $§ ) and:[allowParagraphInIdentifier])
+ or:[(nextChar notNil and:[allowNationalCharactersInIdentifier and:[nextChar isNationalLetter]])
+ or:[(nextChar notNil and:[allowGreekCharactersInIdentifier and:[nextChar isGreekLetter]])
+ ]]]].
+ ].
+ ].
].
(nextChar == $: and:[scanColonAsKeyword]) ifTrue:[
- source next.
- ch2 := source peekOrNil.
- "/ colon follows - care for '::' (nameSpace separator) or ':=' (assignment)
- (ch2 == $=) ifFalse:[
- (ch2 == $:) ifFalse:[
- tokenName := token := string copyWith:nextChar.
- tokenType := #Keyword.
- inArrayLiteral == true ifTrue:[
- (ch2 isLetter
- or:[ch2 == $_ and:[allowUnderscoreInIdentifier]]) ifTrue:[
- "/ kludge: recurse to read the rest.
- self nextIdentifier.
- tokenName := token := (string copyWith:nextChar) , token.
- tokenType ~~ #Keyword ifTrue:[
- self syntaxError:'invalid keyword symbol in array constant'
- position:tokenPosition to:(source position).
- ].
- tokenType := #Keyword.
- ].
- ].
- ^ tokenType
- ].
- peekChar := $:.
- peekChar2 := $:.
- ] ifTrue:[
- peekChar := $:.
- peekChar2 := $=.
- ]
+ source next.
+ ch2 := source peekOrNil.
+ "/ colon follows - care for '::' (nameSpace separator) or ':=' (assignment)
+ (ch2 == $=) ifFalse:[
+ (ch2 == $:) ifFalse:[
+ tokenName := token := string copyWith:nextChar.
+ tokenType := #Keyword.
+ inArrayLiteral == true ifTrue:[
+ (ch2 isLetter
+ or:[ch2 == $_ and:[allowUnderscoreInIdentifier]]) ifTrue:[
+ "/ kludge: recurse to read the rest.
+ self nextIdentifier.
+ tokenName := token := (string copyWith:nextChar) , token.
+ tokenType ~~ #Keyword ifTrue:[
+ self syntaxError:'invalid keyword symbol in array constant'
+ position:tokenPosition to:(source position).
+ ].
+ tokenType := #Keyword.
+ ].
+ ].
+ ^ tokenType
+ ].
+ peekChar := $:.
+ peekChar2 := $:.
+ ] ifTrue:[
+ peekChar := $:.
+ peekChar2 := $=.
+ ]
] ifFalse:[
- (nextChar == $. and:[parserFlags allowQualifiedNames]) ifTrue:[
- "/ period follows - if next-after character is an identifier character,
- "/ make peekSym a #NameSpaceSeparator; otherwise a $.
- source next.
- ch2 := source peekOrNil.
- (ch2 notNil
- and:[ch2 isLetter or:[ch2 == $_ and:[allowUnderscoreInIdentifier]]]) ifTrue:[
- peekChar := #'::'.
- ] ifFalse:[
- peekChar := $.
- ].
- ].
+ (nextChar == $. and:[parserFlags allowQualifiedNames]) ifTrue:[
+ "/ period follows - if next-after character is an identifier character,
+ "/ make peekSym a #NameSpaceSeparator; otherwise a $.
+ source next.
+ ch2 := source peekOrNil.
+ (ch2 notNil
+ and:[ch2 isLetter or:[ch2 == $_ and:[allowUnderscoreInIdentifier]]]) ifTrue:[
+ peekChar := #'::'.
+ ] ifFalse:[
+ peekChar := $.
+ ].
+ ].
].
nextChar == $- ifTrue:[
- pos := source position + 1.
- self
- warnPossibleIncompatibility:'add spaces around ''-'' for compatibility with other systems'
- position:pos to:pos.
+ pos := source position + 1.
+ self
+ warnPossibleIncompatibility:'add spaces around ''-'' for compatibility with other systems'
+ position:pos to:pos.
].
tokenName := token := string.
(self checkForKeyword:string) ifFalse:[
- tokenType := #Identifier.
+ tokenType := #Identifier.
].
^ tokenType
"Created: / 13-09-1995 / 12:56:42 / claus"
"Modified: / 17-11-2016 / 09:19:46 / cg"
+ "Modified: / 08-06-2019 / 18:25:35 / Claus Gittinger"
!
nextMantissa:radix
@@ -2928,150 +3198,268 @@
nextNumber
"scan a number; handles radix prefix, mantissa and exponent.
Allows for
- e, d or q to be used as exponent limiter (for float or long float),
- s for scaled fixpoint numbers,
- f for single precision floats.
- i.e. 1e5 -> float (technically a c-double precision IEEE)
- 1d5 -> float (also, a c-double precision IEEE)
- 1q5 -> long float (a c-long double)
- 1s -> a fixed point with precision from number of digits given.
- 1s5 -> a fixed point with 5 digits precision.
- 1f5 -> shortFloat (technically a c-single precision IEEE float).
- 1f -> shortFloat (technically a c-single precision IEEE float).
- 1d -> shortFloat (technically a c-single precision IEEE float).
- 1q -> shortFloat (technically a c-single precision IEEE float).
+ e, d or q to be used as exponent limiter (for float or long float),
+ s for scaled fixpoint numbers,
+ f for single precision floats (controlled by parserFlags).
+
+ i.e. 1e5 -> float (technically a double precision IEEE)
+ 1d5 -> float (also, a double precision IEEE)
+ 1q5 -> long float (a c-long double / extended or quad precision IEEE, dep. on CPU)
+ 1Q5 -> quad float (quad precision IEEE)
+ 1QD5 -> qDouble float (4*double precision)
+ 1QL5 -> large float (arbitrary precision)
+ 1s -> a fixed point with precision from number of digits given.
+ 1s5 -> a fixed point with 5 digits precision.
+ 1d -> float (technically a double precision IEEE float).
+ 1q -> long float (technically a c-long double / extended or quad precision IEEE float, dep. on CPU).
+ 1Q -> quad float (quad precision IEEE)
+
+ 1f5 -> shortFloat (technically a single precision IEEE float) or float, dep on parserFlags.
+ 1f -> shortFloat (technically a single precision IEEE float) or float, dep on parserFlags.
support for scaled decimals can be disabled, if code needs to be read,
- which does not know about them (very unlikely)"
+ which does not know about them (very unlikely).
+ support for single prec. floats with f/F is controlled by a parser flag"
|pos1 nextChar value integerPart sign
- expSign tokenRadix mantissaAndScaledPart d type exp scale|
+ expSign tokenRadix mantissaAndScaledPart d type exp scale
+ kindChar kindClass chars |
tokenRadix := 10.
sign := 1.
type := #Integer.
pos1 := source position + 1.
- value := Integer readFrom:source radix:tokenRadix.
- nextChar := source peekOrNil.
- (nextChar == $r) ifTrue:[
- tokenRadix := value.
- source next.
-
- (tokenRadix between:2 and:36) ifFalse:[
- self syntaxError:'bad radix (must be 2 .. 36)'
- position:tokenPosition to:(source position).
- ].
- source peekOrNil == $- ifTrue:[
- source next.
- sign := -1
- ].
- value := Integer readFrom:source radix:tokenRadix.
- nextChar := source peekOrNil.
+ parserFlags allowCIntegers ifTrue:[
+ source peek == $0 ifTrue:[
+ nextChar := source nextPeek.
+ nextChar == $x ifTrue:[
+ source next.
+ ((source peek ? $.) isDigitRadix:16) ifFalse:[
+ self syntaxError:'invalid cStyle integer (hex digit expected)'
+ position:tokenPosition to:(source position).
+ ].
+ value := Integer readFrom:source radix:16.
+ sign < 0 ifTrue:[ value := value negated ].
+ tokenValue := token := value.
+ tokenType := type.
+ ^ tokenType
+ ].
+ nextChar == $o ifTrue:[
+ source next.
+ ((source peek ? $.) isDigitRadix:8) ifFalse:[
+ self syntaxError:'invalid cStyle integer (octal digit expected)'
+ position:tokenPosition to:(source position).
+ ].
+ value := Integer readFrom:source radix:8.
+ sign < 0 ifTrue:[ value := value negated ].
+ tokenValue := token := value.
+ tokenType := type.
+ ^ tokenType
+ ].
+ nextChar == $b ifTrue:[
+ source next.
+ ((source peek ? $.) isDigitRadix:2) ifFalse:[
+ self syntaxError:'invalid cStyle integer (binary digit expected)'
+ position:tokenPosition to:(source position).
+ ].
+ value := Integer readFrom:source radix:2.
+ sign < 0 ifTrue:[ value := value negated ].
+ tokenValue := token := value.
+ tokenType := type.
+ ^ tokenType
+ ].
+ (nextChar notNil
+ and:[ nextChar isDigit or:[nextChar == $.]]) ifFalse:[
+ tokenValue := token := 0.
+ tokenType := type.
+ ^ tokenType
+ ].
+ value := 0.
+ ].
+ ].
+ nextChar == $. ifFalse:[
+ value := Integer readFrom:source radix:tokenRadix.
+ nextChar := source peekOrNil.
+ (nextChar == $r) ifTrue:[
+ tokenRadix := value.
+ source next.
+ (tokenRadix between:2 and:36) ifFalse:[
+ self syntaxError:'bad radix (must be 2 .. 36)'
+ position:tokenPosition to:(source position).
+ ].
+ source peekOrNil == $- ifTrue:[
+ source next.
+ sign := -1
+ ].
+ pos1 := source position + 1.
+ value := Integer readFrom:source radix:tokenRadix.
+ nextChar := source peekOrNil.
+ ].
].
(nextChar == $.) ifTrue:[
- nextChar := source nextPeek.
- (nextChar notNil and:[nextChar isDigitRadix:tokenRadix]) ifTrue:[
- (tokenRadix > 13 and:[nextChar == $d or:[nextChar == $D]]) ifTrue:[
- self warning:'float with radix > 13 - (d/D are valid digits; not exponent-leaders)'
- position:tokenPosition to:(source position).
- ].
- (tokenRadix > 14 and:[nextChar == $e or:[nextChar == $E]]) ifTrue:[
- self warning:'float with radix > 14 - (e/E are valid digits; not exponent-leaders)'
- position:tokenPosition to:(source position).
- ].
- mantissaAndScaledPart := self nextMantissaAndScaledPartWithRadix:tokenRadix.
- integerPart := value.
- value := integerPart + (mantissaAndScaledPart first). "could be a longFloat now"
- type := #Float.
- nextChar := source peekOrNil
- ] ifFalse:[
- ('eEdDqQfF' includes:nextChar) ifTrue:[
- "/ allow 5.e-3 - is this standard ?
-
- ] ifFalse:[
+ nextChar := source nextPeek.
+ (nextChar notNil and:[nextChar isDigitRadix:tokenRadix]) ifTrue:[
+ (tokenRadix > 13) ifTrue:[
+ (nextChar == $d or:[nextChar == $D]) ifTrue:[
+ self warning:'float with radix > 13 - (d/D are valid digits; not exponent-leaders)'
+ position:tokenPosition to:(source position).
+ ].
+ (tokenRadix > 14) ifTrue:[
+ (nextChar == $e or:[nextChar == $E]) ifTrue:[
+ self warning:'float with radix > 14 - (e/E are valid digits; not exponent-leaders)'
+ position:tokenPosition to:(source position).
+ ].
+ (tokenRadix > 15) ifTrue:[
+ (nextChar == $f or:[nextChar == $F]) ifTrue:[
+ self warning:'float with radix > 15 - (f/F are valid digits; not exponent-leaders)'
+ position:tokenPosition to:(source position).
+ ]
+ ]
+ ]
+ ].
+ mantissaAndScaledPart := self nextMantissaAndScaledPartWithRadix:tokenRadix.
+ integerPart := value.
+ value := integerPart + (mantissaAndScaledPart first). "could be a longFloat now"
+ type := #Float.
+ nextChar := source peekOrNil
+ ] ifFalse:[
+ ('eEdDqQfF' includes:nextChar) ifTrue:[
+ "/ allow 5.e-3 - is this standard ?
+
+ ] ifFalse:[
"/ nextChar == (Character cr) ifTrue:[
"/ lineNr := lineNr + 1.
"/ ].
- nextChar := peekChar := $..
- ]
- ]
+ nextChar := peekChar := $..
+ ]
+ ]
].
('eEdDqQfF' includes:nextChar) ifTrue:[
- (nextChar == $q or:[nextChar == $Q]) ifTrue:[
- value := value asLongFloat
- ] ifFalse:[
- false "(nextChar == $f or:[nextChar == $F])" ifTrue:[
- value := value asShortFloat
- ] ifFalse:[
- value := value asFloat.
- ].
- ].
- type := #Float.
- nextChar := source nextPeek.
- (nextChar notNil and:[(nextChar isDigit"Radix:tokenRadix") or:['+-' includes:nextChar]]) ifTrue:[
- expSign := 1.
- (nextChar == $+) ifTrue:[
- nextChar := source nextPeek
- ] ifFalse:[
- (nextChar == $-) ifTrue:[
- nextChar := source nextPeek.
- expSign := -1
- ]
- ].
- exp := (Integer readFrom:source) * expSign.
- value := value * ((value class unity * tokenRadix) raisedToInteger:exp).
- nextChar := source peek.
- ].
+ kindClass := Float.
+ kindChar := nextChar.
+ nextChar := source nextPeek.
+ (kindChar == $q or:[kindChar == $Q]) ifTrue:[
+ (kindChar == $Q) ifTrue:[
+ nextChar == $D ifTrue:[
+ kindClass := QDouble.
+ value := value asQDouble.
+ nextChar := source nextPeek.
+ ] ifFalse:[
+ nextChar == $L ifTrue:[
+ kindClass := LargeFloat.
+ value := value asLargeFloat.
+ nextChar := source nextPeek.
+ ] ifFalse:[
+ kindClass := QuadFloat.
+ value := value asQuadFloat
+ ].
+ ].
+ ] ifFalse:[
+ kindClass := LongFloat.
+ value := value asLongFloat
+ ].
+ ] ifFalse:[
+ ((kindChar == $f or:[kindChar == $F]) and:[parserFlags singlePrecisionFloatF]) ifTrue:[
+ kindClass := ShortFloat.
+ value := value asShortFloat
+ ] ifFalse:[
+ value := value asFloat.
+ ].
+ ].
+ type := #Float.
+ (nextChar notNil and:[(nextChar isDigit"Radix:tokenRadix") or:['+-' includes:nextChar]]) ifTrue:[
+ expSign := 1.
+ (nextChar == $+) ifTrue:[
+ nextChar := source nextPeek
+ ] ifFalse:[
+ (nextChar == $-) ifTrue:[
+ nextChar := source nextPeek.
+ expSign := -1
+ ]
+ ].
+ exp := (Integer readFrom:source) * expSign.
+ value := value * ((value class unity * tokenRadix) raisedToInteger:exp).
+
+ nextChar := source peek.
+
+ "/ due to a strange overflow, we might get a Nan, although we
+ "/ are actually still in the float range.
+ "/ happens eg. for 1.7976931348623157e+308
+
+ "/ Also, the above raisedToInteger generates an additional error,
+ "/ which is not present, if we use the strtox functions from the C-library.
+ "/ Therefore, always use the low level fastFromString: converter.
+
+ "/ However: it only accepts decimal radix
+ tokenRadix = 10 ifTrue:[
+ Error handle:[:ex |
+ "/ self halt.
+ ] do:[
+ chars := (source collection copyFrom:pos1 to:source position) string asSingleByteStringIfPossible.
+ value := kindClass fastFromString:chars at:1.
+ ].
+ ].
+ ].
] ifFalse:[
- value isLimitedPrecisionReal ifTrue:[
- "/ no type specified - makes it a float
- value := value asFloat.
- ].
-
- parserFlags allowFixedPointLiterals == true ifTrue:[
- "/ ScaledDecimal numbers
- ('s' includes:nextChar) ifTrue:[
- nextChar := source nextPeek.
-
- (nextChar notNil and:[(nextChar isDigit)]) ifTrue:[
- scale := (Integer readFrom:source).
- ].
-
- mantissaAndScaledPart isNil ifTrue:[
- value := value asFixedPoint:(scale ? 0)
- ] ifFalse:[
- d := 10 raisedTo:(mantissaAndScaledPart last).
- value := FixedPoint
- numerator:((integerPart * d) + mantissaAndScaledPart second)
- denominator:d
- scale:(scale ? mantissaAndScaledPart last).
- ].
- type := #FixedPoint.
- self
- warnPossibleIncompatibility:'fixedPoint literal might be incompatibile with other systems'
- position:pos1 to:source position + 1.
- ].
- ].
+ value isLimitedPrecisionReal ifTrue:[
+ "/ fastFromString only accepts decimal radix
+ tokenRadix = 10 ifTrue:[
+ "/ no type specified - makes it a float
+ "/ value := value asFloat.
+ Error handle:[:ex |
+ value := value asFloat
+ ] do:[
+ chars := (source collection copyFrom:pos1 to:source position) asSingleByteStringIfPossible.
+ value := Float fastFromString:chars at:1.
+ ].
+ ].
+ ].
+
+ parserFlags allowFixedPointLiterals ifTrue:[
+ "/ ScaledDecimal numbers
+ ('s' includes:nextChar) ifTrue:[
+ nextChar := source nextPeek.
+
+ (nextChar notNil and:[(nextChar isDigit)]) ifTrue:[
+ scale := (Integer readFrom:source).
+ ].
+
+ mantissaAndScaledPart isNil ifTrue:[
+ value := value asFixedPoint:(scale ? 0)
+ ] ifFalse:[
+ d := 10 raisedTo:(mantissaAndScaledPart last).
+ value := FixedPoint
+ numerator:((integerPart * d) + mantissaAndScaledPart second)
+ denominator:d
+ scale:(scale ? mantissaAndScaledPart last).
+ ].
+ type := #FixedPoint.
+ self
+ warnPossibleIncompatibility:'fixedPoint literal might be incompatibile with other systems'
+ position:pos1 to:source position + 1.
+ ].
+ ].
].
nextChar == $- ifTrue:[
- self
- warnPossibleIncompatibility:'add a space before ''-'' for compatibility with other systems'
- position:(source position + 1) to:(source position + 1).
+ self
+ warnPossibleIncompatibility:'add a space before ''-'' for compatibility with other systems'
+ position:(source position + 1) to:(source position + 1).
].
- tokenValue := token := value * sign.
+ tokenValue := token := (sign < 0) ifTrue:[value negated] ifFalse:[value].
tokenType := type.
(tokenValue isLimitedPrecisionReal) ~~ (tokenType == #Float) ifTrue:[
- self shouldImplement.
+ self shouldImplement.
].
"/ self markConstantFrom:tokenPosition to:(source position - 1).
^ tokenType
"Modified: / 15-06-2017 / 11:07:52 / cg"
+ "Modified: / 11-06-2019 / 00:41:00 / Claus Gittinger"
!
nextPrimitive
@@ -3130,162 +3518,160 @@
|secondChar thirdChar fourthChar string p|
secondChar := source peekOrNil.
- ((firstChar == $-) and:[secondChar notNil]) ifTrue:[
- secondChar isDigit ifTrue:[
- self nextNumber.
- tokenValue := token := tokenValue negated.
- ^ tokenType
- ]
+ ((firstChar == $-)
+ and:[secondChar notNil
+ and:[secondChar isDigit
+ ]]) ifTrue:[
+ self nextNumber.
+ tokenValue := token := tokenValue negated.
+ ^ tokenType
].
string := firstChar asString.
"/ changed: do not allow second char to be a hash
"/ unless the first is also.
secondChar == $# ifTrue:[
- (parserFlags allowHashAsBinarySelector
- and:[firstChar == $#]) ifFalse:[
- tokenName := token := string.
- tokenType := #BinaryOperator.
- ^ tokenType
- ].
+ (parserFlags allowHashAsBinarySelector
+ and:[firstChar == $#]) ifFalse:[
+ tokenName := token := string.
+ tokenType := #BinaryOperator.
+ ^ tokenType
+ ].
].
secondChar notNil ifTrue:[
- (secondChar == $-) ifTrue:[
- "special- look if minus belongs to number following"
- p := source position.
- source next.
- thirdChar := source peekOrNil.
- source position:p.
- (thirdChar notNil and:[thirdChar isDigit]) ifTrue:[
- tokenName := token := string.
- tokenType := #BinaryOperator.
- self
- warnPossibleIncompatibility:'add a space before ''-'' for compatibility with stc and other ST systems'
- position:p+1
- to:p+1.
- ^ tokenType
- ]
- ].
- (self isSpecialOrExtendedSpecialCharacter:secondChar) ifTrue:[
- source next.
- string := string copyWith:secondChar.
-
- thirdChar := source peekOrNil.
- thirdChar notNil ifTrue:[
- (self isSpecialOrExtendedSpecialCharacter:thirdChar) ifTrue:[
- p := source position.
- source next.
- fourthChar := source peekOrNil.
- source position:p.
-
- (thirdChar == $-) ifTrue:[
- "special- look if minus belongs to number following"
- (fourthChar notNil and:[fourthChar isDigit]) ifTrue:[
- tokenName := token := string.
- tokenType := #BinaryOperator.
- self
- warnPossibleIncompatibility:'add a space before ''-'' for compatibility with stc and other ST systems'
- position:p+1
- to:p+1.
- ^ tokenType
- ].
- ].
- thirdChar == $# ifTrue:[
- (fourthChar notNil and:[fourthChar isSeparator]) ifFalse:[
- "/ in sth. like ->#foo, the binop is NOT ->#
- tokenName := token := string.
- tokenType := #BinaryOperator.
- ^ tokenType
- ].
- ].
- source next.
- string := string copyWith:thirdChar.
- ].
- ].
- ].
+ (secondChar == $-) ifTrue:[
+ "special- look ahead if minus belongs to number following"
+ p := source position.
+ source next.
+ thirdChar := source peekOrNil.
+ source position:p.
+ (thirdChar notNil and:[thirdChar isDigit]) ifTrue:[
+ tokenName := token := string.
+ tokenType := #BinaryOperator.
+ self
+ warnPossibleIncompatibility:'add a space before ''-'' for compatibility with stc and other ST systems'
+ position:p+1
+ to:p+1.
+ ^ tokenType
+ ]
+ ].
+ (self isSpecialOrExtendedSpecialCharacter:secondChar) ifTrue:[
+ source next.
+ string := string copyWith:secondChar.
+
+ thirdChar := source peekOrNil.
+ thirdChar notNil ifTrue:[
+ (self isSpecialOrExtendedSpecialCharacter:thirdChar) ifTrue:[
+ p := source position.
+ source next.
+ fourthChar := source peekOrNil.
+ source position:p.
+
+ (thirdChar == $-) ifTrue:[
+ "special- look ahead if minus belongs to number following"
+ (fourthChar notNil and:[fourthChar isDigit]) ifTrue:[
+ tokenName := token := string.
+ tokenType := #BinaryOperator.
+ self
+ warnPossibleIncompatibility:'add a space before ''-'' for compatibility with stc and other ST systems'
+ position:p+1
+ to:p+1.
+ ^ tokenType
+ ].
+ ].
+ thirdChar == $# ifTrue:[
+ (fourthChar notNil and:[fourthChar isSeparator]) ifFalse:[
+ "/ in sth. like ->#foo, the binop is NOT ->#
+ tokenName := token := string.
+ tokenType := #BinaryOperator.
+ ^ tokenType
+ ].
+ ].
+ source next.
+ string := string copyWith:thirdChar.
+ ].
+ ].
+ ].
].
tokenName := token := string.
tokenType := #BinaryOperator.
^ tokenType
- "Modified: / 12-02-2017 / 11:02:51 / cg"
+ "Modified: / 05-06-2020 / 11:09:25 / cg"
!
nextString:delimiter
- "a single quote has been scanned; scan the string (caring for doubled quotes"
-
- |nextChar string pos
- index "{ Class: SmallInteger }"
- len "{ Class: SmallInteger }"
- inString peekChar|
-
- string := String uninitializedNew:20.
- len := 20.
- index := 1.
- pos := source position + 1.
+ "a quote has been scanned; scan the string (caring for doubled quotes)"
+
source next.
- nextChar := source next.
- inString := true.
-
- [inString] whileTrue:[
- nextChar isNil ifTrue:[
- self syntaxError:'unexpected end-of-input in String'
- position:pos to:(source position).
- self markStringFrom:pos to:source position.
- token := nil.
- tokenType := #EOF.
- ^ tokenType
- ].
- (nextChar == Character cr) ifTrue:[
- lineNr := lineNr + 1
- ] ifFalse:[
- (nextChar == delimiter) ifTrue:[
- (source peekOrNil == delimiter) ifTrue:[
- source next
- ] ifFalse:[
- inString := false
- ]
- ] ifFalse:[
- parserFlags allowExtendedSTXSyntax == true ifTrue:[
- (nextChar == $\) ifTrue:[
- peekChar := source peekOrNil.
- peekChar notNil ifTrue:[
- source next.
- nextChar := self escapeCharacterFor:peekChar.
- ]
- ]
- ]
- ].
- ].
- inString ifTrue:[
- nextChar notNil ifTrue:[
- nextChar codePoint > 255 ifTrue:[
- string bitsPerCharacter < nextChar bitsPerCharacter ifTrue:[
- nextChar codePoint > 16rFFFF ifTrue:[
- string := string asUnicode32String
- ] ifFalse:[
- string := string asUnicode16String.
- ].
- ].
- ].
- string at:index put:nextChar.
- (index == len) ifTrue:[
- string := string , (string species new:len).
- len := len * 2
- ].
- index := index + 1.
- ].
- nextChar := source next
- ]
- ].
-
- tokenValue := token := string copyTo:(index - 1).
- tokenType := #String.
- ^ tokenType
+ ^ self xnextString:delimiter escapeStyle:nil
+
+ "
+ old style ST80 string (no escapes):
+ 'hello\new world'
+
+ ParserFlags allowCStrings:true.
+
+ new style STX c-string (c escapes):
+ c'hello\nnew world'
+ c'hello\tnew world'
+ c'hello\<tab>new world'
+ c'a\0b'
+ c'a\n\\\nb'
+ c'a\r\\\nb'
+
+ ParserFlags allowCStrings:false.
+
+ ParserFlags allowEStrings:true.
+
+ new style strings with embedded expressions:
+ e'Hello, this is a computed value: {3 factorial}'
+
+ ParserFlags allowEStrings:false.
+
+ ParserFlags allowRStrings:true.
+
+ STX regex:
+ r'a+b+'
+
+ ParserFlags allowRStrings:false.
+ "
"Created: / 01-08-2006 / 14:56:07 / cg"
"Modified: / 22-08-2006 / 14:10:26 / cg"
+ "Modified: / 22-05-2019 / 20:32:14 / Claus Gittinger"
+ "Modified (comment): / 03-06-2019 / 11:16:00 / Claus Gittinger"
+ "Modified (comment): / 24-09-2019 / 11:52:28 / Stefan Vogel"
+!
+
+nextString:delimiter escapeStyle:escapeStyle
+ "a quote has been scanned; scan the string (caring for doubled quotes).
+ escapeStyle may be:
+ nil - old style ST80 strings (no character escapes)
+ or a single char string:
+ 'c' - C-style escapes:
+ \n,\t,\r,\b,\xXX,\uXXXX,\UXXXXXX,
+
+ 'e' - C-style plus embedded escapes:
+ e'...{ expr1 } ... { exprN }' will generate:
+ '...%1 ... %N' bindWithArguments:{ expr1 . ... . exprN }
+
+ 'i' - internationalized-string escapes:
+
+ 'x' - extended-style escapes:
+ as yet unsupported
+ 'r' - regex
+ as yet unsupported
+
+ "
+
+ source next.
+ ^ self xnextString:delimiter escapeStyle:escapeStyle
+
+ "Created: / 08-02-2019 / 19:07:57 / Claus Gittinger"
+ "Modified: / 22-05-2019 / 20:33:04 / Claus Gittinger"
+ "Modified (comment): / 23-05-2019 / 08:52:46 / Claus Gittinger"
!
nextSymbolAfterHash
@@ -3401,164 +3787,158 @@
nextToken
"return the next token from the source-stream"
- |skipping actionBlock v ch tok|
-
- source isPositionable ifTrue:[
- tokenLastEndPosition := source position+1.
- ].
+ |skipping actionBlock codePoint ch tok|
+
+ tokenLastEndPosition := source position+1.
[
- peekChar notNil ifTrue:[
- "/ kludge - should be called peekSym.
- "/ used when xlating Foo.Bar into Foo::Bar
- peekChar isSymbol ifTrue:[
- token := nil.
- tokenType := peekChar.
- peekChar := nil.
- ^ tokenType
- ].
-
- (peekChar isSeparator or:[ peekChar codePoint == 16rFEFF ]) ifTrue:[
- peekChar == (Character cr) ifTrue:[
- lineNr := lineNr + 1.
- ].
- hereChar := peekChar.
- peekChar := peekChar2.
- peekChar2 := nil.
- (hereChar == Character cr) ifTrue:[
- (self eolIsWhiteSpace) ifFalse:[
- token := nil.
- tokenType := #EOL.
- ^ tokenType
- ].
- ].
- ].
- ].
-
- peekChar notNil ifTrue:[
- ch := peekChar.
- peekChar := peekChar2.
- peekChar2 := nil.
- hereChar := nil.
- ] ifFalse:[
- skipping := true.
- [skipping] whileTrue:[
-
- outStream notNil ifTrue:[
- [
- hereChar := source peekOrNil.
- (hereChar notNil
- and:[(hereChar == Character space) or:[hereChar isSeparator]])
- ] whileTrue:[
- source next.
- outStream space.
- outCol := outCol + 1.
- hereChar == (Character cr) ifTrue:[
- self eolIsWhiteSpace ifFalse:[
- source isPositionable ifTrue:[
- tokenPosition := source position.
- ].
- token := nil.
- tokenType := #EOL.
- ^ tokenType
- ].
- ]
- ]
- ] ifFalse:[
- hereChar := source skipSeparatorsExceptCR.
- ].
-
- hereChar isNil ifTrue:[
- skipping := false
- ] ifFalse:[
- hereChar == (Character cr) ifTrue:[
- lineNr := lineNr + 1.
- source next.
- outStream notNil ifTrue:[
- outStream cr.
- outCol := 1
- ].
- self eolIsWhiteSpace ifFalse:[
- source isPositionable ifTrue:[
- tokenPosition := source position.
- ].
- token := nil.
- tokenType := #EOL.
- ^ tokenType
- ].
- ] ifFalse:[
- hereChar == (Character return) ifTrue:[
- outStream notNil ifTrue:[
- outStream nextPut:hereChar.
- outCol := 1
- ].
- source next.
- ] ifFalse:[
- (self isCommentCharacter:hereChar) ifTrue:[
- "start of a comment"
-
- self skipComment.
- hereChar := source peekOrNil.
- ] ifFalse:[
- skipping := false
- ]
- ]
- ]
- ].
- ].
- hereChar isNil ifTrue:[
- source isPositionable ifTrue:[
- tokenPosition := source position + 1.
- ].
- token := nil.
- tokenType := #EOF.
- ^ tokenType
- ].
- ch := hereChar
- ].
- source isPositionable ifTrue:[
- tokenPosition := source position + 1.
- ].
- tokenLineNr := lineNr.
-
- (v := ch codePoint) == 0 ifTrue:[
- v := Character space codePoint
- ].
- v <= 16rFF ifTrue:[
- actionBlock := actionArray at:v.
- ] ifFalse:[
- actionBlock := unicodeActions at:v ifAbsent:nil
- ].
- actionBlock notNil ifTrue:[
- tok := actionBlock value:self value:ch.
- tok notNil ifTrue:[
- ^ tok
- ].
- "/ a nil token means: continue reading
- ] ifFalse:[
- (ch isNationalLetter and:[parserFlags allowNationalCharactersInIdentifier]) ifTrue:[
- tok := self nextIdentifier.
- tok notNil ifTrue:[
- ^ tok
- ].
- "/ a nil token means: continue reading
- ] ifFalse:[
- (ch == $§ and:[parserFlags allowParagraphInIdentifier]) ifTrue:[
- tok := self nextIdentifier.
- tok notNil ifTrue:[
- ^ tok
- ].
- "/ a nil token means: continue reading
- ] ifFalse:[
- ^ self invalidCharacter:ch.
- ].
- ].
- ]
+ peekChar notNil ifTrue:[
+ "/ kludge - should be called peekSym.
+ "/ used when xlating Foo.Bar into Foo::Bar
+ peekChar isSymbol ifTrue:[
+ token := nil.
+ tokenType := peekChar.
+ peekChar := nil.
+ ^ tokenType
+ ].
+
+ (peekChar isSeparator or:[ peekChar codePoint == 16rFEFF ]) ifTrue:[
+ peekChar == (Character cr) ifTrue:[
+ lineNr := lineNr + 1.
+ ].
+ hereChar := peekChar.
+ peekChar := peekChar2.
+ peekChar2 := nil.
+ (hereChar == Character cr) ifTrue:[
+ (self eolIsWhiteSpace) ifFalse:[
+ token := nil.
+ tokenType := #EOL.
+ ^ tokenType
+ ].
+ ].
+ ].
+ ].
+
+ peekChar notNil ifTrue:[
+ ch := peekChar.
+ peekChar := peekChar2.
+ peekChar2 := nil.
+ hereChar := nil.
+ ] ifFalse:[
+ skipping := true.
+ [skipping] whileTrue:[
+
+ outStream notNil ifTrue:[
+ [
+ hereChar := source peekOrNil.
+ (hereChar notNil
+ and:[(hereChar == Character space) or:[hereChar isSeparator]])
+ ] whileTrue:[
+ source next.
+ outStream space.
+ outCol := outCol + 1.
+ hereChar == (Character cr) ifTrue:[
+ self eolIsWhiteSpace ifFalse:[
+ source isPositionable ifTrue:[
+ tokenPosition := source position.
+ ].
+ token := nil.
+ tokenType := #EOL.
+ ^ tokenType
+ ].
+ ]
+ ]
+ ] ifFalse:[
+ hereChar := source skipSeparatorsExceptCR.
+ ].
+
+ hereChar isNil ifTrue:[
+ skipping := false
+ ] ifFalse:[
+ hereChar == (Character cr) ifTrue:[
+ lineNr := lineNr + 1.
+ source next.
+ outStream notNil ifTrue:[
+ outStream cr.
+ outCol := 1
+ ].
+ self eolIsWhiteSpace ifFalse:[
+ source isPositionable ifTrue:[
+ tokenPosition := source position.
+ ].
+ token := nil.
+ tokenType := #EOL.
+ ^ tokenType
+ ].
+ ] ifFalse:[
+ hereChar == (Character return) ifTrue:[
+ outStream notNil ifTrue:[
+ outStream nextPut:hereChar.
+ outCol := 1
+ ].
+ source next.
+ ] ifFalse:[
+ (self isCommentCharacter:hereChar) ifTrue:[
+ "start of a comment"
+
+ self skipComment.
+ hereChar := source peekOrNil.
+ ] ifFalse:[
+ skipping := false
+ ]
+ ]
+ ]
+ ].
+ ].
+ hereChar isNil ifTrue:[
+ source isPositionable ifTrue:[
+ tokenPosition := source position + 1.
+ ].
+ token := nil.
+ tokenType := #EOF.
+ ^ tokenType
+ ].
+ ch := hereChar
+ ].
+ source isPositionable ifTrue:[
+ tokenPosition := source position + 1.
+ ].
+ tokenLineNr := lineNr.
+
+ (codePoint := ch codePoint) == 0 ifTrue:[
+ codePoint := Character space codePoint
+ ].
+ codePoint <= 16rFF ifTrue:[
+ actionBlock := actionArray at:codePoint.
+ ] ifFalse:[
+ actionBlock := unicodeActions at:codePoint ifAbsent:nil
+ ].
+ actionBlock notNil ifTrue:[
+ tok := actionBlock value:self value:ch.
+ tok notNil ifTrue:[
+ ^ tok
+ ].
+ "/ a nil token means: continue reading
+ ] ifFalse:[
+ ((ch isNationalLetter and:[parserFlags allowNationalCharactersInIdentifier])
+ or:[ (ch == $§ and:[parserFlags allowParagraphInIdentifier])
+ or:[ (ch isGreekLetter and:[parserFlags allowGreekCharactersInIdentifier])
+ ]]) ifTrue:[
+ tok := self nextIdentifier.
+ tok notNil ifTrue:[
+ ^ tok
+ ].
+ "/ a nil token means: continue reading
+ ] ifFalse:[
+ ^ self invalidCharacter:ch.
+ ].
+ ]
] loop.
"Modified: / 13-09-1995 / 12:56:14 / claus"
"Modified: / 27-07-2011 / 15:36:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 12-02-2017 / 11:27:59 / cg"
+ "Modified: / 08-06-2019 / 14:59:14 / Claus Gittinger"
!
nextToken:aCharacter
@@ -3582,9 +3962,9 @@
skipComment
"skip over a comment;
- handles ST/X eol comments (quote-slash)
- and multiline-delimiter comment (quote-less-less).
- Multiline-delimiter comments start with ''<<TOKEN and end in a line which starts with TOKEN (quote-quote being a double quote here)"
+ handles ST/X eol comments (dquote-slash)
+ and multiline-delimiter comment (dquote-less-less).
+ Multiline-delimiter comments start with dquote<<TOKEN and end in a line which starts with TOKEN, where TOKEN is any word with no separators"
|commentStream commentType commentText startPos endPos stillInComment anyNonBlank
delimiter line|
@@ -3592,7 +3972,7 @@
anyNonBlank := false.
saveComments ifTrue:[
- commentStream := CharacterWriteStream on:''.
+ commentStream := CharacterWriteStream new.
self beginComment.
].
@@ -3725,9 +4105,9 @@
outCol := outCol + 1
].
].
- endPos := source position.
"skip final dQuote"
source next.
+ endPos := source position.
(source peek == Character doubleQuote) ifTrue:[
stillInComment := true.
@@ -3749,7 +4129,7 @@
self isDoIt ifFalse:[
self
warning:'empty comment'
- doNotShowAgainAction:[ ParserFlags warnAboutBadComments: false ]
+ doNotShowAgainAction:(self actionToDisableWarning:#warnAboutBadComments)
position:startPos to:endPos+1.
parserFlags warnAboutBadComments:false.
]
@@ -3758,7 +4138,7 @@
].
].
- "Modified: / 30-08-2017 / 09:58:02 / cg"
+ "Modified: / 14-07-2020 / 10:54:23 / cg"
!
skipToEndOfLineRememberingIn:commentStreamOrNil
@@ -3773,6 +4153,132 @@
hereChar := source nextPeek.
].
lineNr := lineNr + 1.
+!
+
+xnextString:delimiter escapeStyle:escapeStyleOrNil
+ "a quote has been scanned; scan the string (caring for doubled quotes).
+ escapeStyle may be:
+ nil - old style ST80 strings (no character escapes)
+ or a single char string:
+ 'c' - C-style escapes:
+ \n,\t,\r,\b,\xXX,\uXXXX,\UXXXXXX,
+
+ 'e' - C-style with embedded expressions:
+ e'...{ expr1 } ... { exprN }' will generate:
+ '...%1 ... %N' bindWithArguments:{ expr1 . ... . exprN }
+
+ 'i' - C-style plus embedded expressions internationalized:
+ i'...{ expr1 } ... { exprN }' will generate:
+ resources string:'...%1 ... %N' withArguments:{ expr1 . ... . exprN }
+
+ 'r' - regex
+
+ 'x' - extended-style escapes:
+ as yet unsupported
+ "
+
+ |nextChar string pos
+ index "{ Class: SmallInteger }"
+ len "{ Class: SmallInteger }"
+ inString peekChar
+ isCString isEString isRString isIString typeOfToken typeOfTokenIfNoEmbeddedExpression|
+
+ isEString := isCString := isRString := isIString := false.
+
+ (isEString := (escapeStyleOrNil = 'e')) ifTrue:[
+ typeOfToken := #EStringFragment.
+ typeOfTokenIfNoEmbeddedExpression := #String.
+ ] ifFalse:[
+ (isCString := (escapeStyleOrNil = 'c')) ifTrue:[
+ typeOfToken := #String
+ ] ifFalse:[
+ (isRString := (escapeStyleOrNil = 'r')) ifTrue:[
+ typeOfToken := #RegexString
+ ] ifFalse:[
+ (isIString := (escapeStyleOrNil = 'i')) ifTrue:[
+ typeOfToken := #IStringFragment.
+ typeOfTokenIfNoEmbeddedExpression := #IString.
+ ] ifFalse:[
+ escapeStyleOrNil notNil ifTrue:[
+ self parseError:'unhandled string style'.
+ ].
+ typeOfToken := #String
+ ]
+ ]
+ ]
+ ].
+
+ string := String uninitializedNew:20.
+ len := 20.
+ index := 1.
+ pos := source position.
+ nextChar := source next.
+ inString := true.
+
+ [inString] whileTrue:[
+ nextChar isNil ifTrue:[
+ self syntaxError:'unexpected end-of-input in String'
+ position:pos to:(source position).
+ self markStringFrom:pos to:source position.
+ token := nil.
+ tokenType := #EOF.
+ ^ tokenType
+ ].
+ (nextChar == Character cr) ifTrue:[
+ lineNr := lineNr + 1
+ ] ifFalse:[
+ (nextChar == delimiter) ifTrue:[
+ (source peekOrNil == delimiter) ifTrue:[
+ source next
+ ] ifFalse:[
+ inString := false
+ ]
+ ] ifFalse:[
+ (escapeStyleOrNil notNil and:[isRString not]) ifTrue:[
+ ((nextChar == ${) and:[isEString or:[isIString]]) ifTrue:[
+ "/ bail out, to read one expression
+ tokenValue := token := string copyTo:(index - 1).
+ tokenType := typeOfToken.
+ ^ tokenType
+ ].
+ (nextChar == $\) ifTrue:[
+ peekChar := source peekOrNil.
+ peekChar notNil ifTrue:[
+ source next.
+ nextChar := self escapeCharacterFor:peekChar escapeStyle:escapeStyleOrNil.
+ ]
+ ]
+ ]
+ ].
+ ].
+ inString ifTrue:[
+ nextChar notNil ifTrue:[
+ nextChar codePoint > 255 ifTrue:[
+ string bitsPerCharacter < nextChar bitsPerCharacter ifTrue:[
+ nextChar codePoint > 16rFFFF ifTrue:[
+ string := string asUnicode32String
+ ] ifFalse:[
+ string := string asUnicode16String.
+ ].
+ ].
+ ].
+ string at:index put:nextChar.
+ (index == len) ifTrue:[
+ string := string , (string species new:len).
+ len := len * 2
+ ].
+ index := index + 1.
+ ].
+ nextChar := source next
+ ]
+ ].
+
+ tokenValue := token := string copyTo:(index - 1).
+ tokenType := typeOfTokenIfNoEmbeddedExpression ? typeOfToken.
+ ^ tokenType
+
+ "Created: / 22-05-2019 / 20:31:36 / Claus Gittinger"
+ "Modified: / 03-06-2019 / 11:10:24 / Claus Gittinger"
! !
!Scanner::Comment methodsFor:'accessing'!
@@ -3785,12 +4291,13 @@
"Created: / 17.2.1998 / 14:44:33 / cg"
!
-commentString:something
+commentString:aString
"set the value of the instance variable 'commentString' (automatically generated)"
- commentString := something.
-
- "Created: / 17.2.1998 / 14:44:33 / cg"
+ commentString := aString.
+
+ "Created: / 17-02-1998 / 14:44:33 / cg"
+ "Modified (format): / 14-07-2020 / 10:21:33 / cg"
!
commentString:commentStringArg commentType:commentTypeArg
@@ -3806,26 +4313,31 @@
"Created: / 17.2.1998 / 14:44:33 / cg"
!
-commentType:something
- commentType := something.
-
- "Created: / 17.2.1998 / 14:44:33 / cg"
+commentType:typeSymbol
+ commentType := typeSymbol.
+
+ "Created: / 17-02-1998 / 14:44:33 / cg"
+ "Modified (format): / 14-07-2020 / 10:21:23 / cg"
!
endPosition
^ endPosition
!
-endPosition:something
- endPosition := something.
+endPosition:anInteger
+ endPosition := anInteger.
+
+ "Modified (format): / 14-07-2020 / 10:21:12 / cg"
!
startPosition
^ startPosition
!
-startPosition:something
- startPosition := something.
+startPosition:anInteger
+ startPosition := anInteger.
+
+ "Modified (format): / 14-07-2020 / 10:20:59 / cg"
!
startPosition:startPositionArg endPosition:endPositionArg
@@ -3849,6 +4361,19 @@
^ commentString asStringCollection.
! !
+!Scanner::Comment methodsFor:'printing & storing'!
+
+displayOn:aStream
+ aStream nextPutAll:(self class name).
+ aStream nextPutAll:'('.
+ aStream print:commentType.
+ aStream nextPutAll:'; string: "'.
+ commentString displayOn:aStream.
+ aStream nextPutAll:'")'.
+
+ "Created: / 14-07-2020 / 09:46:49 / cg"
+! !
+
!Scanner::Comment methodsFor:'queries'!
isEndOfLineComment
--- a/SelectorNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/SelectorNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -94,19 +94,19 @@
!SelectorNode methodsFor:'testing'!
isSelector
-
- ^true
+ ^ true
"Created: / 16-02-2012 / 21:04:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 22-01-2019 / 16:13:10 / Stefan Vogel"
! !
!SelectorNode class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/SelectorNode.st,v 1.3 2014-07-05 08:31:39 cg Exp $'
+ ^ '$Header$'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libcomp/SelectorNode.st,v 1.3 2014-07-05 08:31:39 cg Exp $'
+ ^ '$Header$'
! !
--- a/SelfNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/SelfNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
@@ -67,6 +69,16 @@
!SelfNode methodsFor:'code generation'!
+codeForSideEffectOn:aStream inBlock:b for:aCompiler
+ "no code at all"
+
+ aCompiler
+ warning:'Useless reference to this'
+ position:startPosition to:endPosition.
+
+ ^ self
+!
+
codeForSimpleReturnOn:aStream inBlock:b lineNumber:lineNrOrNil for:aCompiler
lineNrOrNil notNil ifTrue:[
self codeLineNumber:lineNrOrNil on:aStream for:aCompiler
--- a/SourceFileLoader.st Sat Aug 08 22:49:53 2020 +0100
+++ b/SourceFileLoader.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1995 by Claus Gittinger
All Rights Reserved
@@ -179,7 +181,8 @@
requirePackage:packageName
"sent by the compiler, whenever it encounters a 'Prerequisites:'
- directive. For now, this is ignored."
+ directive. For now, this is ignored.
+ Will use the requirePackage stuff in Smalltalk, when finished."
'SourceFileLoader require package: ' errorPrint.
packageName errorPrintCR.
--- a/StatementNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/StatementNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -141,7 +141,6 @@
"Created: / 20-07-2011 / 19:52:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
-
!StatementNode methodsFor:'code generation'!
codeAllForSideEffectOn:aStream inBlock:b for:aCompiler
@@ -194,6 +193,30 @@
!StatementNode methodsFor:'enumerating'!
+allMessageSelectorsDo:aBlock
+ "evaluate aBlock for each message-selector sent by this statement and all followup statements"
+
+ |s|
+
+ s := self.
+ [s notNil] whileTrue:[
+ s messageSelectorsDo:aBlock.
+ s := s nextStatement
+ ].
+!
+
+allMessagesDo:aBlock
+ "evaluate aBlock for each message-node sent by this statement and all followup statements"
+
+ |s|
+
+ s := self.
+ [s notNil] whileTrue:[
+ s messagesDo:aBlock.
+ s := s nextStatement
+ ].
+!
+
allNodesDo:aBlock
"evaluate aBlock for each node in this node and subnodes"
@@ -230,6 +253,12 @@
"Created: / 15-07-2018 / 10:34:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+childrenDo:aBlock
+ expression notNil ifTrue:[
+ aBlock value:expression
+ ].
+!
+
do:aBlock
"in st/x, statements is a linked list (not an ordered collection),
this provides some dialect compatibility (for st2js)"
@@ -250,25 +279,17 @@
|s e|
- s := self.
- [s notNil] whileTrue:[
- e := s expression.
- e notNil ifTrue:[e messageSelectorsDo:aBlock].
- s := s nextStatement
- ].
+ e := self expression.
+ e notNil ifTrue:[e messageSelectorsDo:aBlock].
!
messagesDo:aBlock
"evaluate aBlock for each message-node sent by this node and subnodes"
- |s e|
+ |e|
- s := self.
- [s notNil] whileTrue:[
- e := s expression.
- e notNil ifTrue:[e messagesDo:aBlock].
- s := s nextStatement
- ].
+ e := self expression.
+ e notNil ifTrue:[e messagesDo:aBlock].
!
nodeDo:anEnumerator
@@ -308,7 +329,6 @@
].
! !
-
!StatementNode methodsFor:'evaluation'!
evaluateAllIn:anEnvironment
--- a/Structure.st Sat Aug 08 22:49:53 2020 +0100
+++ b/Structure.st Tue Aug 25 12:20:06 2020 +0100
@@ -17,11 +17,11 @@
instanceVariableNames:'i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13 i14 i15 i16 i17 i18
i19 i20 i21 i22 i23 i24 i25 i26 i27 i28 i29 i30 i31 i32 i33 i34
i35 i36 i37 i38 i39 i40 i41 i42 i43 i44 i45 i46 i47 i48 i49 i50'
- classVariableNames:'OneInstance DummyClass ReadAccessMethods WriteAccessMethods
- OtherMethods OtherSelectors IndexOfFlags IndexOfMethodDictionary
- IndexOfInstSize'
+ classVariableNames:'DummyClass IndexOfFlags IndexOfInstSize IndexOfMethodDictionary
+ OneInstance OtherMethods OtherSelectors ReadAccessMethods
+ WriteAccessMethods'
poolDictionaries:''
- category:'Programming-Support'
+ category:'Kernel-Classes'
!
!Structure class methodsFor:'documentation'!
@@ -1253,7 +1253,7 @@
].
(sel == #displayString) ifTrue:[
- s := CharacterWriteStream on:''.
+ s := CharacterWriteStream new.
self displayOn:s.
^ s contents
].
@@ -1268,7 +1268,13 @@
sel == #inspect ifTrue:[
^ InspectorView openOn:self
].
-
+ sel == #'inspectorValueListIconFor:' ifTrue:[
+ ^ (args at:1) imageFor_others
+ ].
+ self == #'inspectorValueStringInListFor:' ifTrue:[
+ ^ '{...}'
+ ].
+
sel == #instVarAt: ifTrue:[
|nr|
@@ -1444,7 +1450,7 @@
].
sel == #allInstVarNames ifTrue:[
methodDictionary isNil ifTrue:[
- 'Structure [info]: oops - nil methodDict' infoPrintCR.
+ Logger info:'Structure: oops - nil methodDict'.
^ #()
].
@@ -1481,15 +1487,20 @@
((sel startsWith:'is') or:[sel startsWith:'has']) ifTrue:[
^ false.
].
- 'Structure [warning]: return nil for: ' infoPrint.
- aMessage infoPrint.' args ' infoPrint. args infoPrintCR.
-"/ Object halt.
+ (sel == #acceptVisitor:with:) ifTrue:[
+ ^ (args at:1) visitObject:self with:(args at:2)
+ ].
+ (sel == #acceptVisitor:) ifTrue:[
+ ^ (args at:1) visitObject:self with:nil
+ ].
+ Logger info:'Structure: return nil for: #%1 args %2' with:sel with:args.
^ nil.
"Created: / 13-05-1996 / 20:22:22 / cg"
"Modified: / 16-07-2017 / 13:54:58 / cg"
"Modified (format): / 24-07-2017 / 16:43:06 / stefan"
+ "Modified: / 31-01-2019 / 23:57:16 / Claus Gittinger"
! !
!Structure class methodsFor:'documentation'!
--- a/SuperNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/SuperNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
@@ -102,7 +104,9 @@
!SuperNode methodsFor:'testing'!
isHere
- ^ isHere
+ ^ isHere ? false
+
+ "Modified: / 30-08-2018 / 13:25:54 / Claus Gittinger"
!
isSuper
--- a/SyntaxHighlighter.st Sat Aug 08 22:49:53 2020 +0100
+++ b/SyntaxHighlighter.st Tue Aug 25 12:20:06 2020 +0100
@@ -17,7 +17,7 @@
AbstractSyntaxHighlighter subclass:#SyntaxHighlighter
instanceVariableNames:'currentSuperclasses currentSubclasses
cachedLocalIdentifierEmphasis cachedLocalIdentifierColor
- cachedStringEmphasis cachedStringColor'
+ cachedStringEmphasis cachedStringColor unknownVariableResolver'
classVariableNames:''
poolDictionaries:''
category:'System-Compiler'
@@ -82,6 +82,12 @@
"Created: / 27-07-2012 / 22:01:42 / cg"
! !
+!SyntaxHighlighter methodsFor:'accessing'!
+
+unknownVariableResolver
+ ^ unknownVariableResolver
+! !
+
!SyntaxHighlighter methodsFor:'initialization'!
initialize
--- a/TextCollectingCompilationErrorHandler.st Sat Aug 08 22:49:53 2020 +0100
+++ b/TextCollectingCompilationErrorHandler.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 2010 by Claus Gittinger
All Rights Reserved
@@ -38,7 +40,7 @@
documentation
"
- collects messages - for check before checking in
+ collects messages - used eg. for check before checking in
"
! !
@@ -60,10 +62,11 @@
aCompiler classToCompileFor name
, '>>',
(aCompiler selector ? '???')
- , '] ' , (aMessage allBold withColor:Color red darkened)).
+ , '] ' , (aMessage allBold withColor:Color darkRed)).
"Created: / 02-11-2010 / 12:52:23 / cg"
"Modified: / 03-11-2010 / 12:28:49 / cg"
+ "Modified: / 13-03-2019 / 21:18:11 / Claus Gittinger"
!
warning:aMessage position:position to:endPos from:aCompiler
--- a/UnaryNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/UnaryNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -151,11 +151,18 @@
"
recVal respondsToArithmetic ifTrue:[
(#( negated abs asPoint degreesToRadians radiansToDegrees
- exp ln log sqrt reciprocal
- arcCos arcSin arcTan sin cos tan) includes:selector)
+ reciprocal) includes:selector)
ifTrue:[
canFold := true
- ]
+ ] ifFalse:[
+ (#(exp ln log sqrt
+ arcCos arcSin arcTan sin cos tan) includes:selector)
+ ifTrue:[
+ (recVal isKindOf:LargeInteger) ifFalse:[
+ canFold := true
+ ]
+ ]
+ ].
].
recVal isCharacter ifTrue:[
(#( asciiValue asInteger digitValue asString) includes:selector)
@@ -206,6 +213,7 @@
^ (self basicNew) receiver:r selector:selectorString args:nil lineno:0
"Modified: / 03-07-2017 / 13:56:31 / cg"
+ "Modified: / 25-05-2018 / 16:05:52 / Claus Gittinger"
! !
!UnaryNode methodsFor:'accessing'!
--- a/Variable.st Sat Aug 08 22:49:53 2020 +0100
+++ b/Variable.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -11,6 +13,8 @@
"
"{ Package: 'stx:libcomp' }"
+"{ NameSpace: Smalltalk }"
+
Object subclass:#Variable
instanceVariableNames:'value name used type domain classHint'
classVariableNames:''
@@ -71,21 +75,25 @@
^ name
!
-name:aString
+name:nameString
"set the name of the variable"
"/ self assert:(aString isString).
- name := aString
+ "/ self assert:nameString notNil.
+ name := nameString
"Modified: / 07-08-2006 / 12:18:12 / cg"
+ "Modified: / 27-08-2018 / 13:40:33 / Claus Gittinger"
!
-type:typeSymbol name:aString
+type:typeSymbol name:nameString
+ "/ self assert:nameString notNil.
"/ self assert:(aString isString).
type := typeSymbol.
- name := aString
+ name := nameString
"Modified: / 07-08-2006 / 12:18:08 / cg"
+ "Modified: / 27-08-2018 / 13:40:37 / Claus Gittinger"
!
used
@@ -172,5 +180,6 @@
!Variable class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/Variable.st,v 1.23 2011-09-29 11:20:00 cg Exp $'
+ ^ '$Header$'
! !
+
--- a/VariableNode.st Sat Aug 08 22:49:53 2020 +0100
+++ b/VariableNode.st Tue Aug 25 12:20:06 2020 +0100
@@ -1,3 +1,5 @@
+"{ Encoding: utf8 }"
+
"
COPYRIGHT (c) 1994 by Claus Gittinger
COPYRIGHT (c) 2018 Jan Vrany
@@ -157,15 +159,6 @@
"Modified: / 28-06-2011 / 22:14:40 / cg"
!
-startPosition:start endPosition: end
-
- "/self assert: (end - start + 1) = name size.
-
- ^super startPosition:start endPosition: end
-
- "Created: / 25-08-2011 / 11:46:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
token
^ token
@@ -954,7 +947,7 @@
token value:aValue. ^ aValue
].
(type == #ThreadLocal) ifTrue:[
- ^ Processor activeProcess environmentAt:name asSymbol put:aValue. ^ aValue
+ ^ Processor activeProcess environmentAt:name asSymbol put:aValue.
].
"not reached"
@@ -962,6 +955,7 @@
^ aValue
"Modified: / 05-12-2011 / 18:43:56 / cg"
+ "Modified: / 05-02-2020 / 16:59:34 / Stefan Vogel"
! !
@@ -1093,14 +1087,18 @@
!
isGlobalNamed:nameWanted
- "return true, if this is a node for a particular global variable"
+ "return true, if this is a node for a particular
+ (and existing) global variable"
+ |sym|
+
^ (type == #GlobalVariable)
and:[name = nameWanted
- and:[name isSymbol
+ and:[(sym := name asSymbolIfInterned) isSymbol
and:[Smalltalk includesKey:name]]]
"Created: / 05-03-2007 / 13:35:07 / cg"
+ "Modified: / 22-09-2018 / 17:27:58 / Claus Gittinger"
!
isGlobalVariable
@@ -1109,6 +1107,16 @@
^ type == #GlobalVariable
!
+isGlobalVariableNamed:nameWanted
+ "return true, if this is a node for a particular
+ global variable (existing or not) "
+
+ ^ (type == #GlobalVariable)
+ and:[name = nameWanted]
+
+ "Created: / 22-09-2018 / 17:26:50 / Claus Gittinger"
+!
+
isInstance
<resource: #obsolete>
--- a/abbrev.stc Sat Aug 08 22:49:53 2020 +0100
+++ b/abbrev.stc Tue Aug 25 12:20:06 2020 +0100
@@ -6,6 +6,7 @@
BreakpointQuery BreakpointQuery stx:libcomp 'System-Compiler-Debugging' 1
CompilationErrorHandler CompilationErrorHandler stx:libcomp 'System-Compiler' 0
CompilationErrorHandlerQuery CompilationErrorHandlerQuery stx:libcomp 'System-Compiler' 1
+DoEnableCompilerOptionActionQuery DoEnableCompilerOptionActionQuery stx:libcomp 'System-Compiler' 1
DIEntry DIEntry stx:libcomp 'System-Compiler-Debug Info' 0
DIInfoVersions DIInfoVersions stx:libcomp 'System-Compiler-Debug Info' 0
DISectionTypes DISectionTypes stx:libcomp 'System-Compiler-Debug Info' 0
@@ -28,7 +29,7 @@
STCCompilerInterface STCCompilerInterface stx:libcomp 'System-Compiler' 0
Scanner Scanner stx:libcomp 'System-Compiler' 3
SourceFileLoader SourceFileLoader stx:libcomp 'System-Compiler' 0
-Structure Structure stx:libcomp 'Programming-Support' 0
+Structure Structure stx:libcomp 'Kernel-Classes' 0
UndefinedVariable UndefinedVariable stx:libcomp 'System-Compiler-Support' 0
UndefinedVariableNotification UndefinedVariableNotification stx:libcomp 'System-Compiler' 1
Variable Variable stx:libcomp 'System-Compiler-Support' 0
--- a/bc.mak Sat Aug 08 22:49:53 2020 +0100
+++ b/bc.mak Tue Aug 25 12:20:06 2020 +0100
@@ -46,7 +46,17 @@
OBJS= $(COMMON_OBJS) $(WIN32_OBJS)
-ALL:: classLibRule
+ALL:: INFO1 classLibRule INFO2
+
+INFO1:
+ @echo ============================================================================
+ @echo Building $(PACKAGE)...
+ @echo ----------------------------------------------------------------------------
+
+INFO2:
+ @echo ----------------------------------------------------------------------------
+ @echo Done $(PACKAGE)...
+ @echo ============================================================================
classLibRule: $(OUTDIR) $(OUTDIR)$(LIBNAME).dll
@@ -76,6 +86,7 @@
$(OUTDIR)BreakpointQuery.$(O) BreakpointQuery.$(C) BreakpointQuery.$(H): BreakpointQuery.st $(INCLUDE_TOP)\stx\libbasic\GenericException.$(H) $(INCLUDE_TOP)\stx\libbasic\Notification.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\Query.$(H) $(STCHDR)
$(OUTDIR)CompilationErrorHandler.$(O) CompilationErrorHandler.$(C) CompilationErrorHandler.$(H): CompilationErrorHandler.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)CompilationErrorHandlerQuery.$(O) CompilationErrorHandlerQuery.$(C) CompilationErrorHandlerQuery.$(H): CompilationErrorHandlerQuery.st $(INCLUDE_TOP)\stx\libbasic\GenericException.$(H) $(INCLUDE_TOP)\stx\libbasic\Notification.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\Query.$(H) $(STCHDR)
+$(OUTDIR)DoEnableCompilerOptionActionQuery.$(O) DoEnableCompilerOptionActionQuery.$(C) DoEnableCompilerOptionActionQuery.$(H): DoEnableCompilerOptionActionQuery.st $(INCLUDE_TOP)\stx\libbasic\GenericException.$(H) $(INCLUDE_TOP)\stx\libbasic\Notification.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\Query.$(H) $(STCHDR)
$(OUTDIR)DIEntry.$(O) DIEntry.$(C) DIEntry.$(H): DIEntry.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)DIInfoVersions.$(O) DIInfoVersions.$(C) DIInfoVersions.$(H): DIInfoVersions.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\SharedPool.$(H) $(STCHDR)
$(OUTDIR)DISectionTypes.$(O) DISectionTypes.$(C) DISectionTypes.$(H): DISectionTypes.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\SharedPool.$(H) $(STCHDR)
--- a/libInit.cc Sat Aug 08 22:49:53 2020 +0100
+++ b/libInit.cc Tue Aug 25 12:20:06 2020 +0100
@@ -21,6 +21,7 @@
extern void _BreakpointQuery_Init(int pass, struct __vmData__ *__pRT__, OBJ snd);
extern void _CompilationErrorHandler_Init(int pass, struct __vmData__ *__pRT__, OBJ snd);
extern void _CompilationErrorHandlerQuery_Init(int pass, struct __vmData__ *__pRT__, OBJ snd);
+extern void _DoEnableCompilerOptionActionQuery_Init(int pass, struct __vmData__ *__pRT__, OBJ snd);
extern void _DIEntry_Init(int pass, struct __vmData__ *__pRT__, OBJ snd);
extern void _DIInfoVersions_Init(int pass, struct __vmData__ *__pRT__, OBJ snd);
extern void _DISectionTypes_Init(int pass, struct __vmData__ *__pRT__, OBJ snd);
@@ -108,6 +109,7 @@
_BreakpointQuery_Init(pass,__pRT__,snd);
_CompilationErrorHandler_Init(pass,__pRT__,snd);
_CompilationErrorHandlerQuery_Init(pass,__pRT__,snd);
+ _DoEnableCompilerOptionActionQuery_Init(pass,__pRT__,snd);
_DIEntry_Init(pass,__pRT__,snd);
_DIInfoVersions_Init(pass,__pRT__,snd);
_DISectionTypes_Init(pass,__pRT__,snd);
--- a/stx_libcomp.st Sat Aug 08 22:49:53 2020 +0100
+++ b/stx_libcomp.st Tue Aug 25 12:20:06 2020 +0100
@@ -118,16 +118,6 @@
^ #(
)
-!
-
-subProjects
- "list packages which are known as subprojects.
- The generated makefile will enter those and make there as well.
- However: they are not forced to be loaded when a package is loaded;
- for those, redefine requiredPrerequisites."
-
- ^ #(
- )
! !
!stx_libcomp class methodsFor:'description - compilation'!
@@ -176,6 +166,7 @@
BreakpointQuery
CompilationErrorHandler
CompilationErrorHandlerQuery
+ DoEnableCompilerOptionActionQuery
DIEntry
DIInfoVersions
DISectionTypes
--- a/stx_libcompWINrc.rc Sat Aug 08 22:49:53 2020 +0100
+++ b/stx_libcompWINrc.rc Tue Aug 25 12:20:06 2020 +0100
@@ -2,9 +2,11 @@
// DO NOT EDIT
// automagically generated from the projectDefinition: stx_libcomp.
//
+#include "winver.h"
+
VS_VERSION_INFO VERSIONINFO
- FILEVERSION 7,1,1,80
- PRODUCTVERSION 7,1,0,0
+ FILEVERSION 7,2,1,89
+ PRODUCTVERSION 7,2,0,0
#if (__BORLANDC__)
FILEFLAGSMASK VS_FF_DEBUG | VS_FF_PRERELEASE
FILEFLAGS VS_FF_PRERELEASE | VS_FF_SPECIALBUILD
@@ -18,14 +20,14 @@
BEGIN
BLOCK "040904E4"
BEGIN
- VALUE "CompanyName", "eXept Software AG\0"
+ VALUE "CompanyName", "Claus Gittinger / eXept Software AG\0"
VALUE "FileDescription", "Smalltalk/X Bytecode Compiler (LIB)\0"
- VALUE "FileVersion", "7.1.1.80\0"
+ VALUE "FileVersion", "7.2.1.89\0"
VALUE "InternalName", "stx:libcomp\0"
- VALUE "LegalCopyright", "Copyright Claus Gittinger 1988-2012\nCopyright eXept Software AG 2012\0"
+ VALUE "LegalCopyright", "Copyright Claus Gittinger 1988\nCopyright eXept Software AG 2012\0"
VALUE "ProductName", "Smalltalk/X\0"
- VALUE "ProductVersion", "7.1.0.0\0"
- VALUE "ProductDate", "Tue, 21 Jun 2016 14:18:24 GMT\0"
+ VALUE "ProductVersion", "7.2.0.0\0"
+ VALUE "ProductDate", "Wed, 18 Dec 2019 18:06:26 GMT\0"
END
END