Tcl" append_word 0" \ jump
Tcl" append_word 0" \ cursor_x
Tcl" append_word 0" \ cursor_y
Tcl" append_word 0" \ first_line

: 2DUP OVER OVER ;
: 2DROP DROP DROP ;
: ROT >R SWAP R> SWAP ;
: -ROT ROT ROT ;
: 2SWAP ROT >R ROT R> ;

\ =================================================================
\ Сравнение.
\ =================================================================
: 0= 0 = ;
: 0< 0 < ;
: <> = NOT ;

\ =================================================================
\ Арифметические и логические операции.
\ =================================================================
: NEGATE NOT 1 + ;
: - NEGATE + ;
: 1+ 1 + ;
: ABS	DUP 0< IF NEGATE THEN ;

: XOR
	2DUP NOT AND
	-ROT SWAP NOT
	AND OR
;

: MIN
	2DUP < IF DROP EXIT THEN
	NIP
;

: MAX
	2DUP < IF NIP EXIT THEN
	DROP
;

: UMUL
	0
	BEGIN
		OVER
	WHILE
		OVER 1 AND
		IF
			ROT SWAP
			OVER +
			ROT SWAP
		THEN
		ROT 1<<
		ROT 1>>
		ROT
	REPEAT
	NIP NIP
;

: *
	2DUP 0< SWAP 0< XOR
	ROT ABS ROT ABS UMUL
	SWAP IF NEGATE THEN
;

\ n1 n2 -- n3 n4
\ n1 - делимое, n2 - делитель, n3 - остаток, n4 - частное.
: U/MOD
	DUP 0= IF 2DROP 0 0 EXIT THEN
	1
	BEGIN
		-ROT DUP 0x8000 AND 0=
	WHILE
		1<< ROT 1<<
	REPEAT
	ROT 0 SWAP
	BEGIN
		DUP
	WHILE
		2SWAP
		2DUP U< NOT IF
			SWAP OVER -
			SWAP 2SWAP SWAP OVER +
			SWAP 2SWAP
		THEN
		1>> 2SWAP 1>>
	REPEAT
	DROP NIP
;

: /
	2DUP 0< SWAP 0< XOR
	ROT ABS ROT ABS U/MOD
	NIP SWAP IF NEGATE THEN
;

: C@
	DUP 1 AND IF
		A@ swap_bytes 0xFF AND EXIT
	THEN
	A@ 0xFF AND
;

: C!
	DUP 1 AND IF
		DUP A@ 0xFF AND
		ROT 0xFF AND swap_bytes
		OR SWAP A! EXIT
	THEN
	DUP A@ 0xFF00 AND
	ROT 0xFF AND
	OR SWAP A!
;

: @
	DUP 1 AND IF
		DUP 1+ A@
		0xFF AND swap_bytes SWAP
		A@ swap_bytes 0xFF AND OR
	ELSE
		A@
	THEN
;

: !
	DUP 1 AND IF
		2DUP C! 1+
		SWAP swap_bytes SWAP C!
	ELSE
		A!
	THEN
;

: +!
	SWAP OVER @
	+ SWAP !
;

: -!
	SWAP OVER @
	- SWAP !
;

\ =================================================================
\ Системные переменные.
\ =================================================================
: BASE 0 Tcl" append_word 10" ; IMMEDIATE
: HERE 0 0 ; IMMEDIATE
: STATE 0 Tcl" append_word 0" ; IMMEDIATE
: LAST 0 0 ; IMMEDIATE

\ =================================================================
\ Операции со строками.
\ =================================================================

: STRCMP
	BEGIN
		2DUP C@ SWAP C@ =
	WHILE
		DUP C@ 0= IF 2DROP 0xFFFF EXIT THEN
		1+ SWAP 1+
	REPEAT
	2DROP 0
;

Tcl" for {set i 0} {$i < 10} {incr i} {append_word 10}"
Tcl" set uitoa_buf [here]"
Tcl" append_word 0"
: UITOA
	Tcl" compile_literal $uitoa_buf"
	SWAP
	BEGIN
		Tcl" compile_literal [expr {$dict(BASE) + 2}]"
		A@ U/MOD -ROT
		DUP 10 U< NOT IF 7 + THEN 48 +
		OVER C! 1- SWAP
		DUP 0=
	UNTIL
	DROP 1+
;

: ITOA
	DUP 0< IF
		NEGATE UITOA 1- DUP 45 SWAP C! ;
	THEN
	UITOA
;

