" -*- Smalltalk -*- "

CompilerOutputStream : WriteStream ()

CompilerOutputStream gen: aString [ ^self nextPutAll: aString ]

" ---------------------------------------------------------------- "

TranslationUnit : Object ( environment classes selectors outputStream )

TranslationUnit new
[
    self := super new.
    environment := Dictionary new.
    classes := Dictionary new.
    selectors := Dictionary new.
    outputStream := CompilerOutputStream on: String new.
]

TranslationUnit outputStream
[
    ^outputStream
]

TranslationUnit level
[
    ^0
]

TranslationUnit note: message
[
"
    message println.
    outputStream
	nextPutAll: '  /* ';
	nextPutAll: message;
	nextPutAll: ' */';
	nl
"
]

TranslationUnit mangleVariable: name
[
    ^'v_' , name
]

TranslationUnit mangleSelector: selector
[
    | in out |
    in := selector readStream.
    out := String new writeStream.
    out nextPutAll: 's_'.
    [in atEnd]
	whileFalse:
	  [ | c |
	    c := in next.
	    c == $:
		ifTrue: [out nextPut: $_]
		ifFalse:
		  [ (c isLetter or: [c isDigit])
			ifTrue: [out nextPut: c]
			ifFalse: [out nextPut: $_; nextPutAll: c asciiValue hex2] ] ].
    ^out contents
]

TranslationUnit mangleSlot: name
[
    ^name
]

TranslationUnit declareGlobal: name
[
    ^environment at: name put: (GlobalVariable withName: name mangledName: (self mangleVariable: name))
]

TranslationUnit declareClass: classNode
[
    | decl |
    (decl := classes at: classNode name ifAbsent: []) isNil
	ifTrue:
	    [decl := classes at: classNode name put: classNode.
	     environment at: classNode name put: (GlobalVariable withName: classNode name mangledName: (self mangleVariable: classNode name))]
	ifFalse:
	    [decl ~= classNode
		 ifTrue:
		     [self error: 'declaration of class ', classNode printString,
			  ' conflicts with previous declaration ', decl printString]].
    ^decl
]

TranslationUnit lookupClass: name
[
    ^classes at: name ifAbsent: [self error: 'class ', name, ' is undeclared']
]

TranslationUnit declareSelector: name
[
    ^selectors at: name ifAbsent: [selectors at: name put: (self mangleSelector: name)]
]

TranslationUnit lookupSelector: name
[
    ^selectors at: name ifAbsent: [self error: 'selector ', name, ' is undeclared']
]

TranslationUnit lookup: name
[
    ^environment at: name ifAbsent: [self error: name, ' is undeclared']
]

TranslationUnit lookupFree: name
[
    ^environment at: name ifAbsent: [self error: name, ' is undeclared']
]

TranslationUnit innerScopeFor: blockNode
[
    ^Scope withParent: self block: blockNode
]

TranslationUnit tempCount
[
    ^0
]

TranslationUnit genDefinitions
[
    (environment asSortedCollection: [:x :y | x name <= y name])
	 do: [ :variable | outputStream nextPutAll: 'static oop '; nextPutAll: variable mangledName; nextPutAll: '= 0;'; nl ].
    selectors asSortedCollection
	 do: [ :selector | outputStream nextPutAll: 'static sel_t '; nextPutAll: selector; nextPutAll: '= 0;'; nl ].
    outputStream nl
]

TranslationUnit genInitialisations
[
    selectors keysAndSortedValuesDo: [ :name :mangled |
	outputStream
	    nextPutAll: '  '; nextPutAll: mangled; nextPutAll: '= _selector("'; nextPutAll: name; nextPutAll: '");';
	    nl ]
]

" ---------------------------------------------------------------- "

Scope : Object ( level environment imports exports parent block exportSelf exportOuter exportNLR minTemp maxTemp nTemps literals blocks )

Scope withParent: parentScope block: blockNode
[
    self := self new.
    level := parentScope level + 1.
    environment := Dictionary new.
    imports := Dictionary new.
    exports := 0.
    parent := parentScope.
    block := blockNode.
    exportSelf := false.
    exportOuter := false.
    exportNLR := false.
    minTemp := maxTemp := nTemps := 0.
    literals := OrderedCollection new.
    blocks := OrderedCollection new.
]

Scope level		[ ^level ]
Scope parent		[ ^parent ]
Scope exports		[ ^exports ]
Scope exportNLR		[ ^exportNLR ]
Scope exportSelf	[ ^exportSelf ]
Scope exportOuter	[ ^exportOuter ]

Scope isMethod		[ ^block isMethod ]

Scope class
[
    ^block isMethod ifTrue: [block class] ifFalse: [parent class]
]

Scope addBlock: blockNode
[
    blocks add: blockNode
]

Scope resetTemps
[
    minTemp := maxTemp := nTemps := 0.
]

Scope tempCount
[
    ^maxTemp
]

Scope newTemp
[
    maxTemp := maxTemp max: (nTemps := nTemps + 1).
    ^nTemps.
]

Scope freeTemp
[
    self assert: [nTemps > minTemp].
    nTemps := nTemps - 1.
]

Scope freeTemps: count
[
    count timesRepeat: [self freeTemp]
]

Scope isStatic
[
    ^(parent exportNLR
	  or: [parent exports > 0
	  or: [parent exportSelf
	  or: [parent exportOuter]]])
	not
]

Scope mangleVariable: name	[ ^parent mangleVariable: name ]
Scope declareLiteral: literal	[ ^literals add: literal ]
Scope declareSelector: name	[ ^parent declareSelector: name ]
Scope declareState: classNode	[ ^classNode declareIn: self ]
Scope declare: name as: node	[ ^environment at: name put: node ]

Scope declareLocal: name
[
    ^environment
	 at:  name
	 put: (LocalVariable
		   withName:    name
		   mangledName: (parent mangleVariable: name)
		   level:       level)
]

Scope lookupClass: name
[
    ^parent lookupClass: name
]

Scope lookup: name
[
    ^environment at: name ifAbsent:
	[imports at: name ifAbsent:
	     [imports at: name put: ((parent lookupFree: name) exportedTo: self)]]
]

Scope lookupFree: name
[
    | variable |
    (variable := environment at: name ifAbsent: []) notNil
	ifTrue:
	    [self assert: [variable isRemoteVariable not].
	     variable isExported ifFalse: [variable exportFrom: self]]
	ifFalse:
	    [variable := parent lookupFree: name].
    ^variable
]

Scope innerScopeFor: blockNode
[
    ^Scope withParent: self block: blockNode
]

Scope nextExportOffset
[
    ^(exports := exports + 1) - 1
]

Scope noteExportOuter
[
    exportOuter := true.
    block isMethod ifFalse: [parent noteExportOuter].
]

Scope noteExportSelf
[
    exportSelf := true.
    block isMethod ifFalse: [parent noteExportSelf].
]

Scope noteExportNLR
[
    exportOuter := true.
    block isMethod
	ifTrue: [exportNLR := true]
	ifFalse: [parent noteExportNLR].
]

Scope genDefinitions: unit
[
    literals do: [:literal | literal genDefinition: unit].
    blocks   do: [:block   | block   genDefinition: unit].
]

Scope genImplementations: unit
[
    blocks do: [:block | block genImplementation: unit].
]

Scope genInitialisations: unit
[
    literals do: [:literal | literal genInitialisation: unit].
    blocks   do: [:block   | block   genInitialisation: unit].
]