#! /usr/local/bin/gforth

\	S" struct.fs" required
	S" common.fs" required

\ error codes

	31 CONSTANT ERR_TOO_BIG_VALUE
	32 CONSTANT ERR_TOO_MANY_FORWARD_REFERENCES
	33 CONSTANT ERR_UNKNOWN_REFERENCE

\ code buffer setup

	1024 2 * CONSTANT CodeBufferSize
	CodeBufferSize ALLOCATE THROW CONSTANT CodeBuffer
	CodeBuffer CodeBufferSize + CONSTANT CodeBufferEnd
	CodeBuffer VALUE CodeBufferPointer

	CodeBuffer VALUE there \ there points to CodeBuffer by default

\ data buffer setup

	64 CONSTANT DataBufferSize
	DataBufferSize ALLOCATE THROW CONSTANT DataBuffer
	DataBuffer DataBufferSize + CONSTANT DataBufferEnd
	DataBuffer VALUE DataBufferPointer

: clear-buffer ( u addr -- )
	{ BufferSize BufferAddr -- }
	BufferSize 0 ?DO
		0 BufferAddr I + C!
	LOOP
;

: clear-data-buffer ( -- ) DataBufferSize DataBuffer clear-buffer ;
: clear-code-buffer ( -- ) CodeBufferSize CodeBuffer clear-buffer ;

	clear-data-buffer
	clear-code-buffer

\ saving buffers

: SaveBuffer ( BufferAddr BufferLength FilenameAddr FilenameLength -- )
	0 { BufferFileID -- }

	( FilenameAddr FilenameLength ) W/O CREATE-FILE ABORT" create-file failed while saving buffer" TO BufferFileID
	( BufferAddr BufferLength ) BufferFileID WRITE-FILE ABORT" write-file failed while saving buffer"
	BufferFileID CLOSE-FILE ABORT" close-file failed while saving buffer"
;

: SaveCodeBuffer ( -- )
	CodeBuffer CodeBufferSize S" code.bin" SaveBuffer
;

: SaveDataBuffer ( -- )
	DataBuffer DataBufferSize S" data.bin" SaveBuffer
;

: SaveCodeBufferAs ( FilenameAddr FilenameLength -- )
	CodeBuffer CodeBufferSize 2SWAP SaveBuffer
;

: SaveDataBufferAs ( FilenameAddr FilenameLength -- )
	DataBuffer DataBufferSize 2SWAP SaveBuffer
;

: SaveCodeBufferTillThere ( -- )
	CodeBuffer there CodeBuffer - S" code.bin" SaveBuffer
;

\ assembler instructions

: assemble-there ( w -- )
	there w!

	there 2+ DUP
		CodeBufferEnd > IF ABORT" code buffer overflow" THEN
	TO there
;

: count-bits ( x -- u )
	0 { BitsCounter -- }
	DUP IF
		BEGIN
			BitsCounter 1+ TO BitsCounter
			1 RSHIFT
		DUP 0= UNTIL DROP
	THEN
	BitsCounter
;

\ 0 operands

: instruction-0-ops
	CREATE
		, ( instruction_code -- )
	DOES>
		w@ assemble-there
;

: instruction-1-op
	CREATE
		, , ( operand_1_width instruction_code -- )
	DOES>
		OVER OVER CELL+ @ > IF ERR_TOO_BIG_VALUE ABORT" invalid operand: too big value" THEN

		w@ OR assemble-there
;

: instruction-2-ops
	CREATE
		{ Operand2Width Operand1Width InstructionCode -- }
		InstructionCode ,
		Operand1Width ,
		Operand2Width ,
		Operand1Width count-bits ,
	DOES>
		DUP >R w@
		R@ CELL+ @
		R@ 2 CELLS + @
		R> 3 CELLS + @ { Operand2 Operand1 InstructionCode Operand1Width Operand2Width Operand1Bits -- }

		Operand1 Operand1Width > Operand2 Operand2Width > OR IF ERR_TOO_BIG_VALUE ABORT" invalid operand: too big value" THEN

		Operand2 Operand1Bits LSHIFT Operand1 OR InstructionCode OR
		assemble-there
