" -*- Smalltalk -*- " Scanner : Object ( charTable charEscapes input c token type includeStack searchPaths prevHash ) Scanner new [ self := super new initialise. ] Scanner initialise [ (charTable := Array new: 256) atAllPut: #xIllegal; atAll: '0123456789' asByteArray put: #xDigit; atAll: 'abcdefghijklmnopqrstuvwxyz' asByteArray put: #xLetter; atAll: 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' asByteArray put: #xLetter; atAll: '_' asByteArray put: #xLetter; atAll: '~!@%&*=\\?/><,|^' asByteArray put: #xBinary; atAll: '+-' asByteArray put: #xSign; atAll: '#[];()}' asByteArray put: #xPunctuator; atAll: ' \t\n\v\f' asByteArray put: #xSpace; at: $. asciiValue put: #xDot; at: $: asciiValue put: #xColon; at: ${ asciiValue put: #xBrace; at: $$ asciiValue put: #xCharacter; at: $' asciiValue put: #xString; at: $" asciiValue put: #xComment. (charEscapes := IdentityDictionary new) at: $a put: $\a; "bel" at: $b put: $\b; "bs" at: $e put: $\e; "esc" at: $f put: $\f; "ff" at: $n put: $\n; "nl" at: $r put: $\r; "cr" at: $t put: $\t; "ht" at: $v put: $\v. "vt" includeStack := OrderedCollection new. prevHash := false. ] Scanner next [ [((c := input next) isNil and: [includeStack notEmpty])] whileTrue: [input := includeStack removeLast]. ^c ] Scanner findFile: pathName [ | file | file := String readFromFileNamed: pathName , '.st' ifError: []. file notNil ifTrue: [^file]. searchPaths do: [:dir | file := String readFromFileNamed: dir, '/', pathName, '.st' ifError: []. file notNil ifTrue: [^file]]. self error: pathName, '.st: ', Smalltalk osErrorString. ] Scanner import: pathName [ " ('<', pathName, '>') println. " includeStack add: input. input := (self findFile: pathName) readStream. self next. ] Scanner on: aStringOrStream [ self := self new initialise. input := aStringOrStream readStream. self next. token := String new writeStream. ] Scanner scan [ type := nil. [c notNil and: [type isNil]] whileTrue: [token resetToStart. [c notNil and: [(charTable at: c value) == #xSpace]] whileTrue: [self next]. c notNil ifTrue: [self perform: (charTable at: c value)]]. prevHash := #'#' == type. ^type ] Scanner xSign [ ^input peek isDigit ifTrue: [self xDigit] ifFalse: [self xBinary] ] Scanner xDot [ token nextPut: c. self next. (c = $. and: [input peek = $.]) ifTrue: [self next; next. type := #ellipsis] ifFalse: [type := #'.']. ^type ] Scanner xColon [ token nextPut: c. self next. c == $= ifFalse: [^type := token contents asSymbol]. token nextPut: c. self next. ^type := #assign ] Scanner xPunctuator [ token nextPut: c. type := c asString asSymbol. self next. ^type ] Scanner xBinary [ token nextPut: c. "eat + or -, if present (see xSign)" self next. [c notNil and: [(charTable at: c value) == #xBinary]] whileTrue: [ token nextPut: c. self next ]. ^type := #binary ] Scanner xLetter [ | keywords | keywords := 0. [c notNil and: [(charTable at: c value) == #xLetter]] whileTrue: [[c notNil and: [(charTable at: c value) == #xLetter or: [(charTable at: c value) == #xDigit]]] whileTrue: [token nextPut: c. self next]. c == $: ifTrue: [token nextPut: c. self next. keywords := keywords + 1]]. keywords == 0 ifTrue: [type := #identifier] ifFalse: [keywords == 1 ifTrue: [type := #keyword] ifFalse: [type := #keywords]]. ^type ] Scanner xDigit [ token nextPut: c. "eat sign, if present (see xSign)" self next. [c notNil and: [(charTable at: c value) == #xLetter or: [(charTable at: c value) == #xDigit]]] whileTrue: [ token nextPut: c. self next ]. ^type := #integer ] Scanner scanOctal [ | char | char := c digitValue. 2 timesRepeat: [self next. c isNil ifTrue: [self error: 'EOF while scanning octal character escape']. (c between: $0 and: $7) ifFalse: [self error: 'illegal digit in octal character escape']. char := char * 8 + c digitValue]. ^Character value: char ] Scanner scanEscape [ | char | c isNil ifTrue: [self error: 'EOF while scanning escaped character']. char := charEscapes at: c ifAbsent: [(c between: $0 and: $7) ifTrue: [self scanOctal] ifFalse: [c]]. self next. ^char ] Scanner scanCharacter [ | d | d := c. self next. ^d == $\\ ifTrue: [self scanEscape] ifFalse: [d] ] Scanner xIllegal [ self error: 'illegal character: ', c printString ] Scanner xCharacter [ self next. c isNil ifTrue: [self error: 'EOF in character literal']. token nextPut: self scanCharacter. ^type := #character ] Scanner xString [ [c == $'] whileTrue: [self next. [c notNil and: [c ~~ $']] whileTrue: [token nextPut: self scanCharacter]. c isNil ifTrue: [self error: 'EOF in string literal']. (self next) == $' ifTrue: [token nextPut: c]]. ^type := #string ] Scanner xComment [ self next. [c notNil and: [c ~~ $"]] whileTrue: [self next]. self next. ^type := nil ] Scanner xBrace [ | nest | prevHash ifTrue: [self next. ^type := #'{']. nest := 1. [nest > 0] whileTrue: [self next. [c notNil and: [c ~~ $}]] whileTrue: [token nextPut: c. c == ${ ifTrue: [nest := nest + 1]. self next]. c isNil ifTrue: [self error: 'EOF in external code']. (nest := nest - 1) > 0 ifTrue: [token nextPut: c]]. self next. ^type := #extern ] " ---------------------------------------------------------------- " Parser : Scanner () Parser on: aStringOrStream [ self := super on: aStringOrStream. self scan ] Parser note: marker [ " marker print. ' ' print. type print. ' -> ' print. token contents println. " ] Parser parseByteArray [ | elements | elements := OrderedCollection new. [type == #']'] whileFalse: [type == #integer ifFalse: [self error: 'ByteArrays can only contain integers']. ((elements add: (IntegerNode fromString: token contents)) value between: 0 and: 255) ifFalse: [self error: 'ByteArray element not between 0 and 255']. self scan]. self scan. ^ByteArrayNode withElements: elements ] Parser parseWordArray [ | elements | elements := OrderedCollection new. [type == #'}'] whileFalse: [self note: 'PARSE_WORD_ARRAY-1'. type == #integer ifFalse: [self error: 'WordArrays can only contain integers']. elements add: (IntegerNode fromString: token contents). self scan]. self scan. ^WordArrayNode withElements: elements ] Parser parseArrayLiteral [ | node | (node := self parseLiteralP) notNil ifTrue: [^node]. (#(identifier binary keyword keywords) includes: type) ifTrue: [node := (SymbolNode fromString: token contents). self scan. ^node]. type == #'(' ifTrue: [^self scan; parseArray]. type == #'{' ifTrue: [^self scan; parseWordArray]. type == #'[' ifTrue: [^self scan; parseByteArray]. ^nil ] Parser parseArray [ | elements element | elements := OrderedCollection new. [(element := self parseArrayLiteral) notNil] whileTrue: [elements add: element]. self note: 'ARRAY-1'. type == #')' ifFalse: [self error: ') expected at end of literal Array']. self scan. ^ArrayNode withElements: elements ] Parser parseLiteralP [ self note: 'LITERAL-1'. type == #integer ifTrue: [| node | node := IntegerNode fromString: token contents. self scan. ^node]. type == #character ifTrue: [| node | node := CharacterNode withValue: token contents first. self scan. ^node]. type == #string ifTrue: [| node | node := StringNode fromString: token contents. self scan. ^node]. self note: 'LITERAL-2'. type == #'#' ifFalse: [^nil]. self scan. self note: 'LITERAL-3'. (#(identifier binary keyword keywords string) includes: type) ifTrue: [| node | node := SymbolNode fromString: token contents. self scan. ^node]. self note: 'LITERAL-4'. type == #'(' ifTrue: [^self scan; parseArray]. type == #'{' ifTrue: [^self scan; parseWordArray]. type == #'[' ifTrue: [^self scan; parseByteArray]. self error: 'illegal literal following #' ] Parser parsePrimary [ | node | self note: 'PRIMARY-1'. type == #identifier ifTrue: [ node := VariableNode withName: token contents. self scan. ^node ]. type == #'(' ifTrue: [ node := self scan; parseExpression. type == #')' ifFalse: [self error: ') expected']. self scan. ^node ]. type == #'[' ifTrue: [ ^self scan; parseBlock ]. self note: 'PRIMARY-2'. node := self parseLiteralP. self note: 'PRIMARY-3'. node notNil ifTrue: [^node]. self note: 'PRIMARY-ABORT'. self error: 'parsePrimary: not implemented' ] Parser parseUnary [ | node | node := self parsePrimary. [type == #identifier] whileTrue: [ node := SendNode withReceiver: node selector: token contents. self scan ]. ^node ] Parser parseBinary [ | node | node := self parseUnary. [type == #binary] whileTrue: [ node := SendNode withReceiver: node selector: token contents. node addArgument: (self scan; parseUnary) ]. ^node ] Parser parseExpression [ | node | self note: 'EXPR-1'. node := self parseBinary. self note: 'EXPR-2'. type == #keyword ifTrue: [node := SendNode withReceiver: node selector: token contents. node addArgument: (self scan; parseBinary). self note: 'EXPR-3'. [type == #keyword or: [type == #':']] whileTrue: [type == #keyword ifTrue: [node addKeyword: token contents]. node addArgument: (self scan; parseBinary). self note: 'EXPR-4'. ]]. (type == #assign and: [node isVariableNode]) ifTrue: [^AssignmentNode withVariable: node value: (self scan; parseExpression)]. (type == #';' and: [node isSendNode not]) ifTrue: [self error: 'cascade does not follow a message send']. [type == #';'] whileTrue: [| cascade | cascade := SendNode withReceiver: nil selector: ''. self scan. type == #keyword ifTrue: [[type == #keyword or: [type == #':']] whileTrue: [type == #keyword ifTrue: [cascade addKeyword: token contents]. cascade addArgument: (self scan; parseBinary)]] ifFalse: [type == #binary ifTrue: [cascade addKeyword: token contents; addArgument: (self scan; parseUnary)] ifFalse: [type == #identifier ifTrue: [cascade addKeyword: token contents. self scan] ifFalse: [self error: 'syntax error in cascade']]]. node addCascade: cascade]. ^node ] Parser parseTemporaries: block [ [type == #identifier] whileTrue: [block addTemporary: token contents. self scan]. (type == #binary and: [token contents = '|']) ifFalse: [self error: 'identifier or | expected in temporaries']. self scan. ^block ] Parser parseSequence: block [ self note: 'SEQ-1'. (type == #binary and: [token contents = '|']) ifTrue: [self scan; parseTemporaries: block]. self note: 'SEQ-2'. [type == #']'] whileFalse: [self note: 'SEQ-3'. block addStatement: (type == #extern ifTrue: [self parseExtern] ifFalse: [((type == #binary and: [token contents = '^']) ifTrue: [ReturnNode withValue: (self scan; parseExpression)] ifFalse: [self parseExpression])]). (type == #'.' or: [type == #']']) ifFalse: [self error: '. or ] expected in block']. [type == #'.'] whileTrue: [self scan]. (block lastStatement isReturnNode and: [type ~~ #']']) ifTrue: [self error: '] expected at end of block'] ]. self note: 'SEQ-4'. self scan. self note: 'SEQ-5'. ^block ] Parser parseBlockParameters: block [ [type == #':'] whileTrue: [ self scan. type == #identifier ifFalse: [self error: 'parameter name expected']. block addArgument: token contents. self scan ]. (type == #binary and: [token contents = '||']) ifTrue: [token resetToStart; nextPut: $|] "convert to temp delimiter" ifFalse: [(type == #binary and: [token contents = '|']) ifFalse: [self error: '| expected at end of block parameters']. self scan] ] Parser parseBlock [ | block | block := BlockNode new. type == #':' ifTrue: [self parseBlockParameters: block]. ^self parseSequence: block ] Parser parseExec [ ^self scan; parseSequence: ExecNode new. ] Parser parseExtern [ | text node | text := token contents. node := nil. (text beginsWith: ' import ') ifTrue: [self import: (text tokenised: ' ') second] ifFalse: [node := ExternNode withCode: text]. self scan. ^node ] Parser parseClass: name [ | base slots | base := nil. slots := OrderedCollection new. type == #':' ifTrue: [ self scan. type == #identifier ifFalse: [self error: 'base prototype name expected in declaration']. base := token contents. self scan ]. type == #'(' ifFalse: [self error: 'slot names expected in prototype declaration']. self scan. [type == #identifier] whileTrue: [slots add: token contents. self scan]. type == #')' ifFalse: [self error: ') expected after slot names in prototype declaration']. self scan. ^ClassNode withName: name base: base slots: slots ] Parser parseMethod: className [ | selector arguments node | self note: 'METHOD-1'. selector := ''. arguments := OrderedCollection new. type == #keyword ifTrue: [[type == #keyword] whileTrue: [selector := selector , token contents. self scan. type == #identifier ifFalse: [self error: 'missing parameter name']. arguments add: token contents. self scan]] ifFalse: [type == #binary ifTrue: [selector := selector , token contents. self scan. type == #identifier ifFalse: [self error: 'missing parameter name']. arguments add: token contents. self scan] ifFalse: [type == #identifier ifTrue: [selector := token contents. self scan] ifFalse: [self error: 'method pattern expected'] ] ]. node := MethodNode withClass: className selector: selector arguments: arguments. self note: 'METHOD-2'. type == #ellipsis ifTrue: [node beVariadic. self scan]. type == #'[' ifTrue: [self scan; parseSequence: node] ifFalse: [type == #extern ifTrue: [node external: self parseExtern] ifFalse: [self error: 'method body expected']]. self note: 'METHOD-3'. ^node ] Parser parseDeclaration [ type == #extern ifTrue: [^self parseExtern]. type == #'[' ifTrue: [^self parseExec]. type == #identifier ifTrue: [| name | name := token contents. self scan. ^(type == #':' or: [type == #'(']) ifTrue: [self parseClass: name] ifFalse: [self parseMethod: name]]. self error: 'syntax error' ] Parser parse [ [type notNil] whileTrue: [| node | node := self parseDeclaration. node notNil ifTrue: [self encode: node forTopLevel]] ] " ---------------------------------------------------------------- " Compiler : Parser ( program translationUnit ) Compiler new [ self := self _clone. program := OrderedCollection new. translationUnit := TranslationUnit new. ] Compiler compile: aStringOrStream to: outputPath searching: paths [ self := self on: aStringOrStream. searchPaths := paths. translationUnit := TranslationUnit new. translationUnit declareGlobal: 'nil'; declareGlobal: 'true'; declareGlobal: 'false'. self parse. self assert: [input atEnd]. self assert: [includeStack isEmpty]. translationUnit outputStream gen: '#include "idst.h"'; nl; nl. program do: [:stmt | translationUnit note: ('declare: ', stmt printString). stmt genDeclarationIn: translationUnit]. translationUnit genDefinitions. program do: [:stmt | translationUnit note: ('implement: ', stmt printString). stmt genImplementationIn: translationUnit]. translationUnit outputStream nextPutAll: 'int main(int argc, char **argv)' ; nl; nextPutAll: '{' ; nl; nextPutAll: ' _idst_initialise(argc, argv);' ; nl; nextPutAll: ' oop self= 0;' ; nl; nextPutAll: ' (void)self;' ; nl. translationUnit genInitialisations. program do: [:stmt | translationUnit note: ('initialise: ', stmt printString). stmt genInitialisationIn: translationUnit]. translationUnit outputStream nextPutAll: ' return 0;' ; nl; nextPutAll: '}' ; nl. outputPath isNil ifTrue: [translationUnit outputStream contents print] ifFalse: [translationUnit outputStream contents writeToFileNamed: outputPath]. " (Smalltalk bytesFree printString, ' bytes used; ') print. (Smalltalk garbageCollect bytesFree printString, ' after GC') println. " ] Compiler encode: topLevelNode [ translationUnit note: ('encode: ', topLevelNode debugName). program add: topLevelNode. topLevelNode encodeIn: translationUnit ]