"Exercise: Forth"

forth: instructions
"Implement an evaluator for a very simple subset of Forth.
    Forth is a stack-based programming language. Implement a very basic evaluator for a small subset of Forth.
    Your evaluator has to support the following words:
    - `+`, `-`, `*`, `/` (integer arithmetic)
    - `DUP`, `DROP`, `SWAP`, `OVER` (stack manipulation)
    Your evaluator also has to support defining new words using the customary syntax: `: word-name definition ;`.
    To keep things simple the only data type you need to support is signed integers of at least 16 bits size.
    You should use the following rules for the syntax: a number is a sequence of one or more (ASCII) digits, a word is a sequence of one or more letters, digits, symbols or punctuation that is not a number.
    (Forth probably uses slightly different rules, but this is close enough.)
    Words are case-insensitive."
"(self new forth: #('1 2 3 4 5' )) >>> #(1 2 3 4 5)"
"(self new forth: #('1 2 +' )) >>> #(3)"
| stack vocabulary currentDefinition isSignedInteger checkStackHas makeBlockWord makeSequenceWord executeWord lookupWord literalWord startCompilation finishCompilation compileName compileWord processWord |
	stack := OrderedCollection new.
	vocabulary := Dictionary new.
	currentDefinition := nil.

	isSignedInteger := [ :s |
		                   s notEmpty and: [
				                   (s first = '+' and: [
					                    s allButFirst allSatisfy: [ :ch | ch isDigit ] ])
					                   or: [ s allSatisfy: [ :ch | ch isDigit ] ] ] ].

	checkStackHas := [ :n |
		                 stack size < n ifTrue: [
				                 stack isEmpty
					                 ifTrue: [ self error: 'empty stack' ]
					                 ifFalse: [ self error: 'stack underflow' ] ] ].

	makeBlockWord := [ :blk |
		                 Dictionary new
			                 at: #block put: blk;
			                 yourself ].

	makeSequenceWord := [ :seq |
		                    Dictionary new
			                    at: #definition put: seq asArray;
			                    yourself ].

	executeWord := [ :word |
		               | blk def |
		               blk := word at: #block ifAbsent: [ nil ].
		               def := word at: #definition ifAbsent: [ nil ].
		               blk
			               ifNotNil: [ blk value ]
			               ifNil: [
			               def do: [ :each | executeWord value: each ] ] ].

	lookupWord := [ :name |
		              vocabulary
			              at: name
			              ifAbsent: [
			              self error: 'undefined operation: ' , name ] ].

	literalWord := [ :string |
		               | value |
		               value := string asInteger.
		               makeBlockWord value: [ stack addLast: value ] ].

	startCompilation := [ currentDefinition := OrderedCollection new ].

	finishCompilation := [
		                     | name def newWord |
		                     name := currentDefinition first.
		                     def := currentDefinition allButFirst asArray.
		                     newWord := makeSequenceWord value: def.
		                     vocabulary at: name put: newWord.
		                     currentDefinition := nil ].

	compileName := [ :token |
		               (isSignedInteger value: token) ifTrue: [
			               self error: 'illegal operation' ].
		               currentDefinition add: token ].

	compileWord := [ :token |
		               currentDefinition isEmpty
			               ifTrue: [ compileName value: token ]
			               ifFalse: [
					               (isSignedInteger value: token)
						               ifTrue: [
						               currentDefinition add: (literalWord value: token) ]
						               ifFalse: [
						               currentDefinition add: (lookupWord value: token) ] ] ].

	processWord := [ :raw |
		               | token lower |
		               raw isEmpty ifFalse: [
				               token := raw.
				               lower := token asLowercase.
				               currentDefinition
					               ifNil: [
							               lower = ':'
								               ifTrue: [ startCompilation value ]
								               ifFalse: [
										               (isSignedInteger value: token)
											               ifTrue: [ stack addLast: token asInteger ]
											               ifFalse: [
											               executeWord value: (lookupWord value: lower) ] ] ]
					               ifNotNil: [
							               token = ';'
								               ifTrue: [ finishCompilation value ]
								               ifFalse: [ compileWord value: lower ] ] ] ].

	vocabulary at: '+' put: (makeBlockWord value: [
				 | a b |
				 checkStackHas value: 2.
				 a := stack removeLast.
				 b := stack removeLast.
				 stack addLast: b + a ]).
	vocabulary at: '-' put: (makeBlockWord value: [
				 | a b |
				 checkStackHas value: 2.
				 a := stack removeLast.
				 b := stack removeLast.
				 stack addLast: b - a ]).
	vocabulary at: '*' put: (makeBlockWord value: [
				 | a b |
				 checkStackHas value: 2.
				 a := stack removeLast.
				 b := stack removeLast.
				 stack addLast: b * a ]).
	vocabulary at: '/' put: (makeBlockWord value: [
				 | a b |
				 checkStackHas value: 2.
				 a := stack removeLast.
				 b := stack removeLast.
				 a = 0 ifTrue: [ self error: 'divide by zero' ].
				 stack addLast: b // a ]).
	vocabulary at: 'dup' put: (makeBlockWord value: [
				 checkStackHas value: 1.
				 stack addLast: stack last ]).
	vocabulary at: 'drop' put: (makeBlockWord value: [
				 checkStackHas value: 1.
				 stack removeLast ]).
	vocabulary at: 'swap' put: (makeBlockWord value: [
				 | a b |
				 checkStackHas value: 2.
				 a := stack removeLast.
				 b := stack removeLast.
				 stack
					 addLast: a;
					 addLast: b ]).
	vocabulary at: 'over' put: (makeBlockWord value: [
				 checkStackHas value: 2.
				 stack addLast: (stack at: stack size - 1) ]).

	instructions do: [ :line |
		(line findTokens: ' ') do: [ :tok | processWord value: tok ] ].

	^ stack asArray


"Tests"
testForth
| result |

  result := task forth: #('1 2 3 4 5').
  self assert: result equals: #(1 2 3 4 5).

  result := task forth: #('1 2 +').
  self assert: result equals: #(3).

  self
    should: [ result := task forth: #('+') ]
    raise: Error.

  self
    should: [ result := task forth: #('1 +') ]
    raise: Error.

  result := task forth: #('3 4 -').
  self assert: result equals: #(-1).

  self
    should: [ result := task forth: #('-') ]
    raise: Error.

  self
    should: [ result := task forth: #('1 -') ]
    raise: Error.

  result := task forth: #('2 4 *').
  self assert: result equals: #(8).

  self
    should: [ result := task forth: #('*') ]
    raise: Error.

  self
    should: [ result := task forth: #('1 *') ]
    raise: Error.

  result := task forth: #('12 3 /').
  self assert: result equals: #(4).

  result := task forth: #('8 3 /').
  self assert: result equals: #(2).

  self
    should: [ result := task forth: #('4 0 /') ]
    raise: Error.

  self
    should: [ result := task forth: #('/') ]
    raise: Error.

  self
    should: [ result := task forth: #('1 /') ]
    raise: Error.

  result := task forth: #('1 2 + 4 -').
  self assert: result equals: #(-1).

  result := task forth: #('2 4 * 3 /').
  self assert: result equals: #(2).

  result := task forth: #('1 dup').
  self assert: result equals: #(1 1).

  result := task forth: #('1 2 dup').
  self assert: result equals: #(1 2 2).

  self
    should: [ result := task forth: #('dup') ]
    raise: Error.

  result := task forth: #('1 drop').
  self assert: result equals: #().

  result := task forth: #('1 2 drop').
  self assert: result equals: #(1).

  self
    should: [ result := task forth: #('drop') ]
    raise: Error.

  result := task forth: #('1 2 swap').
  self assert: result equals: #(2 1).

  result := task forth: #('1 2 3 swap').
  self assert: result equals: #(1 3 2).

  self
    should: [ result := task forth: #('swap') ]
    raise: Error.

  self
    should: [ result := task forth: #('1 swap') ]
    raise: Error.

  result := task forth: #('1 2 over').
  self assert: result equals: #(1 2 1).

  result := task forth: #('1 2 3 over').
  self assert: result equals: #(1 2 3 2).

  self
    should: [ result := task forth: #('over') ]
    raise: Error.

  self
    should: [ result := task forth: #('1 over') ]
    raise: Error.

  result := task forth: #(': dup-twice dup dup ;' '1 dup-twice').
  self assert: result equals: #(1 1 1).

  result := task forth: #(': countup 1 2 3 ;' 'countup').
  self assert: result equals: #(1 2 3).

  result := task forth: #(': foo dup ;' ': foo dup dup ;' '1 foo').
  self assert: result equals: #(1 1 1).

  result := task forth: #(': swap dup ;' '1 swap').
  self assert: result equals: #(1 1).

  result := task forth: #(': + * ;' '3 4 +').
  self assert: result equals: #(12).

  result := task forth: #(': foo 5 ;' ': bar foo ;' ': foo 6 ;' 'bar foo').
  self assert: result equals: #(5 6).

  result := task forth: #(': foo 10 ;' ': foo foo 1 + ;' 'foo').
  self assert: result equals: #(11).

  self
    should: [ result := task forth: #(': 1 2 ;') ]
    raise: Error.

  self
    should: [ result := task forth: #('foo') ]
    raise: Error.

  result := task forth: #('1 DUP Dup dup').
  self assert: result equals: #(1 1 1 1).

  result := task forth: #('1 2 3 4 DROP Drop drop').
  self assert: result equals: #(1).

  result := task forth: #('1 2 SWAP 3 Swap 4 swap').
  self assert: result equals: #(2 3 4 1).

  result := task forth: #('1 2 OVER Over over').
  self assert: result equals: #(1 2 1 2 1).

  result := task forth: #(': foo dup ;' '1 FOO Foo foo').
  self assert: result equals: #(1 1 1 1).

  result := task forth: #(': SWAP DUP Dup dup ;' '1 swap').
  self assert: result equals: #(1 1 1 1)