;

\ labels

	4096 CONSTANT ForwardReferencesBufferSize
	ForwardReferencesBufferSize 3 CELLS * ALLOCATE THROW CONSTANT ForwardReferencesBuffer
	0 VALUE ForwardReferencesCounter

	1024 1024 * CONSTANT LabelsBufferSize
	LabelsBufferSize ALLOCATE THROW CONSTANT LabelsBuffer
	LabelsBuffer VALUE LabelsBufferPointer

: _
	CREATE
		there ,
	DOES>
		@ CodeBuffer - 2/
; IMMEDIATE

: prefix-jump ( addr u -- )
	PARSE-WORD 0 { InstructionAddr InstructionLength LabelAddr LabelLength ForwardReferencesOffset -- }

	LabelAddr LabelLength GET-CURRENT SEARCH-WORDLIST IF
		EXECUTE InstructionAddr InstructionLength EVALUATE
	ELSE
		\ jump forward, save and resolve later
		ForwardReferencesCounter 3 CELLS * ForwardReferencesBuffer + TO ForwardReferencesOffset \ get offset to forward references table
		LabelsBufferPointer LabelsBuffer - LabelLength + LabelsBufferSize > IF ERR_TOO_MANY_FORWARD_REFERENCES ABORT" labels buffer overflow" THEN

		LabelAddr LabelsBufferPointer LabelLength CMOVE \ copy label name to labels buffer
		there ForwardReferencesOffset ! \ save address of jump instruction to table
		LabelsBufferPointer ForwardReferencesOffset CELL+ ! \ save label name to table
		LabelLength ForwardReferencesOffset 2 CELLS + ! \ save label name length to table

		LabelsBufferPointer LabelLength + TO LabelsBufferPointer \ save new labels pointer value
		ForwardReferencesCounter 1+ DUP TO ForwardReferencesCounter \ save new forward references counter
		( ForwardReferencesCounter ) ForwardReferencesBufferSize > IF ERR_TOO_MANY_FORWARD_REFERENCES ABORT" forward references buffer overflow" THEN
		0 InstructionAddr InstructionLength EVALUATE
	THEN
;

: resolve-forward-references
	0 0 0 0 { ForwardReferenceOffset LabelAddr LabelLength ThereOffset -- }
	ForwardReferencesCounter 0 ?DO
		I 3 CELLS * ForwardReferencesBuffer + TO ForwardReferenceOffset

		ForwardReferenceOffset @ TO ThereOffset
		ForwardReferenceOffset CELL+ @ TO LabelAddr
		ForwardReferenceOffset 2 CELLS + @ TO LabelLength

		LabelAddr LabelLength GET-CURRENT SEARCH-WORDLIST IF
			LabelAddr LabelLength EVALUATE \ evaluate label
			DUP %1111111111 > ABORT" invalid operand: jump too far" \ only jumps are affected, no need for more sofisticated error checking
		ELSE
			ERR_UNKNOWN_REFERENCE ABORT" invalid operand: unknown reference"
		THEN
			
		ThereOffset w@ OR ThereOffset w! \ insert evaluated label value to precompiled jump command
	LOOP
;

