Commit cbeac87a73809c7824b246de2d94f4c9e28524c9 - SixtyPical

+60

-0

doc/Emitting.markdown less more

167	167	= .data
168	168	= .space position 2
169	169
	170	Copy command: word -> word
	171
	172	\| reserve word position1
	173	\| reserve word position2
	174	\| routine main {
	175	\| copy position1 position2
	176	\| }
	177	= main:
	178	= lda position1
	179	= sta position2
	180	= lda position1+1
	181	= sta position2+1
	182	= rts
	183	=
	184	= .data
	185	= .space position1 2
	186	= .space position2 2
	187
	188	Copy command: word -> word indexed
	189
	190	\| reserve word loc
	191	\| reserve word[4] locs
	192	\| routine main {
	193	\| ldy #0
	194	\| copy loc locs, y
	195	\| }
	196	= main:
	197	= ldy #0
	198	= lda loc
	199	= sta locs_lo, y
	200	= lda loc+1
	201	= sta locs_hi, y
	202	= rts
	203	=
	204	= .data
	205	= .space loc 2
	206	= .space locs_lo 4
	207	= .space locs_hi 4
	208
	209	Copy command: word INDEXED -> word
	210
	211	\| reserve word loc
	212	\| reserve word[4] locs
	213	\| routine main {
	214	\| ldx #0
	215	\| copy locs, x loc
	216	\| }
	217	= main:
	218	= ldx #0
	219	= lda locs_lo, x
	220	= sta loc
	221	= lda locs_hi, x
	222	= sta loc+1
	223	= rts
	224	=
	225	= .data
	226	= .space loc 2
	227	= .space locs_lo 4
	228	= .space locs_hi 4
	229
170	230	`main` is always emitted first.
171	231
172	232	\| reserve word position

+7

-12

eg/game.60p less more

25	25	reserve byte value
26	26	reserve word compare_target
27	27
28		reserve byte[16] actor_pos_hi
29		reserve byte[16] actor_pos_lo
	28	reserve word[16] actor_pos
30	29
31	30	reserve vector dispatch_state
32	31	reserve vector dispatch_logic

140	139	ldy #0
141	140	repeat bne {
142	141	lda #$04
143		sta actor_pos_hi, y
	142	// * this is broken *
	143	sta >actor_pos, y
144	144	tya
145	145	clc
146	146	asl .a
147	147	asl .a
148		sta actor_pos_lo, y
	148	sta <actor_pos, y
149	149	iny
150	150	cpy #8
151	151	}

