"

 COPYRIGHT (c) 1989 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

'From Smalltalk/X, Version:2.10.8 on 29-oct-1995 at 20:01:16'                   !

Parser subclass:#ByteCodeCompiler

	 instanceVariableNames:'codeBytes codeIndex litArray stackDelta extra lineno

		maxStackDepth relocList'

	 classVariableNames:'JumpToAbsJump SequenceNumber STCCompilationDefines

		STCCompilationIncludes STCCompilationOptions STCCompilation

		KeepSource STCKeepCIntermediate'

	 poolDictionaries:''

	 category:'System-Compiler'

!

!ByteCodeCompiler class methodsFor:'documentation'!

version

!

documentation

"

    This class performs compilation into ByteCodes.

    First, parsing is done using superclass methods,

    then the parse-tree is converted into an array of symbolic codes

    and a relocation table; 

    these two are finally combined into a byteArray of the codes.

    (the intermediate step through symbolic codes is for debugging

     only - it will vanish)

    There are many dependencies to the run-time-system (especially the

    interpreter) in here - be careful when playing around ...

    Instance variables:

	codeBytes       <ByteArry>              bytecodes

	codeIndex       <SmallInteger>          next index to put into code array

	litArray        <OrderedCollection>     literals

	stackDelta      <SmallInteger>          return value of byteCodeFor:

	extra           <Symbol>                return value of byteCodeFor:

	lineno          <Boolean>               return value of byteCodeFor:

	maxStackDepth   <SmallInteger>          stack need of method

	relocList       <Array>                 used temporary for relocation

    Class variables:

	JumpToAbsJump   <Dictionary>            internal table to map opcodes

"

!

copyright

"

 COPYRIGHT (c) 1989 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

! !

!ByteCodeCompiler class methodsFor:'compiling methods'!

compile:aString forClass:aClass inCategory:cat notifying:requestor

		 install:install skipIfSame:skipIfSame

    "compile a source-string for a method in classToCompileFor.

     The install-argument controls if the method is to be installed into the

     classes method-dictionary, or just to be compiled and a method object to be returned.

     Errors are forwarded to requestor. The method will get cat as category.

     If skipIsSame is true, and the source is the same as an existing

     methods source, this is a noop (for fast fileIn)."

    ^ self compile:aString

	  forClass:aClass

	inCategory:cat

	 notifying:requestor

	   install:install

	skipIfSame:skipIfSame

	    silent:false

!

compile:textOrStream in:aClass notifying:requestor ifFail:exceptionBlock

    "name alias for ST-80 compatibility"

    |m|

    m := self 

	   compile:textOrStream

	  forClass:aClass 

	inCategory:'others'

	 notifying:requestor 

	   install:true

	skipIfSame:false

	    silent:false.

    m == #Error ifTrue:[

	^ exceptionBlock value

    ].

     ^ m

!

compile:methodText forClass:classToCompileFor

    "compile a source-string for a method in classToCompileFor"

    ^ self compile:methodText

	  forClass:classToCompileFor

	inCategory:'others'

	 notifying:nil

	   install:true

	skipIfSame:false

	    silent:false

!

compile:aString forClass:aClass inCategory:cat

    "compile a source-string for a method in classToCompileFor.

     The method will get cat as category"

    ^ self compile:aString

	  forClass:aClass

	inCategory:cat

	 notifying:nil

	   install:true

	skipIfSame:false

	    silent:false

!

compile:aString forClass:aClass inCategory:cat notifying:requestor

    "compile a source-string for a method in classToCompileFor.

     errors are forwarded to requestor.

     The method will get cat as category"

    ^ self compile:aString

	  forClass:aClass

	inCategory:cat

	 notifying:requestor

	   install:true

	skipIfSame:false

	    silent:false

!

