#include "config.h"
/*
(VOCABULARY) SYSTEM
( -- )
Run time sementique for words defined with VOCABULARY. Replace the first word
list in search order with the address of the word body.
*/
$CODE 0,12,"(VOCABULARY)",_VOCABULARY_
add $4, %ax // >BODY
mov _context, %di
mov %ax, (%di) // CONTEXT !
$NEXT
/*
FORTH SYSTEM
( -- )
Replace the first word list in search order with the FORTH word list.
*/
$OBJECT 0,5,"FORTH",FORTH,_VOCABULARY_
__FORTH:
.word _FORTH
/*
CONTEXT SEARCH
( -- adr )
*/
$CONSTANT 0,7,"CONTEXT",CONTEXT
_context:
.word VOCC-2
/*
CURRENT SEARCH
( -- adr )
*/
_CURRENT:
$CREATE 0,7,"CURRENT",CURRENT
_current:
.word __FORTH
/*
WORDS
( -- )
Display the words in the first word list.
*/
$COLON 0,5,"WORDS",WORDS
.word CONTEXT, FETCH, FETCH, CR
1: .word DUP, COUNT, TYPE, SPACE, LITERAL, 3, MINUS, FETCH, DUP
.word ZERO_EQUALS, UNTIL, 1b,DROP, EXIT
/*
ALSO
*/
$CODE 0,4,"ALSO",ALSO
// Check if max vocabulary reach.
mov $VOCC, %ax
sub _context, %ax
cmp $NVOC*CELS, %ax
jge ABORT // stack is full.
// push zero on vocabulary stack.
sub $CELS, _context
mov _context, %di
movw $0, (%di)
$NEXT
/*
PREVIOUS
*/
$CODE 0,8,"PREVIOUS",PREVIOUS
mov _context, %ax
cmp $VOCC-2, %ax
je ONLY
add $CELS, _context
$NEXT
/*
ONLY
*/
$CODE 0,4,"ONLY",ONLY
movw $VOCC-2, _context
movw $__FORTH, VOCC-2
$NEXT
/*
DEFINITIONS
*/
$COLON 0,11,"DEFINITIONS",DEFINITIONS
.word CONTEXT, FETCH, CURRENT, STORE, EXIT
/*
VOCABULARY
*/
$COLON 0,10,"VOCABULARY",VOCABULARY
// Ditionary entry.
.word HEADER
// link in current.
.word CURRENT, FETCH, FETCH, ROT, STORE, CURRENT, FETCH, STORE
// code field is (VOCABULARY)
.word LITERAL, _VOCABULARY_, CODE_COMMA
// empty vocabulary
.word LITERAL, 0, COMMA
.word EXIT
/*
HEADER
( -- a-link colon-sys )
Create a new dictionary header.
// |<-a-link |<-colon-sys
// +--------+---------+---------+--------+-------+
// | Link | Flags | count | name | pad |
// +--------+---------+---------+--------+-------+
// 0 2 3 4 n
*/
$COLON 0,6,"HEADER",HEADER
// Save link addr of current definition
.word ALIGN, HERE, LITERAL, 1, CELLS, ALLOT // ( -- a-link )
// Compile flag
.word LITERAL, 0, C_COMMA, HERE // ( -- a-link colon-sys )
// Compile name
.word BL, WORD, COUNT, ONE_PLUS, ALLOT, DROP, ALIGN
.word EXIT
/*
CODE,
( xt -- )
Compile a code field.
*/
$COLON 0,5,"CODE,",CODE_COMMA
.word LITERAL, 0xe9, C_COMMA
.word HERE, MINUS, LITERAL, 2, MINUS, COMMA, LITERAL, 0x90, C_COMMA, EXIT
/*
* 6.1.1550 FIND CORE
* ( c-addr -- c-addr 0 | xt 1 | xt -1 )
* Find the definition named in the counted string at c-addr. If the definition is not found, return
* c-addr and zero. If the definition is found, return its execution token xt. If the definition is
* immediate, also return one (1), otherwise also return minus-one (-1). For a given string, the
* values returned by FIND while compiling may differ from those returned while not compiling.
* See: 3.4.2 Finding definition names, A.6.1.0070 ', A.6.1.2510 ['], A.6.1.2033 POSTPONE,
* D.6.7 Immediacy.
*/
$CODE 0,4,"FIND",FIND
movw %si, %ax // save %si
movzbw (%bx), %cx // put the lenght in %cx
push %bx
inc %bx
movw %bx, %si // put the addr in %si
movw _context, %dx // load addr of first vocabulary
2: movw %dx, %di // dx is the voc list pointer
movw (%di), %di // @
cmp $0, %di // if di == 0 then there is no vocabulary. ( see ALSO )
jz 5f
movw (%di), %di // @
cmp $0, %di // if di == 0 then the vocabulary is empty. ( see VOCABULARY )
jz 5f
1: movzbw 0(%di), %bx // get name lenght
inc %di // di point to first char of dictinary name
cmp %bx, %cx // compare lenght with the word provided
je 2f // if equal jump
3: movw -4(%di), %di // get the next word addr
test %di,%di
jnz 1b
// Word not found
5: add $2, %dx // get next vocabulary
cmpw $VOCC, %dx // CONTEXT == VOCC ?
jne 2b
xor %bx, %bx // word not found ( -- addr 0 )
jmp 4f
2: push %cx
push %si
push %di
repz
cmpsb // Compare words
pop %di
pop %si
pop %cx
jne 3b
pop %si // word is found ( -- 0 )
lea (%bx,%di,1), %dx // xt
mov %dx, %si // Align
and $1, %si
add %si, %dx
push %dx // ( -- xt ? )
movzbw -2(%di), %bx // flag
and $1, %bx // ( -- xt 1 )
jnz 4f
not %bx // ( -- xt -1 )
4: movw %ax, %si // restore %si
$NEXT // return