\ registers

	%00000 CONSTANT %aX
	%01000 CONSTANT %bX
	%10000 CONSTANT %cX
	%11000 CONSTANT %dX

	%aX 0 OR DUP CONSTANT %a0 CONSTANT a0
	%aX 1 OR DUP CONSTANT %a1 CONSTANT a1
	%aX 2 OR DUP CONSTANT %a2 CONSTANT a2
	%aX 3 OR DUP CONSTANT %a3 CONSTANT a3
	%aX 4 OR DUP CONSTANT %a4 CONSTANT a4
	%aX 5 OR DUP CONSTANT %a5 CONSTANT a5
	%aX 6 OR DUP CONSTANT %a6 CONSTANT a6
	%aX 7 OR DUP CONSTANT %a7 CONSTANT a7

	%bX 0 OR DUP CONSTANT %b0 CONSTANT b0
	%bX 1 OR DUP CONSTANT %b1 CONSTANT b1
	%bX 2 OR DUP CONSTANT %b2 CONSTANT b2
	%bX 3 OR DUP CONSTANT %b3 CONSTANT b3
	%bX 4 OR DUP CONSTANT %b4 CONSTANT b4
	%bX 5 OR DUP CONSTANT %b5 CONSTANT b5
	%bX 6 OR DUP CONSTANT %b6 CONSTANT b6
	%bX 7 OR DUP CONSTANT %b7 CONSTANT b7

	%cX 0 OR DUP CONSTANT %c0 CONSTANT c0
	%cX 1 OR DUP CONSTANT %c1 CONSTANT c1
	%cX 2 OR DUP CONSTANT %c2 CONSTANT c2
	%cX 3 OR DUP CONSTANT %c3 CONSTANT c3
	%cX 4 OR DUP CONSTANT %c4 CONSTANT c4
	%cX 5 OR DUP CONSTANT %c5 CONSTANT c5
	%cX 6 OR DUP CONSTANT %c6 CONSTANT c6
	%cX 7 OR DUP CONSTANT %c7 CONSTANT c7

	%dX 0 OR DUP CONSTANT %d0 CONSTANT d0
	%dX 1 OR DUP CONSTANT %d1 CONSTANT d1
	%dX 2 OR DUP CONSTANT %d2 CONSTANT d2
	%dX 3 OR DUP CONSTANT %d3 CONSTANT d3
	%dX 4 OR DUP CONSTANT %d4 CONSTANT d4
	%dX 5 OR DUP CONSTANT %d5 CONSTANT d5
	%dX 6 OR DUP CONSTANT %d6 CONSTANT d6
	%dX 7 OR DUP CONSTANT %d7 CONSTANT d7

\ in gforth, numbers with # prefix represent decimal numbers, which is what we need
\ 
\	0 CONSTANT #0
\	1 CONSTANT #1
\	2 CONSTANT #2
\	3 CONSTANT #3
\	4 CONSTANT #4
\	5 CONSTANT #5
\	6 CONSTANT #6
\	7 CONSTANT #7

	0 CONSTANT #a
	1 CONSTANT #b
	2 CONSTANT #c
	3 CONSTANT #d

\ assembler instructions

	%0000000000000000 instruction-0-ops nop
	%0000000000000001 instruction-0-ops wait
	%0000000000000010 instruction-0-ops reset
	%0000000000000011 instruction-0-ops ijmp
	%0000000000000100 instruction-0-ops tof
	%0000000000000101 instruction-0-ops tdc
	%0000000000000110 instruction-0-ops sksp
	%0000000000000111 instruction-0-ops ijsr
	%0000000000001000 instruction-0-ops stop
	%0000000000001000 instruction-0-ops slp \ same as stop
	\ 
	%0000000000001100 instruction-0-ops rts
	%0000000000001101 instruction-0-ops rti

	               %1
	%0000000000001110 instruction-1-op rtsc

	             %111 DUP
	%0000000000010000 instruction-1-op push
	%0000000000011000 instruction-1-op pop

	            %1111 DUP
	%0000000110000000 instruction-1-op sst
	%0000000111000000 instruction-1-op cst

	           %11111 9 *dup
	%0000000000100000 instruction-1-op swap
	%0000000001000000 instruction-1-op neg
	%0000000001100000 instruction-1-op not
	%0000000010000000 instruction-1-op shl
	%0000000010100000 instruction-1-op shr
	%0000000011000000 instruction-1-op shra
	%0000000011100000 instruction-1-op rlc
	%0000000100000000 instruction-1-op rrc
	%0000000100100000 instruction-1-op adc
	%0000000101000000 instruction-1-op sbc

	\ postfix jumps
	      %1111111111 9 *dup
	%1000000000000000 instruction-1-op jmp,
	%1001000000000000 instruction-1-op jsr,
	%1010000000000000 instruction-1-op jz,
	%1010000000000000 instruction-1-op jeq, \ same as jz
	%1011000000000000 instruction-1-op jnz,
	%1011000000000000 instruction-1-op jne, \ same as jnz
	%1100000000000000 instruction-1-op jns,
	%1101000000000000 instruction-1-op js,
	%1110000000000000 instruction-1-op jnc,
	%1111000000000000 instruction-1-op jc,

	        %111
	           %11111 2DUP
	%0000001000000000 instruction-2-ops mtpr
	%0000001100000000 instruction-2-ops mfpr

	\ bic, bis, btt, and btg all have 3 ops
	       %1111
	           %11111 7 *2dup
	%0010100000000000 instruction-2-ops bicl
	%0010101000000000 instruction-2-ops bich
	%0011010000000000 instruction-2-ops bttl
	%0011011000000000 instruction-2-ops btth
	%0011100000000000 instruction-2-ops bisl
	%0011101000000000 instruction-2-ops bish
	%0011110000000000 instruction-2-ops btgl
	%0011111000000000 instruction-2-ops btgh

	      %11111
	           %11111 8 *2dup
	%0000010000000000 instruction-2-ops mov
	%0000100000000000 instruction-2-ops cmp
	%0000110000000000 instruction-2-ops sub
	%0001000000000000 instruction-2-ops add
	%0001010000000000 instruction-2-ops and
	%0001100000000000 instruction-2-ops or
	%0001110000000000 instruction-2-ops xor
	\ 
	%0010110000000000 instruction-2-ops subl
	%0011000000000000 instruction-2-ops addl

	   %11111111
	           %11111 2DUP
	%0100000000000000 instruction-2-ops movl
	%0110000000000000 instruction-2-ops cmpl

	      %1111111
	             %111
	%0010000000000000 instruction-2-ops ldr

