diff -r 20598d7ce9fa -r 9f4558b3be66 compiler/PPCCompiler.st --- a/compiler/PPCCompiler.st Thu Apr 30 23:43:14 2015 +0200 +++ b/compiler/PPCCompiler.st Sun May 10 06:28:36 2015 +0100 @@ -3,8 +3,9 @@ "{ NameSpace: Smalltalk }" Object subclass:#PPCCompiler - instanceVariableNames:'compilerStack compiledParser cache currentMethod ids rootNode - constants compiledParserName returnVariable arguments' + instanceVariableNames:'compilerStack compiledParser cache currentMethod ids constants + compiledParserName compiledParserSuperclass returnVariable + arguments' classVariableNames:'' poolDictionaries:'' category:'PetitCompiler-Core' @@ -36,85 +37,85 @@ !PPCCompiler methodsFor:'accessing'! arguments: args - arguments := args + arguments := args ! compiledParser - ^ compiledParser + ^ compiledParser +! + +compiledParserSuperclass + ^ compiledParserSuperclass ifNil: [ PPCompiledParser ] ! currentNonInlineMethod - ^ compilerStack - detect:[:m | m isInline not ] - ifNone:[ self error: 'No non-inlined method'] + ^ compilerStack + detect:[:m | m isInline not ] + ifNone:[ self error: 'No non-inlined method'] "Created: / 23-04-2015 / 17:33:31 / Jan Vrany " ! currentReturnVariable - ^ currentMethod returnVariable + ^ currentMethod returnVariable ! ids - ^ ids -! - -rootNode - ^ rootNode + ^ ids ! ! !PPCCompiler methodsFor:'cleaning'! clean: class " Transcript crShow: 'Cleaning time: ', - [ + [ " self cleanGeneratedMethods: class. - self cleanInstVars: class. - self cleanConstants: class. + self cleanInstVars: class. + self cleanConstants: class. " ] timeToRun asMilliSeconds asString, 'ms'." ! cleanConstants: class - class constants removeAll. + class constants removeAll. ! cleanGeneratedMethods: class - ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[ - class methodsDo: [ :mthd | - mthd category = #generated ifTrue:[ - class removeSelector: mthd selector. - ] - ] - ] ifFalse: [ - (class allSelectorsInProtocol: #generated) do: [ :selector | - class removeSelectorSilently: selector ]. - ] + ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[ + class methodsDo: [ :mthd | + mthd category = #generated ifTrue:[ + class removeSelector: mthd selector. + ] + ] + ] ifFalse: [ + (class allSelectorsInProtocol: #generated) do: [ :selector | + class removeSelectorSilently: selector ]. + ] ! cleanInstVars: class - class class instanceVariableNames: ''. + class class instanceVariableNames: ''. ! cleanParsers: class - class parsers removeAll. + class parsers removeAll. ! ! !PPCCompiler methodsFor:'code generation'! add: string - currentMethod add: string. + currentMethod add: string. ! addComment: string - currentMethod add: '"', string, '"'. + currentMethod add: '"', string, '"'. ! addConstant: value as: name - constants at: name put: value + constants at: name put: value ! addOnLine: string - currentMethod addOnLine: string. + currentMethod addOnLine: string. ! addVariable: name @@ -124,74 +125,81 @@ ! call: anotherMethod - currentMethod add: anotherMethod call. + currentMethod add: anotherMethod call. ! callOnLine: anotherMethod - currentMethod addOnLine: anotherMethod call. + currentMethod addOnLine: anotherMethod call. ! dedent - currentMethod dedent + currentMethod dedent ! indent - currentMethod indent + currentMethod indent ! nl - currentMethod nl -! - -smartRemember: parser - self flag: 'deprecated'. - ^ self smartRemember: parser to: #memento + currentMethod nl ! -smartRemember: parser to: variableName - parser isContextFree ifTrue: [ - ^ variableName, ' := context lwRemember.'. - ]. - ^ variableName, ':= context remember.' -! - -smartRestore: parser - self flag: 'deprecated'. - ^ self smartRestore: parser from: #memento +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: [ - ^ 'context lwRestore: ', mementoName, '.'. - ]. - ^ 'context restore: ', mementoName, '.'. + parser isContextFree ifTrue: [ + self add: 'context lwRestore: ', mementoName, '.'. + ] ifFalse: [ + self add: 'context restore: ', mementoName, '.'. + ] ! ! !PPCCompiler methodsFor:'code generation - coding'! 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. + 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. ] ifTrue: [ - "In case code hava a side effect" + "In case code hava a side effect" self add: code - ] + ] ! codeClearError - self add: 'self clearError.'. + self add: 'self clearError.'. ! codeError: errorMessage - self add: 'self error: ''', errorMessage, '''.' + self add: 'self error: ''', errorMessage, '''.' ! codeHalt - self add: 'self halt. ' + self add: 'self halt. ' +! + +codeHaltIfShiftPressed + arguments debug ifTrue: [ + self add: 'Halt ifShiftPressed.' + ] +! + +codeNextToken + self add: 'self nextToken.' + + "Created: / 23-04-2015 / 18:01:05 / Jan Vrany " + "Modified: / 23-04-2015 / 20:51:41 / Jan Vrany " ! codeReturn @@ -206,155 +214,179 @@ ! codeReturn: code - " - returns whatever is in code OR - - assigns whatever is in code into the returnVariable" + " - returns whatever is in code OR + - assigns whatever is in code into the returnVariable" currentMethod isInline ifTrue:[ - self codeAssign: code to: currentMethod returnVariable. + self codeAssign: code to: currentMethod returnVariable. ] ifFalse: [ - self add: '^ ', code - ] + self add: '^ ', code + ] "Created: / 23-04-2015 / 18:01:05 / Jan Vrany " "Modified: / 23-04-2015 / 20:51:41 / Jan Vrany " ! 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 codeAssign: (method call) to: aString. - ] - - "Created: / 23-04-2015 / 18:21:51 / Jan Vrany " + | 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 codeAssign: (method call) to: aString. + ] + + "Created: / 23-04-2015 / 18:21:51 / Jan Vrany " +! + +codeTranscriptShow: text + (arguments profile) ifTrue: [ + self add: 'Transcript show: ', text storeString, '; cr.'. + ] ! ! !PPCCompiler methodsFor:'code generation - 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 uncapitalized asSymbol. +! + idFor: object - self assert: (object isKindOf: PPCNode). - ^ self idFor: object prefixed: object prefix suffixed: object suffix effect: #none + self assert: (object isKindOf: PPCNode). + ^ self idFor: object prefixed: object prefix suffixed: object suffix effect: #none ! idFor: object prefixed: prefix - ^ self idFor: object prefixed: prefix effect: #none + ^ self idFor: object prefixed: prefix effect: #none ! idFor: object prefixed: prefix effect: effect - ^ self idFor: object prefixed: prefix suffixed: '' effect: effect. + ^ self idFor: object prefixed: prefix suffixed: '' effect: effect. ! idFor: object prefixed: prefix suffixed: suffix effect: effect - | name id | - ^ ids at: object ifAbsentPut: [ - ((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ - "Do not use prefix, if there is a name" - name := object name asLegalSelector. - id := (name, suffix) asSymbol. - - "Make sure, that the generated ID is uniqe!!" - (ids includes: id) ifTrue: [ - (id, '_', ids size asString) asSymbol - ] ifFalse: [ - id - ] - ] ifFalse: [ - (prefix, '_', (ids size asString), suffix) asSymbol - ] - ] + | name id | + ^ ids at: object ifAbsentPut: [ + ((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ + "Do not use prefix, if there is a name" + name := self asSelector: object name. + id := (name, suffix) asSymbol. + + "Make sure, that the generated ID is uniqe!!" + (ids includes: id) ifTrue: [ + (id, '_', ids size asString) asSymbol + ] ifFalse: [ + id + ] + ] ifFalse: [ + (prefix, '_', (ids 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 ! ! !PPCCompiler methodsFor:'code generation - support'! cache: id as: value - cache at: id put: value. + cache at: id put: value. ! cachedValue: id - ^ cache at: id ifAbsent: [ nil ] + ^ cache at: id ifAbsent: [ nil ] ! checkCache: id - | method | - "Check if method is hand written" - method := compiledParser ifNotNil: [ compiledParser compiledMethodAt: id ifAbsent: [ nil ] ]. - method ifNotNil: [ ^ PPCCompiledMethod new id: id; yourself ]. - - ^ self cachedValue: id + | method | + "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 + | retval | + retval := compilerStack pop. + currentMethod := compilerStack isEmpty + ifTrue: [ nil ] + ifFalse: [ compilerStack top ]. + ^ retval "Modified: / 21-11-2014 / 12:27:25 / Jan Vrany " ! push - compilerStack push: currentMethod. - (compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ] + 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 " ! startInline: id - (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ]. - - currentMethod := PPCInlinedMethod new. - currentMethod id: id. - currentMethod profile: arguments profile. - currentMethod returnVariable: returnVariable. - self push. + | indentationLevel | + (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ]. + indentationLevel := currentMethod indentationLevel. + + currentMethod := PPCInlinedMethod new. + currentMethod id: id. + currentMethod profile: arguments profile. + currentMethod returnVariable: returnVariable. + currentMethod indentationLevel: indentationLevel. + self push. "Modified: / 23-04-2015 / 18:28:26 / Jan Vrany " ! startMethod: id - (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ]. + (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ]. - currentMethod := PPCMethod new. - currentMethod id: id. - currentMethod profile: arguments profile. - self push. + currentMethod := PPCMethod new. + currentMethod id: id. + currentMethod profile: arguments profile. + self push. - self cache: id as: currentMethod. + self cache: id as: currentMethod. "Modified: / 23-04-2015 / 18:36:23 / Jan Vrany " ! stopInline - ^ self pop. + ^ self pop. "Modified: / 23-04-2015 / 18:28:33 / Jan Vrany " ! stopMethod - self cache: currentMethod methodName as: currentMethod. - - arguments profile ifTrue: [ Transcript crShow: currentMethod code ]. - ^ self pop. + self cache: currentMethod methodName as: currentMethod. + + arguments profile ifTrue: [ Transcript crShow: currentMethod code ]. + ^ self pop. "Modified: / 23-04-2015 / 18:36:55 / Jan Vrany " ! top - ^ compilerStack top + ^ compilerStack top ! ! !PPCCompiler methodsFor:'code generation - variables'! @@ -380,104 +412,73 @@ !PPCCompiler methodsFor:'compiling'! compileParser - self installVariables. - self installMethods. - self installClassConstants. + self installVariables. + self installMethods. + self installClassConstants. - ^ compiledParser + ^ compiledParser ! copy: parser - ^ parser transform: [ :p | p copy ]. + ^ parser transform: [ :p | p copy ]. ! installClassConstants - constants keysAndValuesDo: [ :key :value | - compiledParser constants at: key put: value - ] + constants keysAndValuesDo: [ :key :value | + compiledParser constants at: key put: value + ] ! installMethods - cache keysAndValuesDo: [ :key :method | - compiledParser compileSilently: method code classified: 'generated'. - ] + cache keysAndValuesDo: [ :key :method | + compiledParser compileSilently: method code classified: 'generated'. + ] ! installVariables - | varString | - varString := constants keys inject: '' into: [:r :e | r, ' ', e ]. - - PPCompiledParser - subclass: compiledParserName - instanceVariableNames: varString - classVariableNames: '' - poolDictionaries: '' - category: 'PetitCompiler-Generated'. - - compiledParser := Smalltalk at: compiledParserName. -! - -precomputeFirstSets: root - | firstSets | - firstSets := root firstSets. - - root allNodesDo: [ :node | - node firstSet: (firstSets at: node). - ] - -! + | varString | + varString := constants keys inject: '' into: [:r :e | r, ' ', e ]. -precomputeFollowSets: root - | followSets | - followSets := root followSets. - - root allNodesDo: [ :node | - node followSet: (followSets at: node). - ] - -! + (self compiledParserSuperclass) + subclass: compiledParserName + instanceVariableNames: varString + classVariableNames: '' + poolDictionaries: '' + category: 'PetitCompiler-Generated'. -precomputeFollowSetsWithTokens: root - | followSets | - followSets := root followSetsSuchThat: [:e | e isTerminal or: [ e isKindOf: PPCTrimmingTokenNode ]]. - - root allNodesDo: [ :node | - node followSetWithTokens: (followSets at: node). - ] - -! - -toCompilerTree: parser - ^ parser asCompilerTree + compiledParser := Smalltalk at: compiledParserName. ! ! !PPCCompiler methodsFor:'initialization'! initializeForCompiledClassName: aString - - self initialize. - compilerStack := Stack new. - cache := IdentityDictionary new. - constants := IdentityDictionary new. - ids := IdentityDictionary new. - + + self initialize. + compilerStack := Stack new. + cache := IdentityDictionary new. + constants := IdentityDictionary new. + ids := IdentityDictionary new. + - compiledParserName := aString asSymbol. - - ((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'. - ]. + compiledParserName := aString asSymbol. + + ((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'. + ]. - Smalltalk at: compiledParserName ifPresent: [ :class | - compiledParser := class. - self clean: compiledParser. - ]. + Smalltalk at: compiledParserName ifPresent: [ :class | + compiledParser := class. + self clean: compiledParser. + ]. + + + Transcript cr; show: 'intialized for: ', aString; cr. ! ! !PPCCompiler class methodsFor:'documentation'!