REBOL [
	Title:		"6502 ASM"
	Date:		12-Feb-2008
	Version:	1.0.2
	File:		'asm6502.r
	Author:		"John Niclasen"
	Rights:		"Copyright © John Niclasen 2008"
	License:	"GPL"
	Purpose:	{
		A 6502 assembler.
	}
	History: [
		1.0.2	[12-02-2008	JN	{Added /into refinement}]
		1.0.1	[10-02-2008	JN	{Changed label parsing rules
								 Fixed bugs in LSR, ROL and ROR}]
		1.0.0	[05-02-2008	JN	{Finished v. 1.0.0}]
		0.0.2	[04-02-2008	JN	{Added branch}]
		0.0.1	[01-02-2008	JN	{Created}]
	]
]

context [

var-char: charset [#"A" - #"Z" #"a" - #"z" #"_"]
var-name: [var-char any [var-char | integer!]]
hex: charset [#"0" - #"9" #"A" - #"F" #"a" - #"f"]
space: charset { ^-}
sp: [any space]

ram: none

PC: 1	; Program Counter

arg: ""
label: ""
labels: []
label-addrs: []
word: none
int: 0
bin: #{0000}
mode: 0
; 1 = Immediate # or Accumulator A
; 2 = zp
; 3 = zp,X
; 4 = abs
; 5 = abs,X
; 6 = abs,Y
; 7 = (indirect,X)
; 8 = (indirect),Y
; 9 = (indirect)
; 10 = zp,Y

value: [
	"&" copy arg some hex (
		bin: debase/base arg 16
		if 2 < length? bin [make error! "invalid value"]
	)
	| copy arg integer! (
		int: to integer! arg
		if any [int < 0 int > 65535] [make error! "invalid value"]
		either int < 256 [
			bin: debase/base skip to-hex int 6 16
		][
			bin: debase/base skip to-hex int 4 16
		]
	)
]

argument: [sp [
	"A" (mode: 1)
	| "#" (mode: 1) value
	| "(" value [
		",X)" (mode: 7)
		| "),Y" (mode: 8)
		| ")" (mode: 9)
	]
	| value [
		",X" (mode: either 1 = length? bin [3] [5])
		| ",Y" (mode: either 1 = length? bin [10] [6])
		| (mode: either 1 = length? bin [2] [4])
	]
]]

OPCodes: [
	ADC [#"^(69)" #"^(65)" #"^(75)" #"^(6D)" #"^(7D)" #"^(79)" #"^(61)" #"^(71)"]
	AND [#"^(29)" #"^(25)" #"^(35)" #"^(2D)" #"^(3D)" #"^(39)" #"^(21)" #"^(31)"]
	ASL [#"^(0A)" #"^(06)" #"^(16)" #"^(0E)" #"^(1E)"]
	BCC #"^(90)"
	BCS #"^(B0)"
	BEQ #"^(F0)"
	BIT [#"^(24)" #"^(2C)"]
	BMI #"^(30)"
	BNE #"^(D0)"
	BPL #"^(10)"
	BRK #"^(00)"
	BVC #"^(50)"
	BVS #"^(70)"
	CLC #"^(18)"
	CLD #"^(D8)"
	CLI #"^(58)"
	CLV #"^(B8)"
	CMP [#"^(C9)" #"^(C5)" #"^(D5)" #"^(CD)" #"^(DD)" #"^(D9)" #"^(C1)" #"^(D1)"]
	CPX [#"^(E0)" #"^(E4)" #"^(EC)"]
	CPY [#"^(C0)" #"^(C4)" #"^(CC)"]
	DEC [#"^(C6)" #"^(D6)" #"^(CE)" #"^(DE)"]
	DEX #"^(CA)"
	DEY #"^(88)"
	EOR [#"^(49)" #"^(45)" #"^(55)" #"^(4D)" #"^(5D)" #"^(59)" #"^(41)" #"^(51)"]
	INC [#"^(E6)" #"^(F6)" #"^(EE)" #"^(FE)"]
	INX #"^(E8)"
	INY #"^(C8)"
	JMP [#"^(4C)" #"^(6C)"]
	JSR #"^(20)"
	LDA [#"^(A9)" #"^(A5)" #"^(B5)" #"^(AD)" #"^(BD)" #"^(B9)" #"^(A1)" #"^(B1)"]
	LDX [#"^(A2)" #"^(A6)" #"^(B6)" #"^(AE)" #"^(BE)"]
	LDY [#"^(A0)" #"^(A4)" #"^(B4)" #"^(AC)" #"^(BC)"]
	LSR [#"^(4A)" #"^(46)" #"^(56)" #"^(4E)" #"^(5E)"]
	NOP #"^(EA)"
	ORA [#"^(09)" #"^(05)" #"^(15)" #"^(0D)" #"^(1D)" #"^(19)" #"^(01)" #"^(11)"]
	PHA #"^(48)"
	PHP #"^(08)"
	PLA #"^(68)"
	PLP #"^(28)"
	ROL [#"^(2A)" #"^(26)" #"^(36)" #"^(2E)" #"^(3E)"]
	ROR [#"^(6A)" #"^(66)" #"^(76)" #"^(6E)" #"^(7E)"]
	RTI #"^(40)"
	RTS #"^(60)"
	SBC [#"^(E9)" #"^(E5)" #"^(F5)" #"^(ED)" #"^(FD)" #"^(F9)" #"^(E1)" #"^(F1)"]
	SEC #"^(38)"
	SED #"^(F8)"
	SEI #"^(78)"
	STA [#"^(85)" #"^(95)" #"^(8D)" #"^(9D)" #"^(99)" #"^(81)" #"^(91)"]
	STX [#"^(86)" #"^(96)" #"^(8E)"]
	STY [#"^(84)" #"^(94)" #"^(8C)"]
	TAX #"^(AA)"
	TAY #"^(A8)"
	TSX #"^(BA)"
	TXA #"^(8A)"
	TXS #"^(9A)"
	TYA #"^(98)"
]

branch: func [opc /local word] [
	word: to word! label
	ram/:PC: OPCodes/:opc PC: PC + 1

	either find label-addrs word [
		ram/:PC: to char! label-addrs/:word + 255 - PC
		PC: PC + 1
	][
		either find labels word [
			append labels/:word PC
		][
			repend labels [word reduce [PC]]
		]
		ram/:PC: #"^(00)" PC: PC + 1
	]
]

branch-rule: [sp copy label var-name sp]

instructions: [
	err:
	"ADC" argument (
		ram/:PC: OPCodes/ADC/:mode PC: PC + 1
		if find [4 5 6] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "AND" argument (
		ram/:PC: OPCodes/AND/:mode PC: PC + 1
		if find [4 5 6] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "ASL" argument (
		ram/:PC: OPCodes/ASL/:mode PC: PC + 1
		if mode > 1 [
			if mode > 3 [
				ram/:PC: to char! bin/2 PC: PC + 1
			]
			ram/:PC: to char! bin/1 PC: PC + 1
		]
	)
	| "BCC" branch-rule (branch 'BCC)
	| "BCS" branch-rule (branch 'BCS)
	| "BEQ" branch-rule (branch 'BEQ)
	| "BIT" sp value (
		either 1 = length? bin [
			ram/:PC: OPCodes/BIT/1 PC: PC + 1
		][
			ram/:PC: OPCodes/BIT/2 PC: PC + 1
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "BMI" branch-rule (branch 'BMI)
	| "BNE" branch-rule (branch 'BNE)
	| "BPL" branch-rule (branch 'BPL)
	| "BRK" (ram/:PC: OPCodes/BRK PC: PC + 1)
	| "BVC" branch-rule (branch 'BVC)
	| "BVS" branch-rule (branch 'BVS)
	| "CLC" (ram/:PC: OPCodes/CLC PC: PC + 1)
	| "CLD" (ram/:PC: OPCodes/CLD PC: PC + 1)
	| "CLI" (ram/:PC: OPCodes/CLI PC: PC + 1)
	| "CLV" (ram/:PC: OPCodes/CLV PC: PC + 1)
	| "CMP" argument (
		ram/:PC: OPCodes/CMP/:mode PC: PC + 1
		if find [4 5 6] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "CPX" argument (
		either mode = 4 [
			ram/:PC: OPCodes/CPX/3 PC: PC + 1
			ram/:PC: to char! bin/2 PC: PC + 1
		][
			ram/:PC: OPCodes/CPX/:mode PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "CPY" argument (
		either mode = 4 [
			ram/:PC: OPCodes/CPY/3 PC: PC + 1
			ram/:PC: to char! bin/2 PC: PC + 1
		][
			ram/:PC: OPCodes/CPY/:mode PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "DEC" argument (
		mode: mode - 1
		ram/:PC: OPCodes/DEC/:mode PC: PC + 1
		if mode > 2 [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "DEX" (ram/:PC: OPCodes/DEX PC: PC + 1)
	| "DEY" (ram/:PC: OPCodes/DEY PC: PC + 1)
	| "EOR" argument (
		ram/:PC: OPCodes/EOR/:mode PC: PC + 1
		if find [4 5 6] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "INC" argument (
		mode: mode - 1
		ram/:PC: OPCodes/INC/:mode PC: PC + 1
		if mode > 2 [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "INX" (ram/:PC: OPCodes/INX PC: PC + 1)
	| "INY" (ram/:PC: OPCodes/INY PC: PC + 1)
	| "JMP" argument (
		ram/:PC: either mode = 4 [OPCodes/JMP/1] [OPCodes/JMP/2] PC: PC + 1
		ram/:PC: to char! bin/2 PC: PC + 1
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "JSR" sp value (
		ram/:PC: OPCodes/JSR PC: PC + 1
		ram/:PC: to char! bin/2 PC: PC + 1
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "LDA" argument (
		ram/:PC: OPCodes/LDA/:mode PC: PC + 1
		if find [4 5 6] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "LDX" argument (
		if mode = 6 [mode: 5]
		if mode = 10 [mode: 3]
		ram/:PC: OPCodes/LDX/:mode PC: PC + 1
		if mode > 3 [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "LDY" argument (
		ram/:PC: OPCodes/LDY/:mode PC: PC + 1
		if mode > 3 [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "LSR" argument (
		ram/:PC: OPCodes/LSR/:mode PC: PC + 1
		if mode > 1 [
			if mode > 3 [
				ram/:PC: to char! bin/2 PC: PC + 1
			]
			ram/:PC: to char! bin/1 PC: PC + 1
		]
	)
	| "NOP" (ram/:PC: OPCodes/NOP PC: PC + 1)
	;| "OPT"	; options
	| "ORA" argument (
		ram/:PC: OPCodes/ORA/:mode PC: PC + 1
		if find [4 5 6] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "PHA" (ram/:PC: OPCodes/PHA PC: PC + 1)
	| "PHP" (ram/:PC: OPCodes/PHP PC: PC + 1)
	| "PLA" (ram/:PC: OPCodes/PLA PC: PC + 1)
	| "PLP" (ram/:PC: OPCodes/PLP PC: PC + 1)
	| "ROL" argument (
		ram/:PC: OPCodes/ROL/:mode PC: PC + 1
		if mode > 1 [
			if mode > 3 [
				ram/:PC: to char! bin/2 PC: PC + 1
			]
		ram/:PC: to char! bin/1 PC: PC + 1
		]
	)
	| "ROR" argument (
		ram/:PC: OPCodes/ROR/:mode PC: PC + 1
		if mode > 1 [
			if mode > 3 [
				ram/:PC: to char! bin/2 PC: PC + 1
			]
			ram/:PC: to char! bin/1 PC: PC + 1
		]
	)
	| "RTI" (ram/:PC: OPCodes/RTI PC: PC + 1)
	| "RTS" (ram/:PC: OPCodes/RTS PC: PC + 1)
	| "SBC" argument (
		ram/:PC: OPCodes/SBC/:mode PC: PC + 1
		if find [4 5 6] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "SEC" (ram/:PC: OPCodes/SEC PC: PC + 1)
	| "SED" (ram/:PC: OPCodes/SED PC: PC + 1)
	| "SEI" (ram/:PC: OPCodes/SEI PC: PC + 1)
	| "STA" argument (
		mode: mode - 1
		ram/:PC: OPCodes/STA/:mode PC: PC + 1
		if find [3 4 5] mode [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "STX" argument (
		if mode = 10 [mode: 3]
		mode: mode - 1
		ram/:PC: OPCodes/STX/:mode PC: PC + 1
		if mode > 2 [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "STY" argument (
		mode: mode - 1
		ram/:PC: OPCodes/STY/:mode PC: PC + 1
		if mode > 2 [
			ram/:PC: to char! bin/2 PC: PC + 1
		]
		ram/:PC: to char! bin/1 PC: PC + 1
	)
	| "TAX" (ram/:PC: OPCodes/TAX PC: PC + 1)
	| "TAY" (ram/:PC: OPCodes/TAY PC: PC + 1)
	| "TSX" (ram/:PC: OPCodes/TSX PC: PC + 1)
	| "TXA" (ram/:PC: OPCodes/TXA PC: PC + 1)
	| "TXS" (ram/:PC: OPCodes/TXS PC: PC + 1)
	| "TYA" (ram/:PC: OPCodes/TYA PC: PC + 1)
]

set-label: [
	"." copy label var-name sp (
		word: to word! label
		either find label-addrs word [
			label-addrs/:word: PC
		][
			repend label-addrs [word PC]
		]
	)
]

set 'asm6502 func [
	"6502 assembler"
	input		[string! file!]	"Assembler lines"
	/at addr	[integer!]		"Start address for Program Counter"
	/into ramblock	[binary!]	"RAM to assemble into"
	/local ok line-no lbl
][
	clear labels
	clear label-addrs
	PC: either at [addr] [1]
	ok: true

	either into [
		ram: ramblock
	][
		ram: make binary! 64 * 1024
		insert/dup ram #"^(00)" 64 * 1024
		;change/dup ram #"^(00)" 64 * 1024
	]

	input: either file? input [read/lines input] [parse/all input "^/"]

	line-no: 1
	foreach line input [
		if not parse/all line [
			some [sp [
				set-label sp opt instructions [thru ":" | to end]
				| instructions [thru ":" | to end]
			]]
		] [
			ok: false
			break
		]
		line-no: line-no + 1
	]
	;probe labels
	;probe label-addrs

	either ok [
		foreach [l b] labels [
			foreach addr b [
				either find label-addrs l [
					ram/:addr: to char! label-addrs/:l - addr - 1
				][
					lbl: l
					ok: false
					break
				]
			]
			if not ok [break]
		]
		either ok [
			ram
		][
			print ["Label not found:" lbl]
			false
		]
	][
		print ["Syntax error in line" line-no "near:" copy/part err 20]
		false
	]
]

]	; context