2014-07-07 01:49:53 +00:00
|
|
|
; things that a future assembler will need separate memory for:
|
|
|
|
; code; types; args channel
|
2014-08-19 17:31:58 +00:00
|
|
|
(= initialization-fns* (queue))
|
|
|
|
(def reset ()
|
|
|
|
(each f (as cons initialization-fns*)
|
|
|
|
(f)))
|
|
|
|
|
2014-07-06 08:41:37 +00:00
|
|
|
(def clear ()
|
2014-07-11 05:08:08 +00:00
|
|
|
(= types* (obj
|
2014-07-26 19:25:40 +00:00
|
|
|
type (obj size 1 record nil array nil address nil)
|
|
|
|
location (obj size 1 record nil array nil address nil)
|
|
|
|
integer (obj size 1 record nil array nil address nil)
|
|
|
|
boolean (obj size 1 record nil array nil address nil)
|
|
|
|
integer-array (obj array t elem 'integer) ; array of ints, size in front
|
|
|
|
integer-address (obj size 1 address t elem 'integer) ; pointer to int
|
|
|
|
))
|
2014-07-06 08:41:37 +00:00
|
|
|
(= memory* (table))
|
|
|
|
(= function* (table)))
|
2014-08-19 17:31:58 +00:00
|
|
|
(enq clear initialization-fns*)
|
2014-07-06 08:41:37 +00:00
|
|
|
|
2014-08-19 19:02:40 +00:00
|
|
|
(mac init-fn (name . body)
|
|
|
|
`(enq (fn () (= (function* ',name) ',body))
|
|
|
|
initialization-fns*))
|
|
|
|
|
|
|
|
(mac on-init body
|
|
|
|
`(enq (fn () (run ',body))
|
|
|
|
initialization-fns*))
|
|
|
|
|
2014-07-06 08:41:37 +00:00
|
|
|
(def add-fns (fns)
|
|
|
|
(each (name . body) fns
|
|
|
|
(= function*.name body)))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2014-07-31 08:53:14 +00:00
|
|
|
(mac v (operand) ; for value
|
|
|
|
`(,operand 0))
|
|
|
|
|
2014-07-31 09:27:41 +00:00
|
|
|
(mac metadata (operand)
|
|
|
|
`(cdr ,operand))
|
|
|
|
|
2014-07-31 08:53:14 +00:00
|
|
|
(mac ty (operand)
|
|
|
|
`(,operand 1)) ; assume type is always first bit of metadata, and it's always present
|
|
|
|
|
|
|
|
(mac m (loc) ; for memory
|
2014-08-18 19:12:58 +00:00
|
|
|
`(let loc@ ,loc
|
|
|
|
(if (pos 'deref (metadata loc@))
|
|
|
|
(memory* (memory* (v loc@)))
|
|
|
|
(memory* (v loc@)))))
|
2014-07-27 17:55:08 +00:00
|
|
|
|
2014-07-31 10:46:05 +00:00
|
|
|
(mac setm (loc val) ; set memory, respecting addressing-mode tags
|
2014-08-18 19:12:58 +00:00
|
|
|
`(let loc@ ,loc
|
|
|
|
(if (pos 'deref (metadata loc@))
|
|
|
|
(= (memory* (memory* (v loc@))) ,val)
|
|
|
|
(= (memory* (v loc@)) ,val))))
|
2014-07-31 09:27:41 +00:00
|
|
|
|
2014-07-31 08:27:52 +00:00
|
|
|
(def run (instrs (o fn-args) (o fn-oargs))
|
2014-07-12 04:13:26 +00:00
|
|
|
(ret result nil
|
2014-07-31 10:46:05 +00:00
|
|
|
(with (ninstrs 0 fn-arg-idx 0)
|
2014-07-12 04:29:43 +00:00
|
|
|
;? (prn instrs)
|
2014-07-31 10:46:05 +00:00
|
|
|
(for pc 0 (< pc len.instrs) (do ++.ninstrs ++.pc)
|
|
|
|
;? (if (> ninstrs 10) (break))
|
2014-07-12 04:13:26 +00:00
|
|
|
(let instr instrs.pc
|
|
|
|
;? (prn memory*)
|
2014-07-17 15:16:22 +00:00
|
|
|
;? (prn pc ": " instr)
|
2014-07-12 04:13:26 +00:00
|
|
|
(let delim (or (pos '<- instr) -1)
|
|
|
|
(with (oarg (if (>= delim 0)
|
|
|
|
(cut instr 0 delim))
|
|
|
|
op (instr (+ delim 1))
|
|
|
|
arg (cut instr (+ delim 2)))
|
|
|
|
;? (prn op " " oarg)
|
2014-07-31 10:46:05 +00:00
|
|
|
(let tmp
|
|
|
|
(case op
|
|
|
|
literal
|
|
|
|
arg.0
|
|
|
|
add
|
|
|
|
;? (do (prn "add " (m arg.0) (m arg.1))
|
|
|
|
(+ (m arg.0) (m arg.1))
|
|
|
|
;? (prn "add2"))
|
|
|
|
sub
|
|
|
|
(- (m arg.0) (m arg.1))
|
|
|
|
mul
|
|
|
|
(* (m arg.0) (m arg.1))
|
|
|
|
div
|
|
|
|
(/ (real (m arg.0)) (m arg.1))
|
|
|
|
idiv
|
|
|
|
(list
|
|
|
|
(trunc:/ (m arg.0) (m arg.1))
|
|
|
|
(mod (m arg.0) (m arg.1)))
|
|
|
|
and
|
|
|
|
(and (m arg.0) (m arg.1))
|
|
|
|
or
|
|
|
|
(or (m arg.0) (m arg.1))
|
|
|
|
not
|
|
|
|
(not (m arg.0))
|
|
|
|
eq
|
|
|
|
(is (m arg.0) (m arg.1))
|
|
|
|
neq
|
|
|
|
(~is (m arg.0) (m arg.1))
|
|
|
|
lt
|
|
|
|
(< (m arg.0) (m arg.1))
|
|
|
|
gt
|
|
|
|
(> (m arg.0) (m arg.1))
|
|
|
|
le
|
|
|
|
(<= (m arg.0) (m arg.1))
|
|
|
|
ge
|
|
|
|
(>= (m arg.0) (m arg.1))
|
|
|
|
arg
|
|
|
|
(let idx (if arg
|
|
|
|
arg.0
|
|
|
|
(do1 fn-arg-idx
|
|
|
|
++.fn-arg-idx))
|
|
|
|
(m fn-args.idx))
|
|
|
|
otype
|
|
|
|
(ty (fn-oargs arg.0))
|
|
|
|
jmp
|
2014-08-02 09:25:32 +00:00
|
|
|
(do (= pc (+ pc (v arg.0)))
|
2014-07-31 10:46:05 +00:00
|
|
|
;? (prn "jumping to " pc)
|
|
|
|
(continue))
|
|
|
|
jif
|
|
|
|
(when (is t (m arg.0))
|
2014-08-02 09:25:32 +00:00
|
|
|
(= pc (+ pc (v arg.1)))
|
2014-07-12 04:29:43 +00:00
|
|
|
;? (prn "jumping to " pc)
|
|
|
|
(continue))
|
2014-07-31 10:46:05 +00:00
|
|
|
copy
|
|
|
|
(m arg.0)
|
|
|
|
reply
|
|
|
|
(do (= result arg)
|
|
|
|
(break))
|
|
|
|
; else user-defined function
|
|
|
|
(let-or new-body function*.op (prn "no definition for " op)
|
|
|
|
;? (prn "== " memory*)
|
|
|
|
(let results (run new-body arg oarg)
|
|
|
|
;? (prn "=> " oarg)
|
|
|
|
(each o oarg
|
|
|
|
;? (prn o)
|
|
|
|
(setm o (m pop.results))))
|
|
|
|
(continue))
|
|
|
|
)
|
2014-08-02 22:26:08 +00:00
|
|
|
;? (prn tmp " " oarg)
|
2014-07-31 10:46:05 +00:00
|
|
|
; opcode that generated at least some result
|
|
|
|
(if (acons tmp)
|
|
|
|
(for i 0 (< i (min len.tmp len.oarg)) ++.i
|
|
|
|
(setm oarg.i tmp.i))
|
|
|
|
(when oarg ; must be a list
|
|
|
|
;? (prn oarg.0)
|
|
|
|
(setm oarg.0 tmp)))
|
2014-07-12 04:13:26 +00:00
|
|
|
)))))
|
|
|
|
;? (prn "return " result)
|
2014-07-12 04:53:44 +00:00
|
|
|
)))
|
2014-07-06 07:07:03 +00:00
|
|
|
|
2014-07-17 16:02:43 +00:00
|
|
|
(def convert-braces (instrs)
|
|
|
|
(let locs () ; list of information on each brace: (open/close pc)
|
|
|
|
(let pc 0
|
|
|
|
(loop (instrs instrs)
|
|
|
|
(each instr instrs
|
|
|
|
(if (~is 'begin instr.0)
|
|
|
|
(do
|
|
|
|
;? (prn pc " " instr)
|
|
|
|
(++ pc))
|
2014-07-17 16:21:27 +00:00
|
|
|
; hack: racket replaces curlies with parens, so we need the
|
|
|
|
; keyword begin to delimit blocks.
|
|
|
|
; ultimately there'll be no nesting and curlies will just be in a
|
|
|
|
; line by themselves.
|
2014-07-17 16:02:43 +00:00
|
|
|
(do
|
|
|
|
;? (prn `(open ,pc))
|
|
|
|
(push `(open ,pc) locs)
|
|
|
|
(recur cdr.instr)
|
|
|
|
;? (prn `(close ,pc))
|
|
|
|
(push `(close ,pc) locs))))))
|
|
|
|
(zap rev locs)
|
|
|
|
;? (prn locs)
|
|
|
|
(with (pc 0
|
|
|
|
stack ()) ; elems are pcs
|
|
|
|
(accum yield
|
|
|
|
(loop (instrs instrs)
|
|
|
|
(each instr instrs
|
|
|
|
(let delim (or (pos '<- instr) -1)
|
|
|
|
(with (oarg (if (>= delim 0)
|
|
|
|
(cut instr 0 delim))
|
|
|
|
op (instr (+ delim 1))
|
|
|
|
arg (cut instr (+ delim 2)))
|
|
|
|
;? (prn op " " oarg)
|
|
|
|
(case op
|
|
|
|
begin
|
|
|
|
(do
|
|
|
|
(push pc stack)
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(recur arg)
|
|
|
|
(pop stack))
|
2014-07-17 16:21:27 +00:00
|
|
|
break
|
|
|
|
(do
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(assert:is arg nil)
|
2014-07-31 08:47:32 +00:00
|
|
|
(yield `(jmp (,(close-offset pc locs) offset))))
|
2014-07-17 16:02:43 +00:00
|
|
|
breakif
|
|
|
|
(do
|
|
|
|
;? (prn "breakif: " instr)
|
2014-07-17 16:21:27 +00:00
|
|
|
(assert:is oarg nil)
|
2014-07-31 08:47:32 +00:00
|
|
|
(yield `(jif ,arg.0 (,(close-offset pc locs) offset))))
|
2014-07-17 16:21:27 +00:00
|
|
|
continue
|
|
|
|
(do
|
|
|
|
(assert:is oarg nil)
|
|
|
|
(assert:is arg nil)
|
2014-07-31 08:47:32 +00:00
|
|
|
(yield `(jmp (,(- stack.0 pc) offset))))
|
2014-07-17 16:21:27 +00:00
|
|
|
continueif
|
|
|
|
(do
|
|
|
|
;? (prn "continueif: " instr)
|
|
|
|
(assert:is oarg nil)
|
2014-07-31 08:47:32 +00:00
|
|
|
(yield `(jif ,arg.0 (,(- stack.0 pc) offset))))
|
2014-07-17 16:02:43 +00:00
|
|
|
;else
|
|
|
|
(yield instr))))
|
|
|
|
(++ pc)))))))
|
|
|
|
|
|
|
|
(def close-offset (pc locs)
|
|
|
|
(let close 0
|
|
|
|
(with (stacksize 0
|
|
|
|
done nil)
|
|
|
|
(each (state loc) locs
|
|
|
|
;? (prn " :" close " " state " - " loc)
|
|
|
|
(if (< loc pc)
|
|
|
|
nil ; do nothing
|
|
|
|
(no done)
|
|
|
|
(do
|
|
|
|
; first time
|
|
|
|
(when (and (is 0 stacksize) (~is loc pc))
|
|
|
|
(++ stacksize))
|
|
|
|
(if (is 'open state) (++ stacksize) (-- stacksize))
|
|
|
|
; last time
|
|
|
|
(when (is 0 stacksize)
|
|
|
|
(= close loc)
|
|
|
|
(set done))))))
|
|
|
|
(- close pc 1)))
|
|
|
|
|
2014-07-06 08:41:37 +00:00
|
|
|
(awhen cdr.argv
|
2014-07-27 17:09:00 +00:00
|
|
|
(map add-fns:readfile it)
|
2014-07-06 08:41:37 +00:00
|
|
|
(run function*!main)
|
2014-07-06 07:07:03 +00:00
|
|
|
(prn memory*))
|