view code/gcc.tp @ 85:f420fabd0e44 default tip

One last README change
author Michael Pavone <pavone@retrodev.com>
date Mon, 28 Jul 2014 04:42:24 -0700
parents ec87d53603dd
children
line wrap: on
line source

#{
	getTag <- :val {
		if: (val isInteger?) {
			"INTEGER"
		} else: {
			val tag
		}
	}
	
	ifError:else <- :val iferr :else {
		if: (val isInteger?) {
			else:
		} else: {
			if: (val isError?) {
				iferr:
			} else: {
				else:
			}
		}
	}
		
	new <- :rawCode {
		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" }
				string <- { _msg }
			}
		}
		_dummy <- #{
			isInteger? <- { false }
			isError? <- { false }
			isClosure? <- { false }
			isEnvironment? <- { false }
			isCons? <- { false }
			isJoin? <- { false }
			isStop? <- { false }
			tag <- { "DUMMY" }
			string <- { 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"
			}
			arr <- { #[] }
			isError? <- { false }
			isEnvironment? <- { true }
			isJoin? <- { false }
			isReturn? <- { false }
			isStop? <- { false }
			tag <- { "TOPENV" }
			string <- { tag }
		}
		
		cons <- :_car _cdr {
			consUsage <- consUsage + 1
			#{
				car <- { _car }
				cdr <- { _cdr }
				isInteger? <- { false }
				isError? <- { false }
				isClosure? <- { false }
				isEnvironment? <- { false }
				isCons? <- { true }
				isJoin? <- { false }
				tag <- { "CONS" }
				string <- { "(" . _car . ", " . _cdr . ")" }
			}
		}
		
				
		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" }
					string <- { tag }
					arr <- { _arr }
				}
			}
		}
		
		
		closure <- :_address {
			_env <- _curEnv
			#{
				address <- { _address }
				env <- { _env }
				isInteger? <- { false }
				isError? <- { false }
				isClosure? <- { true }
				isEnvironment? <- { false }
				isCons? <- { false }
				isJoin? <- { false }
				tag <- { "CLOSURE" }
				string <- { "{" . _address . ", " . _env . "}" }
			}
		}
		
		joinVal <- :_address {
			#{
				address <- { _address }
				isError? <- { false }
				isEnvironment? <- { false }
				isJoin? <- { true }
				isReturn? <- { false }
				isStop? <- { false }
				tag <- { "JOIN" }
				string <- { tag }
			}
		}
		return <- :_address {
			#{
				address <- { _address }
				isError? <- { false }
				isEnvironment? <- { false }
				isJoin? <- { false }
				isReturn? <- { true }
				isStop? <- { false }
				tag <- { "RETURN" }
				string <- { tag . " " . _address }
			}
		}
		stop <- #{
			isError? <- { false }
			isEnvironment? <- { false }
			isJoin? <- { false }
			isReturn? <- { false }
			isStop? <- { true }
			tag <- { "STOP" }
			string <- { tag }
		}
		
		_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: (joinVal: _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) (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) (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 <- rawCode map: :i {
			foobar <- _instConstructors get: (i inst) else: { { stop } }
			foobar: (i args)
		}
		
		
		_stepMode? <- false
		_lastCommand <- ""
		_breakFun <- :cpu {
			i <-  (rawCode get: (cpu pc))
			print: (string: (cpu pc)) . ": " . (i inst) . " " . ((i args) join: " ") . "\n"
			
			command <- ""
			while: { command != "c" && command != "s"} do: {
				command <- ((file stdin) nextLine) trim
				if: command = "" {
					command <- _lastCommand
				} else: {
					_lastCommand <- command
				}
				if: command = "d" {
					print: "Data Stack:\n"
					ds <- cpu dstack
					while: { not: (ds empty?) } do: {
						print: "\t" . (ds value) . "\n"
						ds <- ds tail
					}
				}
				if: command = "b" {
					print: "Control Stack:\n"
					cs <- cpu cstack
					while: { not: (cs isInteger?) } do: {
						print: "\t" . (cs car) . "\n"
						cs <- cs cdr
					}
				}
				if: command = "e" {
					print: "Environment:\n"
					env <- cpu environment
					foreach: ((cpu environment) arr) :idx val {
						print: "\t" . idx . ": " . val . "\n"
					}
				}
			}
			if: command = "c" {
				cpu runMode
			}
		}
		_cycles <- 0
		#{
			limit <- 3072 * 1000
			stepMode <- { 
				_stepMode? <- true
				self
			}
			runMode <- { 
				_stepMode? <- false
				self
			}
			breakFun <- _breakFun
			
			pc <- { _pc }
			dstack <- { dataStack }
			cstack <- { controlStack }
			environment <- { _curEnv }
			cycles <- { _cycles }
			
			run <- {
				_cycles <- 0
				controlStack <- cons: stop 0
				status <- _dummy
				while: { (not: (status isError?)) && (not: (status isStop?)) } do: {
					if: _stepMode? {
						break <- breakFun
						break: self
					}
					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 <- _pc + 1
							status <- inst:
							_cycles <- _cycles + 1
						}
					}
				}
				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
				if: (args length) > 2 {
					cpu stepMode
				}
				res <- cpu run
				print: "Ran for " . (cpu cycles) . " cycles\n"
				print: "Returned value of type: " . (getTag: res) . " - value: " . res . "\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
		}
	}
}