separated instance creation from parsing
and refactored to allow for adjustments (allowSqueakExtensions)
between creation and parsing.
--- a/ByteCodeCompiler.st Wed Jan 29 18:58:13 2003 +0100
+++ b/ByteCodeCompiler.st Wed Jan 29 18:59:00 2003 +0100
@@ -613,364 +613,9 @@
The argument, silent controls if errors are to be reported.
Returns the method, #Error or nil."
- |compiler newMethod tree symbolicCodeArray oldMethod lazy silencio
- sourceFile sourceStream newSource primNr pos sel keptOldCode msg answer
- pkg aClass aString errorOccurred oldCategory newCategory|
-
- aClass := aClassArg.
- aString := aStringArg.
-
- aString isNil ifTrue:[^ nil].
- silencio := silent
- or:[Smalltalk silentLoading == true
- or:[ListCompiledMethods == false]].
-
- "lazy compilation is EXPERIMENTAL"
- lazy := (LazyCompilation == true) and:[install].
- "/ no longer ...
- lazy := false.
-
- RestartCompilationSignal handle:[:ex |
- "/ class could have changed ...
- aClass := compiler classToCompileFor.
- aString := compiler correctedSource ? aStringArg.
- ex restart
- ] do:[
- "create a compiler, let it parse and create the parsetree"
-
- compiler := self for:(ReadStream on:aString) in:aClass.
- compiler parseForCode.
- fold ifFalse:[compiler foldConstants:nil].
- compiler notifying:requestor.
- silent ifTrue:[
- "/ compiler ignoreErrors.
- compiler ignoreWarnings.
- compiler warnUndeclared:false.
- ].
-
- (errorOccurred := (compiler parseMethodSpec == #Error)) ifTrue:[
- compiler parseError:'syntax error in method specification'.
- tree := #Error.
- ] ifFalse:[
- tree := compiler parseMethodBody.
- compiler checkForEndOfInput.
- compiler tree:tree.
- ].
- ].
-
- sel := compiler selector.
- sel notNil ifTrue:[
- oldMethod := aClass compiledMethodAt:sel.
- oldMethod notNil ifTrue:[
- oldCategory := oldMethod category.
- ].
- ].
- newCategory := cat.
- newCategory isNil ifTrue:[
- newCategory := oldCategory ? '* As yet uncategorized *'.
- ].
-
- errorOccurred ifFalse:[
- (aClass isNil or:[AllowExtensionsToPrivateClasses or:[aClass owningClass isNil]]) ifTrue:[
- (requestor respondsTo:#packageToInstall) ifFalse:[
- pkg := Class packageQuerySignal query.
- ] ifTrue:[
- pkg := requestor packageToInstall
- ].
- ] ifFalse:[
- pkg := aClass owningClass package
- ].
-
- lazy ifTrue:[
- "/
- "/ that one method IS required
- "/
- (aClass isMeta and:[compiler selector == #version]) ifTrue:[
- lazy := false
- ].
- "/
- "/ primitives also
- "/
- (compiler hasNonOptionalPrimitiveCode
- or:[compiler hasPrimitiveCode and:[self canCreateMachineCode]])
- ifTrue:[
- lazy := false
- ].
- ].
-
- lazy ifFalse:[
- "check if same source"
- skipIfSame ifTrue:[
- oldMethod notNil ifTrue:[
- oldMethod source = aString ifTrue:[
- oldMethod isInvalid ifFalse:[
- silencio ifFalse:[
- Transcript showCR:(' unchanged: ',aClass name,' ',compiler selector)
- ].
- "
- same. however, category may be different
- "
- (newCategory ~= oldCategory) ifTrue:[
- oldMethod category:newCategory.
-"/ aClass updateRevisionString.
- aClass addChangeRecordForMethodCategory:oldMethod category:newCategory.
- silencio ifFalse:[
- Transcript showCR:(' (category change only)')
- ].
- ].
- "
- and package may be too.
- "
- (pkg notNil and:[pkg ~~ oldMethod package]) ifTrue:[
- oldMethod package:pkg.
- silencio ifFalse:[
- Transcript showCR:(' (package-id change only)')
- ].
- ].
- ^ oldMethod
- ]
- ]
- ]
- ].
- ]
- ].
-
- (compiler errorFlag or:[tree == #Error]) ifTrue:[
- compiler showErrorMessageForClass:aClass.
- ^ #Error
- ].
-
- "if no error and also no selector ..."
- sel isNil ifTrue:[
- "... it was just a comment or other empty stuff"
- ^ nil
- ].
-
- "
- freak-out support for inline C-code...
- "
- ((compiler hasNonOptionalPrimitiveCode
- or:[(compiler hasPrimitiveCode and:[self canCreateMachineCode])
- or:[STCCompilation == #always and:[sel ~~ #doIt]]])
- and:[(STCCompilation ~~ #never)
- and:[NewPrimitives ~~ true]]) ifTrue:[
-
- newMethod := compiler
- compileToMachineCode:aString
- forClass:aClass
- inCategory:newCategory
- notifying:requestor
- install:install
- skipIfSame:skipIfSame
- silent:silent.
-
- newMethod == #Error ifTrue:[
- compiler showErrorMessageForClass:aClass.
- ^ #Error
- ].
-
- (newMethod == #CannotLoad) ifTrue:[
- newMethod := compiler trappingStubMethodFor:aString inCategory:newCategory.
- newMethod setPackage:pkg.
- keptOldCode := false.
- install ifTrue:[
- "/
- "/ be very careful with existing methods
- "/ (otherwise, you could easily make your system unusable in systems which cannot load)
- "/
- sel notNil ifTrue:[
- oldMethod := aClass compiledMethodAt:sel
- ].
- (oldMethod notNil and:[oldMethod code ~= newMethod code]) ifTrue:[
- answer := Dialog
- confirm:
-'installation of binary code for ''' , aClass name , '>>' , compiler selector , '''
-is not possible or disabled.
-
-Shall I use the old methods functionality
-or instead create a dummy trap method for it ?
-
-Hint:
- if that method is needed by the system, you better leave the
- original functionality in the system.
-
-Close this warnBox to abort the compilation.
-'
- yesLabel:'trap code'
- noLabel:'keep old'.
- answer isNil ifTrue:[
- ^ #Error
- ].
- answer == false ifTrue:[
- newMethod code:(oldMethod code).
- keptOldCode := true.
- ].
- ].
- aClass addSelector:sel withMethod:newMethod
- ].
- Transcript show:'*** '.
- sel notNil ifTrue:[
- Transcript show:(sel ,' ')
- ].
- keptOldCode ifTrue:[
- msg := 'not really compiled - method still shows previous behavior'.
- ] ifFalse:[
- msg := 'not compiled to machine code - created a stub instead.'.
- ].
- Transcript showCR:msg.
- ].
- ^ newMethod
- ].
-
- compiler hasNonOptionalPrimitiveCode ifTrue:[
- "/
- "/ generate a trapping method, if primitive code is present
- "/
- NewPrimitives ~~ true ifTrue:[
- newMethod := compiler trappingStubMethodFor:aString inCategory:newCategory.
- install ifTrue:[
- aClass addSelector:sel withMethod:newMethod.
- ].
- Transcript show:'*** '.
- sel notNil ifTrue:[
- Transcript show:(sel ,' ')
- ].
- Transcript showCR:'not compiled to machine code - created a stub instead.'.
- ^ newMethod
- ].
- ].
-
- "
- EXPERIMENTAL: quick loading
- only create a lazyMethod, which has no byteCode and will
- compile itself when first called.
- "
- lazy ifTrue:[
- newMethod := LazyMethod new.
- (ClassCategoryReader sourceMode == #sourceReference) ifTrue:[
- sourceFile := ObjectMemory nameForSources.
- sourceFile notNil ifTrue:[
- sourceStream := sourceFile asFilename appendingWriteStream.
- ]
- ].
- sourceStream isNil ifTrue:[
- newMethod source:aString string.
- ] ifFalse:[
- sourceStream setToEnd.
- pos := sourceStream position.
- sourceStream nextChunkPut:aString.
- sourceStream close.
- newMethod sourceFilename:sourceFile position:pos.
- ].
- newMethod setCategory:newCategory.
-pkg := aClass package.
-"/ aClass owningClass isNil ifTrue:[
-"/ pkg := Class packageQuerySignal query.
-"/ ] ifFalse:[
-"/ pkg := aClass owningClass package
-"/ ].
- newMethod setPackage:pkg.
-"/ Project notNil ifTrue:[
-"/ newMethod package:(Project currentPackageName)
-"/ ].
- newMethod numberOfArgs:sel numArgs.
- aClass addSelector:sel withLazyMethod:newMethod.
- ^ newMethod
- ].
-
- primNr := compiler primitiveNumber.
- ((NewPrimitives == true) or:[primNr isNil]) ifTrue:[
- "
- produce symbolic code first
- "
- symbolicCodeArray := compiler genSymbolicCode.
-
- (symbolicCodeArray == #Error) ifTrue:[
- Transcript show:' '.
- sel notNil ifTrue:[
- Transcript show:(sel ,' ')
- ].
- Transcript showCR:'translation error'.
- ^ #Error
- ].
-
- "
- take this, producing bytecode
- (someone willin' to make machine code :-)
- "
- ((compiler genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
- Transcript show:' '.
- sel notNil ifTrue:[
- Transcript show:(sel ,' ')
- ].
- Transcript showCR:'relocation error - must be simplified'.
- ^ #Error
- ].
- ].
-
- "
- finally create the new method-object
- "
- newMethod := compiler createMethod.
- NewPrimitives == true ifTrue:[
- newMethod byteCode:(compiler code).
- primNr isNil ifTrue:[
- compiler hasNonOptionalPrimitiveCode ifTrue:[
- primNr := 0.
- ]
- ].
- primNr notNil ifTrue:[
- newMethod setPrimitiveNumber:primNr
- ]
- ] ifFalse:[
- primNr notNil ifTrue:[
- newMethod code:(compiler checkForPrimitiveCode:primNr).
- ] ifFalse:[
- newMethod byteCode:(compiler code).
- ].
- ].
-
- "
- if there where any corrections, install the updated source
- "
- (newSource := compiler correctedSource) isNil ifTrue:[
- newSource := aString string.
- ].
- (newSource includes:Character return) ifTrue:[
- "/ see if it contains crlf's or only cr's
- newSource := self stringWithSimpleCRs:newSource
- ].
- newMethod source:newSource.
- newMethod setCategory:newCategory.
-
- (install not
- and:[(oldMethod := aClass compiledMethodAt:sel) notNil]) ifTrue:[
- pkg := oldMethod package
- ] ifFalse:[
- (AllowExtensionsToPrivateClasses or:[aClass owningClass isNil]) ifTrue:[
- pkg := Class packageQuerySignal query.
- ] ifFalse:[
- pkg := aClass owningClass package
- ].
- ].
- newMethod setPackage:pkg.
-
- (compiler contextMustBeReturnable) ifTrue:[
- newMethod contextMustBeReturnable:true
- ].
- install ifTrue:[
- aClass addSelector:sel withMethod:newMethod
- ].
-
- silencio ifFalse:[
- Transcript showCR:(' compiled: ', aClass name,' ', sel)
- ].
-
- ^ newMethod
-
- "Created: / 29.10.1995 / 19:59:36 / cg"
- "Modified: / 19.3.1999 / 08:31:09 / stefan"
- "Modified: / 17.11.2001 / 21:27:08 / cg"
+ ^ self new
+ compile:aStringArg forClass:aClassArg inCategory:cat notifying:requestor
+ install:install skipIfSame:skipIfSame silent:silent foldConstants:fold
!
compile:methodText forClass:classToCompileFor notifying:requestor
@@ -3285,6 +2930,374 @@
"Modified: 25.6.1997 / 15:06:10 / cg"
! !
+!ByteCodeCompiler methodsFor:'compilation'!
+
+compile:aStringArg forClass:aClassArg inCategory:cat notifying:requestor
+ install:install skipIfSame:skipIfSame silent:silent foldConstants:fold
+
+ "the basic workhorse method for compiling:
+ compile a source-string for a method in classToCompileFor.
+ errors are forwarded to requestor
+ (report on Transcript and return #Error, if requestor is nil).
+
+ The new method will get cat as category.
+ If install is true, the method will go into the classes method-table,
+ otherwise the method is simply returned (for anonymous methods).
+ If skipIsSame is true, and the source is the same as an existing
+ methods source, this is a noop (for fast fileIn).
+ The argument, silent controls if errors are to be reported.
+ Returns the method, #Error or nil."
+
+ |newMethod tree symbolicCodeArray oldMethod lazy silencio
+ sourceFile sourceStream newSource primNr pos keptOldCode answer
+ pkg aClass aString errorOccurred oldCategory newCategory|
+
+ aClass := aClassArg.
+ aString := aStringArg.
+
+ aString isNil ifTrue:[^ nil].
+ silencio := silent
+ or:[Smalltalk silentLoading == true
+ or:[ListCompiledMethods == false]].
+
+ "lazy compilation is EXPERIMENTAL"
+ lazy := (LazyCompilation == true) and:[install].
+ "/ no longer ...
+ lazy := false.
+
+ RestartCompilationSignal handle:[:ex |
+ "/ class could have changed ...
+ aClass := self classToCompileFor.
+ aString := self correctedSource ? aStringArg.
+ ex restart
+ ] do:[
+ "create a compiler, let it parse and create the parsetree"
+
+ self source:(ReadStream on:aString).
+ self setClassToCompileFor:aClass.
+
+ self parseForCode.
+ fold ifFalse:[self foldConstants:nil].
+ self notifying:requestor.
+ silent ifTrue:[
+ "/ self ignoreErrors.
+ self ignoreWarnings.
+ self warnUndeclared:false.
+ ].
+
+ (errorOccurred := (self parseMethodSpec == #Error)) ifTrue:[
+ self parseError:'syntax error in method specification'.
+ tree := #Error.
+ ] ifFalse:[
+ tree := self parseMethodBody.
+ self checkForEndOfInput.
+ self tree:tree.
+ ].
+ ].
+
+ selector notNil ifTrue:[
+ oldMethod := aClass compiledMethodAt:selector.
+ oldMethod notNil ifTrue:[
+ oldCategory := oldMethod category.
+ ].
+ ].
+ newCategory := cat.
+ newCategory isNil ifTrue:[
+ newCategory := oldCategory ? '* As yet uncategorized *'.
+ ].
+
+ errorOccurred ifFalse:[
+ (aClass isNil or:[AllowExtensionsToPrivateClasses or:[aClass owningClass isNil]]) ifTrue:[
+ (requestor respondsTo:#packageToInstall) ifFalse:[
+ pkg := Class packageQuerySignal query.
+ ] ifTrue:[
+ pkg := requestor packageToInstall
+ ].
+ ] ifFalse:[
+ pkg := aClass owningClass package
+ ].
+
+ lazy ifTrue:[
+ "/
+ "/ that one method IS required
+ "/
+ (aClass isMeta and:[selector == #version]) ifTrue:[
+ lazy := false
+ ].
+ "/
+ "/ primitives also
+ "/
+ (self hasNonOptionalPrimitiveCode
+ or:[self hasPrimitiveCode and:[self class canCreateMachineCode]])
+ ifTrue:[
+ lazy := false
+ ].
+ ].
+
+ lazy ifFalse:[
+ "check if same source"
+ skipIfSame ifTrue:[
+ oldMethod notNil ifTrue:[
+ oldMethod source = aString ifTrue:[
+ oldMethod isInvalid ifFalse:[
+ silencio ifFalse:[
+ Transcript showCR:(' unchanged: ',aClass name,' ',selector)
+ ].
+ "
+ same. however, category may be different
+ "
+ (newCategory ~= oldCategory) ifTrue:[
+ oldMethod category:newCategory.
+"/ aClass updateRevisionString.
+ aClass addChangeRecordForMethodCategory:oldMethod category:newCategory.
+ silencio ifFalse:[
+ Transcript showCR:(' (category change only)')
+ ].
+ ].
+ "
+ and package may be too.
+ "
+ (pkg notNil and:[pkg ~~ oldMethod package]) ifTrue:[
+ oldMethod package:pkg.
+ silencio ifFalse:[
+ Transcript showCR:(' (package-id change only)')
+ ].
+ ].
+ ^ oldMethod
+ ]
+ ]
+ ]
+ ].
+ ]
+ ].
+
+ (self errorFlag or:[tree == #Error]) ifTrue:[
+ self showErrorMessageForClass:aClass.
+ ^ #Error
+ ].
+
+ "if no error and also no selector ..."
+ selector isNil ifTrue:[
+ "... it was just a comment or other empty stuff"
+ ^ nil
+ ].
+
+ "
+ freak-out support for inline C-code...
+ "
+ ((self hasNonOptionalPrimitiveCode
+ or:[(self hasPrimitiveCode and:[self class canCreateMachineCode])
+ or:[STCCompilation == #always and:[selector ~~ #doIt]]])
+ and:[(STCCompilation ~~ #never)
+ and:[NewPrimitives ~~ true]]) ifTrue:[
+
+ newMethod := self
+ compileToMachineCode:aString
+ forClass:aClass
+ inCategory:newCategory
+ notifying:requestor
+ install:install
+ skipIfSame:skipIfSame
+ silent:silent.
+
+ newMethod == #Error ifTrue:[
+ self showErrorMessageForClass:aClass.
+ ^ #Error
+ ].
+
+ (newMethod == #CannotLoad) ifTrue:[
+ newMethod := self trappingStubMethodFor:aString inCategory:newCategory.
+ newMethod setPackage:pkg.
+ keptOldCode := false.
+ install ifTrue:[
+ "/
+ "/ be very careful with existing methods
+ "/ (otherwise, you could easily make your system unusable in systems which cannot load)
+ "/
+ selector notNil ifTrue:[
+ oldMethod := aClass compiledMethodAt:selector
+ ].
+ (oldMethod notNil and:[oldMethod code ~= newMethod code]) ifTrue:[
+ answer := Dialog
+ confirm:
+'installation of binary code for ''' , aClass name , '>>' , selector , '''
+is not possible or disabled.
+
+Shall I use the old methods functionality
+or instead create a dummy trap method for it ?
+
+Hint:
+ if that method is needed by the system, you better leave the
+ original functionality in the system.
+
+Close this warnBox to abort the compilation.
+'
+ yesLabel:'trap code'
+ noLabel:'keep old'.
+ answer isNil ifTrue:[
+ ^ #Error
+ ].
+ answer == false ifTrue:[
+ newMethod code:(oldMethod code).
+ keptOldCode := true.
+ ].
+ ].
+ aClass addSelector:selector withMethod:newMethod
+ ].
+ self showErrorNotification:(keptOldCode
+ ifTrue:'not really compiled - method still shows previous behavior'
+ ifFalse:'not compiled to machine code - created a stub instead.')
+ ].
+ ^ newMethod
+ ].
+
+ self hasNonOptionalPrimitiveCode ifTrue:[
+ "/
+ "/ generate a trapping method, if primitive code is present
+ "/
+ NewPrimitives ~~ true ifTrue:[
+ newMethod := self trappingStubMethodFor:aString inCategory:newCategory.
+ install ifTrue:[
+ aClass addSelector:selector withMethod:newMethod.
+ ].
+ self showErrorNotification:'not compiled to machine code - created a stub instead.'.
+ ^ newMethod
+ ].
+ ].
+
+ "
+ EXPERIMENTAL: quick loading
+ only create a lazyMethod, which has no byteCode and will
+ compile itself when first called.
+ "
+ lazy ifTrue:[
+ newMethod := LazyMethod new.
+ (ClassCategoryReader sourceMode == #sourceReference) ifTrue:[
+ sourceFile := ObjectMemory nameForSources.
+ sourceFile notNil ifTrue:[
+ sourceStream := sourceFile asFilename appendingWriteStream.
+ ]
+ ].
+ sourceStream isNil ifTrue:[
+ newMethod source:aString string.
+ ] ifFalse:[
+ sourceStream setToEnd.
+ pos := sourceStream position.
+ sourceStream nextChunkPut:aString.
+ sourceStream close.
+ newMethod sourceFilename:sourceFile position:pos.
+ ].
+ newMethod setCategory:newCategory.
+pkg := aClass package.
+"/ aClass owningClass isNil ifTrue:[
+"/ pkg := Class packageQuerySignal query.
+"/ ] ifFalse:[
+"/ pkg := aClass owningClass package
+"/ ].
+ newMethod setPackage:pkg.
+"/ Project notNil ifTrue:[
+"/ newMethod package:(Project currentPackageName)
+"/ ].
+ newMethod numberOfArgs:selector numArgs.
+ aClass addSelector:selector withLazyMethod:newMethod.
+ ^ newMethod
+ ].
+
+ primNr := self primitiveNumber.
+ ((NewPrimitives == true) or:[primNr isNil]) ifTrue:[
+ "
+ produce symbolic code first
+ "
+ symbolicCodeArray := self genSymbolicCode.
+
+ (symbolicCodeArray == #Error) ifTrue:[
+ self showErrorNotification:'translation error'.
+ ^ #Error
+ ].
+
+ "
+ take this, producing bytecode
+ (someone willin' to make machine code :-)
+ "
+ ((self genByteCodeFrom:symbolicCodeArray) == #Error) ifTrue:[
+ self showErrorNotification:'relocation error - code must be simplified'.
+ ^ #Error
+ ].
+ ].
+
+ "
+ finally create the new method-object
+ "
+ newMethod := self createMethod.
+ NewPrimitives == true ifTrue:[
+ newMethod byteCode:(self code).
+ primNr isNil ifTrue:[
+ self hasNonOptionalPrimitiveCode ifTrue:[
+ primNr := 0.
+ ]
+ ].
+ primNr notNil ifTrue:[
+ newMethod setPrimitiveNumber:primNr
+ ]
+ ] ifFalse:[
+ primNr notNil ifTrue:[
+ newMethod code:(self checkForPrimitiveCode:primNr).
+ ] ifFalse:[
+ newMethod byteCode:(self code).
+ ].
+ ].
+
+ "
+ if there where any corrections, install the updated source
+ "
+ (newSource := self correctedSource) isNil ifTrue:[
+ newSource := aString string.
+ ].
+ (newSource includes:Character return) ifTrue:[
+ "/ see if it contains crlf's or only cr's
+ newSource := self class stringWithSimpleCRs:newSource
+ ].
+ newMethod source:newSource.
+ newMethod setCategory:newCategory.
+
+ (install not
+ and:[(oldMethod := aClass compiledMethodAt:selector) notNil]) ifTrue:[
+ pkg := oldMethod package
+ ] ifFalse:[
+ (AllowExtensionsToPrivateClasses or:[aClass owningClass isNil]) ifTrue:[
+ pkg := Class packageQuerySignal query.
+ ] ifFalse:[
+ pkg := aClass owningClass package
+ ].
+ ].
+ newMethod setPackage:pkg.
+
+ (self contextMustBeReturnable) ifTrue:[
+ newMethod contextMustBeReturnable:true
+ ].
+ install ifTrue:[
+ aClass addSelector:selector withMethod:newMethod
+ ].
+
+ silencio ifFalse:[
+ Transcript showCR:(' compiled: ', aClass name,' ', selector)
+ ].
+
+ ^ newMethod
+
+ "Created: / 29.10.1995 / 19:59:36 / cg"
+ "Modified: / 19.3.1999 / 08:31:09 / stefan"
+ "Modified: / 17.11.2001 / 21:27:08 / cg"
+!
+
+showErrorNotification:message
+ Transcript show:'***'.
+ selector notNil ifTrue:[
+ Transcript show:(selector ,' ')
+ ].
+ Transcript showCR:message.
+! !
+
!ByteCodeCompiler methodsFor:'machine code generation'!
compileToMachineCode:aString forClass:aClass inCategory:cat
@@ -3801,7 +3814,7 @@
!ByteCodeCompiler class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.205 2002-11-26 09:08:11 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libcomp/ByteCodeCompiler.st,v 1.206 2003-01-29 17:59:00 penk Exp $'
! !
ByteCodeCompiler initialize!
--- a/Parser.st Wed Jan 29 18:58:13 2003 +0100
+++ b/Parser.st Wed Jan 29 18:59:00 2003 +0100
@@ -703,181 +703,8 @@
reading and simple sends, where the overhead of compilation is bigger
than the interpretation overhead."
- |parser tree mustBackup loggedString chgStream value s sReal spc
- nameSpaceQuerySignal|
-
- aStringOrStream isNil ifTrue:[
- EmptySourceNotificationSignal raiseRequest.
- ^ nil
- ].
- (mustBackup := aStringOrStream isStream) ifTrue:[
- s := aStringOrStream.
- ] ifFalse:[
- loggedString := aStringOrStream.
- s := ReadStream on:aStringOrStream.
- ].
- parser := self for:s.
- parser parseForCode.
- parser foldConstants:nil.
- parser setSelf:anObject.
- parser setContext:aContext.
- aContext notNil ifTrue:[
- parser setSelf:(aContext receiver).
-"/ aContext method notNil ifTrue:[
-"/ cls := aContext method mclass
-"/ ].
-"/ parser setClassToCompileFor:(cls ? aContext receiver class).
- parser setClassToCompileFor:(aContext receiver class).
- ].
- parser notifying:requestor.
- parser nextToken.
- parser evalExitBlock:[:value | parser release. ^ value].
- tree := parser parseMethodBodyOrEmpty.
-
- parser checkForEndOfInput.
-
- "if reading from a stream, backup for next expression"
- mustBackup ifTrue:[
- parser backupPosition
- ].
-
- (parser errorFlag or:[tree == #Error]) ifTrue:[
- failBlock notNil ifTrue:[
- ^ failBlock value
- ].
- ^ #Error
- ].
-
- tree isNil ifTrue:[
- EmptySourceNotificationSignal raiseRequest.
- ^ nil
- ].
-
- (logged
- and:[loggedString notNil
- and:[Smalltalk logDoits]]) ifTrue:[
- Class updateChangeFileQuerySignal query ifTrue:[
- chgStream := Class changesStream.
- chgStream notNil ifTrue:[
- chgStream nextChunkPut:loggedString.
- chgStream cr.
- chgStream close
- ]
- ].
- Project notNil ifTrue:[
- Class updateChangeListQuerySignal query ifTrue:[
- Project addDoIt:loggedString
- ]
- ]
- ].
-
- "
- during the evaluation, handle nameSpace queries
- from the value as defined by any namespace directive.
- This, if its a class definition expression, the class will
- be installed there.
- "
- nameSpaceQuerySignal := Class nameSpaceQuerySignal.
-
- spc := parser getNameSpace.
- spc isNil ifTrue:[
- (requestor respondsTo:#currentNameSpace) ifTrue:[
- spc := requestor currentNameSpace
- ] ifFalse:[
- spc := nameSpaceQuerySignal query.
- ]
- ].
-
- nameSpaceQuerySignal answer:spc
- do:[
- |method|
-
- "
- if compile is false, or the parse tree is that of a constant,
- or a variable, quickly return its value.
- This is used for example, when reading simple objects
- via #readFrom:.
- The overhead of compiling a method is avoided in this case.
- "
- ((SuppressDoItCompilation == true)
- or:[compile not
- or:[tree isConstant
- or:[tree isVariable
- or:[aStringOrStream isStream
- or:[aContext notNil]]]]]) ifTrue:[
- ^ tree evaluate
- ].
-
- "
- if I am the ByteCodeCompiler,
- generate a dummy method, execute it and return the value.
- otherwise, just evaluate the tree; slower, but not too bad ...
-
- This allows systems to be delivered without the ByteCodeCompiler,
- and still evaluate expressions
- (needed to read resource files or to process .rc files).
- "
- self == Parser ifTrue:[
- parser evalExitBlock:[:value | parser release. ^ value].
- value := tree evaluate.
- parser evalExitBlock:nil.
- ] ifFalse:[
- s := parser correctedSource.
- s isNil ifTrue:[
- aStringOrStream isStream ifTrue:[
- s := parser collectedSource. "/ does not work yet ...
- ] ifFalse:[
- s := aStringOrStream
- ].
- ].
-
- "/ actually, its a block, to allow
- "/ easy return ...
-
- sReal := 'doIt ^[\' withCRs , s , '\] value' withCRs.
-
- method := self
- compile:sReal
- forClass:anObject class
- inCategory:'_temporary_'
- notifying:requestor
- install:false
- skipIfSame:false
- silent:true
- foldConstants:false.
-
- method notNil ifTrue:[
- method ~~ #Error ifTrue:[
- "
- fake: patch the source string, to what the user expects
- in the browser
- "
- method source:' \' withCRs , s string.
- "
- dont do any just-in-time compilation on it.
- "
- method checked:true.
-
- value := method
- valueWithReceiver:anObject
- arguments:nil "/ (Array with:m)
- selector:#doIt "/ #doIt:
- search:nil
- sender:nil.
- ] ifFalse:[
- parser evalExitBlock:[:value | parser release. ^ value].
- value := tree evaluate.
- parser evalExitBlock:nil.
- ]
- ].
- ]
- ].
- parser release.
- ^ value
-
- "Created: / 8.2.1997 / 19:34:44 / cg"
- "Modified: / 18.3.1999 / 18:25:40 / stefan"
- "Modified: / 6.2.2000 / 15:01:57 / cg"
+ ^ self new
+ evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor logged:logged ifFail:failBlock compile:compile
!
evaluate:aStringOrStream logged:logged
@@ -2068,6 +1895,12 @@
"private: set the tree - for internal use only"
tree := aTree
+!
+
+warnSTXHereExtensionUsed
+ "return the value of the instance variable 'warnSTXHereExtensionUsed' (automatically generated)"
+
+ ^ warnSTXHereExtensionUsed
! !
!Parser methodsFor:'dummy - syntax detection'!
@@ -3375,6 +3208,202 @@
"Modified: / 17.11.2001 / 10:30:47 / cg"
! !
+!Parser methodsFor:'evaluating expressions'!
+
+evaluate:aStringOrStream in:aContext receiver:anObject notifying:requestor logged:logged ifFail:failBlock compile:compile
+ "return the result of evaluating aStringOrStream, errors are reported to requestor.
+ Allow access to anObject as self and to its instVars (used in the inspector).
+ If logged is true, an entry is added to the change-file. If the failBlock argument
+ is non-nil, it is evaluated if an error occurs.
+ Finally, compile specifies if the string should be compiled down to
+ bytecode or instead be interpreted from the parseTree.
+ The first should be done for doIts etc, where a readable walkback is
+ required.
+ The latter is better done for constants, styleSheet and resource
+ reading and simple sends, where the overhead of compilation is bigger
+ than the interpretation overhead."
+
+ |tree mustBackup loggedString chgStream value s sReal spc
+ nameSpaceQuerySignal compiler|
+
+ aStringOrStream isNil ifTrue:[
+ EmptySourceNotificationSignal raiseRequest.
+ ^ nil
+ ].
+ (mustBackup := aStringOrStream isStream) ifTrue:[
+ s := aStringOrStream.
+ ] ifFalse:[
+ loggedString := aStringOrStream.
+ s := ReadStream on:aStringOrStream.
+ ].
+
+ self source:s.
+
+ self parseForCode.
+ self foldConstants:nil.
+ self setSelf:anObject.
+ self setContext:aContext.
+ aContext notNil ifTrue:[
+ self setSelf:(aContext receiver).
+"/ aContext method notNil ifTrue:[
+"/ cls := aContext method mclass
+"/ ].
+"/ self setClassToCompileFor:(cls ? aContext receiver class).
+ self setClassToCompileFor:(aContext receiver class).
+ ].
+ self notifying:requestor.
+ self nextToken.
+ self evalExitBlock:[:value | self release. ^ value].
+ tree := self parseMethodBodyOrEmpty.
+
+ self checkForEndOfInput.
+
+ "if reading from a stream, backup for next expression"
+ mustBackup ifTrue:[
+ self backupPosition
+ ].
+
+ (self errorFlag or:[tree == #Error]) ifTrue:[
+ failBlock notNil ifTrue:[
+ ^ failBlock value
+ ].
+ ^ #Error
+ ].
+
+ tree isNil ifTrue:[
+ EmptySourceNotificationSignal raiseRequest.
+ ^ nil
+ ].
+
+ (logged
+ and:[loggedString notNil
+ and:[Smalltalk logDoits]]) ifTrue:[
+ Class updateChangeFileQuerySignal query ifTrue:[
+ chgStream := Class changesStream.
+ chgStream notNil ifTrue:[
+ chgStream nextChunkPut:loggedString.
+ chgStream cr.
+ chgStream close
+ ]
+ ].
+ Project notNil ifTrue:[
+ Class updateChangeListQuerySignal query ifTrue:[
+ Project addDoIt:loggedString
+ ]
+ ]
+ ].
+
+ "
+ during the evaluation, handle nameSpace queries
+ from the value as defined by any namespace directive.
+ This, if its a class definition expression, the class will
+ be installed there.
+ "
+ nameSpaceQuerySignal := Class nameSpaceQuerySignal.
+
+ spc := self getNameSpace.
+ spc isNil ifTrue:[
+ (requestor respondsTo:#currentNameSpace) ifTrue:[
+ spc := requestor currentNameSpace
+ ] ifFalse:[
+ spc := nameSpaceQuerySignal query.
+ ]
+ ].
+
+ nameSpaceQuerySignal answer:spc
+ do:[
+ |method|
+
+ "
+ if compile is false, or the parse tree is that of a constant,
+ or a variable, quickly return its value.
+ This is used for example, when reading simple objects
+ via #readFrom:.
+ The overhead of compiling a method is avoided in this case.
+ "
+ ((SuppressDoItCompilation == true)
+ or:[compile not
+ or:[tree isConstant
+ or:[tree isVariable
+ or:[aStringOrStream isStream
+ or:[aContext notNil]]]]]) ifTrue:[
+ ^ tree evaluate
+ ].
+
+ "
+ if I am the ByteCodeCompiler,
+ generate a dummy method, execute it and return the value.
+ otherwise, just evaluate the tree; slower, but not too bad ...
+
+ This allows systems to be delivered without the ByteCodeCompiler,
+ and still evaluate expressions
+ (needed to read resource files or to process .rc files).
+ "
+ self == Parser ifTrue:[
+ self evalExitBlock:[:value | self release. ^ value].
+ value := tree evaluate.
+ self evalExitBlock:nil.
+ ] ifFalse:[
+ s := self correctedSource.
+ s isNil ifTrue:[
+ aStringOrStream isStream ifTrue:[
+ s := self collectedSource. "/ does not work yet ...
+ ] ifFalse:[
+ s := aStringOrStream
+ ].
+ ].
+
+ "/ actually, its a block, to allow
+ "/ easy return ...
+
+ sReal := 'doIt ^[\' withCRs , s , '\] value' withCRs.
+
+ compiler := self class new.
+ compiler initializeFlagsFrom:self.
+ method := compiler
+ compile:sReal
+ forClass:anObject class
+ inCategory:'_temporary_'
+ notifying:requestor
+ install:false
+ skipIfSame:false
+ silent:true
+ foldConstants:false.
+
+ method notNil ifTrue:[
+ method ~~ #Error ifTrue:[
+ "
+ fake: patch the source string, to what the user expects
+ in the browser
+ "
+ method source:' \' withCRs , s string.
+ "
+ dont do any just-in-time compilation on it.
+ "
+ method checked:true.
+
+ value := method
+ valueWithReceiver:anObject
+ arguments:nil "/ (Array with:m)
+ selector:#doIt "/ #doIt:
+ search:nil
+ sender:nil.
+ ] ifFalse:[
+ self evalExitBlock:[:value | self release. ^ value].
+ value := tree evaluate.
+ self evalExitBlock:nil.
+ ]
+ ].
+ ]
+ ].
+ self release.
+ ^ value
+
+ "Created: / 8.2.1997 / 19:34:44 / cg"
+ "Modified: / 18.3.1999 / 18:25:40 / stefan"
+ "Modified: / 6.2.2000 / 15:01:57 / cg"
+! !
+
!Parser methodsFor:'parsing'!
block
@@ -3860,7 +3889,7 @@
self nextToken
].
- AllowSqueakExtensions ifTrue:[
+ allowSqueakExtensions ifTrue:[
"/ allow for primitiveSpec after local-var decl.
((tokenType == #BinaryOperator) and:[tokenName = '<']) ifTrue:[
@@ -4003,7 +4032,7 @@
(tokenName = 'primitive:') ifTrue:[
self nextToken.
(tokenType == #Integer) ifFalse:[
- AllowSqueakExtensions ifTrue:[
+ allowSqueakExtensions ifTrue:[
(tokenType == #String) ifFalse:[
self parseError:'primitive number or name expected'.
^ #Error
@@ -4215,7 +4244,7 @@
].
(tokenType == $.) ifTrue:[
- AllowSqueakExtensions == true ifTrue:[
+ allowSqueakExtensions == true ifTrue:[
"/ allow empty statement
^ StatementNode expression:nil.
].
@@ -5252,7 +5281,8 @@
].
(tokenType == ${ ) ifTrue:[
- AllowSqueakExtensions == true ifFalse:[
+ allowSqueakExtensions == true ifFalse:[
+self halt.
self parseError:'non-Standard Squeak extension: Brace Computed Array. Enable in settings.' position:pos to:tokenPosition.
^ #Error
].
@@ -6840,6 +6870,13 @@
"Modified: 7.9.1997 / 02:04:34 / cg"
!
+initializeFlagsFrom:aParser
+ "initialize flags from another scanner"
+
+ super initializeFlagsFrom:aParser.
+ warnSTXHereExtensionUsed := aParser warnSTXHereExtensionUsed.
+!
+
parseForCode
"turns off certain statistics (keeping referenced variables, modified vars etc.)
Use this when parsing for compilation or evaluation"
@@ -7031,7 +7068,7 @@
!Parser class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.364 2003-01-28 19:49:58 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libcomp/Parser.st,v 1.365 2003-01-29 17:58:41 penk Exp $'
! !
Parser initialize!