;---------------------------------------------------------
; MS Forth 2.0beta
; Kelly Abrantes Murta - Janeiro de 2010
;
; Desenvolvido a partir do Forth de Thomas Low publicado
; na revista Micro Sistemas Nr. 39/Dezembro 1984.
; 
;
; Célula de 16 bits, 8 bits char, 8 bits (1 byte) para
; unidade de endereçamento.
;
;    Z80 BC =       IP   Interpreter Pointer
;        DE =       W    working register
;      A,HL =       temporários
;        SP =       PSP  Param Stack Pointer
;     (RSP) =       RSP  Return Stack Pointer
;
;
; Obs.: O desenvolvimento desse sistema foi interrompido 
; para dar início a um novo projeto, o ZX81 Toddy Forth.
; Embora o Toddy Forth tenha partido do MS Forth 2.0beta,
; ele é um sistema inteiramente novo com grande parte do
; código totalmente reescrito e adoção do Direct Threaded
; Code (DTC).
;

#define AUTORUN line1
;#define AUTORUN dfile

#include sysvars.asm
#include line0.asm



S0:		ds	2	;Valor inicial da pilha de parâmetros
R0:		ds	2	;Valor inicial da pilha de retorno
TIB:		ds	2	;Terminal Input Buffer
LBP:		ds	2	;Line Buffer Pointer
RSP:		ds	2	;Return Stack Pointer
DP:		dw	last+64	;Dictionary Pointer
CONTEXT:	dw	LAST	;Ponteiro para o vocabulário no qual
				;as buscas no dicionário se iniciam
CURRENT:	dw	LAST	;Ponteiro para o vocabulário no qual as
				;novas definições são criadas
STATE:		ds	2	;Indica se está em estado de compilação ou de execução
BASE:		ds	2	;Base numérica corrente, usada na impressão de números
HLD:		ds	2	;Endereço corrente dentro do PAD
MODE:           ds	2       ;Indica se palavra imediata ou não-imediata

CUR_POS:	ds	2	;Position of cursor on the screen

LAST:           dw W_CSAVE      ;Última palavra definida no vocabulário CURRENT
COMPILER:       dw W_REPEAT     ;Última palavra definida no vocabulário COMPILER


;-----------------------
; Inicialização do Forth
;-----------------------
; Endereço de entrada para iniciar o Forth

START:  call    C_SETCHR
        ld	hl,C_COLD
	jp	NEXT_ADDR


; ****************
; ** KEY TABLES **
; ****************

; -------------------------------
; THE 'UNSHIFTED' CHARACTER CODES
; -------------------------------

K_UNSHIFT:
        db    $5a             ; Z
        db    $58             ; X
        db    $43             ; C
        db    $56             ; V
        db    $41             ; A
        db    $53             ; S
        db    $44             ; D
        db    $46             ; F
        db    $47             ; G
        db    $51             ; Q
        db    $57             ; W
        db    $45             ; E
        db    $52             ; R
        db    $54             ; T
        db    $31             ; 1
        db    $32             ; 2
        db    $33             ; 3
        db    $34             ; 4
        db    $35             ; 5
        db    $30             ; 0
        db    $39             ; 9
        db    $38             ; 8
        db    $37             ; 7
        db    $36             ; 6
        db    $50             ; P
        db    $4f             ; O
        db    $49             ; I
        db    $55             ; U
        db    $59             ; Y
        db    $0d             ; NEWLINE
        db    $4c             ; L
        db    $4b             ; K
        db    $4a             ; J
        db    $48             ; H
        db    $20             ; SPACE
        db    $2e             ; .
        db    $4d             ; M
        db    $4e             ; N
        db    $42             ; B

; -----------------------------
; THE 'SHIFTED' CHARACTER CODES
; -----------------------------