compile:aString forClass:aClass inCategory:cat notifying:requestor

		 install:install skipIfSame:skipIfSame silent:silent

    "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."

    |compiler newMethod tree lits symbolicCodeArray oldMethod lazy silencio 

     sourceFile sourceStream newSource primNr pos sel|

    aString isNil ifTrue:[^ nil].

    silencio := silent or:[Smalltalk silentLoading == true].

    "lazy compilation is EXPERIMENTAL"

    lazy := (LazyCompilation == true) and:[install].

    "create a compiler, let it parse and create the parsetree"

    compiler := self for:(ReadStream on:aString) in:aClass.

    compiler parseForCode.

    compiler notifying:requestor.

    silent ifTrue:[

"/        compiler ignoreErrors.

	compiler ignoreWarnings

    ].

    compiler nextToken.

    (compiler parseMethodSpec == #Error) ifTrue:[

	tree := #Error

    ] ifFalse:[

	"check if same source"

	(skipIfSame and:[(sel := compiler selector) notNil]) ifTrue:[

	    oldMethod := aClass compiledMethodAt:sel.

	    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

			"

			(cat notNil and:[cat ~~ oldMethod category]) ifTrue:[

			    oldMethod category:cat.

			    oldMethod changed:#category.    

			    aClass addChangeRecordForMethodCategory:oldMethod category:cat.

			].

			^ oldMethod

		    ]

		]

	    ]

	].

	lazy ifFalse:[

	    tree := compiler parseMethodBody.

	    compiler tree:tree.

	]

    ].

    sel := compiler selector.

    (compiler errorFlag or:[tree == #Error]) ifTrue:[

"/        compiler parseError:'syntax error'.

	Transcript show:'    '.

	aClass notNil ifTrue:[

	    Transcript show:aClass name , '>>'

	].

	sel notNil ifTrue:[

	    Transcript show:(sel)

	].

	Transcript showCr:' -> Error'.

	^ #Error

    ].

    "if no error and also no selector ..."

     sel isNil ifTrue:[

	"... it was just a comment or other empty stuff"

	^ nil

    ].

    "

     freak-out support ...

    "

    (compiler hasNonOptionalPrimitiveCode 

    or:[(compiler hasPrimitiveCode and:[self canCreateMachineCode])

    or:[STCCompilation == #always and:[sel  ~~ #doIt]]]) ifTrue:[

	newMethod := compiler 

			compileToMachineCode:aString 

			forClass:aClass 

			inCategory:cat 

			notifying:requestor

			install:install 

			skipIfSame:skipIfSame 

			silent:silent.

	newMethod ==#Error ifTrue:[

	    newMethod := compiler trappingStubMethodFor:aString inCategory:cat.

	    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.

	KeepSource == false ifTrue:[

	    sourceFile := ObjectMemory nameForSources.

	    sourceStream := sourceFile asFilename appendingWriteStream.

	].

	sourceStream isNil ifTrue:[

	    newMethod source:aString.

	] ifFalse:[

	    sourceStream setToEnd.

	    pos := sourceStream position.

	    sourceStream nextChunkPut:aString.

	    sourceStream close.

	    newMethod sourceFilename:sourceFile position:pos.

	].

	newMethod category:cat.

	Project notNil ifTrue:[

	    newMethod package:(Project currentPackageName)

	].

	aClass addSelector:sel withLazyMethod:newMethod.

	^ newMethod

    ].

    (primNr := compiler primitiveNumber) 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 := Method new.

    lits := compiler literalArray.

    lits notNil ifTrue:[

	"literals MUST be an array - not just any Collection"

	lits := Array withAll:lits.

	newMethod literals:lits

    ].

    primNr notNil ifTrue:[

	newMethod code:(compiler checkForPrimitiveCode:primNr).

    ] ifFalse:[

	newMethod byteCode:(compiler code).

    ].

    newMethod numberOfMethodVars:(compiler numberOfMethodVars).

    newMethod numberOfMethodArgs:(compiler numberOfMethodArgs).

    newMethod stackSize:(compiler maxStackDepth).

    "

     if there where any corrections, install the updated source

    "

    (newSource := compiler correctedSource) notNil ifTrue:[

	newMethod source:newSource 

    ] ifFalse:[

	newMethod source:aString.

    ].

    newMethod category:cat.

    Project notNil ifTrue:[

	newMethod package:(Project currentPackageName)

    ].

    install ifTrue:[

	aClass addSelector:sel withMethod:newMethod

    ].

    silencio ifFalse:[

	Transcript showCr:('    compiled: ', aClass name,' ', sel)

    ].

    ^ newMethod

    "Created: 29.10.1995 / 19:59:36 / cg"

!

compile:methodText forClass:classToCompileFor notifying:requestor

    "compile a source-string for a method in classToCompileFor.

     Errors are forwarded to requestor."

    ^ self compile:methodText

	  forClass:classToCompileFor

	inCategory:'others'

	 notifying:requestor

	   install:true

	skipIfSame:false

	    silent:false

!

compile:aString forClass:aClass inCategory:cat notifying:requestor install:install

    "compile a source-string for a method in classToCompileFor.

     The install-argument controls if the method is to be installed into the

     classes method-dictionary, or just to be compiled and a method object to be returned.

     Errors are forwarded to requestor. The method will get cat as category"

    ^ self compile:aString

	  forClass:aClass

	inCategory:cat

	 notifying:requestor

	   install:install

	skipIfSame:false

	    silent:false

! !

!ByteCodeCompiler class methodsFor:'constants'!

byteCodeFor:aSymbol

    "only some exported codes handled here (for BlockNode)"

    (aSymbol == #retNil) ifTrue:[^ 1].

    (aSymbol == #retTrue) ifTrue:[^ 2].

    (aSymbol == #retFalse) ifTrue:[^ 3].

    (aSymbol == #ret0) ifTrue:[^ 4].

    (aSymbol == #retTop) ifTrue:[^ 0].

    (aSymbol == #push0) ifTrue:[^120].

    (aSymbol == #push1) ifTrue:[^121].

    (aSymbol == #push2) ifTrue:[^139].

    (aSymbol == #pushMinus1) ifTrue:[^122].

    (aSymbol == #pushNil) ifTrue:[^ 10].

    (aSymbol == #pushTrue) ifTrue:[^ 11].

    (aSymbol == #pushFalse) ifTrue:[^ 12].

    (aSymbol == #pushSelf) ifTrue:[^ 15].

    self error

! !

!ByteCodeCompiler class methodsFor:'stc compilation defaults'!

stcCompilationIncludes:aString

    "define the include directories via additional -I flags.

     These are passed to stc. Can be set in your private.rc file"

    STCCompilationIncludes := aString

    "

     Compiler stcCompilationIncludes:'-I/usr/local/include -I../../include'

     Compiler stcCompilationIncludes:(Compiler stcCompilationIncludes , ' -I../../libxt')

    "

!

stcCompilationDefines:aString

    "define the flags (for example, additional -D defines)

     to be used when compiling to machine code.

     These are passed to stc. Can be set from your private.rc file."

    STCCompilationDefines := aString

    "

     Compiler stcCompilationDefines:'-DVGL -DDEBUG'

    "

!

stcCompilationOptions:aString

    "define the compilation options 

     to be used when compiling to machine code.

     These are passed to stc. Can be set from your private.rc file."

    STCCompilationOptions := aString

    "

     Compiler stcCompilationOptions:'+optinline'

    "

!

stcCompilationIncludes

    "return the includes used with stc compilation"

    ^ STCCompilationIncludes

!

stcCompilationDefines

    "return the defines used with stc compilation"

    ^ STCCompilationDefines

!

stcCompilation:how

    "set the flag which controls compilation to machine code.

     If #always, methods are always compiled to machine code (which takes

     longer, but provides faster code). If #none, methods are never compiled

     to machine code, instead for non-primitive ones, compilation is to bytecode

     and for primitive ones, a trapping stub is generated.

     Anything else lets the compiler compile to bytecode,

     except for methods containing primitive code.

     This can be set from your private.rc file or from a workspace

     for selective compilation to machine code."

    |ret|

    ret := STCCompilation.

    STCCompilation := how.

    ^ ret