diff --git a/src/AST-Core-Tests/OCCompileCodeSnippetTest.class.st b/src/AST-Core-Tests/OCCompileCodeSnippetTest.class.st index 1cf4ed427b9..ec13b4b59c4 100644 --- a/src/AST-Core-Tests/OCCompileCodeSnippetTest.class.st +++ b/src/AST-Core-Tests/OCCompileCodeSnippetTest.class.st @@ -7,53 +7,51 @@ Class { } { #category : 'helpers' } -OCCompileCodeSnippetTest >> compileSnippet: anOCCodeSnippet [ - - ^ [ OpalCompiler new - permitFaulty: true; - isScripting: anOCCodeSnippet isScripting; - compile: anOCCodeSnippet source ] - on: OCCodeError do: [ :e | - "Compilation should success, because its the *faulty* mode". - "If this is expected, then just return nil" - anOCCodeSnippet ifSkip: #compile then: [^ nil ]. - "Otherwise, pass the error" - e pass ] +OCCompileCodeSnippetTest >> compileSnippet: anOCCodeSnippet [ + + ^ [ + OpalCompiler new + permitFaulty: true; + isScripting: anOCCodeSnippet isScripting; + source: anOCCodeSnippet source; + newCompile ] + on: OCCompilationError + do: [ :e | "Compilation should success, because its the *faulty* mode" + anOCCodeSnippet ifSkip: #compile then: [ ^ nil ]. "If this is expected, then just return nil" "Otherwise, pass the error" + e pass ] ] { #category : 'helpers' } OCCompileCodeSnippetTest >> compileSnippet: aSnippet onError: errorBlock [ ^ [ - OpalCompiler new - isScripting: aSnippet isScripting; - compile: aSnippet source ] - on: OCCodeError + OpalCompiler new + isScripting: aSnippet isScripting; + source: aSnippet source; + newCompile ] + on: OCCompilationError do: [ :e | errorBlock cull: e ] ] { #category : 'tests' } OCCompileCodeSnippetTest >> testCompileFailBlock [ - | method error | - error := nil. - method := OpalCompiler new - isScripting: snippet isScripting; - failBlock: [ :e | - self assert: (snippet hasNotice: e). - self assert: error isNil. "single invocation" - error := e. - #tag ]; - compile: snippet source. + | compilationResult | + compilationResult := OpalCompiler new + isScripting: snippet isScripting; + source: snippet source; + doCompile. + + compilationResult isError ifTrue: [ + compilationResult ast allNotices do: [ :n | + self assert: (snippet hasNotice: n) ] ]. snippet isFaulty - ifTrue: [ - self assert: error isNotNil. - self assert: method equals: #tag ] + ifTrue: [ self assert: compilationResult isError ] ifFalse: [ - self assert: error isNil. - self assert: method isCompiledMethod. - self testExecute: method ] + self deny: compilationResult isError. + self assert: compilationResult compiledMethod isCompiledMethod. + self testExecute: compilationResult compiledMethod ] ] { #category : 'tests' } @@ -83,87 +81,63 @@ OCCompileCodeSnippetTest >> testCompileFaulty [ { #category : 'tests' } OCCompileCodeSnippetTest >> testCompileOnError [ - | method error | - error := nil. + | method | method := self compileSnippet: snippet onError: [ :e | - self assert: - (snippet hasNotice: e messageText at: e position). - self assert: error isNil. "single invocation" - error := e ]. + e compilationResult ast allNotices do: [ :n | + self assert: (snippet hasNotice: n). + ]. + ^ self + ]. + snippet isFaulty - ifTrue: [ self assert: error isNotNil ] + ifTrue: [ self fail ] ifFalse: [ - self assert: error isNil. - self assert: method isCompiledMethod. - self testExecute: method ] -] - -{ #category : 'tests' } -OCCompileCodeSnippetTest >> testCompileOnErrorResume [ - - | method error | - error := nil. - method := self compileSnippet: snippet onError: [ :e | - self assert: - (snippet hasNotice: e messageText at: e position). - error := e. - e resume ]. - self assert: snippet isFaulty equals: error isNotNil. - self assert: method isCompiledMethod. - self testExecute: method + self assert: method isCompiledMethod. + self testExecute: method ] ] { #category : 'tests' } OCCompileCodeSnippetTest >> testCompileUndeclaredFaultyFailBlock [ - | method error | - error := nil. - method := OpalCompiler new - isScripting: snippet isScripting; - permitUndeclared: true; - failBlock: [ :e | - self assert: (snippet hasNotice: e). - self assert: error isNil. "single invocation" - error := e. - #tag ]; - compile: snippet source. + | compilationResult | + compilationResult := OpalCompiler new + isScripting: snippet isScripting; + permitUndeclared: true; + source: snippet source; + doCompile. + compilationResult isError ifTrue: [ + compilationResult ast allNotices do: [ :n | + self assert: (snippet hasNotice: n) + ]]. snippet isFaultyMinusUndeclared - ifTrue: [ - self assert: error isNotNil. - self assert: method equals: #tag ] + ifTrue: [ self assert: compilationResult isError ] ifFalse: [ - self assert: error isNil. - self assert: method isCompiledMethod. - self testExecute: method ] + self deny: compilationResult isError. + self assert: compilationResult compiledMethod isCompiledMethod. + self testExecute: compilationResult compiledMethod ] ] { #category : 'tests' } OCCompileCodeSnippetTest >> testCompileWithRequestor [ - | requestor method | - requestor := OCMockRequestor new. - requestor interactive: false. - requestor isScripting: nil. - requestor text: nil. - method := OpalCompiler new - isScripting: snippet isScripting; - requestor: requestor; - failBlock: [ "When a requestion is set, a failBlock MUST also be set or compilation might crash internally" - | n | - self assert: requestor notifyList size equals: 1. - n := requestor notifyList first. - self assert: - (snippet - hasNotice: (n first allButLast: 3) - at: n second). - self assert: snippet isFaulty. - ^ self ]; - compile: snippet source. - - "Still alive? (failBlock never called)" + | method compilationResult | + compilationResult := OpalCompiler new + isScripting: snippet isScripting; + source: snippet source; + doCompile. + compilationResult isError ifTrue: [ + self assert: snippet isFaulty. + compilationResult ast allNotices do: [ :n | + self assert: (snippet hasNotice: n messageText at: n position) ]. + "We verified the error case, exit" + ^ self + ]. + + "Now verify the success case" self deny: snippet isFaulty. - self assert: requestor notifyList isEmpty. + + method := compilationResult compiledMethod. self assert: method isCompiledMethod. self testExecute: method ] @@ -226,7 +200,7 @@ OCCompileCodeSnippetTest >> testDump [ | ast dump ast2 dump2 | ast := snippet parse. dump := ast dump. - ast2 := OpalCompiler new evaluate: dump. + ast2 := OpalEvaluator new evaluate: dump. self assert: ast2 equals: ast. dump2 := ast2 dump. self assert: dump2 equals: dump diff --git a/src/AST-Core/OCErrorNotice.class.st b/src/AST-Core/OCErrorNotice.class.st index 2c967b84c81..6dc4e9dfe34 100644 --- a/src/AST-Core/OCErrorNotice.class.st +++ b/src/AST-Core/OCErrorNotice.class.st @@ -14,3 +14,22 @@ OCErrorNotice >> isError [ ^ true ] + +{ #category : 'testing' } +OCErrorNotice >> isErrorOn: anOpalCompiler [ + + | permitFaulty | + "I'm an error if the compiler does not allow faults. + Otherwise, I'm a warning" + + "I'm an error if the setting is not set" + permitFaulty := anOpalCompiler permitFaulty. + ^ permitFaulty ifNil: [ true ] + ifNotNil: [ permitFaulty not ] +] + +{ #category : 'testing' } +OCErrorNotice >> isWarningOn: anOpalCompiler [ + + ^ (self isErrorOn: anOpalCompiler) not +] diff --git a/src/AST-Core/OCNotice.class.st b/src/AST-Core/OCNotice.class.st index f700772b998..5776b04016e 100644 --- a/src/AST-Core/OCNotice.class.st +++ b/src/AST-Core/OCNotice.class.st @@ -72,6 +72,12 @@ OCNotice >> isError [ ^ false ] +{ #category : 'testing' } +OCNotice >> isErrorOn: anOpalCompiler [ + + ^ false +] + { #category : 'testing' } OCNotice >> isSyntaxError [ @@ -90,6 +96,12 @@ OCNotice >> isWarning [ ^ false ] +{ #category : 'testing' } +OCNotice >> isWarningOn: anOpalCompiler [ + + ^ (self isErrorOn: anOpalCompiler) not +] + { #category : 'accessing' } OCNotice >> messageText [ diff --git a/src/Calypso-SystemQueries/ClySystemEnvironment.class.st b/src/Calypso-SystemQueries/ClySystemEnvironment.class.st index c02c9e27900..162878b0fe7 100644 --- a/src/Calypso-SystemQueries/ClySystemEnvironment.class.st +++ b/src/Calypso-SystemQueries/ClySystemEnvironment.class.st @@ -135,7 +135,6 @@ ClySystemEnvironment >> compileANewClassFrom: newClassDefinitionString notifying compiler := (self classCompilerFor: oldClass) source: newClassDefinitionString; requestor: aController; - failBlock: [ ^ nil ]; logged: true. [newClass := compiler evaluate] diff --git a/src/CodeImport-Commands/ClapCodeEvaluator.class.st b/src/CodeImport-Commands/ClapCodeEvaluator.class.st index f9def1c123e..4bcde525169 100644 --- a/src/CodeImport-Commands/ClapCodeEvaluator.class.st +++ b/src/CodeImport-Commands/ClapCodeEvaluator.class.st @@ -102,7 +102,7 @@ ClapCodeEvaluator >> evaluate [ { #category : 'execution' } ClapCodeEvaluator >> evaluateExpression [ - ^ [ self class compiler evaluate: self source ] + ^ [ OpalEvaluator new evaluate: self source ] on: Error do: [ :error | self handleError: error ] ] diff --git a/src/Debugger-Model-Tests/OCSourceCode2BytecodeTest.class.st b/src/Debugger-Model-Tests/OCSourceCode2BytecodeTest.class.st index ec5d94ad3e9..aea14497d09 100644 --- a/src/Debugger-Model-Tests/OCSourceCode2BytecodeTest.class.st +++ b/src/Debugger-Model-Tests/OCSourceCode2BytecodeTest.class.st @@ -23,11 +23,12 @@ OCSourceCode2BytecodeTest class >> classVar [ { #category : 'compiling' } OCSourceCode2BytecodeTest >> compile2method: sourceStream [ - "Compile code without logging the source in the changes file" - ^OpalCompiler new - source: sourceStream; - class: self class; - compile + "Compile code without logging the source in the changes file" + + ^ OpalCompiler new + source: sourceStream; + class: self class; + newCompile ] { #category : 'accessing' } diff --git a/src/Debugger-Model/DebugContext.class.st b/src/Debugger-Model/DebugContext.class.st index 254e4bd3786..8a1b220afcb 100644 --- a/src/Debugger-Model/DebugContext.class.st +++ b/src/Debugger-Model/DebugContext.class.st @@ -161,26 +161,44 @@ DebugContext >> recompileCurrentMethodTo: aText notifying: aNotifyer [ | classOrTraitOfMethod selector | self context method isDoIt ifFalse: [ - selector := self selectedClass compiler parseSelector: aText. - (self checkSelectorUnchanged: selector) ifFalse: [ ^ nil ] ]. + selector := self selectedClass compiler parseSelector: aText. + (self checkSelectorUnchanged: selector) ifFalse: [ ^ nil ] ]. (self selectedClass includesSelector: selector) ifFalse: [ - ^ self selectedClass compiler - protocol: self selectedMessageCategoryName; - isScripting: self selectedMessageName isDoIt; - requestor: aNotifyer; - compile: aText ]. - - classOrTraitOfMethod := self - confirmOnTraitOverwrite: selector - inClass: self selectedClass. + self selectedMessageName isDoIt + ifTrue: [ + self selectedClass compiler + protocol: self selectedMessageCategoryName; + isScripting: self selectedMessageName isDoIt; + requestor: aNotifyer; + compile: aText ] + ifFalse: [ + self selectedClass + compile: aText asString + classified: self selectedMessageCategoryName + withStamp: DateAndTime now + notifying: aNotifyer + logSource: self selectedClass shouldLogSource ]. + ^ self selectedClass >> self selectedMessageName ]. + + classOrTraitOfMethod := self confirmOnTraitOverwrite: selector inClass: self selectedClass. classOrTraitOfMethod ifNil: [ ^ nil ]. - ^ classOrTraitOfMethod compiler - protocol: self selectedMessageCategoryName; - isScripting: self selectedMessageName isDoIt; - requestor: aNotifyer; - install: aText + self selectedMessageName isDoIt + ifTrue: [ + classOrTraitOfMethod compiler + protocol: self selectedMessageCategoryName; + isScripting: self selectedMessageName isDoIt; + requestor: aNotifyer; + compile: aText ] + ifFalse: [ + classOrTraitOfMethod + compile: aText asString + classified: self selectedMessageCategoryName + withStamp: DateAndTime now + notifying: aNotifyer + logSource: classOrTraitOfMethod shouldLogSource ]. + ^ classOrTraitOfMethod >> self selectedMessageName ] { #category : 'accessing' } diff --git a/src/Deprecated14/Behavior.extension.st b/src/Deprecated14/Behavior.extension.st new file mode 100644 index 00000000000..090678083c5 --- /dev/null +++ b/src/Deprecated14/Behavior.extension.st @@ -0,0 +1,44 @@ +Extension { #name : 'Behavior' } + +{ #category : '*Deprecated14' } +Behavior >> compile: sourceCode classified: protcol notifying: requestor [ + "Return the selector of the compiled method" + + self deprecated: 'Use #compile:classified:withStamp:notifying:logSource: if you need the old style requestor'. + ^ self + compile: sourceCode + classified: protcol + withStamp: DateAndTime now + notifying: requestor + logSource: self shouldLogSource +] + +{ #category : '*Deprecated14' } +Behavior >> compile: sourceCode classified: protocol withStamp: changeStamp notifying: requestor [ + "Return the selector of the compiled method" + + self deprecated: 'Use #compile:classified:withStamp:notifying:logSource: if you need the old style requestor'. + ^ self + compile: sourceCode + classified: protocol + withStamp: changeStamp + notifying: requestor + logSource: self shouldLogSource +] + +{ #category : '*Deprecated14' } +Behavior >> compile: code notifying: requestor [ + "Compile the argument, code, as source code in the context of the + receiver and insEtall the result in the receiver's method dictionary. The + second argument, requestor, is to be notified if an error occurs. The + argument code is either a string or an object that converts to a string or + a PositionableStream. This method also saves the source code." + + self deprecated: 'Use #compile:classified:withStamp:notifying:logSource: if you need the old style requestor'. + ^ self + compile: code + classified: nil + withStamp: DateAndTime now + notifying: requestor + logSource: self shouldLogSource +] diff --git a/src/Epicea-Tests/EpMonitorIntegrationTest.class.st b/src/Epicea-Tests/EpMonitorIntegrationTest.class.st index 371b4bad3be..c01a8b061fe 100644 --- a/src/Epicea-Tests/EpMonitorIntegrationTest.class.st +++ b/src/Epicea-Tests/EpMonitorIntegrationTest.class.st @@ -45,7 +45,9 @@ EpMonitorIntegrationTest >> setUp [ logBuilder := EpTestLogBuilder new useLogWithSessionStore; yourself. - classFactory := ClassFactoryForTestCase new. + + "Epicea works, sadly, with the global environment only" + classFactory := ClassFactoryForTestCase environment: self class environment. monitor := EpMonitor newWithLog: logBuilder log ] diff --git a/src/Flashback-Decompiler-Tests/FBDDecompilerTest.class.st b/src/Flashback-Decompiler-Tests/FBDDecompilerTest.class.st index 8a4438bad69..5e1e6d84788 100644 --- a/src/Flashback-Decompiler-Tests/FBDDecompilerTest.class.st +++ b/src/Flashback-Decompiler-Tests/FBDDecompilerTest.class.st @@ -654,7 +654,7 @@ FBDDecompilerTest >> testPragma [ '; class: OCMockCompilationClass; - compile. + newCompile. bytecode := aCompiledMethod symbolic asString substrings: String cr. self assert: bytecode first equals: 'Quick return self' diff --git a/src/Kernel-CodeModel-Tests/UndeclaredVariableTest.class.st b/src/Kernel-CodeModel-Tests/UndeclaredVariableTest.class.st index 581542cce68..0bdfe9826c0 100644 --- a/src/Kernel-CodeModel-Tests/UndeclaredVariableTest.class.st +++ b/src/Kernel-CodeModel-Tests/UndeclaredVariableTest.class.st @@ -17,7 +17,7 @@ UndeclaredVariableTest >> compile: source in: class [ source: source; permitUndeclared: true; permitFaulty: false. - method := compiler compile. + method := compiler newCompile. class methodInstaller install: method into: class compiler: compiler. ^ method selector ] diff --git a/src/Kernel-CodeModel/Extension.class.st b/src/Kernel-CodeModel/Extension.class.st index aade5436cdc..77639d1df6e 100644 --- a/src/Kernel-CodeModel/Extension.class.st +++ b/src/Kernel-CodeModel/Extension.class.st @@ -18,6 +18,17 @@ Extension >> addUserPackage: aPackage [ self userPackages add: aPackage ] +{ #category : 'as yet unclassified' } +Extension >> compile: sourceCode classified: protocol withStamp: changeStamp logSource: logSource [ + "Return the selector of the compiled method" + + ^ self compile: sourceCode methodInstaller: (self methodInstaller + logged: logSource; + changeStamp: changeStamp; + protocol: protocol; + shouldRecompileDependencies: true) +] + { #category : 'accessing' } Extension >> defineScopedSelector: aSymbol [ diff --git a/src/Kernel-CodeModel/OCExtensionMethodInstaller.class.st b/src/Kernel-CodeModel/OCExtensionMethodInstaller.class.st index 405ba12db90..ae970585f8d 100644 --- a/src/Kernel-CodeModel/OCExtensionMethodInstaller.class.st +++ b/src/Kernel-CodeModel/OCExtensionMethodInstaller.class.st @@ -68,7 +68,7 @@ OCExtensionMethodInstaller >> install: method into: extension compiler: compiler packagesToRecompile := { extension package }. extension hasUserPackages ifTrue: [ packagesToRecompile := packagesToRecompile , extension userPackages asArray ]. (packagesToRecompile flatCollect: [ :p | p methods ]) do: [ :m | - m methodClass compile: m sourceCode notifying: nil methodInstaller: (m methodClass methodInstaller + m methodClass compile: m sourceCode methodInstaller: (m methodClass methodInstaller logged: false; changeStamp: changeStamp; protocol: m protocol) ] diff --git a/src/Kernel-CodeModel/Package.class.st b/src/Kernel-CodeModel/Package.class.st index d040071f1ad..e4fdbfd8e76 100644 --- a/src/Kernel-CodeModel/Package.class.st +++ b/src/Kernel-CodeModel/Package.class.st @@ -128,7 +128,6 @@ Package >> addExtensionImport: anExtension [ compile: m sourceCode classified: m protocol withStamp: m timeStamp - notifying: nil logSource: true ] ] diff --git a/src/Kernel-Extended-Tests/CompiledMethodTest.class.st b/src/Kernel-Extended-Tests/CompiledMethodTest.class.st index b0f144adfae..e35fcff48d5 100644 --- a/src/Kernel-Extended-Tests/CompiledMethodTest.class.st +++ b/src/Kernel-Extended-Tests/CompiledMethodTest.class.st @@ -37,7 +37,6 @@ CompiledMethodTest >> packageNameForTests [ { #category : 'running' } CompiledMethodTest >> setUp [ super setUp. - testingEnvironment := Smalltalk globals. someClass := SomeClassForCompiledMethodTests ] @@ -322,7 +321,7 @@ CompiledMethodTest >> testIsFaulty [ cm := OpalCompiler new source: 'method 3+'; permitFaulty: true; - compile. + newCompile. self assert: cm isFaulty. self deny: (OCASTTranslator>>#visitParseErrorNode:) isFaulty ] @@ -1020,15 +1019,15 @@ CompiledMethodTest >> testWritesUndeclared [ "x is an ivar" method := self someClass compiler compile: 'x ^ x := 0'. self deny: method usesUndeclareds. - self assert: (self executeMethod: method) equals: 0. + self assert: (self someClass new executeMethod: method) equals: 0. "undeclaredxyz is not declared" method := self someClass compiler permitFaulty: true; compile: 'z ^ undeclaredxyz := 1'. self assert: method usesUndeclareds. - self should: [ self executeMethod: method ] raise: UndeclaredVariableWrite. + self should: [ self someClass new executeMethod: method ] raise: UndeclaredVariableWrite. self assert: - ([ self executeMethod: method ] + ([ self someClass new executeMethod: method ] on: UndeclaredVariableWrite do: [:e | e resume]) equals: 1. @@ -1036,10 +1035,10 @@ CompiledMethodTest >> testWritesUndeclared [ "check same behavior in blocks" method := self someClass compiler permitFaulty: true; compile: 'msg ^ self in: [ :anObject | undeclaredxyz := 2 ]'. self assert: method usesUndeclareds. - self should: [ self executeMethod: method ] raise: UndeclaredVariableWrite. + self should: [ self someClass new executeMethod: method ] raise: UndeclaredVariableWrite. self assert: - ([ self executeMethod: method ] + ([ self someClass new executeMethod: method ] on: UndeclaredVariableWrite do: [:e | e resume]) equals: 2 diff --git a/src/Kernel-Tests/IVsAndClassVarNamesConflictTest.class.st b/src/Kernel-Tests/IVsAndClassVarNamesConflictTest.class.st index fd1f9cefb1c..c6808168948 100644 --- a/src/Kernel-Tests/IVsAndClassVarNamesConflictTest.class.st +++ b/src/Kernel-Tests/IVsAndClassVarNamesConflictTest.class.st @@ -15,7 +15,7 @@ Class { { #category : 'running' } IVsAndClassVarNamesConflictTest >> setUp [ super setUp. - classFactory := ClassFactoryForTestCase new + classFactory := ClassFactoryForTestCase environment: testingEnvironment ] { #category : 'running' } diff --git a/src/Kernel-Tests/TrueTest.class.st b/src/Kernel-Tests/TrueTest.class.st index b1a9b3ba866..38dfa3b5c2d 100644 --- a/src/Kernel-Tests/TrueTest.class.st +++ b/src/Kernel-Tests/TrueTest.class.st @@ -12,7 +12,7 @@ Class { { #category : 'coverage' } TrueTest >> classToBeTested [ - ^ True new + ^ True ] { #category : 'tests - logical operations' } diff --git a/src/Monticello-Tests/MCStWriterTest.class.st b/src/Monticello-Tests/MCStWriterTest.class.st index 4588aa45d73..b77a2da7a99 100644 --- a/src/Monticello-Tests/MCStWriterTest.class.st +++ b/src/Monticello-Tests/MCStWriterTest.class.st @@ -23,7 +23,7 @@ MCStWriterTest >> assertChunkIsWellFormed: chunk [ source: chunk; class: UndefinedObject; isScripting: true; - compile + newCompile ] { #category : 'asserting' } @@ -39,7 +39,7 @@ MCStWriterTest >> assertMethodChunkIsWellFormed: chunk [ self class compiler source: chunk; class: UndefinedObject; - compile. + newCompile. ] diff --git a/src/OpalCompiler-Core/Behavior.extension.st b/src/OpalCompiler-Core/Behavior.extension.st index 5359bf91140..a2728d6112c 100644 --- a/src/OpalCompiler-Core/Behavior.extension.st +++ b/src/OpalCompiler-Core/Behavior.extension.st @@ -12,7 +12,11 @@ Behavior >> compile: code [ The argument is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." - ^ self compile: code classified: nil notifying: nil + ^ self + compile: code + classified: nil + withStamp: DateAndTime now + logSource: self shouldLogSource ] { #category : '*OpalCompiler-Core' } @@ -22,37 +26,18 @@ Behavior >> compile: sourceCode classified: protocol [ The argument sourceCode is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." - ^ self compile: sourceCode classified: protocol notifying: nil -] - -{ #category : '*OpalCompiler-Core' } -Behavior >> compile: sourceCode classified: protcol notifying: requestor [ - "Return the selector of the compiled method" - - ^ self - compile: sourceCode - classified: protcol - withStamp: DateAndTime now - notifying: requestor -] - -{ #category : '*OpalCompiler-Core' } -Behavior >> compile: sourceCode classified: protocol withStamp: changeStamp notifying: requestor [ - "Return the selector of the compiled method" - ^ self compile: sourceCode classified: protocol - withStamp: changeStamp - notifying: requestor + withStamp: DateAndTime now logSource: self shouldLogSource ] { #category : '*OpalCompiler-Core' } -Behavior >> compile: sourceCode classified: protocol withStamp: changeStamp notifying: requestor logSource: logSource [ +Behavior >> compile: sourceCode classified: protocol withStamp: changeStamp logSource: logSource [ "Return the selector of the compiled method" - ^ self compile: sourceCode notifying: requestor methodInstaller: (self methodInstaller + ^ self compile: sourceCode methodInstaller: (self methodInstaller logged: logSource; changeStamp: changeStamp; protocol: protocol) @@ -84,34 +69,17 @@ Behavior >> compile: selector from: oldClass [ ] { #category : '*OpalCompiler-Core' } -Behavior >> compile: code notifying: requestor [ - "Compile the argument, code, as source code in the context of the - receiver and insEtall the result in the receiver's method dictionary. The - second argument, requestor, is to be notified if an error occurs. The - argument code is either a string or an object that converts to a string or - a PositionableStream. This method also saves the source code." - - self deprecated: 'Use #compile:classified:notifying: instead'. - ^ self compile: code classified: nil notifying: requestor -] - -{ #category : '*OpalCompiler-Core' } -Behavior >> compile: sourceCode notifying: requestor methodInstaller: methodInstaller [ +Behavior >> compile: sourceCode methodInstaller: methodInstaller [ "Return the selector of the compiled method" | method compiler | - sourceCode ifEmpty: [ Error signal: 'The source code should not be empty' ]. compiler := self compiler source: sourceCode; - requestor: requestor; - failBlock: (requestor ifNotNil: [ [ ^ nil ] ]); - "no failblock if no requestor" - "compatibility: permit undeclared if no requestor" - permitUndeclared: false; + "compatibility: permit undeclared if no requestor" + permitUndeclared: false; permitFaulty: false. - - method := compiler compile. + method := compiler newCompile. methodInstaller install: method into: self compiler: compiler. ^ method selector ] @@ -133,21 +101,19 @@ Behavior >> compileAllFrom: oldClass [ Behavior >> compileSilently: sourceCode [ "Compile the code and classify the resulting method in the given protocol, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." - ^ self compileSilently: sourceCode classified: 'not defined protocol' notifying: nil + ^ self compileSilently: sourceCode classified: 'not defined protocol' ] { #category : '*OpalCompiler-Core' } Behavior >> compileSilently: sourceCode classified: protocolName [ "Compile the code and classify the resulting method in the given protocol, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." - ^ self compileSilently: sourceCode classified: protocolName notifying: nil -] - -{ #category : '*OpalCompiler-Core' } -Behavior >> compileSilently: sourceCode classified: protocolName notifying: requestor [ - "Compile the code and classify the resulting method in the given protocol, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list." - - ^ self codeChangeAnnouncer suspendAllWhile: [ self compile: sourceCode classified: protocolName notifying: requestor ] + ^ self codeChangeAnnouncer suspendAllWhile: [ + self + compile: sourceCode + classified: protocolName + withStamp: DateAndTime now + logSource: self shouldLogSource ] ] { #category : '*OpalCompiler-Core' } diff --git a/src/OpalCompiler-Core/OCCompilationError.class.st b/src/OpalCompiler-Core/OCCompilationError.class.st new file mode 100644 index 00000000000..f186d801984 --- /dev/null +++ b/src/OpalCompiler-Core/OCCompilationError.class.st @@ -0,0 +1,29 @@ +Class { + #name : 'OCCompilationError', + #superclass : 'Error', + #instVars : [ + 'compilationResult' + ], + #category : 'OpalCompiler-Core-Exceptions', + #package : 'OpalCompiler-Core', + #tag : 'Exceptions' +} + +{ #category : 'accessing' } +OCCompilationError >> compilationResult [ + + ^ compilationResult +] + +{ #category : 'accessing' } +OCCompilationError >> compilationResult: anObject [ + + compilationResult := anObject +] + +{ #category : 'initialization' } +OCCompilationError >> initialize [ + + super initialize. + messageText := 'Error while compiling' +] diff --git a/src/OpalCompiler-Core/OCErrorCompilationResult.class.st b/src/OpalCompiler-Core/OCErrorCompilationResult.class.st new file mode 100644 index 00000000000..f877f5cbc6d --- /dev/null +++ b/src/OpalCompiler-Core/OCErrorCompilationResult.class.st @@ -0,0 +1,36 @@ +Class { + #name : 'OCErrorCompilationResult', + #superclass : 'Object', + #instVars : [ + 'ast' + ], + #category : 'OpalCompiler-Core-FrontEnd', + #package : 'OpalCompiler-Core', + #tag : 'FrontEnd' +} + +{ #category : 'accessing' } +OCErrorCompilationResult >> ast [ + + ^ ast +] + +{ #category : 'accessing' } +OCErrorCompilationResult >> ast: anObject [ + + ast := anObject +] + +{ #category : 'testing' } +OCErrorCompilationResult >> isError [ + + ^ true +] + +{ #category : 'testing' } +OCErrorCompilationResult >> signalError [ + + ^ OCCompilationError new + compilationResult: self; + signal +] diff --git a/src/OpalCompiler-Core/OCMethodNode.extension.st b/src/OpalCompiler-Core/OCMethodNode.extension.st index b2357fa16a8..691f63ae7cf 100644 --- a/src/OpalCompiler-Core/OCMethodNode.extension.st +++ b/src/OpalCompiler-Core/OCMethodNode.extension.st @@ -95,7 +95,7 @@ OCMethodNode >> generateMethod [ by OpalCompiler in a full compilation chain might be missing. So use this method if you know what you are doing." - ^ self compiler compile + ^ self compiler newCompile ] { #category : '*OpalCompiler-Core' } diff --git a/src/OpalCompiler-Core/OCSuccessCompilationResult.class.st b/src/OpalCompiler-Core/OCSuccessCompilationResult.class.st new file mode 100644 index 00000000000..24ba438e033 --- /dev/null +++ b/src/OpalCompiler-Core/OCSuccessCompilationResult.class.st @@ -0,0 +1,28 @@ +Class { + #name : 'OCSuccessCompilationResult', + #superclass : 'Object', + #instVars : [ + 'compiledMethod' + ], + #category : 'OpalCompiler-Core-FrontEnd', + #package : 'OpalCompiler-Core', + #tag : 'FrontEnd' +} + +{ #category : 'accessing' } +OCSuccessCompilationResult >> compiledMethod [ + + ^ compiledMethod +] + +{ #category : 'accessing' } +OCSuccessCompilationResult >> compiledMethod: anObject [ + + compiledMethod := anObject +] + +{ #category : 'testing' } +OCSuccessCompilationResult >> isError [ + + ^ false +] diff --git a/src/OpalCompiler-Core/OCUndeclaredVariableNotice.class.st b/src/OpalCompiler-Core/OCUndeclaredVariableNotice.class.st index 565b994c903..9a1eca982b7 100644 --- a/src/OpalCompiler-Core/OCUndeclaredVariableNotice.class.st +++ b/src/OpalCompiler-Core/OCUndeclaredVariableNotice.class.st @@ -6,6 +6,19 @@ Class { #tag : 'FrontEnd' } +{ #category : 'testing' } +OCUndeclaredVariableNotice >> isErrorOn: anOpalCompiler [ + + | permitFaulty permitUndeclared | + "I'm an error if the compiler does not allow faults. + Otherwise, I'm a warning" + + "I'm an error if the setting is not set" + permitUndeclared := anOpalCompiler permitUndeclared ifNil: [ false ]. + permitFaulty := anOpalCompiler permitFaulty ifNil: [ false ]. + ^ permitUndeclared not and: [ permitFaulty not ] +] + { #category : 'testing' } OCUndeclaredVariableNotice >> isUndeclaredNotice [ diff --git a/src/OpalCompiler-Core/OpalCompiler.class.st b/src/OpalCompiler-Core/OpalCompiler.class.st index 6ad74de0693..9ae2eacf4af 100644 --- a/src/OpalCompiler-Core/OpalCompiler.class.st +++ b/src/OpalCompiler-Core/OpalCompiler.class.st @@ -35,12 +35,12 @@ Class { 'compilationContextClass', 'permitFaulty', 'permitUndeclared', - 'failBlock', 'logged', 'changeStamp', 'protocol', 'requestor', - 'priorMethod' + 'priorMethod', + 'compilationResult' ], #classInstVars : [ 'overlayEnvironment' @@ -263,69 +263,6 @@ OpalCompiler >> changeStamp: aString [ changeStamp := aString ] -{ #category : 'private' } -OpalCompiler >> checkNotice: aNotice [ - "This method handles all the logic of error handling. - - Error handing in the compiler is only performed at one place, after the parsing/semantic analysis/other parse plugins. - Each ASTNotice in the AST is then checked with this method. - - There is only three outcomes: - * If this method returns true (OK), then the work of the compiler can continue. - Next notice is then processed. - Or, if this that was the last notice, compilation and cie can be performed. - * If this method returns false (not OK), then the compilation is cancelled. - The failBlock will be invoked. - * If this method returns nil (stop checking), then skip the rest of the notice checks. - This one is used in case of reparation, where a new (checked) AST is produced. - - Errors that may happen later in the backend are consireded internal errors and should not occur (bugs). - - This method is a little long because it handles the requestor (quirks) mode. - " - - aNotice isWarning ifTrue: [ ^ true ]. - (aNotice isUndeclaredNotice and: [ self permitUndeclared ]) ifTrue: [ - OCUndeclaredVariableWarning new - notice: aNotice; - signal. - ^ true ]. - - self requestor ifNotNil: [ - "A requestor is available. We are in quirks mode and are expected to do UI things." - "Reparation menu in quirks mode: - * require a requestor (because quirks mode, and also some reparations expect a requestor) - * require interactive mode (because GUI) - * require method definition becase some reparation assume it's a method body" - self isInteractive ifTrue: [ - aNotice reparator ifNotNil: [ :reparator | - | res | - res := reparator - requestor: requestor; - openMenu. - res ifNil: [ ^ true "reparation unneded, let AST as is" ]. - res ifFalse: [ ^ false "operation cancelled, fail" ]. - self parse: requestor text. "some reparation was done, reparse" - ^ nil ] ]. - - "Quirks mode: otherwise, push the error message to the requestor" - requestor - notify: aNotice messageText , ' ->' - at: aNotice position - in: aNotice node source. - - "Quirks mode: Then leave" - ^ false ]. - - "If a failBlock is provided in non-requestor mode, - we honor it and do not signal exceptions" - self failBlock ifNotNil: [ ^ false ]. - - aNotice signalError. - - ^ true "Error was resumed, so we consider it's OK to continue" -] - { #category : 'accessing' } OpalCompiler >> class: aClass [ self compilationContext class: aClass @@ -351,6 +288,18 @@ OpalCompiler >> compilationContextClass: aClass [ compilationContextClass := aClass ] +{ #category : 'accessing' } +OpalCompiler >> compilationResult [ + + ^ compilationResult +] + +{ #category : 'accessing' } +OpalCompiler >> compilationResult: anObject [ + + compilationResult := anObject +] + { #category : 'public access' } OpalCompiler >> compile [ @@ -362,6 +311,10 @@ OpalCompiler >> compile [ result := self parse. ast ifNil: [ "some failBlock" ^ result ] ]. + (ast allNotices anySatisfy: [ :e | e isErrorOn: self ]) ifTrue: [ + compilationResult := OCErrorCompilationResult new. + ]. + self callPlugins. (compilationContext isSemanticAnalysisNeeded or: [ ast scope isNil ]) ifTrue: [ @@ -416,6 +369,43 @@ OpalCompiler >> decompileMethod: aCompiledMethod [ ifAbsent: [ OCMethodNode errorMethodNode: aCompiledMethod selector errorMessage: 'No decompiler available'. ] ] +{ #category : 'public access' } +OpalCompiler >> doCompile [ + + | parseResult | + parseResult := self doParse. + parseResult isError ifTrue: [ ^ parseResult ]. + + self callPlugins. + (compilationContext isSemanticAnalysisNeeded or: [ ast scope isNil ]) + ifTrue: [ + self doSemanticAnalysis ]. + + ^ OCSuccessCompilationResult new + compiledMethod: self generateMethod; + yourself +] + +{ #category : 'public access' } +OpalCompiler >> doParse [ + "Policy: compiling is non-faulty by default" + + self permitFaulty ifNil: [ self permitFaulty: false ]. + + ast ifNil: [ + self parse. + ast ifNil: [ ^ OCErrorCompilationResult new yourself ] ]. + + (ast allNotices anySatisfy: [ :e | e isErrorOn: self ]) ifTrue: [ + ^ OCErrorCompilationResult new + ast: ast; + yourself ]. + + ^ OCSuccessCompilationResult new + compiledMethod: ast; + yourself +] + { #category : 'private' } OpalCompiler >> doSemanticAnalysis [ @@ -459,7 +449,9 @@ OpalCompiler >> evaluate [ | value doItMethod | self isScripting: true. doItMethod := self compile. - ast ifNil: [ ^ doItMethod ]. + ast ifNil: [ ^ nil ]. + doItMethod ifNil: [ ^ nil ]. + value := self semanticScope evaluateDoIt: doItMethod. self logged == true ifTrue: [ self semanticScope announceDoItEvaluation: source by: self class codeSupportAnnouncer ]. @@ -474,18 +466,6 @@ OpalCompiler >> evaluate: textOrString [ evaluate ] -{ #category : 'accessing' } -OpalCompiler >> failBlock [ - - ^ failBlock -] - -{ #category : 'accessing' } -OpalCompiler >> failBlock: aBlock [ - - failBlock := aBlock -] - { #category : 'public access' } OpalCompiler >> format [ ^self parse formattedCode @@ -566,17 +546,6 @@ OpalCompiler >> install: aSource [ ^ self install ] -{ #category : 'testing' } -OpalCompiler >> isInteractive [ - - self requestor ifNil: [ ^ false ]. - "we asume requestors are interactive, but they can override. - this should be simplified " - ^ (self requestor respondsTo: #interactive) - ifTrue: [ self requestor interactive ] - ifFalse: [ true ] -] - { #category : 'accessing' } OpalCompiler >> isScripting [ ^ self compilationContext isScripting @@ -615,6 +584,28 @@ OpalCompiler >> needRequestorScope [ ^ self requestor needRequestorScope ] +{ #category : 'public access' } +OpalCompiler >> newCompile [ + + | result | + result := self doCompile. + result isError ifTrue: [ + ^ result signalError ]. + + ^ result compiledMethod +] + +{ #category : 'public access' } +OpalCompiler >> newParse [ + + | result | + result := self doParse. + result isError ifTrue: [ + ^ result signalError ]. + + ^ result compiledMethod +] + { #category : 'public access' } OpalCompiler >> options: anOptionsArray [ @@ -635,21 +626,13 @@ OpalCompiler >> parse [ parser := self parserClass new. parser initializeParserWith: source. - ast := self isScripting ifTrue: [ parser parseDoIt ] ifFalse: [ parser parseMethod ]. + ast := self isScripting + ifTrue: [ parser parseDoIt ] + ifFalse: [ parser parseMethod ]. ast methodNode compilationContext: self compilationContext. self doSemanticAnalysis. - self permitFaulty ifFalse: [ - ast allNotices sorted do: [ :n | - | check | - check := self checkNotice: n. - check ifNil: [ ^ ast ]. - check ifFalse: [ - ast := nil. - ^ self failBlock ifNotNil: [ :block | block cull: n ] ifNil: [ nil ]. - ] ] ]. - ^ ast ] diff --git a/src/OpalCompiler-Core/OpalEvaluator.class.st b/src/OpalCompiler-Core/OpalEvaluator.class.st new file mode 100644 index 00000000000..4378aa7498c --- /dev/null +++ b/src/OpalCompiler-Core/OpalEvaluator.class.st @@ -0,0 +1,58 @@ +Class { + #name : 'OpalEvaluator', + #superclass : 'Object', + #instVars : [ + 'failBlock', + 'permitFaultyEvaluation', + 'compiler' + ], + #category : 'OpalCompiler-Core-FrontEnd', + #package : 'OpalCompiler-Core', + #tag : 'FrontEnd' +} + +{ #category : 'adding' } +OpalEvaluator >> addParsePlugin: anOCDynamicASTCompilerPlugin [ + + compiler addParsePlugin: anOCDynamicASTCompilerPlugin +] + +{ #category : 'accessing' } +OpalEvaluator >> evaluate: aString [ + + | doItMethod | + compiler source: aString. + compiler permitFaulty: (permitFaultyEvaluation ifNil: [ false ]). + compiler permitUndeclared: compiler permitFaulty. + doItMethod := compiler compile. + + (compiler ast allNotices select: [ :e | e isErrorOn: compiler ]) sorted do: [ :n | + failBlock ifNotNil: [ ^ failBlock cull: n ]. + n signalError ]. + + + compiler ast ifNil: [ ^ nil ]. + doItMethod ifNil: [ ^ nil ]. + + ^ nil withArgs: #( ) executeMethod: doItMethod +] + +{ #category : 'accessing' } +OpalEvaluator >> failBlock: aFullBlockClosure [ + + failBlock := aFullBlockClosure +] + +{ #category : 'accessing' } +OpalEvaluator >> initialize [ + + super initialize. + compiler := OpalCompiler new. + compiler isScripting: true +] + +{ #category : 'public access' } +OpalEvaluator >> permitFaulty: aBoolean [ + + permitFaultyEvaluation := aBoolean +] diff --git a/src/OpalCompiler-Tests/OCAnnotationTest.class.st b/src/OpalCompiler-Tests/OCAnnotationTest.class.st index b5935e03745..c8cd6636033 100644 --- a/src/OpalCompiler-Tests/OCAnnotationTest.class.st +++ b/src/OpalCompiler-Tests/OCAnnotationTest.class.st @@ -49,54 +49,47 @@ OCAnnotationTest >> testAnnotationBinding [ | plugin result | plugin := OCDynamicASTCompilerPlugin newFromTransformBlock: [ :ast | "In fact, there is no transformation" - (OCParseTreeSearcher new - matches: '@binding: `@arg' - do: [ :node :ans | "Static syntax check" - node arguments first isVariable - ifFalse: [ "Not a variable, add a syntax error" - node arguments first addError: 'Variable expected'. - "Also add a compile-time error for faulty modes" - node receiver emitValueBlock: [ :methodBuilder | - methodBuilder - pushLiteralVariable: OCRuntimeSyntaxError binding; - pushLiteral: 'Variable expected'; - send: #signal: ] ] - ifTrue: [ "It's a real variable, to use the binding. + (OCParseTreeSearcher new matches: '@binding: `@arg' do: [ :node :ans | "Static syntax check" + node arguments first isVariable + ifFalse: [ "Not a variable, add a syntax error" + node arguments first addError: 'Variable expected'. "Also add a compile-time error for faulty modes" + node receiver emitValueBlock: [ :methodBuilder | + methodBuilder + pushLiteralVariable: OCRuntimeSyntaxError binding; + pushLiteral: 'Variable expected'; + send: #signal: ] ] + ifTrue: [ "It's a real variable, to use the binding. Note: currenlty variables are not bound yet, but they will be when the block is evaluated" - node receiver emitValueBlock: [ :methodBuilder | - methodBuilder pushLiteral: - node arguments first variable ] ] ]) executeTree: - ast. - ast ] - andPriority: 0. - - "Use plugin with compiler" - result := Object compiler + node receiver emitValueBlock: [ :methodBuilder | methodBuilder pushLiteral: node arguments first variable ] ] ]) + executeTree: ast. + ast ] + andPriority: 0. "Use plugin with compiler" + result := OpalEvaluator new addParsePlugin: plugin; evaluate: '@binding: Object'. self assert: result class equals: GlobalVariable. self assert: result key equals: #Object. self assert: result value equals: Object. - result := Object compiler + result := OpalEvaluator new addParsePlugin: plugin; evaluate: '@binding: self'. self assert: result class equals: SelfVariable. - result := Object compiler + result := OpalEvaluator new addParsePlugin: plugin; failBlock: [ :n | - self assert: n messageText equals: 'Variable expected'. - #failed ]; + self assert: n messageText equals: 'Variable expected'. + #failed ]; evaluate: '@binding: 42'. self assert: result equals: #failed. self should: [ - Object compiler - addParsePlugin: plugin; - permitFaulty: true; - evaluate: '@binding: 42' ] + OpalEvaluator new + addParsePlugin: plugin; + permitFaulty: true; + evaluate: '@binding: 42' ] raise: OCRuntimeSyntaxError ] diff --git a/src/OpalCompiler-Tests/OCArrayLiteralTest.class.st b/src/OpalCompiler-Tests/OCArrayLiteralTest.class.st index 546b196b87f..e4e1fe6e699 100644 --- a/src/OpalCompiler-Tests/OCArrayLiteralTest.class.st +++ b/src/OpalCompiler-Tests/OCArrayLiteralTest.class.st @@ -11,7 +11,7 @@ OCArrayLiteralTest >> compile: methodSourceCode [ ^ OpalCompiler new source: methodSourceCode; - compile + newCompile ] { #category : 'tests' } diff --git a/src/OpalCompiler-Tests/OCCodeSnippet.extension.st b/src/OpalCompiler-Tests/OCCodeSnippet.extension.st index 0c0a55dff6c..102e1d1ad38 100644 --- a/src/OpalCompiler-Tests/OCCodeSnippet.extension.st +++ b/src/OpalCompiler-Tests/OCCodeSnippet.extension.st @@ -18,8 +18,12 @@ OCCodeSnippet >> doSemanticAnalysis [ { #category : '*OpalCompiler-Tests' } OCCodeSnippet >> doSemanticAnalysisOnError: aBlock [ - ^ [ OpalCompiler new - isScripting: isScripting; - permitFaulty: false; - parse: self source ] on: OCCodeError do: [ :e | aBlock value: e ] + ^ [ + OpalCompiler new + isScripting: isScripting; + permitFaulty: false; + source: self source; + newParse ] + on: OCCompilationError + do: [ :e | aBlock value: e ] ] diff --git a/src/OpalCompiler-Tests/OCCodeSnippetScriptingTest.class.st b/src/OpalCompiler-Tests/OCCodeSnippetScriptingTest.class.st index aa0dcb8252f..c2dd64f60eb 100644 --- a/src/OpalCompiler-Tests/OCCodeSnippetScriptingTest.class.st +++ b/src/OpalCompiler-Tests/OCCodeSnippetScriptingTest.class.st @@ -22,7 +22,7 @@ OCCodeSnippetScriptingTest >> testEvaluateFailBlock [ error := nil. runBlock := [ - OpalCompiler new + OpalEvaluator new failBlock: [ :e | error := e. #tag ]; evaluate: snippet source ]. @@ -42,7 +42,7 @@ OCCodeSnippetScriptingTest >> testEvaluateFaulty [ self skipIf: #exec. runBlock := [ - OpalCompiler new + OpalEvaluator new permitFaulty: true; evaluate: snippet source ]. @@ -56,7 +56,7 @@ OCCodeSnippetScriptingTest >> testEvaluateOnError [ self skipIf: #exec. value := #tag. - runBlock := [ value := OpalCompiler new evaluate: snippet source ]. + runBlock := [ value := OpalEvaluator new evaluate: snippet source ]. snippet isFaulty ifTrue: [ @@ -64,18 +64,3 @@ OCCodeSnippetScriptingTest >> testEvaluateOnError [ self assert: value equals: #tag ] ifFalse: [ self testExecuteBlock: runBlock ] ] - -{ #category : 'tests' } -OCCodeSnippetScriptingTest >> testEvaluateOnErrorResume [ - - | runBlock value | - self skipIf: #exec. - - value := #tag. - runBlock := [ - [ OpalCompiler new evaluate: snippet source ] - on: OCCodeError - do: [ :e | e resume ] ]. - - self testExecuteBlock: runBlock -] diff --git a/src/OpalCompiler-Tests/OCCompileWithFailureTest.class.st b/src/OpalCompiler-Tests/OCCompileWithFailureTest.class.st index ec12f1a945e..7215550c6de 100644 --- a/src/OpalCompiler-Tests/OCCompileWithFailureTest.class.st +++ b/src/OpalCompiler-Tests/OCCompileWithFailureTest.class.st @@ -37,7 +37,7 @@ OCCompileWithFailureTest >> testEvalSimpleMethodWithError [ cm := (compiler := OpalCompiler new) source: 'method 3+'; permitFaulty: true; - compile. + newCompile. self assert: compiler ast isMethod. self assert: compiler ast isFaulty. @@ -53,7 +53,7 @@ OCCompileWithFailureTest >> testParenthesis [ isScripting: true; requestor: self; permitFaulty: true; - compile. + newCompile. self assert: compiler ast isDoIt. self assert: compiler ast isFaulty. self should: [cm valueWithReceiver: nil] raise: OCRuntimeSyntaxError diff --git a/src/OpalCompiler-Tests/OCCompiledMethodIntegrityTest.class.st b/src/OpalCompiler-Tests/OCCompiledMethodIntegrityTest.class.st index c1dbd0bc188..fb0af16aefb 100644 --- a/src/OpalCompiler-Tests/OCCompiledMethodIntegrityTest.class.st +++ b/src/OpalCompiler-Tests/OCCompiledMethodIntegrityTest.class.st @@ -14,7 +14,7 @@ OCCompiledMethodIntegrityTest >> testBlockTemps [ 'ascentOf: aCharacter ^ [ | temp1 temp2 temp3 | 1= temp1. 2 = temp2. 3 = temp3].'; class: OCMockCompilationClass; - compile. + newCompile. self assert: newCompiledMethod numArgs equals: 1. self assert: (newCompiledMethod numLiterals = 3 or: [ newCompiledMethod numLiterals = 4 "Sista Bytecode" ]). @@ -30,7 +30,7 @@ OCCompiledMethodIntegrityTest >> testNotUsedArgument [ 'ascentOf: aCharacter ^ self ascent.'; class: OCMockCompilationClass; - compile. + newCompile. self assert: newCompiledMethod numArgs equals: 1. self assert: newCompiledMethod numLiterals equals: 3. @@ -47,7 +47,7 @@ OCCompiledMethodIntegrityTest >> testPragmas [ '; class: OCMockCompilationClass; - compile. + newCompile. self assert: newCompiledMethod numArgs equals: 0. self assert: newCompiledMethod numLiterals equals: 2. @@ -68,7 +68,7 @@ OCCompiledMethodIntegrityTest >> testPrimitive [ ^ self basicSize.'; class: OCMockCompilationClass; - compile. + newCompile. self assert: newCompiledMethod numArgs equals: 0. self assert: newCompiledMethod numLiterals equals: 3. @@ -88,7 +88,7 @@ OCCompiledMethodIntegrityTest >> testRemoteTempInVector [ answer := each value]. ^answer'; class: Object; - compile. + newCompile. self assert: newCompiledMethod numArgs equals: 0. self assert: newCompiledMethod numLiterals equals: 3. @@ -105,7 +105,7 @@ OCCompiledMethodIntegrityTest >> testUndeclaredVariable [ ^ undeclaredTestVar'; class: OCMockCompilationClass; permitFaulty: true; - compile. + newCompile. undeclaredBinding := newCompiledMethod literals detect: [ :each | each name = #undeclaredTestVar ]. self assert: undeclaredBinding class equals: UndeclaredVariable. @@ -126,7 +126,7 @@ OCCompiledMethodIntegrityTest >> testUndeclaredVariableWhenItIsAlreadyRegistered ^ undeclaredTestVar'; class: OCMockCompilationClass; permitFaulty: true; - compile. + newCompile. undeclaredBinding := newCompiledMethod literals detect: [ :each | each name = #undeclaredTestVar ]. self assert: undeclaredBinding identicalTo: var. @@ -148,7 +148,7 @@ OCCompiledMethodIntegrityTest >> testUndeclaredVariableWhenItIsAlreadyRegistered ^ undeclaredTestVar'; class: OCMockCompilationClass; permitFaulty: true; - compile. + newCompile. undeclaredBinding := newCompiledMethod literals detect: [ :each | each name = #undeclaredTestVar ]. self assert: undeclaredBinding class equals: UndeclaredVariable. diff --git a/src/OpalCompiler-Tests/OCCompilerNotifyingTest.class.st b/src/OpalCompiler-Tests/OCCompilerNotifyingTest.class.st deleted file mode 100644 index 037c5cd7dbd..00000000000 --- a/src/OpalCompiler-Tests/OCCompilerNotifyingTest.class.st +++ /dev/null @@ -1,333 +0,0 @@ -" -A CompilerNotifyingTest is a TestCase for checking that Compiler/Parser notifications are inserted at the right place in a TextEditor. - -Instance Variables - expectedErrorPositions: - expectedErrors: - failure: - morph: - text: - -errorPositions - - the position where error text should be inserted for each chunk of text evaluated - -errors - - the error text that should be inserted on evaluation of each chunk of text evaluated - -failure - - an object returned in case of evaluation error and whose identity can be uniquely recognized as a failure - -morph - - the Morph holding the text - -text - - the string containing all the chunks to be evaluated (separated by %) - and the expected error messages (`enclosed in back quotes`) - this text will be stripped of the error messages before being evaluated. - - -" -Class { - #name : 'OCCompilerNotifyingTest', - #superclass : 'TestCase', - #instVars : [ - 'text', - 'morph', - 'expectedErrors', - 'expectedErrorPositions', - 'failure' - ], - #category : 'OpalCompiler-Tests-FromOld', - #package : 'OpalCompiler-Tests', - #tag : 'FromOld' -} - -{ #category : 'private' } -OCCompilerNotifyingTest >> enumerateAllSelections [ - 1 to: self numberOfSelections do: [ :n | - self assert: (self evaluateSelectionNumber: n) identicalTo: failure. - self assert: morph editor selection asString equals: (expectedErrors at: n). - self assert: morph editor startIndex equals: (expectedErrorPositions at: n). - morph editor cut ] -] - -{ #category : 'private' } -OCCompilerNotifyingTest >> evaluateSelection [ - ^ OpalCompiler new - source: morph editor selection; - requestor: morph editor; - failBlock: [^failure]; - evaluate -] - -{ #category : 'private' } -OCCompilerNotifyingTest >> evaluateSelectionNumber: n [ - | i start stop | - i := start := 1. - [stop := morph text indexOf: $% startingAt: start + 1 ifAbsent: morph text size + 1. - i = n] - whileFalse: - [i := i + 1. - start := stop + 1]. - morph editor selectFrom: start to: stop - 1. - ^self evaluateSelection -] - -{ #category : 'initialization' } -OCCompilerNotifyingTest >> initializeTextWithoutError [ - "Remove the errors from the text to be compiled and answer the text without errors. - Meanwhile, collect the expected error messages and their expected position." - - | input output errorStream positionStream | - input := text readStream. - output := (String new: text size) writeStream. - errorStream := (Array new: self numberOfSelections) writeStream. - positionStream := (Array new: self numberOfSelections) writeStream. - - [output nextPutAll: (input upTo: $`). - input atEnd] - whileFalse: - [positionStream nextPut: output position + 1. - errorStream nextPut: (input upTo: $`)]. - expectedErrors := errorStream contents. - expectedErrorPositions := positionStream contents. - ^output contents -] - -{ #category : 'private' } -OCCompilerNotifyingTest >> numberOfSelections [ - ^(text occurrencesOf: $%) + 1 -] - -{ #category : 'running' } -OCCompilerNotifyingTest >> setUp [ - super setUp. - failure := Object new -] - -{ #category : 'initialization' } -OCCompilerNotifyingTest >> setUpForErrorsIn: aTextWithErrorsEnclosedInBackQuote [ - "Extract the expectedErrors, the expectedErrorPositions and set up a TextMorph containing the text without errors. - each section separated by % in aTextWithErrorsEnclosedInBackQuote will be evaluated separately. - The expected error message should lie in aTextWithErrorsEnclosedInBackQuote at the expected position, and enclosed in back quotes." - text := aTextWithErrorsEnclosedInBackQuote. - morph := MockSourceEditor new contents: self initializeTextWithoutError asString -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testAssignmentOfSelf [ - - self setUpForErrorsIn: '` Assignment to read-only variable ->`self := 1. ^self'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testDigitTooLargeForARadix [ - - self setUpForErrorsIn: '2r` a digit between 0 and 1 expected ->`3'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testEmptyCaseStatement [ - self flag: 'Opal has the correct behavior but the error is not caught' - - "self setUpForErrorsIn: '^ nil caseOf: { ` At least one case required ->`} '. - self enumerateAllSelections." -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testExpectedExpressionInBraceArray [ - - self setUpForErrorsIn: '{ 1. 2 ` End of statement expected ->`3 }'. - self enumerateAllSelections. - self setUpForErrorsIn: '{ 1. 2. ` Variable or expression expected ->`| x | x}'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testExtraneousStatementAfterAReturnInABlock [ - self setUpForErrorsIn: '[ ^1 ` End of statement expected ->`2]'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testInvalidExternalFunctionDeclaration [ - "Not implemented yet. - #externalFunctionDeclaration skipped, cannot be evaluated" -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testInvalidLiteralCharacter [ - self setUpForErrorsIn: '^ #yourself , #` Literal expected ->`) , #end'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testInvalidPattern [ - "Not implemented yet. - #pattern:inContext: skipped, cannot be evaluated" -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testInvalidPragma [ - "Not implemented yet. - #pragmaLiteral: #pragmaSequence #pragmaStatement #pragmaPrimitives skipped, cannot be evaluated" -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testInvalidPrimitive [ - "Not implemented yet. - ##primitive:error: #primitive:module:error: skipped, cannot be evaluated" -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testInvalidRadix [ - - self setUpForErrorsIn: '1` an integer greater than 1 as valid radix expected ->`r0'. - self enumerateAllSelections. -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingArgumentAfterABinaryMessage [ - self setUpForErrorsIn: '1 +` Variable or expression expected ->`'. - self enumerateAllSelections. - self setUpForErrorsIn: '1 + ` Variable or expression expected ->`* 2 + 3'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingArgumentAfterAMessageKey [ - self setUpForErrorsIn: '1 to: ` Variable or expression expected ->`:='. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingBlockArgumentName [ - - self setUpForErrorsIn: '[ :x : ` Variable name expected ->`1]'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingExpression [ - - - self setUpForErrorsIn: '| x | x := ` Variable or expression expected ->'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingExpressionAfterAReturn [ - - self setUpForErrorsIn: '^ ` Variable or expression expected ->`. 1 + 2'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingMessageAfterACascade [ - - self setUpForErrorsIn: 'nil yourself; ` Cascade message expected ->`^ 2'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingPeriodSeparatorBetweenStatements [ - - self setUpForErrorsIn: '1 + 2 ` End of statement expected ->`^nil'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testMissingSeparatorBetweenBlockArgumentAndStatements [ - - self setUpForErrorsIn: '[ :x ` ''|'' or parameter expected ->`x + 1 ]'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testTooLargeAnIntegerInALiteralByteArray [ - - self setUpForErrorsIn: '#[ 1 2 ` 8-bit integer expected ->`256 4 5]'. - self enumerateAllSelections -] - -{ #category : 'tests - bytecode limits' } -OCCompilerNotifyingTest >> testTooManyArguments [ - self setUpForErrorsIn: '^ ` Too many arguments ->`[:x1 :x2 :x3 :x4 :x5 :x6 :x7 :x8 :x9 :x10 :x11 :x12 :x13 :x14 :x15 :x16 :x17 | ]'. - self enumerateAllSelections -] - -{ #category : 'tests - bytecode limits' } -OCCompilerNotifyingTest >> testTooManyTemporaries [ - self setUpForErrorsIn: '| a1 a2 a3 a4 a5 a6 a7 a8 a9 b1 b2 b3 b4 b5 b6 b7 b8 b9 c1 c2 c3 c4 c5 c6 c7 c8 c9 d1 d2 d3 d4 d5 d6 d7 d8 d9 e1 e2 e3 e4 e5 e6 e7 e8 e9 f1 f2 f3 f4 f5 f6 f7 f8 f9 g1 g2 g3 g4 g5 g6 g7 g8 g9 | - a1 := a2 := a3 := a4 := a5 := a6 := a7 := a8 := a9 := b1 := b2 := b3 := b4 := b5 := b6 := b7 := b8 := b9 := c1 := c2 := c3 := c4 := c5 := c6 := c7 := c8 := c9 := d1 := d2 := d3 := d4 := d5 := d6 := d7 := d8 := d9 := e1 := e2 := e3 := e4 := e5 := e6 := e7 := e8 := e9 := f1 := f2 := f3 := f4 := f5 := f6 := f7 := f8 := f9 := g1 := g2 := g3 := g4 := g5 := g6 := g7 := g8 := g9 := 1'. - self flag: 'fail on jenkins but works on my computer with both compiler I dont know why'. - "self should: [ self enumerateAllSelections ] raise: Error. - [ self enumerateAllSelections ] on: Error do: [ :ex | self assert: ex messageText equals: 'Cannot compile -- stack including temps is too deep' ]" -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedBlockBracket [ - self setUpForErrorsIn: 'nil yourself. [` '']'' expected ->`'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedBraceArray [ - self setUpForErrorsIn: '{ 1. 2` ''}'' expected ->`'. - self enumerateAllSelections. - self setUpForErrorsIn: '{ 1. 2 ` ''}'' expected ->`'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedByteArrayBracket [ - - self setUpForErrorsIn: '#[ 1 2 ` '']'' expected ->`'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedCommentQuote [ - - self setUpForErrorsIn: '1+2 "unfinished comment` Unmatched " in comment. ->`'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedExpressionParenthesis [ - - self setUpForErrorsIn: '1+(2 ` '')'' expected ->`. '. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedLiteralParenthesis [ - - self setUpForErrorsIn: '#( 1 2` '')'' expected ->`'. - self enumerateAllSelections. - self setUpForErrorsIn: '#( 1 2 ` '')'' expected ->`'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedLocalTempDeclaration [ - - self setUpForErrorsIn: '| x y ` ''|'' or variable expected ->`'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedLocalTempDeclarationInABlock [ - - self setUpForErrorsIn: '[:z | | x y ` ''|'' or variable expected ->`]'. - self enumerateAllSelections -] - -{ #category : 'tests' } -OCCompilerNotifyingTest >> testUnmatchedStringQuote [ - - self setUpForErrorsIn: '^nil printString , ''unfinished string` Unmatched '' in string literal. ->`'. - self enumerateAllSelections -] diff --git a/src/OpalCompiler-Tests/OCCompilerSyntaxErrorNotifyingTest.class.st b/src/OpalCompiler-Tests/OCCompilerSyntaxErrorNotifyingTest.class.st deleted file mode 100644 index a50f9018ee5..00000000000 --- a/src/OpalCompiler-Tests/OCCompilerSyntaxErrorNotifyingTest.class.st +++ /dev/null @@ -1,53 +0,0 @@ -" -A CompilerSyntaxErrorNotifyingTest is a specialization for testing correct handling of non interactive compiler notification. -Non interactive is a very relative notion in Smalltalk... -Here it means that user interaction will not happen directly in the TextEditor holding source code, but rather thru a SyntaxError window that will pop-up. -This test intercept the Notification before the pop-up is raised. - -" -Class { - #name : 'OCCompilerSyntaxErrorNotifyingTest', - #superclass : 'OCCompilerNotifyingTest', - #category : 'OpalCompiler-Tests-FromOld', - #package : 'OpalCompiler-Tests', - #tag : 'FromOld' -} - -{ #category : 'testing' } -OCCompilerSyntaxErrorNotifyingTest class >> shouldInheritSelectors [ - "This class can recycle all of super tests, it just has to refine internal Compiler evaluation machinery" - ^true -] - -{ #category : 'private' } -OCCompilerSyntaxErrorNotifyingTest >> enumerateAllSelections [ - "This method intercepts the SyntaxErrorNotification and prevent the SyntaxError morph to open. - The notification errorCode hold the source of evaluated sub-selection with inserted error message. - This can be compared to expected error notification." - - 1 to: self numberOfSelections do: [ :n | - | result | - result := [ self evaluateSelectionNumber: n ] - on: OCCodeError - do: [ :exc | - | expectedNotification expectedNotificationLocation | - expectedNotification := (expectedErrors at: n) - allButFirst allButLast: 3. - expectedNotificationLocation := (expectedErrorPositions - at: n) - - - (morph editor startIndex - - 1). - self - assert: exc location - equals: expectedNotificationLocation. - self - assert: exc messageText asString - equals: expectedNotification. - exc return: nil ] ] -] - -{ #category : 'private' } -OCCompilerSyntaxErrorNotifyingTest >> evaluateSelection [ - ^ OpalCompiler new evaluate: morph editor selection -] diff --git a/src/OpalCompiler-Tests/OCCompilerTest.class.st b/src/OpalCompiler-Tests/OCCompilerTest.class.st index b04151f28f5..15ac7be4d25 100644 --- a/src/OpalCompiler-Tests/OCCompilerTest.class.st +++ b/src/OpalCompiler-Tests/OCCompilerTest.class.st @@ -23,12 +23,15 @@ OCCompilerTest >> compile [ { #category : 'running' } OCCompilerTest >> compileWithFailBlock: aBlock [ - ^ OpalCompiler new - source: text; - class: MockForCompilation; - requestor: self; - failBlock: aBlock; - compile + + | result compiler | + compiler := MockForCompilation compiler + source: text; + "compatibility: permit undeclared if no requestor" + permitUndeclared: false; + permitFaulty: false. + result := compiler doCompile. + result isError ifTrue: [ aBlock cull: result ] ] { #category : 'mocking' } @@ -83,25 +86,30 @@ OCCompilerTest >> testAssignmentOfClassNameBinding [ text := 'temp | | MockForCompilation := nil'. self - compileWithFailBlock: [ self assert: errorMessage equals: 'Assignment to read-only variable ->'. - self assert: errorLocation equals: 10. - self assert: errorSource contents equals: 'temp | | MockForCompilation := nil'. + compileWithFailBlock: [ :result | | error | + self assert: result ast allNotices size equals: 1. + error := result ast allNotices first. + self assert: error messageText equals: 'Assignment to read-only variable'. + self assert: error position equals: 10. + self assert: error node parent sourceCode equals: 'MockForCompilation := nil'. ^ nil ]. self fail ] { #category : 'tests - readonly vars' } OCCompilerTest >> testAssignmentOfGlobalVarBinding [ - self initializeErrorMessage. + text := 'temp | | OCCompilerTestTestVar := 2'. - self initializeErrorMessage. - OpalCompiler new - source: text; - class: MockForCompilation; - requestor: self; - failBlock: [ self fail. - ^ nil ]; - compile + + self + should: [ + OpalCompiler new + source: text; + class: MockForCompilation; + requestor: self; + newCompile ] + raise: OCCompilationError + with: [ :err | self assert: err messageText equals: 'Error while compiling' ] ] { #category : 'tests' } @@ -229,8 +237,7 @@ OCCompilerTest >> testSiblingBlocksInstanceVariableShadowing [ source: 'temp [:temp | ].[:temp | |var1|]'; class: MockForCompilation; requestor: self; - failBlock: [ ^ self fail ]; - compile + newCompile ] { #category : 'tests - shadowing' } @@ -241,7 +248,7 @@ OCCompilerTest >> testSiblingBlocksTempShadowing [ OpalCompiler new source: 'temp [:temp | ]. [:temp | ]'; class: MockForCompilation; - compile + newCompile ] { #category : 'tests' } @@ -276,9 +283,9 @@ OCCompilerTest >> testUndefinedVariableFrontend [ Undeclared removeKey: #undefinedName123 ifAbsent: [ ]. OpalCompiler new parse: 'foo ^undefinedName123'. self deny: (Undeclared includesKey: #undefinedName123). - self should: [ OpalCompiler new compile: 'foo ^undefinedName123 ¿ 2' ] raise: OCCodeError. + self should: [ OpalCompiler new source: 'foo ^undefinedName123 ¿ 2'; newCompile ] raise: OCCompilationError. self deny: (Undeclared includesKey: #undefinedName123). - OpalCompiler new permitFaulty: true; compile: 'foo ^undefinedName123'. + OpalCompiler new permitFaulty: true; source: 'foo ^undefinedName123'; newCompile. self assert: (Undeclared includesKey: #undefinedName123). "Cleanup" diff --git a/src/OpalCompiler-Tests/OCDoItVariableTest.class.st b/src/OpalCompiler-Tests/OCDoItVariableTest.class.st index 3c3b114c65c..57c1dec24fd 100644 --- a/src/OpalCompiler-Tests/OCDoItVariableTest.class.st +++ b/src/OpalCompiler-Tests/OCDoItVariableTest.class.st @@ -49,7 +49,7 @@ OCDoItVariableTest >> testDoItCompilation [ source: 'temp + 2'; isScripting: true; bindings: { var }; - compile. + newCompile. self assert: (doIt valueWithReceiver: self) equals: 102 ] @@ -83,11 +83,17 @@ OCDoItVariableTest >> testFromTempVariable [ { #category : 'tests' } OCDoItVariableTest >> testReadCompilation [ - | temp var ast doIt | + | temp var ast doIt undeclaredNotices | temp := 100. var := OCDoItVariable named: #temp fromContext: thisContext. ast := [ temp + 2 ] sourceNode body asDoit doSemanticAnalysis. + + "We patch the AST with a binding, so we need to remove the notice too!" ast variableNodes first variable: var. + undeclaredNotices := ast variableNodes first notices select: [ :n | + n isUndeclaredNotice ]. + ast variableNodes first notices removeAll: undeclaredNotices. + doIt := ast generateMethod. self assert: (doIt valueWithReceiver: self) equals: 102 @@ -115,11 +121,17 @@ OCDoItVariableTest >> testUsingMethods [ { #category : 'tests' } OCDoItVariableTest >> testWriteCompilation [ - | temp var ast doIt | + | temp var ast doIt undeclaredNotices | temp := 100. var := OCDoItVariable named: #temp fromContext: thisContext. ast := [ temp := 500 ] sourceNode body asDoit doSemanticAnalysis. + + "We patch the AST with a binding, so we need to remove the notice too!" ast variableNodes first variable: var. + undeclaredNotices := ast variableNodes first notices select: [ :n | + n isUndeclaredNotice ]. + ast variableNodes first notices removeAll: undeclaredNotices. + doIt := ast generateMethod. doIt valueWithReceiver: self. diff --git a/src/OpalCompiler-Tests/OCDoitTest.class.st b/src/OpalCompiler-Tests/OCDoitTest.class.st index f49f402cee2..2ab7c434038 100644 --- a/src/OpalCompiler-Tests/OCDoitTest.class.st +++ b/src/OpalCompiler-Tests/OCDoitTest.class.st @@ -129,10 +129,11 @@ OCDoitTest >> testDoItHaltBinding [ { #category : 'tests' } OCDoitTest >> testDoItRequestorEvalError [ + | value | - value := OpalCompiler new - requestor: self; - evaluate: '1('. + value := OpalEvaluator new + failBlock: [ nil ]; + evaluate: '1('. self assert: value isNil ] diff --git a/src/OpalCompiler-Tests/OpalCompilerTest.class.st b/src/OpalCompiler-Tests/OpalCompilerTest.class.st index 111fee12290..749face6dba 100644 --- a/src/OpalCompiler-Tests/OpalCompilerTest.class.st +++ b/src/OpalCompiler-Tests/OpalCompilerTest.class.st @@ -201,47 +201,6 @@ OpalCompilerTest >> testInstall [ self deny: (MockForCompilation includesSelector: #foo) ] -{ #category : 'tests' } -OpalCompilerTest >> testInstallException [ - - | method message | - "Precond" - self deny: (MockForCompilation includesSelector: #foo). - - [ method := MockForCompilation compiler install: 'foo ^¿' ] - on: OCCodeError - do: [ :error | message := error messageText , ' :(' ]. - - self deny: (MockForCompilation includesSelector: #foo). - self assert: method isNil. - self assert: message equals: 'Unknown character :(' -] - -{ #category : 'tests' } -OpalCompilerTest >> testInstallRequestor [ - - | method requestor | - "precond" - self deny: (MockForCompilation includesSelector: #foo). - - requestor := OCMockRequestor new. - - [ - method := MockForCompilation compiler - source: 'foo ^¿'; - requestor: requestor; - failBlock: [ ]; - changeStamp: '2025-04-25T14:42:06.014486+02:00'; - protocol: 'hitching'; - install ] - on: OCCodeError - do: [ ]. - - self deny: (MockForCompilation includesSelector: #foo). - self assert: method isNil. - self assert: requestor notifyList first first equals: 'Unknown character ->' -] - { #category : 'tests' } OpalCompilerTest >> testSavedProtocolInChangesFileIsRight [ "Regression test, the saved protocol was wrong when we provided a Protocol instance during compilation.." diff --git a/src/OpalCompiler-UI-Tests/OCCodeReparatorTest.class.st b/src/OpalCompiler-UI-Tests/OCCodeReparatorTest.class.st index 2818e6903bc..fba262c04b3 100644 --- a/src/OpalCompiler-UI-Tests/OCCodeReparatorTest.class.st +++ b/src/OpalCompiler-UI-Tests/OCCodeReparatorTest.class.st @@ -15,7 +15,7 @@ OCCodeReparatorTest >> testDeclareClassVar [ goo := MockForCompilation classVariableNamed: #goo ifAbsent: [ nil ]. goo ifNotNil: [ MockForCompilation removeClassVariable: goo ]. - method := [ OpalCompiler new class: MockForCompilation ; compile: requestor text ] + method := [ OCInteractiveAPI new compile: requestor text notifying: nil in: MockForCompilation ] on: OCUndeclaredVariableWarning , OCCodeError do: [ :e | e notice reparator declareClassVar. @@ -29,31 +29,6 @@ OCCodeReparatorTest >> testDeclareClassVar [ MockForCompilation removeClassVariable: goo ] -{ #category : 'tests' } -OCCodeReparatorTest >> testDeclareClassVarBlock [ - - | compiler requestor method goo | - requestor := OCMockRequestor new. - requestor text: 'griffle ^ goo'. - - goo := MockForCompilation classVariableNamed: #goo ifAbsent: [ nil ]. - goo ifNotNil: [ MockForCompilation removeClassVariable: goo ]. - - method := (compiler := OpalCompiler new) - class: MockForCompilation; - failBlock: [ :notice | - notice reparator declareClassVar. - compiler compile ]; - compile: requestor text. - - self assert: requestor text withSeparatorsCompacted equals: 'griffle ^ goo'. - self assert: method isCompiledMethod. - goo := MockForCompilation classVariableNamed: #goo. - self assert: method literals first equals: goo. - - MockForCompilation removeClassVariable: goo -] - { #category : 'tests' } OCCodeReparatorTest >> testDeclareGlobal [ @@ -63,7 +38,7 @@ OCCodeReparatorTest >> testDeclareGlobal [ Smalltalk globals removeKey: #goo ifAbsent: []. - method := [ OpalCompiler new compile: requestor text ] + method := [ OCInteractiveAPI new compile: requestor text notifying: nil in: MockForCompilation ] on: OCUndeclaredVariableWarning , OCCodeError do: [ :e | e notice reparator declareGlobal. @@ -77,30 +52,6 @@ OCCodeReparatorTest >> testDeclareGlobal [ Smalltalk globals removeKey: #goo ifAbsent: [] ] -{ #category : 'tests' } -OCCodeReparatorTest >> testDeclareGlobalBlock [ - - | compiler requestor method | - requestor := OCMockRequestor new. - requestor text: 'griffle ^ goo'. - - Smalltalk globals removeKey: #goo ifAbsent: []. - - method := (compiler := OpalCompiler new) - class: MockForCompilation; - failBlock: [ :notice | - notice reparator declareGlobal. - compiler compile ]; - compile: requestor text. - - self assert: requestor text withSeparatorsCompacted equals: 'griffle ^ goo'. - self assert: method isCompiledMethod. - self assert: method literals first equals: (Smalltalk globals associationAt: #goo). - self assert: method sourceCode withSeparatorsCompacted equals: 'griffle ^ goo'. - - Smalltalk globals removeKey: #goo ifAbsent: [] -] - { #category : 'tests' } OCCodeReparatorTest >> testDeclareInstVar [ @@ -113,7 +64,7 @@ OCCodeReparatorTest >> testDeclareInstVar [ self deny: (MockForCompilation hasInstVarNamed: #goo). - method := [ OpalCompiler new class: MockForCompilation ; compile: requestor text ] + method := [ OCInteractiveAPI new compile: requestor text notifying: nil in: MockForCompilation ] on: OCUndeclaredVariableWarning , OCCodeError do: [ :e | e notice reparator declareInstVar: #goo. @@ -126,32 +77,6 @@ OCCodeReparatorTest >> testDeclareInstVar [ MockForCompilation removeInstVarNamed: #goo ] -{ #category : 'tests' } -OCCodeReparatorTest >> testDeclareInstVarBlock [ - - | compiler requestor method | - requestor := OCMockRequestor new. - requestor text: 'griffle ^ goo'. - - (MockForCompilation hasInstVarNamed: #goo) ifTrue: [ - MockForCompilation removeInstVarNamed: #goo ]. - - self deny: (MockForCompilation hasInstVarNamed: #goo). - - method := (compiler := OpalCompiler new) - class: MockForCompilation; - failBlock: [ :notice | - notice reparator declareInstVar: #goo. - compiler compile ]; - compile: requestor text. - - self assert: requestor text withSeparatorsCompacted equals: 'griffle ^ goo'. - self assert: method isCompiledMethod. - self assert: (MockForCompilation hasInstVarNamed: #goo). - - MockForCompilation removeInstVarNamed: #goo -] - { #category : 'tests' } OCCodeReparatorTest >> testDeclareTempAndPaste [ @@ -159,7 +84,7 @@ OCCodeReparatorTest >> testDeclareTempAndPaste [ requestor := OCMockRequestor new. requestor text: 'griffle ^ goo'. - method := [ OpalCompiler new compile: requestor text ] + method := [ OCInteractiveAPI new compile: requestor text notifying: nil in: MockForCompilation ] on: OCUndeclaredVariableWarning , OCCodeError do: [ :e | e notice reparator @@ -172,27 +97,6 @@ OCCodeReparatorTest >> testDeclareTempAndPaste [ self assert: method sourceCode withSeparatorsCompacted equals: 'griffle | goo | ^ goo' ] -{ #category : 'tests' } -OCCodeReparatorTest >> testDeclareTempAndPasteBlock [ - - | compiler requestor method | - requestor := OCMockRequestor new. - requestor text: 'griffle ^ goo'. - - method := (compiler := OpalCompiler new) - class: MockForCompilation; - failBlock: [ :notice | - notice reparator - requestor: requestor; - declareTempAndPaste: 'goo'. - compiler compile: requestor text ]; - compile: requestor text. - - self assert: requestor text withSeparatorsCompacted equals: 'griffle | goo | ^ goo'. - self assert: method isCompiledMethod. - self assert: method sourceCode withSeparatorsCompacted equals: 'griffle | goo | ^ goo' -] - { #category : 'tests' } OCCodeReparatorTest >> testPossibleVariablesFor [ @@ -200,7 +104,7 @@ OCCodeReparatorTest >> testPossibleVariablesFor [ requestor := OCMockRequestor new. requestor text: 'griffle | foo | ^ goo'. - names := [ OpalCompiler new compile: requestor text ] + names := [ OCInteractiveAPI new compile: requestor text notifying: nil in: MockForCompilation ] on: OCUndeclaredVariableWarning , OCCodeError do: [ :e | e notice reparator @@ -211,22 +115,6 @@ OCCodeReparatorTest >> testPossibleVariablesFor [ self assert: (names includes: #foo) ] -{ #category : 'tests' } -OCCodeReparatorTest >> testPossibleVariablesForBlock [ - - | compiler requestor names | - requestor := OCMockRequestor new. - requestor text: 'griffle | foo | ^ goo'. - - names := (compiler := OpalCompiler new) - class: MockForCompilation; - failBlock: [ :notice | - notice reparator possibleVariablesFor: #goo ]; - compile: requestor text. - - self assert: (names includes: #foo) -] - { #category : 'tests' } OCCodeReparatorTest >> testSubstituteVariableAtInterval [ @@ -234,7 +122,7 @@ OCCodeReparatorTest >> testSubstituteVariableAtInterval [ requestor := OCMockRequestor new. requestor text: 'griffle | foo | ^ goo'. - method := [ OpalCompiler new compile: requestor text ] + method := [ OCInteractiveAPI new compile: requestor text notifying: nil in: MockForCompilation ] on: OCUndeclaredVariableWarning , OCCodeError do: [ :e | e notice reparator @@ -247,42 +135,17 @@ OCCodeReparatorTest >> testSubstituteVariableAtInterval [ self assert: method sourceCode withSeparatorsCompacted equals: 'griffle | foo | ^ foo' ] -{ #category : 'tests' } -OCCodeReparatorTest >> testSubstituteVariableAtIntervalBlock [ - - | compiler requestor method | - requestor := OCMockRequestor new. - requestor text: 'griffle | foo | ^ goo'. - - method := (compiler := OpalCompiler new) - class: MockForCompilation; - failBlock: [ :notice | - notice reparator - requestor: requestor; - substituteVariable: 'foo' atInterval: notice node sourceInterval. - compiler compile: requestor text ]; - compile: requestor text. - - self assert: requestor text withSeparatorsCompacted equals: 'griffle | foo | ^ foo'. - self assert: method isCompiledMethod. - self assert: method sourceCode withSeparatorsCompacted equals: 'griffle | foo | ^ foo' -] - { #category : 'tests' } OCCodeReparatorTest >> testUndeclaredVariable [ - | requestor method flag | + | requestor method | requestor := OCMockRequestor new. requestor text: 'griffle ^ goo'. - flag := false. - method := [ OpalCompiler new compile: requestor text ] - on: OCUndeclaredVariableWarning , OCCodeError - do: [ :e | - flag := true. - e resume "continue" ]. + method := OCInteractiveAPI new + permitUndeclared: true; + compile: requestor text notifying: nil in: MockForCompilation. - self assert: flag. self assert: method isCompiledMethod. self assert: method literals first isUndeclaredVariable. self assert: method sourceCode withSeparatorsCompacted equals: 'griffle ^ goo' diff --git a/src/OpalCompiler-UI/Behavior.extension.st b/src/OpalCompiler-UI/Behavior.extension.st new file mode 100644 index 00000000000..8ade0500b18 --- /dev/null +++ b/src/OpalCompiler-UI/Behavior.extension.st @@ -0,0 +1,38 @@ +Extension { #name : 'Behavior' } + +{ #category : '*OpalCompiler-UI' } +Behavior >> compile: sourceCode classified: protocol withStamp: changeStamp notifying: requestor logSource: logSource [ + "Return the selector of the compiled method" + + ^ self compile: sourceCode notifying: requestor methodInstaller: (self methodInstaller + logged: logSource; + changeStamp: changeStamp; + protocol: protocol) +] + +{ #category : '*OpalCompiler-UI' } +Behavior >> compile: sourceCode notifying: requestor methodInstaller: methodInstaller [ + "Return the selector of the compiled method" + + | compilerFacade method | + compilerFacade := OCInteractiveAPI new. + + method := compilerFacade compile: sourceCode notifying: requestor in: self. + method ifNil: [ ^ nil ]. + + methodInstaller install: method into: self compiler: compilerFacade compiler. + ^ method selector +] + +{ #category : '*OpalCompiler-UI' } +Behavior >> compileSilently: sourceCode classified: protocolName notifying: requestor [ + "Compile the code and classify the resulting method in the given protocol, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list." + + ^ self codeChangeAnnouncer suspendAllWhile: [ + self + compile: sourceCode + classified: protocolName + withStamp: DateAndTime now + notifying: requestor + logSource: self shouldLogSource ] +] diff --git a/src/OpalCompiler-Core/Extension.extension.st b/src/OpalCompiler-UI/Extension.extension.st similarity index 91% rename from src/OpalCompiler-Core/Extension.extension.st rename to src/OpalCompiler-UI/Extension.extension.st index dddc215a24c..8ac63a8f12a 100644 --- a/src/OpalCompiler-Core/Extension.extension.st +++ b/src/OpalCompiler-UI/Extension.extension.st @@ -1,6 +1,6 @@ Extension { #name : 'Extension' } -{ #category : '*OpalCompiler-Core' } +{ #category : '*OpalCompiler-UI' } Extension >> compile: sourceCode classified: protocol withStamp: changeStamp notifying: requestor logSource: logSource [ "Return the selector of the compiled method" diff --git a/src/OpalCompiler-UI/OCInteractiveAPI.class.st b/src/OpalCompiler-UI/OCInteractiveAPI.class.st new file mode 100644 index 00000000000..74845c86830 --- /dev/null +++ b/src/OpalCompiler-UI/OCInteractiveAPI.class.st @@ -0,0 +1,130 @@ +Class { + #name : 'OCInteractiveAPI', + #superclass : 'Object', + #instVars : [ + 'compiler', + 'permitFaulty', + 'permitUndeclared' + ], + #category : 'OpalCompiler-UI', + #package : 'OpalCompiler-UI' +} + +{ #category : 'compiling' } +OCInteractiveAPI >> checkNotice: aNotice requestor: aRequestor isInteractive: isInteractive [ + "This method handles all the logic of error handling. + + Error handing in the compiler is only performed at one place, after the parsing/semantic analysis/other parse plugins. + Each ASTNotice in the AST is then checked with this method. + + There is only three outcomes: + * If this method returns true (OK), then the work of the compiler can continue. + Next notice is then processed. + Or, if this that was the last notice, compilation and cie can be performed. + * If this method returns false (not OK), then the compilation is cancelled. + The failBlock will be invoked. + * If this method returns nil (stop checking), then skip the rest of the notice checks. + This one is used in case of reparation, where a new (checked) AST is produced. + + Errors that may happen later in the backend are consireded internal errors and should not occur (bugs). + + This method is a little long because it handles the requestor (quirks) mode. + " + + aNotice isWarning ifTrue: [ ^ true ]. + (aNotice isUndeclaredNotice and: [ compiler permitUndeclared ]) ifTrue: [ + OCUndeclaredVariableWarning new + notice: aNotice; + signal. + ^ true ]. + + "A requestor is available. We are in quirks mode and are expected to do UI things." "Reparation menu in quirks mode: + * require a requestor (because quirks mode, and also some reparations expect a requestor) + * require interactive mode (because GUI) + * require method definition becase some reparation assume it's a method body" + isInteractive ifTrue: [ + aNotice reparator ifNotNil: [ :reparator | + | res | + res := reparator + requestor: aRequestor; + openMenu. + res ifNil: [ ^ true "reparation unneded, let AST as is" ]. + res ifFalse: [ ^ false "operation cancelled, fail" ]. + compiler parse: aRequestor text. "some reparation was done, reparse" + ^ nil ] ]. "Quirks mode: otherwise, push the error message to the requestor" + + aRequestor notify: aNotice messageText , ' ->' at: aNotice position in: aNotice node source. + "Quirks mode: Then leave" + ^ false +] + +{ #category : 'compiling' } +OCInteractiveAPI >> compile: sourceCode notifying: requestor in: behavior [ + "Return the selector of the compiled method" + + | compilationResult | + sourceCode ifEmpty: [ Error signal: 'The source code should not be empty' ]. + compiler := behavior compiler + source: sourceCode; + requestor: requestor; + "compatibility: permit undeclared if no requestor" + permitUndeclared: self permitUndeclared; + permitFaulty: self permitFaulty. + + compilationResult := compiler doCompile. + + compilationResult isError ifTrue: [ + compiler ast allNotices sorted do: [ :n | + | check isInteractive | + requestor ifNil: [ n signalError ] ifNotNil: [ + isInteractive := requestor notNil and: [ (requestor respondsTo: #interactive) not or: [ requestor interactive ] ]. + check := self checkNotice: n requestor: requestor isInteractive: isInteractive. + check ifNil: [ ^ self compile: requestor text asString notifying: requestor in: behavior ]. + check ifFalse: [ ^ nil ] ] ]. + ^ nil ]. + + ^ compilationResult compiledMethod +] + +{ #category : 'accessing' } +OCInteractiveAPI >> compiler [ + + ^ compiler +] + +{ #category : 'accessing' } +OCInteractiveAPI >> compiler: anObject [ + + compiler := anObject +] + +{ #category : 'initialization' } +OCInteractiveAPI >> initialize [ + + super initialize. + permitFaulty := false +] + +{ #category : 'accessing' } +OCInteractiveAPI >> permitFaulty [ + + ^ permitFaulty +] + +{ #category : 'accessing' } +OCInteractiveAPI >> permitFaulty: anObject [ + + permitFaulty := anObject +] + +{ #category : 'accessing' } +OCInteractiveAPI >> permitUndeclared [ + + ^ permitUndeclared ifNil: [ permitFaulty ] +] + +{ #category : 'accessing' } +OCInteractiveAPI >> permitUndeclared: anObject [ + + permitUndeclared := anObject +] diff --git a/src/Refactoring-Changes/ReAddMethodChange.class.st b/src/Refactoring-Changes/ReAddMethodChange.class.st index 76a6363bcf1..0175de94ce8 100644 --- a/src/Refactoring-Changes/ReAddMethodChange.class.st +++ b/src/Refactoring-Changes/ReAddMethodChange.class.st @@ -51,8 +51,7 @@ ReAddMethodChange >> accept: aText notifying: aController [ source: aText asString; class: self changeClass; requestor: aController; - failBlock: [ ^ false ]; - compile. + newCompile. self class: self changeClass diff --git a/src/Ring-Definitions-Core/RGClassDefinition.class.st b/src/Ring-Definitions-Core/RGClassDefinition.class.st index 8f612dcfb04..592cf118354 100644 --- a/src/Ring-Definitions-Core/RGClassDefinition.class.st +++ b/src/Ring-Definitions-Core/RGClassDefinition.class.st @@ -161,7 +161,7 @@ RGClassDefinition >> comment: anObject [ { #category : 'compiling' } RGClassDefinition >> compile: aString classified: aCategory notifying: aController [ - self realClass compile: aString classified: aCategory notifying: aController + self realClass compile: aString classified: aCategory ] { #category : 'testing' } diff --git a/src/Ring-Definitions-Core/RGMethodDefinition.class.st b/src/Ring-Definitions-Core/RGMethodDefinition.class.st index 714c66e6ea6..078a02cd7e7 100644 --- a/src/Ring-Definitions-Core/RGMethodDefinition.class.st +++ b/src/Ring-Definitions-Core/RGMethodDefinition.class.st @@ -261,6 +261,7 @@ RGMethodDefinition >> fullName [ ^self annotationNamed: self class fullNameKey ifAbsentPut: [ (self parentName, '>>', self selector) asSymbol ] ] + { #category : 'testing' } RGMethodDefinition >> hasStamp [ diff --git a/src/Rubric-Tests/RubSmalltalkEditorTest.class.st b/src/Rubric-Tests/RubSmalltalkEditorTest.class.st index f7d1c0dda87..ff1ffee0c0f 100644 --- a/src/Rubric-Tests/RubSmalltalkEditorTest.class.st +++ b/src/Rubric-Tests/RubSmalltalkEditorTest.class.st @@ -537,19 +537,6 @@ RubSmalltalkEditorTest >> testBestNodeWithValidValueMidSource [ assertNodeValue: 3 ] -{ #category : 'tests' } -RubSmalltalkEditorTest >> testCompileForIn [ - - | editor method | - editor := RubSmalltalkEditor new. - - method := editor compile: '40+2' for: nil in: nil. - self assert: (nil executeMethod: method) equals: 42. - - method := editor compile: '40+¿' for: nil in: nil. - self should: [ nil executeMethod: method ] raise: OCRuntimeSyntaxError -] - { #category : 'tests' } RubSmalltalkEditorTest >> testCompletionEngineInstanceIsNotUsedIfNil [ diff --git a/src/Rubric/RubPluggableTextMorphExample.class.st b/src/Rubric/RubPluggableTextMorphExample.class.st deleted file mode 100644 index 781c5cb7868..00000000000 --- a/src/Rubric/RubPluggableTextMorphExample.class.st +++ /dev/null @@ -1,328 +0,0 @@ -" -shows how to use a RubPluggableTextMorph. -see example class side -" -Class { - #name : 'RubPluggableTextMorphExample', - #superclass : 'Model', - #instVars : [ - 'selection', - 'scrollValue', - 'classIsMeta', - 'selectedClassName', - 'selectedMethodName', - 'enabled' - ], - #category : 'Rubric-Compatibility-toBeDeprecated', - #package : 'Rubric', - #tag : 'Compatibility-toBeDeprecated' -} - -{ #category : 'source code area' } -RubPluggableTextMorphExample >> accept: source notifying: aController [ - - | protocol result | - self selectedClass ifNil: [ ^ self ]. - protocol := (self selectedClass >> self selector) protocol ifNil: [ Protocol unclassified ]. - result := self selectedClass compile: source classified: protocol notifying: aController. - result ifNotNil: [ self changed: #clearUserEdits ]. - ^ result -] - -{ #category : 'edits' } -RubPluggableTextMorphExample >> askBeforeDiscardingEdits [ - ^ false -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> autoAccept [ - "Answer whether the editor accepts its contents on each change." - - ^ false -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> behavior [ - ^ self selectedClass -] - -{ #category : 'events handling' } -RubPluggableTextMorphExample >> checkClassName [ - | conf | - conf := RubConfigurationChange new. - self selectedClass - ifNil: [ conf configurationBlock: [ :textField | textField textColor: Color red ] ] - ifNotNil: [ conf configurationBlock: [ :textField | textField textColor: Color black ] ]. - self selectedClassName announce: conf -] - -{ #category : 'events handling' } -RubPluggableTextMorphExample >> checkMethodName [ - | conf | - conf := RubConfigurationChange new. - self selectedClass - ifNil: [ conf configurationBlock: [ :textField | textField textColor: Color red ] ] - ifNotNil: [ - conf - configurationBlock: [ :textField | - (self selectedClass canUnderstand: self selectedMethodName getString asSymbol) - ifFalse: [ textField textColor: Color red ] - ifTrue: [ textField textColor: Color black ] ] ]. - self selectedMethodName announce: conf -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> classIsMeta [ - ^ classIsMeta ifNil: [ classIsMeta := false ] -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> classIsMeta: aBoolean [ - classIsMeta := aBoolean. - self changed: #classIsMeta -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> classSelectorMorph [ - ^ self selectedClassName newTextField - withGhostText: 'Class name'; - autoAccept: true; - hResizing: #spaceFill; - yourself -] - -{ #category : 'menu' } -RubPluggableTextMorphExample >> codePaneMenu: aMenu shifted: shifted [ - "Note that unless we override perform:orSendTo:, - PluggableTextController will respond to all menu items in a - text pane" - "You should not use this way of getting menu. Because when you create a text area, you have a menu" - - | donorMenu | - donorMenu := (PragmaMenuBuilder pragmaKeyword: RubSmalltalkCodeMode menuKeyword model: self) menu. - ^ aMenu addAllFrom: donorMenu -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> dragEnabled [ - ^ false -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> dropEnabled [ - ^ false -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> dropEnabled: aBoolean [ -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> editButtonMorph [ - ^ self morphicUIManager - newButtonFor: self - action: #editSourceCode - getEnabled: nil - label: 'Edit' - help: nil -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> editSourceCode [ - self changed: #getText -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> enabled [ - ^ enabled ifNil: [ enabled := true ] -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> enabled: aBoolean [ - enabled = aBoolean ifTrue: [ ^self ]. - enabled := aBoolean. - self changed: #enabled -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> getText [ - ^ self method ifNil: [''] ifNotNil: [:m | m sourceCode] -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> help [ - ^ nil -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> metaSwitchMorph [ - ^ self morphicUIManager - newCheckboxFor: self - getSelected: #classIsMeta - setSelected: #classIsMeta: - label: 'Class' - help: 'Class side is used if checked' -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> method [ - ^ [ self selectedClass >> (self selectedMethodName getString ifEmpty: [ ^nil ]) asSymbol ] on: Error do: [ ] -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> methodSelectorMorph [ - ^ self selectedMethodName newTextField - withGhostText: 'Method name'; - autoAccept: true; - hResizing: #spaceFill; - yourself -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> morphicUIManager [ - - ^ MorphicUIManager new -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> newScrolledTextMorph [ - | st | - st := RubPluggableTextMorph new - on: self - text: #getText - accept: #accept:notifying: - readSelection: #readSelection - menu: nil - setSelection: #setSelection:; - getEnabledSelector: #enabled; - askBeforeDiscardingEdits: self askBeforeDiscardingEdits; - autoAccept: self autoAccept; - setBalloonText: self help; - dragEnabled: self dragEnabled; - dropEnabled: self dropEnabled; - registerScrollChanges: #scrollValueChanged:; - vResizing: #spaceFill; - hResizing: #spaceFill; - yourself. - st - beWrapped; - autoAccept: false; - beForSmalltalkCode; - withCodeSizeFeedback. - ^ st -] - -{ #category : 'edits' } -RubPluggableTextMorphExample >> okToChange [ - self canDiscardEdits - ifTrue: [ ^ true ]. - ^ self promptForCancel -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> open [ - - | window editor clsMorph mthMorph | - window := (StandardWindow labelled: 'Method editor with shout') model: self. - editor := self newScrolledTextMorph. - clsMorph := self classSelectorMorph. - clsMorph announcer when: RubTextChanged send: #whenClassNameChanged: to: self. - mthMorph := self methodSelectorMorph. - mthMorph announcer when: RubTextChanged send: #whenMethodNameChanged: to: self. - editor - hResizing: #spaceFill; - vResizing: #spaceFill. - window - addMorph: (window newColumn: { - (window newRow: { - clsMorph. - self metaSwitchMorph. - mthMorph. - self editButtonMorph }). - editor }) - fullFrame: LayoutFrame identity. - ^ window openInWorld -] - -{ #category : 'edits' } -RubPluggableTextMorphExample >> promptForCancel [ - "Ask for the appropriate action to take when unaccepted contents - would be overwritten." - - | choice | - choice := self morphicUIManager - confirm: - 'Contents has been modified.\What do you want to do?' - translated withCRs - trueChoice: 'Accept' translated - falseChoice: 'Discard' translated - cancelChoice: 'Cancel' translated - default: nil. - choice ifNotNil: [ - choice ifTrue: [ self changed: #getText ]. - self changed: #clearUserEdits ]. - ^ self canDiscardEdits -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> readSelection [ - ^ selection -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> scrollValue: aPoint [ - scrollValue := aPoint -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> scrollValueChanged: anAnnouncement [ - scrollValue := anAnnouncement step -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> selectedClass [ - | cls | - cls := (Smalltalk globals at: (self selectedClassName getString ifEmpty: [ ^ nil ]) asSymbol ifAbsent: [ ^ nil ]) - instanceSide. - ^ self classIsMeta - ifTrue: [ cls class ] - ifFalse: [ cls ] -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> selectedClassName [ - ^ selectedClassName ifNil: [ selectedClassName := RubScrolledTextModel new ] -] - -{ #category : 'view creation' } -RubPluggableTextMorphExample >> selectedMethodName [ - ^ selectedMethodName ifNil: [ selectedMethodName := RubScrolledTextModel new ] -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> selector [ - ^ self selectedMethodName getString asSymbol -] - -{ #category : 'accessing' } -RubPluggableTextMorphExample >> setSelection: anInterval [ - selection := anInterval. - self changed: #readSelection -] - -{ #category : 'shout' } -RubPluggableTextMorphExample >> shoutAboutToStyle: ARubricMode [ - ARubricMode classOrMetaClass: self selectedClass. - ^ true -] - -{ #category : 'events handling' } -RubPluggableTextMorphExample >> whenClassNameChanged: anAnnouncement [ - self checkMethodName. - self checkClassName -] - -{ #category : 'events handling' } -RubPluggableTextMorphExample >> whenMethodNameChanged: anAnnouncement [ - self checkMethodName -] diff --git a/src/Rubric/RubSmalltalkEditor.class.st b/src/Rubric/RubSmalltalkEditor.class.st index 676b2592631..fba21971dd6 100644 --- a/src/Rubric/RubSmalltalkEditor.class.st +++ b/src/Rubric/RubSmalltalkEditor.class.st @@ -314,26 +314,6 @@ RubSmalltalkEditor >> classNamesContainingIt [ caseSensitive: World currentHand shiftPressed ] -{ #category : 'do-its' } -RubSmalltalkEditor >> compile: source for: anObject in: evalContext [ - | methodClass | - methodClass := evalContext - ifNil: [ anObject class ] - ifNotNil: [ evalContext methodClass ]. - ^self class compiler - source: source; - class: methodClass; - context: evalContext; - isScripting: true; - permitFaulty: true; - compile -] - -{ #category : 'do-its' } -RubSmalltalkEditor >> compileSelectionFor: anObject in: evalContext [ - ^ self compile: self selection for: anObject in: evalContext -] - { #category : 'completion engine' } RubSmalltalkEditor >> completionAround: aBlock keyDown: anEvent [ "I'm a editor for Smalltalk, so, do completion around" @@ -432,39 +412,6 @@ RubSmalltalkEditor >> copySelection [ self editingState previousInterval: self selectionInterval ] -{ #category : 'do-its' } -RubSmalltalkEditor >> debug: aStream [ - | method receiver context | - receiver := self doItReceiver. - context := self doItContext. - method := self compile: aStream for: receiver in: context. - method ifNil: [ ^self ]. - method isReturnSpecial - ifTrue: [ InformativeNotification signal: 'Nothing to debug, the expression is optimized'. - ^ self ]. - self debug: method receiver: receiver in: context -] - -{ #category : 'do-its' } -RubSmalltalkEditor >> debug: aCompiledMethod receiver: anObject in: evalContext [ - - | process suspendedContext | - process := [ - aCompiledMethod - valueWithReceiver: anObject - arguments: (aCompiledMethod numArgs = 0 - ifTrue: [ #() ] - ifFalse: [ { evalContext } ] ) ] - newProcess. - suspendedContext := process suspendedContext. - - (OupsDebugRequest newForContext: suspendedContext) - process: process; - compiledMethod: aCompiledMethod; - label: 'debug it'; - submit -] - { #category : 'do-its' } RubSmalltalkEditor >> debugHighlight [ "Treat the current highlight as an expression; evaluate and debugg it in a new debugger." diff --git a/src/SUnit-Core/AbstractEnvironmentTestCase.class.st b/src/SUnit-Core/AbstractEnvironmentTestCase.class.st index 48f6a44a324..5a2c1c11eb9 100644 --- a/src/SUnit-Core/AbstractEnvironmentTestCase.class.st +++ b/src/SUnit-Core/AbstractEnvironmentTestCase.class.st @@ -23,7 +23,7 @@ AbstractEnvironmentTestCase >> environmentOfTest [ { #category : 'running' } AbstractEnvironmentTestCase >> setUp [ super setUp. - testingEnvironment := Smalltalk globals + testingEnvironment := SystemEnvironment new ] { #category : 'accessing' } diff --git a/src/SUnit-Core/ClassFactoryForTestCase.class.st b/src/SUnit-Core/ClassFactoryForTestCase.class.st index 3a745bcc0d6..7f015e65571 100644 --- a/src/SUnit-Core/ClassFactoryForTestCase.class.st +++ b/src/SUnit-Core/ClassFactoryForTestCase.class.st @@ -131,7 +131,7 @@ ClassFactoryForTestCase >> deletePackages [ { #category : 'accessing' } ClassFactoryForTestCase >> environment [ - ^ environment ifNil: [ self class environment ] + ^ environment ifNil: [ self error: 'Cannot build test class without a test environment' ] ] { #category : 'accessing' } @@ -254,7 +254,6 @@ ClassFactoryForTestCase >> silentlyCompile: aString in: aBehavior protocol: anot compile: aString classified: anotherString withStamp: DateAndTime now - notifying: nil logSource: aBoolean ] ] diff --git a/src/SUnit-Core/ClassTestCase.class.st b/src/SUnit-Core/ClassTestCase.class.st index 6dfa8385afb..be8fab07411 100644 --- a/src/SUnit-Core/ClassTestCase.class.st +++ b/src/SUnit-Core/ClassTestCase.class.st @@ -15,7 +15,7 @@ They should also implement to confirm that all methods have been tested. " Class { #name : 'ClassTestCase', - #superclass : 'AbstractEnvironmentTestCase', + #superclass : 'TestCase', #category : 'SUnit-Core-Utilities', #package : 'SUnit-Core', #tag : 'Utilities' @@ -38,7 +38,12 @@ ClassTestCase class >> mustTestCoverage [ { #category : 'coverage' } ClassTestCase >> classToBeTested [ - ^ self subclassResponsibility + | className | + + "By default look for the class we are testing having the same name as me but without the Test suffix" + + className := self class name asString copyFrom: 1 to: self class name size - 4. + ^ self class environment at: className asString asSymbol ] { #category : 'utilities' } @@ -89,14 +94,7 @@ ClassTestCase >> selectorsToBeTested [ { #category : 'private' } ClassTestCase >> targetClass [ - [ ^ self classToBeTested ] - on: Error - do: [ - | className | - className := self class name asString - copyFrom: 1 - to: self class name size - 4. - ^ testingEnvironment at: className asString asSymbol ] + ^ self classToBeTested ] { #category : 'tests' } diff --git a/src/SUnit-Tests/ClassFactoryForTestCaseTest.class.st b/src/SUnit-Tests/ClassFactoryForTestCaseTest.class.st index 503cce3ca3f..499a0d18864 100644 --- a/src/SUnit-Tests/ClassFactoryForTestCaseTest.class.st +++ b/src/SUnit-Tests/ClassFactoryForTestCaseTest.class.st @@ -33,7 +33,7 @@ ClassFactoryForTestCaseTest >> organization [ { #category : 'running' } ClassFactoryForTestCaseTest >> setUp [ super setUp. - factory := ClassFactoryForTestCase new + factory := ClassFactoryForTestCase environment: testingEnvironment ] { #category : 'running' } diff --git a/src/SUnit-Tests/ClassFactoryWithNonDefaultEnvironmentTest.class.st b/src/SUnit-Tests/ClassFactoryWithNonDefaultEnvironmentTest.class.st index e219af7f33f..1cac2ca4d50 100644 --- a/src/SUnit-Tests/ClassFactoryWithNonDefaultEnvironmentTest.class.st +++ b/src/SUnit-Tests/ClassFactoryWithNonDefaultEnvironmentTest.class.st @@ -20,13 +20,6 @@ ClassFactoryWithNonDefaultEnvironmentTest >> environment [ ^ factory environment ] -{ #category : 'running' } -ClassFactoryWithNonDefaultEnvironmentTest >> setUp [ - - super setUp. - factory := ClassFactoryForTestCase environment: SystemEnvironment new -] - { #category : 'testing' } ClassFactoryWithNonDefaultEnvironmentTest >> testClassCreationInDifferentTags [ diff --git a/src/SUnit-Tests/TestCaseTest.class.st b/src/SUnit-Tests/TestCaseTest.class.st index b58a58676a4..7aaa9cdf337 100644 --- a/src/SUnit-Tests/TestCaseTest.class.st +++ b/src/SUnit-Tests/TestCaseTest.class.st @@ -11,25 +11,25 @@ Class { { #category : 'events' } TestCaseTest >> testAnnouncement [ - | announcements oldCollection suite unitTest result | + | announcements oldCollection suite unitTestClass result | - unitTest := ClassFactoryForTestCaseTest. + unitTestClass := ClassFactoryForTestCaseTest. announcements := Dictionary new. - unitTest resetAnnouncer. + unitTestClass resetAnnouncer. - self deny: unitTest shouldAnnounce. - self deny: unitTest new shouldAnnounce. + self deny: unitTestClass shouldAnnounce. + self deny: unitTestClass new shouldAnnounce. - unitTest announcer + unitTestClass announcer when: TestCaseAnnouncement do: [ :ann | (announcements at: ann class ifAbsentPut: [ OrderedCollection new ]) add: ann ] for: self. - self assert: unitTest shouldAnnounce. - self assert: unitTest new shouldAnnounce. + self assert: unitTestClass shouldAnnounce. + self assert: unitTestClass new shouldAnnounce. "We run SUnitTest" - suite := unitTest buildSuite. + suite := unitTestClass buildSuite. result := suite run. self assertEmpty: result failures. @@ -47,8 +47,8 @@ TestCaseTest >> testAnnouncement [ TestCaseEnded }. oldCollection := announcements copy. - unitTest resetAnnouncer. - unitTest debug: #testClassCreationInDifferentTags. + unitTestClass resetAnnouncer. + unitTestClass debug: #testClassCreationInDifferentTags. self assert: announcements equals: oldCollection ] diff --git a/src/Shift-ClassBuilder-Tests/ShClassInstallerTest.class.st b/src/Shift-ClassBuilder-Tests/ShClassInstallerTest.class.st index 09c63488db3..27507fde05c 100644 --- a/src/Shift-ClassBuilder-Tests/ShClassInstallerTest.class.st +++ b/src/Shift-ClassBuilder-Tests/ShClassInstallerTest.class.st @@ -404,8 +404,8 @@ ShClassInstallerTest >> testModifyingClassKeepsOrganizationOfMethods [ newClass := self newClass: #ShCITestClass superclass: subClass slots: #( ). - newClass compile: 'aMethod ^ 42' classified: #'useful-message' notifying: nil. - newClass class compile: 'aClassMethod ^ 21' classified: #'useful-message' notifying: nil. + newClass compile: 'aMethod ^ 42' classified: #'useful-message'. + newClass class compile: 'aClassMethod ^ 21' classified: #'useful-message'. self assert: (newClass >> #aMethod) protocolName equals: #'useful-message'. self assert: (newClass class >> #aClassMethod) protocolName equals: #'useful-message'. diff --git a/src/System-Changes/ChangeRecord.class.st b/src/System-Changes/ChangeRecord.class.st index 3a9c415adc7..049dc6c5a18 100644 --- a/src/System-Changes/ChangeRecord.class.st +++ b/src/System-Changes/ChangeRecord.class.st @@ -67,20 +67,17 @@ ChangeRecord >> fileIn [ "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." self methodClass ifNotNil: [ :methodClass | - methodClass - compile: self string - classified: protocol - withStamp: stamp - notifying: nil ]. + methodClass + compile: self string + classified: protocol + withStamp: stamp + notifying: nil + logSource: self shouldLogSource ]. type == #doIt ifTrue: [ - | string | - string := self string. - (string beginsWith: '----') ifFalse: [ - self class compiler evaluate: string ] ]. - type == #classComment ifTrue: [ - (Smalltalk globals at: class asSymbol) - comment: self string - stamp: stamp ] + | string | + string := self string. + (string beginsWith: '----') ifFalse: [ self class compiler evaluate: string ] ]. + type == #classComment ifTrue: [ (Smalltalk globals at: class asSymbol) comment: self string stamp: stamp ] ] { #category : 'accessing' } diff --git a/src/Tool-Base/DebugSession.extension.st b/src/Tool-Base/DebugSession.extension.st index 4fed5221ce5..8d203c3466f 100644 --- a/src/Tool-Base/DebugSession.extension.st +++ b/src/Tool-Base/DebugSession.extension.st @@ -2,19 +2,21 @@ Extension { #name : 'DebugSession' } { #category : '*Tool-Base' } DebugSession >> implement: aMessage inClass: aClass forContext: aContext [ - | method | + | method newContext | aClass compile: (DynamicMessageImplementor for: aMessage in: aClass) value. method := aClass lookupSelector: aMessage selector. MethodClassifier classify: method. - aContext privRefreshWith: method. - aContext method numArgs > 0 ifTrue: + newContext := Context newForMethod: method. + newContext privRefreshWith: method. + method numArgs > 0 ifTrue: [aMessage arguments withIndexDo: [:arg :index| - aContext tempAt: index put: arg]]. - - self updateContextTo: aContext. + newContext tempAt: index put: arg]]. + newContext sender: aContext sender. + newContext receiver: aContext receiver. + self updateContextTo: newContext. self contextChanged. ^ method ] diff --git a/src/Tool-Profilers/TimeProfiler.class.st b/src/Tool-Profilers/TimeProfiler.class.st index 01a76e6a7b4..19c6b31e7b9 100644 --- a/src/Tool-Profilers/TimeProfiler.class.st +++ b/src/Tool-Profilers/TimeProfiler.class.st @@ -134,27 +134,6 @@ TimeProfiler >> blockCode [ ifNotNil: [ blockSource ifNil: [ blockSource := block asString ]] ] -{ #category : 'actions' } -TimeProfiler >> blockCode: aString notifying: aRequestor [ - "Treat the current selection as an expression; evaluate and tally it." - | compiledMethod | - aString ifNil: [^ self]. - blockSource := aString. - compiledMethod := Smalltalk compiler - source: ('self runBlock: [', aString, ']'); - context: self doItContext; - requestor: self; - failBlock: [^self]; - compile. - self showResult: ( compiledMethod valueWithReceiver: self). - self changed: #blockCode. - self changed: #summaryText. - self changed: #fullReport. - self selection: nil. - self updateList. - self startState -] - { #category : 'actions' } TimeProfiler >> browseItem [ self selectedNode ifNotNil: [:current | current browseItem ] diff --git a/src/Traits/TaAbstractComposition.class.st b/src/Traits/TaAbstractComposition.class.st index 3b19eff8c79..d5996ffce8e 100644 --- a/src/Traits/TaAbstractComposition.class.st +++ b/src/Traits/TaAbstractComposition.class.st @@ -146,7 +146,7 @@ TaAbstractComposition >> compile: selector into: aClass [ newMethod := aClass compiler source: sourceCode; permitUndeclared: true; - compile. + newCompile. selector == newMethod selector ifFalse: [ self error: 'selector changed!' ].