\ prefix jumps

: jmp S" jmp," prefix-jump ;
: jsr S" jsr," prefix-jump ;
: jz S" jz," prefix-jump ;
: jeq S" jz," prefix-jump ; \ same as jz
: jnz S" jnz," prefix-jump ;
: jne S" jnz," prefix-jump ; \ same as jnz
: jns S" jns," prefix-jump ;
: js S" js," prefix-jump ;
: jnc S" jnc," prefix-jump ;
: jc S" jc," prefix-jump ;

\ 
\ 
\ test program

			%d4 CONSTANT ta_dr
			%d5 CONSTANT ta_ci
			%b1 CONSTANT pa_dr
			%b2 CONSTANT pb_dr
			%d1 CONSTANT pa_wr
			%d2 CONSTANT pb_wr

			$40 CONSTANT work

: timer_config { inter_h inter_l -- }
			$10 ta_dr movl
			$40 ta_ci movl
			0 ta_dr movl
			inter_l ta_ci movl
			4 ta_dr movl
			inter_h ta_ci movl
;

			%00011011 CONSTANT port_cf

: port_config { p_dr -- }
			port_cf p_dr movl
			$ff p_dr movl
			0 p_dr movl
			0 p_dr movl
			0 p_dr movl
			0 p_dr movl
;

: loop { LoopCountRegister LoopLabel -- }
			1 LoopCountRegister subl
			LoopLabel jnz, \ postfix jumps in compiled words
;

			jmp _START
			nop
			jmp _EXIT
			jmp _ITMRA
			nop
			nop
			nop
			nop

_ _ITMRA
			#d push
			0 #d ldr
			$e ta_dr bich
			#d pop
			rti
			nop
			nop
			jmp _EXIT

_ _START		work #a ldr
			$18 #b ldr
			pa_dr port_config
			pb_dr port_config
			0 #d ldr
			$ff pa_wr movl
			$ff pb_wr movl
			20 %a1 movl
_ _LOOP1		0 %a0 movl
_ _LOOP2		$55 pa_wr movl
			$55 pb_wr movl
			$aa pa_wr movl
			$aa pb_wr movl
			%a0 _LOOP2 loop
			%a1 _LOOP1 loop
			$ff $ff timer_config
			$55 %a4 movl
			$ff %a5 movl
			3 ta_dr movl
			0 %a6 movl
_ _LOOP3		wait
			%a4 pb_wr mov
			%a5 %a4 xor
			%a6 _LOOP3 loop
_ _EXIT			stop

	resolve-forward-references
	SaveCodeBufferTillThere

\	BYE