K_SHIFT:
        db    $3a             ; :
        db    $3b             ; ;
        db    $3f             ; ?
        db    $2f             ; /
        db    $00             ;
        db    $00             ;
        db    $00             ;
        db    $00             ;
        db    $00             ;
        db    $5b             ; [
        db    $5d             ; ]
        db    $25             ; %
        db    $26             ; &
        db    $27             ; '
        db    $21             ; !
        db    $40             ; @
        db    $23             ; #
        db    $24             ; $
        db    $02             ; KEY LEFT
        db    $08             ; BACKSPACE
        db    $5e             ; ^
        db    $03             ; KEY RIGHT
        db    $01             ; KEY UP
        db    $04             ; KEY DOWN
        db    $22             ; "
        db    $29             ; )
        db    $28             ; (
        db    $24             ; $
        db    $5f             ; _
        db    $00             ;
        db    $3d             ; =
        db    $2b             ; +
        db    $2d             ; -
        db    $5c             ; \
        db    $00             ;
        db    $2c             ; ,
        db    $3e             ; >
        db    $3c             ; <
        db    $2a             ; *


; ------------------
; char-set (symbols)
; ------------------

SET0:

; $20 - Character: ' '          CHR$(32)

        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000

; $21 - Character: '!'          CHR$(33)

        db    %00000000
        db    %00010000
        db    %00010000
        db    %00010000
        db    %00010000
        db    %00000000
        db    %00010000
        db    %00000000

; $22 - Character: '"'          CHR$(34)

        db    %00000000
        db    %00100100
        db    %00100100
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000

; $23 - Character: '#'          CHR$(35)

        db    %00000000
        db    %00001001
        db    %00010010
        db    %01111111
        db    %00100100
        db    %11111110
        db    %01001000
        db    %10010000

; $24 - Character: '$'          CHR$(36)

        db    %00000000
        db    %00001000
        db    %00111110
        db    %00101000
        db    %00111110
        db    %00001010
        db    %00111110
        db    %00001000

; $25 - Character: '%'          CHR$(37)

        db    %00000000
        db    %01100010
        db    %01100100
        db    %00001000
        db    %00010000
        db    %00100110
        db    %01000110
        db    %00000000

; $26 - Character: '&'          CHR$(38)

        db    %00000000
        db    %00010000
        db    %00101000
        db    %00010000
        db    %00101010
        db    %01000100
        db    %00111010
        db    %00000000

; $27 - Character: '''          CHR$(39)

        db    %00000000
        db    %00010000
        db    %00010000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000

; $28 - Character: '('          CHR$(40)

        db    %00000000
        db    %00000100
        db    %00001000
        db    %00001000
        db    %00001000
        db    %00001000
        db    %00000100
        db    %00000000

; $29 - Character: ')'          CHR$(41)

        db    %00000000
        db    %00100000
        db    %00010000
        db    %00010000
        db    %00010000
        db    %00010000
        db    %00100000
        db    %00000000

; $2A - Character: '*'          CHR$(42)

        db    %00000000
        db    %00000000
        db    %00010100
        db    %00001000
        db    %00111110
        db    %00001000
        db    %00010100
        db    %00000000

; $2B - Character: '+'          CHR$(43)

        db    %00000000
        db    %00000000
        db    %00001000
        db    %00001000
        db    %00111110
        db    %00001000
        db    %00001000
        db    %00000000

; $2C - Character: ','          CHR$(44)

        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00001000
        db    %00001000
        db    %00010000

; $2D - Character: '-'          CHR$(45)

        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00111110
        db    %00000000
        db    %00000000
        db    %00000000

; $2E - Character: '.'          CHR$(46)

        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00011000
        db    %00011000
        db    %00000000

; $2F - Character: '/'          CHR$(47)

        db    %00000000
        db    %00000000
        db    %00000010
        db    %00000100
        db    %00001000
        db    %00010000
        db    %00100000
        db    %00000000


SET1:
; $3A - Character: ':'          CHR$(58)

        db    %00000000
        db    %00000000
        db    %00000000
        db    %00010000
        db    %00000000
        db    %00000000
        db    %00010000
        db    %00000000

; $3B - Character: ';'          CHR$(59)

        db    %00000000
        db    %00000000
        db    %00010000
        db    %00000000
        db    %00000000
        db    %00010000
        db    %00010000
        db    %00100000

; $3C - Character: '<'          CHR$(60)

        db    %00000000
        db    %00000000
        db    %00000100
        db    %00001000
        db    %00010000
        db    %00001000
        db    %00000100
        db    %00000000

; $3D - Character: '='          CHR$(61)

        db    %00000000
        db    %00000000
        db    %00000000
        db    %00111110
        db    %00000000
        db    %00111110
        db    %00000000
        db    %00000000

; $3E - Character: '>'          CHR$(62)

        db    %00000000
        db    %00000000
        db    %00010000
        db    %00001000
        db    %00000100
        db    %00001000
        db    %00010000
        db    %00000000

; $3F - Character: '?'          CHR$(63)

        db    %00000000
        db    %00111100
        db    %01000010
        db    %00000100
        db    %00001000
        db    %00000000
        db    %00001000
        db    %00000000

; $40 - Character: '@'          CHR$(64)

        db    %00000000
        db    %00111100
        db    %01001010
        db    %01010110
        db    %01011110
        db    %01000000
        db    %00111100
        db    %00000000

SET3:
; $5B - Character: '['          CHR$(91)

        db    %00000000
        db    %00001110
        db    %00001000
        db    %00001000
        db    %00001000
        db    %00001000
        db    %00001110
        db    %00000000

; $5C - Character: '\'          CHR$(92)

        db    %00000000
        db    %00000000
        db    %01000000
        db    %00100000
        db    %00010000
        db    %00001000
        db    %00000100
        db    %00000000

; $5D - Character: ']'          CHR$(93)

        db    %00000000
        db    %01110000
        db    %00010000
        db    %00010000
        db    %00010000
        db    %00010000
        db    %01110000
        db    %00000000

; $5E - Character: '^'          CHR$(94)

        db    %00000000
        db    %00010000
        db    %00111000
        db    %01010100
        db    %00010000
        db    %00010000
        db    %00010000
        db    %00000000

; $5F - Character: '_'          CHR$(95)

        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %00000000
        db    %11111111


; ---

WAIT_KEY:
	call	KSCAN
        ld      b,h
        ld      c,l
        ld      d,c
        inc     d
        jr      z,WAIT_KEY      	;
        ld      (LAST_K),hl		;LAST-KEY
        call    DECODEKEY
        jr      nc,WAIT_KEY             ;jump back in case of multiples keys
	ld	de,K_UNSHIFT-$7e
	add	hl,de
        ret

; ---

;; Auto Repeat Key
REP_KEY:
	ld      hl,($407b)		;sv Time - Autorepeat timer
        ld      a,h
        or      l
        call    ST_DLY
        jr      nz,W_DLY
        ld      hl,$0020
W_DLY:  ld      ($407b),hl
R_KEY:  call    KSCAN
        ld      c,l
        inc     c
        jr      z,ST_DLY		;
        ld      de,(LAST_K)		;LAST-KEY
        and     a
        sbc     hl,de
        jr      nz,R_KEY		;
        ld      hl,($407b)
        dec     hl
        ld      ($407b),hl		;sv Time - Autorepeat timer
        ld      a,h
        or      l
        jr      nz,R_KEY		;
	ret

ST_DLY:
	ld	hl,$300
	ld	($407b),hl
	ret

; ---


X_KEY:	exx
NOKEY:  call	REP_KEY
	call	WAIT_KEY
        ld      a,(hl)
	or	a
	jr	z,NOKEY
	exx
	ret

;---

X_CLS:
        ld      hl,(D_FILE)
        inc     hl
        ld      (CUR_POS),hl
        ld      bc,$0418
CLS2:   ld      a,(hl)
        cp      $76
        jr      z,CLS1
        ld      (hl),$00
CLS1:   inc     hl
        dec     c
        jr      nz,CLS2
        djnz    CLS2
        ret


; ----------------
; Subrotina 'EMIT'
; ----------------
; Na chamada, o acumulador contém o código do caracter a ser enviado à tela.

X_EMIT: exx
        ld      hl,(CUR_POS)
        cp      $0d                     ; NEWLINE ?
        jr      z,EMIT_CR               ; Salta se o caracter for NEWLINE
        cp      $08                     ; Backspace ?
        jr      z,BACKSPACE             ; Salta se for Backspace (shift 0)
        sub     $20			; ajusta código ASCII para faixa 0-63
        xor     $00                     ; armazene $80 aqui para gerar chars invertidos,
                                        ; conforme usado na definição da palavra REVERSE
        and     $bf                     ; apaga bit 6 do código do caracter
	ld      (hl),a
	inc     hl
	ld	a,(hl)
	cp      $76
        jr      nz,AT_CUR_POS
        inc     hl
QSCR:   call    QSCR_UP                 ; Verifica se foi ultrapassado o limite da tela

AT_CUR_POS:
        ld      (CUR_POS),hl
        exx
        ret

EMIT_CR:
        ld      a,(hl)
        inc     hl
        cp      $76
        jr      nz,EMIT_CR
        jr      QSCR

BACKSPACE:
        dec     hl
        ld      a,(hl)
        cp      $76
        jr      nz,QINICIO_DFILE
        dec     hl
QINICIO_DFILE:
        ld      de,(D_FILE)
        or      a                       ; Zera carry
	ex	de,hl
        sbc     hl,de
	ex	de,hl
        jr      c,APAGA_POS             ; Salta se não houver atingido o início do Dfile
        inc     hl
        inc     hl
APAGA_POS:
        ld      (hl),$00                ; Apaga posição da tela
        jr      AT_CUR_POS

; Verifica se é necessário fazer o scroll da tela
QSCR_UP:
        ld      de,(VARS)
        or      a                       ; Zera carry
        ex	de,hl
        sbc     hl,de
        ex	de,hl
        ret	nz

;--------------------
; Subrotina SCROLL UP
;--------------------

SCRUP:  ld      hl,$21
        ld      de,(D_FILE)
        add     hl,de
        ld      bc,$2f7
        ldir
	xor	a
	ld	b,$20
	ex	de,hl
	push    hl
SCRUP1:
        inc     hl
        ld      (hl),a
        djnz    SCRUP1
        pop     hl
        inc     hl
        ret


;---
; Set the characters table

C_SETCHR:

	exx
	ld	hl,SET0			;chars $20-$2f
	ld	de,$3000
	ld	bc,$80
	ldir
	ld	hl,$1ee0		;chars $30-$39 (digits)
	ld	c,$50
	ldir
	ld	hl,SET1			;chars $3a-$40
	ld	c,$38
	ldir
	ld	hl,$1f30		;chars $41-$5a (alphabet)
	ld	c,$d0
	ldir
	ld	hl,SET3			;chars $5b-$5f
	ld	c,$28
	ldir
	ld	a,$30
	ld	i,a
	exx
	ret


C_STOP:
        dw      $+2

        ld      hl,(RSP)
        ld      c,(hl)
        inc     hl
        ld      b,(hl)
        inc     hl
        ld      (RSP),hl
        jr      NEXT

DPUSH:  push    de
HPUSH:  push    hl
NEXT:	ld      a,(bc)		;(W)<--((IP))
	ld      l,a		;
	inc     bc		;INC IP
	ld      a,(bc)		;
	ld      h,a		;(HL)<--CFA
	inc     bc		;INC IP
NEXT_ADDR:
	ld      e,(hl)		;(PC)<--((W))
	inc     hl		;
	ld      d,(hl)		;
	ex      de,hl		;
	jp      (hl)		;NOTE: (DE)=PFA-1


; ----------------
; THE 'COLON' CODE
; ----------------

E_COLON:
        ld      hl,(RSP)
        dec     hl
        ld      (hl),b
        dec     hl
        ld      (hl),c
        inc     de
        ld      c,e
        ld      b,d
        ld      (RSP),hl
        jr      NEXT

; -----------------------------------------------------
; Aqui inicia-se a definição das palavras do dicionário
; -----------------------------------------------------

; -------------
; *IF ( f --  )
; Rotina de tempo de execução que executa um salto condicional para a frente.
; Se f for falso, o byte seguinte é adicionado ao IP para efetuar um salto
; para a frente. Compilado por IF e WHILE.
;

W_STARIF:
        db $03,"*IF"             ; NFA
        dw $0000                 ; LFA - end of linked list.
C_STARIF:                        ; CFA
        dw $+2                   ;

        pop     hl               ;recupera valor da pilha
        ld      a,l              ;verifica se é zero (false)
        or      h                ;
        jr      z,SELSE          ;Se for zero, executa *ELSE
        inc     bc               ;caso contrário, incrementa IP e continua
        jp      NEXT             ;execução.


; ----------------
; *ELSE   (  --  )
; Rotina de tempo de execução que executa um salto incondicional para a frente.
; O byte seguinte é adicionado ao IP para efetuar um salto para a frente.
; Compilado por ELSE.
;

W_STARELSE:
        db $05,"*ELSE"
        dw W_STARIF
C_STARELSE:
        dw $+2

SELSE:  ld      a,(bc)           ;offset em A
        add     a,c              ;adiciona ao IP
        ld      c,a              ;
        jr      nc,SELSE1        ;
        inc     b                ;
SELSE1: jp      NEXT             ;continua a execução a partir do novo IP


; ----------------
; *END   ( f --  )
; Rotina de tempo de execução que executa um salto condicional para trás.
; Se f for falso, o byte seguinte é adicionado ao IP para efetuar um salto
; para trás. Compilado por UNTIL.
;

W_STAREND:
        db $04,"*END"
        dw W_STARELSE
C_STAREND:
        dw $+2

        pop     hl               ;recupera valor da pilha
        ld      a,l              ;verifica se é zero (false)
        or      h                ;
        jp      z,SWHILE         ;Se for zero, executa *WHILE
        inc     bc               ;caso contrário, incrementa IP e continua
        jp      NEXT             ;execução.


; ----------------
; *WHILE  (  --  )
; Rotina de tempo de execução que executa um salto incondicional para trás.
; O byte seguinte é adicionado ao IP para efetuar um salto para trás.
; Compilado por AGAIN e REPEAT.
;

W_STARWHILE:
        db $06,"*WHILE"
        dw W_STAREND
C_STARWHILE:
        dw $+2

SWHILE: ld      a,(bc)           ;offset em A
        add     a,c              ;adiciona ao IP
        ld      c,a              ;
        jr      c,SWHILE1        ;
        dec     b                ;
SWHILE1:
        jp      NEXT             ;continua a execução a partir do novo IP

; ---------------------
; +!  (n addr --  )
; Adiciona n ao valor contido em addr.
; Pronuncia-se "plus-store"
;

W_PLUSSTORE:
        db $02,"+!"
        dw W_STARWHILE
C_PLUSSTORE:
        dw $+2

        pop     hl
        pop     de
        ld      a,(hl)
        add     a,e
        ld      (hl),a
        inc     hl
        ld      a,(hl)
        adc     a,d
        ld      (hl),a
        jp      NEXT

; --------------
; 1+  (n1 -- n2)
; Adiciona 1 ao valor no topo da pilha.
;

W_ONEPLUS:
        db $02,"1+"
        dw W_PLUSSTORE
C_ONEPLUS:
        dw $+2

        pop     hl
        inc     hl
        jp      HPUSH

; --------------
; 2+  (n1 -- n2)
; Adiciona 2 ao valor no topo da pilha.
;

W_TWOPLUS:
        db $02,"2+"
        dw W_ONEPLUS
C_TWOPLUS:
        dw $+2

        pop     hl
        inc     hl
        inc     hl
        jp      HPUSH

; --------------
; 1-  (n1 -- n2)
; Subtrai 1 do valor no topo da pilha.
;

W_ONEMINUS:
        db $02,"1-"
        dw W_TWOPLUS
C_ONEMINUS:
        dw $+2

        pop     hl
        dec     hl
        jp      HPUSH

; --------------
; 2-  (n1 -- n2)
; Subtrai 2 do valor no topo da pilha.
;

W_TWOMINUS:
        db $02,"2-"
        dw W_ONEMINUS
C_TWOMINUS:
        dw $+2

        pop     hl
        dec     hl
        dec     hl
        jp      HPUSH

; --------------
; 2*  (n1 -- n2)
; Multiplica por 2 (left shift rotate).
;

W_2STAR:
        db $02,"2*"
        dw W_TWOMINUS
C_2STAR:
        dw $+2

        pop     hl
        add	hl,hl
        jp      HPUSH

; --------------
; 2/  (n1 -- n2)
; Divide por 2 (right shift rotate).
;

W_2SLASH:
        db $02,"2/"
        dw W_2STAR
C_2SLASH:
        dw $+2

        pop     hl
        sra	h
        rr	l
        jp      HPUSH

; -------------
; (.")   ( -- )             MODIFICADO: ERA *(
; 
; Rotina de tempo de execução para imprimir na tela uma cadeia de
; caracteres, cujo comprimento precede a cadeia. Compilada por ."
;

W_CQUOTE:
        db $04,"(.",$22,")"
        dw W_2SLASH
C_CQUOTE:
        dw $+2

        ld      a,(bc)
        ld      d,a
SPNLP:  inc     bc
        ld      a,(bc)
        call    X_EMIT
        dec     d
        jr      nz,SPNLP
        inc     bc
        jp      NEXT

; --------------
; C,  ( c --   )
; Armazena o valor c de 8 bits no próximo byte disponível no dicionário,
; avançando o ponteiro do dicionário (DP) em uma posição.
;

W_CCOMMA:
        db $02,"C,"
        dw W_CQUOTE
C_CCOMMA:
        dw $+2

        pop     de
        ld      hl,(DP)
        ld      (hl),e
        inc     hl
        ld      (DP),hl
        jp      NEXT

; ----------------------------
; OVER  (n1, n2 -- n1, n2, n1)
; Copia o segundo valor na pilha, colocando-o no topo.
;

W_OVER:
        db $04,"OVER"
        dw W_CCOMMA
C_OVER:
        dw $+2

        pop     de
        pop     hl
        push    hl
        jp      DPUSH

; -----------------
; C!  (c addr -- )
; Armazena em addr o valor c de oito bits.
;

W_CSTORE:
        db $02,"C!"
        dw W_OVER
C_CSTORE:
        dw $+2

        pop     hl
        pop     de
        ld      (hl),e
        jp      NEXT


; ------------
; CR  (  --  )
; Avança para a próxima linha da tela (carriage return).
;

W_CR:
        db $02,"CR"
        dw W_CSTORE
C_CR:
        dw $+2

        ld      a,$0d
        call    X_EMIT
        jp      NEXT

; ----------------
; HERE  ( -- addr)
; Deixa na pilha o endereço da próxima posição disponível
; no dicionário.
;

W_HERE:
        db $04,"HERE"
        dw W_CR
C_HERE:
        dw $+2

        ld      hl,(DP)
        jp      HPUSH

; --------------
; ALLOT  (n -- )
;     DP +! ;
; Aloca n bytes no dicionário.
;

W_ALLOT:
        db $05,"ALLOT"
        dw W_HERE
C_ALLOT:
        dw E_COLON
        dw C_DP
        dw C_PLUSSTORE
        dw C_STOP

; ---------------
; =  (n1 n2 -- f)
; Deixa um flag verdadeiro se n1=n2, caso contrário deixa uma flag falso.
;

W_EQUAL:
        db $01,"="
        dw W_ALLOT
C_EQUAL:
        dw $+2

        pop     hl
        pop     de
        and     a
        sbc     hl,de
        ld      de,$0000
        jr      nz,NEQU
        inc     e
NEQU:   push    de
        jp      NEXT

; -------------------------------------
; QUESTION  ( -- )                              REVER
;    HERE COUNT TYPE 3F EMIT
;    STATE @ IF LATEST DUP DP ! HERE C@
;               + 1+ @ CURRENT @ !
;            THEN
;    SP! QUIT ;
;
; Imprime na tela a última palavra interpretada seguida do caracter '?'.
; Caso esteja em estado de compilação (STATE=1), também elimina do 
; dicionário a definição incompleta da última palavra compilada.
; A pilha é esvaziada e o comando QUIT executado. Usado para abortar a
; execução em caso de erro.
;

W_QUESTION:
        db $08,"QUESTION"
        dw W_EQUAL
C_QUESTION:
        dw E_COLON
        dw C_HERE
        dw C_COUNT
        dw C_TYPE
        dw C_LIT
        dw $3F
        dw C_EMIT
QUEST1: dw C_STATE
        dw C_FETCH
        dw C_STARIF                  ;IF
        db QUEST2-$
        dw C_LATEST
        dw C_DUP
        dw C_DP
        dw C_STORE
        dw C_HERE
        dw C_CFETCH
        dw C_PLUS
        dw C_ONEPLUS
        dw C_FETCH
        dw C_CURRENT
        dw C_FETCH
        dw C_STORE                   ;THEN
QUEST2: dw C_SPSTORE
        dw C_QUIT

;--------------------
; Rotina print string
; Imprime na tela uma string endereçada por HL e de comprimento dado por E
;

PR_STRING:
        ld      a,(hl)
        call    X_EMIT
	inc	hl
        dec     e
        jr      nz,PR_STRING
        ret

; -------------------
; INPUT  (addr -- )            MODIFICADO
;
; Lê caracteres do teclado e os armazena a partir do endereço no topo da pilha, até que a
; tecla ENTER seja digitada, finalizando a entrada de dados.
;

W_INPUT:
        db $05,"INPUT"
        dw W_QUESTION
C_INPUT:
        dw $+2

        pop     hl
        push    bc
        ld      d,h
        ld      e,l

INP4:	ld	a,$a0		;imprime o cursor
        call    X_EMIT
INP3:   call    X_KEY           ;espera um tecla
	cp      $20		;caracter imprimível?
	jr	nc,INP1         ;
        cp      $08             ;Backspace ?
        jr      z,INP2         ;
        sub     $0d             ;ENTER ?
        jr      nz,INP3         ;

;A tecla ENTER ($0D) foi pressionada, finalizando a entrada de dados
        ld      (hl),a          ;deixa 0 no final da string para marcar fim de dados no buffer
        ld      a,$08           ;Backspace (apaga cursor)
        call    X_EMIT          ;
        ld      a,$20           ;imprime um espaço
        call    X_EMIT          ;
        pop     bc		;recupera IP
        jp      NEXT

INP2:	push	hl              ;se estiver no início do buffer, não executa backspace
	and	a               ;
	sbc	hl,de           ;
	pop	hl              ;
	jr	z,INP3          ;

        dec     hl              ;decrementa ponteiro e apaga caracter no buffer de entrada
        jr      INP5            ;

INP1:   ld      (hl),a          ;armazena caracter no buffer de entrada e
        inc     hl              ;incrementa ponteiro
INP5:   ld	c,a
	ld	a,$08		;apaga o cursor
        call    X_EMIT
	ld	a,c		;imprime o caracter
        call    X_EMIT
        jr      INP4

; ------------
; null  ( -- )
;     R> DROP ;
; Entrada no dicionário para o nome de um caracter de código ASCII nulo.
; Procedimento executado para terminar a interpretação de uma linha de texto
; proveniente do terminal ou de um buffer de arquivo, já que ambos os buffers
; sempre possuem um caracter nulo (0) no fim.
;

W_NULL:
        db $01,$00
        dw W_INPUT
C_NULL:
        dw E_COLON
        dw C_FROMR
        dw C_DROP
        dw C_STOP

; -----------------------
; FILL  (addr quan b -- )
; 
; Preecha a memória no endereço dado com a quantidade especificada de bytes b.
;

W_FILL:
	db	$04,"FILL"
	dw	W_NULL
C_FILL:
	dw	$+2

	exx				;/ save IP
	pop	de			;/ (E)<--byte
	pop	bc			;  (BC)<--quantity
	pop	hl			;/ (HL)<--addr
FILL1:	ld	a,b
	or	c			;  QTY=0?
	jr	z,FILL2			;  yes
	ld	(hl),e			;/ ((HL))<--byte
	inc	hl			;  inc pointer
	dec	bc			;  dec counter
	jp	FILL1			;/
FILL2:	exx				;/ RESTORE IP
	jp      NEXT

; ---------------
; TIB  ( -- addr)
;
; Variável que contém o endereço do buffer de entrada do terminal
; (Terminal Input Buffer).
;

W_TIB:
        db $03,"TIB"
        dw W_FILL
C_TIB:
        dw $+2

        ld      hl,TIB
        jp      HPUSH

; ---------------
; LBP  ( -- addr)
;
; Ponteiro que aponta a próxima palavra a ser interpretada
; dentro do buffer de entrada.
;

W_LBP:
        db $03,"LBP"
        dw W_TIB
C_LBP:
        dw $+2

        ld      hl,LBP
        jp      HPUSH

; -------------
; HOLD  (c -- )
;     -1 HLD +! HLD @ C! ;
; Usado entre <# e #> para inserir um caracter ASCII em uma saída
; numérica formatada.
;

W_HOLD:
        db $04,"HOLD"
        dw W_LBP
C_HOLD:
        dw $+2

	pop	de
HOLD1:	ld	hl,(HLD)
	dec	hl
	ld	(HLD),hl
	ld	(hl),e
	jp	NEXT

; ---------------
; PAD  ( -- addr)
;    HERE 44 + ;
; Deixa o endereço do buffer de saída de texto, fixado 68 bytes acima
; de HERE.
;

W_PAD:
        db $03,"PAD"
        dw W_HOLD
C_PAD:
        dw $+2

	call	X_PAD
        push    hl
	jp	NEXT

X_PAD:	ld	hl,(DP)
	ld	de,$44
	add	hl,de
	ret

; ---------------
; MODE  ( -- add)
; Flag que indica se a palavra atual é imediata (MODE=1) ou não-imediata (MODE=0).
;

W_MODE:
        db $04,"MODE"
        dw W_PAD
C_MODE:
        dw $+2

        ld      hl,MODE
        jp      HPUSH

; ----------------
; BASE  ( -- addr)
; Base numérica corrente.
;

W_BASE:
        db $04,"BASE"
        dw W_MODE
C_BASE:
        dw $+2

        ld      hl,BASE
        jp      HPUSH

; -----------
; BL  ( -- c)             MODIFICADO: ERA 'ASPACE'
; 
; Deixa na pilha o código do caracter espaço.
;

W_BL:
        db $02,"BL"
        dw W_BASE
C_BL:
        dw $+2

        ld      hl,$0020
        jp      HPUSH

; -------------------
; CONTEXT  ( -- addr)
; Variável contendo o ponteiro para o vocabulário no qual as
; buscas se iniciam.
;

W_CONTEXT:
        db $07,"CONTEXT"
        dw W_BL
C_CONTEXT:
        dw $+2

        ld      hl,CONTEXT
        jp      HPUSH

; -------------------
; CURRENT  ( -- addr)
; Variável contendo o ponteiro para o vocabulário sendo compilado.
;

W_CURRENT:
        db $07,"CURRENT"
        dw W_CONTEXT
C_CURRENT:
        dw $+2

        ld      hl,CURRENT
        jp      HPUSH

; --------------------
; COMPILER  ( -- addr)
; Variável contendo o ponteiro para o vocabulário onde as palavras
; imediatas são compiladas.

W_COMPILER:
        db $08,"COMPILER"
        dw W_CURRENT
C_COMPILER:
        dw $+2

        ld      hl,COMPILER
        jp      HPUSH

; -----------------
; STATE  ( -- addr)
; Variável contendo o estado de compilação. STATE=1 indica estado de compilação,
; enquanto STATE=0 indica estado de execução.
;

W_STATE:
        db $05,"STATE"
        dw W_COMPILER
C_STATE:
        dw $+2

        ld      hl,STATE
        jp      HPUSH

; --------------
; DP  ( -- addr)
; Dictionary Pointer, indica a próxima posição de memória livre
; acima do dicionário.

W_DP:
        db $02,"DP"
        dw W_STATE
C_DP:
        dw $+2

        ld      hl,DP
        jp      HPUSH

; ---------------
; DUP  (n -- n n)
; Duplica o valor no topo da pilha.
;

W_DUP:
        db $03,"DUP"
        dw W_DP
C_DUP:
        dw $+2

        pop     hl
        push    hl
        jp      HPUSH

; ----------------
; 2DUP  (d -- d d)
; Duplica o valor de 32 bits (4 bytes) no topo da pilha.
;

W_2DUP:
        db $04,"2DUP"
        dw W_DUP
C_2DUP:
        dw $+2

        pop     hl
        pop	de
        push	de
        push	hl
        jp      DPUSH

; ---------------
; <  (n1 n2 -- f)
; Deixa 1 (verdadeiro) se n1 é menor que n2, caso contrário deixa
; 0 (falso).

W_LESS:
        db $01,"<"
        dw W_2DUP
C_LESS:
        dw $+2

        pop     de
ZLESS:  pop     hl
GREATER:
        and     a
        sbc     hl,de
        ld      de,$0000
        jp      p,NLESS
        inc     e
NLESS:  push    de
        jp      NEXT

; ---------------
; >  (n1 n2 -- f)
; Deixa 1 (verdadeiro) se n1 é maior que n2, caso contrário deixa
; 0 (falso).

W_GREATER:
        db $01,">"
        dw W_LESS
C_GREATER:
        dw $+2

        pop     hl
        pop     de
        jp      GREATER

; ---------------
; 0<  (n -- flag)
; Deixa 1 (verdadeiro) se n é menor que 0, caso contrário deixa
; 0 (falso).

W_ZLESS:
        db $02,"0<"
        dw W_GREATER
C_ZLESS:
        dw $+2

        ld      de,$0000
        jp      ZLESS

; ---------------------------
; ROT  (x1 x2 x3 -- x2 x3 x1)
; Rotaciona os três elementos no topo da pilha, deixando o terceiro no topo.
;

W_ROT:
        db $03,"ROT"
        dw W_ZLESS
C_ROT:
        dw $+2

        pop     de
        pop     hl
        ex      (sp),hl
        jp      DPUSH

; -------------
; SPACE  ( -- )
; Transmite um espaço em branco para a tela.

W_SPACE:
        db $05,"SPACE"
        dw W_ROT
C_SPACE:
        dw $+2

	ld	a,$20
	jr	EMIT1

; ----------------------------
; ?DUP  (n -- n) se for zero 							L0
;       (n -- n n) se não for zero
; Duplica n apenas se não for zero.
; Usualmente usado antes de um IF, para eliminar a necessidade de um ELSE DROP.
;

W_QUERYDUP:
	db $04,"?DUP"
	dw W_SPACE
C_QUERYDUP:
	dw $+2

	pop	hl
	ld	a,h
	or	l
	jr	z,EXDDUP
	push	hl
EXDDUP: jp      HPUSH

; -------------
; EMIT  (c -- )
; Transmite o caracter ASCII c para a tela.
;

W_EMIT:
        db $04,"EMIT"
        dw W_QUERYDUP
C_EMIT:
        dw $+2

        pop     hl
        ld      a,l
EMIT1:  call    X_EMIT
        jp      NEXT

; -------------
; DROP  (x -- )
; Elimina o conteúdo do topo da pilha.
;

W_DROP:
        db $04,"DROP"
        dw W_EMIT
C_DROP:
        dw $+2

        pop     hl
        jp      NEXT

; ------------
; KEY  ( -- c)
; Espera o pressionar de uma tecla e devolve seu código
; no topo da pilha.
;

W_KEY:
        db $03,"KEY"
        dw W_DROP
C_KEY:
        dw $+2

        call    X_KEY
        ld      h,$00
        ld      l,a
        jp      HPUSH

; ----------------------------------------------
; SEARCH  (nfa -- 1 )    palavra não encontrada
;         (nfa -- cfa 0) palavra encontrada
;
; Procura no dicionário a palavra copiada a partir de DP, iniciando a busca pelo
; endereço NFA no topo da pilha. Retorna o CFA e o flag=0 caso a busca seja bem sucedida.
; Caso a palavra não seja localizada, retorna apenas o flag=1.
;

W_SEARCH:
        db $06,"SEARCH"
        dw W_KEY
C_SEARCH:
        dw $+2

        exx			;preserva o IP
        pop     hl
SRCH4:  push    hl
        ld      de,(DP)         ;a palavra ser localizada está armazenada no fim do dicionário
        ld      c,$00
        ld      a,(de)		;carrega o comprimento da palavra
        cp      (hl)		;compara com a palavra do dicionário
        jr      nz,SRCH1	;caso não coincidam, avance p/ próxima palavra do dic.
        ld      b,a		;comprimento em B para ser contador de loop
SRCH2:  inc     hl		;compara as palavras
        inc     de		;
        ld      a,(de)          ;
        cp      (hl)            ;
        jr      nz,SRCH1        ;caso não coincidam, avance p/ próxima palavra do dic.
        djnz    SRCH2		;retorna para comparar próxima letra
        ld      de,$0003	;palavra localizada, calcula o CFA da mesma
        add     hl,de		;
        pop     de		;limpa a pilha
        push    hl		;sobe o CFA da palavra para a pilha
        jr      SRCH3		;
SRCH1:  pop     hl		;avança para a próxima palavra do dicionáro
        ld      d,$00		;carrega comprimento da palavra em DE e incrementa
        ld      e,(hl)		;
        inc     de              ;
        add     hl,de		;obtem o LFA
        ld      e,(hl)          ;carrega em DE o link para a próxima palavra do dic.
        inc     hl              ;
        ld      d,(hl)          ;
        ex      de,hl           ;
        ld      a,h             ;testa se atingiu o fim do dicionário (link = 0)
        or      l               ;
        jr      nz,SRCH4        ;se não, retorna para continuar a busca
        ld      c,$01		;palavra não encontrada, deixa flag = 1 na pilha
SRCH3:  ld      b,$00		;sobe o flag para a pilha
        push    bc              ;
        exx			;recupera IP
        jp      NEXT

; -------------
; WORD  (c -- )
; 
; Lê os próximos caracteres do buffer de entrada sendo interpretado até que o delimitador
; c seja encontrado, armazenando a cadeia de caracteres a partir de HERE. No primeiro byte,
; WORD deixa o comprimento da cadeia, seguido dos caracteres lidos. Ocorrências preliminares
; de c são ignoradas e o caracter null (0) é interpretado como um delimitador incondicional.
;

W_WORD:
        db $04,"WORD"
        dw W_SEARCH
C_WORD:
        dw $+2

        exx                     ;salva IP
        ld      hl,(LBP)        ;armazena em HL o ponteiro do buffer de entrada
        pop     bc              ;recupera em C o código do caracter delimitador
WRD2:   ld      a,(hl)
        cp      c
        jr      nz,WRD1
WRD4:   inc     hl
        jr      WRD2            ;ignora delimitadores antes do texto

WRD1:   cp      $20             ;verifica ocorrência de chrs de controle
        jr      nc,WRD3
        and     a               ;NULL?
        jr      nz,WRD4         ;ignora chr de controle (CR/LF)
        inc     b
        push    hl
        jr      WRD5

WRD3:   push    hl              ;salva endereço do início da cadeia
WRD6:
        inc     b               ;incrementa contador
        inc     hl              ;incrementa o ponteiro
        ld      a,(hl)          ;chr delimitador?
        cp      c               ;
        jr      z,WRD5          ;
        cp      $20             ;verifica ocorrência de chrs de controle
        jr      nc,WRD6
        dec     hl

WRD5:   inc     hl              ;avança para o primeiro caractere após o delimitador
        ld      (LBP),hl        ;atualiza LBP
        ld      de,(DP)         ;armazena em DE o endereço onde será¡ copiada a cadeia de chrs.
        ld      a,b             ;armazena o comprimento da string em (DP)
        ld      (de),a          ;
        inc     de              ;transfere a string para o fim do dicionário, em DP+1
        pop     hl              ;
        ld      c,b             ;
        ld      b,$00           ;
        ldir                    ;
        exx                     ;recupera IP
        jp      NEXT

; --------------
; ABS  (n -- +n)
; Retorna o valor absoluto de n.
;

W_ABS:
        db $03,"ABS"
        dw W_WORD
C_ABS:
        dw $+2

        pop     de
        bit     7,d
        jr      z,ABS1
        ld      hl,$0000
        and     a
        sbc     hl,de
        ex      de,hl
ABS1:   push    de
        jp      NEXT

; ---------------
; !  (n addr -- )
; Armazena o valor n em addr.
;

W_STORE:
        db $01,"!"
        dw W_ABS
C_STORE:
        dw $+2

        pop     hl
        pop     de
        ld      (hl),e
        inc     hl
        ld      (hl),d
        jp      NEXT

;-------------
; LIT  ( -- n)               MODIFICADO: ERA *#
; Em uma definição iniciada por ':', LIT é automaticamente compilado antes de
; cada número literal de 16 bits encontrado na entrada de texto. A execução
; posterior de LIT transfere o conteúdo da próxima célula no dicionário para
; o topo da pilha.
;

W_LIT:
	db      $03,"LIT"
        dw      W_STORE
C_LIT:
	dw      $+2

	ld	a,(bc)
	inc	bc
	ld	l,a
	ld	a,(bc)
	inc	bc
	ld	h,a
        jp      HPUSH

; ----------
; ,  (n -- )
; Armazena n na próxima célula de memória disponível no dicionário e
; incrementa DP em dois bytes.
;

W_COMMA:
        db $01,","
        dw W_LIT
C_COMMA:
        dw $+2

        pop     de
        ld      hl,(DP)
        ld      (hl),e
        inc     hl
        ld      (hl),d
        inc     hl
        ld      (DP),hl
        jp      NEXT

; ----------------
; +  (n1 n2 -- n3)
; Deixa na pilha a soma de n1+n2.
;

W_PLUS:
        db $01,"+"
        dw W_COMMA
C_PLUS:
        dw $+2

        pop     hl
        pop     de
        add     hl,de
        jp      HPUSH

; ----------------
; -  (n1 n2 -- n3)
; Deixa na pilha a diferença de n1-n2.
;

W_MINUS:
        db $01,"-"
        dw W_PLUS
C_MINUS:
        dw $+2

        pop     de
        pop     hl
        and     a
        sbc     hl,de
        jp      HPUSH

; ----------------------
; SWAP  (n1 n2 -- n2 n1)
; Troca entre si os dois valores no topo da pilha.
;

W_SWAP:
        db $04,"SWAP"
        dw W_MINUS
C_SWAP:
        dw $+2

        pop     hl
        ex      (sp),hl
        jp      HPUSH

; -----------
; CLS  ( -- )                MODIFICADO: ERA PAGE
; Apaga a tela.
;

W_CLS:
        db $03,"CLS"
        dw W_SWAP
C_CLS:
        dw $+2

        push    bc
        call    X_CLS
        pop     bc
        jp      NEXT

; -------------
; @ (addr -- n)
; Deixa na pilha o conteúdo de 16 bit contido em addr.
;

W_FETCH:
        db $01,"@"
        dw W_CLS
C_FETCH:
        dw $+2

        pop     hl
        ld      e,(hl)
        inc     hl
        ld      d,(hl)
        push    de
        jp      NEXT

;--------------------
; EXECUTE  (addr -- )
; Executa a definição cujo cfa está na pilha. O cfa é também chamado
; de endereço de compilação.
;

W_EXECUTE:
	db      $07,"EXECUTE"
        dw      W_FETCH
C_EXECUTE:
	dw      $+2

	pop     hl
        jp      NEXT_ADDR

; ---------------
; +SP  (n1 -- n2)
; Deixa na pilha o resultado da soma de n1+SP.
;

W_PLUSSP:
        db $03,"+SP"
        dw W_EXECUTE
C_PLUSSP:
        dw $+2

        pop     hl
        add     hl,sp
        jp      HPUSH

; -----------
; SP!  ( -- )
; Restaura o stack pointer para o seu valor inicial (S0).
;

W_SPSTORE:
        db $03,"SP!"
        dw W_PLUSSP
C_SPSTORE:
        dw $+2

        ld	hl,(S0)
        ld	sp,hl
        jp	NEXT

; -----------
; RP!  ( -- )
; Restaura o return pointer para o seu valor inicial (R0).
;

W_RPSTORE:
        db $03,"RP!"
        dw W_SPSTORE
C_RPSTORE:
        dw $+2

        ld	hl,(R0)
        ld	(RSP),hl
        jp	NEXT

; ------------
; 0=  (n -- f)
; Deixa 1 (verdadeiro) na pilha se n=0, caso contrário deixa 0 (falso).
;

W_0EQUAL:
        db $02,"0="
        dw W_RPSTORE
C_0EQUAL:
        dw $+2

        pop     hl
        ld      a,l
        or      h
        ld      de,$0000
        jr      nz,ZEQU1
        inc     de
ZEQU1:  push    de
        jp      NEXT

; ------------------
; AND  (n1 n2 -- n3)
; Deixa na pilha como n3, o resultado da operação lógica bit-a-bit
; n1 AND n2.
;

W_AND:
        db $03,"AND"
        dw W_0EQUAL
C_AND:
        dw $+2

        pop     hl
        pop     de
        ld      a,d
        and     h
        ld      h,a
        ld      a,e
        and     l
        ld      l,a
        jp      HPUSH

; -----------------
; OR  (n1 n2 -- n3)
; Deixa na pilha como n3, o resultado da operação lógica bit-a-bit
; n1 OR n2.
;

W_OR:
        db $02,"OR"
        dw W_AND
C_OR:
        dw $+2

        pop     hl
        pop     de
        ld      a,d
        or      h
        ld      h,a
        ld      a,e
        or      l
        ld      l,a
        jp      HPUSH

; ------------------
; XOR  (n1 n2 -- n3)
; Deixa na pilha como n3, o resultado da operação lógica bit-a-bit
; n1 XOR n2.
;

W_XOR:
        db $03,"XOR"
        dw W_OR
C_XOR:
        dw $+2

        pop     hl
        pop     de
        ld      a,d
        xor     h
        ld      h,a
        ld      a,e
        xor     l
        ld      l,a
        jp      HPUSH

; ----------------
; 0SET  (addr -- )
; Armazena o valor 0 na célula cujo endereço está na pilha.
;

W_0SET:
        db $04,"0SET"
        dw W_XOR
C_0SET:
        dw $+2

        pop     hl
        ld      (hl),$00
        inc     hl
        ld      (hl),$00
        jp      NEXT

; ----------------
; 1SET  (addr -- )
; Armazena o valor 1 na célula cujo endereço está na pilha.
;

W_1SET:
        db $04,"1SET"
        dw W_0SET
C_1SET:
        dw $+2

        pop     hl
        ld      (hl),$01
        inc     hl
        ld      (hl),$00
        jp      NEXT

; ----------
; I  ( -- n)
; Usado dentro de um laço DO-LOOP para copiar o valor do indíce para
; a pilha.
;

W_I:
        db $01,"I"
        dw W_1SET
C_I:
        dw $+2

        ld      hl,(RSP)
        ld      e,(hl)
        inc     hl
        ld      d,(hl)
        push    de
        jp      NEXT

; -----------------------
; >R  ( n --   R:  -- n )
; Transfere um número do topo da pilha de parâmetros para o topo da
; pilha de retorno. Seu uso deve ser balanceado com R> na mesma definição.
;

W_TOR:
        db $02,">R"
        dw W_I
C_TOR:
        dw $+2

	pop	de
	ld	hl,(RSP)
	dec	hl
	ld	(hl),d		
	dec	hl
	ld	(hl),e			;/ (R1)<--(DE)
	ld	(RSP),hl		;  (RP)<--(RP)-2
        jp      NEXT

; -----------------------
; R>  ( -- n    R: n -- )
; Transfere um número do topo da pilha de retorno para o topo da
; pilha de parâmetros.
;

W_FROMR:
        db $02,"R>"
        dw W_TOR
C_FROMR:
        dw $+2

        ld      hl,(RSP)
        ld      e,(hl)
        inc     hl
        ld      d,(hl)
        inc     hl
        ld      (RSP),hl
        push    de
        jp      NEXT

; ----------
; R  ( -- n)
; Copia o número no topo da pilha de retorno para o topo da
; pilha de parâmetros.
;

W_RR:
        db $01,"R"
        dw W_FROMR
C_RR:
        dw C_I+2

; -------------
; SIGN  (n -- )                  MODIFICADO
;     0< IF [ ASCII - ] HOLD THEN ;
; Armazena o código ASCII de '-' imediatamente antes da conversão literal de 
; um número no buffer de saída de texto (PAD). Deve ser usado entre <# e #>.
;

W_SIGN:
        db $04,"SIGN"
        dw W_RR
C_SIGN:
        dw $+2

	 pop	de
	 rl	d
 	 jp	nc,NEXT
 	 ld	e,'-'
 	 jp	HOLD1

; -------------------------
; COUNT  (addr1 -- addr2 n)
;     DUP 1+ SWAP C@ ;
; Deixa o endereço addr2 e a contagem de bytes n da mensagem de texto
; iniciada em addr1. Presume-se que o primeiro byte em addr1 contém a
; contagem de bytes e o texto em sí começa no segundo byte.
; Tipicamente COUNT é seguido de TYPE.
;

W_COUNT:
        db $05,"COUNT"
        dw W_SIGN
C_COUNT:
        dw $+2
        
        pop   hl
        ld    e,(hl)
        ld    d,0
        inc   hl
        push  hl
        push  de
        jp    NEXT

; ------------------
; TYPE  (addr c -- )                MODIFICADO
;     ?DUP IF OVER + SWAP DO I C@ EMIT LOOP ELSE DROP THEN ;
; Transmite c caracteres de addr para o dispositivo de saída.
;

W_TYPE:
        db $04,"TYPE"
        dw W_COUNT
C_TYPE:
        dw $+2

	 pop	de
	 pop	hl
	 ld	a,d
	 or	e
	 jr	z,TYPE1
	 call	PR_STRING
TYPE1:	 jp	NEXT

; ------------------------
; #>  (0,0 -- addr, count)               MODIFICADO
; 
;     DROP DROP HLD @ PAD OVER - ;
; Termina a conversão numérica eliminando o número de dupla precisão e
; deixando o endereço do texto e a contagem de caracteres prontos para
; serem usados por TYPE.
;

W_SHARPGT:
        db $02,"#>"
        dw W_TYPE
C_SHARPGT:
        dw $+2

	pop	de                        ;DROP
	pop	de                        ;DROP
	call	X_PAD                     ;PAD
	ld	de,(HLD)                  ;HLD @
	and	a                         ;clear carry flag
	sbc	hl,de                     ;PAD - (HLD)
        jp      DPUSH

; ----------
; J  ( -- n)
; Usado dentro de um duplo laço DO-LOOP para copiar o índice do laço
; externo para a pilha.
;

W_J:
        db $01,"J"
        dw W_SHARPGT
C_J:
        dw $+2

        ld      hl,(RSP)
	ld      de,4
	add     hl,de
        ld      e,(hl)
        inc     hl
        ld      d,(hl)
        push    de
        jp      NEXT

; ---------------
; C@  (addr -- b)
; Copia para a pilha o byte contido em addr.

W_CFETCH:
        db $02,"C@"
        dw W_J
C_CFETCH:
        dw $+2

        pop     hl
        ld      l,(hl)
        ld      h,0
        jp      HPUSH

; ----------
; <#  ( -- )               MODIFICADO
; 
;     PAD HLD ! ;
; Preparação para a conversão numérica formatada usando as palavras:
;     <# # #S SIGN #>
; A conversão é feita em um número de dupla precisão, deixando o texto
; no PAD.
;

W_LESSHARP:
        db $02,"<#"
        dw W_CFETCH
C_LESSHARP:
        dw $+2

	call	X_PAD
	ld	(HLD),hl
	jp	NEXT

; --------------
; ASCII  ( -- C)
;     BL WORD HERE 1+ C@ ;
; Deixa na pilha o código ASCII da primeira letra da próxima
; palavra no buffer de entrada.
;

W_ASCII:
        db $05,"ASCII"
        dw W_LESSHARP
C_ASCII:
        dw E_COLON
        dw C_BL
        dw C_WORD
        dw C_HERE
        dw C_ONEPLUS
        dw C_CFETCH
        dw C_STOP


; Palavra interna, fornece o CFA da última palavra do vocabulário
;     LATEST DUP C@ 3 + + ;

C_LCFA:
        dw $+2

        ld      de,(LAST)                      ; DE = NFA address da última palavra definida
        ld      h,$00
        ld      a,(de)                         ; A = comprimento da palavra
        ld      l,a
        add     hl,de                          ; HL = LFA - 1
        ld      de,$0003
        add     hl,de                          ; HL = CFA
        jp      HPUSH

; ----------
; 0  ( -- 0)
; Deixa o número 0 na pilha.
;

W_ZERO:
        db $01,"0"
        dw W_ASCII
C_ZERO:
        dw $+2

        ld      hl,$0000
        jp      HPUSH

; ----------
; 1  ( -- 1)
; Deixa o número 1 na pilha.
;

W_ONE:
        db $01,"1"
        dw W_ZERO
C_ONE:
        dw $+2

        ld      hl,$0001
        jp      HPUSH

; ----------
; 2  ( -- 2)
; Deixa o número 2 na pilha.
;

W_TWO:
        db $01,"2"
        dw W_ONE
C_TWO:
        dw $+2

        ld      hl,$0002
        jp      HPUSH

; ----------
; 3  ( -- 3)
; Deixa o número 3 na pilha.
;

W_THREE:
        db $01,"3"
        dw W_TWO
C_THREE:
        dw $+2

        ld      hl,$0003
        jp      HPUSH

; -----------------
; (DO)  (n1 n2 -- )                 MODIFICADO
; Rotina de tempo de execução compilado por DO que move os parâmetros
; de controle do laço para a pilha de retorno.
;

W_XDO:
        db $04,"(DO)"
        dw W_THREE
C_XDO:
        dw $+2
        
	exx			;/ save IP
	pop	de		;  (DE)<--initial INDEX
	pop	bc		;/ (BC)<--LIMIT
	ld	hl,(RSP)	;  (HL)<--(RP)
	dec	hl
	ld	(hl),b
	dec	hl
	ld	(hl),c		;/ (R2)<--LIMIT
	dec	hl
	ld	(hl),d
	dec	hl
	ld	(hl),e		;  (R1)<--initial INDEX
	ld	(RSP),hl	;  (RP)<--(RP)-4
	exx			;/ RESTORE IP
        jp      NEXT

MSG3:   db  "PILHA VAZIA!"

; verifica se a pilha de dados está vazia
C_QSTACK:
        dw $+2

        ld      hl,(S0)		; topo da pilha de dados
        and     a
        sbc     hl,sp		; profundidade da pilha
        jp      nc,NEXT
        ld      hl,(S0)
        ld      sp,hl
        ld      e,$0c		; comprimento da string
        ld      hl,MSG3		; imprime "PILHA VAZIA"
        call    PR_STRING	;
        ld      bc,QUEST1
        jp      NEXT

;---------------
; (LOOP)  ( -- )
; Rotina de tempo de execução compilada por LOOP o qual incrementa o
; índice e testa pelo final do laço.
;

W_XLOOP:
        db $06,"(LOOP)"
        dw W_XDO
C_XLOOP:
        dw      $+2

        ld      hl,(RSP)
        ld      a,$01
STRLP1: add     a,(hl)
        ld      (hl),a
        inc     hl
        jr      nc,STRLP2
        inc     (hl)
STRLP2: ld      d,(hl)
        inc     hl
        sub     (hl)
        ld      a,d
        inc     hl
        sbc     a,(hl)
        jp      c,SWHILE		; se não exceder o valor de I então vá para  *WHILE
					; (salto incondicional para trás)
        inc	hl                      ; se exceder, descarte o valor
        ld      (RSP),hl
        inc     bc
NEXT5:  jp      NEXT

; ----------------
; (+LOOP)  (n -- )
; Rotina de tempo de execução compilada por +LOOP, o qual incrementa
; o índice por n e testa pelo final do laço.
;

W_XPLOOP:
        db $07,"(+LOOP)"
        dw W_XLOOP
C_XPLOOP:

        dw $+2

        ld      hl,(RSP)
        pop     de
        ld      a,e
        jp      STRLP1

; -------------
; LEAVE  ( -- )
; Força o fim do laço na próxima oportunidade igualando o limite superior
; ao valor atual do índice. O índice por si mesmo permanece inalterado e
; a execução procede normalmente até que LOOP ou +LOOP seja encontrado.
;

W_LEAVE:
        db $07,"(LEAVE)"               MODIFICADO
        dw W_XPLOOP
C_LEAVE:
        dw $+2

        ld      hl,(RSP)
        ld      e,(hl)
        inc     hl
	ld      d,(hl)
        inc     hl
        ld      (hl),e
        inc     hl
        ld      (hl),d
        jp      NEXT

; ----------------
; *  (n1 n2 -- n3)                 MODIFICADO
; Deixa o produto sinalizado de dois números com sinal.
;

W_TIMES:
        db $01,"*"
        dw W_LEAVE
C_TIMES:
        dw $+2

	exx			;/ save IP
	pop	hl
	pop	de
	ld	a,l		;/
	ld	c,h		;/
	ld	b,10h		;/
	ld	hl,0		;/
STAR1:	srl	c		;/
	rra			;/ SRL CA  (MPCATOR)
	jr	nc,STAR2	;/ LSB (CA)=0?
	add	hl,de		;/ no, add mpcant to HL
STAR2:	sla	e		;/
	rl	d		;/ SLA DE  (MPCANT 2 *)
	djnz	STAR1		;/ do all 16 bits
	push	hl		;/ (S1)<--product
	exx			;/ restore IP
	jp      NEXT

; ------------------------
; /MOD  (n1 n2 -- rem quot)
; 
; Deixa o resto e o quociente sinalizado de n1/n2. O resto tem o mesmo
; sinal do dividendo.
;

W_DIVMOD:
	db	$04,"/MOD"
	dw	W_TIMES
C_DIVMOD:
	dw	$+2

	pop     de
	pop     hl
	push    bc
	bit     7,d
	jr      z,DIVMOD1
	push    de
	ex      de,hl
	ld      hl,0
	or      a
	sbc     hl,de
	ld      a,l
	ld      c,h
	pop     de
	ld      hl,0
	or      a
	sbc     hl,de
	ex      de,hl
	jr      DIVMOD3
DIVMOD1:
	ld      a,d
	or      e
	jr      nz,DIVMOD2
	ld      hl,-1
	ld      d,h
	ld      e,l
	jr      DIVMOD6
DIVMOD2:
	ld      a,l
	ld      c,h
DIVMOD3:
	ld      hl,0
	ld      b,$10
DIVMOD4:
	rla
	rl      c
	adc     hl,hl
	sbc     hl,de
	jr      nc,DIVMOD5
	add     hl,de
DIVMOD5:
	ccf
	djnz    DIVMOD4
	rla     
	rl      c
	ld      e,a
	ld      d,c
DIVMOD6:
	pop     bc
	ex      de,hl
        jp      DPUSH

; ------------------
; /  (n1 n2 -- quot)
; 
; Deixa o quociente com sinal de n1/n2.

W_DIV:
	db	$01,"/"
	dw	W_DIVMOD
C_DIV:
	dw	E_COLON		
	dw	C_DIVMOD
	dw	C_SWAP
	dw	C_DROP
	dw	C_STOP

; -----------------
; NUMBER  ( -- ff) conversão fracassou              MODIFICADO
;         ( -- n tf) conversão bem sucedida
; Converte uma sequência de caracteres deixados no final do dicionário e 
; precedidos pela contagem de bytes, em um número de precisão simples com
; sinal, usando a base numérica corrente. Se a conversão é feita com sucesso,
; são deixados na pilha o número e um flag verdadeiro. Caso contrário, apenas
; um flag falso é deixado na pilha.
;

W_NUMBER:
        db $06,"NUMBER"
        dw W_DIV
C_NUMBER:
        dw $+2

        exx                     ;preserva IP
        ld      hl,(DP)         ;HL = endereço inicial da string
        ld      b,(hl)		;B = comprimento da string
        inc     hl              ;o primeiro caracter é o sinal de menos?
        ld      a,(hl)          ;
        cp      '-'	        ;
        ld      a,$00
        jr      nz,NUMB1
        dec     a
        dec     b
        inc     hl
NUMB1:  push     af             ;preserva sinal
        ld      de,$0000
        push    de
        push    de
NUMB5:  ld      a,(hl)		;dígito em A
        sub	'0'		;/ >=0?
        jr	c,NUMB2		;/ <0 é dígito inválido
        cp	$0a		;/ >9?
        jr	c,NUMB3		;/ não, testa a base numérica
        sub	$07		;/ intervalo entre '9' e 'A'
        cp	$0a             ;/ >='A'?
        jr	c,NUMB2		;/ caracteres entre '9' e 'A' são inválidos

NUMB3:  ld      e,a             ;compara dígito com a base numérica corrente
        ld      a,(BASE)        ;se for dígito válido, prossegue para NUMB4
        dec     a               ;
        cp      e               ;
        jr      nc,NUMB4        ;
NUMB2:  pop     hl		;descarta o sinal e deixa 0 na pilha para
        pop     hl              ;sinalizar conversão não possível
        pop     af
        push    hl
        exx                     ;recupera IP
        jp      NEXT            ;

NUMB4:  ex      (sp),hl
        ex      de,hl
        push    bc
        push    hl
        ld      bc,$0800
        inc     a
        ld      l,c
        ld      h,c
NUMB6:  add     hl,hl
        adc     a,a
        jr      nc,NUMB7
        add     hl,de
NUMB7:  djnz    NUMB6
        pop     de
        add     hl,de
        pop     bc
        ex      (sp),hl
        inc     hl
        djnz    NUMB5
        pop     de		;conversão concluída
        pop     hl              ;HL = 0
        pop     af              ;recupera o sinal
        and     a               ;se positivo, prossegue para NUMB8
        jr      z,NUMB8         ;
        sbc     hl,de           ;senão, converte nr para seu complemento de 2
        ex      de,hl           ;
NUMB8:  push    de              ;deixa número convertido na pilha
        scf
        push    af              ;deixa flag não nulo na pilha p/ sinalizar sucesso
        exx                     ;recupera IP
        jp      NEXT

; ---------------------
; U/ ( ud u1 -- u2 u3 )
; Deixa o resto u2 e o quociente u3, não-sinalizados, provenientes do
; dividendo de dupla precisão ud e do divisor u1, ambos não-sinalizados.
;

W_UDIVMOD:
	db $02,"U/"
	dw W_NUMBER
C_UDIVMOD:
	dw $+2

	ld	hl,0004h
	add	hl,sp		;((HL))<--NUMERATOR.LW
	ld	e,(hl)		;(DE)<--NUMER.LW
	ld	(hl),c		;save ip on stack
	inc	hl
	ld	d,(hl)
	ld	(hl),b
	pop	bc		;(BC)<--DENOMINATOR
	pop	hl		;(HL)<--NUMER.HW
	ld	a,l
	sub	c
	ld	a,h
	sbc	a,b		;NUMER >= DENOM?
	jr	c,USLA1		;no, go ahead
	ld	hl,0ffffh	;yes, overflow
	ld	d,h
	ld	e,l		;/ set REM & QUOT to MAX
	jp	USLA7
USLA1:	ld	a,10h		;loop counter
USLA2:	add	hl,hl		;left shift (HLDE) thru carry
	rla			;rot carry into ACCU bit 0
	ex	de,hl
	add	hl,hl
	jr	nc,USLA3
	inc	de		;add carry
	and	a		;reset carry
USLA3:	ex	de,hl		;shift done
	rra			;restore 1st carry & counter
	jr	nc,USLA4	;if carry=1
	or	a		;/ reset carry
	sbc	hl,bc		;/ then (HL)<--(HL)-(BC)
	jp	USLA5
USLA4:	sbc	hl,bc		;/ (HL)<--partial remainder
	jr	nc,USLA5
	add	hl,bc		;underflow, restore
	dec	de
USLA5:	inc	de		;inc QUOT
	dec	a		;counter=0?
	jp	nz,USLA2	;no, loop agn
USLA7:	pop	bc		;restore IP
	push	hl		;(S2)<--remainder
	push	de		;(S1)<--quotient
	jp      NEXT

; -------------------------
; M/MOD  (ud1 u2 -- u3 ud4)
;
;      >R 0 R U/ R> SWAP >R U/ R> ;
; Operação matemática sem sinal de magnitude mista a qual deixa o quosciente
; de dupla precisão ud4 e o resto u3, provenientes do dividendo de dupla precisão
; ud1 e do divisor de precisão simples u2.
;

W_MDIVMOD:
	db $05,"M/MOD"
	dw W_UDIVMOD
C_MDIVMOD:
	dw E_COLON
	dw C_TOR
	dw C_ZERO
	dw C_RR
	dw C_UDIVMOD
	dw C_FROMR
	dw C_SWAP
	dw C_TOR
	dw C_UDIVMOD
	dw C_FROMR
	dw C_STOP

; ------------------
; LATEST  ( -- addr)              MODIFICADO: ERA 'ENTRY'
;     CURRENT @ @ ;
; Deixa o name field address (nfa) da última palavra definida no
; vocabulário CURRENT.
;

W_LATEST:
        db $06,"LATEST"
        dw W_MDIVMOD
C_LATEST:
        dw E_COLON
        dw C_CURRENT
        dw C_FETCH
        dw C_FETCH
        dw C_STOP

; -------------------------------------------
; ?SEARCH  ( -- 1)     palavra não encontrada
;          ( -- CFA 0) palavra encontrada
;
;     CONTEXT @ @ SEARCH DUP
;     IF STATE @
;        IF DROP COMPILER @ SEARCH DUP
;           IF 0 ELSE 1 THEN  MODE !
;        THEN
;     THEN ;
;
; Procura por uma palavra no vocabulário CONTEXT; não localizando-a e estando em estado
; de compilação, procura pela palavra no vocabulário COMPILER; localizando-a, coloca
; MODE em 1, caso contrário deixa MODE em 0. De outro modo, caso a palavra não seja
; localizada no voc. CONTEXT e estando em estado de execução, finaliza a busca sem alterar
; o estado de MODE.
; Por outro lado, caso a palavra seja encontrada no voc. CONTEXT, deixa MODE em 1 e larga
; na pilha o CFA da palavra e o flag=0 para indicar que a busca foi bem sucedida.
;

W_QSEARCH:
        db $07,"?SEARCH"
        dw W_LATEST
C_QSEARCH:
        dw E_COLON
        dw C_CONTEXT
        dw C_FETCH
        dw C_FETCH
        dw C_SEARCH
        dw C_DUP
        dw C_STARIF	;IF
        db QSRCH1-$	;$20
        dw C_STATE
        dw C_FETCH
        dw C_STARIF	;IF
        db QSRCH1-$	;$19
        dw C_DROP
        dw C_COMPILER
        dw C_FETCH
        dw C_SEARCH
        dw C_DUP
        dw C_STARIF	;IF
        db QSRCH2-$	;06
        dw C_ZERO
        dw C_STARELSE	;ELSE
        db QSRCH3-$	;$03
QSRCH2: dw C_ONE	;
QSRCH3: dw C_MODE
        dw C_STORE	;
QSRCH1: dw C_STOP

; ------------
; NEXT  ( -- )
;
;     C3 C, next , ;
; Este é o interprete interno que usa o ponteiro interpretativo IP para executar
; as definições compiladas em Forth. Ele não é executado diretamente mas é o ponto
; de retorno para todas as rotinas em código. Ele atua colentando o endereço
; apontado por IP e armazenando-o no registrador W. Então ele salta para o endereço
; apontado por W. W aponta para o code field da definição o qual contém o endereço
; do código que é executado para aquela definição.
; Este uso do indirect threaded code é a maior contribuição ao poder, portabilidade
; e extensibilidade do Forth.
; 

W_NEXT:
        db $04,"NEXT"
        dw W_QSEARCH
C_NEXT:
        dw E_COLON
        dw C_LIT                        ;coloque os dois bytes seguintes na pilha
        dw $00c3                        ;opcode de JP
        dw C_CCOMMA                     ;salve byte
        dw C_LIT                        ;coloque os dois bytes seguintes na pilha
        dw NEXT                         ;endereço de NEXT
        dw C_COMMA                      ;salve dois bytes
        dw C_STOP                       ;

; -----------------
; PICK   (n1 -- n2)
;     1 - 2* +SP @ ;
; Deixa no topo da pilha a cópia do n1-ézimo elemento da pilha de parâmetros.
;

W_PICK:
        db $04,"PICK"
        dw W_NEXT
C_PICK:
        dw E_COLON
        dw C_ONE
        dw C_MINUS
        dw C_2STAR
        dw C_PLUSSP
        dw C_FETCH
        dw C_STOP

; -------------
; #  (d1 -- d2)                MODIFICADO - REVER: TENTAR COMPILAR EM LM
;
;     BASE @ M/MOD ROT 9 OVER < IF 7 + THEN 30 + HOLD ;
; Gera a partir do número de dupla precisão d1, o próximo caracter ASCII o qual
; é colocado no buffer de saída de texto. O resultado d2 é o quociente após a
; divisão pela BASE corrente e é mantido para processamento posterior.
; É usado entre <# e #>.

W_SHARP:
        db $01,"#"
        dw W_PICK
C_SHARP:
        dw E_COLON
        dw C_BASE
        dw C_FETCH
        dw C_MDIVMOD
        dw C_ROT
        dw C_DIG
        dw C_HOLD
        dw C_STOP

C_DIG:  dw    $+2

        pop     hl
        ld      a,l                     ; digito em A
        add     a,$30                   ; converte para ASCII
        cp      $3a                     ; compara com '9'
        jr      c,DIG1                  ; salta se for número
        add     a,$07                   ; senão, é letra
DIG1:   ld      l,a                     ;
        jp      HPUSH                   ;

; ---------------
; #S   (d1 -- d2)                 MODIFICADO
;     BEGIN # 2DUP OR 0= UNTIL ;
; Gera sucessivos caracteres ASCII no buffer de saída de texto, pelo uso de #, até
; que o número de dupla precisão d2 resulte em 0. Usado entre <# e #>.
;

W_SHARPS:
        db $02,"#S"
        dw W_SHARP
C_SHARPS:
	 dw E_COLON
SHRPS1:	 dw C_SHARP
	 dw C_2DUP
	 dw C_OR
	 dw C_0EQUAL
	 dw C_STAREND
	 db SHRPS1-$
	 dw C_STOP

; ----------
; .  (n -- )                   MODIFICADO PENDENTE
;     <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ;
; Imprime um número sinalizado de precisão simples, convertido de acordo com
; a base numérica corrente. Um espaço em branco é deixado após o número.
;

W_DOT:
        db $01,"."
        dw W_SHARPS
C_DOT:
        dw E_COLON
        dw C_LESSHARP
	dw C_DUP
        dw C_ABS
	dw C_ZERO
        dw C_SHARPS
	dw C_ROT
        dw C_SIGN
        dw C_SHARPGT
        dw C_TYPE
        dw C_SPACE
        dw C_STOP

; -----------
; U.  (u -- )
;     <# 0 #S #> TYPE SPACE ;
; Imprime um número de precisão simples, sem sinal, convertido de acordo com
; a base numérica corrente. Um espaço em branco é deixado após o número.


W_UDOT:
        db $02,"U."
        dw W_DOT
C_UDOT:
        dw E_COLON
        dw C_LESSHARP
        dw C_ZERO
        dw C_SHARPS
        dw C_SHARPGT
        dw C_TYPE
        dw C_SPACE
        dw C_STOP

; ---------------
; (;CODE)  ( -- )           MODIFICADO: ERA SCODE
;     R> lcfa ! ;
;
; Rotina de tempo de execução, compilado por ;CODE, que reescreve o CFA da mais recente
; palavra definida para apontar para a rotina em código de máquina que se segue.
;

W_CCODE:
        db $07,"(;CODE)"
        dw W_UDOT
C_CCODE:
        dw E_COLON
        dw C_FROMR
        dw C_LCFA
        dw C_STORE
        dw C_STOP

; -------------------
; ?NUMBER  ( -- tf)   conversão não foi possível
;          ( -- ff)   número convertido, estado de compilação
;          ( -- n ff) número convertido, estado de execução
;     NUMBER IF STATE @
;               IF LIT LIT , , THEN 0
;            ELSE 1 THEN ;
; Executa NUMBER para converter a cadeia de caracteres deixada no fim do
; dicionário em um número de precisão simples. Caso a conversão não seja
; possível, é deixado 1 na pilha. No caso da conversão ser bem sucedida e
; estando em modo compilado (STATE=1), o número é compilado no dicionário
; e é deixado 0 na pilha. Se estiver em modo de execução, são deixados na 
; pilha o número convertido e o flag 0.
;

W_QNUMBER:
        db $07,"?NUMBER"
        dw W_CCODE
C_QNUMBER:
        dw E_COLON
        dw C_NUMBER
        dw C_STARIF
        db QNUM1-$	;$15
        dw C_STATE
        dw C_FETCH
        dw C_STARIF
        db QNUM2-$	;$09
        dw C_LIT
        dw C_LIT
        dw C_COMMA
        dw C_COMMA
QNUM2:  dw C_ZERO
        dw C_STARELSE
        db QNUM3-$	;$03
QNUM1:  dw C_ONE
QNUM3:  dw C_STOP

; --------------
; CREATE  ( -- )
;     LATEST BL WORD HERE CURRENT @ ! HERE C@ 1+ ALLOT , HERE 2+ , ;
; Uma palavra que define (cria) novas palavras, usada na forma:
;     CREATE cccc
; CREATE cria no dicionário o cabeçalho para uma nova palavra Forth.
; O cfa contém o endereço do pfa da nova palavra, a qual é criada no
; vocabulário CURRENT.
;

W_CREATE:
        db $06,"CREATE"
        dw W_QNUMBER
C_CREATE:
        dw E_COLON
        dw C_LATEST
        dw C_BL
        dw C_WORD
        dw C_HERE
        dw C_CURRENT
        dw C_FETCH
        dw C_STORE
	dw C_HERE
	dw C_CFETCH
	dw C_ONEPLUS
        dw C_ALLOT
        dw C_COMMA
        dw C_HERE
        dw C_TWOPLUS
        dw C_COMMA
        dw C_STOP

; ---------
; :  ( -- )
;     CURRENT @ CONTEXT ! CREATE LIT e_colon lcfa ! ] ;
; Usada na forma:
;     : cccc    ...    ;
; Cria uma entrada no dicionário definindo cccc como equivalente à sequência
; seguinte de palavras Forth '...' até o próximo ';' ou ';CODE'.
; O processo de compilação é feito pelo interpretador de texto desde que STATE
; seja não-zero. Outros detalhes são que o vocabulário CONTEXT é fixado ao 
; vocabulário CURRENT e as palavras do vocabulário COMPILER são executadas em
; vez de serem compiladas.
;

W_COLON:
        db $01,":"
        dw W_CREATE
C_COLON:
        dw E_COLON
        dw C_CURRENT
        dw C_FETCH
        dw C_CONTEXT
        dw C_STORE
        dw C_CREATE
        dw C_LIT
        dw E_COLON
        dw C_LCFA
        dw C_STORE
        dw C_RIGHTBRKT
        dw C_STOP

; -------------
; '  ( -- addr)
;     BL WORD CONTEXT @ @ SEARCH
;     IF LATEST SEARCH IF QUESTION THEN
;     THEN ;
; Usado na forma;
;     ' cccc
; Deixa na pilha o endereço de compilação (cfa) da palavra cccc.
; Se após a busca nos vocabulários CONTEXT e CURRENT a palavra não for
; encontrada, aborta a execução via QUESTION.
;

W_TICK:
        db $01,"'"
        dw W_COLON
C_TICK:
        dw E_COLON
        dw C_BL
        dw C_WORD
        dw C_CONTEXT
        dw C_FETCH
        dw C_FETCH
        dw C_SEARCH
        dw C_STARIF
        db TICK1-$	;$0a
        dw C_LATEST
        dw C_SEARCH
        dw C_STARIF
        db TICK1-$	;$03
        dw C_QUESTION
TICK1:  dw C_STOP

; ---------------
; COMPILE  ( -- )
;     R> DUP 2+ >R @ , ;
; Quando a palavra que contém COMPILE é executada, o endereço de execução da palavra
; seguinte a COMPILE é copiado (compilado) no dicionário.
; Isto permite que situações específicas de compilação sejam implementadas em adição
; a simplesmente compilar um endereço de execução (o que o interpretador já faz).
;

W_COMPILE:
        db $07,"COMPILE"
        dw W_TICK
C_COMPILE:
        dw E_COLON
        dw C_FROMR
        dw C_DUP
        dw C_TWOPLUS
        dw C_TOR
        dw C_FETCH
        dw C_COMMA
        dw C_STOP

; ---------
; ]  ( -- )
;     STATE 1SET ;
; Retorna ao modo compilado, para conclusão de uma definição de dois pontos.
; Ver [.
;

W_RIGHTBRKT:
        db $01,"]"
        dw W_COMPILE
C_RIGHTBRKT:
        dw E_COLON
        dw C_STATE
        dw C_1SET
        dw C_STOP

; -------------
; DOES>  ( -- )
;     R> LATEST DUP C@ 5 + + ! ;CODE ... código para DODOES
; Palavra que define a ação em tempo de execução em uma definição de alto-nível.
; DOES> altera o cfa e o primeiro parâmetro da nova palavra para executar a 
; sequência de endereços compilados das palavras que seguem o DOES>. Quando a 
; parte do DOES> é executado, ela começa com o endereço do primeiro parâmetro da
; nova palavra na pilha. Isto permite a interpretação usando esta área ou seu 
; conteúdo. Usado em combinação com <BUILDS.
;

W_DOES:
        db $05,"DOES>"
        dw W_RIGHTBRKT
C_DOES:
        dw E_COLON
        dw C_FROMR
        dw C_LATEST
        dw C_DUP
        dw C_CFETCH
        dw C_LIT
        dw $0005
        dw C_PLUS
        dw C_PLUS
        dw C_STORE
        dw C_CCODE

DODOES: ld      hl,(RSP)
        dec     hl
        ld      (hl),b
        dec     hl
        ld      (hl),c
        ld      (RSP),hl
        ex      de,hl
        ld      c,(hl)
        inc     hl
        ld      b,(hl)
        inc     hl
        jp      HPUSH

; -----------------
; CONSTANT  (n -- )
;     CREATE , ;CODE ... código para DOCON
; Uma palavra definidora usada na forma:
;     n CONSTANT cccc
; para criar a palavra cccc, cujo campo de parâmetros contém n. Quando cccc
; é executado posteriormente, o valor de n é colocado na pilha.
;

W_CONSTANT:
        db $08,"CONSTANT"
        dw W_DOES
C_CONSTANT:
        dw E_COLON
        dw C_CREATE
        dw C_COMMA
        dw C_CCODE

DOCON:  ex      de,hl
        inc     hl
        ld      e,(hl)
        inc     hl
        ld      d,(hl)
        push    de
        jp      NEXT

; -----------------
; VARIABLE  (n -- )
;     CONSTANT ;CODE ... código para DOVAR
; Uma palavra definidora usada na forma:
;     n VARIABLE cccc
; Ao ser executada, VARIABLE cria a definição cccc, com seu campo de parâmetros
; inicializado com n. Quando cccc é executada posteriormente, o endereço do seu
; campo de parâmetros (contendo n) é deixado na pilha, tal que @ ou ! possam
; acessar essa posição.
;

W_VARIABLE:
        db $08,"VARIABLE"
        dw W_CONSTANT
C_VARIABLE:
        dw E_COLON
        dw C_CONSTANT
        dw C_CCODE

DOCREATE:
DOVAR:  inc     de              ;DE aponta para PFA-1, então incremente-o
        push    de              ;para acessar o conteúdo do Parameter Field
        jp      NEXT

; -----------------
; INTERPRET  ( -- )               MODIFICADO: ERA OUTIN
;     BEGIN
;        BL WORD ?SEARCH
;        IF ?NUMBER IF QUESTION THEN
;        ELSE MODE @ MODE 0SET STATE @ =
;             IF EXECUT ?STACK ELSE , THEN
;        THEN
;     AGAIN ;
;
; O interpretador de texto que sequencialmente executa ou compila o text vindo
; do fluxo de entrada, de acordo com STATE. Se a palavra não pôde ser encontrada
; após uma busca por CONTEXT e CURRENT, ela é convertida em um número de acordo
; com a base numérica corrente.
; Se isto também falha, a palavra é ecoada seguida de "?" para indicar erro.
; A entrada de texto deve atender ao convencionado para WORD.
;

W_INTERPRET:
        db $09,"INTERPRET"
        dw W_VARIABLE
C_INTERPRET:
        dw E_COLON
INTE5:  dw C_BL                ;BEGIN
        dw C_WORD
        dw C_QSEARCH
        dw C_STARIF            ;IF
        db INTE1-$
        dw C_QNUMBER
        dw C_STARIF            ;IF
        db INTE2-$
        dw C_QUESTION          ;THEN
INTE2:  dw C_STARELSE          ;ELSE
        db INTE3-$
INTE1:  dw C_MODE
        dw C_FETCH
        dw C_MODE
        dw C_0SET
        dw C_STATE
        dw C_FETCH
        dw C_EQUAL
        dw C_STARIF            ;IF
        db INTE4-$
        dw C_EXECUTE
        dw C_QSTACK
        dw C_STARELSE          ;ELSE
        db INTE3-$
INTE4:  dw C_COMMA             ;THEN THEN
INTE3:  dw C_STARWHILE         ;AGAIN
        db INTE5-$

; ---------------
; <BUILDS  ( -- )
;     LIT 0 CONSTANT ;
;
; Usado em dentro de uma definição de dois pontos:
;     : cccc <BUILDS   ...
;       DOES>    ...   ;
; A cada vez que cccc é executada, <BUILDS define uma nova palavra com um 
; procedimento de alto-nível. Executando cccc na forma:
;
;             cccc nnnn
;
; usa <BUILDS para criar uma entrada no dicionário para nnnn com uma chamada
; para a parte do DOES> para nnnn. Quando nnnn é executada posteriormente, ela
; contém o endereço de sua área de parâmetros na pilha e executa as palavras 
; após DOES> em cccc. <BUILDS e DOES> permitem que procedimentos de tempo de
; execução sejam escritos em linguagem de alto nível ao invés de em código 
; assembler (tal qual requerido por ;CODE).
;

W_LBUILDS:
        db $07,"<BUILDS"
        dw W_INTERPRET
C_LBUILDS:
        dw E_COLON
        dw C_LIT
        dw $0000
        dw C_CONSTANT
        dw C_STOP

; ----------
; (   ( -- )
; 
; Usado na forma:
;     ( cccc)
; Ignora comentários que devem ser delimitados por um fecha-parênteses na mesma linha.
; Pode ocorrer durante a execução ou em uma definição. Um espaço em branco após o 
; parênteses é necessário.
;

W_OPENBRKT:
	defb	$01,"("
	defw	W_LBUILDS
C_OPENBRKT:
	defw	E_COLON
	defw	C_LIT
	defw	$29
	defw	C_WORD
	defw	C_STOP

;-------------
; QUIT  ( -- )              MODIFICADO
;     [ RP!
;     BEGIN
;        TIB @ DUP LBP !
;        CR INPUT INTERPRET
;        STATE @ 0= IF ." OK" THEN
;     AGAIN ;
;
; Limpa a pilha de retorno, interrompe a compilação e retorna o controle para
; o terminal do operador.
;

W_QUIT:
	db $04,"QUIT"
	dw W_OPENBRKT
C_QUIT:
        dw E_COLON
        dw C_LEFTBRKT
        dw C_RPSTORE
QLOOP:  dw C_TIB
	dw C_FETCH
	dw C_DUP
	dw C_LBP
	dw C_STORE
	dw C_CR
        dw C_INPUT
        dw C_INTERPRET
        dw C_STATE
        dw C_FETCH
        dw C_0EQUAL
        dw C_STARIF		;IF
        db QUIT1-$
        dw C_CQUOTE
        db $02,"OK"
QUIT1:  dw C_STARWHILE		;THEN AGAIN
        db QLOOP-$

; -------------
; ABORT  ( -- )
;
;     SP! DECIMAL
;     CR ." COMPILADOR FORTH V2.0"
;     CR ." FORTH INICIALIZADO"
;     CR QUIT ;
;
; Limpa a pilha de parâmetros e entra no estado de execução. Retorna o controle
; ao terminal do operador e imprime uma mensagem apropriada à instalação.
;

W_ABORT:
	db $05,"ABORT"
	dw W_QUIT
C_ABORT:
	dw E_COLON
	dw C_SPSTORE
	dw C_DECIMAL
	dw C_CR
	dw C_CQUOTE
	db $15,"COMPILADOR FORTH V2.0"
	dw C_CR
	dw C_CQUOTE
	db $12,"FORTH INICIALIZADO"
	dw C_CR
        dw C_QUIT

; ------------
; COLD  ( -- )
;
; Procedimento de inicialização para ajustar os ponteiros do sistema e 
; reiniciar via ABORT.
;

W_COLD:
	db $04,"COLD"
	dw W_ABORT
C_COLD:
	dw	$+2

        ld	hl,(RAMTOP)
	dec	hl
	ld	(hl),$3e
	dec	hl
	ld	(R0),hl
	ld	(RSP),hl
	ld	de,$200
	sbc	hl,de
	ld	(S0),hl
	ld	(TIB),hl
	ld	sp,hl
	call    X_CLS
        ld	hl,C_ABORT
	jp	NEXT_ADDR

; -----------------
; IMMEDIATE  ( -- )
;     LATEST DUP DUP C@ 1+ + DUP @ CURRENT @ !
;     COMPILER @ SWAP ! COMPILER ! ;
;
; Coloca a mais recente definição criada no dicionário COMPILER tal que quando
; encontrada durante a compilação, ela seja executada em vez de ser compilada.
;

W_IMMEDIATE:
        db $09,"IMMEDIATE"
        dw W_COLD
C_IMMEDIATE:
        dw E_COLON
        dw C_LATEST
        dw C_DUP
        dw C_DUP
        dw C_CFETCH
        dw C_ONEPLUS
        dw C_PLUS
        dw C_DUP
        dw C_FETCH
        dw C_CURRENT
        dw C_FETCH
        dw C_STORE
        dw C_COMPILER
        dw C_FETCH
        dw C_SWAP
        dw C_STORE
        dw C_COMPILER
        dw C_STORE
        dw C_STOP

; ----------------
; LOAD  (addr -- )
;     LBP ! INTERPRET R> DROP ;
;
; Efetua a interpretação do texto armazenado a partir de addr.
;

W_LOAD:
        db $04,"LOAD"
        dw W_IMMEDIATE
C_LOAD:
        dw E_COLON
        dw C_LBP
        dw C_STORE
        dw C_INTERPRET
        dw C_FROMR
        dw C_DROP
        dw C_STOP

; --------------
; FORGET  ( -- )
;     CURRENT @ CONTEXT ! ' DUP 2 - @
;     CURRENT @ ! DP @ C@ 3 + - DP ! ;
;
; Executada na forma:
;     FORGET cccc
; Apaga do dicionário a definição nomeada cccc juntamente com todas as entradas
; que a seguem, ou seja, que foram criadas após cccc.
;

W_FORGET:
        db $06,"FORGET"
        dw W_LOAD
C_FORGET:
        dw E_COLON
        dw C_CURRENT
        dw C_FETCH
        dw C_CONTEXT
        dw C_STORE
        dw C_TICK
        dw C_DUP
        dw C_TWO
        dw C_MINUS
        dw C_FETCH
        dw C_CURRENT
        dw C_FETCH
        dw C_STORE
        dw C_DP
        dw C_FETCH
        dw C_CFETCH
        dw C_THREE
        dw C_PLUS
        dw C_MINUS
        dw C_DP
        dw C_STORE
        dw C_STOP

; -----------
; HEX  ( -- )
;     10 BASE ! ;
;
; Adota a base hexadecimal, usado na conversão numérica.
;

W_HEX:
        db $03,"HEX"
        dw W_FORGET
C_HEX:
        dw E_COLON
        dw C_LIT
        dw $10
        dw C_BASE
        dw C_STORE
        dw C_STOP

; ---------------
; DECIMAL  ( -- )
;     0A BASE ! ;
;
; Adota a base decimal, usado na conversão numérica.
;

W_DECIMAL:
        db $07,"DECIMAL"
        dw W_HEX
C_DECIMAL:
        dw E_COLON
        dw C_LIT
        dw $0a
        dw C_BASE
        dw C_STORE
        dw C_STOP

;-----------------------------------------------
; Vocabulário de compilação (palavras imediatas)
;-----------------------------------------------

; ---------
; ;  ( -- )
;     COMPILE ;S [ ; IMMEDIATE
;
; Termina uma definição de dois pontos e interrompe a compilação.
;

W_SEMICOLON:
        db $01,";"
        dw $0000
C_SEMICOLON:
        dw E_COLON
        dw C_COMPILE
        dw C_STOP
        dw C_LEFTBRKT
        dw C_STOP

; ----------
; IF  ( -- )
;     COMPILE *IF HERE 0 C, ; IMMEDIATE
;

W_IF:
        db $02,"IF"
        dw W_SEMICOLON
C_IF:
        dw E_COLON
        dw C_COMPILE
        dw C_STARIF
        dw C_HERE
        dw C_ZERO
        dw C_CCOMMA
        dw C_STOP

; ------------
; THEN  ( -- )
;     HERE OVER - SWAP C! ; IMMEDIATE
;

W_THEN:
        db $04,"THEN"
        dw W_IF
C_THEN:
        dw E_COLON
        dw C_HERE
        dw C_OVER
        dw C_MINUS
        dw C_SWAP
        dw C_CSTORE
        dw C_STOP

; ------------
; ELSE  ( -- )
;     COMPILE *ELSE HERE 0 C, SWAP THEN ; IMMEDIATE
;

W_ELSE:
        db $04,"ELSE"
        dw W_THEN
C_ELSE:
        dw E_COLON 
        dw C_COMPILE
        dw C_STARELSE
        dw C_HERE
        dw C_ZERO
        dw C_CCOMMA
        dw C_SWAP
        dw C_THEN
        dw C_STOP

; ---------
; [  ( -- )
;     STATE 0SET ;
;

W_LEFTBRKT:
        db $01,"["
        dw W_ELSE
C_LEFTBRKT:
        dw E_COLON
        dw C_STATE
        dw C_0SET
        dw C_STOP

; ---------------
; DO  (n1 n2 -- ) na execução
;     (addr -- )  na compilação
;     COMPILE (DO) HERE ; IMMEDIATE
;

W_DO:
        db $02,"DO"
        dw W_LEFTBRKT
C_DO:
        dw E_COLON
        dw C_COMPILE
        dw C_XDO
        dw C_HERE
        dw C_STOP

; ----------------
; LOOP  (addr -- ) na compilaçâo
;     COMPILE (LOOP) HERE - C, ; IMMEDIATE
;

W_LOOP:
        db $04,"LOOP"
        dw W_DO
C_LOOP:
        dw E_COLON
        dw C_COMPILE
        dw C_XLOOP
        dw C_HERE
        dw C_MINUS
        dw C_CCOMMA
        dw C_STOP

; --------------
; +LOOP  (n -- )
;     COMPILE (+LOOP) HERE - C, ; IMMEDIATE
;

W_PLOOP:
        db $05,"+LOOP"
        dw W_LOOP
C_PLOOP:
        dw E_COLON
        dw C_COMPILE
        dw C_XPLOOP
        dw C_HERE
        dw C_MINUS
        dw C_CCOMMA
        dw C_STOP

; ----------
; ."  ( -- )
;     COMPILE (.") 22 WORD HERE
;     C@ 1+ ALLOT ; IMMEDIATE
;

W_QUOTE:
        db $02,".",$22
        dw W_PLOOP
C_QUOTE:
        dw E_COLON
        dw C_COMPILE
        dw C_CQUOTE
        dw C_LIT
        dw $22
        dw C_WORD
        dw C_HERE
        dw C_CFETCH
        dw C_ONEPLUS
        dw C_ALLOT
        dw C_STOP

; -------------
; ;CODE  ( -- )
;     COMPILE (;CODE) [ ; IMMEDIATE
;

W_SCCODE:
        db $05,";CODE"
        dw W_QUOTE
C_SCCODE:
        dw E_COLON
        dw C_COMPILE
        dw C_CCODE
        dw C_LEFTBRKT
        dw C_STOP

; -----------------
; BEGIN  ( -- addr) na compilação
;     HERE ; IMMEDIATE
;

W_BEGIN:
        db $05,"BEGIN"
        dw W_SCCODE
C_BEGIN:
        dw E_COLON
        dw C_HERE
        dw C_STOP

; -------------
; UNTIL  (f -- ) na execução
;        (addr -- ) na compilação
;     COMPILE *END HERE - C, ; IMMEDIATE
;

W_UNTIL:
        db $05,"UNTIL"
        dw W_BEGIN
C_UNTIL:
        dw E_COLON
        dw C_COMPILE
        dw C_STAREND
        dw C_HERE
        dw C_MINUS
        dw C_CCOMMA
        dw C_STOP

; -----------------
; AGAIN  (addr -- ) na compilação
;     COMPILE *WHILE HERE - C, ; IMMEDIATE
;

W_AGAIN:
        db $05,"AGAIN"
        dw W_UNTIL
C_AGAIN:
        dw E_COLON
        dw C_COMPILE
        dw C_STARWHILE
        dw C_HERE
        dw C_MINUS
        dw C_CCOMMA
        dw C_STOP

; -------------
; WHILE  (f -- ) na execução
;        (addr1 -- addr1 addr2) na compilação
;     COMPILE *IF HERE 0 C, ; IMMEDIATE
;

W_WHILE:
        db $05,"WHILE"
        dw W_AGAIN
C_WHILE:
        dw E_COLON
        dw C_COMPILE
        dw C_STARIF
        dw C_HERE
        dw C_ZERO
        dw C_CCOMMA
        dw C_STOP

; -------------------------
; REPEAT  (addr1 addr2 -- ) na compilação
;     SWAP AGAIN HERE OVER -
;     SWAP C! ; IMMEDIATE
;

W_REPEAT:
        db $06,"REPEAT"
        dw W_WHILE
C_REPEAT:
        dw E_COLON
        dw C_SWAP
        dw C_AGAIN
        dw C_HERE
        dw C_OVER
        dw C_MINUS
        dw C_SWAP
        dw C_CSTORE
        dw C_STOP

; --------------------
; LISTVOC  ( addr -- )      lista todas as palavras de um dicionário
;    BEGIN
;       DUP COUNT TYPE SPACE
;       DUP C@ + 1+ @
;       ?DUP 0=
;    UNTIL ;
;

C_LISTVOC:
        dw E_COLON
LSTV1:  dw C_DUP
        dw C_COUNT
        dw C_TYPE
        dw C_SPACE
        dw C_DUP
        dw C_CFETCH
        dw C_PLUS
        dw C_ONEPLUS
        dw C_FETCH
        dw C_QUERYDUP
        dw C_0EQUAL
        dw C_STAREND
        db LSTV1-$
        dw C_STOP

; --------------
; VLIST  ( -- )         lista todas as palavras do dicionário
;    CR LATEST listvoc            lista dic. comum
;    CR CR COMPILER @ listvoc     lista dic. de palavras imed.
;    CR ;
;
W_VLIST:
        db $05,"VLIST"
        dw W_DECIMAL
C_VLIST:
        dw E_COLON
        dw C_CR
        dw C_LATEST
        dw C_LISTVOC
        dw C_CR
        dw C_CR
        dw C_COMPILER
        dw C_FETCH
        dw C_LISTVOC
        dw C_CR
        dw C_STOP

; -------------
; CSAVE  ( -- )
; salva o compilador em tape
;
W_CSAVE:
        db $05,"CSAVE"
        dw W_VLIST
C_CSAVE:
        dw $+2

        ld      hl,(DP)
        ld      ($4014),hl
        exx
        call    SETFAST
        call    SAVE-1
        call    SLOW
        exx
        jp      NEXT

#include line1.asm

;DICTPTR = last + 64         ; DP aponta para aqui