\ Преобразование кода одного символа в число.
\ Если код не соответствует никакому числу, то вернет -1.
: (UATOI)
	DUP DUP 2DUP
	48 U< NOT SWAP 58 U< AND
	-ROT \ n f n n
	65 U< NOT SWAP 71 U< AND
	OR IF
		48 -
		DUP 10 U< NOT IF 7 - THEN
		DUP Tcl" compile_literal [expr {$dict(BASE) + 2}]"
		A@ U< IF EXIT THEN
	THEN
	DROP -1
;

: UATOI
	0 \ addr n1
	BEGIN
		OVER C@ (UATOI) DUP \ addr n1 n n
		-1 <> \ addr n1 n f
	WHILE \ addr n1 n
\		(.") Tcl" compile_string {test1: }" 2DUP . . CR CR
		SWAP \ addr n n1
		Tcl" compile_literal [expr {$dict(BASE) + 2}]"
		A@
\		(.") Tcl" compile_string {test2: }" 2DUP . . CR CR
		UMUL
		+ \ addr n1
		SWAP 1+ SWAP
	REPEAT \ addr n1 n
	DROP NIP
;

: ATOI
	DUP C@ 0x2D = IF
		1+ UATOI NEGATE EXIT
	THEN
	UATOI
;

: ISUNUM C@ (UATOI) -1 = NOT ;
: ISNUM DUP C@ 0x2D = IF 1+ THEN ISUNUM ;

\ Вычисление длины строки (без терминирующего нулевого байта).
: STRLEN
	0
	BEGIN
		SWAP DUP C@
	WHILE
		1+ SWAP 1+
	REPEAT
	DROP
;

\ =================================================================
\ Ввод/вывод.
\ =================================================================
: AT-XY
	DUP 4 A! 0x6604 A!
	DUP 2 A! 0x6602 A!
;

: SCROLL
	6 A@ 1 +
	DUP 75 = IF
		DROP 0
	THEN
	DUP 0x6600 A!
	DUP 6 A!
	\ Определение номера нижней строки.
	DUP IF
		1-
	ELSE
		DROP 74
	THEN
	\ В стеке - номер нижней строки.
	\ 128 * 0x4000 +
	swap_bytes 1>> 0x3F80 AND
	0x3FFF +
	\ Заполнение нижней строки пробелами.
	100 BEGIN
		OVER OVER +
		0x20 SWAP A!
		1- DUP 0 =
	UNTIL
	DROP DROP
;

: CR
	4 A@ 74 = IF
		0 74 AT-XY SCROLL EXIT
	THEN
	0 4 A@ 1+ AT-XY
;

: EMIT
	4 A@ 6 A@ +
	74 OVER < IF -75 + THEN \ если 4 + 6 > 74, то отнять 75.
	swap_bytes 1>> \ 7 <<
	0x3F80 AND
	2 A@
	+ 0x4000 + A!
	\ Если 2 = 99, то вызвать cr.
	2 A@
	99 = IF CR EXIT THEN
	2 A@ 1+ 4 A@ AT-XY
;

: SPACE 0x20 EMIT ;

: BS
	2 A@ \ cursor_x
	DUP IF
		1-
		4 A@ \ cursor_x
		OVER OVER AT-XY SPACE AT-XY
	ELSE
		DROP
	THEN
;

: TYPE
	BEGIN
		DUP C@ DUP
	WHILE
		EMIT 1+
	REPEAT
	2DROP
;

\ 0x7000 - Указатель начала очереди. Чтение и запись.
\ 0x7002 - Указатель конца очереди. Только чтение.
\ 0x7004 - Значение клавиши в начале очереди. Только чтение.
: KEY
	BEGIN
		0x7000 A@ 0x7002 A@ OVER =
	WHILE
		DROP
	REPEAT
	1+ 0x7000 A!
	0x7004 A@
;

: KEY?
	0x7000 A@ 0x7002 A@ = NOT
;

: ACCEPT
	OVER + 1- OVER
	BEGIN
		KEY
		DUP 0x0D = IF
			\ Была нажата клавиша Enter.
			DROP 0 SWAP C!
			DROP EXIT
		THEN
		DUP 0x08 = IF
			\ Была нажата клавиша backspace.
			DROP ROT
			2DUP = IF
				-ROT
			ELSE
				-ROT 1- BS
			THEN
		ELSE
			-ROT 2DUP = IF
				ROT DROP
			ELSE
				ROT DUP EMIT
				OVER C! 1+
			THEN
		THEN
	AGAIN
;

: (.")
	Tcl" set print [here]"
	R>
	BEGIN
		DUP C@ DUP
	WHILE
		EMIT 1+
	REPEAT
	DROP 1+
	DUP 1 AND
	IF 1+ THEN
	>R
;

: . ITOA TYPE SPACE ;
: U. UITOA TYPE SPACE ;

Tcl" set dots_depth [here]; append_word 0; set dots_buf [here]; for {set i 0} {$i <= 32} {incr i} {append_word 0}"
: .S
	\ Запись первоначального размера стека.
	DEPTH Tcl" compile_literal $dots_depth" A!
	\ Перенос всего из стека в буфер.
	BEGIN
		DEPTH
	WHILE
		DEPTH 1<<
		Tcl" compile_literal $dots_buf"
		+ A!
	REPEAT
	\ Перенос из буфера в стек.
	BEGIN
		DEPTH Tcl" compile_literal $dots_depth" A@
		= NOT
	WHILE
		Tcl" compile_literal $dots_buf"
		DEPTH 1<< + A@ DUP .
	REPEAT
;

: 0SP
	BEGIN
		DEPTH
	WHILE
		DROP
	REPEAT
;

\ =================================================================
\ =================================================================
: FREE
	0x4000
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ -
;

: ALLOT
	DUP FREE U< IF
		Tcl" compile_literal [expr {$dict(HERE) + 2}]"
		A@ +
		Tcl" compile_literal [expr {$dict(HERE) + 2}]"
		A!
	ELSE
		(.") Tcl" compile_string {Out of memory}"
		Tcl" set allot_abort [here]"
		BEGIN AGAIN
	THEN
;

: A,
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ A!
	2 ALLOT
;

: C,
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ C!
	1 ALLOT
;

: S,
	BEGIN \ addr
		DUP C@ DUP \ addr c c
	WHILE
		C, 1+
	REPEAT
	C, DROP
;

: LITERAL
	DUP 0< IF
		NOT 0x8000 OR A,
		0x6600 A,
	ELSE
		0x8000 OR A,
	THEN
; IMMEDIATE

: DOVAR
	R>
	Tcl" compile_literal [expr {$dict(STATE) + 2}]"
	A@ IF LITERAL THEN
;

Tcl" replace_word $dict(BASE) [expr {($dict(DOVAR) >> 1) | 0x4000}]"
Tcl" replace_word $dict(HERE) [expr {($dict(DOVAR) >> 1) | 0x4000}]"
Tcl" replace_word $dict(STATE) [expr {($dict(DOVAR) >> 1) | 0x4000}]"
Tcl" replace_word $dict(LAST) [expr {($dict(DOVAR) >> 1) | 0x4000}]"

: DOCON
	R> A@
	Tcl" compile_literal [expr {$dict(STATE) + 2}]"
	A@ IF LITERAL THEN
;

: DOISTR
	Tcl" compile_literal [expr {$dict(STATE) + 2}]"
	A@ IF
		R> A@ A,
	THEN
;

: A! A! ;
: A@ DOISTR A@ ; IMMEDIATE
: + DOISTR + ; IMMEDIATE
: 1- DOISTR 1- ; IMMEDIATE
: AND DOISTR AND ; IMMEDIATE
: OR DOISTR OR ; IMMEDIATE
: DUP DOISTR DUP ; IMMEDIATE
: DROP DOISTR DROP ; IMMEDIATE
: OVER DOISTR OVER ; IMMEDIATE
: SWAP DOISTR SWAP ; IMMEDIATE
: NIP DOISTR NIP ; IMMEDIATE
: NOT DOISTR NOT ; IMMEDIATE
: 1>> DOISTR 1>> ; IMMEDIATE
: 1<< DOISTR 1<< ; IMMEDIATE
: U< DOISTR U< ; IMMEDIATE
: < DOISTR < ; IMMEDIATE
: >R DOISTR >R ; IMMEDIATE
: R> DOISTR R> ; IMMEDIATE
: DEPTH DOISTR DEPTH ; IMMEDIATE
: = DOISTR = ; IMMEDIATE

\ =================================================================
\ =================================================================
: >NAME
	6 -
	BEGIN
		DUP C@
	WHILE
		1-
	REPEAT
	1+
;

: WORDS
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A@
	BEGIN
		DUP >NAME TYPE SPACE
		2 - A@ DUP
	WHILE REPEAT
	DROP
;

: EXECUTE >R ;

: TIB DOVAR
	Tcl" for {set i 0} {$i < 75} {incr i} {append_word 0}"
; IMMEDIATE

: TIBPTR DOVAR 0 ; IMMEDIATE

: TRUE DOCON Tcl" append_word 0xFFFF" ; IMMEDIATE
: FALSE DOCON Tcl" append_word 0" ; IMMEDIATE

: DECIMAL
	10
	Tcl" compile_literal [expr {$dict(BASE) + 2}]"
	A!
;

: HEX
	16
	Tcl" compile_literal [expr {$dict(BASE) + 2}]"
	A!
;

\ =================================================================
\ Интерпретатор.
\ =================================================================
\ Так как в этом форте используются нуль-терминированные строки,
\ то нет смысла пытаться придерживатся какого-нибудь стандарта в реализации интерпретатора.
\ TIB ( -- addr ) возвращает адрес входного буфера.
\ TIBPTR ( -- addr ) переменная, указывающая на интерпертируемую строку.
\ WORD ( <char> -- addr ) выделяет (ограничивает нулем) слово ограниченное разделителем <char> из строки, на которую указывает TIBPTR.
\ Оставляет адрес нуль-терминированной строки. В TIBPTR сохраняется адрес оставшейся строки.
\ INTERPRET ( addr -- ?? ) Сохраняет addr в TIBPTR, а потом...

: FIND
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A@
	BEGIN
		2DUP >NAME STRCMP IF
			DUP 3 -
			C@ 2 <> IF
				NIP DUP 3 - C@ EXIT
			THEN
		THEN
		2 - A@ DUP 0=
	UNTIL
	2DROP 0 0
;

: [
	0
	Tcl" compile_literal [expr {$dict(STATE) + 2}]"
	A!
; IMMEDIATE

: ]
	1
	Tcl" compile_literal [expr {$dict(STATE) + 2}]"
	A!
; IMMEDIATE

: HIDE
	2
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A@ 3 - C!
;

: UNHIDE
	0
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A@ 3 - C!
;

: IMMEDIATE
	1
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A@ 3 - C!
;

: WORD
	Tcl" compile_literal [expr {$dict(TIBPTR) + 2}]"
	A@
	BEGIN
		OVER OVER C@ =
		OVER C@ AND
	WHILE
		1+
	REPEAT
	SWAP OVER
	BEGIN
		OVER OVER C@ DUP
		ROT <> AND
	WHILE
		1+
	REPEAT
	NIP DUP C@ IF
		DUP 0 SWAP C! 1+
	THEN
	Tcl" compile_literal [expr {$dict(TIBPTR) + 2}]"
	A!
;

: HEADER
	0x20 WORD DUP STRLEN
	1 AND 0= IF
		0 C,
	THEN
	0 C, S, 0 C,
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A@ A,
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A!
;

: : HEADER HIDE ] ;
: ; 0x700C A, UNHIDE [ ; IMMEDIATE

: INTERPRET
	Tcl" compile_literal [expr {$dict(TIBPTR) + 2}]"
	A!
	BEGIN
		0x20 WORD \ str
		DUP C@ 0= IF DROP EXIT THEN
		DUP FIND \ str w-addr p
		OVER IF
			Tcl" compile_literal [expr {$dict(STATE) + 2}]"
			A@ IF
				\ Режим компиляции.
				IF
					NIP EXECUTE
				ELSE
					NIP 1>> 0x4000 OR A,
				THEN
			ELSE
				\ Режим интерпретации.
				DROP NIP EXECUTE
			THEN
		ELSE \ str w-addr p
			\ Такого слова в словаре нет.
			2DROP DUP ISNUM IF \ str
				ATOI
				Tcl" compile_literal [expr {$dict(STATE) + 2}]"
				A@ IF
					LITERAL
				THEN
			ELSE \ str
				(.") Tcl" compile_string {Unknown token: }"
				TYPE CR
				Tcl" set interpret_abort [here]"
				BEGIN AGAIN
			THEN
		THEN
	AGAIN
;

: QUIT
	0
	Tcl" compile_literal [expr {$dict(STATE) + 2}]"
	A!
	BEGIN
		CR
		Tcl" compile_literal [expr {$dict(STATE) + 2}]"
		A@ IF
			(.") Tcl" compile_string {compile: }"
		ELSE
			(.") Tcl" compile_string {> }"
		THEN
		Tcl" compile_literal [expr {$dict(TIB) + 2}]"
		150 ACCEPT SPACE INTERPRET
	AGAIN
;

: ABORT 0SP QUIT ;
Tcl" replace_word $interpret_abort [expr {($dict(ABORT) >> 1) | 0x4000}]"
Tcl" replace_word $allot_abort [expr {($dict(ABORT) >> 1) | 0x4000}]"

: COLD
	Tcl" replace_word 0 [expr {[here] >> 1 }]"
	CR (.") Tcl" compile_string {NedoForth v0.1d Initialized}"
	CR FREE . (.") Tcl" compile_string {bytes free.}" CR
	QUIT
;

: VARIABLE
	HEADER Tcl" compile_literal $dict(DOVAR)" 1>> 0x4000 OR
	A, 0 A, IMMEDIATE
;

: CONSTANT
	HEADER Tcl" compile_literal [expr {($dict(DOCON) >> 1) | 0x4000}]"
	A, A, IMMEDIATE
;

: '
	0x20 WORD
	DUP FIND DROP
	DUP IF
		NIP
	ELSE
		DROP
		(.") Tcl" compile_string {Unknown token: }"
		TYPE CR ABORT
	THEN
;

: POSTPONE
	DUP IF
		1>> 0x4000 OR A,
	THEN
; IMMEDIATE

: BEGIN
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ 1>>
; IMMEDIATE

: AGAIN A, ; IMMEDIATE

: UNTIL 0x2000 OR A, ; IMMEDIATE

: WHILE
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ 0 A,
; IMMEDIATE

: REPEAT
	SWAP A,
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ 1>> 0x2000 OR SWAP A!
; IMMEDIATE

: DO
	24903 A,
	24903 A,
	Tcl" compile_literal [expr {$dict(HERE) + 2}]" A@
; IMMEDIATE

: (loop)
	R> R> R>
	1+
	2DUP = IF
		DROP DROP 2 + >R
	ELSE
		>R >R A@ >R
	THEN
;

: LOOP
	Tcl" compile_literal [expr {(($dict(\(loop\)) >> 1) | 0x4000)}]"
	A, A,
; IMMEDIATE

: I
	R> R> R@ SWAP
	>R SWAP >R
;

: J
	R> R> R> R> R@
	SWAP >R SWAP >R SWAP >R SWAP >R
;

: (TIMES)
	>R >R
	BEGIN
		R> DUP
	WHILE
		1- R> DUP
		-ROT >R >R
		EXECUTE
	REPEAT
	R> 2DROP
;

: TIMES
	Tcl" compile_literal [expr {$dict(STATE) + 2}]"
	A@ IF
		' LITERAL
		Tcl" compile_literal $dict(\(TIMES\))"
		1>> 0x4000 OR A,
	ELSE
		'
		Tcl" append_word [expr {$dict(\(TIMES\)) >> 1}]"
	THEN
; IMMEDIATE

: IF
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@
	8192 A,
; IMMEDIATE

: THEN
	DUP A@
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@
	1>> OR SWAP A!
; IMMEDIATE

: ELSE
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@
	SWAP 0 A,
	Tcl" compile_word THEN"
; IMMEDIATE

: ."
	Tcl" compile_literal [expr {($print >> 1) | 0x4000}]"
	A,
	0x22 WORD S,
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ 1 AND IF 0 C, THEN
; IMMEDIATE

: CREATE
	HEADER
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A@ 4 +
	0x8000 OR A,
	0x700C A,
;

: (dodoes)
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A@ 2 +
	R> 1>>
	SWAP A!
;

: DOES>
	Tcl" compile_literal [expr {($dict(\(dodoes\)) >> 1) | 0x4000}]"
	A,
; IMMEDIATE

: CELL DOCON Tcl" compile_word 2" ; IMMEDIATE
: CELLS DOISTR 1<< ; IMMEDIATE

: FORGET
	' DUP 1- 1- A@
	Tcl" compile_literal [expr {$dict(LAST) + 2}]"
	A! >NAME 1- 1 NOT AND
	Tcl" compile_literal [expr {$dict(HERE) + 2}]"
	A!
;

\ =================================================================
\ Для майнкрафта.
\ =================================================================
: TICK 1 28680 A! ;

: TICKS
	BEGIN
		TICK DUP
	WHILE
		1-
	REPEAT
	DROP
;

: NBP! 28690 A! ;

: IOXADDR DOVAR Tcl" append_word 1" ; IMMEDIATE

: IOX!
	Tcl" compile_literal [expr {$dict(IOXADDR) + 2}]"
	A@ NBP!
	29954 A!
;

: IOX@
	Tcl" compile_literal [expr {$dict(IOXADDR) + 2}]"
	A@ NBP!
	29952 A@
;

: IOXSET
	Tcl" compile_literal [expr {$dict(IOXADDR) + 2}]"
	A@ NBP!
	29954 A@ OR
	29954 A!
;

: IOXRST
	Tcl" compile_literal [expr {$dict(IOXADDR) + 2}]"
	A@ NBP!
	NOT
	29954 A@ AND
	29954 A!
;

: UTIME@
	28682 A@
	28684 A@
;

Tcl" replace_word [expr {$dict(LAST) + 2}] $last_word"
Tcl" replace_word [expr {$dict(HERE) + 2}] [here]"