diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 90db8ea1..7115f62f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,9 +14,7 @@ jobs: - { name: Crystal, id: crystal, folder: Crystal } - { name: JavaScript, id: js, folder: JavaScript } - { name: SOMns, id: somns, folder: SOMns } - - #- { name: Pharo, id: pharo, folder: Smalltalk } - + - { name: Pharo, id: pharo, folder: Smalltalk } - { name: Squeak, id: squeak, folder: Smalltalk } - { name: Ruby, id: ruby, folder: Ruby } - { name: Lua, id: lua, folder: Lua } @@ -39,7 +37,7 @@ jobs: run: | git clone --depth 1 https://github.com/asdf-vm/asdf.git ~/.asdf --branch v0.14.0 ~/.asdf/bin/asdf plugin add awfy https://github.com/smarr/asdf-awfy.git - if: matrix.id == 'squeak' + if: matrix.id == 'squeak' || matrix.id == 'pharo' - name: Install Crystal if: matrix.id == 'crystal' @@ -52,9 +50,11 @@ jobs: - name: Install Pharo if: matrix.id == 'pharo' - uses: hpi-swa/setup-smalltalkCI@v1 - with: - smalltalk-image: Pharo64-stable + run: | + ~/.asdf/bin/asdf install awfy pharo-120 + cp ~/.asdf/installs/awfy/pharo-120/Pharo*.sources benchmarks/Smalltalk/ + cp ~/.asdf/installs/awfy/pharo-120/Pharo*.image benchmarks/Smalltalk/Pharo.image + cp ~/.asdf/installs/awfy/pharo-120/Pharo*.changes benchmarks/Smalltalk/Pharo.changes - name: Install Squeak if: matrix.id == 'squeak' diff --git a/benchmarks/Smalltalk/CD/CD.som b/benchmarks/Smalltalk/CD/CD.som index a936140f..d2f80fd4 100644 --- a/benchmarks/Smalltalk/CD/CD.som +++ b/benchmarks/Smalltalk/CD/CD.som @@ -31,25 +31,25 @@ CD = Benchmark ( benchmark: numAircrafts = ( | numFrames simulator detector actualCollisions | numFrames := 200. - + simulator := Simulator new: numAircrafts. detector := CollisionDetector new. - + actualCollisions := 0. - + 0 to: numFrames - 1 do: [:i | | time collisions | time := i / 10.0. collisions := detector handleNewFrame: (simulator simulate: time). actualCollisions := actualCollisions + collisions size ]. - + ^ actualCollisions ) - + innerBenchmarkLoop: innerIterations = ( ^ self verify: (self benchmark: innerIterations) resultFor: innerIterations ) - + verify: actualCollisions resultFor: numAircrafts = ( numAircrafts = 1000 ifTrue: [ ^ actualCollisions = 14484 ]. numAircrafts = 500 ifTrue: [ ^ actualCollisions = 14484 ]. @@ -58,14 +58,14 @@ CD = Benchmark ( numAircrafts = 100 ifTrue: [ ^ actualCollisions = 4305 ]. numAircrafts = 10 ifTrue: [ ^ actualCollisions = 390 ]. numAircrafts = 2 ifTrue: [ ^ actualCollisions = 42 ]. - + ScriptConsole println: ('No verification result for ', numAircrafts asString, ' found.'). ScriptConsole println: ('Result is: ', actualCollisions asString). ^ false ) ---- - + new = ( Constants initialize. ^ super new diff --git a/benchmarks/Smalltalk/DeltaBlue/BinaryConstraint.som b/benchmarks/Smalltalk/DeltaBlue/BinaryConstraint.som index 15aebe1a..2037b410 100644 --- a/benchmarks/Smalltalk/DeltaBlue/BinaryConstraint.som +++ b/benchmarks/Smalltalk/DeltaBlue/BinaryConstraint.som @@ -10,13 +10,13 @@ BinaryConstraint = AbstractConstraint ( variables. Instance variables: - v1, v2 possible output variables + v1, v2 possible output variables direction one of: #forward (v2 is output) #backward ( v1 is output) nil (not satisfied)" | v1 v2 direction | - + "initialize-release" initializeVar: variable1 var: variable2 strength: strengthSymbol addTo: planner = ( @@ -89,7 +89,7 @@ BinaryConstraint = AbstractConstraint ( ifTrue: [ aBlock value: v1 ] ifFalse: [ aBlock value: v2 ]. ) - + inputsHasOne: aBlock = ( ^ direction = #forward ifTrue: [ aBlock value: v1 ] diff --git a/benchmarks/Smalltalk/DeltaBlue/EditConstraint.som b/benchmarks/Smalltalk/DeltaBlue/EditConstraint.som index 114930df..8f379764 100644 --- a/benchmarks/Smalltalk/DeltaBlue/EditConstraint.som +++ b/benchmarks/Smalltalk/DeltaBlue/EditConstraint.som @@ -8,7 +8,7 @@ http://web.archive.org/web/20050825101121/http://www.sunlabs.com/people/mario/ja EditConstraint = UnaryConstraint ( "I am a unary input constraint used to mark a variable that the client wishes to change." - + "queries" isInput = ( "I indicate that a variable is to be changed by imperative code." @@ -19,15 +19,15 @@ EditConstraint = UnaryConstraint ( execute = ( "Edit constraints do nothing." ) - + ---- "instance creation" - var: aVariable strength: strengthSymbol addTo: planner = ( + var: aDBVariable strength: strengthSymbol addTo: planner = ( "Install an edit constraint with the given strength on the given variable." - ^ self new initializeVar: aVariable strength: strengthSymbol addTo: planner + ^ self new initializeVar: aDBVariable strength: strengthSymbol addTo: planner ) ) diff --git a/benchmarks/Smalltalk/DeltaBlue/Planner.som b/benchmarks/Smalltalk/DeltaBlue/Planner.som index e2736a51..51ae2a33 100644 --- a/benchmarks/Smalltalk/DeltaBlue/Planner.som +++ b/benchmarks/Smalltalk/DeltaBlue/Planner.som @@ -152,12 +152,12 @@ Planner = ( ^ true ) - changeVar: aVariable newValue: newValue = ( + changeVar: aDBVariable newValue: newValue = ( | editConstraint plan | - editConstraint := EditConstraint var: aVariable strength: Strength SymPreferred addTo: self. + editConstraint := EditConstraint var: aDBVariable strength: Strength SymPreferred addTo: self. plan := self extractPlanFromConstraints: (Vector with: editConstraint). 10 timesRepeat: [ - aVariable value: newValue. + aDBVariable value: newValue. plan execute ]. editConstraint destroyConstraint: self. ) @@ -189,7 +189,7 @@ Planner = ( | unsatisfied todo v | unsatisfied := Vector new. - + out determinedBy: nil. out walkStrength: Strength absoluteWeakest. out stay: true. @@ -205,9 +205,9 @@ Planner = ( unsatisfied sort: [:c1 :c2 | c1 strength stronger: c2 strength]. ^ unsatisfied ) - + ---- - + "instance creation" new = ( ^ super new initialize @@ -217,11 +217,11 @@ Planner = ( chainTest: n = ( "Do chain-of-equality-constraints performance tests." | vars editConstraint plan planner | - + planner := Planner new. vars := Array new: n+1. 1 to: n+1 do: [:i | - vars at: i put: Variable new ]. + vars at: i put: DBVariable new ]. "thread a chain of equality constraints through the variables" 1 to: n do: [ :i | @@ -249,12 +249,12 @@ Planner = ( | scale offset src dst planner dests | planner := Planner new. dests := Vector new. - scale := Variable value: 10. - offset := Variable value: 1000. + scale := DBVariable value: 10. + offset := DBVariable value: 1000. 1 to: n do: [ :i | - src := Variable value: i. - dst := Variable value: i. + src := DBVariable value: i. + dst := DBVariable value: i. dests append: dst. StayConstraint var: src strength: Strength SymDefault addTo: planner. ScaleConstraint var: src var: scale var: offset var: dst strength: Strength SymRequired addTo: planner diff --git a/benchmarks/Smalltalk/DeltaBlue/ScaleConstraint.som b/benchmarks/Smalltalk/DeltaBlue/ScaleConstraint.som index 20735169..3e1dee98 100644 --- a/benchmarks/Smalltalk/DeltaBlue/ScaleConstraint.som +++ b/benchmarks/Smalltalk/DeltaBlue/ScaleConstraint.som @@ -11,10 +11,10 @@ ScaleConstraint = BinaryConstraint ( this relationship but the scale factor and offset are considered read-only. Instance variables: - scale scale factor input variable - offset offset input variable " + scale scale factor input variable + offset offset input variable " | scale offset | - + "initialize-release" initializeSrc: srcVar scale: scaleVar offset: offsetVar dst: dstVar strength: strengthSymbol addTo: planner = ( "Initialize myself with the given variables and strength." @@ -77,7 +77,7 @@ ScaleConstraint = BinaryConstraint ( out stay: (in stay and: [scale stay and: [offset stay]]). out stay ifTrue: [self execute]. "stay optimization" ) - + ---- "instance creation" @@ -87,4 +87,4 @@ ScaleConstraint = BinaryConstraint ( variables." ^ self new initializeSrc: src scale: scale offset: offset dst: dst strength: strengthSymbol addTo: planner ) -) \ No newline at end of file +) diff --git a/benchmarks/Smalltalk/DeltaBlue/StayConstraint.som b/benchmarks/Smalltalk/DeltaBlue/StayConstraint.som index 539769a1..925c08f9 100644 --- a/benchmarks/Smalltalk/DeltaBlue/StayConstraint.som +++ b/benchmarks/Smalltalk/DeltaBlue/StayConstraint.som @@ -16,13 +16,13 @@ StayConstraint = UnaryConstraint ( execute = ( "Stay constraints do nothing." ) - + ---- "instance creation" - var: aVariable strength: strengthSymbol addTo: planner = ( + var: aDBVariable strength: strengthSymbol addTo: planner = ( "Install a stay constraint with the given strength on the given variable." - ^ self new initializeVar: aVariable strength: strengthSymbol addTo: planner + ^ self new initializeVar: aDBVariable strength: strengthSymbol addTo: planner ) ) diff --git a/benchmarks/Smalltalk/DeltaBlue/UnaryConstraint.som b/benchmarks/Smalltalk/DeltaBlue/UnaryConstraint.som index 38ba5d84..e56f53e8 100644 --- a/benchmarks/Smalltalk/DeltaBlue/UnaryConstraint.som +++ b/benchmarks/Smalltalk/DeltaBlue/UnaryConstraint.som @@ -10,16 +10,16 @@ UnaryConstraint = AbstractConstraint ( variable. Instance variables: - output possible output variable + output possible output variable satisfied true if I am currently satisfied " | output satisfied | - + "initialize-release" - initializeVar: aVariable strength: strengthSymbol addTo: planner = ( + initializeVar: aDBVariable strength: strengthSymbol addTo: planner = ( "Initialize myself with the given variable and strength." super initialize: strengthSymbol. - output := aVariable. + output := aDBVariable. satisfied := false. self addConstraint: planner. ) @@ -62,7 +62,7 @@ UnaryConstraint = AbstractConstraint ( inputsDo: aBlock = ( "I have no input variables." ) - + inputsHasOne: aBlock = ( ^ false ) diff --git a/benchmarks/Smalltalk/DeltaBlue/Variable.som b/benchmarks/Smalltalk/DeltaBlue/Variable.som index 8fccd3b1..c1577257 100644 --- a/benchmarks/Smalltalk/DeltaBlue/Variable.som +++ b/benchmarks/Smalltalk/DeltaBlue/Variable.som @@ -5,7 +5,7 @@ License details: http://web.archive.org/web/20050825101121/http://www.sunlabs.com/people/mario/java_benchmarking/index.html " -Variable = ( +DBVariable = ( "I represent a constrained variable. In addition to my value, I maintain the structure of the constraint graph, the current dataflow graph, and various parameters of interest to the DeltaBlue incremental constraint solver. @@ -19,7 +19,7 @@ Variable = ( stay true if I am a planning-time constant mark used by the planner to mark constraints " | value constraints determinedBy walkStrength stay mark | - + "initialize-release" initialize = ( @@ -101,7 +101,7 @@ Variable = ( "Set my walkabout strength in the current dataflow." walkStrength := aStrength. ) - + ---- "instance creation" diff --git a/benchmarks/Smalltalk/Harness.som b/benchmarks/Smalltalk/Harness.som index b18038be..5bae277a 100644 --- a/benchmarks/Smalltalk/Harness.som +++ b/benchmarks/Smalltalk/Harness.som @@ -20,7 +20,7 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. " Harness = ( - + processArguments: args= ( | run | "First argument is the Harness" @@ -33,21 +33,21 @@ Harness = ( ] ]. ^ run ) - + run: args = ( | run | args size < 2 ifTrue: [ self printUsage. Smalltalk exit: 1 ]. - + run := self processArguments: args. run runBenchmark. run printTotal. Smalltalk exit: 0 ) - + printUsage = ( ScriptConsole println: './som -cp Smalltalk Benchmarks/Harness.som [benchmark] [num-iterations [inner-iter]]'. ScriptConsole println: ''. diff --git a/benchmarks/Smalltalk/Havlak/Havlak.som b/benchmarks/Smalltalk/Havlak/Havlak.som index 2a5729a4..e693eb2f 100644 --- a/benchmarks/Smalltalk/Havlak/Havlak.som +++ b/benchmarks/Smalltalk/Havlak/Havlak.som @@ -16,18 +16,18 @@ limitations under the License. Havlak = Benchmark ( innerBenchmarkLoop: innerIterations = ( - ^ self verifyResult: + ^ self verifyResult: (LoopTesterApp new main: innerIterations loop: 50 p: 10 p: 10 p: 5) iterations: innerIterations ) - + verifyResult: result iterations: innerIterations = ( innerIterations = 15000 ifTrue: [ ^ (result at: 1) = 46602 and: [(result at: 2) = 5213] ]. innerIterations = 1500 ifTrue: [ ^ (result at: 1) = 6102 and: [(result at: 2) = 5213] ]. innerIterations = 150 ifTrue: [ ^ (result at: 1) = 2052 and: [(result at: 2) = 5213] ]. innerIterations = 15 ifTrue: [ ^ (result at: 1) = 1647 and: [(result at: 2) = 5213] ]. innerIterations = 1 ifTrue: [ ^ (result at: 1) = 1605 and: [(result at: 2) = 5213] ]. - + ScriptConsole println: ('No verification result for', innerIterations asString, ' found'). ScriptConsole println: ('Result is ', (result at: 1) asString, ', ', (result at: 2) asString). ^ false diff --git a/benchmarks/Smalltalk/Run.som b/benchmarks/Smalltalk/Run.som index ce4fc760..56bf109c 100644 --- a/benchmarks/Smalltalk/Run.som +++ b/benchmarks/Smalltalk/Run.som @@ -21,7 +21,7 @@ THE SOFTWARE. " Run = ( | total numIterations innerIterations benchmarkSuite name | - + initialize: aName = ( name := aName. benchmarkSuite := self loadBenchmarkSuite: aName. @@ -29,7 +29,7 @@ Run = ( numIterations := 1. innerIterations := 1. ) - + loadBenchmarkSuite: className = ( | cls | cls := Smalltalk classNamed: className. @@ -37,21 +37,21 @@ Run = ( self error: 'Failed loading benchmark: ', className ]. ^ cls ) - + name: aString = ( name := aString ) benchmarkSuite: aSuite = ( benchmarkSuite := aSuite ) numIterations: anInt = ( numIterations := anInt ) innerIterations: anInt = ( innerIterations := anInt ) - + runBenchmark = ( ScriptConsole println: ('Starting ', name, ' benchmark ... '). - + self doRuns: benchmarkSuite new. self reportBenchmark. ScriptConsole println: '' ) - + measure: bench = ( | startTime endTime runTime | startTime := Time primUTCMicrosecondsClock. @@ -64,7 +64,7 @@ Run = ( total := total + runTime. ) - + doRuns: bench = ( 1 to: numIterations do: [:i | self measure: bench @@ -74,19 +74,19 @@ Run = ( reportBenchmark = ( ScriptConsole println: (name, ': iterations=', numIterations asString, ' average: ', (total // numIterations) asString, 'us total: ', total asString, - 'us\n'). + 'us'). ) - + printResult: runTime = ( ScriptConsole println: (name, ': iterations=1 runtime: ', runTime asString, 'us') ) - + printTotal = ( ScriptConsole println: ('Total Runtime: ', total asString, 'us') ) - + ---- - + new: aName = ( ^ self new initialize: aName ) diff --git a/benchmarks/Smalltalk/Scripting.st b/benchmarks/Smalltalk/Scripting.st index 28c28196..6939c478 100644 --- a/benchmarks/Smalltalk/Scripting.st +++ b/benchmarks/Smalltalk/Scripting.st @@ -2,6 +2,12 @@ SystemOrganization addCategory: #'Scripting-Examples'! SystemOrganization addCategory: #Scripting! SystemOrganization addCategory: #'Scripting-Tests'! +Object subclass: #ScriptConsole + instanceVariableNames: '' + classVariableNames: 'LastPrintedChar OutputToTranscript Position PrintTarget' + poolDictionaries: '' + category: 'Scripting'! + TestCase subclass: #SubunitTestExamples instanceVariableNames: '' classVariableNames: '' @@ -61,10 +67,10 @@ run: arguments sel := (arguments at: 2) asSymbol. sel = #runAllTests ifTrue: [ ^ self runAllTests.]. - + (arguments size < 3) ifTrue: [ ^ self usage.]. - + self perform: sel with: (arguments at: 3). ! ! @@ -95,7 +101,7 @@ runClasses: aCollectionOfClasses named: aString !SubunitRunner class methodsFor: 'running' stamp: ''! runPackage: aString - ^ self runClasses: (RPackage organizer packageNamed: aString) classes + ^ self runClasses: (self packageOrganizer packageNamed: aString) classes named: aString! ! !SubunitRunner class methodsFor: 'running' stamp: ''! @@ -104,21 +110,21 @@ runPackages: aCollectionOfStrings !SubunitRunner class methodsFor: 'running' stamp: ''! runSuite: aTestSuite - ^ self new - initializeOn: aTestSuite; + ^ self new + initializeOn: aTestSuite; run! ! !SubunitRunner class methodsFor: 'scripting' stamp: 'StefanMarr 3/10/2012 17:48'! usage ScriptConsole println: 'TestConsoleRunner [argument]'. ScriptConsole println: ''. - + ScriptConsole println: ' = runAllTests | runCategory: | runPackage: '.! ! !SubunitRunner methodsFor: 'reporting' stamp: 'StefanMarr 8/12/2012 08:23'! beforeTestCase: aTestCase stream nextPut: Character lf. - + stream nextPutAll: 'test: '. self reportTestName: aTestCase. stream nextPut: Character lf. @@ -127,18 +133,18 @@ beforeTestCase: aTestCase !SubunitRunner methodsFor: 'reporting' stamp: 'StefanMarr 8/12/2012 08:23'! beforeTestSuite: aSuite stream nextPut: Character lf. - + stream nextPutAll: 'suite: '; nextPutAll: aSuite name; nextPut: Character lf. stream nextPutAll: 'progress: '; nextPutAll: aSuite tests size asString; nextPut: Character lf. stream nextPutAll: 'time: '; nextPutAll: DateAndTime now asString; nextPut: Character lf. - + stream flush. ! ! !SubunitRunner methodsFor: 'reporting' stamp: 'StefanMarr 8/12/2012 08:23'! errorTestCase: aTestCase with: error stack: stack stream nextPut: Character lf. - + stream nextPutAll: 'error: '. self reportTestName: aTestCase. self reportCause: error stack: stack. @@ -147,7 +153,7 @@ errorTestCase: aTestCase with: error stack: stack !SubunitRunner methodsFor: 'reporting' stamp: 'StefanMarr 8/12/2012 08:23'! expectedFailTestCase: aTestCase stream nextPut: Character lf. - + stream nextPutAll: 'xfail: '. self reportTestName: aTestCase. stream nextPut: Character lf. @@ -173,7 +179,7 @@ initializeOn: aTestSuite suitePosition := suiteTime := suiteFailures := suiteErrors := 0! ! !SubunitRunner methodsFor: 'reporting' stamp: 'StefanMarr 8/11/2012 13:12'! -reportCause: error stack: stack. +reportCause: error stack: stack. stream nextPutAll: ' ['; nextPut: Character lf. stream tab; nextPutAll: 'type: '; nextPutAll: (error class name); nextPut: Character lf; @@ -193,13 +199,13 @@ reportTestName: aTestCase !SubunitRunner methodsFor: 'running' stamp: 'StefanMarr 8/11/2012 13:15'! run | execBlock | - execBlock := [ [ + execBlock := [ [ self setUp. suiteTime := [ self runAll ] timeToRun ] ensure: [ self tearDown. ] ]. - - (Smalltalk at: #Author ifAbsent: [ + + (Smalltalk at: #Author ifAbsent: [ execBlock value. ^ self ]) uniqueInstance @@ -214,14 +220,14 @@ runAll runCase: aTestCase | error stack didSucceed | didSucceed := false. - + self beforeTestCase: aTestCase. - + [ aTestCase announce: TestCaseStarted withResult: self. aTestCase runCase. aTestCase announce: TestCaseEnded withResult: self. self addPass: aTestCase. - didSucceed := true.] + didSucceed := true.] on: Halt , Error, TestFailure, self class failure, self class error do: [ :err | error := err. @@ -231,7 +237,7 @@ runCase: aTestCase didSucceed ifTrue: [ self successfulTestCase: aTestCase. ^ self.]. - + (error isNil or: [ aTestCase expectedFailures includes: aTestCase selector ]) ifTrue: [ self expectedFailTestCase: aTestCase. ^ self. @@ -246,7 +252,7 @@ runCase: aTestCase !SubunitRunner methodsFor: 'running' stamp: 'StefanMarr 8/11/2012 12:30'! setUp self beforeTestSuite: suite. - + "Initialize the test resources." suite resources do: [ :each | each isAvailable @@ -254,18 +260,18 @@ setUp !SubunitRunner methodsFor: 'private' stamp: ''! stackTraceString: err of: aTestCase - ^ String streamContents: [ :str | + ^ String streamContents: [ :str | | context | context := err signalerContext. - [ context isNil or: [ context receiver == aTestCase and: [ context methodSelector == #runCase ] ] ] whileFalse: [ + [ context isNil or: [ context receiver == aTestCase and: [ context selector == #runCase ] ] ] whileFalse: [ str print: context; nextPut: Character lf. context := context sender ] ] ! ! !SubunitRunner methodsFor: 'reporting' stamp: 'StefanMarr 8/12/2012 08:25'! successfulTestCase: aTestCase stream nextPut: Character lf. - - stream + + stream nextPutAll: 'success: '; nextPutAll: (aTestCase class category); nextPut: $.; nextPutAll: (aTestCase class name); nextPut: $.; @@ -275,15 +281,9 @@ successfulTestCase: aTestCase !SubunitRunner methodsFor: 'running' stamp: 'StefanMarr 8/11/2012 13:14'! tearDown - suite resources + suite resources do: [ :each | each reset ]! ! -Object subclass: #ScriptConsole - instanceVariableNames: '' - classVariableNames: 'LastPrintedChar OutputToTranscript Position PrintTarget' - poolDictionaries: '' - category: 'Scripting'! - !ScriptConsole class methodsFor: 'streaming' stamp: ''! << aString self print: aString! ! @@ -296,17 +296,21 @@ cr detectAvailableMechanismForStdout "The preferred means is to use the stdout file handle. Will try to fall back on the RoarVM primitive if necessary." - | cls | - (FileStream respondsTo: #stdout) + | cls ioCls | + (Smalltalk classNamed: #Stdio) + ifNotNil: [:c| ioCls := c ] + ifNil: [ ioCls := Smalltalk classNamed: #FileStream ]. + + (ioCls respondsTo: #stdout) ifTrue: [ - PrintTarget := FileStream stdout. - PrintTarget closed ifTrue: [ - PrintTarget := FileStream standardIOStreamNamed: #stdout forWrite: true ]. + PrintTarget := ioCls stdout. + PrintTarget closed ifTrue: [ + PrintTarget := ioCls standardIOStreamNamed: #stdout forWrite: true ]. ^ self. ]. - + cls := Smalltalk at: #RVMOperations ifAbsent: [nil]. - + "Squeak 4.2 provides a stream at FileStream>>stdout" PrintTarget := Transcript. ^ Transcript! ! @@ -358,9 +362,9 @@ print: somethingAsString withLineEnding: lineEnd Position := Position + output size. output size > 0 ifTrue: [ LastPrintedChar := output last]. - + PrintTarget ifNotNil: [ - PrintTarget closed ifTrue: [ScriptConsole detectAvailableMechanismForStdout]. + PrintTarget closed ifTrue: [ScriptConsole detectAvailableMechanismForStdout]. PrintTarget nextPutAll: (output, lineEnd) ]. @@ -371,7 +375,7 @@ print: somethingAsString withLineEnding: lineEnd !ScriptConsole class methodsFor: 'printing' stamp: ''! println: somethingAsString - self print: somethingAsString withLineEnding: String crlf.! ! + self print: somethingAsString withLineEnding: String lf.! ! !ScriptConsole class methodsFor: 'printing' stamp: 'StefanMarr 12/31/2011 01:22'! space diff --git a/benchmarks/Smalltalk/SomLoader-Compiler.st b/benchmarks/Smalltalk/SomLoader-Compiler.st index 209277c2..f5732582 100644 --- a/benchmarks/Smalltalk/SomLoader-Compiler.st +++ b/benchmarks/Smalltalk/SomLoader-Compiler.st @@ -6,6 +6,24 @@ Object subclass: #SomClassGenerationContext poolDictionaries: '' category: 'SomLoader-Compiler'! +Object subclass: #SomParser + instanceVariableNames: 'cgenc sym text lexer shouldReadSources' + classVariableNames: 'BinaryOpSyms KeywordSelectorSyms SingleOpSyms TextStreamCls' + poolDictionaries: '' + category: 'SomLoader-Compiler'! + +SomParser subclass: #SomClassParser + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SomLoader-Compiler'! + +SomParser subclass: #SomMethodParser + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'SomLoader-Compiler'! + !SomClassGenerationContext commentStamp: 'StefanMarr 7/21/2016 13:09' prior: 0! I represent a class that is currently parsed and I will create the final class object from this information.! @@ -99,7 +117,7 @@ createEmptyClassIn: universe superclass := universe globalAt: self superName ifAbsent: [universe loadSOMClass: self superName]. - ^ universe classClass + ^ universe classClass inUniverse: universe withSomSuperClass: superclass.! ! @@ -217,14 +235,17 @@ load: aFileName parser := SomClassParser on: sourceStream. ^ parser start! ! -!SomCompiler methodsFor: 'file access' stamp: 'StefanMarr 7/21/2016 10:53'! +!SomCompiler methodsFor: 'file access' stamp: 'StefanMarr 1/28/2024 01:08'! sourceOfClassFile: aFileName - | source | - source := nil. - FileStream - fileNamed: aFileName - do: [:s | source := s contents]. - ^ source readStream! ! + (Smalltalk hasClassNamed: #Stdio) + ifTrue: [^ aFileName asFileReference readStream] + ifFalse: [ + | source | + source := nil. + (Smalltalk classNamed: #FileStream) + fileNamed: aFileName + do: [:s | source := s contents]. + ^ source readStream ]! ! Object subclass: #SomLexer instanceVariableNames: 'stream text nextText lineNumber peekDone sym nextSym symChr nextSymChr buf bufP prevStreamPosition lastNonWhiteChar prevLastNonWhiteChar' @@ -235,8 +256,6 @@ Object subclass: #SomLexer !SomLexer class methodsFor: 'instance creation' stamp: 'StefanMarr 5/10/2012 21:22'! on: aReadStream | lexer | - [aReadStream isKindOf: PositionableStream ] assert. - lexer := self new. lexer stream: aReadStream. ^ lexer! ! @@ -262,26 +281,26 @@ endOfBuffer !SomLexer methodsFor: 'accessing' stamp: 'StefanMarr 5/13/2012 17:14'! fillBuffer stream atEnd ifTrue: [^ -1]. - + buf := stream nextLine. buf ifNil: [^ -1]. - + lineNumber := lineNumber + 1. - + bufP := 1. ^ buf size.! ! !SomLexer methodsFor: 'private' stamp: 'StefanMarr 5/13/2012 17:11'! hasMoreInput self readBufferIfEmpty: [^ false]. - + ^ true! ! !SomLexer methodsFor: 'initialize-release' stamp: 'StefanMarr 5/13/2012 10:04'! initialize lineNumber := 0. peekDone := false. - text := RWBinaryOrTextStream on: String new. + text := SomParser textStreamCls on: String new. buf := ''. bufP := 1.! ! @@ -310,7 +329,7 @@ lastNonWhiteCharIdx match: aSymbol sym := aSymbol. symChr := self currentChar. - text := RWBinaryOrTextStream with: symChr asString. + text := SomParser textStreamCls with: symChr asString. self readNext. ^ sym.! ! @@ -320,7 +339,7 @@ matchColonOrAssignment sym := #assign. bufP := bufP + 2. symChr := nil. - text := RWBinaryOrTextStream with: ':='. + text := SomParser textStreamCls with: ':='. ^ sym ]. @@ -329,8 +348,8 @@ matchColonOrAssignment !SomLexer methodsFor: 'lexing' stamp: 'StefanMarr 5/13/2012 18:33'! matchLetter symChr := nil. - text := RWBinaryOrTextStream on: String new. - + text := SomParser textStreamCls on: String new. + [self currentChar notNil and: [ self currentChar isLetter or: [ self currentChar isDigit or: [ @@ -339,14 +358,14 @@ matchLetter text nextPut: self currentChar. self readNext. ]. - + sym := #identifier. - + self currentChar == $: ifTrue: [ sym := #keyword. self readNext. text nextPut: $:. - + (self currentChar notNil and: [self currentChar isLetter]) ifTrue: [ sym := #keywordSequence. [self currentChar isLetter or: [self currentChar == $:]] @@ -362,7 +381,7 @@ matchLetter !SomLexer methodsFor: 'lexing' stamp: 'StefanMarr 5/13/2012 17:51'! matchMinusOrSeparator (self nextInBufIs: self seperator) ifTrue: [ - text := RWBinaryOrTextStream on: String new. + text := SomParser textStreamCls on: String new. [self currentChar == $-] whileTrue: [ text nextPut: $-. self readNext. @@ -379,8 +398,8 @@ matchNumber | sawDecimalMark | sym := #integer. symChr := nil. - text := RWBinaryOrTextStream on: String new. - + text := SomParser textStreamCls on: String new. + sawDecimalMark := false. [ text nextPut: self currentChar. @@ -404,8 +423,8 @@ matchOperator (self isOperator: (self bufchar: bufP + 1)) ifTrue: [ sym := #operatorSequence. symChr := nil. - text := RWBinaryOrTextStream on: String new. - + text := SomParser textStreamCls on: String new. + [self isOperator: self currentChar] whileTrue: [ text nextPut: self currentChar. self readNext. @@ -427,7 +446,7 @@ matchOperator cur == $, ifTrue: [ ^ self match: #comma]. cur == $@ ifTrue: [ ^ self match: #at ]. cur == $% ifTrue: [ ^ self match: #per ]. - + Error signal: 'STEFAN: this is unexpected, I think...'.! ! !SomLexer methodsFor: 'lexing' stamp: 'StefanMarr 7/22/2016 23:42'! @@ -435,7 +454,7 @@ matchPrimitive self readNext: self primitive size. sym := #primitive. symChr := nil. - text := RWBinaryOrTextStream with: self primitive. + text := SomParser textStreamCls with: self primitive. ^ sym ! ! @@ -443,17 +462,17 @@ matchPrimitive matchString sym := #STString. symChr := nil. - text := RWBinaryOrTextStream on: String new. - + text := SomParser textStreamCls on: String new. + self readNext. "skip start $' " [ self currentChar == $' ] whileFalse: [ text nextPut: self currentChar. self readNext. ]. - + self readNext. "skip the ending $'" - + ^ sym! ! !SomLexer methodsFor: 'helper' stamp: 'StefanMarr 5/13/2012 17:48'! @@ -471,9 +490,9 @@ nextWordInBufIs: aString (self nextInBufIs: aString) ifTrue: [ | nextPos nextChar | nextPos := bufP + aString size. - + nextPos > buf size ifTrue: [^true]. - + nextChar := buf at: nextPos. ^ (nextChar isLetter or: [nextChar isDigit]) not. ]. @@ -485,22 +504,22 @@ peek | oldSym oldSymChr oldText oldPrevStream | peekDone ifTrue: [ Error signal: 'SOM Lexer: cannot peek twice!!' ]. - + oldSym := sym. oldSymChr := symChr. - oldText := RWBinaryOrTextStream with: text contents. + oldText := SomParser textStreamCls with: text contents. oldPrevStream := prevStreamPosition. - + nextSym := self symbol. nextSymChr:= symChr. nextText := text. - + sym := oldSym. symChr:= oldSymChr. text := oldText. - + peekDone := true. - + prevStreamPosition := oldPrevStream. ^ nextSym.! ! @@ -582,16 +601,16 @@ symbol | currentChar | peekDone ifTrue: [^ self symbolAfterPeek]. prevLastNonWhiteChar := lastNonWhiteChar. - + self skipWhitespaceAndCommentsOrEnd: [ sym := #none. symChr := nil. - text := RWBinaryOrTextStream on: String new. + text := SomParser textStreamCls on: String new. ^ sym ]. currentChar := self currentChar. - + currentChar == $' ifTrue: [ ^ self matchString ]. currentChar == $[ ifTrue: [ ^ self match: #newBlock ]. currentChar == $] ifTrue: [ ^ self match: #endBlock ]. @@ -605,15 +624,15 @@ symbol (self isOperator: currentChar) ifTrue: [ ^ self matchOperator ]. (self nextWordInBufIs: self primitive) ifTrue: [ ^ self matchPrimitive ]. - + currentChar isLetter ifTrue: [ ^ self matchLetter ]. currentChar isDigit ifTrue: [ ^ self matchNumber ]. - + "else" sym := #none. symChr := currentChar. - text := RWBinaryOrTextStream with: currentChar asString. - + text := SomParser textStreamCls with: currentChar asString. + ^ sym! ! !SomLexer methodsFor: 'lexing' stamp: 'StefanMarr 5/12/2012 23:18'! @@ -655,7 +674,7 @@ checkClassesNotInSystem createClasses | postPoned | postPoned := classDefinitions. - [ postPoned isEmpty ] whileFalse: [ + [ postPoned isEmpty ] whileFalse: [ postPoned := self createClasses: postPoned ]! ! !SomLoader methodsFor: 'actions' stamp: 'StefanMarr 7/22/2016 12:56'! @@ -668,19 +687,35 @@ createClasses: classes postPoned := OrderedCollection new. classes do: [:c | (Smalltalk hasClassNamed: c superName) - ifTrue: [ - | instVars classVars superCls | - superCls := Smalltalk classNamed: c superName. - instVars := self varString: c instanceFields. - classVars := self varString: c classFields. - superCls - subclass: c theName asSymbol - instanceVariableNames: instVars - classVariableNames: classVars - package: 'AWFY-Benchmarks' ] + ifTrue: [ self createClass: c ] ifFalse: [ postPoned add: c ]]. ^ postPoned! ! +!SomLoader methodsFor: 'actions' stamp: 'StefanMarr 2/02/2024 12:15'! +createClass: cls + | instVars classVars superCls | + superCls := Smalltalk classNamed: cls superName. + instVars := self varString: cls instanceFields. + classVars := self varString: cls classFields. + + (superCls respondsTo: #classInstaller) + ifTrue: [ + superCls classInstaller make: [ :builder | + builder + superclass: superCls; + name: cls theName asSymbol; + slotsFromString: instVars; + sharedVariablesFromString: classVars; + package: 'AWFY-Benchmarks'; + environment: superCls environment ]] + ifFalse: [ + superCls + subclass: cls theName asSymbol + instanceVariableNames: instVars + classVariableNames: classVars + package: 'AWFY-Benchmarks' ] +! ! + !SomLoader methodsFor: 'actions' stamp: 'StefanMarr 7/22/2016 13:04'! createMethods classDefinitions do: [:c | @@ -718,21 +753,9 @@ loadFile: aFileName ^ results! ! !SomLoader methodsFor: 'helper methods' stamp: 'StefanMarr 7/22/2016 12:47'! -varString: collectionOfSymbols +varString: collectionOfSymbols ^ collectionOfSymbols inject: '' into: [:res :sym | res, ' ', sym asString ]! ! -Object subclass: #SomParser - instanceVariableNames: 'cgenc sym text lexer shouldReadSources' - classVariableNames: 'BinaryOpSyms KeywordSelectorSyms SingleOpSyms' - poolDictionaries: '' - category: 'SomLoader-Compiler'! - -SomParser subclass: #SomClassParser - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'SomLoader-Compiler'! - !SomClassParser class methodsFor: 'instance creation' stamp: 'StefanMarr 7/21/2016 11:05'! on: readStream | parser | @@ -743,13 +766,13 @@ on: readStream !SomClassParser methodsFor: 'patterns' stamp: 'StefanMarr 5/13/2012 17:54'! classBody self expect: #newTerm. - + self classSide. - + self classInstanceSwitch ifTrue: [ cgenc toggleClassSide. self classSide.]. - + self expect: #endTerm.! ! !SomClassParser methodsFor: 'patterns' stamp: 'StefanMarr 5/13/2012 12:13'! @@ -759,7 +782,7 @@ classInstanceSwitch !SomClassParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 13:30'! classSide self vars. - + [self symIsIdentifier or: [ sym == #keyword or: [ sym == #operatorSequence or: [ @@ -770,9 +793,9 @@ classSide !SomClassParser methodsFor: 'patterns' stamp: 'StefanMarr 5/17/2012 15:23'! classStart cgenc theName: self identifier. - + self expect: #equal. - + sym == #identifier ifTrue: [cgenc superName: self identifier.]. ! ! @@ -785,7 +808,7 @@ classdef !SomClassParser methodsFor: 'initialize-release' stamp: 'StefanMarr 7/21/2016 13:07'! initialize super initialize. - + self cgenc: SomClassGenerationContext new.! ! !SomClassParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 14:49'! @@ -816,16 +839,10 @@ vars [self symIsIdentifier] whileTrue: [ cgenc addField: self variable. ]. - + self expect: #or. ]! ! -SomParser subclass: #SomMethodParser - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'SomLoader-Compiler'! - !SomMethodParser class methodsFor: 'instance creation' stamp: 'StefanMarr 7/21/2016 13:35'! with: lexer sym: sym text: text | parser | @@ -857,7 +874,7 @@ assignation assignment | v | v := self variable. - self expect: #assign. + self expect: #assign. ^ v! ! !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 13:18'! @@ -865,12 +882,12 @@ assignments: vars self symIsIdentifier ifTrue: [ | var nextSym | var := self assignment. - + nextSym := self peek. nextSym == #assign ifTrue: [ self assignments: vars. ]. - + vars add: var ]! ! !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 13:42'! @@ -882,10 +899,10 @@ binaryMessage: superSend binaryOperand: superSend | doSuper | doSuper := self primary: superSend. - + [self symIsIdentifier] whileTrue: [self unaryMessage: doSuper]. - + ^ doSuper! ! !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 11:31'! @@ -898,7 +915,7 @@ binaryPattern binarySelector | s | s := text asSymbol. - + (self accept: #or) ifFalse: [ (self accept: #comma) ifFalse: [ (self accept: #minus) ifFalse: [ @@ -935,7 +952,7 @@ blockBody ]. self expression. - + (self accept: #period) ifTrue: [ self blockBody. ]. @@ -959,7 +976,7 @@ blockPattern evaluation | superSend | superSend := self primary: false. - + (self symIsIdentifier or: [ sym == #keyword or: [ sym == #operatorSequence or: [ @@ -972,25 +989,25 @@ expectOneOf: syms | msg | (self acceptOneOf: syms) ifTrue: [ ^ true. ]. - - msg := RWBinaryOrTextStream on: String new. + + msg := SomParser textStreamCls on: String new. msg nextPutAll: 'unexpected symbol in line '. msg nextPutAll: lexer currentLineNumber asString. msg nextPutAll: '. Expected one of '. - - syms do: [:s | + + syms do: [:s | msg nextPutAll: s. msg nextPutAll: ', ']. - + msg nextPutAll: 'but found '. msg nextPutAll: sym asString. - + self printableSymbol ifTrue: [ msg nextPutAll: ' (', text contents, ')']. - + msg nextPutAll: ': '. msg nextPutAll: lexer rawBuffer. - + Error signal: msg.! ! !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 13:17'! @@ -1019,10 +1036,10 @@ fakeMgenc formula | superSend | superSend := self binaryOperand: false. - + (sym == #operatorSequence or: [self symIn: BinaryOpSyms]) ifTrue: [self binaryMessage: superSend ]. - + "only the first message in a sequence can be a super send" [sym == #operatorSequence or: [self symIn: BinaryOpSyms]] whileTrue: [self binaryMessage: false ].! ! @@ -1037,8 +1054,8 @@ keyword !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 13:45'! keywordMessage: superSend | kw sel | - kw := RWBinaryOrTextStream on: String new. - + kw := SomParser textStreamCls on: String new. + [ kw nextPutAll: self keyword. self formula. ] doWhileTrue: [sym == #keyword]. @@ -1049,7 +1066,7 @@ keywordMessage: superSend keywordPattern | methodDef first | first := true. - methodDef := RWBinaryOrTextStream on: String new. + methodDef := SomParser textStreamCls on: String new. [ first ifTrue: [ first := false ] ifFalse: [ methodDef nextPutAll: ' ' ]. methodDef nextPutAll: self keyword. methodDef nextPutAll: ' '. @@ -1062,9 +1079,9 @@ keywordPattern keywordSelector | s | s := text asSymbol. - + self expectOneOf: KeywordSelectorSyms. - + ^ s! ! !SomMethodParser methodsFor: 'accessing' stamp: 'StefanMarr 7/21/2016 13:33'! @@ -1132,16 +1149,16 @@ locals messages: superSend | doSuper | doSuper := superSend. - + self symIsIdentifier ifTrue: [ [ self unaryMessage: doSuper. doSuper := false. ] doWhileTrue: [self symIsIdentifier]. - + [sym == #operatorSequence or: [self symIn: BinaryOpSyms]] whileTrue: [ self binaryMessage: false. ]. - + sym == #keyword ifTrue: [ self keywordMessage: false. ]. @@ -1152,7 +1169,7 @@ messages: superSend [ self binaryMessage: doSuper. doSuper := false. ] doWhileTrue: [sym == #operatorSequence or: [self symIn: BinaryOpSyms]]. - + sym == #keyword ifTrue: [ self keywordMessage: false. ]. @@ -1167,7 +1184,7 @@ method | name body | name := self methodName. self expect: #equal. - + body := self methodBody. ^ name, Character lf asString, body ! ! @@ -1176,14 +1193,14 @@ method methodBlock | methodSource startIdx endIdx len stream trueEndIdx | startIdx := lexer prevLastNonWhiteCharIdx. - + self expect: #newTerm. self blockContents. - + endIdx := lexer prevLastNonWhiteCharIdx - 1. stream := lexer stream. trueEndIdx := stream position. - + len := endIdx - startIdx. methodSource := String new: len. stream position: startIdx. @@ -1231,9 +1248,9 @@ nestedBlock !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 5/13/2012 10:30'! nestedTerm self expect: #newTerm. - + self expression. - + self expect: #endTerm.! ! !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 13:13'! @@ -1249,7 +1266,7 @@ parserState primary: doSuper | superSend | superSend := doSuper. - + self symIsIdentifier ifTrue: [ | v | v := self variable. @@ -1279,17 +1296,17 @@ primitiveBlock !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 7/21/2016 13:45'! result - self expression. + self expression. self accept: #period.! ! !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 5/13/2012 10:36'! selector (sym == #operatorSequence or: [self symIn: SingleOpSyms]) ifTrue: [^ self binarySelector ]. - + (sym == #keyword or: [sym == #keywordSequence]) ifTrue: [^ self keywordSelector]. - + ^ self unarySelector! ! !SomMethodParser methodsFor: 'patterns' stamp: 'StefanMarr 5/13/2012 11:53'! @@ -1318,6 +1335,9 @@ initialize SingleOpSyms := #( not and or star div mod plus equal more less comma at per none). BinaryOpSyms := #(or comma minus equal not and or star div mod plus equal more less comma at per none). KeywordSelectorSyms := #(keyword keywordSequence). + TextStreamCls := (Smalltalk classNamed: #TextStream) + ifNotNil: [:cls | cls] + ifNil: [Smalltalk classNamed: #RWBinaryOrTextStream]. ! ! SomParser initialize! @@ -1342,21 +1362,21 @@ cgenc: anObject expect: aSymbol | msg | (self accept: aSymbol) ifTrue: [ ^ true ]. - - msg := RWBinaryOrTextStream on: String new. + + msg := SomParser textStreamCls on: String new. msg nextPutAll: 'unexpected symbol in line '. msg nextPutAll: lexer currentLineNumber asString. msg nextPutAll: '. Expected '. msg nextPutAll: aSymbol asString. msg nextPutAll: ', but found '. msg nextPutAll: sym asString. - + self printableSymbol ifTrue: [ msg nextPutAll: ' (', text contents, ')'.]. - + msg nextPutAll: ': '. msg nextPutAll: lexer rawBuffer. - + Error signal: msg contents.! ! !SomParser methodsFor: 'private' stamp: 'StefanMarr 5/10/2012 23:03'! @@ -1366,12 +1386,12 @@ getSym !SomParser methodsFor: 'patterns' stamp: 'StefanMarr 5/15/2012 22:28'! identifier - | s | + | s | s := text asSymbol. - + (self accept: #primitive) ifFalse: [ - self expect: #identifier]. - + self expect: #identifier]. + ^ s! ! !SomParser methodsFor: 'initialize-release' stamp: 'StefanMarr 7/21/2016 13:16'! @@ -1413,4 +1433,8 @@ symIsIdentifier variable ^ self identifier! ! +!SomParser class methodsFor: 'patterns' stamp: 'StefanMarr 2/02/2024 20:16'! +textStreamCls + ^ TextStreamCls! ! + SomParser initialize! diff --git a/benchmarks/Smalltalk/SomLoader-Tests.st b/benchmarks/Smalltalk/SomLoader-Tests.st index b72f813a..6fccf3da 100644 --- a/benchmarks/Smalltalk/SomLoader-Tests.st +++ b/benchmarks/Smalltalk/SomLoader-Tests.st @@ -8,13 +8,14 @@ TestCase subclass: #SomLoaderTests !SomLoaderTests methodsFor: 'test all files' stamp: 'StefanMarr 7/22/2016 11:01'! testLoadAll - | classes inSystem loader | + | classes loader | loader := SomLoader load: '.'. - classes := loader classDefinitions. - + classes := loader classDefinitions. + "Test that none of the loaded classes is in the system" - inSystem := classes collect: [:c | Smalltalk hasClassNamed: c theName ]. - self deny: (inSystem anySatisfy: [:b | b ])! ! + classes do: [:c | + self deny: (Smalltalk hasClassNamed: c theName) description: 'Class already present with name:', c theName. + ].! ! !SomLoaderTests methodsFor: 'test' stamp: 'StefanMarr 7/21/2016 15:00'! testLoadBall diff --git a/benchmarks/Smalltalk/build-image-part2.st b/benchmarks/Smalltalk/build-image-part2.st new file mode 100644 index 00000000..ea5242ea --- /dev/null +++ b/benchmarks/Smalltalk/build-image-part2.st @@ -0,0 +1,19 @@ +| loader runner starting | +ScriptConsole println: '== Run Tests'. + +runner := SubunitRunner runPackage: 'SomLoader'. + +ScriptConsole println: '== Load Code'. + +loader := SomLoader load: '.'. +loader createClasses. +loader createMethods. + +ScriptConsole println: '== Safe and Exit'. + +starting := Smalltalk saveAs: 'AWFY_Pharo'. +starting ifTrue: [ ^ self ]. + +runner hasPassed + ifTrue: [ Smalltalk exit: 0 ] + ifFalse: [ Smalltalk exit: 1 ]! diff --git a/benchmarks/Smalltalk/build-image-squeak.st b/benchmarks/Smalltalk/build-image-squeak.st index cca17613..3fa7ea3e 100644 --- a/benchmarks/Smalltalk/build-image-squeak.st +++ b/benchmarks/Smalltalk/build-image-squeak.st @@ -1,9 +1,13 @@ FileStream startUp: true. -[| parentDir runner loader starting | -FileStream stdout nextPutAll: 'Installing SOM benchmarks'. +[| parentDir runner loader starting | Utilities setAuthorInitials: 'SomLoader'. +FileStream stdout class compile: 'println: aString + ^ self nextPutAll: aString; cr; flush' classified: '*SomLoader'. + +FileStream stdout println: 'Installing SOM benchmarks'. + parentDir := (FileDirectory default fileNamed: Smalltalk documentPath) directoryEntry containingDirectory. @@ -31,26 +35,33 @@ Smalltalk class compile: 'exit: code ^ Smalltalk quitPrimitive' classified: '*SomLoader'. Smalltalk at: #DiskStore put: FileDirectory. + +"We don't need it, but we'd like the Json name for the benchmark." +Json rename: 'SqueakJson'. +JsonObject rename: 'SqueakJsonObject'. + FileDirectory class methodDict at: #delimiter put: (FileDirectory class >> #slash). -FileStream stdout nextPutAll: '== Run Tests'; cr. +FileStream stdout println: '== Run Tests'. runner := (Smalltalk classNamed: 'SomLoaderTests') suite run. -FileStream stdout nextPutAll: '== Load Code'; cr. +FileStream stdout println: '== Load Code'. loader := (Smalltalk classNamed: 'SomLoader') load: parentDir fullName. loader createClasses. loader createMethods. (runner hasPassed) - ifFalse: [FileStream stderr nextPutAll: '==== Test errors ===='; cr; nextPutAll: runner printString; cr.]. + ifFalse: [FileStream stderr println: '==== Test errors ===='; println: runner printString.]. -FileStream stdout nextPutAll: '== Save and Exit'; cr. +FileStream stdout println: '== Save and Exit'. PreferenceWizardMorph allInstances do: #delete. SystemWindow allSubInstances do: #delete. -Smalltalk saveAs: 'AWFY_Squeak'] on: Error do: [:e | - FileStream stdout nextPutAll: e printString. +Smalltalk saveAs: 'AWFY_Squeak'. + +] on: Error do: [:e | + FileStream stdout nextPutAll: e printString; cr; flush. ]. Project current addDeferredUIMessage: [ diff --git a/benchmarks/Smalltalk/build-image.st b/benchmarks/Smalltalk/build-image.st index 96f82981..6ad8ffe7 100644 --- a/benchmarks/Smalltalk/build-image.st +++ b/benchmarks/Smalltalk/build-image.st @@ -1,24 +1,11 @@ -| loader runner starting | -'Scripting.st' asFileReference fileIn. -'SomLoader-Compiler.st' asFileReference fileIn. -'SomLoader-Tests.st' asFileReference fileIn. - -ScriptConsole println: '== Run Tests'. - -runner := SubunitRunner runPackage: 'SomLoader-Tests'. - -ScriptConsole println: '== Load Code'. - +EpMonitor current disable. Author fullName: 'SomLoader'. -loader := SomLoader load: '.'. -loader createClasses. -loader createMethods. - -ScriptConsole println: '== Safe and Exit'. -starting := Smalltalk saveAs: 'AWFY'. -starting ifTrue: [ ^ self ]. +PharoCommandLineHandler compile: 'runPreferences + "Disabled preference loading for benchmarking" + ^ self' classified: '*SomLoader'. -runner hasPassed - ifTrue: [ Smalltalk exit: 0 ] - ifFalse: [ Smalltalk exit: 1 ]! +'Scripting.st' asFileReference fileIn. +'SomLoader-Compiler.st' asFileReference fileIn. +'SomLoader-Tests.st' asFileReference fileIn. +'build-image-part2.st' asFileReference fileIn. diff --git a/benchmarks/Smalltalk/build.sh b/benchmarks/Smalltalk/build.sh index 21c00506..3bb14c07 100755 --- a/benchmarks/Smalltalk/build.sh +++ b/benchmarks/Smalltalk/build.sh @@ -15,7 +15,13 @@ then ERR "Please copy a Squeak.image, Squeak.changes and the corresponding *.sources file to this directory." exit 1 fi - ~/.asdf/installs/awfy/squeak-6.0-22148/bin/squeak -headless Squeak.image build-image-squeak.st + cmd=~/.asdf/installs/awfy/squeak-6.0-22148/bin/squeak + headless="-vm-sound-null -vm-display-null -noevents" + if [[ ! -f "$cmd" ]]; then + cmd=~/.asdf/installs/awfy/squeak-6.0-22148/Squeak.app/Contents/MacOS/Squeak + headless="-headless" + fi + eval "$cmd" "$headless" Squeak.image build-image-squeak.st elif [[ "$1" == "pharo" ]] then pushd "$SCRIPT_PATH" @@ -25,7 +31,7 @@ then ERR "Please copy a Pharo.image, Pharo.changes and the corresponding *.sources file to this directory." exit 1 fi - ~/.asdf/installs/awfy/pharo-120/bin/pharo Pharo.image build-image.st + ~/.asdf/installs/awfy/pharo-120/pharo Pharo.image build-image.st else exit 0 fi diff --git a/benchmarks/Smalltalk/run.st b/benchmarks/Smalltalk/run.st index 087a74f7..abc80300 100644 --- a/benchmarks/Smalltalk/run.st +++ b/benchmarks/Smalltalk/run.st @@ -1,4 +1,5 @@ | args | "Adapt array to expectation of harness" +ScriptConsole detectAvailableMechanismForStdout. args := {nil}, Smalltalk arguments. Harness new run: args.! diff --git a/test.conf b/test.conf index 1ecbd797..9124423e 100644 --- a/test.conf +++ b/test.conf @@ -125,10 +125,12 @@ executors: Pharo: path: /home/runner/.asdf/installs/awfy/pharo-120 executable: pharo + env: + HOME: /home/runner Squeak: path: /home/runner/.asdf/installs/awfy/squeak-6.0-22148/bin executable: squeak - args: -headless + args: -vm-sound-null -vm-display-null -noevents Lua52: path: .lua/bin executable: lua5.2