# HG changeset patch
# User Michael Pavone <pavone@retrodev.com>
# Date 1406451049 25200
# Node ID 6d2cbad5fca9c064b329e75286c1493e4f4b40c9
# Parent  f1453e8970ca83d4a5ecfdba1aad790c17f05888
WIP version of a compiler for the LamCo GCC

diff -r f1453e8970ca -r 6d2cbad5fca9 code/gcc.tp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/code/gcc.tp	Sun Jul 27 01:50:49 2014 -0700
@@ -0,0 +1,684 @@
+#{
+	new <- :code {
+		consUsage <- 0
+		dataStack <- []
+		controlStack <- 0
+		stackSize <- 0
+		pc <- 0
+		
+		error <- :_msg {
+			#{
+				msg <- { _msg }
+				isInteger? <- { false }
+				isError? <- { true }
+				isClosure? <- { false }
+				isEnvironment? <- { false }
+				isCons? <- { false }
+				isJoin? <- { false }
+				isStop? <- { false }
+				tag <- { "ERROR" }
+			}
+		}
+		_dummy <- #{
+			isInteger? <- { false }
+			isError? <- { false }
+			isClosure? <- { false }
+			isEnvironment? <- { false }
+			isCons? <- { false }
+			isJoin? <- { false }
+			isStop? <- { false }
+			tag <- { "DUMMY" }
+		}
+		
+		getTag <- :val {
+			if: (val isInteger?) {
+				"INTEGER"
+			} else: {
+				val tag
+			}
+		}
+		
+		push <- :val {
+			dataStack <- val | dataStack
+			stackSize <- stackSize + 1
+		}
+		
+		pop <- {
+			if: (dataStack empty?) {
+				error: "datastack empty"
+			} else: {
+				ret <- dataStack value
+				dataStack <- dataStack tail
+				stackSize <- stackSize - 1
+				ret
+			}
+		}
+		
+		_curEnv <- #{
+			ld <- :envNum slotNum {
+				error: "invalid environment"
+			}
+			st <- :envNum slotNum val {
+				error: "invalid environment"
+			}
+			rapLoad <- {
+				error: "invalid environment"
+			}
+			isError? <- { false }
+			isEnvironment? <- { true }
+			isJoin? <- { false }
+			isReturn? <- { false }
+			isStop? <- { false }
+			tag <- { "TOPENV" }
+		}
+		
+		cons <- :_car _cdr {
+			consUsage <- consUsage + 1
+			#{
+				car <- { _car }
+				cdr <- { _cdr }
+				isInteger? <- { false }
+				isError? <- { false }
+				isClosure? <- { false }
+				isEnvironment? <- { false }
+				isCons? <- { true }
+				isJoin? <- { false }
+				tag <- { "CONS" }
+			}
+		}
+		
+				
+		env:dummy? <- :_size _parent :_dummy? {
+			consUsage <- consUsage + 1 + _size / 2
+			_arr <- #[]
+			_hasError <- false
+			_error <- false
+			if: _size > 0 {
+				_arr resize: _size
+				i <- 0
+				while: { i < _size } do: {
+					_arr append: 0
+					i <- i + 1
+				}
+				
+				if: (not: _dummy?) {
+					i <- _size - 1
+					while: { (not: _hasError) && i >= 0 } do: {
+						val <- pop:
+						if: ((not: (val isInteger?)) && (val isError?)) {
+							_error <- error: "data stack empty while populating env at slot " . i . " of " . _size
+							_hasError <- true
+						} else: {
+							_arr set: i val
+							i <- i - 1
+						}
+					}
+				}
+			}
+			if: _hasError {
+				_error
+			} else: {
+				#{
+					!= <- :other {
+						//TODO: implement me properly	
+						tag != (other tag)
+					}
+					ld <- :envNum slotNum {
+						if: envNum > 0 {
+							_parent ld: envNum - 1 slotNum
+						} else: {
+							if: _dummy? {
+								error: "attempt to ld from dummy env"
+							} else: {
+								if: slotNum < _size {
+									_arr get: slotNum
+								} else: {
+									error: "attempt to access invalid slot " . slotNum . " in env of size " . _size
+								}
+							}
+						}
+					}
+					st <- :envNum slotNum val {
+						if: envNum > 0 {
+							_parent st: envNum - 1 slotNum val
+						} else: {
+							if: _dummy? {
+								error: "attempt to st to dummy env"
+							} else: {
+								if: slotNum < _size {
+									_arr set: slotNum val
+									_dummy
+								} else: {
+									error: "attempt to access invalid slot " . slotNum . " in env of size " . _size
+								}
+							}
+						}
+					}
+					rapLoad <- :rapSize {
+						if: _dummy? {
+							if: rapSize != _size {
+								_hasError <- true
+								_error <- error: "frame size mismatch for RAP instruction"
+							} else: {
+								i <- 0
+								i <- _size - 1
+								while: { (not: _hasError) && i >= 0 } do: {
+									val <- pop:
+									if: ((not: (val isInteger?)) && (val isError?)) {
+										_error <- error: "data stack empty while populating env at slot " . i . " of " . _size
+										_hasError <- true
+									} else: {
+										_arr set: i val
+										i <- i - 1
+									}
+								}
+								_dummy? <- false
+							}
+						} else: {
+							_hasError <- true
+							_error <- error: "attempt to RAP into non-dummy environment"
+						}
+						if: _hasError { _error } else: { _dummy }
+					}
+					isError? <- { false }
+					isEnvironment? <- { true }
+					isJoin? <- { false }
+					isReturn? <- { false }
+					isStop? <- { false }
+					tag <- { "ENVIRONMENT" }
+				}
+			}
+		}
+		
+		
+		closure <- :_address {
+			_env <- _curEnv
+			#{
+				address <- { _address }
+				env <- { _env }
+				isInteger? <- { false }
+				isError? <- { false }
+				isClosure? <- { true }
+				isEnvironment? <- { false }
+				isCons? <- { false }
+				isJoin? <- { false }
+				tag <- { "CLOSURE" }
+			}
+		}
+		
+		join <- :_address {
+			#{
+				address <- { _address }
+				isError? <- { false }
+				isEnvironment? <- { false }
+				isJoin? <- { true }
+				isReturn? <- { false }
+				isStop? <- { false }
+				tag <- { "JOIN" }
+			}
+		}
+		return <- :_address {
+			#{
+				address <- { _address }
+				isError? <- { false }
+				isEnvironment? <- { false }
+				isJoin? <- { false }
+				isReturn? <- { true }
+				isStop? <- { false }
+				tag <- { "RETURN" }
+			}
+		}
+		stop <- #{
+			isError? <- { false }
+			isEnvironment? <- { false }
+			isJoin? <- { false }
+			isReturn? <- { false }
+			isStop? <- { true }
+			tag <- { "STOP" }
+		}
+		
+		_instConstructors <- dict hash
+		_instConstructors set: "LDC" :args {
+			_const <- args get: 0
+			{
+				push: _const
+				_dummy
+			}
+		}
+		_instConstructors set: "LD" :args {
+			_env <- args get: 0
+			_slot <- args get: 1
+			{
+				val <- _curEnv ld: _env _slot
+				if: (not: (val isInteger?)) && (val isError?) {
+					val
+				} else: {
+					push: val
+					_dummy
+				}
+			}
+		}
+		_instConstructors set: "ST" :args {
+			_env <- args get: 0
+			_slot <- args get: 1
+			{
+				val <- pop:
+				if: (not: (val isInteger?)) && (val isError?) {
+					val
+				} else: {
+					_curEnv st: _env _slot val
+				}
+			}
+		}
+		
+		binaryConstruct <- macro: :name op a b{
+			quote: (_instConstructors set: name :args {
+				{
+					a <- pop:
+					if: (a isInteger?) {
+						b <- pop:
+						if: (b isInteger?) {
+							push: op
+							_dummy
+						} else: {
+							if: (b isError?) {	
+								b
+							} else: {
+								error: "Got wrong type for left param of " . name . " instruction"
+							}
+						}
+					} else: {
+						if: (a isError?) {
+							a
+						} else: {
+							error: "Got wrong type for right param of " . name . " instruction"
+						}
+					}
+				}
+			})
+		}
+		
+		binaryConstruct: "ADD" b + a a b
+		binaryConstruct: "SUB" b - a a b
+		binaryConstruct: "MUL" b * a a b
+		binaryConstruct: "DIV" b / a a b
+		binaryConstruct: "CEQ" (if: b = a { 1 } else: { 0 }) a b
+		binaryConstruct: "CGT" (if: b > a { 1 } else: { 0 }) a b
+		binaryConstruct: "CGTE" (if: b >= a { 1 } else: { 0 }) a b
+		_instConstructors set: "ATOM" :args {
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					push: 1
+					_dummy
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						push: 0
+						_dummy
+					}
+				}
+			}
+		}
+		_instConstructors set: "CONS" :args {
+			{
+				a <- pop:
+				if: ((not: (a isInteger?)) && (a isError?)) {
+					a
+				} else: {
+					b <- pop:
+					if: ((not: (b isInteger?)) && (b isError?)) {
+						b
+					} else: {
+						push: (cons: b a)
+						_dummy
+					}
+				}
+			}
+		}
+		_instConstructors set: "CAR" :args {
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					error: "CAR expects CONS cell, got INTEGER instead"
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						if: (val isCons?) {
+							push: (val car)
+							_dummy
+						} else: {
+							error: "CAR expects CONS cell, got " . (val tag) . " instead"
+						}
+					}
+				}
+			}
+		}
+		_instConstructors set: "CDR" :args {
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					error: "CDR expects CONS cell, got integer instead"
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						if: (val isCons?) {
+							push: (val cdr)
+							_dummy
+						} else: {
+							error: "CDR expects CONS cell, got " . (val tag) . " instead"
+						}
+					}
+				}
+			}
+		}
+		_instConstructors set: "SEL" :args {
+			_t <- args get: 0
+			_f <- args get: 1
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					controlStack <- cons: (join: pc) controlStack
+					pc <- if: (val != 0) { _t } else: { _f }
+					_dummy
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						error: "SEL expects INTEGER, got " . (val tag) . " instead"
+					}
+				}
+			}
+		}
+		_instConstructors set: "TSEL" :args {
+			_t <- args get: 0
+			_f <- args get: 1
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					pc <- if: (val != 0) { _t } else: { _f }
+					_dummy
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						error: "TSEL expects INTEGER, got " . (val tag) . " instead"
+					}
+				}
+			}
+		}
+		_instConstructors set: "JOIN" :args {
+			{
+				if: (controlStack isInteger?) {
+					error: "JOIN tried to pull value from empty control stack"
+				} else: {
+					val <- controlStack car
+					controlStack <- controlStack cdr
+					if: (val isJoin?) {
+						pc <- val address
+						_dummy
+					} else: {
+						error: "JOIN expects JOIN cell, got " . (val tag) . " instead"
+					}
+				}
+			}
+		}
+		_instConstructors set: "LDF" :args {
+			_address <- args get: 0
+			{
+				push: (closure: _address)
+				_dummy
+			}
+		}
+		_instConstructors set: "AP" :args {
+			_envSize <- args get: 0
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					error: "AP expects CLOSURE, got INTEGER instead"
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						if: (val isClosure?) {
+							frame <- env: _envSize (val env) dummy?: false
+							if: (frame isError?) {
+								frame
+							} else: {
+								controlStack <- cons: (return: pc+1) (cons: _curEnv controlStack)
+								_curEnv <- frame
+								pc <- val address
+								_dummy
+							}
+						} else: {
+							error: "AP expects CLOSURE, got " . (val tag) . " instead"
+						}
+					}
+				}
+			}
+		}
+		_instConstructors set: "TAP" :args {
+			_envSize <- args get: 0
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					error: "TAP expects CLOSURE, got INTEGER instead"
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						if: (val isClosure?) {
+							frame <- env: _envSize (val env) dummy?: false
+							if: (frame isError?) {
+								frame
+							} else: {
+								_curEnv <- frame
+								pc <- val address
+								_dummy
+							}
+						} else: {
+							error: "TAP expects CLOSURE, got " . (val tag) . " instead"
+						}
+					}
+				}
+			}
+		}
+		_instConstructors set: "RTN" :args {
+			{
+				if: (controlStack isInteger?) {
+					error: "control stack is empty for RTN instruction"
+				} else: {
+					val <- controlStack car
+					controlStack <- controlStack cdr
+					if: (val isReturn?) {
+						_curEnv <- controlStack car
+						controlStack <- controlStack cdr
+						pc <- val address
+						_dummy
+					} else: {
+						if: (val isStop?) {
+							val
+						} else: {
+							error: "RTN expects RETURN, got " . (val tag) . " instead"
+						}
+					}
+				}
+			}
+		}
+		_instConstructors set: "DUM" :args {
+			_envSize <- args get: 0
+			{
+				frame <- env: _envSize _curEnv dummy?: true
+				if: (frame isError?) {
+					frame
+				} else: {
+					_curEnv <- frame
+					_dummy
+				}
+			}
+		}
+		_instConstructors set: "RAP" :args {
+			_envSize <- args get: 0
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					error: "RAP expects CLOSURE, got INTEGER instead"
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						if: (val isClosure?) {
+							res <- _curEnv rapLoad: _envSize
+							if: (not: (res isError?)) {
+								if: (val env) != _curEnv {
+									res <- error: "CLOSURE environment must equal current environment for RAP"
+								} else: {
+									controlStack <- cons: (return: pc+1) (cons: (_curEnv parent) controlStack)
+									pc <- val address
+								}
+							}
+							res
+						} else: {
+							error: "RAP expects CLOSURE, got " . (val tag) . " instead"
+						}
+					}
+				}
+			}
+		}
+		_instConstructors set: "TRAP" :args {
+			_envSize <- args get: 0
+			{
+				val <- pop:
+				if: (val isInteger?) {
+					error: "RAP expects CLOSURE, got INTEGER instead"
+				} else: {
+					if: (val isError?) {
+						val
+					} else: {
+						if: (val isClosure?) {
+							res <- _curEnv rapLoad: _envSize
+							if: (not: (res isError?)) {
+								if: (val env) != _curEnv {
+									res <- error: "CLOSURE environment must equal current environment for RAP"
+								} else: {
+									pc <- val address
+								}
+							}
+							res
+						} else: {
+							error: "RAP expects CLOSURE, got " . (val tag) . " instead"
+						}
+					}
+				}
+			}
+		}
+		_instConstructors set: "STOP" :args {
+			{
+				stop
+			}
+		}
+		_instConstructors set: "DBUG" :args {
+			{
+				val <- pop:
+				if: (not: (val isInteger?)) && (val isError?) {
+					val
+				} else: {
+					print: (string: val) . "\n"
+					_dummy
+				}
+			}
+		}
+		_instConstructors set: "BRK" :args {
+			{
+				_dummy
+			}
+		}
+		
+		code <- code map: :i {
+			foobar <- _instConstructors get: (i inst) else: { { stop } }
+			foobar: (i args)
+		}
+		
+		#{
+			limit <- 3072 * 1000
+			run <- {
+				cycles <- 0
+				status <- _dummy
+				while: { (not: (status isError?)) && (not: (status isStop?)) } do: {
+					oldpc <- pc
+					if: (cycles >= limit) {
+						status <- error: "cycle limit of " . limit . " exceeded"
+					} else: {
+						if: (pc >= (code length)) {
+							status <- error: "PC walked off end of program"
+						} else: {
+							inst <- code get: pc
+							pc <- -1
+							status <- inst:
+							if: pc = -1 {
+								pc <- oldpc + 1
+							}
+							cycles <- cycles + 1
+						}
+					}
+				}
+				print: "Status: " . (status tag) . "\n"
+				if: (status isStop?) {
+					if: (dataStack empty?) {
+						_dummy
+					} else: {
+						pop:
+					}
+				} else: {
+					status
+				}
+			}
+		}
+	}
+	
+	parseLines <- :lines {
+		//remove comments and filter blank lines
+		lines <- (lines map: :line {
+			((line partitionOn: ";") before) trim
+		}) filter: :line { line != "" }
+		//parse the preprocessed lines
+		lines map: :line {
+			ret <- line partitionOn: " "
+			_inst <- ret before
+			_args <- (((ret after) trim) splitOn: " ") map: :arg { int32: arg }
+			#{
+				inst <- { _inst }
+				args <- { _args }
+			}
+		}
+	}
+	
+	parseFile <- :f {
+		parseLines: (f lines)
+	}
+	
+	main <- :args {
+		if: (args length) > 1 {
+			f <- file open: (args get: 1)
+			if: (f fd) >= 0 {
+				code <- parseFile: f
+				cpu <- new: code
+				res <- cpu run
+				print: "Returned value of type: " . (res tag) . "\n"
+				if: (res isError?) {
+					print: (res msg) . "\n"
+				}
+				0
+			} else: {
+				(file stderr) write: "Failed to open " . (args get: 1) . " for reading\n"
+				1
+			}
+		} else: {
+			(file stderr) write: "USAGE: gcc FILE\n"
+			1
+		}
+	}
+}
\ No newline at end of file