213	213	repeat bne {
214	214	stx save_x
215	215
216		lda actor_pos_hi, x
217		sta >position
218		lda actor_pos_lo, x
219		sta <position
	216	copy actor_pos, x position
220	217
221	218	cpx #0
222	219	if beq {

227	224	jsr indirect_jsr_logic
228	225
229	226	ldx save_x
230		lda >position
231		sta actor_pos_hi, x
232		lda <position
233		sta actor_pos_lo, x
	227	copy position actor_pos, x
	228
234	229	inx
235	230	cpx #8
236	231	}

+2

-2

src/SixtyPical/Checker.hs less more

30	30	where
31	31	checkInstr j@(COPY _ (Indexed (NamedLocation sz g) reg)) =
32	32	case lookupDecl p g of
33		Just (Assign _ (Table Byte _) _) -> j
34		Just (Reserve _ (Table Byte _) _) -> j
	33	Just (Assign _ (Table _ _) _) -> j
	34	Just (Reserve _ (Table _ _) _) -> j
35	35	Just _ -> (COPY A A)
36	36	Nothing -> (COPY A A)
37	37	checkInstr other = other

+26

-0

src/SixtyPical/Emitter.hs less more

39	39	showList [val] = show val
40	40	showList (val:vals) = (show val) ++ ", " ++ (showList vals)
41	41
	42	emitDecl p (Reserve name (Table Word size) []) =
	43	".space " ++ name ++ "_lo " ++ (show size) ++ "\n" ++
	44	".space " ++ name ++ "_hi " ++ (show size)
	45
42	46	emitDecl p (Reserve name typ [])
43	47	\| typ == Byte = ".space " ++ name ++ " 1"
44	48	\| typ == Word = ".space " ++ name ++ " 2"

96	100
97	101	emitInstr p r (COPY (Indexed (NamedLocation (Just (Table Byte _)) label) X) A) = "lda " ++ label ++ ", x"
98	102	emitInstr p r (COPY (Indexed (NamedLocation (Just (Table Byte _)) label) Y) A) = "lda " ++ label ++ ", y"
	103
	104	emitInstr p r (COPY (NamedLocation (Just st1) src) (Indexed (NamedLocation (Just (Table st2 _)) dst) reg))
	105	\| (st1 == Vector && st2 == Vector) \|\| (st1 == Word && st2 == Word) =
	106	"lda " ++ src ++ "\n" ++
	107	" sta " ++ dst ++ "_lo, " ++ r ++ "\n" ++
	108	" lda " ++ src ++ "+1\n" ++
	109	" sta " ++ dst ++ "_hi, " ++ r
	110	where
	111	r = case reg of
	112	X -> "x"
	113	Y -> "y"
	114
	115	emitInstr p r (COPY (Indexed (NamedLocation (Just (Table st1 _)) src) reg) (NamedLocation (Just st2) dst))
	116	\| (st1 == Vector && st2 == Vector) \|\| (st1 == Word && st2 == Word) =
	117	"lda " ++ src ++ "_lo, " ++ r ++ "\n" ++
	118	" sta " ++ dst ++ "\n" ++
	119	" lda " ++ src ++ "_hi, " ++ r ++ "\n" ++
	120	" sta " ++ dst ++ "+1"
	121	where
	122	r = case reg of
	123	X -> "x"
	124	Y -> "y"
99	125
100	126	emitInstr p r (COPY A (IndirectIndexed (NamedLocation st label) Y)) = "sta (" ++ label ++ "), y"
101	127	emitInstr p r (COPY (IndirectIndexed (NamedLocation st label) Y) A) = "lda (" ++ label ++ "), y"

+13

-5

src/SixtyPical/Parser.hs less more

574	574	copy_general_statement = do
575	575	string "copy"
576	576	nspaces
	577
577	578	src <- (try immediate <\|> try direct_location)
	579	srcI <- many index
	580	lhs <- return $ case (src, srcI) of
	581	((Immediately s), []) -> (Immediate s)
	582	((Directly s), []) -> (NamedLocation Nothing s)
	583	((Directly s), [reg]) -> (Indexed (NamedLocation Nothing s) reg)
	584
578	585	dst <- direct_location
579		return $ case (src, dst) of
580		(Immediately s, Directly d) ->
581		(COPY (Immediate s) (NamedLocation Nothing d))
582		(Directly s, Directly d) ->
583		(COPY (NamedLocation Nothing s) (NamedLocation Nothing d))
	586	dstI <- many index
	587	rhs <- return $ case (dst, dstI) of
	588	((Directly d), []) -> (NamedLocation Nothing d)
	589	((Directly d), [reg]) -> (Indexed (NamedLocation Nothing d) reg)
	590
	591	return $ COPY lhs rhs
584	592
585	593	copy_routine_statement :: Parser Instruction
586	594	copy_routine_statement = do

+7

-2

src/SixtyPical/Transformer.hs less more

111	111	getType A = Byte
112	112	getType X = Byte
113	113	getType Y = Byte
114		getType (Immediate x) =
	114	getType (Immediate x) = -- TODO! allow promotion!
115	115	if x > 255 then Word else Byte
	116	getType (Indexed t _) =
	117	getType t
116	118	getType _ = Byte
117	119	typeMatch x y constructor =
118	120	let

125	127	(True, _, _) -> constructor rx ry
126	128	(_, Byte, (Table Byte _)) -> constructor rx ry
127	129	(_, (Table Byte _), Byte) -> constructor rx ry
128		_ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'")
	130	(_, Word, (Table Word _)) -> constructor rx ry
	131	(_, (Table Word _), Word) -> constructor rx ry
	132	_ -> error ("incompatible types '" ++ (show typeRx) ++ "' and '" ++ (show typeRy) ++ "'" ++
	133	" " ++ (show rx) ++ "," ++ (show ry))
129	134	resolve (NamedLocation Nothing name) =
130	135	case lookupDecl p name of
131	136	Just decl ->