--- a/PPCompositeParser.st Fri Jun 19 08:13:39 2015 +0100
+++ b/PPCompositeParser.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/PPDelegateParser.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/PPFlattenParser.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/PPSequenceParser.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/analyzer/bmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/analyzer/mingwmake.bat Fri Jul 24 15:37:23 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/bmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/analyzer/tests/bmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/analyzer/tests/mingwmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/analyzer/tests/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/analyzer/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/bmake.bat Fri Jul 24 15:37:23 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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/Make.proto Fri Jul 24 15:37:23 2015 +0100
@@ -130,9 +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,10 +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)
@@ -158,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)
--- a/compiler/Make.spec Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/Make.spec Fri Jul 24 15:37:23 2015 +0100
@@ -51,9 +51,17 @@
STCWARNINGS=-warnNonStandard
COMMON_CLASSES= \
+ PEGFsa \
+ PEGFsaFailure \
+ PEGFsaInterpret \
+ PEGFsaPair \
+ PEGFsaState \
+ PEGFsaTransition \
PPCArguments \
PPCBridge \
PPCCodeBlock \
+ PPCClassBuilder \
+ PPCCodeGen \
PPCCompiledMethod \
PPCCompiler \
PPCCompilerTokenErrorStrategy \
@@ -68,10 +76,14 @@
PPCNode \
PPCNodeVisitor \
PPCPluggableConfiguration \
+ PPCScanner \
+ PPCScannerCodeGenerator \
PPCTokenGuard \
PPCompiledParser \
PPMappedActionParser \
stx_goodies_petitparser_compiler \
+ FooScanner \
+ PEGFsaGenerator \
PPCAbstractLiteralNode \
PPCAbstractPredicateNode \
PPCAnyNode \
@@ -79,6 +91,7 @@
PPCCodeGenerator \
PPCDelegateNode \
PPCEndOfFileNode \
+ PPCFSACodeGen \
PPCInlinedMethod \
PPCInliningVisitor \
PPCListNode \
@@ -146,9 +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)PPCCodeBlock.$(O) \
+ $(OUTDIR_SLASH)PPCClassBuilder.$(O) \
+ $(OUTDIR_SLASH)PPCCodeGen.$(O) \
$(OUTDIR_SLASH)PPCCompiledMethod.$(O) \
$(OUTDIR_SLASH)PPCCompiler.$(O) \
$(OUTDIR_SLASH)PPCCompilerTokenErrorStrategy.$(O) \
@@ -163,10 +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) \
@@ -174,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) \
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsa.st Fri Jul 24 15:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCArguments.st Fri Jul 24 15:37:23 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:37:23 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.
+! !
+
--- a/compiler/PPCCodeBlock.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCCodeBlock.st Fri Jul 24 15:37:23 2015 +0100
@@ -39,26 +39,12 @@
code: aStringOrBlockOrRBParseNode
aStringOrBlockOrRBParseNode isString ifTrue:[
- buffer nextPutAll: aStringOrBlockOrRBParseNode
+ self emitCodeAsString: aStringOrBlockOrRBParseNode
] ifFalse:[
(aStringOrBlockOrRBParseNode isKindOf: RBProgramNode) ifTrue:[
- aStringOrBlockOrRBParseNode isSequence ifTrue:[
- aStringOrBlockOrRBParseNode temporaries do:[:e |
- (temporaries includes: e name) ifFalse:[
- temporaries add: e name
- ].
- ].
- aStringOrBlockOrRBParseNode statements do:[:e|
- buffer nextPutAll: e formattedCode; nextPut: $..
- self nl; codeIndent.
- ].
-
- ] ifFalse:[
- buffer nextPutAll: aStringOrBlockOrRBParseNode formattedCode.
- ].
-
+ self emitCodeAsRBNode: aStringOrBlockOrRBParseNode.
] ifFalse:[
- aStringOrBlockOrRBParseNode value
+ self emitCodeAsBlock: aStringOrBlockOrRBParseNode
].
].
@@ -143,7 +129,7 @@
((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
indentation * 4 timesRepeat: [ aStream nextPut: Character space ].
] ifFalse:[
- indentation timesRepeat: [ buffer nextPut: Character tab ].
+ indentation timesRepeat: [ aStream nextPut: Character tab ].
].
aStream nextPut: $|.
temporaries do:[:e | aStream space; nextPutAll: e ].
@@ -160,3 +146,37 @@
"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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCCodeGenerator.st Fri Jul 24 15:37:23 2015 +0100
@@ -9,7 +9,6 @@
category:'PetitCompiler-Visitors'
!
-
!PPCCodeGenerator class methodsFor:'as yet unclassified'!
new
@@ -34,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
@@ -401,54 +482,13 @@
!
visitChoiceNode: node
- | whitespaceConsumed allowGuard elementVar coding |
-
-
- elementVar := compiler allocateTemporaryVariableNamed: 'element'.
- whitespaceConsumed := self addGuardTrimming: node.
- allowGuard := whitespaceConsumed.
+ | whitespaceConsumed useGuards resultVar |
- allowGuard ifTrue:[
- coding :=
- [ :children :index |
- self addGuard: (children at: index) ifTrue: [
- compiler add: 'self clearError.'.
- compiler
- codeAssignParsedValueOf:[ self visit:(children at:index) ]
- to:elementVar.
- compiler add: 'error ifFalse: [ '.
- compiler codeReturn: elementVar.
- compiler add: ' ].'.
- ] ifFalse:[
- compiler add: 'error := true.'.
- ].
- compiler add: 'error ifTrue:[ '.
- index < children size ifTrue:[
- coding value: children value: index + 1.
- ] ifFalse:[
- compiler codeError: 'no choice suitable'.
- ].
- compiler add: '] '.
- ]
- ] ifFalse:[
- coding :=
- [ :children :index |
- index <= children size ifTrue:[
- compiler add: 'self clearError.'.
- compiler
- codeAssignParsedValueOf:[ self visit:(children at:index) ]
- to:elementVar.
- compiler add: 'error ifFalse: [ '.
- compiler codeReturn: elementVar.
- compiler add: ' ].'.
- coding value: children value: index + 1.
- ] ifFalse:[
- compiler codeError: 'no choice suitable'.
- ].
- ]
- ].
-
- coding value: node children value: 1.
+ resultVar := compiler allocateTemporaryVariableNamed: 'element'.
+ whitespaceConsumed := self addGuardTrimming: node.
+ useGuards := whitespaceConsumed.
+ self generateChoiceChildOf: node atIndex: 1 useGuards: useGuards storeResultInto: resultVar
+
"Modified: / 29-05-2015 / 07:17:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
@@ -462,12 +502,10 @@
compiler
codeAssignParsedValueOf:[ self visit:node child ]
to:self retvalVar.
- compiler add: 'context atEnd ifTrue: ['.
- compiler codeReturn.
- compiler add: '] ifFalse: ['.
- compiler codeError: 'End of input expected'.
- compiler add: '].'.
-
+ 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>"
!
@@ -762,14 +800,13 @@
visitSequenceNode: node
- | elementVars mementoVar canBacktrack coding |
+ | elementVars mementoVar canBacktrack |
elementVars := node preferredChildrenVariableNames.
elementVars do:[:e |
compiler allocateTemporaryVariableNamed: e.
].
-
canBacktrack := (node children allButFirst allSatisfy: [:e | e acceptsEpsilon ]) not.
" self addGuardTrimming: node.
@@ -783,45 +820,7 @@
node returnParsedObjectsAsCollection ifTrue:[
compiler codeAssign: 'Array new: ', node children size asString, '.' to: self retvalVar.
].
-
- coding := [ :index |
- | child childValueVar |
-
- child := node children at: index.
- childValueVar := elementVars at: index.
- compiler codeAssignParsedValueOf: [ self visit:child ]
- to: childValueVar.
- child acceptsEpsilon ifFalse: [
- compiler codeIfErrorThen: [
- "Handle error in the first element specially"
- "TODO: JK, please explain here why!!!!!!"
- index == 1 ifTrue:[
- compiler add: 'error ifTrue: [ ^ failure ].'.
- ] ifFalse:[
- compiler smartRestore: node from: mementoVar.
- compiler codeReturn: 'failure.'.
- ]
- ] else:[
- node returnParsedObjectsAsCollection ifTrue:[
- compiler add: self retvalVar , ' at: ', index asString, ' put: ', childValueVar, '.'.
- ].
- (index < node children size) ifTrue:[
- coding value: index + 1.
- ].
- ]
-
- ] ifTrue:[
- node returnParsedObjectsAsCollection ifTrue:[
- compiler add: self retvalVar , ' at: ', index asString, ' put: ', childValueVar, '.'.
- ].
- (index < node children size) ifTrue:[
- coding value: index + 1.
- ].
- ]
- ].
-
- coding value:1.
-
+ self generateSequenceChildOf: node atIndex: 1 useMememntoVar: mementoVar storeResultInto: elementVars.
compiler codeReturn
"Modified (comment): / 16-06-2015 / 06:38:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
@@ -1051,10 +1050,3 @@
"Modified: / 15-06-2015 / 17:59:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
-!PPCCodeGenerator class methodsFor:'documentation'!
-
-version_HG
-
- ^ '$Changeset: <not expanded> $'
-! !
-
--- a/compiler/PPCCompiler.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCCompiler.st Fri Jul 24 15:37:23 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'!
@@ -133,6 +127,12 @@
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.
!
@@ -199,6 +199,7 @@
method := [
aBlock value
] ensure:[ returnVariable := tmpVarirable ].
+ self assert: (method isKindOf: PPCMethod).
method isInline ifTrue:[
self callOnLine:method
] ifFalse:[
@@ -243,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
]
!
@@ -336,16 +337,16 @@
codeReturn
currentMethod isInline ifTrue: [
- "If inlined, the return variable already holds the value"
- ] ifFalse: [
- arguments profile ifTrue:[
- self codeProfileStop.
- ].
- 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: / 01-06-2015 / 21:49:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "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
@@ -364,6 +365,47 @@
"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
+ | 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.
@@ -523,11 +565,11 @@
stopMethod
self cache: currentMethod methodName as: currentMethod.
-
- "arguments profile ifTrue: [ Transcript show: currentMethod code; cr. ]."
- ^ self pop.
+
+ "arguments profile ifTrue: [ Transcript show: currentMethod code; cr. ]."
+ ^ self pop.
- "Modified: / 01-06-2015 / 21:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 01-06-2015 / 21:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
top
--- a/compiler/PPCConfiguration.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCConfiguration.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCContextMemento.st Fri Jul 24 15:37:23 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:37:23 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/PPCMethod.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCMethod.st Fri Jul 24 15:37:23 2015 +0100
@@ -3,7 +3,7 @@
"{ NameSpace: Smalltalk }"
Object subclass:#PPCMethod
- instanceVariableNames:'buffer id variableForReturn category'
+ instanceVariableNames:'buffer id variableForReturn category profile'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Compiler-Codegen'
@@ -66,6 +66,14 @@
methodName
^ id
+!
+
+profile
+ ^ profile
+!
+
+profile: aBoolean
+ profile := aBoolean
! !
!PPCMethod methodsFor:'as yet unclassified'!
@@ -88,14 +96,14 @@
profilingBegin
self profile ifTrue: [
- ^ ' context methodInvoked: #', id, '.'
+ ^ ' context methodInvoked: #', id, '.'
].
^ ''
!
profilingEnd
self profile ifTrue: [
- ^ ' context methodFinished: #', id, '.'
+ ^ ' context methodFinished: #', id, '.'
].
^ ''
! !
@@ -116,17 +124,14 @@
innerBlock := PPCCodeBlock new.
innerBlock indentationLevel: outerBlock indentationLevel + 1.
[
- buffer addOnLine:'['; nl; codeIndent.
+ outerBlock addOnLine:'['.
buffer := innerBlock.
self code: contents.
] ensure:[
- buffer := outerBlock.
- buffer
+ outerBlock
code: (String streamContents:[:s | innerBlock codeOn: s]);
- nl;
- codeIndent.
-
- buffer addOnLine:']'.
+ add:']'.
+ buffer := outerBlock.
]
"Created: / 01-06-2015 / 22:33:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
@@ -156,6 +161,17 @@
!PPCMethod methodsFor:'code generation - variables'!
+allocateReturnVariable
+
+ ^ variableForReturn isNil ifTrue:[
+ variableForReturn := self allocateTemporaryVariableNamed: 'retval'
+ ] ifFalse:[
+ variableForReturn
+ ].
+
+ "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)"
--- a/compiler/PPCNilNode.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCNilNode.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCNode.st Fri Jul 24 15:37:23 2015 +0100
@@ -242,7 +242,7 @@
finite := self.
infinite := anotherNode.
] ifFalse: [
- finite := anotherNode.
+ finite := anotherNode.
infinite := self.
].
@@ -525,6 +525,10 @@
!PPCNode methodsFor:'testing'!
+canHavePPCId
+ ^ true
+!
+
isMarkedForInline
^ self propertyAt: #inlined ifAbsent: [ false ].
@@ -551,6 +555,12 @@
^ self
!
+asFsa
+ | visitor |
+ visitor := PEGFsaGenerator new.
+ ^ visitor visit: self
+!
+
replace: node with: anotherNode
!
--- a/compiler/PPCProfilingContext.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCProfilingContext.st Fri Jul 24 15:37:23 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:37:23 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:37:23 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/PPCTokenizingCodeGenerator.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPCTokenizingCodeGenerator.st Fri Jul 24 15:37:23 2015 +0100
@@ -9,7 +9,6 @@
category:'PetitCompiler-Visitors'
!
-
!PPCTokenizingCodeGenerator methodsFor:'accessing'!
guards
@@ -51,7 +50,7 @@
trueBlock value.
compiler dedent.
falseBlock isNil ifTrue: [ compiler addOnLine: '].' ]
- ifFalse: [ compiler add: ']'. ]
+ ifFalse: [ compiler add: ']'. ]
].
falseBlock isNil ifFalse: [
compiler addOnLine: ' ifFalse: ['.
@@ -130,9 +129,11 @@
!
visitDeterministicChoiceNode: node
- | dictionary |
+ | dictionary isInlined |
dictionary := IdentityDictionary new.
+ isInlined := node isMarkedForInline.
+
node children do: [ :child |
| firstSet |
firstSet := child firstSetWithTokens.
@@ -148,14 +149,19 @@
compiler add: '(self ', tokenMethodName asString, ')'.
compiler addOnLine: ' ifTrue: ['.
compiler indent.
- compiler codeAssignParsedValueOf:[ self visit:child ] to:self retvalVar.
- compiler codeReturn: self retvalVar.
+ compiler codeReturnParsedValueOf:[ self visit:child ].
compiler dedent.
- compiler add: '] ifFalse:['
+ isInlined ifTrue:[
+ compiler add: '] ifFalse: ['
+ ] ifFalse:[
+ compiler add: '].'.
+ ]
].
compiler codeError: 'no choice found'.
- node children size timesRepeat: [ compiler add: ']' ].
- compiler add: '.'.
+ isInlined ifTrue:[
+ node children size timesRepeat: [ compiler addOnLine: ']' ].
+ compiler addOnLine: '.'.
+ ]
"Modified: / 21-05-2015 / 15:31:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
@@ -214,10 +220,3 @@
self error: 'shoudl not happend!!'
! !
-!PPCTokenizingCodeGenerator class methodsFor:'documentation'!
-
-version_HG
-
- ^ '$Changeset: <not expanded> $'
-! !
-
--- a/compiler/PPMappedActionParser.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPMappedActionParser.st Fri Jul 24 15:37:23 2015 +0100
@@ -6,7 +6,7 @@
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
- category:'PetitParser-Parsers'
+ category:'PetitCompiler-Parsers'
!
!PPMappedActionParser methodsFor:'converting'!
--- a/compiler/PPTokenizingCompiledParser.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/PPTokenizingCompiledParser.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/abbrev.stc Fri Jul 24 15:37:23 2015 +0100
@@ -1,9 +1,18 @@
# 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
PPCCodeBlock PPCCodeBlock stx:goodies/petitparser/compiler 'PetitCompiler-Compiler-Codegen' 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
@@ -18,10 +27,14 @@
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 'PetitParser-Parsers' 0
+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
@@ -30,6 +43,8 @@
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-Compiler-Codegen' 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
@@ -88,6 +103,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 'PetitParser-Parsers' 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/bc.mak Fri Jul 24 15:37:23 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\goodies\refactoryBrowser\parser -I$(INCLUDE_TOP)\stx\libbasic -I$(INCLUDE_TOP)\stx\libbasic2 -I$(INCLUDE_TOP)\stx\libwidg -I$(INCLUDE_TOP)\stx\libwidg2
+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)
@@ -77,9 +77,18 @@
# 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)PPCCodeBlock.$(O) PPCCodeBlock.$(H): PPCCodeBlock.st $(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,10 +103,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)
@@ -105,6 +118,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)
--- a/compiler/benchmarks/PPCBenchmark.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/benchmarks/PPCBenchmark.st Fri Jul 24 15:37:23 2015 +0100
@@ -30,7 +30,7 @@
].
^ (benchmarkSuiteClass class:self) run
- "
+ "
PPCBenchmark run.
"
!
@@ -712,6 +712,28 @@
"Created: / 16-05-2015 / 09:44:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+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.
"
--- a/compiler/benchmarks/PPCSmalltalkNoopParser.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/benchmarks/PPCSmalltalkNoopParser.st Fri Jul 24 15:37:23 2015 +0100
@@ -12,21 +12,21 @@
!PPCSmalltalkNoopParser methodsFor:'accessing'!
startExpression
- "Make the sequence node has a method node as its parent and that the source is set."
+ "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 ] ]
+ ^ ([ :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 ]
+ "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'!
@@ -100,7 +100,7 @@
!
blockArgument
- ^ super blockArgument ==> #second
+ ^ super blockArgument ==> #second
!
blockBody
@@ -213,107 +213,107 @@
!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
+ 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 ] ]
+ ^ 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 ]
+ | 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 ] ] ]
+ ^ (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
+ | 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
+ ^ 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
+ 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: ''''
+ (aString isEmpty or: [ aString first ~= $' or: [ aString last ~= $' ] ])
+ ifTrue: [ ^ aString ].
+ ^ (aString
+ copyFrom: 2
+ to: aString size - 1)
+ copyReplaceAll: ''''''
+ with: ''''
! !
!PPCSmalltalkNoopParser methodsFor:'token'!
--- a/compiler/benchmarks/bmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/benchmarks/bmake.bat Fri Jul 24 15:37:23 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/mingwmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/benchmarks/mingwmake.bat Fri Jul 24 15:37:23 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/vcmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/benchmarks/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/bmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/extensions.st Fri Jul 24 15:37:23 2015 +0100
@@ -8,6 +8,12 @@
!Object methodsFor:'*petitcompiler'!
+canHavePPCId
+ ^ false
+! !
+
+!Object methodsFor:'*petitcompiler'!
+
isInlinedMethod
^ false
! !
@@ -638,7 +644,7 @@
!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
comment
- ^ $" asParser, $" asParser negate star, $" asParser.
+ ^ $" asParser, $" asParser negate star, $" asParser.
! !
!PPSmalltalkGrammar methodsFor:'*petitcompiler'!
--- a/compiler/libInit.cc Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/libInit.cc Fri Jul 24 15:37:23 2015 +0100
@@ -27,9 +27,18 @@
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);
_PPCCodeBlock_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);
@@ -44,10 +53,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);
@@ -55,6 +68,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);
--- a/compiler/mingwmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/mingwmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/stx_goodies_petitparser_compiler.st Fri Jul 24 15:37:23 2015 +0100
@@ -76,8 +76,9 @@
^ #(
#'stx:goodies/petitparser/analyzer' "PPSentinel - referenced by PPCompiledParser class>>referringParser"
#'stx:goodies/refactoryBrowser/parser' "RBAssignmentNode - referenced by PPCCodeGenerator>>visitActionNode:"
- #'stx:libbasic2' "Stack - referenced by PPCCompiler>>initializeForCompiledClassName:"
+ #'stx:libbasic2' "IdentityBag - referenced by PEGFsa>>checkTransitionsIdentity"
#'stx:libwidg' "ScrollableView - referenced by PPCNode>>inspector2TabTree"
+ #'stx:libview' "Color - referenced by PEGFsa>>viewGraphOn:"
#'stx:libwidg2' "HierarchicalListView - referenced by PPCNode>>inspector2TabTree"
)
!
@@ -110,9 +111,18 @@
^ #(
"<className> or (<className> attributes...) in load order"
+ PEGFsa
+ PEGFsaFailure
+ PEGFsaInterpret
+ PEGFsaPair
+ PEGFsaState
+ PEGFsaTransition
PPCArguments
PPCBridge
PPCCodeBlock
+ PPCClassBuilder
+ PPCCodeBlock
+ PPCCodeGen
PPCCompiledMethod
PPCCompiler
PPCCompilerTokenErrorStrategy
@@ -127,10 +137,14 @@
PPCNode
PPCNodeVisitor
PPCPluggableConfiguration
+ PPCScanner
+ PPCScannerCodeGenerator
PPCTokenGuard
PPCompiledParser
PPMappedActionParser
#'stx_goodies_petitparser_compiler'
+ FooScanner
+ PEGFsaGenerator
PPCAbstractLiteralNode
PPCAbstractPredicateNode
PPCAnyNode
@@ -138,6 +152,7 @@
PPCCodeGenerator
PPCDelegateNode
PPCEndOfFileNode
+ PPCFSACodeGen
PPCInlinedMethod
PPCInliningVisitor
PPCListNode
@@ -316,6 +331,9 @@
PPParser compileTokenizing
PPCompositeParser asCompilerNode
PPSequenceParser map:
+ 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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/Make.proto Fri Jul 24 15:37:23 2015 +0100
@@ -127,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)
@@ -143,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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/Make.spec Fri Jul 24 15:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/PPCCodeGeneratorTest.st Fri Jul 24 15:37:23 2015 +0100
@@ -437,21 +437,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
@@ -917,6 +917,48 @@
"Created: / 22-05-2015 / 11:47:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
+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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/abbrev.stc Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/bc.mak Fri Jul 24 15:37:23 2015 +0100
@@ -74,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)
@@ -90,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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/bmake.bat Fri Jul 24 15:37:23 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/PPCExpressionsVerificationTest.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPCExpressionsVerificationTest.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPCompiledExpressionGrammarResource.st Fri Jul 24 15:37:23 2015 +0100
@@ -15,7 +15,7 @@
setUp
| time configuration |
configuration := PPCConfiguration universal.
- configuration arguments name: #PPCompiledExpressionGrammar.
+ configuration arguments parserName: #PPCompiledExpressionGrammar.
time := Time millisecondsToRun: [
--- a/compiler/tests/extras/PPCompiledJavaResource.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPCompiledJavaResource.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPCompiledJavaSyntaxTest.st Fri Jul 24 15:37:23 2015 +0100
@@ -107,9 +107,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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPCompiledSmalltalkGrammarResource.st Fri Jul 24 15:37:23 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:37:23 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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPLL1ExpressionGrammar.st Fri Jul 24 15:37:23 2015 +0100
@@ -14,14 +14,14 @@
add
^ prod, addPrime optional
- map: [ :_prod :_addPrime |
- _addPrime isNil
- ifTrue: [ _prod ]
- ifFalse: [ (Array with: _prod) , _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>"
+ "Modified (format): / 26-05-2015 / 07:23:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
addPrime
@@ -30,14 +30,14 @@
mul
^ prim, mulPrime optional
- map: [ :_prim :_mulPrime |
- _mulPrime isNil
- ifTrue: [ _prim ]
- ifFalse: [ (Array with: _prim) , _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>"
+ "Modified (format): / 26-05-2015 / 07:23:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
mulPrime
--- a/compiler/tests/extras/PPTokenizedExpressionGrammarResource.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPTokenizedExpressionGrammarResource.st Fri Jul 24 15:37:23 2015 +0100
@@ -15,7 +15,7 @@
setUp
| time configuration |
configuration := PPCTokenizingConfiguration new.
- configuration arguments name:#PPTokenizedExpressionGrammar.
+ configuration arguments parserName:#PPTokenizedExpressionGrammar.
time := Time millisecondsToRun: [
--- a/compiler/tests/extras/PPTokenizedLL1ExpressionGrammarResource.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPTokenizedLL1ExpressionGrammarResource.st Fri Jul 24 15:37:23 2015 +0100
@@ -14,7 +14,7 @@
setUp
| time configuration |
configuration := PPCTokenizingConfiguration new.
- configuration arguments name:#PPTokenizedLL1ExpressionGrammar.
+ configuration arguments parserName:#PPTokenizedLL1ExpressionGrammar.
time := Time millisecondsToRun: [
--- a/compiler/tests/extras/PPTokenizedSmalltalkGrammarResource.st Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/PPTokenizedSmalltalkGrammarResource.st Fri Jul 24 15:37:23 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:37:23 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:37:23 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:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/abbrev.stc Fri Jul 24 15:37:23 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/bmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/bmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/mingwmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/stx_goodies_petitparser_compiler_tests_extras.st Fri Jul 24 15:37:23 2015 +0100
@@ -139,6 +139,8 @@
(PPCompiledJavaSyntaxTest autoload)
PPCompiledSmalltalkGrammarResource
PPCompiledSmalltalkGrammarTests
+ (PPCompiledSmalltalkParserResource autoload)
+ (PPCompiledSmalltalkParserTests autoload)
PPExpressionGrammar
PPExpressionGrammarTest
PPLL1ExpressionGrammar
@@ -149,11 +151,14 @@
PPTokenizedLL1ExpressionGrammarTest
PPTokenizedSmalltalkGrammarResource
PPTokenizedSmalltalkGrammarTests
+ (PPTokenizedSmalltalkParserResource autoload)
+ (PPTokenizedSmalltalkParserTests autoload)
#'stx_goodies_petitparser_compiler_tests_extras'
PPCompiledExpressionsVerificationTest
PPCompiledSmalltalkVerificationTest
PPTokenizedExpressionsVerificationTest
PPTokenizedSmalltalkVerificationTest
+ (PPTokenizedSmalltalkParserVerificationTest autoload)
)
!
--- a/compiler/tests/extras/vcmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/extras/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/libInit.cc Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/mingwmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/stx_goodies_petitparser_compiler_tests.st Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/tests/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/compiler/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/islands/bmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/islands/mingwmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/islands/tests/bmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/islands/tests/mingwmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/islands/tests/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/islands/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/mingwmake.bat Fri Jul 24 15:37:23 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/PPArithmeticParser.st Fri Jun 19 08:13:39 2015 +0100
+++ b/tests/PPArithmeticParser.st Fri Jul 24 15:37:23 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/bmake.bat Fri Jun 19 08:13:39 2015 +0100
+++ b/tests/bmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/tests/mingwmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/tests/vcmake.bat Fri Jul 24 15:37:23 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 Fri Jun 19 08:13:39 2015 +0100
+++ b/vcmake.bat Fri Jul 24 15:37:23 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 "***********************************"