Updated to PetitCompiler-JanVrany.135, PetitCompiler-Tests-JanKurs.93, PetitCompiler-Extras-Tests-JanVrany.16, PetitCompiler-Benchmarks-JanKurs.12
Name: PetitCompiler-JanVrany.135
Author: JanVrany
Time: 22-07-2015, 06:53:29.127 PM
UUID: 890178b5-275d-46af-a2ad-1738998f07cb
Ancestors: PetitCompiler-JanVrany.134
Name: PetitCompiler-Tests-JanKurs.93
Author: JanKurs
Time: 20-07-2015, 11:30:10.283 PM
UUID: 6473e671-ad70-42ca-b6c3-654b78edc531
Ancestors: PetitCompiler-Tests-JanKurs.92
Name: PetitCompiler-Extras-Tests-JanVrany.16
Author: JanVrany
Time: 22-07-2015, 05:18:22.387 PM
UUID: 8f6f9129-dbba-49b1-9402-038470742f98
Ancestors: PetitCompiler-Extras-Tests-JanKurs.15
Name: PetitCompiler-Benchmarks-JanKurs.12
Author: JanKurs
Time: 06-07-2015, 02:10:06.901 PM
UUID: cb24f1ac-46a4-494d-9780-64576f0f0dba
Ancestors: PetitCompiler-Benchmarks-JanKurs.11, PetitCompiler-Benchmarks-JanVrany.e29bd90f388e.20150619081300
--- a/PPCompositeParser.st Thu May 21 14:12:22 2015 +0100
+++ b/PPCompositeParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -1,5 +1,7 @@
"{ Package: 'stx:goodies/petitparser' }"
+"{ NameSpace: Smalltalk }"
+
PPDelegateParser subclass:#PPCompositeParser
instanceVariableNames:'dependencies'
classVariableNames:''
@@ -83,6 +85,7 @@
^ (self newStartingAt: aSymbol) parse: anObject onError: aBlock
! !
+
!PPCompositeParser methodsFor:'accessing'!
start
--- a/PPDelegateParser.st Thu May 21 14:12:22 2015 +0100
+++ b/PPDelegateParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -1,5 +1,7 @@
"{ Package: 'stx:goodies/petitparser' }"
+"{ NameSpace: Smalltalk }"
+
PPParser subclass:#PPDelegateParser
instanceVariableNames:'parser'
classVariableNames:''
@@ -15,6 +17,8 @@
! !
+
+
!PPDelegateParser methodsFor:'accessing'!
children
--- a/PPFlattenParser.st Thu May 21 14:12:22 2015 +0100
+++ b/PPFlattenParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -1,5 +1,7 @@
"{ Package: 'stx:goodies/petitparser' }"
+"{ NameSpace: Smalltalk }"
+
PPDelegateParser subclass:#PPFlattenParser
instanceVariableNames:''
classVariableNames:''
@@ -40,6 +42,11 @@
^ '$Header: /cvs/stx/stx/goodies/petitparser/PPFlattenParser.st,v 1.4 2014-03-04 14:32:30 cg Exp $'
!
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+!
+
version_SVN
^ '$Id: PPFlattenParser.st,v 1.4 2014-03-04 14:32:30 cg Exp $'
! !
--- a/PPSequenceParser.st Thu May 21 14:12:22 2015 +0100
+++ b/PPSequenceParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -1,5 +1,7 @@
"{ Package: 'stx:goodies/petitparser' }"
+"{ NameSpace: Smalltalk }"
+
PPListParser subclass:#PPSequenceParser
instanceVariableNames:''
classVariableNames:''
@@ -9,6 +11,13 @@
+!PPSequenceParser methodsFor:'*petitcompiler'!
+
+map: aBlock
+ ^ aBlock numArgs = self children size
+ ifTrue: [ self ==> [ :nodes | aBlock valueWithArguments: nodes ] ]
+ ifFalse: [ self error: aBlock numArgs asString , ' arguments expected.' ]
+! !
!PPSequenceParser methodsFor:'operations'!
@@ -26,14 +35,6 @@
^ self ==> [ :nodes | anArrayOfIntegers collect: [ :index | nodes at: index ] ]
! !
-!PPSequenceParser methodsFor:'operators-mapping'!
-
-map: aBlock
- ^ aBlock numArgs = self children size
- ifTrue: [ self ==> [ :nodes | aBlock valueWithArguments: nodes ] ]
- ifFalse: [ self error: aBlock numArgs asString , ' arguments expected.' ]
-! !
-
!PPSequenceParser methodsFor:'parsing'!
parseOn: aPPContext
--- a/analyzer/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/analyzer/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\rules
@call find_mingw.bat
--- a/analyzer/tests/Make.proto Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/tests/Make.proto Fri Jul 24 15:06:54 2015 +0100
@@ -103,7 +103,6 @@
prereq:
cd ../../../../libbasic && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../libbasic2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
- cd ../../../../libbasic3 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../libview && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../ && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../libview2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
--- a/analyzer/tests/bc.mak Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/tests/bc.mak Fri Jul 24 15:06:54 2015 +0100
@@ -53,7 +53,6 @@
prereq:
pushd ..\..\..\..\libbasic & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\libbasic2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
- pushd ..\..\..\..\libbasic3 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\libview & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\.. & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\libview2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
--- a/analyzer/tests/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/tests/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/analyzer/tests/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/tests/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\..\rules
@call find_mingw.bat
--- a/analyzer/tests/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/tests/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/analyzer/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/analyzer/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
@echo "***********************************"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/FooScanner.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,210 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCScanner subclass:#FooScanner
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Scanner'
+!
+
+!FooScanner methodsFor:'as yet unclassified'!
+
+nextTokenA
+ "a"
+ self step.
+ self peek == $a ifFalse: [ ^ self return ].
+
+ self recordMatch: #a.
+
+ ^ self return
+!
+
+nextTokenAAorA
+ "aa / a"
+ self step.
+ (self peek == $a) ifFalse: [ ^ self return ].
+ self recordMatch: #a priority: -1.
+
+ self step.
+ (self peek == $a) ifFalse: [ ^ self return ].
+ self recordMatch: #aa priority: 0.
+
+ ^ self return.
+!
+
+nextTokenAAplusA
+ "(aa)+a"
+ self step.
+ self peek == $a ifFalse: [ ^ self return ].
+
+ self step.
+ self peek == $a ifFalse: [ ^ self return. ].
+
+ [
+ self step.
+ self peek == $a ifFalse: [ ^ self returnPriority: 0 ].
+ self recordMatch: #AAplusA priority: -1.
+
+ self step.
+ self peek == $a.
+ ] whileTrue.
+
+ ^ self returnPriority: -1
+!
+
+nextTokenAAstarA
+ "(aa)*a"
+ self step.
+ self peek == $a ifFalse: [ ^ self return ].
+
+ [
+ self recordMatch: #AAstarA priority: -1.
+
+ self step.
+ self peek == $a ifFalse: [ ^ self returnPriority: -1 ].
+ self step.
+
+ self peek == $a
+ ] whileTrue.
+
+ ^ self returnPriority: 0
+!
+
+nextTokenAB
+ "ab"
+ self step.
+ self peek == $a ifFalse: [ ^ self return ].
+
+ self step.
+ self peek == $b ifFalse: [ ^ self return ].
+ self recordMatch: #b.
+
+ ^ self return.
+!
+
+nextTokenABorBC
+ "a"
+ self step.
+ (self peek == $a) ifTrue: [
+
+ self step.
+ self peek == $b ifFalse: [ ^ self return ].
+ self recordMatch: #ab.
+
+ ^ self return
+ ].
+
+ (self peek == $b) ifTrue: [
+ self step.
+ self peek == $c ifFalse: [ ^ self return ].
+ self recordMatch: #bc.
+
+ ^ self return
+ ].
+
+ ^ self return
+!
+
+nextTokenABstarA
+ "(ab)*a"
+ self step.
+ self peek == $a ifFalse: [ ^ self return ].
+
+ [
+ self recordMatch: #ABstarA priority: -1.
+
+ self step.
+ self peek == $b ifFalse: [ ^ self returnPriority: -1 ].
+
+ self step.
+ self peek == $a.
+ ] whileTrue.
+
+ ^ self returnPriority: 0
+!
+
+nextTokenA_Bstar_A
+ "ab"
+ self step.
+ self peek == $a ifFalse: [ ^ self return ].
+
+ [
+ self step.
+ self peek == $b.
+ ] whileTrue.
+
+
+ self peek == $a ifFalse: [ ^ self return ].
+ self recordMatch: #A_Bstar_A.
+
+ ^ self return.
+!
+
+nextTokenAorAA
+ "aa / a"
+ self step.
+ (self peek == $a) ifTrue: [
+ self recordMatch: #a priority: 0.
+ ^ self return
+ ].
+
+ self step.
+ (self peek == $a) ifTrue: [
+ self recordMatch: #aa priority: -1.
+ ^ self return
+ ].
+!
+
+nextTokenAorB
+ "a"
+ self step.
+ (self peek == $a) ifTrue: [
+ self recordMatch: #a.
+ ^ self return
+ ].
+ (self peek == $b) ifTrue: [
+ self recordMatch: #b.
+ ^ self return
+ ].
+
+ ^ self return
+!
+
+nextTokenAstarA
+ "a*a"
+ [
+ self step.
+ self peek == $a.
+ ] whileTrue.
+
+ self peek == $a ifFalse: [ ^ self return ].
+ self recordMatch: #AstarA.
+ ^ self return
+!
+
+nextTokenAstarB
+ "a*b"
+ [
+ self step.
+ self peek == $a.
+ ] whileTrue.
+
+ self peek == $b ifFalse: [ ^ self return ].
+ self recordMatch: #AstarB.
+ ^ self return
+!
+
+nextTokenAuorA
+ "a | a"
+ self step.
+ (self peek == $a) ifTrue: [
+ self recordMatch: #a1.
+ self recordMatch: #a2.
+ ^ self return
+ ].
+
+ ^ self return
+! !
+
--- a/compiler/Make.proto Thu May 21 14:12:22 2015 +0100
+++ b/compiler/Make.proto Fri Jul 24 15:06:54 2015 +0100
@@ -34,7 +34,7 @@
# add the path(es) here:,
# ********** OPTIONAL: MODIFY the next lines ***
# LOCALINCLUDES=-Ifoo -Ibar
-LOCALINCLUDES= -I$(INCLUDE_TOP)/stx/goodies/petitparser -I$(INCLUDE_TOP)/stx/goodies/petitparser/analyzer -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/java -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk -I$(INCLUDE_TOP)/stx/libbasic -I$(INCLUDE_TOP)/stx/libbasic2
+LOCALINCLUDES= -I$(INCLUDE_TOP)/stx/goodies/petitparser -I$(INCLUDE_TOP)/stx/goodies/petitparser/analyzer -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/java -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk -I$(INCLUDE_TOP)/stx/goodies/refactoryBrowser/parser -I$(INCLUDE_TOP)/stx/libbasic -I$(INCLUDE_TOP)/stx/libbasic2 -I$(INCLUDE_TOP)/stx/libview
# if you need any additional defines for embedded C code,
@@ -104,7 +104,6 @@
cd ../../../libbasic && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../refactoryBrowser/parser && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../libbasic2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
- cd ../../../libbasic3 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../libview && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../ && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../libview2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
@@ -131,8 +130,17 @@
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
+$(OUTDIR)PEGFsa.$(O) PEGFsa.$(H): PEGFsa.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaFailure.$(O) PEGFsaFailure.$(H): PEGFsaFailure.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaInterpret.$(O) PEGFsaInterpret.$(H): PEGFsaInterpret.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaPair.$(O) PEGFsaPair.$(H): PEGFsaPair.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaState.$(O) PEGFsaState.$(H): PEGFsaState.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaTransition.$(O) PEGFsaTransition.$(H): PEGFsaTransition.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCArguments.$(O) PPCArguments.$(H): PPCArguments.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCBridge.$(O) PPCBridge.$(H): PPCBridge.st $(INCLUDE_TOP)/stx/goodies/petitparser/PPParser.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCClassBuilder.$(O) PPCClassBuilder.$(H): PPCClassBuilder.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCCodeBlock.$(O) PPCCodeBlock.$(H): PPCCodeBlock.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCCodeGen.$(O) PPCCodeGen.$(H): PPCCodeGen.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompiledMethod.$(O) PPCCompiledMethod.$(H): PPCCompiledMethod.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompiler.$(O) PPCCompiler.$(H): PPCCompiler.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompilerTokenErrorStrategy.$(O) PPCCompilerTokenErrorStrategy.$(H): PPCCompilerTokenErrorStrategy.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
@@ -147,9 +155,14 @@
$(OUTDIR)PPCNode.$(O) PPCNode.$(H): PPCNode.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCNodeVisitor.$(O) PPCNodeVisitor.$(H): PPCNodeVisitor.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCPluggableConfiguration.$(O) PPCPluggableConfiguration.$(H): PPCPluggableConfiguration.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCScanner.$(O) PPCScanner.$(H): PPCScanner.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCScannerCodeGenerator.$(O) PPCScannerCodeGenerator.$(H): PPCScannerCodeGenerator.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenGuard.$(O) PPCTokenGuard.$(H): PPCTokenGuard.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCompiledParser.$(O) PPCompiledParser.$(H): PPCompiledParser.st $(INCLUDE_TOP)/stx/goodies/petitparser/PPParser.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPMappedActionParser.$(O) PPMappedActionParser.$(H): PPMappedActionParser.st $(INCLUDE_TOP)/stx/goodies/petitparser/PPActionParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPDelegateParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPParser.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)stx_goodies_petitparser_compiler.$(O) stx_goodies_petitparser_compiler.$(H): stx_goodies_petitparser_compiler.st $(INCLUDE_TOP)/stx/libbasic/LibraryDefinition.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/ProjectDefinition.$(H) $(STCHDR)
+$(OUTDIR)FooScanner.$(O) FooScanner.$(H): FooScanner.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCScanner.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaGenerator.$(O) PEGFsaGenerator.$(H): PEGFsaGenerator.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNodeVisitor.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCAbstractLiteralNode.$(O) PPCAbstractLiteralNode.$(H): PPCAbstractLiteralNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCAbstractPredicateNode.$(O) PPCAbstractPredicateNode.$(H): PPCAbstractPredicateNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCAnyNode.$(O) PPCAnyNode.$(H): PPCAnyNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
@@ -157,6 +170,7 @@
$(OUTDIR)PPCCodeGenerator.$(O) PPCCodeGenerator.$(H): PPCCodeGenerator.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNodeVisitor.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCDelegateNode.$(O) PPCDelegateNode.$(H): PPCDelegateNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCEndOfFileNode.$(O) PPCEndOfFileNode.$(H): PPCEndOfFileNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCFSACodeGen.$(O) PPCFSACodeGen.$(H): PPCFSACodeGen.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCCodeGen.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCInlinedMethod.$(O) PPCInlinedMethod.$(H): PPCInlinedMethod.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCMethod.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCInliningVisitor.$(O) PPCInliningVisitor.$(H): PPCInliningVisitor.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNodeVisitor.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCListNode.$(O) PPCListNode.$(H): PPCListNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
@@ -216,6 +230,7 @@
$(OUTDIR)PPCTokenChoiceNode.$(O) PPCTokenChoiceNode.$(H): PPCTokenChoiceNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCChoiceNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCListNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCTrimNode.$(O) PPCTrimNode.$(H): PPCTrimNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCListNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCSequenceNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCTrimmingCharacterTokenNode.$(O) PPCTrimmingCharacterTokenNode.$(H): PPCTrimmingCharacterTokenNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCListNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCTrimmingTokenNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCMappedActionNode.$(O) PPCMappedActionNode.$(H): PPCMappedActionNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCAbstractActionNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCActionNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCDelegateNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenStarMessagePredicateNode.$(O) PPCTokenStarMessagePredicateNode.$(H): PPCTokenStarMessagePredicateNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCDelegateNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCStarMessagePredicateNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCStarNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenStarSeparatorNode.$(O) PPCTokenStarSeparatorNode.$(H): PPCTokenStarSeparatorNode.st $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCDelegateNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCStarMessagePredicateNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCStarNode.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/compiler/PPCTokenStarMessagePredicateNode.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)extensions.$(O): extensions.st $(INCLUDE_TOP)/stx/goodies/petitparser/PPActionParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPAndParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPCharSetPredicate.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPChoiceParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPCompositeParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPContext.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPDelegateParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPEndOfInputParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPEpsilonParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPFailure.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPFlattenParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPListParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPLiteralObjectParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPLiteralParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPLiteralSequenceParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPNotParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPOptionalParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPPluggableParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPPossessiveRepeatingParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPPredicateObjectParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPPredicateParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPRepeatingParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPSequenceParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPStream.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPToken.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPTokenParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPTrimmingParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/parsers/java/PPJavaWhitespaceParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk/PPSmalltalkGrammar.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk/PPSmalltalkTokenParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk/PPSmalltalkWhitespaceParser.$(H) $(INCLUDE_TOP)/stx/libbasic/Character.$(H) $(INCLUDE_TOP)/stx/libbasic/Magnitude.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/PeekableStream.$(H) $(INCLUDE_TOP)/stx/libbasic/PositionableStream.$(H) $(INCLUDE_TOP)/stx/libbasic/ReadStream.$(H) $(INCLUDE_TOP)/stx/libbasic/Stream.$(H) $(INCLUDE_TOP)/stx/libbasic/UndefinedObject.$(H) $(STCHDR)
--- a/compiler/Make.spec Thu May 21 14:12:22 2015 +0100
+++ b/compiler/Make.spec Fri Jul 24 15:06:54 2015 +0100
@@ -51,8 +51,17 @@
STCWARNINGS=-warnNonStandard
COMMON_CLASSES= \
+ PEGFsa \
+ PEGFsaFailure \
+ PEGFsaInterpret \
+ PEGFsaPair \
+ PEGFsaState \
+ PEGFsaTransition \
PPCArguments \
PPCBridge \
+ PPCClassBuilder \
+ PPCCodeBlock \
+ PPCCodeGen \
PPCCompiledMethod \
PPCCompiler \
PPCCompilerTokenErrorStrategy \
@@ -67,9 +76,14 @@
PPCNode \
PPCNodeVisitor \
PPCPluggableConfiguration \
+ PPCScanner \
+ PPCScannerCodeGenerator \
PPCTokenGuard \
PPCompiledParser \
+ PPMappedActionParser \
stx_goodies_petitparser_compiler \
+ FooScanner \
+ PEGFsaGenerator \
PPCAbstractLiteralNode \
PPCAbstractPredicateNode \
PPCAnyNode \
@@ -77,6 +91,7 @@
PPCCodeGenerator \
PPCDelegateNode \
PPCEndOfFileNode \
+ PPCFSACodeGen \
PPCInlinedMethod \
PPCInliningVisitor \
PPCListNode \
@@ -136,6 +151,7 @@
PPCTokenChoiceNode \
PPCTrimNode \
PPCTrimmingCharacterTokenNode \
+ PPCMappedActionNode \
PPCTokenStarMessagePredicateNode \
PPCTokenStarSeparatorNode \
@@ -143,8 +159,17 @@
COMMON_OBJS= \
+ $(OUTDIR_SLASH)PEGFsa.$(O) \
+ $(OUTDIR_SLASH)PEGFsaFailure.$(O) \
+ $(OUTDIR_SLASH)PEGFsaInterpret.$(O) \
+ $(OUTDIR_SLASH)PEGFsaPair.$(O) \
+ $(OUTDIR_SLASH)PEGFsaState.$(O) \
+ $(OUTDIR_SLASH)PEGFsaTransition.$(O) \
$(OUTDIR_SLASH)PPCArguments.$(O) \
$(OUTDIR_SLASH)PPCBridge.$(O) \
+ $(OUTDIR_SLASH)PPCClassBuilder.$(O) \
+ $(OUTDIR_SLASH)PPCCodeBlock.$(O) \
+ $(OUTDIR_SLASH)PPCCodeGen.$(O) \
$(OUTDIR_SLASH)PPCCompiledMethod.$(O) \
$(OUTDIR_SLASH)PPCCompiler.$(O) \
$(OUTDIR_SLASH)PPCCompilerTokenErrorStrategy.$(O) \
@@ -159,9 +184,14 @@
$(OUTDIR_SLASH)PPCNode.$(O) \
$(OUTDIR_SLASH)PPCNodeVisitor.$(O) \
$(OUTDIR_SLASH)PPCPluggableConfiguration.$(O) \
+ $(OUTDIR_SLASH)PPCScanner.$(O) \
+ $(OUTDIR_SLASH)PPCScannerCodeGenerator.$(O) \
$(OUTDIR_SLASH)PPCTokenGuard.$(O) \
$(OUTDIR_SLASH)PPCompiledParser.$(O) \
+ $(OUTDIR_SLASH)PPMappedActionParser.$(O) \
$(OUTDIR_SLASH)stx_goodies_petitparser_compiler.$(O) \
+ $(OUTDIR_SLASH)FooScanner.$(O) \
+ $(OUTDIR_SLASH)PEGFsaGenerator.$(O) \
$(OUTDIR_SLASH)PPCAbstractLiteralNode.$(O) \
$(OUTDIR_SLASH)PPCAbstractPredicateNode.$(O) \
$(OUTDIR_SLASH)PPCAnyNode.$(O) \
@@ -169,6 +199,7 @@
$(OUTDIR_SLASH)PPCCodeGenerator.$(O) \
$(OUTDIR_SLASH)PPCDelegateNode.$(O) \
$(OUTDIR_SLASH)PPCEndOfFileNode.$(O) \
+ $(OUTDIR_SLASH)PPCFSACodeGen.$(O) \
$(OUTDIR_SLASH)PPCInlinedMethod.$(O) \
$(OUTDIR_SLASH)PPCInliningVisitor.$(O) \
$(OUTDIR_SLASH)PPCListNode.$(O) \
@@ -228,6 +259,7 @@
$(OUTDIR_SLASH)PPCTokenChoiceNode.$(O) \
$(OUTDIR_SLASH)PPCTrimNode.$(O) \
$(OUTDIR_SLASH)PPCTrimmingCharacterTokenNode.$(O) \
+ $(OUTDIR_SLASH)PPCMappedActionNode.$(O) \
$(OUTDIR_SLASH)PPCTokenStarMessagePredicateNode.$(O) \
$(OUTDIR_SLASH)PPCTokenStarSeparatorNode.$(O) \
$(OUTDIR_SLASH)extensions.$(O) \
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsa.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,714 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PEGFsa
+ instanceVariableNames:'states startState name distances priorities'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
+!PEGFsa methodsFor:'accessing'!
+
+allTransitions
+ ^ self allTransitions: IdentitySet new
+!
+
+allTransitions: collection
+ self states do: [ :s | collection addAll: s transitions ].
+ ^ collection
+!
+
+forwardTransitions
+ | backTransitions |
+ backTransitions := self backTransitions.
+ ^ self allTransitions reject: [ :t | backTransitions includes: t ]
+!
+
+minPriority
+ "this is the worst estimate"
+ ^ (self states size) negated
+!
+
+name
+ ^ name
+!
+
+name: anObject
+
+ name := anObject
+!
+
+prefix
+ ^ 'fsa_'
+!
+
+startState
+ ^ startState
+!
+
+stateNamed: name
+ ^ states detect: [ :e | e name = name ]
+!
+
+states
+ ^ states
+!
+
+suffix
+ ^ ''
+!
+
+transitionFrom: from to: to
+ ^ from transitions detect: [ :t | t destination = to ]
+!
+
+transitionsFor: state
+ self assert: (states includes: state).
+ ^ state transitions
+! !
+
+!PEGFsa methodsFor:'analysis'!
+
+backTransitions
+ | transitionSet |
+ transitionSet := IdentitySet new.
+ self computeDistances.
+
+ self backTransitionsFrom: startState openSet: IdentitySet new transitionSet: transitionSet.
+ ^ transitionSet
+!
+
+backTransitionsFrom: state openSet: openSet transitionSet: transitionSet
+ (openSet includes: state) ifTrue: [
+ ^ self
+ ].
+ openSet add: state.
+
+ state transitions do: [ :t |
+ ((openSet includes: t destination) and: [self is: state furtherThan: t destination]) ifTrue: [
+ transitionSet add: t
+ ].
+ self backTransitionsFrom: t destination openSet: openSet copy transitionSet: transitionSet
+ ]
+!
+
+computeDistances
+ | queue openSet |
+ distances := IdentityDictionary new.
+ queue := OrderedCollection with: startState.
+ openSet := IdentitySet new.
+
+ distances at: startState put: 0.
+
+ [ queue isEmpty not ] whileTrue: [
+ | state |
+ state := queue removeFirst.
+ openSet add: state.
+
+ state transitions do: [ :t |
+ (openSet includes: (t destination)) ifFalse: [
+ distances at: (t destination ) put: ((distances at: state) + 1).
+ queue addLast: (t destination)
+ ]
+ ]
+ ].
+
+ ^ distances
+!
+
+computePriorities
+ | queue openSet |
+ self flag: 'not working...'.
+ priorities := IdentityDictionary new.
+ queue := OrderedCollection with: startState.
+ openSet := IdentitySet new.
+
+ priorities at: startState put: (startState priorityIfNone: 0).
+
+ [ queue isEmpty not ] whileTrue: [
+ | state |
+ state := queue removeFirst.
+ openSet add: state.
+
+ state transitions do: [ :t |
+ (openSet includes: (t destination)) ifFalse: [
+ priorities at: (t destination ) put: ((priorities at: state) + t priority).
+ queue addLast: (t destination)
+ ]
+ ]
+ ].
+
+ ^ priorities
+!
+
+epsilonDestinationsFrom: state
+ | openSet |
+ openSet := IdentitySet new.
+ self epsilonDestinationsFrom: state openSet: openSet.
+ ^ openSet
+!
+
+epsilonDestinationsFrom: state openSet: openSet.
+ (openSet includes: state) ifTrue: [
+ ^ self
+ ].
+
+ openSet add: state.
+
+ ((self transitionsFor: state) select: [ :t | t isEpsilon ]) do: [ :t |
+ self epsilonDestinationsFrom: t destination openSet: openSet
+ ]
+
+!
+
+finalStates
+ ^ self reachableStates select: [ :s | s isFinal ]
+!
+
+is: state furtherThan: anotherState
+
+ ^ (distances at: state) >= (distances at: anotherState)
+!
+
+isBackTransition: t
+ ^ self backTransitions includes: t
+!
+
+joinPoints
+ ^ self joinTransitions collect: [ :t | t destination ]
+!
+
+joinTransitions
+ | joinTransitions transitions size |
+ joinTransitions := IdentitySet new.
+
+ transitions := self allTransitions asOrderedCollection.
+ size := transitions size.
+
+
+ (1 to: size - 1) do: [ :index1 |
+ (index1 + 1 to: size) do: [ :index2 |
+ ((transitions at: index1) destination == (transitions at: index2) destination) ifTrue: [
+ joinTransitions add: (transitions at: index1).
+ joinTransitions add: (transitions at: index2).
+ ]
+ ]
+ ].
+
+ ^ joinTransitions
+!
+
+minimumPriority
+!
+
+nonFinalStates
+ ^ self states reject: [ :s | s isFinal ]
+!
+
+reachableStates
+ ^ self statesReachableFrom: startState
+!
+
+statePairs
+ | pairs ordered |
+ pairs := OrderedCollection new.
+ ordered := self topologicalOrder.
+ 1 to: (ordered size - 1) do: [ :index1 |
+ (index1 + 1) to: ordered size do: [ :index2 |
+ pairs add: (PEGFsaPair with: (ordered at: index1) with: (ordered at: index2))
+ ]
+ ].
+
+ self assert: (pairs allSatisfy: [ :e | e class == PEGFsaPair ]).
+ ^ pairs
+!
+
+statesReachableFrom: state
+ | openSet |
+ self assert: state isNil not.
+
+ openSet := IdentitySet new.
+ self statesReachableFrom: state openSet: openSet.
+ ^ openSet
+!
+
+statesReachableFrom: state openSet: openSet
+ (openSet contains: [:e | e == state]) ifTrue: [
+ ^ self
+ ].
+
+ openSet add: state.
+
+ (self transitionsFor: state) do: [ :t |
+ self statesReachableFrom: t destination openSet: openSet
+ ]
+
+!
+
+topologicalOrder
+ | collection |
+ collection := OrderedCollection new.
+ self statesReachableFrom: startState openSet: collection.
+ ^ collection
+! !
+
+!PEGFsa methodsFor:'comparing'!
+
+= anotherFsa
+ "
+ Please note what the compare does. IMO nothing useful for no.
+
+ For comparing if two FSA's are equivalent, use isIsomorphicTo:
+ "
+
+ (self == anotherFsa) ifTrue: [ ^ true ].
+ (self class == anotherFsa class) ifFalse: [ ^ false ].
+
+ (startState = anotherFsa startState) ifFalse: [ ^ false ].
+ (name = anotherFsa name) ifFalse: [ ^ false ].
+
+ (states size = anotherFsa states size) ifFalse: [ ^ false ].
+ states do: [:s |
+ (anotherFsa states contains: [ :e | e = s ]) ifFalse: [ ^ false ].
+ ].
+ ^ true
+!
+
+hash
+ ^ states hash bitXor: (startState bitXor: name)
+!
+
+isIsomorphicTo: anotherFsa
+ | topologicalOrder anotherTopologicalOrder |
+
+ "
+ Please not that this version of comparison is sensitive to the order
+ in which the transitions in state are ordered.
+ "
+
+ topologicalOrder := self topologicalOrder.
+ anotherTopologicalOrder := anotherFsa topologicalOrder.
+
+ topologicalOrder size == anotherTopologicalOrder size ifFalse: [ ^ false ].
+
+ topologicalOrder with: anotherTopologicalOrder do: [ :s1 :s2 |
+ (s1 canBeIsomorphicTo: s2) ifFalse: [ ^ false ]
+ ].
+
+ ^ true
+"
+ transitions := topologicalOrder flatCollect: [ :s | s transitions ].
+ anotherTransitions := anotherTopologicalOrder flatCollect: [ :s | s transitions ].
+"
+! !
+
+!PEGFsa methodsFor:'copying'!
+
+postCopy
+ | map |
+ super postCopy.
+
+ map := IdentityDictionary new.
+ states do: [ :s |
+ map at: s put: s copy.
+ ].
+
+ states := map values asIdentitySet.
+ startState := map at: startState.
+
+ states do: [ :s |
+ s transitions do: [:t |
+ t destination: (map at: t destination)
+ ]
+ ]
+! !
+
+!PEGFsa methodsFor:'gt'!
+
+gtGraphViewIn: composite
+ <gtInspectorPresentationOrder: 41>
+ composite roassal2
+ title: 'Graph';
+ initializeView: [ RTMondrian new ];
+ painting: [ :view |
+ self viewGraphOn: view.
+ ].
+!
+
+gtStringViewIn: composite
+ <gtInspectorPresentationOrder: 40>
+
+ composite text
+ title: 'Textual Representation';
+ display: [ :fsa | fsa asString ]
+!
+
+viewGraphOn: b
+ b shape circle size: 50.
+ b shape color: Color gray muchLighter muchLighter.
+ b shape withText: #gtName.
+ b nodes: (self nonFinalStates).
+
+ b shape circle size: 50.
+ b shape color: Color gray muchLighter.
+ b shape withText: #gtName.
+ b nodes: (self finalStates).
+
+ b shape arrowedLine.
+ b edges
+ connectToAll: [ :state |
+ state transitions select: [:t | (self isBackTransition:t) not]
+ thenCollect: #destination ]
+ labelled: [ :t | (self transitionFrom: t key to: t value) gtName ].
+
+ b shape arrowedLine.
+ b shape color: Color red.
+ b edges
+ connectToAll: [ :state |
+ state transitions select: [:t | (self isBackTransition: t) ]
+ thenCollect: #destination ]
+ labelled: [ :t | (self transitionFrom: t key to: t value) gtName ].
+
+
+ b layout horizontalTree .
+ b layout layout horizontalGap: 30.
+
+ ^ b
+! !
+
+!PEGFsa methodsFor:'initialization'!
+
+initialize
+ states := IdentitySet new.
+! !
+
+!PEGFsa methodsFor:'modifications'!
+
+addState: state
+ self assert: (states includes: state) not.
+ states add: state
+!
+
+addTransitionFrom: fromState to: toState
+ ^ self addTransitionFrom: fromState to: toState priority: 0
+!
+
+addTransitionFrom: fromState to: toState on: character
+ self addTransitionFrom: fromState to: toState on: character priority: 0
+!
+
+addTransitionFrom: fromState to: toState on: character priority: priority
+ | transition |
+ transition := PEGFsaTransition new
+ addCharacter: character;
+ destination: toState;
+ priority: priority;
+ yourself.
+
+ fromState addTransition: transition
+!
+
+addTransitionFrom: fromState to: toState onCharacterSet: characterSet
+ self addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: 0
+!
+
+addTransitionFrom: fromState to: toState onCharacterSet: characterSet priority: priority
+ | transition |
+ transition := PEGFsaTransition new
+ characterSet: characterSet;
+ destination: toState;
+ priority: priority;
+ yourself.
+
+ fromState addTransition: transition
+!
+
+addTransitionFrom: fromState to: toState priority: priority
+ | transition |
+ self assert: (states includes: fromState).
+ self assert: (states includes: toState).
+
+ transition := PEGFsaTransition new
+ destination: toState;
+ priority: priority;
+ yourself.
+
+ fromState addTransition: transition.
+!
+
+adopt: fsa
+ states addAll: fsa reachableStates.
+!
+
+finalState: state
+ self assert: state isFinal not.
+ state final: true.
+!
+
+fixFinalStatePriorities
+ self finalStates do: [ :s |
+ s hasPriority ifFalse: [ s priority: 0 ]
+ ]
+!
+
+removeState: state
+ self assert: (states includes: state).
+ states remove: state.
+!
+
+replace: state with: anotherState
+ | transitions |
+ self assert: (state class == PEGFsaState).
+ self assert: (anotherState class == PEGFsaState).
+
+ transitions := self allTransitions.
+
+ transitions do: [ :t |
+ (t destination == state) ifTrue: [
+ t destination: anotherState.
+ ]
+ ].
+ states := startState reachableStates.
+!
+
+startState: state
+ self assert: (states includes: state).
+
+ startState := state
+! !
+
+!PEGFsa methodsFor:'printing'!
+
+asString
+ | stream |
+ stream := WriteStream on: ''.
+
+ self topologicalOrder do: [ :state |
+ state printOn: stream.
+ stream nextPutAll: '> '.
+
+ (self transitionsFor: state) do: [ :transition |
+ stream nextPut: (Character codePoint: 13).
+ stream nextPut: (Character codePoint: 9).
+ transition printOn: stream.
+ ].
+ stream nextPut: (Character codePoint: 13).
+ ].
+
+" stream nextPutAll: 'finals: '.
+ (states select: [:s | s isFinal ]) do: [:e | e printOn: stream ].
+ stream nextPut: (Character codePoint: 13).
+"
+ ^ stream contents.
+! !
+
+!PEGFsa methodsFor:'testing'!
+
+canHavePPCId
+ ^ true
+!
+
+checkConsistency
+ self assert: (states includes: startState).
+ states do: [ :s | s transitions do: [ :t |
+ self assert: (states includes: t destination).
+ ] ].
+ ^ true
+!
+
+checkFinalStatesPriorities
+ self assert: (self finalStates allSatisfy: #hasPriority)
+!
+
+checkSanity
+ self checkConsistency.
+ self checkTransitionsIdentity.
+ self checkFinalStatesPriorities.
+!
+
+checkTransitionsIdentity
+ | bag set |
+ bag := IdentityBag new.
+ set := IdentitySet new.
+ bag := self allTransitions: bag.
+ set := self allTransitions: set.
+
+ self assert: bag size == set size.
+!
+
+isDeterministic
+ self reachableStates do: [ :state |
+ state transitionPairs do: [ :pair |
+ ((pair first intersection: pair second) includes: true) ifTrue: [
+ ^ false
+ ]
+ ]
+ ].
+ ^ true
+!
+
+isReachableState: state
+ ^ self reachableStates includes: state
+!
+
+isStartState: state
+ ^ startState == state
+!
+
+isWithoutEpsilons
+ self reachableStates do: [ :state |
+ state transitions do: [ :t |
+ t isEpsilon ifTrue: [ ^ false ]
+ ]
+ ].
+ ^ true
+! !
+
+!PEGFsa methodsFor:'transformations'!
+
+compact
+ self fixFinalStatePriorities.
+ self determinize.
+ self minimize.
+
+ self checkSanity.
+!
+
+determinize
+ | joinDictionary |
+ self removeEpsilons.
+
+ self removeUnreachableStates.
+ self removeLowPriorityTransitions.
+ self mergeTransitions.
+
+ joinDictionary := Dictionary new.
+ self topologicalOrder do: [:state | state determinize: joinDictionary ].
+
+ states := startState reachableStates.
+
+ self removeUnreachableStates.
+ self removeLowPriorityTransitions.
+ self mergeTransitions.
+
+!
+
+mergeTransitions
+ | toRemove |
+ self reachableStates do: [ :state |
+ toRemove := OrderedCollection new.
+ state transitionPairs do:[ :pair |
+ (pair first destination = pair second destination) ifTrue: [
+ pair first mergeWith: pair second.
+ toRemove add: pair second.
+ ]
+ ].
+ toRemove do: [ :t |
+ state removeTransition: t
+ ]
+ ]
+!
+
+minimize
+ | pair |
+ pair := self statePairs detect: [ :p | p first equals: p second ] ifNone: [ nil ].
+ [ pair isNil not ] whileTrue: [
+ "Join priorities, because equivalency of priorities does not imply from the equeality of states"
+ pair first joinPriority: pair second newState: pair first.
+ pair first joinName: pair second newState: pair first.
+ self replace: pair second with: pair first.
+ self mergeTransitions.
+ pair := self statePairs detect: [ :p | p first equals: p second ] ifNone: [ nil ].
+ ].
+!
+
+removeEpsilonTransition: transition source: state
+ ^ self removeEpsilonTransition: transition source: state openSet: IdentitySet new
+!
+
+removeEpsilonTransition: transition source: source openSet: openSet
+ | destination |
+ (openSet includes: transition) ifTrue: [ self error: 'loop in epsilons?!!' ].
+ openSet add: transition.
+
+ destination := transition destination.
+
+ "First Remove Recursively"
+ ((self transitionsFor: destination ) select: [ :t | t isEpsilon ]) do: [ :t |
+ self removeEpsilonTransition: t source: destination openSet: openSet
+ ].
+
+ (transition priority abs) timesRepeat: [
+ (self statesReachableFrom: destination) do: [ :s |
+ s decreasePriority.
+ s transitions do: [ :t | t decreasePriority ]
+ ]
+ ].
+
+ (destination transitions) do: [ :t |
+ source addTransition: (t copy)
+ ].
+
+ destination hasPriority ifTrue: [
+ source hasPriority ifTrue: [
+ "self assert: source priority == destination priority"
+ self flag: 'I am not 100% sure about this case'
+ ].
+ source priority: destination priority
+ ].
+
+ destination isFinal ifTrue: [
+ source final: true.
+ source retval: destination retval.
+ ].
+
+ source removeTransition: transition.
+!
+
+removeEpsilons
+ states do: [ :state |
+ self removeEpsilonsFor: state
+ ]
+!
+
+removeEpsilonsFor: state
+ (self transitionsFor: state) copy do: [ :t |
+ t isEpsilon ifTrue: [
+ self removeEpsilonTransition: t source: state
+ ]
+ ]
+!
+
+removeLowPriorityTransitions
+ states do: [ :state |
+ self removeLowPriorityTransitionsFor: state
+ ]
+!
+
+removeLowPriorityTransitionsFor: state
+ state hasPriority ifFalse: [ ^ self ].
+ state isFinal ifFalse: [ ^ self ].
+
+ state transitions do: [ :t |
+ (t priority < state priority) ifTrue: [
+ state removeTransition: t
+ ]
+ ]
+!
+
+removeUnreachableStates
+ | reachable toRemove |
+ reachable := self reachableStates.
+ toRemove := OrderedCollection new.
+
+ states do: [ :s |
+ (reachable includes: s) ifFalse: [
+ toRemove add: s
+ ]
+ ].
+
+ toRemove do: [ :s | states remove: s ]
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsaFailure.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,11 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PEGFsaFailure
+ instanceVariableNames:'message'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsaGenerator.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,229 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCNodeVisitor subclass:#PEGFsaGenerator
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
+!PEGFsaGenerator methodsFor:'as yet unclassified'!
+
+visitCharSetPredicateNode: node
+ | stop start fsa |
+ start := PEGFsaState new.
+ stop := PEGFsaState new.
+
+ fsa := PEGFsa new
+ addState: start;
+ addState: stop;
+
+ startState: start;
+ finalState: stop;
+ yourself.
+
+ fsa addTransitionFrom: start to: stop onCharacterSet: (node predicate classification).
+
+ ^ fsa
+!
+
+visitCharacterNode: node
+ | stop start |
+ start := PEGFsaState new.
+ stop := PEGFsaState new.
+ stop name: node character storeString.
+
+ ^ PEGFsa new
+ addState: start;
+ addState: stop;
+
+ startState: start;
+ finalState: stop;
+
+ addTransitionFrom: start to: stop on: node character;
+ yourself
+!
+
+visitChoiceNode: node
+ | priority childrenFsa fsa start |
+
+ childrenFsa := node children collect: [ :child | child accept: self ].
+ fsa := PEGFsa new.
+ start := PEGFsaState new.
+
+ fsa addState: start.
+ fsa startState: start.
+
+ priority := 0.
+ childrenFsa do: [ :childFsa |
+ fsa adopt: childFsa.
+ fsa addTransitionFrom: start to: childFsa startState priority: priority.
+ priority := priority + childFsa minPriority.
+ ].
+
+ ^ fsa
+!
+
+visitLiteralNode: node
+ | states fsa |
+
+ states := OrderedCollection new.
+ (node literal size + 1) timesRepeat: [
+ states add: PEGFsaState new
+ ].
+
+ fsa := PEGFsa new.
+ states do: [ :state | fsa addState: state ].
+ fsa startState: states first;
+ finalState: states last;
+ yourself.
+
+ (1 to: (states size - 1)) do: [ :index |
+ fsa addTransitionFrom: (states at: index)
+ to: (states at: index + 1)
+ on: (node literal at: index).
+ "set the name"
+ (states at: (index + 1)) name: (node literal at: index).
+ ].
+
+ fsa name: node literal.
+ ^ fsa
+!
+
+visitNode: node
+ self error: 'node not supported'
+!
+
+visitNotNode: node
+ | fsa finalState |
+ fsa := node child accept: self.
+ finalState := PEGFsaState new
+ name: '!!', fsa name asString;
+ yourself.
+
+ fsa finalStates do: [ :fs |
+ fs retval: PEGFsaFailure new.
+ ].
+
+ fsa addState: finalState.
+ fsa finalState: finalState.
+
+ fsa addTransitionFrom: fsa startState to: finalState priority: -1.
+ ^ fsa
+!
+
+visitOptionalNode: node
+ | fsa startState finalState |
+
+ fsa := node child accept: self.
+ startState := PEGFsaState new
+ yourself.
+
+ finalState := PEGFsaState new
+ final: true;
+ yourself.
+
+ fsa addState: startState.
+ fsa addState: finalState.
+
+ fsa addTransitionFrom: startState to: fsa startState priority: 0.
+ fsa addTransitionFrom: startState to: finalState priority: fsa minPriority.
+
+ fsa startState: startState.
+
+ ^ fsa
+!
+
+visitPlusNode: node
+ | fsa finalState |
+
+ finalState := PEGFsaState new.
+ fsa := node child accept: self.
+ fsa addState: finalState.
+
+ fsa finalStates do: [ :state |
+ fsa addTransitionFrom: state to: (fsa startState).
+ fsa addTransitionFrom: state to: finalState priority: -1.
+ self assert: (state hasPriority not).
+ state priority: 0.
+ state final: false.
+ ].
+
+ fsa finalState: finalState.
+
+ ^ fsa
+!
+
+visitPredicateNode: node
+ | stop start fsa |
+ start := PEGFsaState new.
+ stop := PEGFsaState new.
+
+ fsa := PEGFsa new
+ addState: start;
+ addState: stop;
+
+ startState: start;
+ finalState: stop;
+ yourself.
+
+ fsa addTransitionFrom: start to: stop onCharacterSet: (node predicate classification).
+
+ ^ fsa
+!
+
+visitSequenceNode: node
+ | childrenFsa fsa start previousFinalStates |
+
+ childrenFsa := node children collect: [ :child | child accept: self ].
+
+ fsa := PEGFsa new.
+ start := PEGFsaState new name: 'start'; yourself.
+ fsa addState: start.
+ fsa startState: start.
+
+ fsa adopt: childrenFsa first.
+ fsa addTransitionFrom: start to: childrenFsa first startState.
+
+ previousFinalStates := childrenFsa first finalStates.
+ childrenFsa allButFirst do: [ :childFsa |
+ | newFinalStates |
+ newFinalStates := IdentitySet new.
+ previousFinalStates do: [ :state |
+ | copy |
+ copy := childFsa copy.
+ fsa adopt: copy.
+
+ state isFailure ifFalse: [
+ state final: false.
+ fsa addTransitionFrom: state to: copy startState.
+ ].
+ newFinalStates addAll: copy finalStates.
+ ].
+ previousFinalStates := newFinalStates.
+ ].
+ ^ fsa
+!
+
+visitStarNode: node
+ | fsa finalState |
+
+ finalState := PEGFsaState new.
+ fsa := node child accept: self.
+ fsa addState: finalState.
+
+ fsa finalStates do: [ :state |
+ fsa addTransitionFrom: state to: (fsa startState).
+ self assert: (state hasPriority not).
+ state priority: 0.
+ state final: false.
+ ].
+
+ fsa addTransitionFrom: fsa startState to: finalState priority: -1.
+ fsa finalState: finalState.
+
+ ^ fsa
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsaInterpret.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,180 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PEGFsaInterpret
+ instanceVariableNames:'fsa debug retvals stream maxPriority'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
+!PEGFsaInterpret methodsFor:'accessing'!
+
+debug
+ ^ debug
+!
+
+debug: anObject
+ debug := anObject
+!
+
+fsa
+ ^ fsa
+! !
+
+!PEGFsaInterpret methodsFor:'debugging'!
+
+reportFsa: anFsa
+ debug ifTrue: [
+ Transcript show: anFsa asString; cr.
+ ]
+!
+
+reportStart
+ debug ifTrue: [
+ Transcript show: '============================'; cr.
+ ]
+!
+
+reportStates: states
+ debug ifTrue: [
+ Transcript show: 'states: '; show: states asString; cr
+ ]
+! !
+
+!PEGFsaInterpret methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ debug := true
+! !
+
+!PEGFsaInterpret methodsFor:'running'!
+
+interpret
+ | states newStates character run |
+ maxPriority := SmallInteger minVal.
+ newStates := IdentitySet with: fsa startState.
+ retvals := IdentityDictionary new.
+
+ self recordNewState: fsa startState position: 0.
+
+ self reportStart.
+ self reportFsa: fsa.
+
+ run := stream atEnd not.
+
+ [run] whileTrue: [
+ states := newStates.
+ newStates := IdentitySet new.
+ character := stream peek.
+
+ self reportStates: states.
+
+ states do: [ :state |
+ self expand: state on: character into: newStates.
+ ].
+
+ newStates isEmpty ifFalse: [ stream next ].
+ run := stream atEnd not and: [ newStates isEmpty not ].
+ ].
+
+ ^ self return: newStates
+!
+
+interpret: anFsa on: aStream
+ fsa := anFsa.
+ stream := aStream.
+
+ ^ self interpret
+! !
+
+!PEGFsaInterpret methodsFor:'running support'!
+
+allowsTransition: t from: state transitionsTaken: transitionsTaken
+" (state hasPriority) ifTrue: [
+ ^ state priority <= t priority
+ ].
+"
+ "state hasPriority ifTrue: [ "
+" transitionsTaken isEmpty ifTrue: [ ^ true ].
+ ^ transitionsTaken anyOne priority <= t priority.
+" "]."
+ ^ true
+!
+
+expand: state on: character into: newStates "transitionsTaken: transitionsTaken"
+ | transitions transitionsTaken |
+
+ transitionsTaken := OrderedCollection new.
+ transitions := self sortedTransitionsFor: state.
+ transitions do: [ :t |
+ (self allowsTransition: t from: state transitionsTaken: transitionsTaken) ifTrue: [
+ t isEpsilon ifTrue: [
+ (t destination isFinal) ifTrue: [
+ newStates add: t destination.
+ self recordNewState: t destination position: stream position.
+ ].
+
+ "Descent into the next state"
+ self expand: t destination
+ on: character
+ into: newStates.
+
+ newStates isEmpty ifFalse: [
+ transitionsTaken add: t.
+ ].
+
+ ] ifFalse: [
+ (t accepts: character) ifTrue: [
+ transitionsTaken add: t.
+ newStates add: t destination.
+ self recordNewState: t destination.
+ ]
+ ]
+ ]
+ ]
+!
+
+recordNewState: state
+ ^ self recordNewState: state position: stream position + 1
+!
+
+recordNewState: state position: position
+ (state isFinal) ifFalse: [ ^ self ].
+ (maxPriority > state priority) ifTrue: [ ^ true ].
+
+ self assert: state hasPriority description: 'final state must have priority'.
+ (maxPriority < state priority) ifTrue: [
+ retvals := IdentityDictionary new.
+ maxPriority := state priority.
+ ].
+
+
+ state retvalAsCollection do: [ :r |
+ retvals at: r put: position
+ ].
+!
+
+return: states
+ | priority priorities |
+ priorities := (states select: #hasPriority thenCollect: #priority).
+ priorities isEmpty ifTrue: [
+ ^ retvals keysAndValuesRemove: [ :key :value | key class == PEGFsaFailure ]
+ ].
+
+ priority := priorities max.
+
+ (maxPriority < priority) ifTrue: [ ^ IdentityDictionary new ].
+ ^ retvals keysAndValuesRemove: [ :key :value | key class == PEGFsaFailure ]
+!
+
+sortedTransitionsFor: state
+ ^ (fsa transitionsFor: state) asOrderedCollection
+ "Dear future me, enjoy this:"
+" sort: [ :e1 :e2 | (e1 isEpsilon not and: [e2 isEpsilon]) not ])"
+ sort: [ :e1 :e2 | e1 priority > e2 priority ]
+
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsaPair.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,54 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PEGFsaPair
+ instanceVariableNames:'first second'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
+!PEGFsaPair class methodsFor:'instance creation'!
+
+with: a with: b
+ ^ PEGFsaPair new
+ first: a;
+ second: b;
+ yourself
+! !
+
+!PEGFsaPair methodsFor:'accessing'!
+
+first
+ ^ first
+!
+
+first: anObject
+ first := anObject
+!
+
+second
+ ^ second
+!
+
+second: anObject
+ second := anObject
+! !
+
+!PEGFsaPair methodsFor:'comparing'!
+
+= anObject
+ (anObject == self) ifTrue: [ ^ true ].
+ (anObject class == self class) ifFalse: [ ^ false ].
+
+ ((anObject first == first) and: [anObject second == second]) ifTrue: [ ^ true ].
+ ((anObject first == second) and: [anObject second == first]) ifTrue: [ ^ true ].
+
+ ^ false
+!
+
+hash
+ ^ first hash bitXor: second hash
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsaState.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,455 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PEGFsaState
+ instanceVariableNames:'name retval priority transitions final multivalue'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
+!PEGFsaState methodsFor:'accessing'!
+
+destination
+ self assert: transitions size = 1.
+ ^ transitions anyOne destination
+!
+
+destinations
+ ^ (transitions collect: #destination) asIdentitySet
+!
+
+final
+ ^ final
+!
+
+final: anObject
+ final := anObject
+!
+
+multivalue
+ ^ multivalue
+!
+
+multivalue: anObject
+ multivalue := anObject
+!
+
+name
+ ^ name
+!
+
+name: anObject
+ name := anObject asString
+!
+
+prefix
+ ^ 'state'
+!
+
+priority
+ ^ priority
+!
+
+priority: anObject
+ priority := anObject
+!
+
+priorityIfNone: value
+ ^ self hasPriority ifTrue: [ self priority ] ifFalse: [ value ]
+!
+
+retval
+ ^ retval
+!
+
+retval: anObject
+ retval := anObject
+!
+
+retvalAsCollection
+ ^ self isMultivalue ifTrue: [
+ self retval
+ ] ifFalse: [
+ Array with: self retval
+ ]
+!
+
+suffix
+ ^ ''
+!
+
+transitions
+ ^ transitions
+! !
+
+!PEGFsaState methodsFor:'analysis'!
+
+reachableStates
+ | openSet |
+ openSet := IdentitySet new.
+ self reachableStatesOpenSet: openSet.
+ ^ openSet
+!
+
+reachableStatesOpenSet: openSet
+ (openSet includes: self) ifTrue: [
+ ^ self
+ ].
+
+ openSet add: self.
+
+ (self transitions) do: [ :t |
+ t destination reachableStatesOpenSet: openSet
+ ].
+
+!
+
+transitionPairs
+ | size pairs collection |
+ size := transitions size.
+ pairs := OrderedCollection new: (size - 1) * size / 2.
+
+ collection := transitions asOrderedCollection.
+
+ 1 to: (size - 1) do: [ :index1 |
+ (index1 + 1 to: size) do: [ :index2 |
+ pairs add: (PEGFsaPair new
+ first: (collection at: index1);
+ second: (collection at: index2);
+ yourself).
+ ]
+ ].
+ ^ pairs
+! !
+
+!PEGFsaState methodsFor:'comparing'!
+
+= anotherState
+ (self == anotherState) ifTrue: [ ^ true ].
+ (self class == anotherState class) ifFalse: [ ^ true ].
+
+ (name == anotherState name) ifFalse: [ ^ false ].
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ (multivalue == anotherState multivalue) ifFalse: [ ^ false ].
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+ (final = anotherState final) ifFalse: [ ^ false ].
+
+ (transitions size = anotherState transitions size) ifFalse: [ ^ false ].
+ transitions do: [:t |
+ (anotherState transitions contains: [:at | at = t]) ifFalse: [ ^ false ].
+ ].
+
+ ^ true
+!
+
+canBeIsomorphicTo: anotherState
+ (name == anotherState name) ifFalse: [ ^ false ].
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ (multivalue == anotherState multivalue) ifFalse: [ ^ false ].
+ (final == anotherState final) ifFalse: [ ^ false ].
+ (transitions size == anotherState transitions size) ifFalse: [ ^ false ].
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+
+ ^ true
+!
+
+equals: anotherState
+ (self == anotherState) ifTrue: [ ^ true ].
+ (anotherState class == PEGFsaState) ifFalse: [ ^ false ].
+
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+ (multivalue = anotherState multivalue) ifFalse: [ ^ false ].
+ (self isFinal = anotherState isFinal) ifFalse: [ ^ false ].
+
+ (self hasPriority and: [anotherState hasPriority]) ifTrue: [
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ ].
+
+ (transitions size == anotherState transitions size) ifFalse: [ ^ false ].
+ anotherState transitions do: [ :t |
+ (transitions contains: [ :e | e equals: t]) ifFalse: [ ^ false ]
+ ].
+
+ ^ true
+!
+
+hash
+ ^ retval hash bitXor: (
+ priority hash bitXor: (
+ multivalue hash bitXor:
+ "JK: Size is not the best option here, but it one gets infinite loops otherwise"
+ transitions size hash)).
+!
+
+isIsomorphicTo: anotherState resolvedSet: set
+ (self == anotherState) ifTrue: [ ^ true ].
+
+ (name == anotherState name) ifFalse: [ ^ false ].
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ (multivalue == anotherState multivalue) ifFalse: [ ^ false ].
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+ (final = anotherState final) ifFalse: [ ^ false ].
+
+ (transitions size = anotherState transitions size) ifFalse: [ ^ false ].
+ transitions do: [:t |
+ (anotherState transitions contains: [:at | t isIsomorphicto: at]) ifFalse: [ ^ false ].
+ ].
+
+ ^ true
+! !
+
+!PEGFsaState methodsFor:'copying'!
+
+postCopy
+ super postCopy.
+ transitions := (transitions collect: [ :t | t copy ]).
+ retval := retval copy.
+! !
+
+!PEGFsaState methodsFor:'gt'!
+
+gtName
+ | gtName |
+ gtName := name.
+
+ self hasPriority ifTrue: [
+ gtName := gtName asString, ',', self priority asString.
+ ].
+
+ ^ gtName
+! !
+
+!PEGFsaState methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ transitions := OrderedCollection new.
+ multivalue := false.
+! !
+
+!PEGFsaState methodsFor:'modifications'!
+
+addTransition: t
+ self assert: (transitions identityIncludes: t) not.
+ transitions add: t
+!
+
+decreasePriority
+ (self isFinal and: [ self hasPriority not ]) ifTrue: [
+ priority := 0.
+ ].
+ priority isNil ifFalse: [
+ priority := priority - 1
+ ]
+!
+
+removeTransition: t
+ self assert: (transitions includes: t).
+ transitions remove: t
+! !
+
+!PEGFsaState methodsFor:'printing'!
+
+printNameOn: aStream
+ self name isNil
+ ifTrue: [ aStream print: self hash ]
+ ifFalse: [ aStream nextPutAll: self name ]
+!
+
+printOn: aStream
+ super printOn: aStream.
+ aStream nextPut: $(.
+ self printNameOn: aStream.
+ aStream nextPut: Character space.
+ aStream nextPutAll: self identityHash asString.
+ self isFinal ifTrue: [
+ aStream nextPutAll: ' FINAL'.
+ ].
+ aStream nextPut: (Character codePoint: 32).
+ aStream nextPutAll: priority asString.
+ aStream nextPut: $)
+! !
+
+!PEGFsaState methodsFor:'testing'!
+
+canHavePPCId
+ ^ true
+!
+
+hasEqualPriorityTo: state
+ "nil - nil"
+ (self hasPriority not and: [state hasPriority not]) ifTrue: [ ^ true ].
+
+ "nil - priority"
+ (self hasPriority) ifFalse: [ ^ false ].
+
+ "priority - nil"
+ state hasPriority ifFalse: [ ^ false ].
+
+ "priority - priority"
+ ^ self priority = state priority
+!
+
+hasHigherPriorityThan: state
+ "nil - nil"
+ (self hasPriority not and: [state hasPriority not]) ifTrue: [ ^ true ].
+
+ "nil - priority"
+ (self hasPriority) ifFalse: [ ^ false ].
+
+ "priority - nil"
+ state hasPriority ifFalse: [ ^ true ].
+
+ "priority - priority"
+ ^ self priority > state priority
+!
+
+hasPriority
+ ^ priority isNil not
+!
+
+isFailure
+ ^ self isFinal and: [ retval class == PEGFsaFailure ]
+!
+
+isFinal
+ final isNil ifTrue: [ ^ false ].
+
+ final ifTrue: [
+" self assert: self hasPriority. "
+ ^ true
+ ].
+
+ ^ false
+!
+
+isMultivalue
+ ^ multivalue
+! !
+
+!PEGFsaState methodsFor:'transformation'!
+
+determinize
+ ^ self determinize: Dictionary new.
+!
+
+determinize: dictionary
+ self transitionPairs do: [ :pair |
+ self assert: (pair first destination = pair second destination) not.
+ (pair first overlapsWith: pair second) ifTrue: [
+ self determinizeOverlap: pair first second: pair second joinDictionary: dictionary
+ ]
+ ].
+!
+
+determinizeOverlap: t1 second: t2 joinDictionary: dictionary
+ | pair t1Prime t2Prime tIntersection |
+ pair := PEGFsaPair with: t1 with: t2.
+
+ (dictionary includes: pair) ifTrue: [ self error: 'should not happen'.].
+ dictionary at: pair put: nil.
+
+ tIntersection := t1 join: t2 joinDictionary: dictionary.
+ t1Prime := PEGFsaTransition new
+ destination: t1 destination;
+ characterSet: (t1 complement: t2);
+ yourself.
+ t2Prime := PEGFsaTransition new
+ destination: t2 destination;
+ characterSet: (t2 complement: t1);
+ yourself.
+
+
+ self removeTransition: t1.
+ self removeTransition: t2.
+
+ tIntersection isEpsilon ifFalse: [ self addTransition: tIntersection ].
+ t1Prime isEpsilon ifFalse: [ self addTransition: t1Prime ].
+ t2Prime isEpsilon ifFalse: [ self addTransition: t2Prime ].
+
+ dictionary at: pair put: (Array
+ with: tIntersection
+ with: t1Prime
+ with: t2Prime
+ )
+!
+
+join: state
+ ^ self join: state joinDictionary: Dictionary new
+!
+
+join: state joinDictionary: dictionary
+ | pair newState |
+ pair := PEGFsaPair with: self with: state.
+ (dictionary includesKey: pair) ifTrue: [ ^ dictionary at: pair ].
+
+ newState := PEGFsaState new.
+
+ dictionary at: pair put: newState.
+
+ self joinFinal: state newState: newState.
+ self joinPriority: state newState: newState.
+ self joinRetval: state newState: newState.
+ self joinName: state newState: newState.
+
+ newState transitions addAll: (self transitions collect: #copy).
+ newState transitions addAll: (state transitions collect: #copy).
+ newState determinize: dictionary.
+
+ ^ dictionary at: pair put: newState
+!
+
+joinFinal: state newState: newState
+ (self hasEqualPriorityTo: state) ifTrue: [
+ ^ newState final: (self isFinal or: [ state isFinal ]).
+ ].
+
+ (self hasHigherPriorityThan: state) ifTrue: [
+ ^ newState final: self isFinal.
+ ].
+
+ newState final: state isFinal.
+
+!
+
+joinName: state newState: newState
+ newState name: self name asString, '-', state name asString.
+!
+
+joinPriority: state newState: newState
+ (self hasHigherPriorityThan: state) ifTrue: [
+ newState priority: self priority.
+ ^ self
+ ].
+
+ newState priority: state priority.
+!
+
+joinRetval: state newState: newState
+ self isFinal ifFalse: [ ^ newState retval: state retval ].
+ state isFinal ifFalse: [ ^ newState retval: self retval ].
+
+ (self priority = state priority) ifTrue: [
+ newState multivalue: true.
+ ^ newState retval: { self retval . state retval }.
+ ].
+
+ "Both are final"
+ self priority isNil ifTrue: [
+ ^ newState retval: state retval.
+ ].
+
+ state priority isNil ifTrue: [
+ ^ newState retval: self retval.
+ ].
+
+ (self priority > state priority) ifTrue: [
+ ^ newState retval: self retval.
+ ].
+
+ ^ newState retval: state retval.
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsaTransition.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,265 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PEGFsaTransition
+ instanceVariableNames:'characterSet destination priority'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
+!PEGFsaTransition methodsFor:'accessing'!
+
+characterSet
+ ^ characterSet
+!
+
+characterSet: anObject
+ characterSet := anObject
+!
+
+destination
+ ^ destination
+!
+
+destination: anObject
+ destination := anObject
+!
+
+priority
+ ^ priority
+!
+
+priority: anObject
+ priority := anObject
+! !
+
+!PEGFsaTransition methodsFor:'comparing'!
+
+= anotherTransition
+ "
+ Please note the identity comparison on destination
+ If you use equality instead of identy, you will get infinite loop.
+
+ So much for comparison by now :)
+ "
+ (self == anotherTransition) ifTrue: [ ^ true ].
+ (self class == anotherTransition class) ifFalse: [ ^ false ].
+
+ (destination == anotherTransition destination) ifFalse: [ ^ false ].
+ (priority == anotherTransition priority) ifFalse: [ ^ false ].
+ (characterSet = anotherTransition characterSet) ifFalse: [ ^ false ].
+
+ ^ true
+!
+
+canBeIsomorphicTo: anotherTransition
+ (priority == anotherTransition priority) ifFalse: [ ^ false ].
+ (characterSet = anotherTransition characterSet) ifFalse: [ ^ false ].
+
+ ^ true
+!
+
+equals: anotherTransition
+ "this method is used for minimization of the FSA"
+
+ (self == anotherTransition) ifTrue: [ ^ true ].
+
+ (destination == anotherTransition destination) ifFalse: [ ^ false ].
+ (characterSet = anotherTransition characterSet) ifFalse: [ ^ false ].
+
+ "JK: If character set and destination are the same, priority does not really matter"
+ ^ true
+!
+
+hash
+ ^ destination hash bitXor: (priority hash bitXor: characterSet hash)
+!
+
+isIsomorphicTo: object resolvedSet: set
+ (set includes: (PEGFsaPair with: self with: object)) ifTrue: [
+ ^ true
+ ].
+ set add: (PEGFsaPair with: self with: object).
+
+ (self == object) ifTrue: [ ^ true ].
+ (self class == object class) ifFalse: [ ^ false ].
+
+ (priority == object priority) ifFalse: [ ^ false ].
+ (characterSet = object characterSet) ifFalse: [ ^ false ].
+ (destination isIsomorphicTo: object destination resolvedSet: set) ifFalse: [ ^ false ].
+
+ ^ true
+! !
+
+!PEGFsaTransition methodsFor:'copying'!
+
+postCopy
+ super postCopy.
+ characterSet := characterSet copy.
+! !
+
+!PEGFsaTransition methodsFor:'gt'!
+
+gtName
+ | gtName |
+ gtName := self characterSetAsString.
+ priority < 0 ifTrue: [ gtName := gtName, ',', priority asString ].
+ ^ gtName
+! !
+
+!PEGFsaTransition methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ characterSet := Array new: 255 withAll: false.
+ priority := 0.
+! !
+
+!PEGFsaTransition methodsFor:'modifications'!
+
+addCharacter: character
+ characterSet at: character codePoint put: true
+!
+
+decreasePriority
+ priority := priority - 1
+! !
+
+!PEGFsaTransition methodsFor:'printing'!
+
+characterSetAsString
+ | stream |
+ stream := WriteStream on: ''.
+ self printCharacterSetOn: stream.
+ ^ stream contents
+!
+
+printCharacterSetOn: stream
+ self isEpsilon ifTrue: [
+ stream nextPutAll: '<epsilon>'.
+ ^ self
+ ].
+
+ stream nextPut: $[.
+ 32 to: 127 do: [ :index |
+ (characterSet at: index) ifTrue: [
+ stream nextPut: (Character codePoint: index)
+ ]
+ ].
+ stream nextPut: $].
+!
+
+printOn: stream
+ self printCharacterSetOn: stream.
+ stream nextPutAll: ' ('.
+ priority printOn: stream.
+ stream nextPutAll: ')'.
+ stream nextPutAll: '-->'.
+ destination printOn: stream.
+ stream nextPutAll: '(ID: '.
+ stream nextPutAll: self identityHash asString.
+ stream nextPutAll: ')'.
+! !
+
+!PEGFsaTransition methodsFor:'set operations'!
+
+complement: transition
+ | complement |
+ complement := Array new: 255.
+
+ 1 to: 255 do: [ :index |
+ complement
+ at: index
+ put: ((self characterSet at: index) and: [(transition characterSet at: index) not])
+ ].
+
+ ^ complement
+!
+
+disjunction: transition
+ | disjunction |
+ disjunction := Array new: 255.
+
+ 1 to: 255 do: [ :index |
+ disjunction
+ at: index
+ put: ((self characterSet at: index) xor: [transition characterSet at: index])
+ ].
+
+ ^ disjunction
+!
+
+intersection: transition
+ | intersection |
+ intersection := Array new: 255.
+
+ 1 to: 255 do: [ :index |
+ intersection
+ at: index
+ put: ((self characterSet at: index) and: [transition characterSet at: index])
+ ].
+
+ ^ intersection
+!
+
+union: transition
+ | union |
+ union := Array new: 255.
+
+ 1 to: 255 do: [ :index |
+ union
+ at: index
+ put: ((self characterSet at: index) or: [transition characterSet at: index])
+ ].
+
+ ^ union
+! !
+
+!PEGFsaTransition methodsFor:'testing'!
+
+accepts: character
+ ^ characterSet at: character codePoint
+!
+
+isEpsilon
+ ^ characterSet allSatisfy: [ :e | e not ]
+!
+
+overlapsWith: transition
+ ^ (self intersection: transition) anySatisfy: [ :bool | bool ]
+! !
+
+!PEGFsaTransition methodsFor:'transformation'!
+
+join: transition
+ ^ self join: transition joinDictionary: Dictionary new.
+!
+
+join: transition joinDictionary: dictionary
+ | newDestination newTransition |
+" pair := PEGFsaPair with: self with: transition.
+ (dictionary includesKey: pair) ifTrue: [ ^ dictionary at: pair ].
+ dictionary at: pair put: nil.
+"
+ newDestination := self destination join: transition destination joinDictionary: dictionary.
+ newDestination isNil ifTrue: [ self error: 'What a cycle!! I wonder, how does this happened!!' ].
+
+ newTransition := PEGFsaTransition new.
+ newTransition destination: newDestination.
+ newTransition characterSet: (self intersection: transition).
+ newTransition priority: (self priority min: transition priority).
+
+" ^ dictionary at: pair put: newTransition"
+ ^ newTransition
+!
+
+mergeWith: transition
+ | union |
+ self assert: destination = transition destination.
+
+ union := self union: transition.
+ self characterSet: union
+! !
+
--- a/compiler/PPCArguments.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCArguments.st Fri Jul 24 15:06:54 2015 +0100
@@ -87,12 +87,12 @@
self set: #merge to: value.
!
-name
- ^ self at: #name ifAbsent: #PPGeneratedParser
+parserName
+ ^ self at: #parserName ifAbsent: #PPGeneratedParser
!
-name: value
- self set: #name to: value.
+parserName: value
+ self set: #parserName to: value.
!
profile
@@ -111,6 +111,14 @@
self set: #recognizingComponents to: value.
!
+scannerName
+ ^ self at: #scannerName ifAbsent: #PPGeneratedScanner
+!
+
+scannerName: value
+ self set: #scannerName to: value.
+!
+
specialize
^ self at: #specialize ifAbsent: true
!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCClassBuilder.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,154 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PPCClassBuilder
+ instanceVariableNames:'compiledClass compiledClassName constants instvars
+ methodDictionary compiledSuperclass'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Core'
+!
+
+!PPCClassBuilder methodsFor:'accessing'!
+
+compiledClass
+ ^ compiledClass
+!
+
+compiledClassName
+ ^ compiledClassName
+!
+
+compiledClassName: anObject
+ compiledClassName := anObject asSymbol
+!
+
+compiledSuperclass
+ ^ compiledSuperclass
+!
+
+compiledSuperclass: anObject
+ compiledSuperclass := anObject
+!
+
+constants
+ ^ constants
+!
+
+constants: anObject
+ constants := anObject
+!
+
+instvars
+ ^ instvars
+!
+
+instvars: anObject
+ instvars := anObject
+!
+
+methodDictionary
+ ^ methodDictionary
+!
+
+methodDictionary: anObject
+ methodDictionary := anObject
+! !
+
+!PPCClassBuilder methodsFor:'cleaning'!
+
+clean
+ Smalltalk at: compiledClassName ifPresent: [ :e |
+ compiledClass := e.
+ self cleanGeneratedMethods.
+ ]
+!
+
+cleanGeneratedMethods
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ compiledClass methodsDo: [ :mthd |
+ (mthd category beginsWith: 'generated') ifTrue:[
+ compiledClass removeSelector: mthd selector.
+ ]
+ ]
+ ] ifFalse: [
+ (compiledClass allProtocolsUpTo: compiledClass) do: [ :protocol |
+ (protocol beginsWith: 'generated') ifTrue: [
+ compiledClass removeProtocol: protocol.
+ ]
+ ]
+ ]
+! !
+
+!PPCClassBuilder methodsFor:'compiling'!
+
+compileClass
+ self clean.
+
+ self installVariables.
+ self installMethods.
+ self setConstants.
+
+ ^ compiledClass
+!
+
+installMethods
+ methodDictionary values do: [ :method |
+ (compiledClass methodDictionary includesKey: method methodName) ifFalse: [
+ compiledClass compileSilently: method code classified: method category.
+ ]
+ ]
+!
+
+installVariables
+ | instvarString classvarString |
+ instvarString := instvars inject: '' into: [:r :e | r, ' ', e ].
+ classvarString := constants keys inject: '' into: [:r :e | r, ' ', e ].
+
+ compiledSuperclass
+ subclass: compiledClassName
+ instanceVariableNames: instvarString
+ classVariableNames: classvarString
+ poolDictionaries: ''
+ category: 'PetitCompiler-Generated'.
+
+ compiledClass := Smalltalk at: compiledClassName.
+!
+
+registerPackages
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ | rPackageOrganizer |
+ rPackageOrganizer := Smalltalk at: #RPackageOrganizer.
+ rPackageOrganizer notNil ifTrue:[
+ rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
+ ].
+ ] ifFalse: [
+ RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
+ ].
+!
+
+setClassVars
+ constants keysAndValuesDo: [ :key :value |
+ compiledClass classVarNamed: key put: value
+ ]
+!
+
+setConstants
+ constants keysAndValuesDo: [ :key :value |
+ compiledClass classVarNamed: key put: value
+ ]
+! !
+
+!PPCClassBuilder methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ methodDictionary := IdentityDictionary new.
+ constants := IdentityDictionary new.
+ instvars := IdentitySet new.
+
+ self registerPackages.
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCCodeBlock.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,182 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PPCCodeBlock
+ instanceVariableNames:'buffer indentation temporaries'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Compiler-Codegen'
+!
+
+!PPCCodeBlock class methodsFor:'instance creation'!
+
+new
+ "return an initialized instance"
+
+ ^ self basicNew initialize.
+! !
+
+!PPCCodeBlock methodsFor:'as yet unclassified'!
+
+add: string
+ self nl.
+ self codeIndent.
+ self addOnLine: string.
+
+ "Modified: / 01-06-2015 / 22:58:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+addOnLine: string
+ buffer nextPutAll: string.
+!
+
+nl
+ ^ buffer nextPut: Character cr
+! !
+
+!PPCCodeBlock methodsFor:'code generation'!
+
+code: aStringOrBlockOrRBParseNode
+ aStringOrBlockOrRBParseNode isString ifTrue:[
+ self emitCodeAsString: aStringOrBlockOrRBParseNode
+ ] ifFalse:[
+ (aStringOrBlockOrRBParseNode isKindOf: RBProgramNode) ifTrue:[
+ self emitCodeAsRBNode: aStringOrBlockOrRBParseNode.
+ ] ifFalse:[
+ self emitCodeAsBlock: aStringOrBlockOrRBParseNode
+ ].
+ ].
+
+ "Created: / 01-06-2015 / 21:07:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 03-06-2015 / 05:52:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIndent
+ self codeIndent:indentation
+
+ "Created: / 01-06-2015 / 22:58:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIndent: level
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ level * 4 timesRepeat: [ buffer nextPut: Character space ].
+ ] ifFalse:[
+ level timesRepeat: [ buffer nextPut: Character tab ].
+ ].
+
+ "Created: / 01-06-2015 / 22:58:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCCodeBlock methodsFor:'code generation - variables'!
+
+allocateTemporaryVariableNamed:preferredName
+ "Allocate a new variable with (preferably) given name.
+ Returns a real variable name that should be used."
+
+ (temporaries includes:preferredName) ifFalse:[
+ temporaries add:preferredName.
+ ^ preferredName
+ ] ifTrue:[
+ | name |
+
+ name := preferredName , '_' , (temporaries size + 1) printString.
+ temporaries add:name.
+ ^ name
+ ].
+
+ "Created: / 23-04-2015 / 17:37:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:03:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCCodeBlock methodsFor:'indentation'!
+
+dedent
+ indentation := indentation - 1
+!
+
+indent
+ indentation := indentation + 1
+!
+
+indentationLevel
+ ^ indentation
+!
+
+indentationLevel: value
+ indentation := value
+! !
+
+!PPCCodeBlock methodsFor:'initialization'!
+
+initialize
+ "Invoked when a new instance is created."
+
+ buffer := String new writeStream.
+ indentation := 1.
+ temporaries := OrderedCollection new.
+
+ "Modified: / 01-06-2015 / 20:57:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 18-06-2015 / 06:04:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCCodeBlock methodsFor:'printing and storing'!
+
+codeOn: aStream
+ "Dumps generated code on given stream"
+
+ temporaries notEmpty ifTrue:[
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ indentation * 4 timesRepeat: [ aStream nextPut: Character space ].
+ ] ifFalse:[
+ indentation timesRepeat: [ aStream nextPut: Character tab ].
+ ].
+ aStream nextPut: $|.
+ temporaries do:[:e | aStream space; nextPutAll: e ].
+ aStream space.
+ aStream nextPut: $|.
+ self nl.
+ "In Smalltalk/X, there should be a blank line after temporaries"
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ self nl.
+ ].
+ ].
+ aStream nextPutAll: buffer contents
+
+ "Created: / 01-06-2015 / 21:26:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCCodeBlock methodsFor:'private'!
+
+emitCodeAsBlock: aBlock
+ aBlock value
+!
+
+emitCodeAsRBNode: anRBNode
+ anRBNode isSequence ifTrue:[
+ anRBNode temporaries do:[:e |
+ (temporaries includes: e name) ifFalse:[
+ temporaries add: e name
+ ].
+ ].
+ anRBNode statements do:[:e|
+ self add: (self formatRBNode: e);
+ addOnLine: '.'.
+ ].
+ ] ifFalse:[
+ buffer nextPutAll: anRBNode formattedCode.
+ ].
+
+!
+
+emitCodeAsString: aString
+ buffer nextPutAll: aString
+!
+
+formatRBNode: anRBNode
+ | formatter |
+ formatter := anRBNode formatterClass new.
+ formatter indent: indentation.
+ ^ formatter format: anRBNode
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCCodeGen.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,574 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PPCCodeGen
+ instanceVariableNames:'compilerStack compiledParser methodCache currentMethod constants
+ returnVariable arguments idCache'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Compiler-Codegen'
+!
+
+!PPCCodeGen class methodsFor:'instance creation'!
+
+new
+ "return an initialized instance"
+
+ ^ self on: PPCArguments default
+!
+
+on: aPPCArguments
+ "return an initialized instance"
+
+ ^ self basicNew
+ initialize;
+ arguments: aPPCArguments
+! !
+
+!PPCCodeGen methodsFor:'accessing'!
+
+arguments: args
+ arguments := args
+!
+
+constants
+ ^ constants
+!
+
+currentMethod
+ ^ currentMethod
+!
+
+currentNonInlineMethod
+ ^ compilerStack
+ detect:[:m | m isInline not ]
+ ifNone:[ self error: 'No non-inlined method']
+
+ "Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+currentReturnVariable
+ ^ currentMethod returnVariable
+!
+
+ids
+ ^ idCache keys
+!
+
+methodCategory
+ ^ 'generated'
+!
+
+methodDictionary
+ ^ methodCache
+!
+
+methodFor: object
+ | id |
+ id := self idFor: object.
+ ^ methodCache at: id ifAbsent: [ nil ]
+! !
+
+!PPCCodeGen methodsFor:'code generation'!
+
+add: string
+ currentMethod add: string.
+!
+
+addConstant: value as: name
+ (constants includesKey: name) ifTrue:[
+ (constants at: name) ~= value ifTrue:[
+ self error:'Duplicate constant!!'.
+ ].
+ ^ self.
+ ].
+ constants at: name put: value
+
+ "Modified: / 29-05-2015 / 07:22:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+addOnLine: string
+ currentMethod addOnLine: string.
+!
+
+addVariable: name
+ ^ self currentNonInlineMethod addVariable: name
+
+ "Modified: / 23-04-2015 / 17:34:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+call: anotherMethod
+ currentMethod add: anotherMethod call.
+!
+
+callOnLine: anotherMethod
+ currentMethod addOnLine: anotherMethod call.
+!
+
+dedent
+ currentMethod dedent
+!
+
+indent
+ currentMethod indent
+!
+
+nl
+ currentMethod nl
+!
+
+smartRemember: parser to: variableName
+ parser isContextFree ifTrue: [
+ self codeAssign: 'context lwRemember.'
+ to: variableName.
+ ] ifFalse: [
+ self codeAssign: 'context remember.'
+ to: variableName.
+ ]
+!
+
+smartRestore: parser from: mementoName
+ parser isContextFree ifTrue: [
+ self add: 'context lwRestore: ', mementoName, '.'.
+ ] ifFalse: [
+ self add: 'context restore: ', mementoName, '.'.
+ ]
+! !
+
+!PPCCodeGen methodsFor:'coding'!
+
+code:aStringOrBlockOrRBParseNode
+ currentMethod code: aStringOrBlockOrRBParseNode
+
+ "Created: / 01-06-2015 / 23:49:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeAssign: code to: variable
+ self assert: variable isNil not.
+
+ "TODO JK: Hack alert, whatever is magic constant!!"
+ (variable == #whatever) ifFalse: [
+ "Do not assign, if somebody does not care!!"
+ self add: variable ,' := ', code.
+ ]
+!
+
+codeAssignParsedValueOf:aBlock to:aString
+ | tmpVarirable method |
+
+ self assert:aBlock isBlock.
+ self assert:aString isNil not.
+ tmpVarirable := returnVariable.
+ returnVariable := aString.
+ method := [
+ aBlock value
+ ] ensure:[ returnVariable := tmpVarirable ].
+ method isInline ifTrue:[
+ self callOnLine:method
+ ] ifFalse:[
+ self codeEvaluateAndAssign:(method call) to:aString.
+ ]
+
+ "Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeBlock: contents
+ currentMethod codeBlock: contents
+
+ "Created: / 01-06-2015 / 22:35:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeClearError
+ self add: 'self clearError.'.
+!
+
+codeComment: string
+ currentMethod add: '"', string, '"'.
+!
+
+codeDot
+ self addOnLine:'.'.
+
+ "Created: / 16-06-2015 / 06:09:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeError
+ self add: 'self error: ''message notspecified''.'.
+!
+
+codeError: errorMessage
+ self add: 'self error: ''', errorMessage, '''.'
+!
+
+codeError: errorMessage at: position
+ self add: 'self error: ''', errorMessage, ''' at: ', position asString, '.'
+!
+
+codeEvaluate: selector argument: argument on: variable
+ self assert: variable isNil not.
+
+ "TODO JK: Hack alert, whatever is magic constant!!"
+ (variable == #whatever) ifFalse: [
+ "Do not assign, if somebody does not care!!"
+ self add: variable, ' ', selector,' ', argument.
+ ] ifTrue: [
+ "In case argument has a side effect"
+ self add: argument
+ ]
+!
+
+codeEvaluateAndAssign: argument to: variable
+ self assert: variable isNil not.
+
+ "TODO JK: Hack alert, whatever is magic constant!!"
+ (variable == #whatever) ifFalse: [
+ "Do not assign, if somebody does not care!!"
+ self add: variable ,' := ', argument.
+ ] ifTrue: [
+ "In case an argument has a side effect"
+ self add: argument.
+ ]
+!
+
+codeHalt
+ self add: 'self halt. '
+!
+
+codeHaltIfShiftPressed
+ arguments debug ifTrue: [
+ ((Smalltalk respondsTo: #isSmalltalkX) and:[Smalltalk isSmalltalkX]) ifFalse:[
+ self add: 'Halt ifShiftPressed.'
+ ]
+ ]
+
+ "Modified: / 10-05-2015 / 07:39:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIf: condition then: then
+ self codeIf: condition then: then else: nil
+
+ "Created: / 16-06-2015 / 06:07:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIf: condition then: then else: else
+ currentMethod
+ add: '(';
+ code: condition;
+ addOnLine: ')'.
+ then notNil ifTrue:[
+ currentMethod
+ addOnLine:' ifTrue:';
+ codeBlock: then.
+ ].
+ else notNil ifTrue:[
+ currentMethod
+ addOnLine:' ifFalse:';
+ codeBlock: else.
+ ].
+ self codeDot.
+
+ "Created: / 01-06-2015 / 22:43:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 16-06-2015 / 06:09:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIfErrorThen: then
+ ^ self codeIf: 'error' then: then else: nil
+
+ "Created: / 16-06-2015 / 06:06:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIfErrorThen: then else: else
+ ^ self codeIf: 'error' then: then else: else
+
+ "Created: / 16-06-2015 / 06:05:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeNextToken
+ self add: 'self nextToken.'
+
+ "Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeProfileStart
+ self add: 'context methodInvoked: #', currentMethod methodName, '.'
+
+ "Created: / 01-06-2015 / 21:17:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeProfileStop
+ self add: 'context methodFinished: #', currentMethod methodName, '.'
+
+ "Created: / 01-06-2015 / 21:19:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeReturn
+ currentMethod isInline ifTrue: [
+ "If inlined, the return variable already holds the value"
+ ] ifFalse: [
+ arguments profile ifTrue:[
+ self codeProfileStop.
+ ].
+ self add: '^ ', currentMethod returnVariable
+ ].
+
+ "Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:49:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeReturn: code
+ " - returns whatever is in code OR
+ - assigns whatever is in code into the returnVariable"
+ currentMethod isInline ifTrue:[
+ self codeEvaluateAndAssign: code to: currentMethod returnVariable.
+ ] ifFalse: [
+ arguments profile ifTrue:[
+ self codeProfileStop.
+ ].
+ self add: '^ ', code
+ ]
+
+ "Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:48:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeStoreValueOf: aBlock intoVariable: aString
+ | tmpVarirable method |
+ self assert: aBlock isBlock.
+ self assert: aString isNil not.
+
+ tmpVarirable := returnVariable.
+ returnVariable := aString.
+ method := [
+ aBlock value
+ ] ensure: [
+ returnVariable := tmpVarirable
+ ].
+
+ method isInline ifTrue: [
+ self callOnLine: method
+ ] ifFalse: [
+ self codeEvaluateAndAssign: (method call) to: aString.
+ ]
+
+ "Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeTokenGuard: node ifFalse: codeBlock
+ | guard id |
+ guard := PPCTokenGuard on: node.
+ (guard makesSense) ifTrue: [
+ id := self idFor: guard firstToken.
+
+ self add: 'self ', id asString, ' ifFalse: ['.
+ self indent.
+ codeBlock value.
+ self dedent.
+ self add: '].'.
+ ]
+!
+
+codeTranscriptShow: text
+ (arguments profile) ifTrue: [
+ self add: 'Transcript show: ', text storeString, '; cr.'.
+ ]
+! !
+
+!PPCCodeGen methodsFor:'ids'!
+
+asSelector: string
+ "e.g. '234znak 43 ) 2' asLegalSelector = #v234znak432"
+
+ | toUse |
+
+ toUse := string select: [:char | char isAlphaNumeric or: [ char = $_ ] ].
+ (toUse isEmpty or: [ toUse first isLetter not ])
+ ifTrue: [ toUse := 'v', toUse ].
+ toUse first isUppercase ifFalse:[
+ toUse := toUse copy.
+ toUse at: 1 put: toUse first asLowercase
+ ].
+ ^toUse
+
+ "Modified: / 10-05-2015 / 07:29:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+idFor: object
+ self assert: (object canHavePPCId).
+ ^ self idFor: object prefixed: object prefix suffixed: object suffix
+!
+
+idFor: object prefixed: prefix
+ ^ self idFor: object prefixed: prefix suffixed: ''
+!
+
+idFor: object prefixed: prefix suffixed: suffix
+ | name id |
+ ^ idCache at: object ifAbsentPut: [
+ ((object canHavePPCId) and: [object name isNotNil]) ifTrue: [
+ "Do not use prefix, if there is a name"
+ name := self asSelector: (object name asString).
+ id := (name, suffix) asSymbol.
+
+ "Make sure, that the generated ID is uniqe!!"
+ (idCache includes: id) ifTrue: [
+ (id, '_', idCache size asString) asSymbol
+ ] ifFalse: [
+ id
+ ]
+ ] ifFalse: [
+ (prefix, '_', (idCache size asString), suffix) asSymbol
+ ]
+ ]
+!
+
+idFor: object suffixed: suffix
+ self assert: (object isKindOf: PPCNode) description: 'Shold use PPCNode for ids'.
+ ^ self idFor: object prefixed: object prefix suffixed: suffix effect: #none
+! !
+
+!PPCCodeGen methodsFor:'initialization'!
+
+copy: parser
+ self halt: 'deprecated?'.
+ ^ parser transform: [ :p | p copy ].
+!
+
+initialize
+ super initialize.
+
+ compilerStack := Stack new.
+ methodCache := IdentityDictionary new.
+ constants := Dictionary new.
+ idCache := IdentityDictionary new.
+! !
+
+!PPCCodeGen methodsFor:'profiling'!
+
+profileTokenRead: tokenName
+ arguments profile ifTrue: [
+ self add: 'context tokenRead: ', tokenName storeString, '.'
+ ]
+! !
+
+!PPCCodeGen methodsFor:'support'!
+
+cache: id as: value
+ methodCache at: id put: value.
+!
+
+cachedValue: id
+ ^ methodCache at: id ifAbsent: [ nil ]
+!
+
+cachedValue: id ifPresent: block
+ ^ methodCache at: id ifPresent: block
+!
+
+checkCache: id
+ | method |
+
+ "self halt: 'deprecated?'."
+
+ "Check if method is hand written"
+ method := compiledParser ifNotNil: [ compiledParser compiledMethodAt: id ifAbsent: [ nil ] ].
+ method ifNotNil: [ ^ PPCCompiledMethod new id: id; yourself ].
+
+ ^ self cachedValue: id
+!
+
+pop
+ | retval |
+ retval := compilerStack pop.
+ currentMethod := compilerStack isEmpty
+ ifTrue: [ nil ]
+ ifFalse: [ compilerStack top ].
+ ^ retval
+
+ "Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+push
+ compilerStack push: currentMethod.
+ (compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]
+
+ "Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+startInline: id
+ | indentationLevel |
+ (methodCache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
+ indentationLevel := currentMethod indentationLevel.
+
+ currentMethod := PPCInlinedMethod new.
+ currentMethod id: id.
+ currentMethod returnVariable: returnVariable.
+ currentMethod indentationLevel: indentationLevel.
+ self push.
+
+ "Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+startMethod: id
+ (methodCache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
+
+ currentMethod := PPCMethod new.
+ currentMethod id: id.
+ currentMethod category: self methodCategory.
+
+ arguments profile ifTrue:[
+ self codeProfileStart.
+ ].
+ self push.
+
+ self cache: id as: currentMethod.
+
+ "Modified: / 01-06-2015 / 21:19:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+stopInline
+ ^ self pop.
+
+ "Modified: / 01-06-2015 / 21:37:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+stopMethod
+ self cache: currentMethod methodName as: currentMethod.
+
+ "arguments profile ifTrue: [ Transcript show: currentMethod code; cr. ]."
+ ^ self pop.
+
+ "Modified: / 01-06-2015 / 21:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+top
+ ^ compilerStack top
+! !
+
+!PPCCodeGen methodsFor:'variables'!
+
+allocateReturnVariable
+ ^ self allocateReturnVariableNamed: 'retval'
+
+ "Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 15-06-2015 / 17:52:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+allocateReturnVariableNamed: name
+ "Allocate (or return previously allocated one) temporary variable used for
+ storing a parser's return value (the parsed object)"
+ ^ currentMethod allocateReturnVariableNamed: name
+
+ "Created: / 15-06-2015 / 18:04:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+allocateTemporaryVariableNamed: preferredName
+ "Allocate a new variable with (preferably) given name.
+ Returns a real variable name that should be used."
+
+ ^ self currentNonInlineMethod allocateTemporaryVariableNamed: preferredName
+
+ "Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
--- a/compiler/PPCCodeGenerator.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCCodeGenerator.st Fri Jul 24 15:06:54 2015 +0100
@@ -33,6 +33,88 @@
^ arguments guards
! !
+!PPCCodeGenerator methodsFor:'code generation'!
+
+generateChoiceChildOf: choiceNode atIndex: choiceChildNodeIndex useGuards: useGuards storeResultInto: resultVar
+
+ | children |
+
+ children := choiceNode children.
+ useGuards ifTrue:[
+ self addGuard: (children at: choiceChildNodeIndex) ifTrue: [
+ compiler add: 'self clearError.'.
+ compiler
+ codeAssignParsedValueOf:[ self visit:(children at: choiceChildNodeIndex) ]
+ to: resultVar.
+ compiler add: 'error ifFalse: [ '.
+ compiler codeReturn: resultVar.
+ compiler add: ' ].'.
+ ] ifFalse:[
+ compiler add: 'error := true.'.
+ ].
+ compiler add: 'error ifTrue:[ '.
+ choiceChildNodeIndex < children size ifTrue:[
+ self generateChoiceChildOf: choiceNode atIndex: choiceChildNodeIndex + 1 useGuards: useGuards storeResultInto: resultVar.
+ ] ifFalse:[
+ compiler codeError: 'no choice suitable'.
+ ].
+ compiler addOnLine: '].'.
+
+ ] ifFalse:[
+ choiceChildNodeIndex <= children size ifTrue:[
+ compiler add: 'self clearError.'.
+ compiler
+ codeAssignParsedValueOf:[ self visit:(children at: choiceChildNodeIndex) ]
+ to: resultVar.
+ compiler add: 'error ifFalse: [ '.
+ compiler codeReturn: resultVar.
+ compiler add: ' ].'.
+ self generateChoiceChildOf: choiceNode atIndex: choiceChildNodeIndex + 1 useGuards: useGuards storeResultInto: resultVar.
+ ] ifFalse:[
+ compiler codeError: 'no choice suitable'.
+ ].
+ ].
+
+
+!
+
+generateSequenceChildOf: sequenceNode atIndex: sequenceNodeChildIndex useMememntoVar: mementoVar storeResultInto: elementVars
+ | child childValueVar |
+
+ child := sequenceNode children at: sequenceNodeChildIndex.
+ childValueVar := elementVars at: sequenceNodeChildIndex.
+ compiler codeAssignParsedValueOf: [ self visit:child ]
+ to: childValueVar.
+ child acceptsEpsilon ifFalse: [
+ compiler codeIfErrorThen: [
+ "Handle error in the first element in a special way,
+ because one does not need to do backtracking if the first element fails."
+ (sequenceNodeChildIndex == 1) ifTrue: [
+ compiler codeReturn: 'failure'
+ ] ifFalse: [
+ compiler smartRestore: sequenceNode from: mementoVar.
+ compiler codeReturn: 'failure.'.
+ ]
+ ] else:[
+ sequenceNode returnParsedObjectsAsCollection ifTrue:[
+ compiler add: self retvalVar , ' at: ', sequenceNodeChildIndex asString, ' put: ', childValueVar, '.'.
+ ].
+ (sequenceNodeChildIndex < sequenceNode children size) ifTrue:[
+ self generateSequenceChildOf: sequenceNode atIndex: sequenceNodeChildIndex + 1 useMememntoVar: mementoVar storeResultInto: elementVars.
+ ].
+ ]
+
+ ] ifTrue:[
+ sequenceNode returnParsedObjectsAsCollection ifTrue:[
+ compiler add: self retvalVar , ' at: ', sequenceNodeChildIndex asString, ' put: ', childValueVar, '.'.
+ ].
+ (sequenceNodeChildIndex < sequenceNode children size) ifTrue:[
+ self generateSequenceChildOf: sequenceNode atIndex: sequenceNodeChildIndex + 1 useMememntoVar: mementoVar storeResultInto: elementVars.
+
+ ].
+ ]
+! !
+
!PPCCodeGenerator methodsFor:'guards'!
addGuard: node ifTrue: trueBlock ifFalse: falseBlock
@@ -107,12 +189,33 @@
^ compiler checkCache: (compiler idFor: node)
! !
+!PPCCodeGenerator methodsFor:'private'!
+
+withAllVariableNodesOf: anRBProgramNode do: aBlock
+ "Enumerate all chilren of `anRBProgramNode` (including itself)
+ and evaluate `aBlock` for each variable node.
+ This is a replacement for Smalltalk/X's RBProgramNode>>variableNodesDo:
+ which is not present in Pharo"
+
+ anRBProgramNode isVariable ifTrue:[
+ aBlock value: anRBProgramNode.
+ ^ self.
+ ].
+ anRBProgramNode children do:[:each |
+ self withAllVariableNodesOf: each do: aBlock
+ ].
+
+ "Created: / 18-06-2015 / 22:02:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
!PPCCodeGenerator methodsFor:'support'!
compileTokenWhitespace: node
compiler add: 'context atWs ifFalse: ['.
compiler indent.
- compiler codeStoreValueOf: [ self visit: node whitespace ] intoVariable: #whatever.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node whitespace ]
+ to:#whatever.
compiler add: 'context setWs.'.
compiler dedent.
compiler add: '].'.
@@ -155,23 +258,25 @@
!
retvalVar
- ^ compiler currentReturnVariable
+ ^ compiler currentReturnVariable
+
+ "Modified: / 15-06-2015 / 18:20:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
startMethodForNode:node
node isMarkedForInline ifTrue:[
- compiler startInline: (compiler idFor: node).
- compiler addComment: 'BEGIN inlined code of ' , node printString.
- compiler indent.
+ compiler startInline: (compiler idFor: node).
+ compiler addComment: 'BEGIN inlined code of ' , node printString.
+ compiler indent.
] ifFalse:[
- compiler startMethod: (compiler idFor: node).
- compiler addComment: 'GENERATED by ' , node printString.
- compiler allocateReturnVariable.
+ compiler startMethod: (compiler idFor: node).
+ compiler addComment: 'GENERATED by ' , node printString.
+ compiler allocateReturnVariable.
].
"Created: / 23-04-2015 / 15:51:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 23-04-2015 / 19:13:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified (comment): / 23-04-2015 / 21:31:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 15-06-2015 / 18:03:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stopMethodForNode:aPPCNode
@@ -204,19 +309,102 @@
!PPCCodeGenerator methodsFor:'visiting'!
visitActionNode: node
- | blockId |
+ | blockNode blockBody blockNodesVar blockNeedsCollection blockMatches childValueVars |
+
+ blockNode := node block sourceNode copy.
+ self assert: blockNode arguments size == 1.
+ blockNodesVar := blockNode arguments first .
+ blockBody := blockNode body.
+
+ "Now, analyze block body, search for all references to
+ block arg <barg> and check if in all cases it's used
+ in one of the following patterns:
+
+ * <barg> first , <barg> second, ... , <barg> sixth
+ * <barg> at: <integer constant>
+
+ If so, then the block code can be inlined and the intermediate
+ result collection need not to be created. Keep this information
+ in temporary `blockNeedsCollection`.
+ During the analysis, remember all nodes that matches the pattern
+ in a dictionary `blockMatches` mapping the node to actual temporary
+ variable where the node is used. This will be later used for block's node
+ rewriting"
+ blockNeedsCollection := true.
+ node child isSequenceNode ifTrue:[
+ blockNeedsCollection := false.
+ blockMatches := IdentityDictionary new."Must use IDENTITY dict as nodes have overwritten their #=!!!!!!"
+ childValueVars := node child preferredChildrenVariableNames.
+ self withAllVariableNodesOf: blockBody do:[:variableNode|
+ variableNode name = blockNodesVar name ifTrue:[
+ "Check if variable node matches..."
+ variableNode parent isMessage ifTrue:[
+ | parent |
+
+ parent := variableNode parent.
+ "Check for <barg> at: <number>"
+ ((parent selector == #at:) and:[ parent arguments first isLiteralNumber ]) ifTrue:[
+ blockMatches at: parent put: (childValueVars at: parent arguments first value).
+ ] ifFalse:[
+ "Check for <barg> first / second / ..."
+ | i |
- blockId := 'block_', (compiler idFor: node).
- compiler addConstant: node block as: blockId.
-
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
- compiler add: 'error ifFalse: ['.
- compiler codeReturn: blockId, ' value: ', self retvalVar.
- compiler add: '] ifTrue: ['.
- compiler codeReturn: 'failure'.
- compiler add: '].'.
+ i := #(first second third fourth fifth sixth) indexOf: parent selector.
+ i ~~ 0 ifTrue:[
+ blockMatches at: parent put: (childValueVars at: i).
+ ] ifFalse:[
+ blockNeedsCollection := true.
+ ].
+ ].
+ ] ifFalse:[
+ blockNeedsCollection := true.
+ ].
+ ].
+ ].
+ ].
- "Modified: / 23-04-2015 / 15:59:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ blockNeedsCollection ifTrue:[
+ "Bad, we have to use the collection.
+ Replace all references to blockNodeVar to retvalVar..."
+ self withAllVariableNodesOf: blockBody do:[:variableNode|
+ variableNode name = blockNodesVar name ifTrue:[
+ variableNode name: self retvalVar.
+ ].
+ ].
+ ] ifFalse:[
+ "Good, can avoid intermediate collection.
+ Replace references to collection with corresponding temporary variable"
+ blockMatches keysAndValuesDo:[:matchingNode :childValueVar |
+ matchingNode parent replaceNode: matchingNode withNode: (RBVariableNode named: childValueVar).
+ ].
+ node child returnParsedObjectsAsCollection: false.
+ ].
+
+ "Block return value is return value of last statement.
+ So if the method is not inline, make last statement a return.
+ if the method is inline, make it assignment to retvalVar."
+ blockBody statements notEmpty ifTrue:["Care for empty blocks - [:t | ] !!"
+ compiler currentMethod isInline ifTrue:[
+ | assignment |
+
+ assignment := RBAssignmentNode variable: (RBVariableNode named: self retvalVar) value: blockBody statements last.
+ blockBody replaceNode: blockBody statements last withNode: assignment.
+ ] ifFalse:[
+ | return |
+
+ return := RBReturnNode value: blockBody statements last.
+ blockBody replaceNode: blockBody statements last withNode: return.
+ ].
+ ].
+
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:self retvalVar.
+ compiler codeIfErrorThen: [
+ compiler codeReturn: 'failure'.
+ ] else: [
+ compiler code: blockBody.
+ ]
+
+ "Modified: / 19-06-2015 / 07:05:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitAndNode: node
@@ -225,7 +413,9 @@
mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
compiler smartRemember: node child to: mementoVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node child ]
+ to:self retvalVar.
compiler smartRestore: node child from: mementoVar.
compiler codeReturn.
@@ -292,33 +482,15 @@
!
visitChoiceNode: node
- | whitespaceConsumed elementVar |
- "The code is not ready for inlining"
- self assert: node isMarkedForInline not.
+ | whitespaceConsumed useGuards resultVar |
+
+ resultVar := compiler allocateTemporaryVariableNamed: 'element'.
+ whitespaceConsumed := self addGuardTrimming: node.
+ useGuards := whitespaceConsumed.
+ self generateChoiceChildOf: node atIndex: 1 useGuards: useGuards storeResultInto: resultVar
- elementVar := compiler allocateTemporaryVariableNamed: 'element'.
- whitespaceConsumed := self addGuardTrimming: node.
-
- 1 to: node children size do: [ :idx | |child allowGuard |
- child := node children at: idx.
- allowGuard := whitespaceConsumed.
-
- allowGuard ifTrue: [
- self addGuard: child ifTrue: [
- compiler add: 'self clearError.'.
- compiler codeStoreValueOf: [self visit: child] intoVariable: elementVar.
- compiler add: 'error ifFalse: [ ^ ', elementVar, ' ].'.
- ] ifFalse: nil.
- ] ifFalse: [
- compiler add: 'self clearError.'.
- compiler codeStoreValueOf: [self visit: child] intoVariable: elementVar.
- compiler add: 'error ifFalse: [ ^ ', elementVar, ' ].'.
- ]
- ].
- compiler codeError: 'no choice suitable'.
-
- "Modified: / 23-04-2015 / 21:40:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 29-05-2015 / 07:17:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitEndOfFileNode: node
@@ -327,17 +499,21 @@
visitEndOfInputNode: node
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
- compiler add: 'context atEnd ifTrue: ['.
- compiler codeReturn.
- compiler add: '] ifFalse: ['.
- compiler codeError: 'End of input expected'.
- compiler add: ']'.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node child ]
+ to:self retvalVar.
+ compiler codeIf: 'context atEnd'
+ then: [ compiler codeReturn ]
+ else: [ compiler codeError: 'End of input expected' ].
+
+ "Modified: / 26-05-2015 / 19:03:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitForwardNode: node
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node child ]
+ to:self retvalVar.
compiler codeReturn.
!
@@ -357,6 +533,71 @@
compiler add: '].'.
!
+visitMappedActionNode: node
+ | child blockNode blockBody |
+
+ child := node child.
+ blockNode := node block sourceNode copy.
+ blockBody := blockNode body.
+
+ "Block return value is return value of last statement.
+ So if the method is not inline, make last statement a return.
+ if the method is inline, make it assignment to retvalVar."
+ compiler currentMethod isInline ifTrue:[
+ | assignment |
+
+ assignment := RBAssignmentNode variable: (RBVariableNode named: self retvalVar) value: blockBody statements last.
+ blockBody replaceNode: blockBody statements last withNode: assignment.
+ ] ifFalse:[
+ | return |
+
+ return := RBReturnNode value: blockBody statements last.
+ blockBody replaceNode: blockBody statements last withNode: return.
+ ].
+
+ child isSequenceNode ifTrue:[
+ child isMarkedForInline ifTrue:[
+ child preferredChildrenVariableNames: blockNode argumentNames.
+ child returnParsedObjectsAsCollection: false.
+ ].
+ ] ifFalse:[
+ "Child is not a sequence so it 'returns' only one object.
+ Therefore the block takes only one argument and it's value
+ is value of child's retval.
+ In the block, replace all references to block argument to
+ my retvalVar. "
+ | blockArg |
+
+ blockArg := blockNode arguments first.
+ self withAllVariableNodesOf: blockBody do:[:variableNode|
+ variableNode name = blockArg name ifTrue:[
+ variableNode name: self retvalVar.
+ ].
+ ].
+ ].
+
+ compiler codeAssignParsedValueOf: [ self visit: child ] to: self retvalVar.
+ compiler codeIf: 'error' then: [
+ compiler codeReturn: 'failure'.
+ ] else: [
+ "If the child is sequence and not inlined, extract
+ nodes from returned collection into used-to-be block variables"
+ (child isSequenceNode and:[ child returnParsedObjectsAsCollection ]) ifTrue:[
+ blockNode arguments withIndexDo:[ :arg :idx |
+ node child isMarkedForInline ifFalse:[
+ compiler allocateTemporaryVariableNamed: arg name.
+ compiler codeAssign: (self retvalVar , ' at: ', idx printString) to: arg name.
+ ].
+ compiler addOnLine: '.'; nl.
+ ].
+ ].
+ compiler code: blockBody.
+ ]
+
+ "Created: / 02-06-2015 / 17:28:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 19-06-2015 / 07:06:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
visitMessagePredicateNode: node
compiler add: '(context peek ', node message, ') ifFalse: ['.
compiler codeError: 'predicate not found'.
@@ -443,7 +684,7 @@
mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
compiler smartRemember: node child to: mementoVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:#whatever.
compiler smartRestore: node child from: mementoVar.
compiler add: '^ error ifFalse: [ self error ] ifTrue: [ self clearError. nil ]'.
@@ -452,7 +693,9 @@
!
visitOptionalNode: node
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node child ]
+ to:self retvalVar.
compiler add: 'error ifTrue: [ '.
compiler indent.
compiler add: 'self clearError. '.
@@ -475,32 +718,37 @@
elementVar := compiler allocateTemporaryVariableNamed: 'element'.
-" self tokenGuards ifTrue: [
+" self tokenGuards ifTrue: [
compiler codeTokenGuard: node ifFalse: [ compiler codeError: 'at least one occurence expected' ].
].
"
compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:elementVar.
compiler add: 'error ifTrue: ['.
compiler codeError: 'at least one occurence expected'.
compiler add: '] ifFalse: ['.
compiler indent.
- compiler add: self retvalVar , ' add: ',elementVar , '.'.
-
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ (self retvalVar ~~ #whatever) ifTrue:[
+ compiler add: self retvalVar , ' add: ',elementVar , '.'.
+ ].
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:elementVar.
compiler add: '[ error ] whileFalse: ['.
compiler indent.
- compiler add: self retvalVar , ' add: ',elementVar , '.'.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ (self retvalVar ~~ #whatever) ifTrue:[
+ compiler add: self retvalVar , ' add: ',elementVar , '.'.
+ ].
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:elementVar.
compiler dedent.
compiler add: '].'.
compiler add: 'self clearError.'.
- compiler codeReturn: self retvalVar , ' asArray.'.
+ (self retvalVar ~~ #whatever) ifTrue:[
+ compiler codeReturn: self retvalVar , ' asArray.'.
+ ].
compiler dedent.
compiler add: '].'.
- "Modified (comment): / 23-04-2015 / 21:30:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 26-05-2015 / 19:04:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitPredicateNode: node
@@ -530,12 +778,14 @@
compiler smartRemember: node to: mementoVar.
].
- compiler codeStoreValueOf: [ self visit: (node children at: 1) ] intoVariable: #whatever.
+ compiler
+ codeAssignParsedValueOf:[ self visit:(node children at:1) ]
+ to:#whatever.
compiler add: 'error ifTrue: [ ^ failure ].'.
2 to: (node children size) do: [ :idx | |child|
child := node children at: idx.
- compiler codeStoreValueOf: [ self visit: child ] intoVariable: #whatever.
+ compiler codeAssignParsedValueOf:[ self visit:child ] to:#whatever.
child acceptsEpsilon ifFalse: [
compiler add: 'error ifTrue: [ '.
@@ -550,55 +800,43 @@
visitSequenceNode: node
- | elementVar mementoVar canBacktrack |
+ | elementVars mementoVar canBacktrack |
- elementVar := compiler allocateTemporaryVariableNamed: 'element'.
+ elementVars := node preferredChildrenVariableNames.
+ elementVars do:[:e |
+ compiler allocateTemporaryVariableNamed: e.
+ ].
+
canBacktrack := (node children allButFirst allSatisfy: [:e | e acceptsEpsilon ]) not.
-" self addGuardTrimming: node.
+" self addGuardTrimming: node.
self addGuard: node ifTrue: nil ifFalse: [ compiler addOnLine: ' ^ self error' ].
"
canBacktrack ifTrue: [
mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
compiler smartRemember: node to: mementoVar.
].
-
- compiler codeAssign: 'Array new: ', node children size asString, '.' to: self retvalVar.
- compiler codeStoreValueOf: [ self visit: (node children at: 1)] intoVariable: elementVar.
- compiler add: 'error ifTrue: [ ^ failure ].'.
- compiler add: self retvalVar , ' at: 1 put: ', elementVar, '.'.
-
- 2 to: (node children size) do: [ :idx | |child|
- child := node children at: idx.
- compiler codeStoreValueOf: [ self visit: child ] intoVariable: elementVar.
-
- child acceptsEpsilon ifFalse: [
- compiler add: 'error ifTrue: [ '.
- compiler indent.
- compiler smartRestore: node from: mementoVar.
- compiler add: '^ failure.'.
- compiler dedent.
- compiler add: '].'.
- ].
- compiler add: self retvalVar , ' at: ', idx asString, ' put: ',elementVar,'.'.
+ node returnParsedObjectsAsCollection ifTrue:[
+ compiler codeAssign: 'Array new: ', node children size asString, '.' to: self retvalVar.
].
+ self generateSequenceChildOf: node atIndex: 1 useMememntoVar: mementoVar storeResultInto: elementVars.
compiler codeReturn
- "Modified: / 23-04-2015 / 22:03:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 16-06-2015 / 06:38:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitStarAnyNode: node
| retvalVar sizeVar |
- retvalVar := compiler allocateReturnVariable.
+ retvalVar := self retvalVar.
sizeVar := compiler allocateTemporaryVariableNamed: 'size'.
compiler add: sizeVar , ' := context size - context position.'.
compiler add: retvalVar,' := Array new: ',sizeVar,'.'.
compiler add: '(1 to: ',sizeVar,') do: [ :e | ',retvalVar,' at: e put: context next ].'.
compiler codeReturn.
-
- "Modified: / 05-05-2015 / 14:13:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+
+ "Modified: / 15-06-2015 / 18:53:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitStarCharSetPredicateNode: node
@@ -639,11 +877,11 @@
self addGuard: node child ifTrue: nil ifFalse: [ compiler codeReturn: '#()' ].
compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:elementVar.
compiler add: '[ error ] whileFalse: ['.
compiler indent.
compiler add: self retvalVar, ' add: ', elementVar, '.'.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:elementVar.
compiler dedent.
compiler add: '].'.
compiler codeClearError.
@@ -654,7 +892,7 @@
| elementVar |
elementVar := compiler allocateTemporaryVariableNamed: 'element'.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:elementVar.
compiler add: 'error ifFalse: [ '.
compiler codeReturn: elementVar, ' ', node block asString, '.'.
compiler add: '] ifTrue: ['.
@@ -681,7 +919,7 @@
compiler profileTokenRead: (compiler idFor: node).
compiler codeAssign: 'context position + 1.' to: startVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:#whatever.
compiler add: 'error ifFalse: [ '.
compiler indent.
compiler codeAssign: 'context position.' to: endVar.
@@ -710,7 +948,7 @@
!
visitTokenWhitespaceNode: node
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:#whatever.
compiler codeReturn.
!
@@ -723,7 +961,9 @@
compiler smartRemember: node child to: mementoVar.
compiler add: 'context skipSeparators.'.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node child ]
+ to:self retvalVar.
compiler add: 'error ifTrue: [ '.
compiler indent.
@@ -763,7 +1003,7 @@
].
compiler codeAssign: 'context position + 1.' to: startVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:#whatever.
(arguments guards and: [(guard := PPCGuard on: node) makesSense]) ifTrue: [
compiler dedent.
@@ -802,9 +1042,11 @@
compiler codeClearError.
compiler add: '(', self retvalVar, ' := ', id, ' parseOn: context) isPetitFailure'.
compiler indent.
- compiler add: ' ifTrue: [self error: retval message at: ', self retvalVar, ' position ].'.
+ compiler add: ' ifTrue: [self error: ', self retvalVar, ' message at: ', self retvalVar, ' position ].'.
compiler dedent.
compiler add: 'error := ', self retvalVar, ' isPetitFailure.'.
compiler codeReturn.
+
+ "Modified: / 15-06-2015 / 17:59:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
--- a/compiler/PPCCompiler.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCCompiler.st Fri Jul 24 15:06:54 2015 +0100
@@ -17,21 +17,15 @@
new
"return an initialized instance"
- ^ self basicNew initializeForCompiledClassName: 'PPGeneratedParser'
-!
-
-newForCompiledClassName: aString
- "return an initialized instance"
- self halt: 'deprecated'.
- ^ self basicNew initializeForCompiledClassName: aString
+ ^ self on: PPCArguments default
!
on: aPPCArguments
"return an initialized instance"
^ self basicNew
- arguments: aPPCArguments;
- initializeForCompiledClassName: aPPCArguments name
+ arguments: aPPCArguments;
+ initializeForCompiledClassName: aPPCArguments parserName
! !
!PPCCompiler methodsFor:'accessing'!
@@ -71,12 +65,12 @@
!PPCCompiler methodsFor:'cleaning'!
clean: class
-" Transcript crShow: 'Cleaning time: ',
+" Transcript show: ('Cleaning time: ',
[
" self cleanGeneratedMethods: class.
self cleanInstVars: class.
self cleanConstants: class.
-" ] timeToRun asMilliSeconds asString, 'ms'."
+" ] timeToRun asMilliSeconds asString, 'ms'); cr. "
!
cleanConstants: class
@@ -117,8 +111,16 @@
currentMethod add: '"', string, '"'.
!
-addConstant: value as: name
+addConstant: value as: name
+ (constants includesKey: name) ifTrue:[
+ (constants at: name) ~= value ifTrue:[
+ self error:'Duplicate constant!!'.
+ ].
+ ^ self.
+ ].
constants at: name put: value
+
+ "Modified: / 29-05-2015 / 07:22:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
addOnLine: string
@@ -171,6 +173,12 @@
!PPCCompiler methodsFor:'code generation - coding'!
+code:aStringOrBlockOrRBParseNode
+ currentMethod code: aStringOrBlockOrRBParseNode
+
+ "Created: / 01-06-2015 / 23:49:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
codeAssign: code to: variable
self assert: variable isNil not.
@@ -181,10 +189,42 @@
]
!
+codeAssignParsedValueOf:aBlock to:aString
+ | tmpVarirable method |
+
+ self assert:aBlock isBlock.
+ self assert:aString isNil not.
+ tmpVarirable := returnVariable.
+ returnVariable := aString.
+ method := [
+ aBlock value
+ ] ensure:[ returnVariable := tmpVarirable ].
+ self assert: (method isKindOf: PPCMethod).
+ method isInline ifTrue:[
+ self callOnLine:method
+ ] ifFalse:[
+ self codeEvaluateAndAssign:(method call) to:aString.
+ ]
+
+ "Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeBlock: contents
+ currentMethod codeBlock: contents
+
+ "Created: / 01-06-2015 / 22:35:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
codeClearError
self add: 'self clearError.'.
!
+codeDot
+ self addOnLine:'.'.
+
+ "Created: / 16-06-2015 / 06:09:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
codeError
self add: 'self error: ''message notspecified''.'.
!
@@ -204,9 +244,9 @@
(variable == #whatever) ifFalse: [
"Do not assign, if somebody does not care!!"
self add: variable, ' ', selector,' ', argument.
- ] ifTrue: [
+ ] ifTrue: [
"In case argument has a side effect"
- self add: argument
+ self add: argument
]
!
@@ -237,6 +277,45 @@
"Modified: / 10-05-2015 / 07:39:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+codeIf: condition then: then
+ self codeIf: condition then: then else: nil
+
+ "Created: / 16-06-2015 / 06:07:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIf: condition then: then else: else
+ currentMethod
+ add: '(';
+ code: condition;
+ addOnLine: ')'.
+ then notNil ifTrue:[
+ currentMethod
+ addOnLine:' ifTrue:';
+ codeBlock: then.
+ ].
+ else notNil ifTrue:[
+ currentMethod
+ addOnLine:' ifFalse:';
+ codeBlock: else.
+ ].
+ self codeDot.
+
+ "Created: / 01-06-2015 / 22:43:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 16-06-2015 / 06:09:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIfErrorThen: then
+ ^ self codeIf: 'error' then: then else: nil
+
+ "Created: / 16-06-2015 / 06:06:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeIfErrorThen: then else: else
+ ^ self codeIf: 'error' then: then else: else
+
+ "Created: / 16-06-2015 / 06:05:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
codeNextToken
self add: 'self nextToken.'
@@ -244,28 +323,65 @@
"Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+codeProfileStart
+ self add: 'context methodInvoked: #', currentMethod methodName, '.'
+
+ "Created: / 01-06-2015 / 21:17:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeProfileStop
+ self add: 'context methodFinished: #', currentMethod methodName, '.'
+
+ "Created: / 01-06-2015 / 21:19:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
codeReturn
currentMethod isInline ifTrue: [
- "If inlined, the return variable already holds the value"
- ] ifFalse: [
- self add: '^ ', currentMethod returnVariable
- ].
+ "If inlined, the return variable already holds the value"
+ ] ifFalse: [
+ arguments profile ifTrue:[
+ self codeProfileStop.
+ ].
+ self add: '^ ', currentMethod returnVariable
+ ].
"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:49:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeReturn: code
" - returns whatever is in code OR
- assigns whatever is in code into the returnVariable"
- currentMethod isInline ifTrue:[
+ currentMethod isInline ifTrue:[
self codeEvaluateAndAssign: code to: currentMethod returnVariable.
- ] ifFalse: [
- self add: '^ ', code
+ ] ifFalse: [
+ arguments profile ifTrue:[
+ self codeProfileStop.
+ ].
+ self add: '^ ', code
]
"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:48:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeReturnParsedValueOf:aBlock
+ | tmpVarirable method |
+
+ self assert:aBlock isBlock.
+ tmpVarirable := returnVariable.
+ method := aBlock value.
+ self assert: returnVariable == tmpVarirable.
+ self assert: (method isKindOf: PPCMethod).
+ method isInline ifTrue:[
+ self callOnLine:method.
+ self codeReturn: returnVariable.
+ ] ifFalse:[
+ self codeReturn: method call.
+
+ ]
+
+ "Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeStoreValueOf: aBlock intoVariable: aString
@@ -419,12 +535,11 @@
currentMethod := PPCInlinedMethod new.
currentMethod id: id.
- currentMethod profile: arguments profile.
currentMethod returnVariable: returnVariable.
currentMethod indentationLevel: indentationLevel.
self push.
- "Modified: / 23-04-2015 / 18:28:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
startMethod: id
@@ -432,28 +547,29 @@
currentMethod := PPCMethod new.
currentMethod id: id.
- currentMethod profile: arguments profile.
+ arguments profile ifTrue:[
+ self codeProfileStart.
+ ].
self push.
self cache: id as: currentMethod.
- "Modified: / 23-04-2015 / 18:36:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:19:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stopInline
-
^ self pop.
- "Modified: / 23-04-2015 / 18:28:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:37:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stopMethod
- self cache: currentMethod methodName as: currentMethod.
-
- "arguments profile ifTrue: [ Transcript show: currentMethod code; cr. ]."
- ^ self pop.
+ self cache: currentMethod methodName as: currentMethod.
+
+ "arguments profile ifTrue: [ Transcript show: currentMethod code; cr. ]."
+ ^ self pop.
- "Modified: / 01-05-2015 / 14:18:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
top
@@ -462,13 +578,19 @@
!PPCCompiler methodsFor:'code generation - variables'!
-allocateReturnVariable
- "Return a new variable to store parsed value"
+allocateReturnVariable
+ ^ self allocateReturnVariableNamed: 'retval'
+
+ "Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 15-06-2015 / 17:52:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
- ^ currentMethod allocateReturnVariable
+allocateReturnVariableNamed: name
+ "Allocate (or return previously allocated one) temporary variable used for
+ storing a parser's return value (the parsed object)"
+ ^ currentMethod allocateReturnVariableNamed: name
- "Created: / 23-04-2015 / 17:58:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified (comment): / 23-04-2015 / 21:12:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Created: / 15-06-2015 / 18:04:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
allocateTemporaryVariableNamed: preferredName
@@ -527,7 +649,7 @@
self initialize.
compilerStack := Stack new.
cache := IdentityDictionary new.
- constants := IdentityDictionary new.
+ constants := Dictionary new.
ids := IdentityDictionary new.
@@ -550,6 +672,8 @@
Transcript cr; show: 'intialized for: ', aString; cr.
+
+ "Modified: / 26-05-2015 / 17:09:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCCompiler class methodsFor:'documentation'!
--- a/compiler/PPCConfiguration.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCConfiguration.st Fri Jul 24 15:06:54 2015 +0100
@@ -32,8 +32,8 @@
!PPCConfiguration methodsFor:'accessing'!
arguments
- arguments isNil ifTrue: [ arguments := self defaultArguments ].
- ^ arguments
+ arguments isNil ifTrue: [ arguments := self defaultArguments ].
+ ^ arguments
!
arguments: args
@@ -41,7 +41,7 @@
!
defaultArguments
- ^ PPCArguments default
+ ^ PPCArguments default
!
input: whatever
--- a/compiler/PPCContextMemento.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCContextMemento.st Fri Jul 24 15:06:54 2015 +0100
@@ -99,7 +99,7 @@
self keysAndValuesDo: [ :key :value |
(anObject hasProperty: key) ifFalse: [ ^ false ].
((anObject propertyAt: key) = value) ifFalse: [ ^ false ].
- ].
+ ].
^ true.
!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCFSACodeGen.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,211 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCCodeGen subclass:#PPCFSACodeGen
+ instanceVariableNames:'fsa backlinkStates'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Scanner'
+!
+
+!PPCFSACodeGen methodsFor:'accessing'!
+
+methodCategory
+ ^ 'generated - scanning'
+! !
+
+!PPCFSACodeGen methodsFor:'analysis'!
+
+beginOfRange: characterSet
+ characterSet withIndexDo: [ :e :index |
+ e ifTrue: [ ^ index ]
+ ].
+ self error: 'should not happend'
+!
+
+endOfRange: characterSet
+ | change |
+ change := false.
+ characterSet withIndexDo: [ :e :index |
+ e ifTrue: [ change := true ].
+ (e not and: [ change ]) ifTrue: [ ^ index - 1]
+ ].
+ ^ characterSet size
+!
+
+isLetter: characterSet
+ | changes previous |
+ changes := 0.
+ previous := false.
+ characterSet withIndexDo: [ :e :index |
+ (e == (Character codePoint: index) isLetter) ifFalse: [ ^ false ].
+ ].
+ ^ true
+!
+
+isSingleCharacter: characterSet
+ ^ (characterSet select: [ :e | e ]) size = 1
+!
+
+isSingleRange: characterSet
+ | changes previous |
+ changes := 0.
+ previous := false.
+ characterSet do: [ :e |
+ (e == previous) ifFalse: [ changes := changes + 1 ].
+ previous := e.
+ ].
+ ^ changes < 3
+! !
+
+!PPCFSACodeGen methodsFor:'coding'!
+
+codeAbsoluteReturn: code
+ self add: '^ ', code
+!
+
+codeAssertPeek: characterSet
+ | character id extendedCharacterSet |
+
+ (self isSingleCharacter: characterSet) ifTrue: [
+ character := self character: characterSet.
+ self addOnLine: 'self peek == ', character storeString.
+ ^ self
+ ].
+
+ (self isLetter: characterSet) ifTrue: [
+ self addOnLine: 'self peek isLetter'.
+ ^ self
+ ].
+
+ (self isSingleRange: characterSet) ifTrue: [
+ | begin end |
+ begin := self beginOfRange: characterSet.
+ end := self endOfRange: characterSet.
+ self addOnLine: 'self peekBetween: ', begin asString, ' and: ', end asString.
+ ^ self
+ ].
+
+ extendedCharacterSet := (characterSet asOrderedCollection addLast: false; yourself) asArray.
+ id := self idFor: characterSet prefixed: 'characterSet'.
+
+ self addConstant: extendedCharacterSet as: id.
+ self addOnLine: id, ' at: self peek asInteger'.
+!
+
+codeAssertPeek: characterSet ifTrue: block
+ self addOnLine: '('.
+ self codeAssertPeek: characterSet.
+ self addOnLine: ') ifTrue: ['.
+ self indent.
+ self code: block.
+ self dedent.
+ self add: ']'.
+!
+
+codeAssertPeek: characterSet orReturn: priority
+ self add: '('.
+ self codeAssertPeek: characterSet.
+ self addOnLine: ') ifFalse: [ '.
+ self codeReturnResult: priority.
+ self addOnLine: ']'.
+ self codeDot.
+!
+
+codeAssertPeek: characterSet whileTrue: block
+ self add: '['.
+ self codeAssertPeek: characterSet.
+ self addOnLine: '] whileTrue: ['.
+ self indent.
+ self code: block.
+ self dedent.
+ self add: '].'.
+ self nl.
+!
+
+codeEndBlock
+ self dedent.
+ self add: ']'.
+!
+
+codeEndBlockWhileTrue
+ self dedent.
+ self add: '] whileTrue.'.
+!
+
+codeIfFalse
+ self addOnLine: ' ifFalse: ['.
+!
+
+codeNextChar
+ self add: 'self step.'
+!
+
+codeNl
+ self add: ''.
+!
+
+codeNlAssertPeek: characterSet
+ self add: ''.
+ self codeAssertPeek: characterSet.
+!
+
+codeNlReturnResult
+ self add: '^ self return.'
+!
+
+codeNlReturnResult: priority
+ priority isNil ifTrue: [
+ ^ self codeNlReturnResult
+ ].
+ self add: '^ self returnPriority: ', priority asString, '.'
+!
+
+codeRecordMatch: state
+ self add: 'self recordMatch: ', state storeString, '.'
+!
+
+codeRecordMatch: state priority: priority
+ priority isNil ifTrue: [
+ ^ self codeRecordMatch: state
+ ].
+
+ self add: 'self recordMatch: ', state storeString, ' priority: ', priority asString, '.'
+!
+
+codeReturnResult
+ self addOnLine: '^ self return.'
+!
+
+codeReturnResult: priority
+ priority isNil ifTrue: [
+ ^ self codeReturnResult
+ ].
+
+ self addOnLine: '^ self returnPriority: ', priority asString, '.'
+!
+
+codeStartBlock
+ self add: '['.
+ self indent.
+! !
+
+!PPCFSACodeGen methodsFor:'helpers'!
+
+character: characterSet
+ self assert: (self isSingleCharacter: characterSet).
+ characterSet withIndexDo: [ :e :index | e ifTrue: [ ^ Character codePoint: index ] ].
+
+ self error: 'should not happen'
+! !
+
+!PPCFSACodeGen methodsFor:'intitialization'!
+
+initialize
+ super initialize.
+ backlinkStates := IdentityDictionary new.
+
+ "Modified: / 24-07-2015 / 15:03:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
--- a/compiler/PPCInlinedMethod.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCInlinedMethod.st Fri Jul 24 15:06:54 2015 +0100
@@ -6,7 +6,7 @@
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
- category:'PetitCompiler-Core'
+ category:'PetitCompiler-Compiler-Codegen'
!
!PPCInlinedMethod methodsFor:'as yet unclassified'!
@@ -16,7 +16,9 @@
!
code
- ^ buffer contents trimRight
+ ^ (String streamContents:[:s | buffer codeOn:s ]) trimRight
+
+ "Modified (format): / 01-06-2015 / 21:44:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
isInline
@@ -31,6 +33,12 @@
"Created: / 23-04-2015 / 21:06:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+allocateReturnVariableNamed: name
+ self error: 'return variable must be assigned by the non-inlined method....'
+
+ "Created: / 15-06-2015 / 17:52:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
allocateTemporaryVariableNamed:aString
self error: 'sorry, I can''t allocate variables....'
--- a/compiler/PPCInliningVisitor.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCInliningVisitor.st Fri Jul 24 15:06:54 2015 +0100
@@ -37,6 +37,13 @@
^ node
!
+visitActionNode: node
+ node child markForInline.
+ ^ super visitActionNode: node.
+
+ "Created: / 13-05-2015 / 16:25:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
visitCharSetPredicateNode: node
^ self markForInline: node
!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCMappedActionNode.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,19 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCActionNode subclass:#PPCMappedActionNode
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Nodes'
+!
+
+!PPCMappedActionNode methodsFor:'visiting'!
+
+accept: visitor
+ ^ visitor visitMappedActionNode: self
+
+ "Created: / 02-06-2015 / 17:27:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
--- a/compiler/PPCMethod.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCMethod.st Fri Jul 24 15:06:54 2015 +0100
@@ -3,11 +3,10 @@
"{ NameSpace: Smalltalk }"
Object subclass:#PPCMethod
- instanceVariableNames:'buffer variables indentation id profile variableForReturn
- category'
+ instanceVariableNames:'buffer id variableForReturn category profile'
classVariableNames:''
poolDictionaries:''
- category:'PetitCompiler-Core'
+ category:'PetitCompiler-Compiler-Codegen'
!
@@ -41,19 +40,30 @@
!
code
- ^ self methodName, Character cr asString,
- self variables, Character cr asString,
- self profilingBegin, Character cr asString,
- self body, Character cr asString
-" self profilingEnd"
+ ^ String streamContents: [ :s |
+ s nextPutAll: self methodName; cr.
+ buffer codeOn: s.
+ ]
- "Modified: / 23-04-2015 / 19:26:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:24:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
id: value
id := value
!
+indentationLevel
+ ^ buffer indentationLevel
+
+ "Created: / 01-06-2015 / 21:38:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+indentationLevel: anInteger
+ buffer indentationLevel: anInteger
+
+ "Created: / 01-06-2015 / 21:38:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
methodName
^ id
!
@@ -69,48 +79,88 @@
!PPCMethod methodsFor:'as yet unclassified'!
add: string
- self nl.
- indentation timesRepeat: [ buffer nextPut: Character tab ].
- self addOnLine: string.
+ buffer add: string
+
+ "Modified: / 01-06-2015 / 21:09:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
addOnLine: string
- buffer nextPutAll: string.
+ buffer addOnLine: string
+
+ "Modified: / 01-06-2015 / 21:09:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
call
^ 'self ', self methodName, '.'.
!
-nl
- ^ buffer nextPut: Character cr
-!
-
profilingBegin
self profile ifTrue: [
- ^ ' context methodInvoked: #', id, '.'
+ ^ ' context methodInvoked: #', id, '.'
].
^ ''
!
profilingEnd
self profile ifTrue: [
- ^ ' context methodFinished: #', id, '.'
+ ^ ' context methodFinished: #', id, '.'
].
^ ''
! !
-!PPCMethod methodsFor:'code generation - variables'!
+!PPCMethod methodsFor:'code generation'!
+
+code: aStringOrBlockOrRBParseNode
+ buffer code: aStringOrBlockOrRBParseNode.
+
+ "Created: / 01-06-2015 / 22:31:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 01-06-2015 / 23:50:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+codeBlock: contents
+ | outerBlock innerBlock |
+
+ outerBlock := buffer.
+ innerBlock := PPCCodeBlock new.
+ innerBlock indentationLevel: outerBlock indentationLevel + 1.
+ [
+ outerBlock addOnLine:'['.
+ buffer := innerBlock.
+ self code: contents.
+ ] ensure:[
+ outerBlock
+ code: (String streamContents:[:s | innerBlock codeOn: s]);
+ add:']'.
+ buffer := outerBlock.
+ ]
-addVariable: name
- (variables includes: name) ifTrue:[
- self error:'Duplicate variable name, must rename'.
- ].
- variables add: name.
+ "Created: / 01-06-2015 / 22:33:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 03-06-2015 / 06:11:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCMethod methodsFor:'code generation - indenting'!
+
+dedent
+ buffer dedent
+
+ "Created: / 01-06-2015 / 21:32:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
- "Modified: / 23-04-2015 / 12:29:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+indent
+ buffer indent
+
+ "Created: / 01-06-2015 / 21:32:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+nl
+
+ buffer nl
+
+ "Created: / 01-06-2015 / 21:52:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCMethod methodsFor:'code generation - variables'!
+
allocateReturnVariable
^ variableForReturn isNil ifTrue:[
@@ -122,65 +172,52 @@
"Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+allocateReturnVariableNamed: name
+ "Allocate temporary variable used for storing a parser's return value (the parsed object)"
+
+ variableForReturn notNil ifTrue:[
+ self error: 'Return variable already allocated!!'.
+ ^ self.
+ ].
+ variableForReturn := self allocateTemporaryVariableNamed: name.
+ ^ variableForReturn
+
+ "Created: / 15-06-2015 / 17:52:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
allocateTemporaryVariableNamed:preferredName
"Allocate a new variable with (preferably) given name.
Returns a real variable name that should be used."
-
- (variables includes:preferredName) ifFalse:[
- variables add:preferredName.
- ^ preferredName
- ] ifTrue:[
- | name |
- name := preferredName , '_' , (variables size + 1) printString.
- variables add:name.
- ^ name
- ].
+ ^ buffer allocateTemporaryVariableNamed: preferredName
"Created: / 23-04-2015 / 17:37:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:04:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
-returnVariable
- ^ variableForReturn
+returnVariable
+ ^ variableForReturn
"Created: / 23-04-2015 / 20:50:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 15-06-2015 / 18:12:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
returnVariable: aString
- ^ variableForReturn := aString
+ (variableForReturn notNil and:[variableForReturn ~= aString]) ifTrue:[
+ self error: 'Return variable already allocated with different name (''', variableForReturn , ''' vs ''', aString,''')'.
+ ].
+ variableForReturn := aString
"Created: / 23-04-2015 / 18:23:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 23-04-2015 / 21:08:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-!
-
-variables
- ^ ' | ', (variables inject: '' into: [ :s :e | s, ' ', e]), ' |'
-! !
-
-!PPCMethod methodsFor:'indentation'!
-
-dedent
- indentation := indentation - 1
-!
-
-indent
- indentation := indentation + 1
-!
-
-indentationLevel
- ^ indentation
-!
-
-indentationLevel: value
- indentation := value
+ "Modified: / 15-06-2015 / 18:14:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCMethod methodsFor:'initialization'!
initialize
- buffer := WriteStream on: ''.
- indentation := 1.
- variables := OrderedCollection new.
+ buffer := PPCCodeBlock new.
+
+ "Modified: / 01-06-2015 / 21:33:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCMethod methodsFor:'printing'!
--- a/compiler/PPCNilNode.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCNilNode.st Fri Jul 24 15:06:54 2015 +0100
@@ -9,6 +9,7 @@
category:'PetitCompiler-Nodes'
!
+
!PPCNilNode methodsFor:'accessing'!
prefix
@@ -35,3 +36,10 @@
^ visitor visitNilNode: self
! !
+!PPCNilNode class methodsFor:'documentation'!
+
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+! !
+
--- a/compiler/PPCNode.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCNode.st Fri Jul 24 15:06:54 2015 +0100
@@ -241,7 +241,7 @@
finite := self.
infinite := anotherNode.
] ifFalse: [
- finite := anotherNode.
+ finite := anotherNode.
infinite := self.
].
@@ -488,17 +488,32 @@
super printOn: aStream.
aStream nextPut: $(.
self printNameOn: aStream.
+ self isMarkedForInline ifTrue:[
+ aStream nextPutAll: ' INL'
+ ].
aStream nextPut: $)
+
+ "Modified: / 22-05-2015 / 15:34:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCNode methodsFor:'testing'!
+canHavePPCId
+ ^ true
+!
+
isMarkedForInline
^ self propertyAt: #inlined ifAbsent: [ false ].
"Created: / 23-04-2015 / 15:40:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+isSequenceNode
+ ^ false
+
+ "Created: / 15-06-2015 / 18:29:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
isTokenNode
^ false
!
@@ -513,6 +528,12 @@
^ self
!
+asFsa
+ | visitor |
+ visitor := PEGFsaGenerator new.
+ ^ visitor visit: self
+!
+
replace: node with: anotherNode
!
--- a/compiler/PPCNodeVisitor.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCNodeVisitor.st Fri Jul 24 15:06:54 2015 +0100
@@ -167,6 +167,12 @@
^ self visitNode: node.
!
+visitMappedActionNode: node
+ ^ self visitActionNode: node
+
+ "Created: / 02-06-2015 / 17:28:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
visitMessagePredicateNode: node
^ self visitNode: node
!
--- a/compiler/PPCProfilingContext.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCProfilingContext.st Fri Jul 24 15:06:54 2015 +0100
@@ -77,9 +77,9 @@
sender := thisContext sender.
selector := (sender receiver isKindOf: PPCompiledParser) ifTrue: [
- sender selector.
+ sender selector.
] ifFalse: [
- sender receiver class.
+ sender receiver class.
].
remembers add: selector.
^ super remember
@@ -90,9 +90,9 @@
sender := thisContext sender.
selector := (sender receiver isKindOf: PPCompiledParser) ifTrue: [
- sender selector.
+ sender selector.
] ifFalse: [
- sender receiver class.
+ sender receiver class.
].
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCScanner.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,80 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PPCScanner
+ instanceVariableNames:'matches stream maxPriority currentChar'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Scanner'
+!
+
+!PPCScanner methodsFor:'accessing'!
+
+stream
+ ^ stream
+!
+
+stream: anObject
+ stream := anObject
+! !
+
+!PPCScanner methodsFor:'as yet unclassified'!
+
+recordMatch: match
+ ^ self recordMatch: match priority: 0
+!
+
+recordMatch: match priority: currentPriority
+ (maxPriority < currentPriority) ifTrue: [
+ matches := IdentityDictionary new.
+ maxPriority := currentPriority.
+ ].
+
+ (maxPriority == currentPriority) ifTrue: [
+ matches at: match put: stream position
+ ].
+!
+
+return
+ ^ self returnPriority: SmallInteger minVal.
+!
+
+returnPriority: priority
+ (maxPriority < priority) ifTrue: [
+ ^ IdentityDictionary new
+ ].
+ ^ matches keysAndValuesRemove: [ :key :value | key class == PEGFsaFailure ]
+! !
+
+!PPCScanner methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ matches := IdentityDictionary new.
+ maxPriority := SmallInteger minVal.
+! !
+
+!PPCScanner methodsFor:'scanning'!
+
+consumeConditionally: character
+ ^ (stream peek == character) ifTrue: [ stream next. true ] ifFalse: [ false ]
+!
+
+next
+ stream next
+!
+
+peek
+ ^ currentChar
+!
+
+peekBetween: start and: stop
+ (currentChar == nil) ifTrue: [ ^ false ].
+ ^ start <= currentChar codePoint and: [ currentChar codePoint <= stop ]
+!
+
+step
+ currentChar := stream next
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCScannerCodeGenerator.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,306 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PPCScannerCodeGenerator
+ instanceVariableNames:'codeGen fsa backlinkStates backlinkTransitions arguments openSet
+ joinPoints incommingTransitions methodCache id'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Scanner'
+!
+
+!PPCScannerCodeGenerator methodsFor:'accessing'!
+
+arguments
+ ^ arguments
+!
+
+arguments: anObject
+ arguments := anObject
+! !
+
+!PPCScannerCodeGenerator methodsFor:'analysis'!
+
+analyzeBacklinks
+ backlinkTransitions := fsa backTransitions.
+ backlinkStates := IdentityDictionary new.
+
+ backlinkTransitions do: [ :t |
+ (self backlinksTo: (t destination)) add: t.
+ ].
+!
+
+analyzeJoinPoints
+ | joinTransitions |
+ joinTransitions := fsa joinTransitions.
+ joinTransitions := joinTransitions reject: [ :t | self isBacklinkDestination: t destination ].
+ joinPoints := IdentityDictionary new.
+
+ joinTransitions do: [ :t |
+ (joinPoints at: t destination ifAbsentPut: [ IdentitySet new ]) add: t.
+ ]
+
+!
+
+analyzeTransitions
+ | transitions |
+ transitions := fsa allTransitions.
+ incommingTransitions := IdentityDictionary new.
+ (self incommingTransitionsFor: fsa startState) add: #transitionStub.
+
+ transitions do: [ :t |
+ (self incommingTransitionsFor: t destination) add: t.
+ ].
+!
+
+backlinksTo: state
+ ^ backlinkStates at: state ifAbsentPut: [ OrderedCollection new ]
+!
+
+closedJoinPoints
+ | closed |
+ closed := IdentitySet new.
+
+ joinPoints keysAndValuesDo: [ :key :value |
+ value isEmpty ifTrue: [ closed add: key ].
+ ].
+
+ ^ closed
+!
+
+containsBacklink: state
+ state transitions do: [ :t |
+ (self isBacklink: t) ifTrue: [ ^ true ]
+ ].
+
+ ^ false
+!
+
+hasMultipleIncommings: state
+ ^ (incommingTransitions at: state ifAbsent: [ self error: 'should not happen']) size > 1
+!
+
+incommingTransitionsFor: state
+ ^ incommingTransitions at: state ifAbsentPut: [ IdentitySet new ]
+!
+
+isBacklink: transition
+ ^ backlinkTransitions includes: transition
+!
+
+isBacklinkDestination: state
+ ^ (self backlinksTo: state) isEmpty not
+!
+
+isJoinPoint: state
+ "Please note that joinPoints are removed as the compilaction proceeds"
+ ^ joinPoints keys includes: state
+!
+
+joinTransitionsTo: joinPoint "state"
+ ^ joinPoints at: joinPoint ifAbsent: [ #() ]
+! !
+
+!PPCScannerCodeGenerator methodsFor:'code generation'!
+
+generate
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+ self assert: fsa checkConsistency.
+
+
+ self analyzeBacklinks.
+ self analyzeJoinPoints.
+ self analyzeTransitions.
+
+ openSet := IdentitySet new.
+
+ codeGen startMethod: (codeGen idFor: fsa).
+ codeGen codeComment: (Character codePoint: 13) asString, fsa asString.
+
+ self generateFor: fsa startState.
+
+ codeGen stopMethod.
+
+ ^ self compileScannerClass new
+
+
+!
+
+generate: aPEGFsa
+ fsa := aPEGFsa.
+
+ fsa compact.
+ fsa checkSanity.
+
+ ^ self generate
+!
+
+generateFinalFor: state
+ state isFinal ifFalse: [ ^ self ].
+
+ codeGen codeRecordMatch: state retval priority: state priority.
+!
+
+generateFor: state
+" (self isJoinPoint: state) ifTrue: [
+ ^ codeGen codeComment: 'join point generation postponed...'
+ ].
+"
+ codeGen cachedValue: (codeGen idFor: state) ifPresent: [ :method |
+ "if state is already cached, it has multiple incomming links.
+ In such a case, it is compiled as a method, thus return immediatelly"
+ ^ codeGen codeAbsoluteReturn: method call
+ ].
+
+ self generateStartMethod: state.
+" (self isBacklinkDestination: state) ifTrue: [
+ codeGen codeStartBlock.
+ ].
+"
+ self generateFinalFor: state.
+ self generateNextFor: state.
+ self generateTransitionsFor: state.
+
+" (self isBacklinkDestination: state) ifTrue: [
+ codeGen codeEndBlockWhileTrue.
+ ].
+"
+ self generateStopMethod: state.
+!
+
+generateForSingleTransition: t from: state.
+
+ (self isJoinPoint: t destination) ifTrue: [ self removeJoinTransition: t ].
+
+ codeGen codeAssertPeek: (t characterSet) orReturn: state priority.
+" (self isBacklink: t) ifTrue: [
+ codeGen add: 'true'
+ ] ifFalse: [
+ self generateFor: t destination.
+ ]
+"
+ self generateFor: t destination
+!
+
+generateForTransition: t from: state
+ (self isJoinPoint: t destination) ifTrue: [ self removeJoinTransition: t ].
+
+" (self isBacklink: t) ifTrue: [
+ codeGen codeAssertPeek: (t characterSet) ifTrue: [
+ codeGen add: 'true'
+ ]
+ ] ifFalse: [
+ codeGen codeAssertPeek: (t characterSet) ifTrue: [.
+ self generateFor: t destination.
+ ].
+ ].
+"
+ codeGen codeAssertPeek: (t characterSet) ifTrue: [.
+ self generateFor: t destination.
+ ].
+ codeGen codeIfFalse.
+!
+
+generateNextFor: state
+ state transitions isEmpty ifTrue: [ ^ self ].
+ codeGen codeNextChar.
+!
+
+generateReturnFor: state
+ codeGen codeNlReturnResult: state priority.
+!
+
+generateStartMethod: state.
+ id := codeGen idFor: state.
+
+ codeGen codeComment: 'START - Generated from state: ', state asString.
+
+ (self hasMultipleIncommings: state) ifTrue: [
+ codeGen startMethod: id.
+ ] ifFalse: [
+ codeGen startInline: id.
+ ]
+!
+
+generateStopMethod: state
+ | |
+ (self hasMultipleIncommings: state) ifTrue: [
+ codeGen codeAbsoluteReturn: codeGen stopMethod call.
+ ] ifFalse: [
+ codeGen code: codeGen stopInline call.
+ ].
+ codeGen codeComment: 'STOP - Generated from state: ', state asString.
+!
+
+generateTransitionsFor: state
+ (state transitions size = 0) ifTrue: [
+ self generateReturnFor: state.
+ ^ self
+ ].
+
+ (state transitions size = 1) ifTrue: [
+ self generateForSingleTransition: state transitions anyOne from: state.
+ ^ self
+ ].
+
+
+ codeGen codeNl.
+ state transitions do: [ :t |
+ self generateForTransition: t from: state
+ ].
+
+ codeGen indent.
+ self generateReturnFor: state.
+ codeGen dedent.
+ codeGen codeNl.
+ state transitions size timesRepeat: [ codeGen addOnLine: ']' ].
+ codeGen addOnLine: '.'.
+
+
+" self closedJoinPoints isEmpty ifFalse: [
+ | jp |
+ self assert: self closedJoinPoints size == 1.
+
+ jp := self closedJoinPoints anyOne.
+ self removeJoinPoint: jp.
+ self generateFor: jp.
+ ]
+"
+! !
+
+!PPCScannerCodeGenerator methodsFor:'compiling'!
+
+compileScannerClass
+ | builder |
+ builder := PPCClassBuilder new.
+
+ builder compiledClassName: arguments scannerName.
+ builder compiledSuperclass: PPCScanner.
+ builder methodDictionary: codeGen methodDictionary.
+ builder constants: codeGen constants.
+
+ ^ builder compileClass.
+! !
+
+!PPCScannerCodeGenerator methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ codeGen := PPCFSACodeGen new.
+ arguments := PPCArguments default.
+! !
+
+!PPCScannerCodeGenerator methodsFor:'support'!
+
+removeJoinPoint: state
+ self assert: (joinPoints at: state) size = 0.
+ joinPoints removeKey: state
+!
+
+removeJoinTransition: t
+ (self joinTransitionsTo: t destination) remove: t ifAbsent: [ self error: 'this should not happen' ].
+! !
+
--- a/compiler/PPCSequenceNode.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCSequenceNode.st Fri Jul 24 15:06:54 2015 +0100
@@ -11,8 +11,58 @@
!PPCSequenceNode methodsFor:'accessing'!
+preferredChildrenVariableNames
+ "Return an array of preferred variable names of variables where to store
+ particular child's result value."
+
+ | names |
+
+ names := self propertyAt: #preferredChildrenVariableNames ifAbsent:[ nil ].
+ names notNil ifTrue:[ ^ names ].
+ names := OrderedCollection new.
+ self children do:[:child |
+ | id |
+
+ id := child name notNil ifTrue:[ child name ] ifFalse:[ 'c' ].
+ (names includes: id) ifTrue:[
+ | i |
+
+ i := 1.
+ [ names includes: (id , '_' , i printString) ] whileTrue:[
+ i := i + 1.
+ ].
+ id := (id , '_' , i printString).
+ ].
+ names add: id.
+ ].
+ self propertyAt: #preferredChildrenVariableNames put: names.
+ ^ names
+
+ "Created: / 04-06-2015 / 23:08:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+preferredChildrenVariableNames: aSequenceableCollection
+ "Sets an array of preferred variable names"
+
+ self propertyAt: #preferredChildrenVariableNames put: aSequenceableCollection
+
+ "Created: / 04-06-2015 / 23:09:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
prefix
^ #seq
+!
+
+returnParsedObjectsAsCollection
+ ^ self propertyAt: #returnParsedObjectsAsCollection ifAbsent:[ true ]
+
+ "Created: / 04-06-2015 / 23:43:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+returnParsedObjectsAsCollection: aBoolean
+ self propertyAt: #returnParsedObjectsAsCollection put: aBoolean
+
+ "Created: / 04-06-2015 / 23:43:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCSequenceNode methodsFor:'analysis'!
@@ -121,6 +171,14 @@
reject: [ :each | each isNullable ]) ] ]
! !
+!PPCSequenceNode methodsFor:'testing'!
+
+isSequenceNode
+ ^ true
+
+ "Created: / 15-06-2015 / 18:29:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
!PPCSequenceNode methodsFor:'visiting'!
accept: visitor
--- a/compiler/PPCSpecializingVisitor.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCSpecializingVisitor.st Fri Jul 24 15:06:54 2015 +0100
@@ -188,13 +188,15 @@
(node child isKindOf: PPCCharacterNode) ifTrue: [
self change.
^ PPCTrimmingCharacterTokenNode new
- name: node name;
+ child: node child;
whitespace: node whitespace;
tokenClass: node tokenClass;
- child: node child;
+ name: node name;
yourself
].
^ node
+
+ "Modified: / 21-05-2015 / 14:41:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
--- a/compiler/PPCTokenCodeGenerator.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCTokenCodeGenerator.st Fri Jul 24 15:06:54 2015 +0100
@@ -31,7 +31,9 @@
!PPCTokenCodeGenerator methodsFor:'visiting'!
visitOptionalNode: node
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node child ]
+ to:self retvalVar.
compiler codeAssign: 'false.' to: 'error'.
compiler codeReturn.
!
@@ -60,7 +62,7 @@
compiler codeAssign: 'context position + 1.' to: startVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:#whatever.
compiler add: 'error ifTrue: [ ^ error := false ].'.
compiler codeAssign: 'context position.' to: endVar.
@@ -109,7 +111,9 @@
to: 'currentTokenValue := ', self retvalVar.
compiler addComment: 'Consume Whitespace:'.
- compiler codeStoreValueOf: [ self visit: node whitespace ] intoVariable: #whatever.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node whitespace ]
+ to:#whatever.
compiler nl.
compiler add: '^ true'.
@@ -141,14 +145,16 @@
].
compiler codeAssign: 'context position + 1.' to: startVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
+ compiler codeAssignParsedValueOf:[ self visit:node child ] to:#whatever.
compiler add: 'error ifTrue: [ ^ error := false ].'.
compiler codeAssign: 'context position.' to: endVar.
compiler addComment: 'Consume Whitespace:'.
- compiler codeStoreValueOf: [ self visit: node whitespace ] intoVariable: #whatever.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node whitespace ]
+ to:#whatever.
compiler nl.
--- a/compiler/PPCTokenizingCodeGenerator.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCTokenizingCodeGenerator.st Fri Jul 24 15:06:54 2015 +0100
@@ -17,11 +17,11 @@
!
tokenGenerator
- ^ tokenGenerator isNil
- ifTrue: [ tokenGenerator := (PPCTokenCodeGenerator on: compiler)
- arguments: arguments;
- yourself ]
- ifFalse: [ tokenGenerator ]
+ tokenGenerator isNil ifTrue: [
+ tokenGenerator := PPCTokenCodeGenerator on: compiler.
+ tokenGenerator arguments: arguments.
+ ].
+ ^ tokenGenerator
!
tokenGenerator: whatever
@@ -50,7 +50,7 @@
trueBlock value.
compiler dedent.
falseBlock isNil ifTrue: [ compiler addOnLine: '].' ]
- ifFalse: [ compiler add: ']'. ]
+ ifFalse: [ compiler add: ']'. ]
].
falseBlock isNil ifFalse: [
compiler addOnLine: ' ifFalse: ['.
@@ -73,7 +73,9 @@
compiler smartRemember: node child to: mementoVar.
compiler codeAssign: '{ currentTokenValue . currentTokenType }.' to: currentTokenVar.
- compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node child ]
+ to:self retvalVar.
compiler smartRestore: node child from: mementoVar.
compiler codeAssign: '(', currentTokenVar, ' at: 1).' to: 'currentTokenValue'.
@@ -92,7 +94,7 @@
child acceptsEpsilon ifTrue: [
possibleError := false.
- compiler codeStoreValueOf: [ self visit: child ] intoVariable: self retvalVar.
+ compiler codeAssignParsedValueOf:[ self visit:child ] to:self retvalVar.
compiler codeReturn
] ifFalse: [
child firstSetWithTokens do: [ :first |
@@ -102,7 +104,7 @@
compiler add: '(self ', tokenMethodName asString, ')'.
compiler addOnLine: ' ifTrue: ['.
compiler indent.
- compiler codeStoreValueOf: [ self visit: child ] intoVariable: self retvalVar.
+ compiler codeAssignParsedValueOf:[ self visit:child ] to:self retvalVar.
compiler add: 'error ifFalse: ['.
compiler indent.
compiler codeReturn: self retvalVar.
@@ -127,9 +129,11 @@
!
visitDeterministicChoiceNode: node
- | dictionary |
+ | dictionary isInlined |
dictionary := IdentityDictionary new.
+ isInlined := node isMarkedForInline.
+
node children do: [ :child |
| firstSet |
firstSet := child firstSetWithTokens.
@@ -145,13 +149,21 @@
compiler add: '(self ', tokenMethodName asString, ')'.
compiler addOnLine: ' ifTrue: ['.
compiler indent.
- compiler codeStoreValueOf: [ self visit: child ] intoVariable: self retvalVar.
- compiler codeReturn: self retvalVar.
+ compiler codeReturnParsedValueOf:[ self visit:child ].
compiler dedent.
- compiler add: '].'
+ isInlined ifTrue:[
+ compiler add: '] ifFalse: ['
+ ] ifFalse:[
+ compiler add: '].'.
+ ]
].
+ compiler codeError: 'no choice found'.
+ isInlined ifTrue:[
+ node children size timesRepeat: [ compiler addOnLine: ']' ].
+ compiler addOnLine: '.'.
+ ]
- compiler codeError: 'no choice found'.
+ "Modified: / 21-05-2015 / 15:31:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visitTokenChoiceNode: node
@@ -198,7 +210,9 @@
self visit: node whitespace.
compiler codeHaltIfShiftPressed.
- compiler codeStoreValueOf: [ self visit: node parser ] intoVariable: self retvalVar.
+ compiler
+ codeAssignParsedValueOf:[ self visit:node parser ]
+ to:self retvalVar.
compiler codeReturn.
!
--- a/compiler/PPCTokenizingVisitor.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPCTokenizingVisitor.st Fri Jul 24 15:06:54 2015 +0100
@@ -18,17 +18,17 @@
tokens addLast: self eofToken.
tokens do: [ :token | token unmarkForInline ].
- whitespaceNode := tokens detect: [ :e | e isTrimmingTokenNode ] ifFound: [:token |
- token whitespace copy
- unmarkForInline;
- name: 'consumeWhitespace';
- yourself
- ] ifNone: [
- PPCNilNode new
- name: 'consumeWhitespace';
- yourself
- ].
-
+ whitespaceNode := tokens detect: [ :e | e isTrimmingTokenNode ] ifNone:[nil].
+ whitespaceNode notNil ifTrue:[
+ whitespaceNode := whitespaceNode whitespace copy
+ unmarkForInline;
+ name: 'consumeWhitespace';
+ yourself
+ ] ifFalse:[
+ whitespaceNode := (PPCNilNode new)
+ name: 'consumeWhitespace';
+ yourself
+ ].
tokenizerNode := PPCTokenChoiceNode new
children: tokens asArray;
name: 'nextToken';
@@ -42,7 +42,8 @@
yourself
].
^ parserNode
-
+
+ "Modified: / 12-05-2015 / 01:37:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
eofToken
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPMappedActionParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,36 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPActionParser subclass:#PPMappedActionParser
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Parsers'
+!
+
+!PPMappedActionParser methodsFor:'converting'!
+
+asCompilerNode
+ ^ PPCMappedActionNode new
+ name: self name;
+ block: block;
+ child: parser;
+ properties: properties;
+ parser: self;
+ yourself
+
+ "Created: / 02-06-2015 / 17:27:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPMappedActionParser methodsFor:'parsing'!
+
+parseOn: aPPContext
+ | element |
+ ^ (element := parser parseOn: aPPContext) isPetitFailure
+ ifFalse: [ block valueWithArguments: element ]
+ ifTrue: [ element ]
+
+ "Created: / 02-06-2015 / 17:15:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
--- a/compiler/PPTokenizingCompiledParser.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/PPTokenizingCompiledParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -3,7 +3,7 @@
"{ NameSpace: Smalltalk }"
PPCompiledParser subclass:#PPTokenizingCompiledParser
- instanceVariableNames:'currentTokenValue currentTokenType'
+ instanceVariableNames:'currentTokenValue currentTokenType scanner'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Parsers'
@@ -12,6 +12,7 @@
!PPTokenizingCompiledParser methodsFor:'tokenizing'!
consume: tokenType
+ self halt: 'deprecated'.
(self perform: tokenType) ifTrue: [
currentTokenType := nil.
^ currentTokenValue.
@@ -56,6 +57,7 @@
context noteFailure: failure.
error := false.
currentTokenType := nil.
+ scanner := PPCScanner new.
self consumeWhitespace.
retval := self perform: startSymbol.
--- a/compiler/abbrev.stc Thu May 21 14:12:22 2015 +0100
+++ b/compiler/abbrev.stc Fri Jul 24 15:06:54 2015 +0100
@@ -1,8 +1,17 @@
# automagically generated by the project definition
# this file is needed for stc to be able to compile modules independently.
# it provides information about a classes filename, category and especially namespace.
+PEGFsa PEGFsa stx:goodies/petitparser/compiler 'PetitCompiler-FSA' 0
+PEGFsaFailure PEGFsaFailure stx:goodies/petitparser/compiler 'PetitCompiler-FSA' 0
+PEGFsaInterpret PEGFsaInterpret stx:goodies/petitparser/compiler 'PetitCompiler-FSA' 0
+PEGFsaPair PEGFsaPair stx:goodies/petitparser/compiler 'PetitCompiler-FSA' 0
+PEGFsaState PEGFsaState stx:goodies/petitparser/compiler 'PetitCompiler-FSA' 0
+PEGFsaTransition PEGFsaTransition stx:goodies/petitparser/compiler 'PetitCompiler-FSA' 0
PPCArguments PPCArguments stx:goodies/petitparser/compiler 'PetitCompiler-Core' 0
PPCBridge PPCBridge stx:goodies/petitparser/compiler 'PetitCompiler-Core' 0
+PPCClassBuilder PPCClassBuilder stx:goodies/petitparser/compiler 'PetitCompiler-Core' 0
+PPCCodeBlock PPCCodeBlock stx:goodies/petitparser/compiler 'PetitCompiler-Compiler-Codegen' 0
+PPCCodeGen PPCCodeGen stx:goodies/petitparser/compiler 'PetitCompiler-Compiler-Codegen' 0
PPCCompiledMethod PPCCompiledMethod stx:goodies/petitparser/compiler 'PetitCompiler-Core' 0
PPCCompiler PPCCompiler stx:goodies/petitparser/compiler 'PetitCompiler-Compiler' 0
PPCCompilerTokenErrorStrategy PPCCompilerTokenErrorStrategy stx:goodies/petitparser/compiler 'PetitCompiler-Compiler' 0
@@ -13,13 +22,18 @@
PPCContext PPCContext stx:goodies/petitparser/compiler 'PetitCompiler-Context' 0
PPCContextMemento PPCContextMemento stx:goodies/petitparser/compiler 'PetitCompiler-Context' 0
PPCGuard PPCGuard stx:goodies/petitparser/compiler 'PetitCompiler-Guards' 0
-PPCMethod PPCMethod stx:goodies/petitparser/compiler 'PetitCompiler-Core' 0
+PPCMethod PPCMethod stx:goodies/petitparser/compiler 'PetitCompiler-Compiler-Codegen' 0
PPCNode PPCNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCNodeVisitor PPCNodeVisitor stx:goodies/petitparser/compiler 'PetitCompiler-Visitors' 0
PPCPluggableConfiguration PPCPluggableConfiguration stx:goodies/petitparser/compiler 'PetitCompiler-Core' 0
+PPCScanner PPCScanner stx:goodies/petitparser/compiler 'PetitCompiler-Scanner' 0
+PPCScannerCodeGenerator PPCScannerCodeGenerator stx:goodies/petitparser/compiler 'PetitCompiler-Scanner' 0
PPCTokenGuard PPCTokenGuard stx:goodies/petitparser/compiler 'PetitCompiler-Guards' 0
PPCompiledParser PPCompiledParser stx:goodies/petitparser/compiler 'PetitCompiler-Parsers' 4
+PPMappedActionParser PPMappedActionParser stx:goodies/petitparser/compiler 'PetitCompiler-Parsers' 0
stx_goodies_petitparser_compiler stx_goodies_petitparser_compiler stx:goodies/petitparser/compiler '* Projects & Packages *' 3
+FooScanner FooScanner stx:goodies/petitparser/compiler 'PetitCompiler-Scanner' 0
+PEGFsaGenerator PEGFsaGenerator stx:goodies/petitparser/compiler 'PetitCompiler-FSA' 0
PPCAbstractLiteralNode PPCAbstractLiteralNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCAbstractPredicateNode PPCAbstractPredicateNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCAnyNode PPCAnyNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
@@ -27,7 +41,8 @@
PPCCodeGenerator PPCCodeGenerator stx:goodies/petitparser/compiler 'PetitCompiler-Visitors' 0
PPCDelegateNode PPCDelegateNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCEndOfFileNode PPCEndOfFileNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
-PPCInlinedMethod PPCInlinedMethod stx:goodies/petitparser/compiler 'PetitCompiler-Core' 0
+PPCFSACodeGen PPCFSACodeGen stx:goodies/petitparser/compiler 'PetitCompiler-Scanner' 0
+PPCInlinedMethod PPCInlinedMethod stx:goodies/petitparser/compiler 'PetitCompiler-Compiler-Codegen' 0
PPCInliningVisitor PPCInliningVisitor stx:goodies/petitparser/compiler 'PetitCompiler-Visitors' 0
PPCListNode PPCListNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCNilNode PPCNilNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
@@ -86,5 +101,6 @@
PPCTokenChoiceNode PPCTokenChoiceNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCTrimNode PPCTrimNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCTrimmingCharacterTokenNode PPCTrimmingCharacterTokenNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
+PPCMappedActionNode PPCMappedActionNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCTokenStarMessagePredicateNode PPCTokenStarMessagePredicateNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
PPCTokenStarSeparatorNode PPCTokenStarSeparatorNode stx:goodies/petitparser/compiler 'PetitCompiler-Nodes' 0
--- a/compiler/bc.mak Thu May 21 14:12:22 2015 +0100
+++ b/compiler/bc.mak Fri Jul 24 15:06:54 2015 +0100
@@ -35,7 +35,7 @@
-LOCALINCLUDES= -I$(INCLUDE_TOP)\stx\goodies\petitparser -I$(INCLUDE_TOP)\stx\goodies\petitparser\analyzer -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\java -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk -I$(INCLUDE_TOP)\stx\libbasic -I$(INCLUDE_TOP)\stx\libbasic2
+LOCALINCLUDES= -I$(INCLUDE_TOP)\stx\goodies\petitparser -I$(INCLUDE_TOP)\stx\goodies\petitparser\analyzer -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\java -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk -I$(INCLUDE_TOP)\stx\goodies\refactoryBrowser\parser -I$(INCLUDE_TOP)\stx\libbasic -I$(INCLUDE_TOP)\stx\libbasic2 -I$(INCLUDE_TOP)\stx\libview
LOCALDEFINES=
STCLOCALOPT=-package=$(PACKAGE) -I. $(LOCALINCLUDES) -headerDir=. $(STCLOCALOPTIMIZATIONS) $(STCWARNINGS) $(LOCALDEFINES) -varPrefix=$(LIBNAME)
@@ -54,7 +54,6 @@
pushd ..\..\..\libbasic & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\refactoryBrowser\parser & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\libbasic2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
- pushd ..\..\..\libbasic3 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\libview & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd .. & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\libview2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
@@ -78,8 +77,17 @@
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
+$(OUTDIR)PEGFsa.$(O) PEGFsa.$(H): PEGFsa.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaFailure.$(O) PEGFsaFailure.$(H): PEGFsaFailure.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaInterpret.$(O) PEGFsaInterpret.$(H): PEGFsaInterpret.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaPair.$(O) PEGFsaPair.$(H): PEGFsaPair.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaState.$(O) PEGFsaState.$(H): PEGFsaState.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaTransition.$(O) PEGFsaTransition.$(H): PEGFsaTransition.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCArguments.$(O) PPCArguments.$(H): PPCArguments.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCBridge.$(O) PPCBridge.$(H): PPCBridge.st $(INCLUDE_TOP)\stx\goodies\petitparser\PPParser.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCClassBuilder.$(O) PPCClassBuilder.$(H): PPCClassBuilder.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCCodeBlock.$(O) PPCCodeBlock.$(H): PPCCodeBlock.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCCodeGen.$(O) PPCCodeGen.$(H): PPCCodeGen.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompiledMethod.$(O) PPCCompiledMethod.$(H): PPCCompiledMethod.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompiler.$(O) PPCCompiler.$(H): PPCCompiler.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompilerTokenErrorStrategy.$(O) PPCCompilerTokenErrorStrategy.$(H): PPCCompilerTokenErrorStrategy.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
@@ -94,9 +102,14 @@
$(OUTDIR)PPCNode.$(O) PPCNode.$(H): PPCNode.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCNodeVisitor.$(O) PPCNodeVisitor.$(H): PPCNodeVisitor.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCPluggableConfiguration.$(O) PPCPluggableConfiguration.$(H): PPCPluggableConfiguration.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCScanner.$(O) PPCScanner.$(H): PPCScanner.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCScannerCodeGenerator.$(O) PPCScannerCodeGenerator.$(H): PPCScannerCodeGenerator.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenGuard.$(O) PPCTokenGuard.$(H): PPCTokenGuard.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCompiledParser.$(O) PPCompiledParser.$(H): PPCompiledParser.st $(INCLUDE_TOP)\stx\goodies\petitparser\PPParser.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPMappedActionParser.$(O) PPMappedActionParser.$(H): PPMappedActionParser.st $(INCLUDE_TOP)\stx\goodies\petitparser\PPActionParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPDelegateParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPParser.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)stx_goodies_petitparser_compiler.$(O) stx_goodies_petitparser_compiler.$(H): stx_goodies_petitparser_compiler.st $(INCLUDE_TOP)\stx\libbasic\LibraryDefinition.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\ProjectDefinition.$(H) $(STCHDR)
+$(OUTDIR)FooScanner.$(O) FooScanner.$(H): FooScanner.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCScanner.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaGenerator.$(O) PEGFsaGenerator.$(H): PEGFsaGenerator.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNodeVisitor.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCAbstractLiteralNode.$(O) PPCAbstractLiteralNode.$(H): PPCAbstractLiteralNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCAbstractPredicateNode.$(O) PPCAbstractPredicateNode.$(H): PPCAbstractPredicateNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCAnyNode.$(O) PPCAnyNode.$(H): PPCAnyNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
@@ -104,6 +117,7 @@
$(OUTDIR)PPCCodeGenerator.$(O) PPCCodeGenerator.$(H): PPCCodeGenerator.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNodeVisitor.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCDelegateNode.$(O) PPCDelegateNode.$(H): PPCDelegateNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCEndOfFileNode.$(O) PPCEndOfFileNode.$(H): PPCEndOfFileNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCFSACodeGen.$(O) PPCFSACodeGen.$(H): PPCFSACodeGen.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCCodeGen.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCInlinedMethod.$(O) PPCInlinedMethod.$(H): PPCInlinedMethod.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCMethod.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCInliningVisitor.$(O) PPCInliningVisitor.$(H): PPCInliningVisitor.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNodeVisitor.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCListNode.$(O) PPCListNode.$(H): PPCListNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
@@ -163,6 +177,7 @@
$(OUTDIR)PPCTokenChoiceNode.$(O) PPCTokenChoiceNode.$(H): PPCTokenChoiceNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCChoiceNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCListNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCTrimNode.$(O) PPCTrimNode.$(H): PPCTrimNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCListNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCSequenceNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCTrimmingCharacterTokenNode.$(O) PPCTrimmingCharacterTokenNode.$(H): PPCTrimmingCharacterTokenNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCListNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCTrimmingTokenNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCMappedActionNode.$(O) PPCMappedActionNode.$(H): PPCMappedActionNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCAbstractActionNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCActionNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCDelegateNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenStarMessagePredicateNode.$(O) PPCTokenStarMessagePredicateNode.$(H): PPCTokenStarMessagePredicateNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCDelegateNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCStarMessagePredicateNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCStarNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenStarSeparatorNode.$(O) PPCTokenStarSeparatorNode.$(H): PPCTokenStarSeparatorNode.st $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCDelegateNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCStarMessagePredicateNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCStarNode.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\compiler\PPCTokenStarMessagePredicateNode.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)extensions.$(O): extensions.st $(INCLUDE_TOP)\stx\goodies\petitparser\PPActionParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPAndParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPCharSetPredicate.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPChoiceParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPCompositeParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPContext.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPDelegateParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPEndOfInputParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPEpsilonParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPFailure.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPFlattenParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPListParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPLiteralObjectParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPLiteralParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPLiteralSequenceParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPNotParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPOptionalParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPPluggableParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPPossessiveRepeatingParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPPredicateObjectParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPPredicateParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPRepeatingParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPSequenceParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPStream.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPToken.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPTokenParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPTrimmingParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\parsers\java\PPJavaWhitespaceParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk\PPSmalltalkGrammar.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk\PPSmalltalkTokenParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk\PPSmalltalkWhitespaceParser.$(H) $(INCLUDE_TOP)\stx\libbasic\Character.$(H) $(INCLUDE_TOP)\stx\libbasic\Magnitude.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\PeekableStream.$(H) $(INCLUDE_TOP)\stx\libbasic\PositionableStream.$(H) $(INCLUDE_TOP)\stx\libbasic\ReadStream.$(H) $(INCLUDE_TOP)\stx\libbasic\Stream.$(H) $(INCLUDE_TOP)\stx\libbasic\UndefinedObject.$(H) $(STCHDR)
--- a/compiler/benchmarks/Make.proto Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/Make.proto Fri Jul 24 15:06:54 2015 +0100
@@ -34,7 +34,7 @@
# add the path(es) here:,
# ********** OPTIONAL: MODIFY the next lines ***
# LOCALINCLUDES=-Ifoo -Ibar
-LOCALINCLUDES= -I$(INCLUDE_TOP)/stx/goodies/petitparser -I$(INCLUDE_TOP)/stx/goodies/petitparser/compiler -I$(INCLUDE_TOP)/stx/goodies/petitparser/compiler/tests/extras -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/java -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk -I$(INCLUDE_TOP)/stx/goodies/refactoryBrowser/parser -I$(INCLUDE_TOP)/stx/libbasic
+LOCALINCLUDES= -I$(INCLUDE_TOP)/stx/goodies/petitparser -I$(INCLUDE_TOP)/stx/goodies/petitparser/compiler -I$(INCLUDE_TOP)/stx/goodies/petitparser/compiler/tests/extras -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/java -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk -I$(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk/tests -I$(INCLUDE_TOP)/stx/goodies/petitparser/tests -I$(INCLUDE_TOP)/stx/goodies/refactoryBrowser/parser -I$(INCLUDE_TOP)/stx/goodies/sunit -I$(INCLUDE_TOP)/stx/libbasic
# if you need any additional defines for embedded C code,
@@ -102,6 +102,15 @@
# build all mandatory prerequisite packages (containing superclasses) for this package
prereq:
cd ../../../../libbasic && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../../refactoryBrowser/parser && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../../../libbasic2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../../../libview && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../ && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../../../libview2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../parsers/smalltalk && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../../sunit && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../tests && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
+ cd ../../parsers/smalltalk/tests && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
@@ -122,6 +131,7 @@
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
$(OUTDIR)PPCBenchmark.$(O) PPCBenchmark.$(H): PPCBenchmark.st $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCSmalltalkNoopParser.$(O) PPCSmalltalkNoopParser.$(H): PPCSmalltalkNoopParser.st $(INCLUDE_TOP)/stx/goodies/petitparser/PPCompositeParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPDelegateParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/PPParser.$(H) $(INCLUDE_TOP)/stx/goodies/petitparser/parsers/smalltalk/PPSmalltalkGrammar.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)stx_goodies_petitparser_compiler_benchmarks.$(O) stx_goodies_petitparser_compiler_benchmarks.$(H): stx_goodies_petitparser_compiler_benchmarks.st $(INCLUDE_TOP)/stx/libbasic/LibraryDefinition.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(INCLUDE_TOP)/stx/libbasic/ProjectDefinition.$(H) $(STCHDR)
# ENDMAKEDEPEND --- do not remove this line
--- a/compiler/benchmarks/Make.spec Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/Make.spec Fri Jul 24 15:06:54 2015 +0100
@@ -52,6 +52,7 @@
COMMON_CLASSES= \
PPCBenchmark \
+ PPCSmalltalkNoopParser \
stx_goodies_petitparser_compiler_benchmarks \
@@ -59,6 +60,7 @@
COMMON_OBJS= \
$(OUTDIR_SLASH)PPCBenchmark.$(O) \
+ $(OUTDIR_SLASH)PPCSmalltalkNoopParser.$(O) \
$(OUTDIR_SLASH)stx_goodies_petitparser_compiler_benchmarks.$(O) \
--- a/compiler/benchmarks/PPCBenchmark.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/PPCBenchmark.st Fri Jul 24 15:06:54 2015 +0100
@@ -30,7 +30,7 @@
].
^ (benchmarkSuiteClass class:self) run
- "
+ "
PPCBenchmark run.
"
!
@@ -47,6 +47,20 @@
"
PPCBenchmark run: #benchmarkRBParserC
"
+!
+
+spy: benchmark
+ | benchmarkInstanceClass |
+
+ benchmarkInstanceClass := Smalltalk at: #BenchmarkInstance.
+ benchmarkInstanceClass isNil ifTrue:[
+ self error: 'CalipeL is not loaded.'
+ ].
+
+ ^ (benchmarkInstanceClass class:self selector:benchmark) spy
+
+ "Created: / 11-05-2015 / 16:31:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 16-05-2015 / 19:19:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCBenchmark methodsFor:'benchmark support'!
@@ -370,6 +384,26 @@
input do: [ :source | parser parse: source withContext: context ]
!
+benchmarkSmalltalkNoopParserCompiledC
+ <setup: #setupSmalltalkNoopParserCompiled>
+ <teardown: #teardownSmalltalkNoopParserCompiled>
+ <benchmark: 'Petit Smalltalk Parser (noop)- Compiled'>
+
+ input do: [ :source | parser parse: source withContext: context ]
+
+ "Created: / 16-05-2015 / 09:45:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+benchmarkSmalltalkNoopParserTokenizedC
+ <setup: #setupSmalltalkNoopParserTokenized>
+ <teardown: #teardownSmalltalkNoopParserTokenized>
+ <benchmark: 'Petit Smalltalk Parser (noop) - Tokenized'>
+
+ input do: [ :source | parser parse: source withContext: context ]
+
+ "Created: / 16-05-2015 / 09:46:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
benchmarkSmalltalkParserC
<setup: #setupSmalltalkParser>
<benchmark: 'Petit Smalltalk Parser - Standard'>
@@ -384,6 +418,16 @@
input do: [ :source | parser parse: source withContext: context ]
+!
+
+benchmarkSmalltalkParserTokenizedC
+ <setup: #setupSmalltalkParserTokenized>
+ <teardown: #teardownSmalltalkParserTokenized>
+ <benchmark: 'Petit Smalltalk Parser - Tokenized'>
+
+ input do: [ :source | parser parse: source withContext: context ]
+
+ "Created: / 16-05-2015 / 09:45:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCBenchmark methodsFor:'intitialization'!
@@ -565,6 +609,28 @@
]
!
+setupSmalltalkNoopParserCompiled
+
+ configuration := PPCConfiguration universal.
+ parser := PPCSmalltalkNoopParser new compileWithConfiguration: configuration.
+ context := PPCContext new.
+ context initializeFor: parser.
+ input := sources smalltalkSourcesBig.
+
+ "Created: / 16-05-2015 / 09:44:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+setupSmalltalkNoopParserTokenized
+
+ configuration := PPCConfiguration LL1.
+ parser := PPCSmalltalkNoopParser new compileWithConfiguration: configuration.
+ context := PPCContext new.
+ context initializeFor: parser.
+ input := sources smalltalkSourcesBig.
+
+ "Created: / 16-05-2015 / 09:44:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
setupSmalltalkParser
parser := PPSmalltalkParser new.
@@ -617,6 +683,28 @@
parser class removeFromSystem.
!
+teardownSmalltalkNoopParserCompiled
+ parser class removeFromSystem.
+"
+ size := input inject: 0 into: [:r :e | r + e size ].
+ Transcript crShow: 'Compiled Grammar time: ', time asString.
+ Transcript crShow: 'Time per character: ', (time / size * 1000.0) asString, ' microseconds'.
+"
+
+ "Created: / 16-05-2015 / 09:44:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+teardownSmalltalkNoopParserTokenized
+ parser class removeFromSystem.
+"
+ size := input inject: 0 into: [:r :e | r + e size ].
+ Transcript crShow: 'Compiled Grammar time: ', time asString.
+ Transcript crShow: 'Time per character: ', (time / size * 1000.0) asString, ' microseconds'.
+"
+
+ "Created: / 16-05-2015 / 09:44:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
teardownSmalltalkParserCompiled
parser class removeFromSystem.
"
@@ -624,6 +712,17 @@
Transcript crShow: 'Compiled Grammar time: ', time asString.
Transcript crShow: 'Time per character: ', (time / size * 1000.0) asString, ' microseconds'.
"
+!
+
+teardownSmalltalkParserTokenized
+ parser class removeFromSystem.
+"
+ size := input inject: 0 into: [:r :e | r + e size ].
+ Transcript crShow: 'Compiled Grammar time: ', time asString.
+ Transcript crShow: 'Time per character: ', (time / size * 1000.0) asString, ' microseconds'.
+"
+
+ "Created: / 16-05-2015 / 09:47:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCBenchmark class methodsFor:'documentation'!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/benchmarks/PPCSmalltalkNoopParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,344 @@
+"{ Package: 'stx:goodies/petitparser/compiler/benchmarks' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPSmalltalkGrammar subclass:#PPCSmalltalkNoopParser
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Benchmarks-Parsers'
+!
+
+!PPCSmalltalkNoopParser methodsFor:'accessing'!
+
+startExpression
+ "Make the sequence node has a method node as its parent and that the source is set."
+
+ ^ ([ :stream | stream collection ] asParser and , super startExpression) map: [ :source :node |
+ (RBMethodNode selector: #doIt body: node)
+ source: source.
+ (node statements size = 1 and: [ node temporaries isEmpty ])
+ ifTrue: [ node statements first ]
+ ifFalse: [ node ] ]
+!
+
+startMethod
+ "Make sure the method node has the source code properly set."
+
+ ^ ([ :stream | stream collection ] asParser and , super startMethod)
+ map: [ :source :node | node source: source ]
+! !
+
+!PPCSmalltalkNoopParser methodsFor:'grammar'!
+
+array
+ ^ super array map: [ :openNode :statementNodes :closeNode | ]
+
+ "Modified: / 15-05-2015 / 08:54:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+expression
+ ^ super expression map: [ :variableNodes :expressionNodes | ]
+
+ "Modified: / 15-05-2015 / 08:55:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+method
+ ^ super method map: [ :methodNode :bodyNode | ]
+
+ "Modified (format): / 15-05-2015 / 08:55:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+methodDeclaration
+ ^ super methodDeclaration ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:55:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+methodSequence
+ ^ super methodSequence map: [ :periodNodes1 :pragmaNodes1 :periodNodes2 :tempNodes :periodNodes3 :pragmaNodes2 :periodNodes4 :statementNodes | ]
+
+ "Modified: / 15-05-2015 / 08:55:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+parens
+ ^ super parens map: [ :openToken :expressionNode :closeToken | ]
+
+ "Modified: / 15-05-2015 / 08:55:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+pragma
+ ^ super pragma ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:55:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+return
+ ^ super return map: [ :token :expressionNode | ]
+
+ "Modified: / 15-05-2015 / 08:55:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+sequence
+ ^ super sequence map: [ :tempNodes :periodNodes :statementNodes | ]
+
+ "Modified: / 15-05-2015 / 08:56:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+variable
+ ^ super variable ==> [ :token | ]
+
+ "Modified: / 15-05-2015 / 08:56:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCSmalltalkNoopParser methodsFor:'grammar-blocks'!
+
+block
+ ^ super block map: [ :leftToken :blockNode :rightToken | ]
+
+ "Modified: / 15-05-2015 / 08:56:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+blockArgument
+ ^ super blockArgument ==> #second
+!
+
+blockBody
+ ^ super blockBody
+ ==> [ :nodes | ]
+
+ "Modified: / 15-05-2015 / 08:56:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCSmalltalkNoopParser methodsFor:'grammar-literals'!
+
+arrayLiteral
+ ^ super arrayLiteral ==> [ :nodes | nodes ]
+
+ "Modified (format): / 15-05-2015 / 08:56:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+arrayLiteralArray
+ ^ super arrayLiteralArray ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:56:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+byteLiteral
+ ^ super byteLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:56:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+byteLiteralArray
+ ^ super byteLiteralArray ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:56:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+charLiteral
+ ^ super charLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+falseLiteral
+ ^ super falseLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+nilLiteral
+ ^ super nilLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+numberLiteral
+ ^ super numberLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+stringLiteral
+ ^ super stringLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+symbolLiteral
+ ^ super symbolLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+symbolLiteralArray
+ ^ super symbolLiteralArray ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trueLiteral
+ ^ super trueLiteral ==> [ :nodes | nodes ]
+
+ "Modified: / 15-05-2015 / 08:57:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCSmalltalkNoopParser methodsFor:'grammar-messages'!
+
+binaryExpression
+ ^ super binaryExpression map: [ :receiverNode :messageNodes | ]
+
+ "Modified: / 15-05-2015 / 08:57:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+cascadeExpression
+ ^ super cascadeExpression map: [ :receiverNode :messageNodes | ]
+
+ "Modified: / 15-05-2015 / 08:57:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+keywordExpression
+ ^ super keywordExpression map: [ :receiveNode :messageNode | ]
+
+ "Modified: / 15-05-2015 / 08:58:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+unaryExpression
+ ^ super unaryExpression map: [ :receiverNode :messageNodes | ]
+
+ "Modified: / 15-05-2015 / 08:58:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!PPCSmalltalkNoopParser methodsFor:'private'!
+
+addStatements: aCollection into: aNode
+ aCollection isNil
+ ifTrue: [ ^ aNode ].
+ aCollection do: [ :each |
+ each class == PPSmalltalkToken
+ ifFalse: [ aNode addNode: each ]
+ ifTrue: [
+ aNode statements isEmpty
+ ifTrue: [ aNode addComments: each comments ]
+ ifFalse: [ aNode statements last addComments: each comments ].
+ aNode periods: (aNode periods asOrderedCollection
+ addLast: each start;
+ yourself) ] ].
+ ^ aNode
+!
+
+build: aNode assignment: anArray
+ ^ anArray isEmpty
+ ifTrue: [ aNode ]
+ ifFalse: [
+ anArray reverse
+ inject: aNode
+ into: [ :result :each |
+ RBAssignmentNode
+ variable: each first
+ value: result
+ position: each second start ] ]
+!
+
+build: aNode cascade: anArray
+ | messages semicolons |
+ ^ (anArray isNil or: [ anArray isEmpty ])
+ ifTrue: [ aNode ]
+ ifFalse: [
+ messages := OrderedCollection new: anArray size + 1.
+ messages addLast: aNode.
+ semicolons := OrderedCollection new.
+ anArray do: [ :each |
+ messages addLast: (self
+ build: aNode receiver
+ messages: (Array with: each second)).
+ semicolons addLast: each first start ].
+ RBCascadeNode messages: messages semicolons: semicolons ]
+!
+
+build: aNode messages: anArray
+ ^ (anArray isNil or: [ anArray isEmpty ])
+ ifTrue: [ aNode ]
+ ifFalse: [
+ anArray
+ inject: aNode
+ into: [ :rec :msg |
+ msg isNil
+ ifTrue: [ rec ]
+ ifFalse: [
+ RBMessageNode
+ receiver: rec
+ selectorParts: msg first
+ arguments: msg second ] ] ]
+!
+
+build: aTempCollection sequence: aStatementCollection
+ | result |
+ result := self
+ addStatements: aStatementCollection
+ into: RBSequenceNode new.
+ aTempCollection isEmpty ifFalse: [
+ result
+ leftBar: aTempCollection first start
+ temporaries: aTempCollection second
+ rightBar: aTempCollection last start ].
+ ^ result
+!
+
+buildArray: aStatementCollection
+ ^ self addStatements: aStatementCollection into: RBArrayNode new
+!
+
+buildMethod: aMethodNode
+ aMethodNode selectorParts
+ do: [ :each | aMethodNode addComments: each comments ].
+ aMethodNode arguments
+ do: [ :each | aMethodNode addComments: each token comments ].
+ aMethodNode pragmas do: [ :pragma |
+ aMethodNode addComments: pragma comments.
+ pragma selectorParts
+ do: [ :each | aMethodNode addComments: each comments ].
+ pragma arguments do: [ :each |
+ each isLiteralArray
+ ifFalse: [ aMethodNode addComments: each token comments ] ].
+ pragma comments: nil ].
+ ^ aMethodNode
+!
+
+buildString: aString
+ (aString isEmpty or: [ aString first ~= $' or: [ aString last ~= $' ] ])
+ ifTrue: [ ^ aString ].
+ ^ (aString
+ copyFrom: 2
+ to: aString size - 1)
+ copyReplaceAll: ''''''
+ with: ''''
+! !
+
+!PPCSmalltalkNoopParser methodsFor:'token'!
+
+binaryToken
+ ^ super binaryToken ==> [ :token | token ]
+
+ "Modified: / 15-05-2015 / 08:54:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+identifierToken
+ ^ super identifierToken ==> [ :token | token ]
+
+ "Modified: / 15-05-2015 / 08:54:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+keywordToken
+ ^ super keywordToken ==> [ :token | token ]
+
+ "Modified: / 15-05-2015 / 08:54:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+unaryToken
+ ^ super unaryToken ==> [ :token | token ]
+
+ "Modified: / 15-05-2015 / 08:54:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/benchmarks/PPCSmalltalkNoopParserTests.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,19 @@
+"{ Package: 'stx:goodies/petitparser/compiler/benchmarks' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPSmalltalkGrammarTests subclass:#PPCSmalltalkNoopParserTests
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Benchmarks-Parsers-Tests'
+!
+
+!PPCSmalltalkNoopParserTests methodsFor:'accessing'!
+
+parserClass
+ ^ PPCSmalltalkNoopParser
+
+ "Created: / 15-05-2015 / 09:00:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
--- a/compiler/benchmarks/abbrev.stc Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/abbrev.stc Fri Jul 24 15:06:54 2015 +0100
@@ -2,4 +2,6 @@
# this file is needed for stc to be able to compile modules independently.
# it provides information about a classes filename, category and especially namespace.
PPCBenchmark PPCBenchmark stx:goodies/petitparser/compiler/benchmarks 'PetitCompiler-Benchmarks-Core' 0
+PPCSmalltalkNoopParser PPCSmalltalkNoopParser stx:goodies/petitparser/compiler/benchmarks 'PetitCompiler-Benchmarks-Parsers' 0
+PPCSmalltalkNoopParserTests PPCSmalltalkNoopParserTests stx:goodies/petitparser/compiler/benchmarks 'PetitCompiler-Benchmarks-Parsers-Tests' 1
stx_goodies_petitparser_compiler_benchmarks stx_goodies_petitparser_compiler_benchmarks stx:goodies/petitparser/compiler/benchmarks '* Projects & Packages *' 3
--- a/compiler/benchmarks/bc.mak Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/bc.mak Fri Jul 24 15:06:54 2015 +0100
@@ -35,7 +35,7 @@
-LOCALINCLUDES= -I$(INCLUDE_TOP)\stx\goodies\petitparser -I$(INCLUDE_TOP)\stx\goodies\petitparser\compiler -I$(INCLUDE_TOP)\stx\goodies\petitparser\compiler\tests\extras -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\java -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk -I$(INCLUDE_TOP)\stx\goodies\refactoryBrowser\parser -I$(INCLUDE_TOP)\stx\libbasic
+LOCALINCLUDES= -I$(INCLUDE_TOP)\stx\goodies\petitparser -I$(INCLUDE_TOP)\stx\goodies\petitparser\compiler -I$(INCLUDE_TOP)\stx\goodies\petitparser\compiler\tests\extras -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\java -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk -I$(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk\tests -I$(INCLUDE_TOP)\stx\goodies\petitparser\tests -I$(INCLUDE_TOP)\stx\goodies\refactoryBrowser\parser -I$(INCLUDE_TOP)\stx\goodies\sunit -I$(INCLUDE_TOP)\stx\libbasic
LOCALDEFINES=
STCLOCALOPT=-package=$(PACKAGE) -I. $(LOCALINCLUDES) -headerDir=. $(STCLOCALOPTIMIZATIONS) $(STCWARNINGS) $(LOCALDEFINES) -varPrefix=$(LIBNAME)
@@ -52,6 +52,15 @@
# build all mandatory prerequisite packages (containing superclasses) for this package
prereq:
pushd ..\..\..\..\libbasic & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\..\refactoryBrowser\parser & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\..\..\libbasic2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\..\..\libview & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\.. & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\..\..\libview2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\parsers\smalltalk & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\..\sunit & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\tests & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
+ pushd ..\..\parsers\smalltalk\tests & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
@@ -69,6 +78,7 @@
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
$(OUTDIR)PPCBenchmark.$(O) PPCBenchmark.$(H): PPCBenchmark.st $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCSmalltalkNoopParser.$(O) PPCSmalltalkNoopParser.$(H): PPCSmalltalkNoopParser.st $(INCLUDE_TOP)\stx\goodies\petitparser\PPCompositeParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPDelegateParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\PPParser.$(H) $(INCLUDE_TOP)\stx\goodies\petitparser\parsers\smalltalk\PPSmalltalkGrammar.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)stx_goodies_petitparser_compiler_benchmarks.$(O) stx_goodies_petitparser_compiler_benchmarks.$(H): stx_goodies_petitparser_compiler_benchmarks.st $(INCLUDE_TOP)\stx\libbasic\LibraryDefinition.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(INCLUDE_TOP)\stx\libbasic\ProjectDefinition.$(H) $(STCHDR)
# ENDMAKEDEPEND --- do not remove this line
--- a/compiler/benchmarks/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/compiler/benchmarks/libInit.cc Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/libInit.cc Fri Jul 24 15:06:54 2015 +0100
@@ -28,6 +28,7 @@
OBJ snd; struct __vmData__ *__pRT__; {
__BEGIN_PACKAGE2__("libstx_goodies_petitparser_compiler_benchmarks", _libstx_goodies_petitparser_compiler_benchmarks_Init, "stx:goodies/petitparser/compiler/benchmarks");
_PPCBenchmark_Init(pass,__pRT__,snd);
+_PPCSmalltalkNoopParser_Init(pass,__pRT__,snd);
_stx_137goodies_137petitparser_137compiler_137benchmarks_Init(pass,__pRT__,snd);
--- a/compiler/benchmarks/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\..\rules
@call find_mingw.bat
--- a/compiler/benchmarks/stx_goodies_petitparser_compiler_benchmarks.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/stx_goodies_petitparser_compiler_benchmarks.st Fri Jul 24 15:06:54 2015 +0100
@@ -56,6 +56,11 @@
by searching along the inheritance chain of all of my classes."
^ #(
+ #'stx:goodies/petitparser' "PPCompositeParser - superclass of PPCSmalltalkNoopParser"
+ #'stx:goodies/petitparser/parsers/smalltalk' "PPSmalltalkGrammar - superclass of PPCSmalltalkNoopParser"
+ #'stx:goodies/petitparser/parsers/smalltalk/tests' "PPSmalltalkGrammarTests - superclass of PPCSmalltalkNoopParserTests"
+ #'stx:goodies/petitparser/tests' "PPAbstractParserTest - superclass of PPCSmalltalkNoopParserTests"
+ #'stx:goodies/sunit' "TestAsserter - superclass of PPCSmalltalkNoopParserTests"
#'stx:libbasic' "LibraryDefinition - superclass of stx_goodies_petitparser_compiler_benchmarks"
)
!
@@ -71,12 +76,10 @@
by searching all classes (and their packages) which are referenced by my classes."
^ #(
- #'stx:goodies/petitparser' "PPContext - referenced by PPCBenchmark>>benchmarkSmalltalkParser"
#'stx:goodies/petitparser/compiler' "PPCConfiguration - referenced by PPCBenchmark>>benchmarkSmalltalkParserCompiled"
#'stx:goodies/petitparser/compiler/tests/extras' "PPCResources - referenced by PPCBenchmark>>initialize"
#'stx:goodies/petitparser/parsers/java' "PPJavaSyntax - referenced by PPCBenchmark>>benchmarkJavaSyntax"
- #'stx:goodies/petitparser/parsers/smalltalk' "PPSmalltalkGrammar - referenced by PPCBenchmark>>setupSmalltalkGrammar"
- #'stx:goodies/refactoryBrowser/parser' "RBParser - referenced by PPCBenchmark>>benchmarkRBParserC"
+ #'stx:goodies/refactoryBrowser/parser' "RBArrayNode - referenced by PPCSmalltalkNoopParser>>buildArray:"
)
!
@@ -101,6 +104,8 @@
^ #(
"<className> or (<className> attributes...) in load order"
PPCBenchmark
+ PPCSmalltalkNoopParser
+ (PPCSmalltalkNoopParserTests autoload)
#'stx_goodies_petitparser_compiler_benchmarks'
)
!
--- a/compiler/benchmarks/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/benchmarks/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/compiler/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/compiler/extensions.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/extensions.st Fri Jul 24 15:06:54 2015 +0100
@@ -8,6 +8,12 @@
!Object methodsFor:'*petitcompiler'!
+canHavePPCId
+ ^ false
+! !
+
+!Object methodsFor:'*petitcompiler'!
+
isInlinedMethod
^ false
! !
@@ -93,6 +99,17 @@
^ aPetitCompiler compileChoice: self
! !
+!PPCompositeParser methodsFor:'*petitcompiler'!
+
+asCompilerNode
+ ^ PPCForwardNode new
+ name: self name;
+ child: parser;
+ yourself
+
+ "Modified: / 22-05-2015 / 21:54:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
!PPContext methodsFor:'*petitcompiler'!
asCompiledParserContext
@@ -189,7 +206,9 @@
child: parser;
yourself
].
- ^ super asCompilerNode
+ ^ super asCompilerNode
+
+ "Modified: / 22-05-2015 / 21:53:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPDelegateParser methodsFor:'*petitcompiler'!
@@ -612,10 +631,20 @@
^ aCollection
! !
+!PPSequenceParser methodsFor:'*petitcompiler'!
+
+map: aBlock
+ ^ aBlock numArgs = self children size
+ ifTrue: [ PPMappedActionParser on: self block: aBlock ]
+ ifFalse: [ self error: aBlock numArgs asString , ' arguments expected.' ]
+
+ "Modified: / 02-06-2015 / 17:16:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
comment
- ^ $" asParser, $" asParser negate star, $" asParser.
+ ^ $" asParser, $" asParser negate star, $" asParser.
! !
!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
--- a/compiler/libInit.cc Thu May 21 14:12:22 2015 +0100
+++ b/compiler/libInit.cc Fri Jul 24 15:06:54 2015 +0100
@@ -27,8 +27,17 @@
void _libstx_goodies_petitparser_compiler_Init(pass, __pRT__, snd)
OBJ snd; struct __vmData__ *__pRT__; {
__BEGIN_PACKAGE2__("libstx_goodies_petitparser_compiler", _libstx_goodies_petitparser_compiler_Init, "stx:goodies/petitparser/compiler");
+_PEGFsa_Init(pass,__pRT__,snd);
+_PEGFsaFailure_Init(pass,__pRT__,snd);
+_PEGFsaInterpret_Init(pass,__pRT__,snd);
+_PEGFsaPair_Init(pass,__pRT__,snd);
+_PEGFsaState_Init(pass,__pRT__,snd);
+_PEGFsaTransition_Init(pass,__pRT__,snd);
_PPCArguments_Init(pass,__pRT__,snd);
_PPCBridge_Init(pass,__pRT__,snd);
+_PPCClassBuilder_Init(pass,__pRT__,snd);
+_PPCCodeBlock_Init(pass,__pRT__,snd);
+_PPCCodeGen_Init(pass,__pRT__,snd);
_PPCCompiledMethod_Init(pass,__pRT__,snd);
_PPCCompiler_Init(pass,__pRT__,snd);
_PPCCompilerTokenErrorStrategy_Init(pass,__pRT__,snd);
@@ -43,9 +52,14 @@
_PPCNode_Init(pass,__pRT__,snd);
_PPCNodeVisitor_Init(pass,__pRT__,snd);
_PPCPluggableConfiguration_Init(pass,__pRT__,snd);
+_PPCScanner_Init(pass,__pRT__,snd);
+_PPCScannerCodeGenerator_Init(pass,__pRT__,snd);
_PPCTokenGuard_Init(pass,__pRT__,snd);
_PPCompiledParser_Init(pass,__pRT__,snd);
+_PPMappedActionParser_Init(pass,__pRT__,snd);
_stx_137goodies_137petitparser_137compiler_Init(pass,__pRT__,snd);
+_FooScanner_Init(pass,__pRT__,snd);
+_PEGFsaGenerator_Init(pass,__pRT__,snd);
_PPCAbstractLiteralNode_Init(pass,__pRT__,snd);
_PPCAbstractPredicateNode_Init(pass,__pRT__,snd);
_PPCAnyNode_Init(pass,__pRT__,snd);
@@ -53,6 +67,7 @@
_PPCCodeGenerator_Init(pass,__pRT__,snd);
_PPCDelegateNode_Init(pass,__pRT__,snd);
_PPCEndOfFileNode_Init(pass,__pRT__,snd);
+_PPCFSACodeGen_Init(pass,__pRT__,snd);
_PPCInlinedMethod_Init(pass,__pRT__,snd);
_PPCInliningVisitor_Init(pass,__pRT__,snd);
_PPCListNode_Init(pass,__pRT__,snd);
@@ -112,6 +127,7 @@
_PPCTokenChoiceNode_Init(pass,__pRT__,snd);
_PPCTrimNode_Init(pass,__pRT__,snd);
_PPCTrimmingCharacterTokenNode_Init(pass,__pRT__,snd);
+_PPCMappedActionNode_Init(pass,__pRT__,snd);
_PPCTokenStarMessagePredicateNode_Init(pass,__pRT__,snd);
_PPCTokenStarSeparatorNode_Init(pass,__pRT__,snd);
--- a/compiler/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\rules
@call find_mingw.bat
--- a/compiler/stx_goodies_petitparser_compiler.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/stx_goodies_petitparser_compiler.st Fri Jul 24 15:06:54 2015 +0100
@@ -75,7 +75,9 @@
^ #(
#'stx:goodies/petitparser/analyzer' "PPSentinel - referenced by PPCompiledParser class>>referringParser"
- #'stx:libbasic2' "Stack - referenced by PPCCompiler>>initializeForCompiledClassName:"
+ #'stx:goodies/refactoryBrowser/parser' "RBAssignmentNode - referenced by PPCCodeGenerator>>visitActionNode:"
+ #'stx:libbasic2' "IdentityBag - referenced by PEGFsa>>checkTransitionsIdentity"
+ #'stx:libview' "Color - referenced by PEGFsa>>viewGraphOn:"
)
!
@@ -107,8 +109,17 @@
^ #(
"<className> or (<className> attributes...) in load order"
+ PEGFsa
+ PEGFsaFailure
+ PEGFsaInterpret
+ PEGFsaPair
+ PEGFsaState
+ PEGFsaTransition
PPCArguments
PPCBridge
+ PPCClassBuilder
+ PPCCodeBlock
+ PPCCodeGen
PPCCompiledMethod
PPCCompiler
PPCCompilerTokenErrorStrategy
@@ -123,9 +134,14 @@
PPCNode
PPCNodeVisitor
PPCPluggableConfiguration
+ PPCScanner
+ PPCScannerCodeGenerator
PPCTokenGuard
PPCompiledParser
+ PPMappedActionParser
#'stx_goodies_petitparser_compiler'
+ FooScanner
+ PEGFsaGenerator
PPCAbstractLiteralNode
PPCAbstractPredicateNode
PPCAnyNode
@@ -133,6 +149,7 @@
PPCCodeGenerator
PPCDelegateNode
PPCEndOfFileNode
+ PPCFSACodeGen
PPCInlinedMethod
PPCInliningVisitor
PPCListNode
@@ -192,6 +209,7 @@
PPCTokenChoiceNode
PPCTrimNode
PPCTrimmingCharacterTokenNode
+ PPCMappedActionNode
PPCTokenStarMessagePredicateNode
PPCTokenStarSeparatorNode
)
@@ -308,6 +326,9 @@
PPParser allNodesDo:seen:
PPSmalltalkWhitespaceParser hash
PPParser compileTokenizing
+ Object canHavePPCId
+ PPCompositeParser asCompilerNode
+ PPSequenceParser map:
)
! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/FooScannerTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,162 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#FooScannerTest
+ instanceVariableNames:'scanner result'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-Scanner'
+!
+
+!FooScannerTest methodsFor:'as yet unclassified'!
+
+fail: stream rule: rule
+ scanner initialize.
+ scanner stream: stream asPetitStream.
+ result := scanner perform: rule.
+
+ self assert: result isEmpty
+!
+
+fail: stream token: token rule: rule
+ self fail: stream token: token rule: rule position: stream size
+!
+
+fail: stream token: token rule: rule position: position
+ scanner initialize.
+ scanner stream: stream asPetitStream.
+ result := scanner perform: rule.
+
+ self assert: (result at: token ifAbsent: [nil]) isNil.
+!
+
+parse: stream token: token rule: rule
+ self parse: stream token: token rule: rule position: stream size.
+!
+
+parse: stream token: token rule: rule position: position
+ scanner initialize.
+ scanner stream: stream asPetitStream.
+ result := scanner perform: rule.
+
+ self assert: (result includesKey: token).
+ self assert: (result at: token) = position.
+!
+
+setUp
+ scanner := FooScanner new.
+!
+
+testA
+ self parse: 'aaa' token: #a rule: #nextTokenA position: 1.
+!
+
+testAAorA
+ self fail: 'a' token: #aa rule: #nextTokenAAorA.
+ self parse: 'aa' token: #aa rule: #nextTokenAAorA.
+ self parse: 'aaa' token: #aa rule: #nextTokenAAorA position: 2.
+
+ self parse: 'a' token: #a rule: #nextTokenAAorA.
+ self fail: 'aa' token: #a rule: #nextTokenAAorA.
+ self fail: 'aaa' token: #a rule: #nextTokenAAorA.
+
+ self fail: 'b' rule: #nextTokenAAorA.
+!
+
+testAAplusA
+ self parse: 'aaa' token: #AAplusA rule: #nextTokenAAplusA.
+ self parse: 'aaaaa' token: #AAplusA rule: #nextTokenAAplusA.
+
+ self fail: '' rule: #nextTokenAAplusA.
+ self fail: 'a' rule: #nextTokenAAplusA.
+ self fail: 'aa' rule: #nextTokenAAplusA.
+ self fail: 'aaaa' rule: #nextTokenAAplusA.
+!
+
+testAAstarA
+ self parse: 'a' token: #AAstarA rule: #nextTokenAAstarA.
+ self parse: 'aaa' token: #AAstarA rule: #nextTokenAAstarA.
+ self parse: 'aaaaa' token: #AAstarA rule: #nextTokenAAstarA.
+
+ self fail: '' rule: #nextTokenAAstarA.
+ self fail: 'aa' rule: #nextTokenAAstarA.
+ self fail: 'aaaa' rule: #nextTokenAAstarA.
+!
+
+testAB
+ self parse: 'ab' token: #b rule: #nextTokenAB position: 2.
+!
+
+testABorBC
+ self parse: 'ab' token: #ab rule: #nextTokenABorBC position: 2.
+ self parse: 'bc' token: #bc rule: #nextTokenABorBC position: 2.
+
+ self fail: 'ac' rule: #nextTokenABorBC.
+!
+
+testABstarA
+ self parse: 'a' token: #ABstarA rule: #nextTokenABstarA position: 1.
+ self parse: 'aa' token: #ABstarA rule: #nextTokenABstarA position: 1.
+ self parse: 'aba' token: #ABstarA rule: #nextTokenABstarA position: 3.
+ self parse: 'abaa' token: #ABstarA rule: #nextTokenABstarA position: 3.
+ self parse: 'ababa' token: #ABstarA rule: #nextTokenABstarA position: 5.
+
+ self fail: 'ab' rule: #nextTokenABstarA.
+ self fail: 'abab' rule: #nextTokenABstarA.
+
+ self fail: '' rule: #nextTokenABstarA.
+
+!
+
+testA_Bstar_A
+ self parse: 'aa' token: #A_Bstar_A rule: #nextTokenA_Bstar_A.
+ self parse: 'aba' token: #A_Bstar_A rule: #nextTokenA_Bstar_A.
+
+ self fail: '' rule: #nextTokenABstarA.
+ self fail: 'ab' rule: #nextTokenABstarA.
+!
+
+testAorAA
+ self fail: 'a' token: #aa rule: #nextTokenAorAA.
+ self fail: 'aa' token: #aa rule: #nextTokenAorAA.
+ self fail: 'aaa' token: #aa rule: #nextTokenAorAA.
+
+ self parse: 'a' token: #a rule: #nextTokenAorAA position: 1.
+ self parse: 'aa' token: #a rule: #nextTokenAorAA position: 1.
+ self parse: 'aaa' token: #a rule: #nextTokenAorAA position: 1.
+
+ self fail: 'b' rule: #nextTokenAAorA.
+!
+
+testAorB
+ self parse: 'a' token: #a rule: #nextTokenAorB.
+ self parse: 'b' token: #b rule: #nextTokenAorB.
+
+ self parse: 'ab' token: #a rule: #nextTokenAorB position: 1.
+ self fail: 'c' rule: #nextTokenAorB.
+ self fail: 'c' rule: #nextTokenAorB.
+!
+
+testAstarA
+ self fail: '' rule: #nextTokenAstarA.
+ self fail: 'a' rule: #nextTokenAstarA.
+ self fail: 'aa' rule: #nextTokenAstarA.
+ self fail: 'aaa' rule: #nextTokenAstarA.
+!
+
+testAstarB
+ self parse: 'ab' token: #AstarB rule: #nextTokenAstarB.
+ self parse: 'b' token: #AstarB rule: #nextTokenAstarB.
+ self parse: 'aaab' token: #AstarB rule: #nextTokenAstarB.
+
+ self fail: 'c' rule: #nextTokenAstarB.
+!
+
+testAuorA
+ self parse: 'a' token: #a1 rule: #nextTokenAuorA.
+ self parse: 'a' token: #a2 rule: #nextTokenAuorA.
+
+ self fail: 'b' rule: #nextTokenAuorA.
+! !
+
--- a/compiler/tests/Make.proto Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/Make.proto Fri Jul 24 15:06:54 2015 +0100
@@ -103,7 +103,6 @@
prereq:
cd ../../../../libbasic && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../libbasic2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
- cd ../../../../libbasic3 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../libview && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../ && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../libview2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
@@ -128,6 +127,15 @@
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
+$(OUTDIR)FooScannerTest.$(O) FooScannerTest.$(H): FooScannerTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaDeterminizationTest.$(O) PEGFsaDeterminizationTest.$(H): PEGFsaDeterminizationTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaGeneratorTest.$(O) PEGFsaGeneratorTest.$(H): PEGFsaGeneratorTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaInterpretTest.$(O) PEGFsaInterpretTest.$(H): PEGFsaInterpretTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaScannerIntegrationTest.$(O) PEGFsaScannerIntegrationTest.$(H): PEGFsaScannerIntegrationTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaStateTest.$(O) PEGFsaStateTest.$(H): PEGFsaStateTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaTest.$(O) PEGFsaTest.$(H): PEGFsaTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaTransitionTest.$(O) PEGFsaTransitionTest.$(H): PEGFsaTransitionTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCClassBuilderTest.$(O) PPCClassBuilderTest.$(H): PPCClassBuilderTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCCodeGeneratorTest.$(O) PPCCodeGeneratorTest.$(H): PPCCodeGeneratorTest.st $(INCLUDE_TOP)/stx/goodies/petitparser/tests/PPAbstractParserTest.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompilerTest.$(O) PPCCompilerTest.$(H): PPCCompilerTest.st $(INCLUDE_TOP)/stx/goodies/petitparser/tests/PPAbstractParserTest.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCContextMementoTest.$(O) PPCContextMementoTest.$(H): PPCContextMementoTest.st $(INCLUDE_TOP)/stx/goodies/petitparser/tests/PPContextMementoTest.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
@@ -144,6 +152,7 @@
$(OUTDIR)PPCOptimizeChoicesTest.$(O) PPCOptimizeChoicesTest.$(H): PPCOptimizeChoicesTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCRecognizerComponentDetectorTest.$(O) PPCRecognizerComponentDetectorTest.$(H): PPCRecognizerComponentDetectorTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCRecognizerComponentVisitorTest.$(O) PPCRecognizerComponentVisitorTest.$(H): PPCRecognizerComponentVisitorTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
+$(OUTDIR)PPCScannerCodeGeneratorTest.$(O) PPCScannerCodeGeneratorTest.$(H): PPCScannerCodeGeneratorTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCSpecializingVisitorTest.$(O) PPCSpecializingVisitorTest.$(H): PPCSpecializingVisitorTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenDetectorTest.$(O) PPCTokenDetectorTest.$(H): PPCTokenDetectorTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenGuardTest.$(O) PPCTokenGuardTest.$(H): PPCTokenGuardTest.st $(INCLUDE_TOP)/stx/goodies/sunit/TestAsserter.$(H) $(INCLUDE_TOP)/stx/goodies/sunit/TestCase.$(H) $(INCLUDE_TOP)/stx/libbasic/Object.$(H) $(STCHDR)
--- a/compiler/tests/Make.spec Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/Make.spec Fri Jul 24 15:06:54 2015 +0100
@@ -51,6 +51,15 @@
STCWARNINGS=-warnNonStandard
COMMON_CLASSES= \
+ FooScannerTest \
+ PEGFsaDeterminizationTest \
+ PEGFsaGeneratorTest \
+ PEGFsaInterpretTest \
+ PEGFsaScannerIntegrationTest \
+ PEGFsaStateTest \
+ PEGFsaTest \
+ PEGFsaTransitionTest \
+ PPCClassBuilderTest \
PPCCodeGeneratorTest \
PPCCompilerTest \
PPCContextMementoTest \
@@ -67,6 +76,7 @@
PPCOptimizeChoicesTest \
PPCRecognizerComponentDetectorTest \
PPCRecognizerComponentVisitorTest \
+ PPCScannerCodeGeneratorTest \
PPCSpecializingVisitorTest \
PPCTokenDetectorTest \
PPCTokenGuardTest \
@@ -81,6 +91,15 @@
COMMON_OBJS= \
+ $(OUTDIR_SLASH)FooScannerTest.$(O) \
+ $(OUTDIR_SLASH)PEGFsaDeterminizationTest.$(O) \
+ $(OUTDIR_SLASH)PEGFsaGeneratorTest.$(O) \
+ $(OUTDIR_SLASH)PEGFsaInterpretTest.$(O) \
+ $(OUTDIR_SLASH)PEGFsaScannerIntegrationTest.$(O) \
+ $(OUTDIR_SLASH)PEGFsaStateTest.$(O) \
+ $(OUTDIR_SLASH)PEGFsaTest.$(O) \
+ $(OUTDIR_SLASH)PEGFsaTransitionTest.$(O) \
+ $(OUTDIR_SLASH)PPCClassBuilderTest.$(O) \
$(OUTDIR_SLASH)PPCCodeGeneratorTest.$(O) \
$(OUTDIR_SLASH)PPCCompilerTest.$(O) \
$(OUTDIR_SLASH)PPCContextMementoTest.$(O) \
@@ -97,6 +116,7 @@
$(OUTDIR_SLASH)PPCOptimizeChoicesTest.$(O) \
$(OUTDIR_SLASH)PPCRecognizerComponentDetectorTest.$(O) \
$(OUTDIR_SLASH)PPCRecognizerComponentVisitorTest.$(O) \
+ $(OUTDIR_SLASH)PPCScannerCodeGeneratorTest.$(O) \
$(OUTDIR_SLASH)PPCSpecializingVisitorTest.$(O) \
$(OUTDIR_SLASH)PPCTokenDetectorTest.$(O) \
$(OUTDIR_SLASH)PPCTokenGuardTest.$(O) \
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PEGFsaDeterminizationTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,259 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PEGFsaDeterminizationTest
+ instanceVariableNames:'fsa a b c result d interpreter e'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-FSA'
+!
+
+!PEGFsaDeterminizationTest methodsFor:'as yet unclassified'!
+
+assert: anFsa fail: input
+ | stream |
+ stream := input asPetitStream.
+
+ result := interpreter interpret: anFsa on: stream.
+
+ self assert: result isEmpty.
+ ^ result
+!
+
+assert: anFsa parse: input retval: name
+ ^ self assert: anFsa parse: input retval: name end: input size
+!
+
+assert: anFsa parse: input retval: name end: end
+ | stream |
+ stream := input asPetitStream.
+
+ result := interpreter interpret: anFsa on: stream.
+
+ self assert: result isEmpty not.
+ self assert: ((result at: name) = end) description: 'wrong position'.
+
+ ^ result
+!
+
+assertFail: name
+ self assert: (result includesKey: name) not
+!
+
+assertPass: name
+ self assert: (result includesKey: name)
+!
+
+setUp
+ a := PEGFsaState new name: #a; retval: #a; yourself.
+ b := PEGFsaState new name: #b; retval: #b; yourself.
+ c := PEGFsaState new name: #c; retval: #c; yourself.
+ d := PEGFsaState new name: #d; retval: #d; yourself.
+ e := PEGFsaState new name: #e; retval: #e; yourself.
+
+ fsa := PEGFsa new.
+
+ interpreter := PEGFsaInterpret new
+ yourself.
+!
+
+testAAplusA
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: e.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: c to: a.
+ fsa addTransitionFrom: c to: d priority: -1.
+ fsa addTransitionFrom: d to: e on: $a.
+
+ c priority: 0.
+
+ fsa determinize.
+
+" self assert: fsa states size = 3."
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'aa'.
+ self assert: fsa fail: 'aaaa'.
+
+ self assert: fsa parse: 'aaa' retval: #e.
+ self assert: fsa parse: 'aaaaa' retval: #e.
+ self assert: fsa parse: 'aaaaaaa' retval: #e.
+!
+
+testAB
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: c to: d on: $b.
+ fsa addTransitionFrom: b to: c priority: -1.
+
+ fsa determinize.
+
+ self assert: fsa states size = 3.
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: fsa parse: 'ab' retval: #d.
+ self assert: fsa parse: 'abc' retval: #d end: 2.
+
+ self assert: fsa fail: 'ac'.
+!
+
+testAPlusA
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: a.
+ fsa addTransitionFrom: b to: c priority: -1.
+ fsa addTransitionFrom: c to: d on: $a.
+
+ b priority: 0.
+
+ fsa determinize.
+
+" self assert: fsa states size = 2."
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'aa'.
+ self assert: fsa fail: 'b'.
+!
+
+testAPlusB
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: a.
+ fsa addTransitionFrom: b to: c priority: -1.
+ fsa addTransitionFrom: c to: d on: $b.
+
+ fsa determinize.
+
+ self assert: fsa states size = 3.
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: fsa parse: 'ab' retval: #d.
+ self assert: fsa parse: 'aaaab' retval: #d.
+ self assert: fsa parse: 'aaaabc' retval: #d end: 5.
+
+ self assert: fsa fail: 'b'.
+!
+
+testAorA
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: a to: d.
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: d to: e on: $a.
+
+ c priority: 0.
+ e priority: 0.
+
+ fsa determinize.
+
+ self assert: fsa states size = 2.
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: fsa parse: 'a' retval: #c.
+ self assert: fsa parse: 'a' retval: #e.
+ self assert: (a transitions allSatisfy: [:t | t priority = 0]).
+
+ self assert: fsa fail: 'b'.
+!
+
+testApriorityOrA
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+ c priority: 0.
+ e priority: 0.
+
+ fsa addTransitionFrom: a to: b priority: -1.
+ fsa addTransitionFrom: a to: d.
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: d to: e on: $a.
+
+ fsa determinize.
+
+ self assert: fsa states size = 2.
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: fsa parse: 'a' retval: #e.
+ self assertFail: #c.
+
+ self assert: fsa fail: 'b'.
+!
+
+testApriorityOrA2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+ c priority: 0.
+ e priority: 0.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: a to: d priority: -1.
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: d to: e on: $a.
+
+ fsa determinize.
+
+ self assert: fsa states size = 2.
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: fsa parse: 'a' retval: #c.
+ self assertFail: #e.
+
+ self assert: fsa fail: 'b'.
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PEGFsaGeneratorTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,466 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PEGFsaGeneratorTest
+ instanceVariableNames:'result node fsa generator interpreter'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-FSA'
+!
+
+
+!PEGFsaGeneratorTest methodsFor:'as yet unclassified'!
+
+assert: anFsa fail: input
+ | stream |
+ stream := input asPetitStream.
+
+ result := interpreter interpret: anFsa on: stream.
+
+ self assert: result isEmpty.
+ ^ result
+!
+
+assert: interpret parse: input
+ ^ self assert: interpret parse: input end: input size
+!
+
+assert: anFsa parse: input end: end
+ | stream |
+ stream := input asPetitStream.
+
+ result := interpreter interpret: anFsa on: stream.
+
+ self assert: result isEmpty not.
+ self assert: (result values anySatisfy: [ :pos | pos = end ]) description: 'wrong position'.
+
+ ^ result
+!
+
+fsaFrom: aNode
+ ^ (aNode accept: generator)
+ compact;
+ yourself
+!
+
+setUp
+ super setUp.
+ generator := PEGFsaGenerator new.
+ interpreter := PEGFsaInterpret new.
+!
+
+testAAA_Aplusnot
+ | parser |
+ parser := 'aaa' asParser not, $a asParser plus.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'a'.
+ self assert: fsa parse: 'aa'.
+ self assert: fsa fail: ''.
+ self assert: fsa fail: 'aaa'.
+ self assert: fsa fail: 'aaaa'.
+ self assert: fsa fail: 'aaaaa'.
+!
+
+testAAplusA
+ | parser |
+ parser := 'aa' asParser plus, $a asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'aaa'.
+ self assert: fsa parse: 'aaaaa'.
+ self assert: fsa parse: 'aaaaaaa'.
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'aa'.
+ self assert: fsa fail: 'aaaa'.
+!
+
+testAAplusB
+ | parser |
+ parser := 'aa' asParser plus, $b asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'aab'.
+ self assert: fsa parse: 'aaaab'.
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'aa'.
+ self assert: fsa fail: 'aaaa'.
+ self assert: fsa fail: 'aaaac'.
+!
+
+testAB
+ | parser |
+ parser := $a asParser, $b asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'ab'.
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'b'.
+ self assert: fsa fail: 'ac'.
+!
+
+testA_Boptional
+ | parser |
+ parser := $a asParser, $b asParser optional.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'ab'.
+ self assert: fsa parse: 'ac' end: 1.
+ self assert: fsa parse: 'a'.
+ self assert: fsa fail: 'b'.
+!
+
+testA_Boptionaloptional
+ | parser |
+ parser := ($a asParser, $b asParser optional) optional.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: ''.
+ self assert: fsa parse: 'a'.
+ self assert: fsa parse: 'ab'.
+ self assert: fsa parse: 'b' end: 0.
+!
+
+testA_BorC_D
+ | parser |
+ parser := $a asParser, ($b asParser / $c asParser), $d asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'abd'.
+ self assert: fsa parse: 'acd'.
+ self assert: fsa fail: 'abc'.
+ self assert: fsa fail: 'add'.
+ self assert: fsa fail: 'ad'.
+!
+
+testAorAA
+ | parser |
+ parser := 'a' asParser / 'aa' asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'a'.
+ self assert: fsa parse: 'aa' end: 1.
+ self assert: fsa parse: 'aaaaaaa' end: 1.
+ self assert: fsa fail: ''.
+ self assert: fsa fail: 'b'.
+!
+
+testAorAX_X
+ | parser |
+ parser := ('a' asParser / 'ax' asParser), $x asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'ax'.
+ self assert: fsa parse: 'axx' end: 2.
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'x'.
+ self assert: fsa fail: ''.
+!
+
+testAorBC_X
+ | parser |
+ parser := ('a' asParser / 'bc' asParser), $x asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'ax'.
+ self assert: fsa parse: 'bcx' end: 3.
+ self assert: fsa fail: 'bx'.
+ self assert: fsa fail: 'cx'.
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'bc'.
+!
+
+testAorB_Coptionaloptional
+ | parser |
+ parser := (($a asParser / $b asParser), $c asParser optional) optional.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: ''.
+ self assert: fsa parse: 'a'.
+ self assert: fsa parse: 'b'.
+ self assert: fsa parse: 'ac'.
+ self assert: fsa parse: 'bc'.
+ self assert: fsa parse: 'ad' end: 1.
+ self assert: fsa parse: 'bd' end: 1.
+ self assert: fsa parse: 'd' end: 0.
+ self assert: fsa parse: 'c' end: 0.
+!
+
+testAstarA
+ | parser |
+ parser := $a asParser star, $a asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'aa'.
+ self assert: fsa fail: 'aaa'.
+!
+
+testAstarB
+ | parser |
+ parser := $a asParser star, $b asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'b'.
+ self assert: fsa parse: 'ab'.
+ self assert: fsa parse: 'aaab'.
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'ac'.
+ self assert: fsa fail: 'aac'.
+!
+
+testCharSet
+ | parser |
+ parser := #letter asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'a'.
+ self assert: fsa parse: 'z'.
+ self assert: fsa parse: 'A'.
+ self assert: fsa parse: 'Z'.
+ self assert: fsa fail: '_'.
+ self assert: fsa fail: '()'.
+ self assert: fsa fail: ''.
+!
+
+testCharSetPredicateNode
+ node := PPCCharSetPredicateNode new
+ predicate: (PPCharSetPredicate on: [ :e | e = $a ]);
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'a' end: 1.
+ self assert: fsa parse: 'ab' end: 1.
+ self assert: fsa fail: 'b'.
+!
+
+testCharSetPredicateNode2
+ node := PPCCharSetPredicateNode new
+ predicate: (PPCharSetPredicate on: [ :e | e isDigit ]);
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: '1' end: 1.
+ self assert: fsa parse: '0' end: 1.
+ self assert: fsa parse: '5' end: 1.
+ self assert: fsa fail: 'a'.
+!
+
+testCharacterNode
+ node := PPCCharacterNode new
+ character: $a;
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'a' end: 1.
+ self assert: fsa parse: 'ab' end: 1.
+ self assert: fsa fail: 'b'.
+!
+
+testChoiceNode
+ | literal1 literal2 |
+ literal1 := PPCLiteralNode new
+ literal: 'foo';
+ yourself.
+ literal2 := PPCLiteralNode new
+ literal: 'bar';
+ yourself.
+
+ node := PPCChoiceNode new
+ children: { literal1 . literal2 };
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'foo'.
+ self assert: fsa parse: 'bar'.
+self assert: fsa fail: 'fof'.
+!
+
+testChoicePriorities
+ | parser |
+ parser := ($a asParser optional, $b asParser optional) / $a asParser.
+ node := parser asCompilerTree.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'ab'.
+ self assert: fsa parse: 'a' end: 1.
+ self assert: fsa parse: 'b' end: 1.
+ self assert: fsa parse: ''.
+ self assert: fsa parse: 'c' end: 0.
+!
+
+testLiteralNode
+ node := PPCLiteralNode new
+ literal: 'foo';
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'foo' end: 3.
+ self assert: fsa parse: 'foobar' end: 3.
+ self assert: fsa fail: 'fox'.
+ self assert: fsa fail: 'bar'.
+!
+
+testLiteralNode2
+ node := PPCLiteralNode new
+ literal: '';
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: ''.
+!
+
+testNot
+ | parser |
+ parser := 'aaa' asParser not, $a asParser plus.
+ node := parser asCompilerTree.
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'a'.
+ self assert: fsa parse: 'aa'.
+ self assert: fsa fail: 'aaa'.
+ self assert: fsa fail: 'aaaa'.
+ self assert: fsa fail: ''.
+!
+
+testNotNode
+ | literal |
+ literal := PPCLiteralNode new
+ literal: 'foo';
+ yourself.
+
+ node := PPCNotNode new
+ child: literal;
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'fo' end: 0.
+ self assert: fsa parse: 'z' end: 0.
+ self assert: fsa parse: 'foO' end: 0.
+ self assert: fsa parse: 'bar' end: 0.
+ self assert: fsa parse: ''.
+ self assert: fsa fail: 'foo'.
+!
+
+testPlusNode
+ | literal |
+ literal := PPCLiteralNode new
+ literal: 'foo';
+ yourself.
+
+ node := PPCPlusNode new
+ child: literal;
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa fail: ''.
+ self assert: fsa parse: 'foo'.
+ self assert: fsa parse: 'foofoofoo'.
+!
+
+testSequenceNode
+ | literal1 literal2 |
+ literal1 := PPCLiteralNode new
+ literal: 'foo';
+ yourself.
+ literal2 := PPCLiteralNode new
+ literal: 'bar';
+ yourself.
+
+ node := PPCSequenceNode new
+ children: { literal1 . literal2 };
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'foobar'.
+ self assert: fsa fail: 'foo'.
+ self assert: fsa fail: 'bar'.
+!
+
+testSequenceNode2
+ | literal1 literal2 literal3 |
+ literal1 := PPCLiteralNode new
+ literal: 'b';
+ yourself.
+ literal2 := PPCLiteralNode new
+ literal: 'a';
+ yourself.
+ literal3 := PPCLiteralNode new
+ literal: 'z';
+ yourself.
+
+ node := PPCSequenceNode new
+ children: { literal1 . literal2 . literal3 };
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: 'baz'.
+ self assert: fsa fail: 'bar'.
+ self assert: fsa fail: 'faz'.
+ self assert: fsa fail: 'boz'.
+!
+
+testStarNode
+ | literal |
+ literal := PPCLiteralNode new
+ literal: 'foo';
+ yourself.
+
+ node := PPCStarNode new
+ child: literal;
+ yourself.
+
+ fsa := self fsaFrom: node.
+
+ self assert: fsa parse: ''.
+ self assert: fsa parse: 'foo'.
+ self assert: fsa parse: 'foofoofoo'.
+! !
+
+!PEGFsaGeneratorTest class methodsFor:'documentation'!
+
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PEGFsaInterpretTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,442 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PEGFsaInterpretTest
+ instanceVariableNames:'fsa a b c result d interpreter e'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-FSA'
+!
+
+!PEGFsaInterpretTest methodsFor:'as yet unclassified'!
+
+assert: anFsa fail: input
+ | stream |
+ stream := input asPetitStream.
+
+ result := interpreter interpret: anFsa on: stream.
+
+ self assert: result isEmpty.
+ ^ result
+!
+
+assert: anFsa parse: input
+ ^ self assert: anFsa parse: input end: input size
+!
+
+assert: anFsa parse: input end: end
+ | stream |
+ stream := input asPetitStream.
+ anFsa fixFinalStatePriorities.
+
+ result := interpreter interpret: anFsa on: stream.
+
+ self assert: result isEmpty not.
+ self assert: (result values anySatisfy: [ :pos | pos = end ]) description: 'wrong position'.
+
+ ^ result
+!
+
+assert: anFsa parse: input retval: name
+ ^ self assert: anFsa parse: input retval: name end: input size
+!
+
+assert: anFsa parse: input retval: name end: end
+ | stream |
+ stream := input asPetitStream.
+ anFsa fixFinalStatePriorities.
+
+ result := interpreter interpret: anFsa on: stream.
+
+ self assert: result isEmpty not.
+ self assert: ((result at: name) = end) description: 'wrong position'.
+
+ ^ result
+!
+
+assert: name position: pos
+ ^ self assert: ((result at: name) = pos)
+!
+
+assertFail: name
+ self assert: (result includesKey: name) not
+!
+
+assertPass: name
+ self assert: (result includesKey: name)
+!
+
+setUp
+ a := PEGFsaState new name: #a; retval: #a; yourself.
+ b := PEGFsaState new name: #b; retval: #b; yourself.
+ c := PEGFsaState new name: #c; retval: #c; yourself.
+ d := PEGFsaState new name: #d; retval: #d; yourself.
+ e := PEGFsaState new name: #e; retval: #e; yourself.
+
+ fsa := PEGFsa new.
+
+ interpreter := PEGFsaInterpret new
+ yourself.
+!
+
+testAB
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $b.
+
+ self assert: fsa parse: 'ab' retval: #c.
+ self assert: fsa parse: 'abc' retval: #c end: 2.
+
+ self assert: fsa fail: 'ac'.
+!
+
+testABPlus
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: a on: $b.
+ fsa addTransitionFrom: b to: c on: $b.
+
+ self assert: fsa parse: 'ab'.
+ self assert: fsa parse: 'ababab'.
+ self assert: fsa parse: 'abababc' end: 6.
+
+ self assert: fsa fail: 'ac'.
+!
+
+testAOptional
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ c priority: -1.
+ b priority: 0.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c priority: -1.
+
+ self assert: fsa parse: 'a'.
+ self assert: fsa parse: 'ab' end: 1.
+ self assert: fsa parse: 'b' end: 0.
+!
+
+testAPlusA
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+
+ fsa addTransitionFrom: c to: d on: $a.
+ fsa addTransitionFrom: c to: d on: $b.
+
+ b priority: 0.
+ d priority: -1.
+ fsa addTransitionFrom: b to: a. "a-loop"
+ fsa addTransitionFrom: b to: c priority: -1. "sequence"
+
+
+ self assert: fsa parse: 'aaab'.
+ self assert: fsa fail: 'aaaa'.
+!
+
+testAPlusB
+ fsa addState: a.
+ fsa addState: b.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $b.
+
+ self assert: fsa parse: 'ab'.
+ self assert: fsa parse: 'aaaab'.
+ self assert: fsa parse: 'abc' end: 2.
+
+ self assert: fsa fail: 'ac'.
+!
+
+testChoice
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $b.
+ fsa addTransitionFrom: a to: c on: $c.
+
+ self assert: fsa parse: 'b'.
+ self assert: fsa parse: 'c'.
+
+ self assert: fsa fail: 'a'
+!
+
+testChoice2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $a.
+
+ self assert: fsa parse: 'a'.
+ self assert: #b position: 1.
+ self assert: #c position: 1.
+
+ self assert: fsa fail: 'b'
+!
+
+testEmpty
+ fsa addState: a.
+ fsa startState: a.
+ fsa finalState: a.
+
+" fsa addTransitionFrom: a to: b.
+"
+ self assert: fsa parse: '' retval: #a.
+!
+
+testEpsilonChoice
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+ fsa addTransitionFrom: b to: c on: $c.
+ fsa addTransitionFrom: d to: e on: $e.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: a to: d.
+
+ self assert: fsa parse: 'c'.
+ self assert: fsa parse: 'e'.
+
+ self assert: fsa fail: 'a'
+!
+
+testEpsilonChoice2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: d to: e on: $a.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: a to: d.
+
+ self assert: fsa parse: 'a'.
+ self assert: #c position: 1.
+ self assert: #e position: 1.
+
+ self assert: fsa fail: 'b'
+!
+
+testOverlap
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ b priority: -1.
+ c priority: -1.
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a priority: -1.
+
+ self assert: fsa parse: 'aa'.
+ self assertPass: #b.
+ self assertPass: #c.
+
+ self assert: fsa parse: 'ac' end: 1.
+ self assertPass: #b.
+ self assertFail: #c.
+!
+
+testOverlap2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ b priority: 0.
+ c priority: -1.
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a priority: -1.
+
+ self assert: fsa parse: 'aa' end: 1.
+ self assertPass: #b.
+ self assertFail: #c.
+
+ self assert: fsa parse: 'ac' end: 1.
+ self assertPass: #b.
+ self assertFail: #c.
+!
+
+testPriorityChoice
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ b priority: 0.
+ c priority: -1.
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $a priority: -1.
+
+ self assert: fsa parse: 'a'.
+ self assert: #b position: 1.
+ self assert: (result includesKey: #b).
+ self assert: (result includesKey: #c) not.
+
+ self assert: fsa fail: 'b'
+!
+
+testPriorityChoice2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ b priority: -1.
+ c priority: 0.
+ fsa addTransitionFrom: a to: b on: $a priority: -1.
+ fsa addTransitionFrom: a to: c on: $a.
+
+ self assert: fsa parse: 'a'.
+ self assert: #c position: 1.
+ self assert: (result includesKey: #b) not.
+ self assert: (result includesKey: #c).
+
+ self assert: fsa fail: 'b'
+!
+
+testPriorityContinuation
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+
+ fsa finalState: b.
+ fsa finalState: c.
+
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a priority: -1.
+
+ b retval: PEGFsaFailure new.
+ b priority: 0.
+ c priority: -1.
+
+ self assert: fsa fail: 'a'.
+ self assert: fsa fail: 'aa'
+!
+
+testPriorityEpsilonChoice
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: d to: e on: $a.
+
+ c priority: 0.
+ e priority: -1.
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: a to: d priority: -1.
+
+ self assert: fsa parse: 'a'.
+ self assert: #c position: 1.
+ self assertPass: #c.
+ self assertFail: #e.
+
+ self assert: fsa fail: 'b'
+!
+
+testPriorityEpsilonChoice2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: d to: e on: $a.
+
+ c priority: -1.
+ e priority: 0.
+ fsa addTransitionFrom: a to: b priority: -1.
+ fsa addTransitionFrom: a to: d.
+
+ self assert: fsa parse: 'a'.
+ self assert: #e position: 1.
+ self assertPass: #e.
+ self assertFail: #c.
+
+ self assert: fsa fail: 'b'
+!
+
+testPriorityReturn
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a.
+
+ b priority: -1.
+ c priority: 0.
+
+ self assert: fsa parse: 'a'.
+ self assert: #b position: 1.
+
+ self assert: fsa fail: 'aa'
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PEGFsaScannerIntegrationTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,392 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PEGFsaScannerIntegrationTest
+ instanceVariableNames:'fsa fsaGenerator parser scanner result compiled'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-Scanner'
+!
+
+!PEGFsaScannerIntegrationTest methodsFor:'as yet unclassified'!
+
+compile
+ | ppcTree |
+ compiled ifTrue: [ ^ self ].
+ ppcTree := parser asCompilerTree.
+ fsa := ppcTree asFsa.
+ fsa name: #nextToken.
+ fsa finalStates do: [ :s | s isFailure ifFalse: [s retval: #token ]].
+
+ scanner := ((PPCScannerCodeGenerator new)
+ generate: fsa).
+
+ compiled := true
+!
+
+failScan: stream
+ self compile.
+
+ scanner initialize.
+ scanner stream: stream asPetitStream.
+ result := scanner nextToken.
+
+ self assert: result isEmpty
+!
+
+scan: stream token: token
+ self scan: stream token: token position: stream size.
+!
+
+scan: stream token: token position: position
+ self compile.
+
+ scanner initialize.
+ scanner stream: stream asPetitStream.
+ result := scanner nextToken.
+
+ self assert: result isCollection description: 'no collection returned as a result!!'.
+ self assert: (result isEmpty not) description: 'no token found'.
+ self assert: (result at: token) = position.
+!
+
+setUp
+ compiled := false.
+ fsaGenerator := PEGFsaGenerator new.
+!
+
+testA
+ parser := 'a' asParser.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: ''.
+ self failScan: 'b'.
+
+ self scan: 'a' token: #token position: 1.
+ self scan: 'aaa' token: #token position: 1.
+!
+
+testAAA_Aplusnot
+ parser := 'aaa' asParser not, $a asParser plus.
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self scan: 'a' token: #token.
+ self scan: 'aa' token: #token.
+
+ self failScan: ''.
+ self failScan: 'aaa'.
+ self failScan: 'aaaa'.
+ self failScan: 'aaaaa'.
+!
+
+testAAplus_A
+ parser := 'aa' asParser plus, $a asParser.
+
+ self scan: 'aaa' token: #token.
+ self scan: 'aaaaa' token: #token.
+
+ self failScan: 'a'.
+ self failScan: 'aa'.
+ self failScan: 'aaaa'.
+!
+
+testAAplus_B
+ parser := 'aa' asParser plus, $b asParser.
+
+ self scan: 'aab' token: #token.
+ self scan: 'aaaab' token: #token.
+
+ self failScan: 'ab'.
+ self failScan: 'aaab'.
+ self failScan: 'aac'.
+!
+
+testAAstar_A
+ parser := 'aa' asParser star, $a asParser.
+
+ self scan: 'a' token: #token.
+ self scan: 'aaa' token: #token.
+ self scan: 'aaaaa' token: #token.
+ self scan: 'aaaaaaa' token: #token.
+
+
+ self failScan: 'aa'.
+ self failScan: 'aaaa'.
+!
+
+testAAstar_B
+ parser := 'aa' asParser star, $b asParser.
+
+ self scan: 'b' token: #token.
+ self scan: 'aab' token: #token.
+ self scan: 'aaaab' token: #token.
+ self scan: 'aaaaaab' token: #token.
+
+
+ self failScan: 'ab'.
+ self failScan: 'aaa'.
+!
+
+testAB
+ parser := 'ab' asParser.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: ''.
+ self failScan: 'b'.
+
+ self scan: 'ab' token: #token position: 2.
+ self scan: 'aba' token: #token position: 2.
+!
+
+testA_BCorCD_D
+ parser := $a asParser, ('bc' asParser / 'cd' asParser), $d asParser.
+
+ self scan: 'abcd' token: #token.
+ self scan: 'acdd' token: #token.
+
+ self failScan: 'abdd'.
+ self failScan: 'ad'.
+ self failScan: 'aacd'.
+!
+
+testA_BCorCDplus_D
+ parser := $a asParser, ('bc' asParser / 'cd' asParser) plus, $d asParser.
+
+ self scan: 'abcd' token: #token.
+ self scan: 'acdd' token: #token.
+ self scan: 'abcbccdd' token: #token.
+ self scan: 'acdcdbcbcd' token: #token.
+
+ self failScan: 'abdd'.
+ self failScan: 'ad'.
+ self failScan: 'abcccd'.
+!
+
+testA_BCorCDstar_D
+ parser := $a asParser, ('bc' asParser / 'cd' asParser) star, $d asParser.
+
+ self scan: 'ad' token: #token.
+ self scan: 'abcd' token: #token.
+ self scan: 'acdd' token: #token.
+ self scan: 'abcbccdd' token: #token.
+ self scan: 'acdcdbcbcd' token: #token.
+
+ self failScan: 'abdd'.
+ self failScan: 'abcccd'.
+!
+
+testA_Bnot
+ parser := 'a' asParser, $b asParser not.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: 'ab'.
+ self failScan: 'bb'.
+
+ self scan: 'a' token: #token position: 1.
+ self scan: 'ac' token: #token position: 1.
+!
+
+testA_Boptional
+ parser := $a asParser, $b asParser optional.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: ''.
+ self failScan: 'b'.
+
+ self scan: 'ab' token: #token position: 2.
+ self scan: 'ac' token: #token position: 1.
+ self scan: 'a' token: #token position: 1.
+!
+
+testA_BorC_D
+ parser := $a asParser, ($b asParser / $c asParser), $d asParser.
+
+ self scan: 'abd' token: #token.
+ self scan: 'acd' token: #token.
+
+ self failScan: 'a'.
+ self failScan: 'abc'.
+ self failScan: 'add'.
+!
+
+testA_BorCplus_D
+ parser := $a asParser, ($b asParser / $c asParser) plus, $d asParser.
+
+ self scan: 'abd' token: #token.
+ self scan: 'acd' token: #token.
+ self scan: 'abcbcd' token: #token.
+ self scan: 'acbcbcd' token: #token.
+
+ self failScan: 'a'.
+ self failScan: 'ad'.
+ self failScan: 'abc'.
+ self failScan: 'aad'.
+!
+
+testA_BorCstar_D
+ parser := $a asParser, ($b asParser / $c asParser) star, $d asParser.
+
+ self scan: 'ad' token: #token.
+ self scan: 'abd' token: #token.
+ self scan: 'acd' token: #token.
+ self scan: 'abcbcd' token: #token.
+ self scan: 'acbcbcd' token: #token.
+
+ self failScan: 'a'.
+ self failScan: 'abc'.
+ self failScan: 'aad'.
+!
+
+testAorAA
+ parser := 'a' asParser / 'aa' asParser.
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: ''.
+ self failScan: 'b'.
+
+ self scan: 'aa' token: #token position: 1.
+ self scan: 'a' token: #token position: 1.
+!
+
+testAorAX_X
+ parser := ('a' asParser / 'ax' asParser), $x asParser.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self scan: 'ax' token: #token position: 2.
+ self scan: 'axx' token: #token position: 2.
+
+ self failScan: 'a'.
+ self failScan: 'x'.
+ self failScan: ''.
+!
+
+testAorB
+ parser := $a asParser / $b asParser.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: ''.
+ self failScan: 'c'.
+
+ self scan: 'aa' token: #token position: 1.
+ self scan: 'bb' token: #token position: 1.
+!
+
+testAplus_B
+ parser := $a asParser plus, $b asParser.
+
+ self scan: 'ab' token: #token.
+ self scan: 'aab' token: #token.
+ self scan: 'aaab' token: #token.
+
+ self failScan: 'b'.
+ self failScan: 'ac'.
+!
+
+testAstar_A
+ parser := $a asParser star, $a asParser.
+
+ self failScan: 'a'.
+ self failScan: 'aa'.
+ self failScan: 'ac'.
+!
+
+testAstar_B
+ parser := $a asParser star, $b asParser.
+
+ self scan: 'b' token: #token.
+ self scan: 'ab' token: #token.
+ self scan: 'aab' token: #token.
+
+ self failScan: ''.
+ self failScan: 'ac'.
+!
+
+testAstar_Bnot
+ parser := 'a' asParser star, $b asParser not.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: 'aaab'.
+ self failScan: 'b'.
+
+ self scan: '' token: #token position: 0.
+ self scan: 'a' token: #token position: 1.
+ self scan: 'aac' token: #token position: 2.
+ self scan: 'aaaac' token: #token position: 4.
+!
+
+testFoo
+ parser := 'foo' asParser.
+
+ self scan: 'foo' token: #token.
+ self scan: 'foobar' token: #token position: 3.
+
+ self failScan: 'bar'.
+ self failScan: 'fo'.
+!
+
+testNumber
+ parser := #digit asParser plus.
+
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self failScan: ''.
+ self failScan: 'b'.
+
+ self scan: '12' token: #token position: 2.
+ self scan: '2312' token: #token position: 4.
+!
+
+testSmalltalkIdentifier
+ parser := #letter asParser, #word asParser star, $: asParser not.
+ self compile.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa isWithoutEpsilons.
+
+ self scan: 'a' token: #token.
+ self scan: 'hithere' token: #token.
+ self scan: 'hi123' token: #token.
+
+ self failScan: ''.
+ self failScan: 'aaa:'.
+ self failScan: '123'.
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PEGFsaStateTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,210 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PEGFsaStateTest
+ instanceVariableNames:'state t1 t2 t3 t4 anotherState'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-FSA'
+!
+
+!PEGFsaStateTest methodsFor:'as yet unclassified'!
+
+setUp
+ state := PEGFsaState new name: #state; retval: #state; yourself.
+ anotherState := PEGFsaState new name: #anotherState; retval: #anotherState; yourself.
+
+ t1 := PEGFsaTransition new.
+ t2 := PEGFsaTransition new.
+ t3 := PEGFsaTransition new.
+ t4 := PEGFsaTransition new.
+
+!
+
+testCopy
+ state addTransition: t1.
+ anotherState := state copy.
+
+ self assert: (state = anotherState).
+ self assert: (state == anotherState) not.
+
+ state retval: #foo.
+ self assert: (state = anotherState) not.
+
+ anotherState retval: #foo.
+ self assert: (state = anotherState).
+
+ state addTransition: t2.
+ self assert: (state = anotherState) not.
+
+ anotherState addTransition: t2.
+ self assert: (state = anotherState).
+
+!
+
+testCopy2
+ state addTransition: t1.
+ anotherState := state copy.
+
+ self assert: (state = anotherState).
+ self assert: (state == anotherState) not.
+
+ state addTransition: t2.
+ self assert: (state = anotherState) not.
+
+ anotherState addTransition: t2 copy.
+ self assert: (state = anotherState).
+
+!
+
+testCopy3
+ state addTransition: t1.
+ anotherState := state copy.
+
+ self assert: (state = anotherState).
+ self assert: (state == anotherState) not.
+
+ t1 addCharacter: $x.
+ self assert: (state = anotherState) not.
+
+ anotherState transitions anyOne addCharacter: $x.
+ self assert: (state = anotherState).
+
+!
+
+testEquals
+ state addTransition: t1.
+ anotherState addTransition: t2.
+
+ state retval: #baz.
+ anotherState retval: #baz.
+
+ t1 destination: #foo.
+ t2 destination: #bar.
+
+ self assert: (state equals: anotherState) not
+!
+
+testEquals2
+ state addTransition: t1.
+ anotherState addTransition: t2.
+
+ state retval: #baz.
+ anotherState retval: #baz.
+
+ t1 destination: #foo.
+ t2 destination: #foo.
+
+ self assert: (state equals: anotherState).
+!
+
+testEquals3
+ state addTransition: t1.
+ anotherState addTransition: t2.
+
+ state retval: #bar.
+ anotherState retval: #baz.
+
+ t1 destination: #foo.
+ t2 destination: #foo.
+
+ self assert: (state equals: anotherState) not
+!
+
+testEquals4
+ state addTransition: t1.
+ anotherState addTransition: t2.
+
+ state retval: #bar.
+ anotherState retval: #bar.
+
+ state priority: 0.
+ anotherState priority: -1.
+
+ t1 destination: #foo.
+ t2 destination: #foo.
+
+ self assert: (state equals: anotherState) not
+!
+
+testEquals5
+ state addTransition: t1.
+ state addTransition: t2.
+ anotherState addTransition: t2.
+ anotherState addTransition: t3.
+
+ state retval: #bar.
+ anotherState retval: #bar.
+
+ state priority: -1.
+ anotherState priority: -1.
+
+ t1 destination: #foobar.
+ t2 destination: #foo.
+ t3 destination: #foobar.
+
+ self assert: (state equals: anotherState)
+!
+
+testEquals6
+ state addTransition: t1.
+ state addTransition: t2.
+ anotherState addTransition: t1.
+
+ state retval: #bar.
+ anotherState retval: #bar.
+
+ state priority: -1.
+ anotherState priority: -1.
+
+ t1 destination: #foo.
+ t2 destination: #bar.
+
+ self assert: (state equals: anotherState) not
+!
+
+testJoin
+ | newState |
+ state addTransition: t1.
+ anotherState addTransition: t2.
+ state final: true.
+
+ t1 destination: #t1.
+ t2 destination: #t2.
+
+ newState := state join: anotherState.
+
+ self assert: (newState transitions contains: [ :t | t = t1 ]).
+ self assert: (newState transitions contains: [ :t | t = t2 ]).
+ self assert: (newState isFinal).
+!
+
+testJoin2
+ | newState |
+ state addTransition: t1.
+ anotherState addTransition: t2.
+ state final: true.
+
+ t1 destination: #t1.
+ t2 destination: #t2.
+
+ newState := anotherState join: state.
+
+ self assert: (newState transitions contains: [ :t | t = t1 ]).
+ self assert: (newState transitions contains: [ :t | t = t2 ]).
+ self assert: (newState isFinal).
+!
+
+testTransitionPairs
+ state addTransition: t1.
+ state addTransition: t2.
+ state addTransition: t3.
+
+ self assert: state transitions size = 3.
+ self assert: state transitionPairs size = 3.
+ self assert: (state transitionPairs includes: (PEGFsaPair with: t1 with: t2)).
+ self assert: (state transitionPairs includes: (PEGFsaPair with: t1 with: t3)).
+ self assert: (state transitionPairs includes: (PEGFsaPair with: t2 with: t3)).
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PEGFsaTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,616 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PEGFsaTest
+ instanceVariableNames:'fsa a b c d e result newFsa'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-FSA'
+!
+
+!PEGFsaTest methodsFor:'as yet unclassified'!
+
+assert: col allSatisfy: block
+ self assert: (col allSatisfy: block).
+!
+
+assert: col anySatisfy: block
+ self assert: (col anySatisfy: block).
+!
+
+setUp
+ a := PEGFsaState new name: #a; retval: #a; yourself.
+ b := PEGFsaState new name: #b; retval: #b; yourself.
+ c := PEGFsaState new name: #c; retval: #c; yourself.
+ d := PEGFsaState new name: #d; retval: #d; yourself.
+ e := PEGFsaState new name: #e; retval: #e; yourself.
+
+ fsa := PEGFsa new.
+!
+
+testBackTransitions
+ fsa addState: a.
+ fsa addState: b.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $a.
+
+ result := fsa backTransitions.
+
+ self assert: result size = 1.
+ self assert: result anyOne destination = a.
+!
+
+testBackTransitions2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: c to: a.
+
+ result := fsa backTransitions.
+
+ self assert: result size = 2.
+ self assert: result allSatisfy: [:t | t destination = a ].
+!
+
+testBackTransitions3
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $a.
+ fsa addTransitionFrom: b to: d on: $a.
+ fsa addTransitionFrom: c to: d on: $a.
+ fsa addTransitionFrom: d to: b on: $a.
+ fsa addTransitionFrom: d to: c on: $a.
+ result := fsa backTransitions.
+
+ self assert: result size = 2.
+
+ d transitions allSatisfy: [ :t | result includes: t ].
+!
+
+testBackTransitions4
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: a to: c on: $a.
+
+ result := fsa backTransitions.
+
+ self assert: result size = 0.
+!
+
+testBackTransitions5
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: c on: $a.
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a.
+
+ result := fsa backTransitions.
+
+ self assert: result size = 0.
+!
+
+testDeterminize
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $a.
+
+ fsa determinize.
+
+ self assert: fsa states size = 2.
+ self assert: a transitions size = 1.
+ self assert: a transitions anyOne destination retval = #c.
+!
+
+testDeterminize2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $a.
+
+ fsa determinize.
+
+ self assert: fsa states size = 2.
+ self assert: a transitions size = 1.
+ self assert: a transitions anyOne destination retval = #b.
+!
+
+testDeterminize3
+ | merged |
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+
+ fsa startState: a.
+ fsa finalState: e.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $a.
+ fsa addTransitionFrom: b to: e on: $e.
+ fsa addTransitionFrom: c to: d on: $d.
+ fsa addTransitionFrom: d to: e on: $e.
+
+ fsa determinize.
+ merged := a transitions anyOne destination.
+
+ self assert: fsa states size = 4.
+ self assert: a transitions size = 1.
+ self assert: merged transitions size = 2.
+ self assert: (merged transitions anySatisfy: [ :t | (t accepts: $d) and: [ t destination = d ]]).
+ self assert: (merged transitions anySatisfy: [ :t | (t accepts: $e) and: [ t destination = e ]]).
+!
+
+testDeterminize4
+ | merged |
+ fsa addState: a.
+ fsa addState: b.
+
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $a.
+
+ fsa determinize.
+ merged := a transitions anyOne destination.
+
+ self assert: fsa states size = 2.
+ self assert: a transitions size = 1.
+ self assert: merged transitions size = 1.
+ self assert: ((merged name = #'a-b') or: [merged name = #'b-a']).
+ self assert: (merged transitions anySatisfy: [ :t | (t accepts: $a) and: [ t destination = merged ]]).
+!
+
+testDeterminize5
+ | merged |
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: a.
+ fsa addTransitionFrom: b to: c priority: -1.
+ fsa addTransitionFrom: c to: d on: $a.
+ b priority: 0.
+
+ fsa determinize.
+ merged := b transitions anyOne destination.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa states size = 3.
+
+
+ self assert: a transitions size = 1.
+ self assert: b transitions size = 1.
+ self assert: (fsa states noneSatisfy: [ :s | s isFinal ]).
+!
+
+testDeterminize6
+ | merged |
+ fsa addState: a.
+ fsa addState: b.
+
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $a priority: -1.
+
+ fsa determinize.
+ self assert: fsa isDeterministic.
+ self assert: fsa states size = 2.
+
+
+ self assert: a transitions size = 1.
+ self assert: a isFinal not.
+
+ merged := a transitions anyOne destination.
+ self assert: merged transitions size = 1.
+ self assert: merged isFinal.
+!
+
+testIsDeterministic
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $b.
+ fsa addTransitionFrom: a to: c on: $c.
+
+ self assert: fsa isDeterministic.
+!
+
+testIsDeterministic2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $a.
+
+ self assert: fsa isDeterministic not.
+!
+
+testIsWithoutEpsilons
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: b to: c on: $c.
+
+ self assert: fsa isWithoutEpsilons not.
+!
+
+testMergeTransitions
+ fsa addState: a.
+ fsa addState: b.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: b on: $b.
+
+ fsa mergeTransitions.
+
+ self assert: a transitions size = 1.
+ self assert: (a transitions anyOne accepts: $a).
+ self assert: (a transitions anyOne accepts: $b).
+!
+
+testMergeTransitions2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $b.
+
+ fsa mergeTransitions.
+
+ self assert: a transitions size = 2.
+!
+
+testMinimize
+ | merged |
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $b.
+ fsa addTransitionFrom: a to: c on: $c.
+
+ fsa addTransitionFrom: b to: d on: $a.
+ fsa addTransitionFrom: c to: d on: $a.
+ b retval: nil.
+ c retval: nil.
+
+ fsa minimize.
+
+ self assert: fsa states size = 3.
+ self assert: a transitions size = 1.
+
+ merged := a transitions anyOne destination.
+ self assert: merged transitions size = 1.
+ self assert: merged transitions anyOne destination = d.
+ self assert: (merged transitions anyOne accepts: $a).
+!
+
+testMinimze2
+ | merged |
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+
+ fsa startState: a.
+ fsa finalState: e.
+
+ "states c and d are equivalent"
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $c priority: -1.
+ fsa addTransitionFrom: b to: d on: $d priority: -2.
+ fsa addTransitionFrom: c to: e on: $e priority: -3.
+ fsa addTransitionFrom: d to: e on: $e priority: -4.
+
+ c retval: nil.
+ d retval: nil.
+
+ fsa minimize.
+
+ self assert: fsa isDeterministic.
+ self assert: fsa states size = 4.
+
+ self assert: b transitions size = 1.
+
+ merged := b destination.
+ self assert: merged transitions size = 1.
+ self assert: merged destination isFinal.
+!
+
+testRemoveEpsilons
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: b to: c on: $c.
+
+ fsa removeEpsilons.
+
+ self assert: a transitions size = 1.
+ self assert: b transitions size = 1.
+ self assert: a transitions anyOne isEpsilon not.
+ self assert: (a transitions anyOne accepts: $c).
+ self assert: (fsa isReachableState: c).
+ self assert: (fsa isReachableState: b) not.
+ self assert: fsa isWithoutEpsilons.
+!
+
+testRemoveEpsilons2
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: a to: b on: $b.
+ fsa addTransitionFrom: b to: c on: $c.
+
+ fsa removeEpsilons.
+
+ self assert: a transitions size = 2.
+ self assert: b transitions size = 1.
+ self assert: (a transitions noneSatisfy: [:t | t isEpsilon ]).
+ self assert: (a transitions anySatisfy: [:t | t accepts: $c ]).
+ self assert: (a transitions anySatisfy: [:t | t accepts: $b ]).
+!
+
+testRemoveEpsilons3
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b.
+ fsa addTransitionFrom: b to: c.
+ fsa addTransitionFrom: c to: d on: $d.
+
+ fsa removeEpsilons.
+
+ self assert: a transitions size = 1.
+
+ self assert: a transitions anyOne isEpsilon not.
+ self assert: (a transitions anyOne accepts: $d).
+ self assert: (fsa isReachableState: d).
+ self assert: (fsa isReachableState: b) not.
+ self assert: (fsa isReachableState: c) not.
+!
+
+testRemoveEpsilons4
+ fsa addState: a.
+ fsa addState: b.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b.
+
+ fsa removeEpsilons.
+
+ self assert: a isFinal.
+!
+
+testRemoveEpsilons5
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+
+
+ fsa startState: a.
+ fsa finalState: d.
+
+ c priority: 0.
+ d priority: 0.
+
+ fsa addTransitionFrom: a to: b priority: -1.
+ fsa addTransitionFrom: a to: c on: $c.
+ fsa addTransitionFrom: b to: d on: $d.
+ fsa addTransitionFrom: c to: d on: $d.
+
+ fsa removeEpsilons.
+
+ self assert: c priority = 0.
+ self assert: d priority = -1.
+ self assert: (a transitions anySatisfy: [:t | t accepts: $d ]).
+!
+
+testRemoveEpsilons6
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: a.
+ fsa addTransitionFrom: b to: c priority: -1.
+ fsa addTransitionFrom: c to: d on: $b.
+
+ d priority: 0.
+
+ fsa removeEpsilons.
+
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: a transitions size = 1.
+ self assert: b transitions size = 2.
+ self assert: b transitions anySatisfy: [ :t | (t accepts: $a) and: [t destination = b]].
+ self assert: b transitions anySatisfy: [ :t | (t accepts: $b) and: [t destination = d]].
+
+ self assert: d priority = -1.
+!
+
+testRemoveEpsilons7
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa startState: a.
+ fsa finalState: d.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: a.
+
+ fsa removeEpsilons.
+
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: a transitions size = 1.
+ self assert: b transitions size = 1.
+ self assert: (a transitions anyOne == b transitions anyOne) not.
+!
+
+testRemoveLowPriorityTransitions
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+ b priority: 0.
+ fsa addTransitionFrom: a to: b on: $a priority: -1.
+ fsa addTransitionFrom: b to: c on: $b priority: -1.
+
+ fsa removeLowPriorityTransitions.
+
+ self assert: fsa isWithoutEpsilons.
+
+ self assert: a transitions size = 1.
+ self assert: b transitions size = 0.
+!
+
+testRemoveUnreachableStates
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: c.
+ fsa addTransitionFrom: b to: c.
+
+ fsa removeUnreachableStates.
+
+ self assert: fsa states size = 2.
+!
+
+testTopologicalOrder
+ | |
+ fsa addState: a.
+ fsa addState: b.
+
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $a.
+
+ result := fsa topologicalOrder.
+
+ self assert: result first == a.
+ self assert: result second == b.
+! !
+
+!PEGFsaTest methodsFor:'tests - copy'!
+
+testCopy
+ | newA newC |
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+
+ fsa finalState: c.
+ fsa startState: a.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $b priority: -1.
+ fsa addTransitionFrom: c to: a priority: -2.
+
+ newFsa := fsa copy.
+
+ self assert: (fsa isIsomorphicTo: newFsa).
+
+ newA := newFsa states detect: [ :s | s canBeIsomorphicTo: a ].
+
+ self assert: newFsa startState = newA.
+ self assert: (a == newA) not.
+ self assert: (newA transitions anyOne canBeIsomorphicTo: a transitions anyOne).
+ self assert: (newA transitions anyOne == a transitions anyOne) not.
+ self assert: newA destination destination destination == newA.
+
+ newC := newA destination destination.
+ self assert: (newC == c) not.
+ self assert: newC isFinal.
+ self assert: newC retval = #c.
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PEGFsaTransitionTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,130 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PEGFsaTransitionTest
+ instanceVariableNames:'t1 t2 result'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-FSA'
+!
+
+!PEGFsaTransitionTest methodsFor:'as yet unclassified'!
+
+setUp
+ t1 := PEGFsaTransition new.
+ t2 := PEGFsaTransition new.
+!
+
+testCompare
+ t1 addCharacter: $a.
+ t1 addCharacter: $b.
+ t2 addCharacter: $a.
+ t2 addCharacter: $b.
+
+ self assert: t1 = t2.
+!
+
+testComplement
+ t1 addCharacter: $a.
+ t1 addCharacter: $b.
+ t2 addCharacter: $b.
+ t2 addCharacter: $c.
+
+ result := t1 complement: t2.
+
+ self assert: (result at: $a codePoint).
+ self assert: (result at: $b codePoint) not.
+ self assert: (result at: $c codePoint) not.
+!
+
+testComplement2
+ t1 addCharacter: $a.
+ t1 addCharacter: $b.
+ t2 addCharacter: $b.
+ t2 addCharacter: $c.
+
+ result := t2 complement: t1.
+
+ self assert: (result at: $a codePoint) not.
+ self assert: (result at: $b codePoint) not.
+ self assert: (result at: $c codePoint).
+!
+
+testCopy
+ t1 addCharacter: $a.
+ t1 addCharacter: $b.
+
+ t2 := t1 copy.
+
+
+ self assert: t1 = t2.
+ self assert: (t1 == t2) not.
+
+ t2 destination: #foo.
+ self assert: (t1 = t2) not.
+
+ t1 destination: #foo.
+ self assert: (t1 = t2).
+
+ t1 addCharacter: $c.
+ self assert: (t1 = t2) not.
+
+ t2 addCharacter: $c.
+ t1 priority: -1.
+ self assert: (t1 = t2) not.
+
+ t2 priority: -1.
+ self assert: (t1 = t2).
+!
+
+testDisjunction
+ t1 addCharacter: $a.
+ t1 addCharacter: $c.
+ t2 addCharacter: $b.
+ t2 addCharacter: $c.
+
+ result := t1 disjunction: t2.
+
+ self assert: (result at: $a codePoint).
+ self assert: (result at: $b codePoint).
+ self assert: (result at: $c codePoint) not.
+!
+
+testIntersection
+ t1 addCharacter: $a.
+ t1 addCharacter: $b.
+ t2 addCharacter: $b.
+ t2 addCharacter: $c.
+
+ result := t1 intersection: t2.
+
+ self assert: (result at: $b codePoint).
+ self assert: (result at: $a codePoint) not.
+ self assert: (result at: $c codePoint) not.
+!
+
+testIntersection2
+ t1 addCharacter: $a.
+ t2 addCharacter: $b.
+
+ result := t1 intersection: t2.
+
+ self assert: (result allSatisfy: [:e | e not ]).
+
+!
+
+testUnion
+ t1 addCharacter: $a.
+ t1 addCharacter: $b.
+ t2 addCharacter: $b.
+ t2 addCharacter: $c.
+
+ result := t1 union: t2.
+
+ self assert: (result at: $b codePoint).
+ self assert: (result at: $a codePoint).
+ self assert: (result at: $c codePoint).
+ self assert: (result at: $d codePoint) not.
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PPCClassBuilderTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,110 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PPCClassBuilderTest
+ instanceVariableNames:'builder method1 result'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-Core'
+!
+
+!PPCClassBuilderTest methodsFor:'as yet unclassified'!
+
+foo
+ ^ PPCMethod new
+ id: #foo;
+ code: '^ 1';
+ yourself
+!
+
+setUp
+ super setUp.
+ builder := PPCClassBuilder new.
+!
+
+tearDown
+ super tearDown.
+ result removeFromSystem.
+!
+
+testCompileClass
+ builder compiledClassName: #PPCGenerated.
+ builder compiledSuperclass: Object.
+
+ method1 := self foo.
+ builder methodDictionary at: #foo put: method1.
+
+ builder instvars add: #foo.
+
+ builder constants at: #foobar put: #foobar.
+ builder constants at: #barbar put: #barbar.
+
+ result := builder compileClass.
+
+ self assert: result isNil not.
+ self assert: result name = #PPCGenerated.
+ self assert: result superclass = Object.
+
+ self assert: result methodDictionary size =1.
+ self assert: result instanceVariables size = 1.
+ self assert: result classVariables size = 2.
+ self assert: (result classVariableNamed: #foobar) value = #foobar.
+ self assert: (result classVariableNamed: #barbar) value = #barbar.
+
+ self assert: result new foo = 1.
+!
+
+testCompileClass2
+ Object subclass: #PPCGenerated
+ instanceVariableNames: ''
+ classVariableNames: 'foobar'
+ category: 'PetitCompiler-generated'.
+
+ (Smalltalk at: #PPCGenerated) compileSilently: 'bar ^ 12' classified: 'test'.
+ (Smalltalk at: #PPCGenerated) compileSilently: 'foo ^ 123' classified: 'generated'.
+ (Smalltalk at: #PPCGenerated) compileSilently: 'foo2 ^ 1234' classified: 'generated'.
+
+ builder compiledClassName: #PPCGenerated.
+ builder compiledSuperclass: Object.
+
+ method1 := self foo.
+ builder methodDictionary at: #foo put: method1.
+
+ result := builder compileClass.
+
+ self assert: result isNil not.
+ self assert: result name = #PPCGenerated.
+ self assert: result superclass = Object.
+ self assert: result methodDictionary size = 2.
+
+ self assert: result classVariables size = 0.
+
+ self assert: result new foo = 1.
+ self assert: result new bar = 12.
+!
+
+testCompileClass3
+ Object subclass: #PPCGenerated
+ instanceVariableNames: ''
+ classVariableNames: 'foobar'
+ category: 'PetitCompiler-generated'.
+
+ (Smalltalk at: #PPCGenerated) compileSilently: 'foo ^ 123' classified: 'testing'.
+
+ builder compiledClassName: #PPCGenerated.
+ builder compiledSuperclass: Object.
+
+ method1 := self foo.
+ builder methodDictionary at: #foo put: method1.
+
+ result := builder compileClass.
+
+ self assert: result isNil not.
+ self assert: result name = #PPCGenerated.
+ self assert: result superclass = Object.
+ self assert: result methodDictionary size = 1.
+
+ self assert: result new foo = 123.
+! !
+
--- a/compiler/tests/PPCCodeGeneratorTest.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/PPCCodeGeneratorTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -71,6 +71,77 @@
self assert: parser fail: ''.
!
+testActionNode2
+ node := PPCPlusNode new
+ child:
+ (PPCActionNode new
+ block: [ :res | res asUppercase ];
+ child: #letter asParser asCompilerTree;
+ yourself);
+ yourself.
+
+ self compileTree: node.
+
+ self assert: parser parse: 'foo' to: { $F . $O . $O}.
+ self assert: parser parse: 'bar' to: { $B . $A . $R}.
+ self assert: parser fail: ''.
+
+ "Created: / 15-06-2015 / 13:57:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+testActionNode3
+ node := ((#letter asParser , #letter asParser)
+ ==> [:nodes | String with:(nodes first) with:(nodes second) ]) asCompilerTree.
+ node child markForInline.
+
+ self compileTree:node.
+
+ self assert:parser parse:'ab' to:'ab'.
+ self assert:parser parse:'cz' to:'cz'.
+ self assert:parser fail:''.
+
+ "Created: / 16-06-2015 / 06:53:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+testActionNode4
+ node := ((#letter asParser , #letter asParser)
+ ==> [:nodes | String with:(nodes first) with:(nodes second) ]) asCompilerTree.
+ node child markForInline.
+
+ self compileTree:node.
+
+ self assert:parser fail:'a'.
+
+ "Created: / 16-06-2015 / 06:53:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+testActionNode5
+ node := ((#letter asParser , #letter asParser optional)
+ ==> [:nodes | String with:(nodes first) with:((nodes second) isNil ifTrue:[$?] ifFalse:[nodes second]) ]) asCompilerTree.
+ node child markForInline.
+
+ self compileTree:node.
+
+ self assert:parser parse:'cz' to:'cz'.
+ self assert:parser parse:'c' to:'c?'.
+
+ "Created: / 16-06-2015 / 06:53:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+testActionNode6
+ node := ((#letter asParser , #letter asParser)
+ ==> [:nodes | String withAll:nodes ]) asCompilerTree.
+ node child markForInline.
+
+ self compileTree:node.
+
+ self assert:parser parse:'ab' to:'ab'.
+ self assert:parser parse:'cz' to:'cz'.
+ self assert:parser fail:''.
+
+ "Created: / 16-06-2015 / 07:22:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
testAnyNode
node := PPCForwardNode new
child: PPCAnyNode new;
@@ -365,21 +436,21 @@
testInlinePluggableNode
"Sadly, on Smalltalk/X blocks cannot be inlined because
- the VM does not provide enough information to map
- it back to source code. Very bad indeed!!"
- ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
- self skipIf: true description: 'Blocks cannot be inlined due to a lack of proper VM support'.
- ].
+ the VM does not provide enough information to map
+ it back to source code. Very bad indeed!!"
+ ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+ self skipIf: true description: 'Blocks cannot be inlined due to a lack of proper VM support'.
+ ].
- node := PPCSequenceNode new
- children: {
- PPCPluggableNode new block: [ :ctx | ctx next ]; markForInline; yourself.
- $a asParser asCompilerNode }.
-
- self compileTree: node.
-
- self assert: parser class methodDictionary size = 2.
- self assert: parser parse: 'ba' to: #($b $a).
+ node := PPCSequenceNode new
+ children: {
+ PPCPluggableNode new block: [ :ctx | ctx next ]; markForInline; yourself.
+ $a asParser asCompilerNode }.
+
+ self compileTree: node.
+
+ self assert: parser class methodDictionary size = 2.
+ self assert: parser parse: 'ba' to: #($b $a).
!
testLiteralNode
@@ -421,6 +492,54 @@
self assert: parser fail: 'boo'.
!
+testMappedActionNode1
+ node := ((#letter asParser , #letter asParser)
+ map:[:a :b | String with:a with:b ]) asCompilerTree.
+
+ self compileTree:node.
+
+ self assert:parser parse:'ab' to:'ab'.
+ self assert:parser parse:'cz' to:'cz'.
+ self assert:parser fail:''.
+ self assert:parser fail:'a'.
+
+ "Created: / 02-06-2015 / 17:04:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 04-06-2015 / 22:44:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 15-06-2015 / 14:08:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+testMappedActionNode2
+ node := ((#letter asParser , #letter asParser)
+ map:[:a :b | String with:a with:b ]) asCompilerTree.
+ node child markForInline.
+
+ self compileTree:node.
+
+ self assert:parser parse:'ab' to:'ab'.
+ self assert:parser parse:'cz' to:'cz'.
+ self assert:parser fail:''.
+ self assert:parser fail:'a'.
+
+ "Created: / 04-06-2015 / 23:13:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (format): / 15-06-2015 / 14:08:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+testMappedActionNode3
+ node := PPCPlusNode new
+ child:
+ (PPCMappedActionNode new
+ block: [ :l | l asUppercase ];
+ child: #letter asParser asCompilerTree;
+ yourself);
+ yourself.
+
+ self compileTree:node.
+
+ self assert:parser parse:'abc' to:#($A $B $C).
+
+ "Created: / 15-06-2015 / 18:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
testMessagePredicate
| messageNode |
messageNode := PPCMessagePredicateNode new
@@ -755,6 +874,48 @@
self assert: parser fail: 'ab'.
!
+testSequenceOptInlined1
+ | a b bOpt |
+
+ a := $a asParser asCompilerNode.
+ b := $b asParser asCompilerNode.
+ bOpt := PPCOptionalNode new
+ child: b ;
+ markForInline;
+ yourself.
+ node := PPCSequenceNode new
+ children: { a . bOpt };
+ yourself.
+ self compileTree: node.
+
+ self assert: parser parse: 'ab' to: #($a $b ) end: 2.
+ self assert: parser parse: 'a' to: #( $a nil ) end: 1.
+
+ "Created: / 22-05-2015 / 11:47:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+testSequenceOptInlined2
+ | a b bOpt |
+
+ a := $a asParser asCompilerNode.
+ a markForInline.
+ b := $b asParser asCompilerNode.
+ b markForInline.
+ bOpt := PPCOptionalNode new
+ child: b ;
+ markForInline;
+ yourself.
+ node := PPCSequenceNode new
+ children: { a . bOpt };
+ yourself.
+ self compileTree: node.
+
+ self assert: parser parse: 'ab' to: #($a $b ) end: 2.
+ self assert: parser parse: 'a' to: #( $a nil ) end: 1.
+
+ "Created: / 22-05-2015 / 11:47:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
testStarAnyNode
arguments cacheFirstFollow: false.
node := PPCStarAnyNode new
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/PPCScannerCodeGeneratorTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,247 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestCase subclass:#PPCScannerCodeGeneratorTest
+ instanceVariableNames:'fsa a b c d e codeGenerator scanner result'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Tests-Scanner'
+!
+
+!PPCScannerCodeGeneratorTest methodsFor:'as yet unclassified'!
+
+fail: stream rule: rule
+ scanner initialize.
+ scanner stream: stream asPetitStream.
+ result := scanner perform: rule.
+
+ self assert: result isEmpty
+!
+
+parse: stream token: token rule: rule
+ self parse: stream token: token rule: rule position: stream size.
+!
+
+parse: stream token: token rule: rule position: position
+ scanner initialize.
+ scanner stream: stream asPetitStream.
+ result := scanner perform: rule.
+
+ self assert: (result at: token) = position.
+!
+
+setUp
+ a := PEGFsaState new name: #a; retval: #a; yourself.
+ b := PEGFsaState new name: #b; retval: #b; yourself.
+ c := PEGFsaState new name: #c; retval: #c; yourself.
+ d := PEGFsaState new name: #d; retval: #d; yourself.
+ e := PEGFsaState new name: #e; retval: #e; yourself.
+
+ fsa := PEGFsa new.
+
+ codeGenerator := PPCScannerCodeGenerator new.
+!
+
+testA
+ fsa addState: a.
+ fsa addState: b.
+
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa name: #nextTokenA.
+ b retval: #a.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'aaa' token: #a rule: #nextTokenA position: 1.
+ self fail: 'b' rule: #nextTokenA.
+!
+
+testAAstarA
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $a.
+ fsa addTransitionFrom: c to: b on: $a.
+
+ fsa name: #nextTokenAAstarA.
+ b priority: -1.
+ c priority: 0.
+ b retval: #AAstarA.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'a' token: #AAstarA rule: #nextTokenAAstarA.
+ self parse: 'aaa' token: #AAstarA rule: #nextTokenAAstarA.
+ self parse: 'aaaaa' token: #AAstarA rule: #nextTokenAAstarA.
+
+ self fail: '' rule: #nextTokenAAstarA.
+ self fail: 'aa' rule: #nextTokenAAstarA.
+ self fail: 'aaaa' rule: #nextTokenAAstarA.
+!
+
+testAB
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $b.
+
+ fsa name: #nextTokenAB.
+ c retval: #ab.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'ab' token: #ab rule: #nextTokenAB position: 2.
+!
+
+testABorBC
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa addState: d.
+ fsa addState: e.
+ fsa startState: a.
+ fsa finalState: c.
+ fsa finalState: e.
+
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $b.
+
+ fsa addTransitionFrom: a to: d on: $b.
+ fsa addTransitionFrom: d to: e on: $c.
+
+ fsa name: #nextTokenABorBC.
+ c retval: #ab.
+ e retval: #bc.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'ab' token: #ab rule: #nextTokenABorBC position: 2.
+ self parse: 'abbc' token: #ab rule: #nextTokenABorBC position: 2.
+ self parse: 'bc' token: #bc rule: #nextTokenABorBC position: 2.
+
+ self fail: 'ac' rule: #nextTokenABorBC.
+!
+
+testABstarA
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: c on: $b.
+ fsa addTransitionFrom: c to: b on: $a.
+
+ fsa name: #nextTokenABstarA.
+ b retval: #ABstarA.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'a' token: #ABstarA rule: #nextTokenABstarA position: 1.
+ self parse: 'aa' token: #ABstarA rule: #nextTokenABstarA position: 1.
+ self parse: 'aba' token: #ABstarA rule: #nextTokenABstarA position: 3.
+ self parse: 'abaa' token: #ABstarA rule: #nextTokenABstarA position: 3.
+ self parse: 'ababa' token: #ABstarA rule: #nextTokenABstarA position: 5.
+
+
+
+ self fail: '' rule: #nextTokenABstarA.
+!
+
+testA_Bstar_A
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: c.
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: b to: b on: $b.
+ fsa addTransitionFrom: b to: c on: $a.
+
+ fsa name: #nextTokenA_Bstar_A.
+ c retval: #A_Bstar_A.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'aa' token: #A_Bstar_A rule: #nextTokenA_Bstar_A.
+ self parse: 'aba' token: #A_Bstar_A rule: #nextTokenA_Bstar_A.
+
+ self fail: '' rule: #nextTokenA_Bstar_A.
+!
+
+testAorB
+ fsa addState: a.
+ fsa addState: b.
+ fsa addState: c.
+ fsa startState: a.
+ fsa finalState: b.
+ fsa finalState: c.
+
+
+ fsa addTransitionFrom: a to: b on: $a.
+ fsa addTransitionFrom: a to: c on: $b.
+
+ fsa name: #nextTokenAorB.
+ b retval: #a.
+ c retval: #b.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'a' token: #a rule: #nextTokenAorB.
+ self parse: 'b' token: #b rule: #nextTokenAorB.
+
+ self fail: 'c' rule: #nextTokenAorB.
+ self fail: 'c' rule: #nextTokenAorB.
+!
+
+testAstarA
+ fsa addState: a.
+ fsa addState: b.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $a.
+
+ fsa name: #nextTokenAstarA.
+ b retval: #AstarA.
+
+ self should: [codeGenerator generate: fsa ] raise: Exception.
+!
+
+testAstarB
+ fsa addState: a.
+ fsa addState: b.
+ fsa startState: a.
+ fsa finalState: b.
+
+ fsa addTransitionFrom: a to: a on: $a.
+ fsa addTransitionFrom: a to: b on: $b.
+
+ fsa name: #nextTokenAstarB.
+ b retval: #AstarB.
+
+ scanner := (codeGenerator generate: fsa).
+
+ self parse: 'ab' token: #AstarB rule: #nextTokenAstarB.
+ self parse: 'b' token: #AstarB rule: #nextTokenAstarB.
+ self parse: 'aaab' token: #AstarB rule: #nextTokenAstarB.
+
+ self fail: 'c' rule: #nextTokenAstarB.
+! !
+
--- a/compiler/tests/abbrev.stc Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/abbrev.stc Fri Jul 24 15:06:54 2015 +0100
@@ -1,6 +1,15 @@
# automagically generated by the project definition
# this file is needed for stc to be able to compile modules independently.
# it provides information about a classes filename, category and especially namespace.
+FooScannerTest FooScannerTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Scanner' 1
+PEGFsaDeterminizationTest PEGFsaDeterminizationTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-FSA' 1
+PEGFsaGeneratorTest PEGFsaGeneratorTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-FSA' 1
+PEGFsaInterpretTest PEGFsaInterpretTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-FSA' 1
+PEGFsaScannerIntegrationTest PEGFsaScannerIntegrationTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Scanner' 1
+PEGFsaStateTest PEGFsaStateTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-FSA' 1
+PEGFsaTest PEGFsaTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-FSA' 1
+PEGFsaTransitionTest PEGFsaTransitionTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-FSA' 1
+PPCClassBuilderTest PPCClassBuilderTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Core' 1
PPCCodeGeneratorTest PPCCodeGeneratorTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Visitors' 1
PPCCompilerTest PPCCompilerTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Core' 1
PPCContextMementoTest PPCContextMementoTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Context' 1
@@ -17,6 +26,7 @@
PPCOptimizeChoicesTest PPCOptimizeChoicesTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Visitors' 1
PPCRecognizerComponentDetectorTest PPCRecognizerComponentDetectorTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Visitors' 1
PPCRecognizerComponentVisitorTest PPCRecognizerComponentVisitorTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Visitors' 1
+PPCScannerCodeGeneratorTest PPCScannerCodeGeneratorTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Scanner' 1
PPCSpecializingVisitorTest PPCSpecializingVisitorTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Visitors' 1
PPCTokenDetectorTest PPCTokenDetectorTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Visitors' 1
PPCTokenGuardTest PPCTokenGuardTest stx:goodies/petitparser/compiler/tests 'PetitCompiler-Tests-Guards' 1
--- a/compiler/tests/bc.mak Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/bc.mak Fri Jul 24 15:06:54 2015 +0100
@@ -53,7 +53,6 @@
prereq:
pushd ..\..\..\..\libbasic & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\libbasic2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
- pushd ..\..\..\..\libbasic3 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\libview & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\.. & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\libview2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
@@ -75,6 +74,15 @@
# BEGINMAKEDEPEND --- do not remove this line; make depend needs it
+$(OUTDIR)FooScannerTest.$(O) FooScannerTest.$(H): FooScannerTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaDeterminizationTest.$(O) PEGFsaDeterminizationTest.$(H): PEGFsaDeterminizationTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaGeneratorTest.$(O) PEGFsaGeneratorTest.$(H): PEGFsaGeneratorTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaInterpretTest.$(O) PEGFsaInterpretTest.$(H): PEGFsaInterpretTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaScannerIntegrationTest.$(O) PEGFsaScannerIntegrationTest.$(H): PEGFsaScannerIntegrationTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaStateTest.$(O) PEGFsaStateTest.$(H): PEGFsaStateTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaTest.$(O) PEGFsaTest.$(H): PEGFsaTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PEGFsaTransitionTest.$(O) PEGFsaTransitionTest.$(H): PEGFsaTransitionTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCClassBuilderTest.$(O) PPCClassBuilderTest.$(H): PPCClassBuilderTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCCodeGeneratorTest.$(O) PPCCodeGeneratorTest.$(H): PPCCodeGeneratorTest.st $(INCLUDE_TOP)\stx\goodies\petitparser\tests\PPAbstractParserTest.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCCompilerTest.$(O) PPCCompilerTest.$(H): PPCCompilerTest.st $(INCLUDE_TOP)\stx\goodies\petitparser\tests\PPAbstractParserTest.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCContextMementoTest.$(O) PPCContextMementoTest.$(H): PPCContextMementoTest.st $(INCLUDE_TOP)\stx\goodies\petitparser\tests\PPContextMementoTest.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
@@ -91,6 +99,7 @@
$(OUTDIR)PPCOptimizeChoicesTest.$(O) PPCOptimizeChoicesTest.$(H): PPCOptimizeChoicesTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCRecognizerComponentDetectorTest.$(O) PPCRecognizerComponentDetectorTest.$(H): PPCRecognizerComponentDetectorTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCRecognizerComponentVisitorTest.$(O) PPCRecognizerComponentVisitorTest.$(H): PPCRecognizerComponentVisitorTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
+$(OUTDIR)PPCScannerCodeGeneratorTest.$(O) PPCScannerCodeGeneratorTest.$(H): PPCScannerCodeGeneratorTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCSpecializingVisitorTest.$(O) PPCSpecializingVisitorTest.$(H): PPCSpecializingVisitorTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenDetectorTest.$(O) PPCTokenDetectorTest.$(H): PPCTokenDetectorTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
$(OUTDIR)PPCTokenGuardTest.$(O) PPCTokenGuardTest.$(H): PPCTokenGuardTest.st $(INCLUDE_TOP)\stx\goodies\sunit\TestAsserter.$(H) $(INCLUDE_TOP)\stx\goodies\sunit\TestCase.$(H) $(INCLUDE_TOP)\stx\libbasic\Object.$(H) $(STCHDR)
--- a/compiler/tests/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/compiler/tests/extras/Make.proto Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/Make.proto Fri Jul 24 15:06:54 2015 +0100
@@ -103,7 +103,6 @@
prereq:
cd ../../../../../libbasic && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../../libbasic2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
- cd ../../../../../libbasic3 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../../libview && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../ && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../../../libview2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
--- a/compiler/tests/extras/PPCExpressionsVerificationTest.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPCExpressionsVerificationTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -75,7 +75,22 @@
source := fileResources expressionOfSize: 100.
result := normalParser parse: source.
- self assert: ((result deepFlatten select: [ :e | e isNumber ]) size) = 100.
- self assert: ((result deepFlatten select: [ :e | e isNumber ]) size) = 100.
+ self assert: (((self deepFlattened: result) select: [ :e | e isNumber ]) size) = 100.
+ self assert: (((self deepFlattened: result)select: [ :e | e isNumber ]) size) = 100.
! !
+!PPCExpressionsVerificationTest methodsFor:'utilities'!
+
+deepFlatten: anObject into: aCollection
+ (anObject isCollection and:[anObject isString not]) ifTrue:[
+ anObject do:[:each|self deepFlatten: each into: aCollection]
+ ] ifFalse:[
+ aCollection add: anObject
+ ].
+ ^aCollection
+!
+
+deepFlattened: aCollection
+ ^self deepFlatten: aCollection into: OrderedCollection new.
+! !
+
--- a/compiler/tests/extras/PPCompiledExpressionGrammarResource.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPCompiledExpressionGrammarResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -14,7 +14,7 @@
setUp
| time configuration |
configuration := PPCConfiguration universal.
- configuration arguments name: #PPCompiledExpressionGrammar.
+ configuration arguments parserName: #PPCompiledExpressionGrammar.
time := Time millisecondsToRun: [
--- a/compiler/tests/extras/PPCompiledJavaResource.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPCompiledJavaResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -15,7 +15,7 @@
| time configuration |
configuration := PPCConfiguration universal.
- configuration arguments name:#PPCompiledJavaSyntax.
+ configuration arguments parserName:#PPCompiledJavaSyntax.
time := Time millisecondsToRun: [
PPJavaSyntax new compileWithConfiguration: configuration.
--- a/compiler/tests/extras/PPCompiledJavaSyntaxTest.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPCompiledJavaSyntaxTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -106,9 +106,9 @@
self parse: '
public class OddEven {
- private int input;
- public static void main(String[] args) {
- OddEven number = new OddEven();
+ private int input;
+ public static void main(String[] args) {
+ OddEven number = new OddEven();
number.showDialog(); }
public void showDialog() {
--- a/compiler/tests/extras/PPCompiledSmalltalkGrammarResource.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPCompiledSmalltalkGrammarResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -14,7 +14,7 @@
setUp
| time configuration |
configuration := PPCConfiguration universal.
- configuration arguments name:#PPCompiledSmalltalkGrammar.
+ configuration arguments parserName:#PPCompiledSmalltalkGrammar.
time := Time millisecondsToRun: [
PPSmalltalkGrammar new compileWithConfiguration: configuration.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/extras/PPCompiledSmalltalkParserResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,26 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests/extras' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestResource subclass:#PPCompiledSmalltalkParserResource
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Extras-Tests-Smalltalk'
+!
+
+!PPCompiledSmalltalkParserResource methodsFor:'as yet unclassified'!
+
+setUp
+ | time configuration |
+ configuration := PPCConfiguration universal.
+ configuration arguments parserName:#PPCompiledSmalltalkParser.
+
+ time := Time millisecondsToRun: [
+ PPSmalltalkParser new compileWithConfiguration: configuration.
+ ].
+ Transcript show: 'Smalltalk Parser compiled in: '; show: time asString; show: 'ms'; cr.
+
+ "Modified: / 10-05-2015 / 07:57:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/extras/PPCompiledSmalltalkParserTests.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,39 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests/extras' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCompositeParserTest subclass:#PPCompiledSmalltalkParserTests
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Extras-Tests-Smalltalk'
+!
+
+!PPCompiledSmalltalkParserTests class methodsFor:'as yet unclassified'!
+
+resources
+ ^ (OrderedCollection with: PPCompiledSmalltalkParserResource)
+ addAll: super resources;
+ yourself
+! !
+
+!PPCompiledSmalltalkParserTests methodsFor:'as yet unclassified'!
+
+context
+ ^ PPCContext new
+!
+
+parserClass
+ ^ Smalltalk at: #PPCompiledSmalltalkParser
+!
+
+parserInstanceFor: aSymbol
+ ^ (Smalltalk at: #PPCompiledSmalltalkParser) new startSymbol: aSymbol
+!
+
+testBlock1
+ self
+ parse: '[]'
+ rule: #block
+! !
+
--- a/compiler/tests/extras/PPLL1ExpressionGrammar.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPLL1ExpressionGrammar.st Fri Jul 24 15:06:54 2015 +0100
@@ -14,12 +14,14 @@
add
^ prod, addPrime optional
- map: [ :_prod :_addPrime |
- _addPrime isNil
- ifTrue: [ _prod ]
- ifFalse: [ Array with: _prod withAll: _addPrime ]
-
- ]
+ map: [ :_prod :_addPrime |
+ _addPrime isNil
+ ifTrue: [ _prod ]
+ ifFalse: [ (Array with: _prod) , _addPrime ]
+
+ ]
+
+ "Modified (format): / 26-05-2015 / 07:23:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
addPrime
@@ -28,12 +30,14 @@
mul
^ prim, mulPrime optional
- map: [ :_prim :_mulPrime |
- _mulPrime isNil
- ifTrue: [ _prim ]
- ifFalse: [ Array with: _prim withAll: _mulPrime ]
-
- ]
+ map: [ :_prim :_mulPrime |
+ _mulPrime isNil
+ ifTrue: [ _prim ]
+ ifFalse: [ (Array with: _prim) , _mulPrime ]
+
+ ]
+
+ "Modified (format): / 26-05-2015 / 07:23:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
mulPrime
@@ -62,11 +66,13 @@
term
^ prod, termPrime optional
- map: [ :_prod :_termPrime |
+ map: [ :_prod :_termPrime |
_termPrime isNil
ifTrue: [ _prod ]
- ifFalse: [ Array with: _prod withAll: _termPrime ]
- ]
+ ifFalse: [ (Array with: _prod) , _termPrime ]
+ ]
+
+ "Modified: / 26-05-2015 / 07:24:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
termPrime
--- a/compiler/tests/extras/PPTokenizedExpressionGrammarResource.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPTokenizedExpressionGrammarResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -9,18 +9,27 @@
category:'PetitCompiler-Extras-Tests-Expressions'
!
+
!PPTokenizedExpressionGrammarResource methodsFor:'as yet unclassified'!
setUp
| time configuration |
configuration := PPCTokenizingConfiguration new.
- configuration arguments name:#PPTokenizedExpressionGrammar.
+ configuration arguments parserName:#PPTokenizedExpressionGrammar.
time := Time millisecondsToRun: [
PPExpressionGrammar new compileWithConfiguration: configuration.
].
- Transcript crShow: 'Expression grammar tokenized in: ', time asString, 'ms'.
-
+ Transcript show: 'Expression grammar tokenized in: '; show: time asString; show: 'ms'; cr.
+
+ "Modified: / 26-05-2015 / 07:25:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
+!PPTokenizedExpressionGrammarResource class methodsFor:'documentation'!
+
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+! !
+
--- a/compiler/tests/extras/PPTokenizedLL1ExpressionGrammarResource.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPTokenizedLL1ExpressionGrammarResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -14,13 +14,14 @@
setUp
| time configuration |
configuration := PPCTokenizingConfiguration new.
- configuration arguments name:#PPTokenizedLL1ExpressionGrammar.
+ configuration arguments parserName:#PPTokenizedLL1ExpressionGrammar.
time := Time millisecondsToRun: [
PPLL1ExpressionGrammar new compileWithConfiguration: configuration.
].
- Transcript crShow: 'LL1 Expression grammar tokenized in: ', time asString, 'ms'.
-
+ Transcript show: 'LL1 Expression grammar tokenized in: '; show: time asString; show: 'ms'; cr.
+
+ "Modified: / 26-05-2015 / 07:24:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
--- a/compiler/tests/extras/PPTokenizedSmalltalkGrammarResource.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/PPTokenizedSmalltalkGrammarResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -15,7 +15,7 @@
setUp
| time configuration |
configuration := PPCConfiguration tokenizing.
- configuration arguments name:#PPTokenizedSmalltalkGrammar.
+ configuration arguments parserName:#PPTokenizedSmalltalkGrammar.
time := Time millisecondsToRun: [
PPSmalltalkGrammar new compileWithConfiguration: configuration.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/extras/PPTokenizedSmalltalkParserResource.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,39 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests/extras' }"
+
+"{ NameSpace: Smalltalk }"
+
+TestResource subclass:#PPTokenizedSmalltalkParserResource
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Extras-Tests-Smalltalk'
+!
+
+!PPTokenizedSmalltalkParserResource methodsFor:'as yet unclassified'!
+
+setUp
+ | time configuration |
+ configuration := PPCConfiguration tokenizing.
+ configuration arguments parserName:#PPTokenizedSmalltalkParser.
+
+ time := Time millisecondsToRun: [
+ PPSmalltalkParser new compileWithConfiguration: configuration.
+ ].
+ Transcript show: 'Smalltalk Parser tokenized in: '; show: time asString; show: 'ms'; cr.
+
+ "Modified: / 10-05-2015 / 07:55:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+tearDown
+ | parserClass |
+ super tearDown.
+
+ parserClass := (Smalltalk at: #PPTokenizedSmalltalkParser ifAbsent: [nil]).
+ self flag: 'uncomment:'.
+"
+ parserClass notNil ifTrue:[
+ parserClass removeFromSystem
+ ].
+"
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/extras/PPTokenizedSmalltalkParserTests.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,935 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests/extras' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCompositeParserTest subclass:#PPTokenizedSmalltalkParserTests
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Extras-Tests-Smalltalk'
+!
+
+!PPTokenizedSmalltalkParserTests class methodsFor:'accessing'!
+
+resources
+ ^ (OrderedCollection with: PPTokenizedSmalltalkParserResource)
+ addAll: super resources;
+ yourself
+! !
+
+!PPTokenizedSmalltalkParserTests methodsFor:'accessing'!
+
+context
+ ^ PPCContext new
+!
+
+parserClass
+ ^ Smalltalk at: #PPTokenizedSmalltalkParser
+!
+
+parserInstanceFor: aSymbol
+ ^ (Smalltalk at: #PPTokenizedSmalltalkParser) new startSymbol: aSymbol
+!
+
+testSmalltalkWhitespace
+ | whitespaces |
+ whitespaces := parser class methodDictionary keys select: [:e | e beginsWith: 'smalltalk_ws' ].
+ self assert: whitespaces size = 1.
+! !
+
+!PPTokenizedSmalltalkParserTests methodsFor:'testing'!
+
+testArray1
+ self
+ parse: '{}'
+ rule: #array
+!
+
+testArray2
+ self
+ parse: '{self foo}'
+ rule: #array
+!
+
+testArray3
+ self
+ parse: '{self foo. self bar}'
+ rule: #array
+!
+
+testArray4
+ self
+ parse: '{self foo. self bar.}'
+ rule: #array
+!
+
+testAssignment1
+ self
+ parse: '1'
+ rule: #expression
+!
+
+testAssignment2
+ self
+ parse: 'a := 1'
+ rule: #expression
+!
+
+testAssignment3
+ self
+ parse: 'a := b := 1'
+ rule: #expression
+!
+
+testAssignment4
+ PPSmalltalkGrammar allowUnderscoreAssignment
+ ifTrue: [ self parse: 'a _ 1' rule: #expression ]
+ ifFalse: [ self fail: 'a _ 1' rule: #expression ]
+!
+
+testAssignment5
+ PPSmalltalkGrammar allowUnderscoreAssignment
+ ifTrue: [ self parse: 'a _ b _ 1' rule: #expression ]
+ ifFalse: [ self fail: 'a _ b _ 1' rule: #expression ]
+!
+
+testAssignment6
+ self
+ parse: 'a := (b := c)'
+ rule: #expression
+!
+
+testComment1
+ self
+ parse: '1"one"+2'
+ rule: #expression
+!
+
+testComment2
+ self
+ parse: '1 "one" +2'
+ rule: #expression
+!
+
+testComment3
+ self
+ parse: '1"one"+"two"2'
+ rule: #expression
+!
+
+testComment4
+ self
+ parse: '1"one""two"+2'
+ rule: #expression
+!
+
+testComment5
+ self
+ parse: '1"one" "two"+2'
+ rule: #expression
+!
+
+testCompleteness
+ "This test asserts that all subclasses override all test methods."
+
+ self class allSubclasses do: [ :subclass |
+ self class testSelectors do: [ :selector |
+ self
+ assert: (selector = #testCompleteness or: [ subclass selectors includes: selector ])
+ description: subclass printString , ' does not test ' , selector printString ] ]
+!
+
+testMethod1
+ self
+ parse: 'negated ^ 0 - self'
+ rule: #method
+!
+
+testMethod2
+ "Spaces at the beginning of the method."
+ self
+ parse: ' negated ^ 0 - self'
+ rule: #method
+!
+
+testMethod3
+ "Spaces at the end of the method."
+ self
+ parse: ' negated ^ 0 - self '
+ rule: #method
+!
+
+testMethod4
+ self
+ parse: 'foo: bar
+ foo:= bar'
+ rule: #method
+!
+
+testSequence1
+ self
+ parse: '| a | 1 . 2'
+ rule: #sequence
+!
+
+testStatements1
+ self
+ parse: '1'
+ rule: #sequence
+!
+
+testStatements2
+ self
+ parse: '1 . 2'
+ rule: #sequence
+!
+
+testStatements3
+ self
+ parse: '1 . 2 . 3'
+ rule: #sequence
+!
+
+testStatements4
+ self
+ parse: '1 . 2 . 3 .'
+ rule: #sequence
+!
+
+testStatements5
+ self
+ parse: '1 . . 2'
+ rule: #sequence
+!
+
+testStatements6
+ self
+ parse: '1. 2'
+ rule: #sequence
+!
+
+testStatements7
+ self
+ parse: '. 1'
+ rule: #sequence
+!
+
+testStatements8
+ self
+ parse: '.1'
+ rule: #sequence
+!
+
+testStatements9
+ self
+ parse: ''
+ rule: #statements
+!
+
+testTemporaries1
+ self
+ parse: '| a |'
+ rule: #sequence
+!
+
+testTemporaries2
+ self
+ parse: '| a b |'
+ rule: #sequence
+!
+
+testTemporaries3
+ self
+ parse: '| a b c |'
+ rule: #sequence
+!
+
+testVariable1
+ self
+ parse: 'trueBinding'
+ rule: #primary
+!
+
+testVariable2
+ self
+ parse: 'falseBinding'
+ rule: #primary
+!
+
+testVariable3
+ self
+ parse: 'nilly'
+ rule: #primary
+!
+
+testVariable4
+ self
+ parse: 'selfish'
+ rule: #primary
+!
+
+testVariable5
+ self
+ parse: 'supernanny'
+ rule: #primary
+!
+
+testVariable6
+ PPSmalltalkGrammar allowUnderscoreAssignment ifFalse: [
+ self
+ parse: 'super_nanny'
+ rule: #primary ]
+!
+
+testVariable7
+ PPSmalltalkGrammar allowUnderscoreAssignment ifFalse: [
+ self
+ parse: '__gen_var_123__'
+ rule: #primary ]
+! !
+
+!PPTokenizedSmalltalkParserTests methodsFor:'testing-blocks'!
+
+testArgumentsBlock1
+ self
+ parse: '[ :a | ]'
+ rule: #block
+!
+
+testArgumentsBlock2
+ self
+ parse: '[ :a :b | ]'
+ rule: #block
+!
+
+testArgumentsBlock3
+ self
+ parse: '[ :a :b :c | ]'
+ rule: #block
+!
+
+testBlock1
+ self
+ parse: '[]'
+ rule: #block
+!
+
+testComplexBlock1
+ self
+ parse: '[ :a | | b | c ]'
+ rule: #block
+!
+
+testComplexBlock2
+ self
+ parse: '[:a||b|c]'
+ rule: #block
+!
+
+testSimpleBlock1
+ self
+ parse: '[ ]'
+ rule: #block
+!
+
+testSimpleBlock2
+ self
+ parse: '[ nil ]'
+ rule: #block
+!
+
+testSimpleBlock3
+ self
+ parse: '[ :a ]'
+ rule: #block
+!
+
+testStatementBlock1
+ self
+ parse: '[ nil ]'
+ rule: #block
+!
+
+testStatementBlock2
+ self
+ parse: '[ | a | nil ]'
+ rule: #block
+!
+
+testStatementBlock3
+ self
+ parse: '[ | a b | nil ]'
+ rule: #block
+! !
+
+!PPTokenizedSmalltalkParserTests methodsFor:'testing-literals'!
+
+testArrayLiteral1
+ self
+ parse: '#()'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral10
+ self
+ parse: '#((1 2) #(1 2 3))'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral11
+ self
+ parse: '#([1 2] #[1 2 3])'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral2
+ self
+ parse: '#(1)'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral3
+ self
+ parse: '#(1 2)'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral4
+ self
+ parse: '#(true false nil)'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral5
+ self
+ parse: '#($a)'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral6
+ self
+ parse: '#(1.2)'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral7
+ self
+ parse: '#(size #at: at:put: #''=='')'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral8
+ self
+ parse: '#(''baz'')'
+ rule: #arrayLiteral
+!
+
+testArrayLiteral9
+ self
+ parse: '#((1) 2)'
+ rule: #arrayLiteral
+!
+
+testByteLiteral1
+ self
+ parse: '#[]'
+ rule: #byteLiteral
+!
+
+testByteLiteral2
+ self
+ parse: '#[0]'
+ rule: #byteLiteral
+!
+
+testByteLiteral3
+ self
+ parse: '#[255]'
+ rule: #byteLiteral
+!
+
+testByteLiteral4
+ self
+ parse: '#[ 1 2 ]'
+ rule: #byteLiteral
+!
+
+testByteLiteral5
+ self
+ parse: '#[ 2r1010 8r77 16rFF ]'
+ rule: #byteLiteral
+!
+
+testCharLiteral1
+ self
+ parse: '$a'
+ rule: #charLiteral
+!
+
+testCharLiteral2
+ self
+ parse: '$ '
+ rule: #charLiteral
+!
+
+testCharLiteral3
+ self
+ parse: '$$'
+ rule: #charLiteral
+!
+
+testNumberLiteral1
+ self
+ parse: '0'
+ rule: #numberLiteral
+!
+
+testNumberLiteral10
+ self
+ parse: '10r10'
+ rule: #numberLiteral
+!
+
+testNumberLiteral11
+ self
+ parse: '8r777'
+ rule: #numberLiteral
+!
+
+testNumberLiteral12
+ self
+ parse: '16rAF'
+ rule: #numberLiteral
+!
+
+testNumberLiteral13
+ self
+ parse: '16rCA.FE'
+ rule: #numberLiteral
+!
+
+testNumberLiteral14
+ self
+ parse: '3r-22.2'
+ rule: #numberLiteral
+!
+
+testNumberLiteral15
+ self
+ parse: '0.50s2'
+ rule: #numberLiteral
+!
+
+testNumberLiteral2
+ self
+ parse: '0.1'
+ rule: #numberLiteral
+!
+
+testNumberLiteral3
+ self
+ parse: '123'
+ rule: #numberLiteral
+!
+
+testNumberLiteral4
+ self
+ parse: '123.456'
+ rule: #numberLiteral
+!
+
+testNumberLiteral5
+ self
+ parse: '-0'
+ rule: #numberLiteral
+!
+
+testNumberLiteral6
+ self
+ parse: '-0.1'
+ rule: #numberLiteral
+!
+
+testNumberLiteral7
+ self
+ parse: '-123'
+ rule: #numberLiteral
+!
+
+testNumberLiteral8
+ self
+ parse: '-125'
+ rule: #numberLiteral
+!
+
+testNumberLiteral9
+ self
+ parse: '-123.456'
+ rule: #numberLiteral
+!
+
+testSpecialLiteral1
+ self
+ parse: 'true'
+ rule: #trueLiteral
+!
+
+testSpecialLiteral2
+ self
+ parse: 'false'
+ rule: #falseLiteral
+!
+
+testSpecialLiteral3
+ self
+ parse: 'nil'
+ rule: #nilLiteral
+!
+
+testStringLiteral1
+ self
+ parse: ''''''
+ rule: #stringLiteral
+!
+
+testStringLiteral2
+ self
+ parse: '''ab'''
+ rule: #stringLiteral
+!
+
+testStringLiteral3
+ self
+ parse: '''ab''''cd'''
+ rule: #stringLiteral
+!
+
+testSymbolLiteral1
+ self
+ parse: '#foo'
+ rule: #symbolLiteral
+!
+
+testSymbolLiteral2
+ self
+ parse: '#+'
+ rule: #symbolLiteral
+!
+
+testSymbolLiteral3
+ self
+ parse: '#key:'
+ rule: #symbolLiteral
+!
+
+testSymbolLiteral4
+ self
+ parse: '#key:value:'
+ rule: #symbolLiteral
+!
+
+testSymbolLiteral5
+ self
+ parse: '#''testing-result'''
+ rule: #symbolLiteral
+!
+
+testSymbolLiteral6
+ PPSmalltalkGrammar allowUnderscoreAssignment ifFalse: [
+ self
+ parse: '#__gen__binding'
+ rule: #symbolLiteral ]
+!
+
+testSymbolLiteral7
+ self
+ parse: '# fucker'
+ rule: #symbolLiteral
+!
+
+testSymbolLiteral8
+ self
+ parse: '##fucker'
+ rule: #symbolLiteral
+!
+
+testSymbolLiteral9
+ self
+ parse: '## fucker'
+ rule: #symbolLiteral
+! !
+
+!PPTokenizedSmalltalkParserTests methodsFor:'testing-messages'!
+
+testBinaryExpression1
+ self
+ parse: '1 + 2'
+ rule: #expression
+!
+
+testBinaryExpression2
+ self
+ parse: '1 + 2 + 3'
+ rule: #expression
+!
+
+testBinaryExpression3
+ self
+ parse: '1 // 2'
+ rule: #expression
+!
+
+testBinaryExpression4
+ self
+ parse: '1 -- 2'
+ rule: #expression
+!
+
+testBinaryExpression5
+ self
+ parse: '1 ==> 2'
+ rule: #expression.
+!
+
+testBinaryMethod1
+ self
+ parse: '+ a'
+ rule: #method
+!
+
+testBinaryMethod2
+ self
+ parse: '+ a | b |'
+ rule: #method
+!
+
+testBinaryMethod3
+ self
+ parse: '+ a b'
+ rule: #method
+!
+
+testBinaryMethod4
+ self
+ parse: '+ a | b | c'
+ rule: #method
+!
+
+testBinaryMethod5
+ self
+ parse: '-- a'
+ rule: #method
+!
+
+testCascadeExpression1
+ self
+ parse: '1 abs; negated'
+ rule: #expression
+!
+
+testCascadeExpression2
+ self
+ parse: '1 abs negated; raisedTo: 12; negated'
+ rule: #expression
+!
+
+testCascadeExpression3
+ self
+ parse: '1 + 2; - 3'
+ rule: #expression
+!
+
+testIdentifierToken
+ self
+ parse: 'foo'
+ rule: #identifierToken
+!
+
+testIdentifierToken2
+ self
+ parse: ' foo'
+ rule: #identifierToken
+!
+
+testKeywordExpression1
+ self
+ parse: '1 to: 2'
+ rule: #expression
+!
+
+testKeywordExpression2
+ self
+ parse: '1 to: 2 by: 3'
+ rule: #expression
+!
+
+testKeywordExpression3
+ self
+ parse: '1 to: 2 by: 3 do: 4'
+ rule: #expression
+!
+
+testKeywordMethod1
+ self
+ parse: 'to: a'
+ rule: #method
+!
+
+testKeywordMethod2
+ self
+ parse: 'to: a do: b | c |'
+ rule: #method
+!
+
+testKeywordMethod3
+ self
+ parse: 'to: a do: b by: c d'
+ rule: #method
+!
+
+testKeywordMethod4
+ self
+ parse: 'to: a do: b by: c | d | e'
+ rule: #method
+!
+
+testUnaryExpression1
+ self
+ parse: '1 abs'
+ rule: #expression
+!
+
+testUnaryExpression2
+ self
+ parse: '1 abs negated'
+ rule: #expression
+!
+
+testUnaryMethod1
+ self
+ parse: 'abs'
+ rule: #method
+!
+
+testUnaryMethod2
+ self
+ parse: 'abs | a |'
+ rule: #method
+!
+
+testUnaryMethod3
+ self
+ parse: 'abs a'
+ rule: #method
+!
+
+testUnaryMethod4
+ self
+ parse: 'abs | a | b'
+ rule: #method
+!
+
+testUnaryMethod5
+ self
+ parse: 'abs | a |'
+ rule: #method
+! !
+
+!PPTokenizedSmalltalkParserTests methodsFor:'testing-pragmas'!
+
+testPragma1
+ self
+ parse: 'method <foo>'
+ rule: #method
+!
+
+testPragma10
+ self
+ parse: 'method <foo: bar>'
+ rule: #method
+!
+
+testPragma11
+ self
+ parse: 'method <foo: true>'
+ rule: #method
+!
+
+testPragma12
+ self
+ parse: 'method <foo: false>'
+ rule: #method
+!
+
+testPragma13
+ self
+ parse: 'method <foo: nil>'
+ rule: #method
+!
+
+testPragma14
+ self
+ parse: 'method <foo: ()>'
+ rule: #method
+!
+
+testPragma15
+ self
+ parse: 'method <foo: #()>'
+ rule: #method
+!
+
+testPragma16
+ self
+ parse: 'method < + 1 >'
+ rule: #method
+!
+
+testPragma2
+ self
+ parse: 'method <foo> <bar>'
+ rule: #method
+!
+
+testPragma3
+ self
+ parse: 'method | a | <foo>'
+ rule: #method
+!
+
+testPragma4
+ self
+ parse: 'method <foo> | a |'
+ rule: #method
+!
+
+testPragma5
+ self
+ parse: 'method <foo> | a | <bar>'
+ rule: #method
+!
+
+testPragma6
+ self
+ parse: 'method <foo: 1>'
+ rule: #method
+!
+
+testPragma7
+ self
+ parse: 'method <foo: 1.2>'
+ rule: #method
+!
+
+testPragma8
+ self
+ parse: 'method <foo: ''bar''>'
+ rule: #method
+!
+
+testPragma9
+ self
+ parse: 'method <foo: #''bar''>'
+ rule: #method
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/tests/extras/PPTokenizedSmalltalkParserVerificationTest.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,39 @@
+"{ Package: 'stx:goodies/petitparser/compiler/tests/extras' }"
+
+"{ NameSpace: Smalltalk }"
+
+PPCSmalltalkVerificationTest subclass:#PPTokenizedSmalltalkParserVerificationTest
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-Extras-Tests-Smalltalk'
+!
+
+!PPTokenizedSmalltalkParserVerificationTest class methodsFor:'as yet unclassified'!
+
+resources
+ ^ (OrderedCollection with: PPTokenizedSmalltalkParserResource)
+ addAll: super resources;
+ yourself
+! !
+
+!PPTokenizedSmalltalkParserVerificationTest methodsFor:'accessing'!
+
+compiledSmalltalkGrammarClass
+ ^ (Smalltalk at: #PPTokenizedSmalltalkParser)
+! !
+
+!PPTokenizedSmalltalkParserVerificationTest methodsFor:'tests'!
+
+testSmalltalk
+ super testSmalltalk
+!
+
+testSmalltalkClass
+ super testSmalltalkClass
+!
+
+testSmalltalkObject
+ super testSmalltalkObject
+! !
+
--- a/compiler/tests/extras/abbrev.stc Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/abbrev.stc Fri Jul 24 15:06:54 2015 +0100
@@ -12,6 +12,8 @@
PPCompiledJavaSyntaxTest PPCompiledJavaSyntaxTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Java' 1
PPCompiledSmalltalkGrammarResource PPCompiledSmalltalkGrammarResource stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
PPCompiledSmalltalkGrammarTests PPCompiledSmalltalkGrammarTests stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
+PPCompiledSmalltalkParserResource PPCompiledSmalltalkParserResource stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
+PPCompiledSmalltalkParserTests PPCompiledSmalltalkParserTests stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
PPExpressionGrammar PPExpressionGrammar stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Expressions' 0
PPExpressionGrammarTest PPExpressionGrammarTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Expressions' 1
PPLL1ExpressionGrammar PPLL1ExpressionGrammar stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Expressions' 0
@@ -22,8 +24,11 @@
PPTokenizedLL1ExpressionGrammarTest PPTokenizedLL1ExpressionGrammarTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Expressions' 1
PPTokenizedSmalltalkGrammarResource PPTokenizedSmalltalkGrammarResource stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
PPTokenizedSmalltalkGrammarTests PPTokenizedSmalltalkGrammarTests stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
+PPTokenizedSmalltalkParserResource PPTokenizedSmalltalkParserResource stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
+PPTokenizedSmalltalkParserTests PPTokenizedSmalltalkParserTests stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
stx_goodies_petitparser_compiler_tests_extras stx_goodies_petitparser_compiler_tests_extras stx:goodies/petitparser/compiler/tests/extras '* Projects & Packages *' 3
PPCompiledExpressionsVerificationTest PPCompiledExpressionsVerificationTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Expressions' 1
PPCompiledSmalltalkVerificationTest PPCompiledSmalltalkVerificationTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
PPTokenizedExpressionsVerificationTest PPTokenizedExpressionsVerificationTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Expressions' 1
+PPTokenizedSmalltalkParserVerificationTest PPTokenizedSmalltalkParserVerificationTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
PPTokenizedSmalltalkVerificationTest PPTokenizedSmalltalkVerificationTest stx:goodies/petitparser/compiler/tests/extras 'PetitCompiler-Extras-Tests-Smalltalk' 1
--- a/compiler/tests/extras/bc.mak Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/bc.mak Fri Jul 24 15:06:54 2015 +0100
@@ -53,7 +53,6 @@
prereq:
pushd ..\..\..\..\..\libbasic & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\..\libbasic2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
- pushd ..\..\..\..\..\libbasic3 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\..\libview & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\.. & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\..\..\libview2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
--- a/compiler/tests/extras/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/compiler/tests/extras/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\..\..\rules
@call find_mingw.bat
--- a/compiler/tests/extras/stx_goodies_petitparser_compiler_tests_extras.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/stx_goodies_petitparser_compiler_tests_extras.st Fri Jul 24 15:06:54 2015 +0100
@@ -113,6 +113,8 @@
(PPCompiledJavaSyntaxTest autoload)
(PPCompiledSmalltalkGrammarResource autoload)
(PPCompiledSmalltalkGrammarTests autoload)
+ (PPCompiledSmalltalkParserResource autoload)
+ (PPCompiledSmalltalkParserTests autoload)
PPExpressionGrammar
(PPExpressionGrammarTest autoload)
PPLL1ExpressionGrammar
@@ -123,10 +125,13 @@
(PPTokenizedLL1ExpressionGrammarTest autoload)
(PPTokenizedSmalltalkGrammarResource autoload)
(PPTokenizedSmalltalkGrammarTests autoload)
+ (PPTokenizedSmalltalkParserResource autoload)
+ (PPTokenizedSmalltalkParserTests autoload)
#'stx_goodies_petitparser_compiler_tests_extras'
(PPCompiledExpressionsVerificationTest autoload)
(PPCompiledSmalltalkVerificationTest autoload)
(PPTokenizedExpressionsVerificationTest autoload)
+ (PPTokenizedSmalltalkParserVerificationTest autoload)
(PPTokenizedSmalltalkVerificationTest autoload)
)
!
--- a/compiler/tests/extras/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/extras/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/compiler/tests/libInit.cc Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/libInit.cc Fri Jul 24 15:06:54 2015 +0100
@@ -27,6 +27,15 @@
void _libstx_goodies_petitparser_compiler_tests_Init(pass, __pRT__, snd)
OBJ snd; struct __vmData__ *__pRT__; {
__BEGIN_PACKAGE2__("libstx_goodies_petitparser_compiler_tests", _libstx_goodies_petitparser_compiler_tests_Init, "stx:goodies/petitparser/compiler/tests");
+_FooScannerTest_Init(pass,__pRT__,snd);
+_PEGFsaDeterminizationTest_Init(pass,__pRT__,snd);
+_PEGFsaGeneratorTest_Init(pass,__pRT__,snd);
+_PEGFsaInterpretTest_Init(pass,__pRT__,snd);
+_PEGFsaScannerIntegrationTest_Init(pass,__pRT__,snd);
+_PEGFsaStateTest_Init(pass,__pRT__,snd);
+_PEGFsaTest_Init(pass,__pRT__,snd);
+_PEGFsaTransitionTest_Init(pass,__pRT__,snd);
+_PPCClassBuilderTest_Init(pass,__pRT__,snd);
_PPCCodeGeneratorTest_Init(pass,__pRT__,snd);
_PPCCompilerTest_Init(pass,__pRT__,snd);
_PPCContextMementoTest_Init(pass,__pRT__,snd);
@@ -43,6 +52,7 @@
_PPCOptimizeChoicesTest_Init(pass,__pRT__,snd);
_PPCRecognizerComponentDetectorTest_Init(pass,__pRT__,snd);
_PPCRecognizerComponentVisitorTest_Init(pass,__pRT__,snd);
+_PPCScannerCodeGeneratorTest_Init(pass,__pRT__,snd);
_PPCSpecializingVisitorTest_Init(pass,__pRT__,snd);
_PPCTokenDetectorTest_Init(pass,__pRT__,snd);
_PPCTokenGuardTest_Init(pass,__pRT__,snd);
--- a/compiler/tests/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\..\rules
@call find_mingw.bat
--- a/compiler/tests/stx_goodies_petitparser_compiler_tests.st Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/stx_goodies_petitparser_compiler_tests.st Fri Jul 24 15:06:54 2015 +0100
@@ -57,7 +57,7 @@
^ #(
#'stx:goodies/petitparser/tests' "PPAbstractParserTest - superclass of PPCCodeGeneratorTest"
- #'stx:goodies/sunit' "TestAsserter - superclass of PPCCodeGeneratorTest"
+ #'stx:goodies/sunit' "TestAsserter - superclass of FooScannerTest"
#'stx:libbasic' "LibraryDefinition - superclass of stx_goodies_petitparser_compiler_tests"
)
!
@@ -73,8 +73,8 @@
by searching all classes (and their packages) which are referenced by my classes."
^ #(
- #'stx:goodies/petitparser' "PPCharSetPredicate - referenced by PPCCodeGeneratorTest>>testCharSetPredicateNode"
- #'stx:goodies/petitparser/compiler' "PPCAbstractLiteralNode - referenced by PPCNodeFirstFollowNextTests>>testFirst1"
+ #'stx:goodies/petitparser' "PPCharSetPredicate - referenced by PEGFsaGeneratorTest>>testCharSetPredicateNode"
+ #'stx:goodies/petitparser/compiler' "FooScanner - referenced by FooScannerTest>>setUp"
#'stx:goodies/petitparser/parsers/java' "PPJavaWhitespaceParser - referenced by PPCMergingVisitorTest>>javaWsNode"
)
!
@@ -107,6 +107,15 @@
^ #(
"<className> or (<className> attributes...) in load order"
+ FooScannerTest
+ PEGFsaDeterminizationTest
+ PEGFsaGeneratorTest
+ PEGFsaInterpretTest
+ PEGFsaScannerIntegrationTest
+ PEGFsaStateTest
+ PEGFsaTest
+ PEGFsaTransitionTest
+ PPCClassBuilderTest
PPCCodeGeneratorTest
PPCCompilerTest
PPCContextMementoTest
@@ -123,6 +132,7 @@
PPCOptimizeChoicesTest
PPCRecognizerComponentDetectorTest
PPCRecognizerComponentVisitorTest
+ PPCScannerCodeGeneratorTest
PPCSpecializingVisitorTest
PPCTokenDetectorTest
PPCTokenGuardTest
--- a/compiler/tests/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/tests/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/compiler/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/compiler/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/islands/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/islands/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/islands/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/islands/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\rules
@call find_mingw.bat
--- a/islands/tests/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/islands/tests/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/islands/tests/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/islands/tests/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\..\rules
@call find_mingw.bat
--- a/islands/tests/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/islands/tests/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/islands/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/islands/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\rules
@call find_mingw.bat
--- a/tests/Make.proto Thu May 21 14:12:22 2015 +0100
+++ b/tests/Make.proto Fri Jul 24 15:06:54 2015 +0100
@@ -103,7 +103,6 @@
prereq:
cd ../../../libbasic && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../libbasic2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
- cd ../../../libbasic3 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../libview && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../ && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
cd ../../../libview2 && $(MAKE) "CFLAGS_LOCAL=$(GLOBALDEFINES)"
--- a/tests/PPArithmeticParser.st Thu May 21 14:12:22 2015 +0100
+++ b/tests/PPArithmeticParser.st Fri Jul 24 15:06:54 2015 +0100
@@ -66,6 +66,11 @@
^ '$Header: /cvs/stx/stx/goodies/petitparser/PPArithmeticParser.st,v 1.4 2014-03-04 14:33:59 cg Exp $'
!
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+!
+
version_SVN
^ '$Id: PPArithmeticParser.st,v 1.4 2014-03-04 14:33:59 cg Exp $'
! !
--- a/tests/bc.mak Thu May 21 14:12:22 2015 +0100
+++ b/tests/bc.mak Fri Jul 24 15:06:54 2015 +0100
@@ -53,7 +53,6 @@
prereq:
pushd ..\..\..\libbasic & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\libbasic2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
- pushd ..\..\..\libbasic3 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\libview & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd .. & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
pushd ..\..\..\libview2 & $(MAKE_BAT) "CFLAGS_LOCAL=$(GLOBALDEFINES) "
--- a/tests/bmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/tests/bmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,7 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak %DEFINES% %*
--- a/tests/mingwmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/tests/mingwmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -4,9 +4,6 @@
@REM do not edit - automatically generated from ProjectDefinition
@REM -------
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
@pushd ..\..\..\rules
@call find_mingw.bat
--- a/tests/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/tests/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,11 +10,8 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
--- a/vcmake.bat Thu May 21 14:12:22 2015 +0100
+++ b/vcmake.bat Fri Jul 24 15:06:54 2015 +0100
@@ -10,13 +10,10 @@
popd
)
@SET DEFINES=
-@REM Kludge got Mercurial, cannot be implemented in Borland make
-@FOR /F "tokens=*" %%i in ('hg root') do SET HGROOT=%%i
-@IF "%HGROOT%" NEQ "" SET DEFINES=%DEFINES% "-DHGROOT=%HGROOT%"
+
make.exe -N -f bc.mak -DUSEVC=1 %DEFINES% %*
-
@echo "***********************************"
@echo "Buildung stx/goodies/petitparser/analyzer
@echo "***********************************"