6502/SixtyPical
1
0
Fork 0
mirror of https://github.com/catseye/SixtyPical.git synced 2024-06-26 16:29:28 +00:00
Code Issues Projects Releases Wiki Activity

typematching

Browse Source
This commit is contained in:
Cat's Eye Technologies 2014-04-02 20:50:35 +01:00
parent d225d1e727
commit f5df4e5680
2 changed files with 93 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
README.markdown
View File

@ -467,9 +467,17 @@ We cannot absolute access a word.
| assign word screen 1024
| routine main {
| lda screen
| ldx screen
| }
? absolute access of non-byte-based address
? incompatible types 'Word' and 'Byte'
No, not even with `ora`.
| assign word screen 1024
| routine main {
| ora screen
| }
? incompatible types 'Byte' and 'Word'
Instead, we have to do this.
@ -480,112 +488,122 @@ Instead, we have to do this.
| }
= True
We cannot absolute access a vector.
| assign vector screen 1024
| routine main {
| lda screen
| }
? incompatible types 'Vector' and 'Byte'
-> Tests for functionality "Emit ASM for SixtyPical program"
-> Functionality "Emit ASM for SixtyPical program" is implemented by
-> shell command "bin/sixtypical emit %(test-file)"
| reserve word score
| assign byte table screen 1024
| reserve word vword
| reserve byte vbyte
| assign byte table table 1024
| routine main {
| lda #4
| ldx #0
| ldy #$FF
| lda screen
| lda screen, x
| lda screen, y
| lda (screen), y
| lda <score
| lda >score
| inc screen
| lda vbyte
| lda table, x
| lda table, y
| lda (vword), y
| lda <vword
| lda >vword
| inc vbyte
| tax
| inx
| dex
| stx score
| stx vbyte
| tay
| iny
| dey
| sty score
| cmp score
| sty vbyte
| cmp vbyte
| cmp #30
| ldx score
| cpx screen
| ldx vbyte
| cpx vbyte
| cpx #31
| txa
| ldy score
| cpy screen
| ldy vbyte
| cpy vbyte
| cpy #32
| tya
| sta screen
| sta screen, x
| sta screen, y
| sta (screen), y
| dec screen
| sta vbyte
| sta table, x
| sta table, y
| sta (vword), y
| dec vbyte
| clc
| cld
| clv
| sec
| sed
| adc #8
| adc screen
| adc vbyte
| and #8
| and screen
| and vbyte
| sbc #8
| sbc screen
| sbc vbyte
| ora #8
| ora screen
| ora vbyte
| }
= main:
= lda #4
= ldx #0
= ldy #255
= lda screen
= lda screen, x
= lda screen, y
= lda (screen), y
= lda score
= lda score+1
= inc screen
= lda vbyte
= lda table, x
= lda table, y
= lda (vword), y
= lda vword
= lda vword+1
= inc vbyte
= tax
= inx
= dex
= stx score
= stx vbyte
= tay
= iny
= dey
= sty score
= cmp score
= sty vbyte
= cmp vbyte
= cmp #30
= ldx score
= cpx screen
= ldx vbyte
= cpx vbyte
= cpx #31
= txa
= ldy score
= cpy screen
= ldy vbyte
= cpy vbyte
= cpy #32
= tya
= sta screen
= sta screen, x
= sta screen, y
= sta (screen), y
= dec screen
= sta vbyte
= sta table, x
= sta table, y
= sta (vword), y
= dec vbyte
= clc
= cld
= clv
= sec
= sed
= adc #8
= adc screen
= adc vbyte
= and #8
= and screen
= and vbyte
= sbc #8
= sbc screen
= sbc vbyte
= ora #8
= ora screen
= ora vbyte
= rts
=
= score: .word 0
= .alias screen 1024
= vword: .word 0
= vbyte: .byte 0
= .alias table 1024
| assign byte screen $0400
| routine main {

34
src/SixtyPical/Checker.hs
View File

@ -111,22 +111,17 @@ fillOutNamedLocationTypes p@(Program decls routines) =
mapProgramRoutines (xform) p
where
xform (COPY src dest) =
-- ewww special-case-y
case ((resolve src), (resolve dest)) of
((NamedLocation (Just Word) name), A) ->
error ("absolute access of non-byte-based address '" ++ name ++ "'")
_ ->
COPY (resolve src) (resolve dest)
typeMatch src dest (COPY)
xform (CMP dest other) =
CMP (resolve dest) (resolve other)
typeMatch dest other (CMP)
xform (ADD dest other) =
ADD (resolve dest) (resolve other)
typeMatch dest other (ADD)
xform (AND dest other) =
AND (resolve dest) (resolve other)
typeMatch dest other (AND)
xform (SUB dest other) =
SUB (resolve dest) (resolve other)
typeMatch dest other (SUB)
xform (OR dest other) =
OR (resolve dest) (resolve other)
typeMatch dest other (OR)
xform (JMPVECTOR dest) =
case (resolve dest) of
d@(NamedLocation (Just Vector) _) ->
@ -147,6 +142,23 @@ fillOutNamedLocationTypes p@(Program decls routines) =
COPYROUTINE name (resolve dest)
xform other =
other
getType (NamedLocation (Just t) _) = t
getType A = Byte
getType X = Byte
getType Y = Byte
getType _ = Byte
typeMatch x y constructor =
let
rx = resolve x
ry = resolve y
typeRx = getType rx
typeRy = getType ry
in
case (typeRx == typeRy, typeRx, typeRy) of
(True, _, _) -> constructor rx ry
(_, Byte, ByteTable) -> constructor rx ry
(_, ByteTable, Byte) -> constructor rx ry
_ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'")
resolve (NamedLocation Nothing name) =
case lookupDecl p name of
Just decl ->