Add globals, test various pointer setting

This commit is contained in:
Jeremy Penner 2021-08-10 13:23:09 -04:00
parent 8a211365e4
commit 1eea56bb5b
5 changed files with 47 additions and 23 deletions

View file

@ -1,5 +1,5 @@
(local lume (require "lib.lume"))
(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes} (require "lib.util"))
(fn make-env [block parent]
{:parent parent
@ -75,6 +75,7 @@
(fn dat-parser.db [db] {:type :var :init (. db 2) :size 1})
(fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2})
(fn dat-parser.dl [dl] {:type :var :init (. dl 4) :size 4})
(fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
(fn dat-parser.ref [ref] {:type :ref :target (. ref 2)})
(fn dat-parser.flatten [flat block]
@ -127,6 +128,8 @@
(match d.size
1 (int8-to-bytes init)
2 (int16-to-bytes init)
3 (int24-to-bytes init)
4 (int32-to-bytes init)
n (string.rep "\0" n)))
(fn pdat-processor.ref.bytes [ref env]
(int16-to-bytes (env:lookup-addr ref.target)))

View file

@ -17,7 +17,9 @@
(fn int16-to-bytes [i]
(string.char (lo i) (hi i)))
(fn int24-to-bytes [i]
(string.char (lo i) (hi i) (bit.band (bit.rshift i 16) 0xff)))
(string.char (lo i) (hi i) (lo (bit.rshift i 16))))
(fn int32-to-bytes [i]
(string.char (lo i) (hi i) (lo (bit.rshift i 16)) (hi (bit.rshift i 16))))
(fn bytes-to-uint8 [b ?offset]
(string.byte b (+ 1 (or ?offset 0)) (+ 1 (or ?offset 0))))
(fn bytes-to-uint16 [b ?offset]
@ -114,7 +116,7 @@
(when (not= f nil) (io.close f))
(not= f nil)))
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
: splice : lo : hi : loword : hiword
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset
: readjson : writejson : file-exists : waitfor : in-coro : multival}

View file

@ -141,7 +141,7 @@
(bencode.encode addr-to-bytes)))
(fn Machine.launch [self prg]
(self:eval "(manager.machine:soft_reset)")
(self:eval (string.format "(emu.keypost \"\n\n\n\nCALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
(self:eval (string.format "(emu.keypost \"\n\nCALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
(fn Machine.reboot [self] (self:eval "(manager.machine:hard_reset)"))
(fn Machine.coro-eval [self code ?handlers]
(var result nil)

View file

@ -12,23 +12,34 @@
(WriteString (far-ref pascalhex)))
(fn add (lhs rhs) (+ lhs rhs))
(global word UserID)
(fn main ()
(TLStartUp)
(let (userid (MMStartUp))
(IMStartUp)
(TextStartUp)
(set! UserID (MMStartUp))
(IMStartUp)
(TextStartUp)
(let (x 1)
(printnum x)
(set! x (+ x 1))
(printnum x)
(set! (long-at (ref hexbuf)) 0x6b636548)
(WriteString (far-ref pascalhex)))
(let (x 1)
(printnum x)
(set! x (+ x 1))
(printnum x))
(set! (long-at (ref hexbuf)) 0x6b636548)
(WriteString (far-ref pascalhex))
(long! (ref hexbuf) 0x74747542)
(WriteString (far-ref pascalhex))
(let (buf (ref hexbuf)
str (far-ref pascalhex))
(long! buf 0x6b726f42)
(WriteString str)
(word! (+ buf 2) 0x706f)
(WriteString str))
(printnum (hiword (long-at (far-ref pascalhex))))
(TextShutDown)
(IMShutDown)
(MMShutDown UserID)
(TLShutDown)))
(TextShutDown)
(IMShutDown)
(MMShutDown userid)
(TLShutDown)))
)
(ssc:assemble)

View file

@ -166,6 +166,13 @@
func (if (= (type mod) :function) mod mod.module)]
(tset self.modules name mod)
(func self))))
:global (lambda [self etype name ?const]
(tset self.globals name {:type etype : name})
(self.org:append name
(match etype
:word [:dw ?const]
:long [:dl ?const]
_ (error (.. "Unrecognized type " (fv etype))))))
:do (fn [self ...]
(var etype-body :void)
(local c-body (lume.concat [:block] (icollect [i (countiter (select :# ...))]
@ -255,11 +262,12 @@
:long-at (lambda [self ref]
(local (c-ref etype) (self:expr-poly ref))
(if (= etype :word)
[:block (self:push nil c-ref :word) [:ldy 0] [:lda [1 :s] :y] [:sta self.LONG_LO] [:iny] [:iny] [:lda [1 :s] :y] [:sta self.LONG_HI] (self:drop)]
(values [:block (self:push nil c-ref :word) [:ldy 0] [:lda [1 :s] :y] [:sta self.LONG_LO] [:iny] [:iny] [:lda [1 :s] :y] [:sta self.LONG_HI] (self:drop)]
:long)
(= etype :long)
[:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y]] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] [:sta self.LONG_HI] [:stx self.LONG_LO]]))
(values [:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] :y] [:sta self.LONG_HI] [:stx self.LONG_LO]]
:long)))
:set! (lambda [self lhs value]
(let [(c-value etype) (self:expr-poly value)
{: lo : hi} (self:opgen-lhs lhs)
@ -380,7 +388,7 @@
(fn Ssc.expr-word [self expr]
(let [(c etype) (self:expr-poly expr)]
(when (not= etype :word) (error "Unexpected long or void in " (fv expr) " - please wrap in explicit truncation form"))
(when (not= etype :word) (error (.. "Unexpected long or void in " (fv expr) " - please wrap in explicit truncation form")))
c))
(fn Ssc.expr-long [self expr]
@ -388,7 +396,7 @@
(match etype
:long c
:word [:block c [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]]
_ (error "Unexpected type " etype " in " (fv expr) " - wanted long or word"))))
_ (error (.. "Unexpected type " (fv etype) " in " (fv expr) " - wanted long or word")))))
(fn Ssc.compile [self ...]
(for [i 1 (select :# ...)]