( copyright PPC Paris et l'Auteur, 1987 )
: TYPES ;

VOCABULARY vt IMMEDIATE
vt DEFINITIONS

" OWRDS" ASSEMBLE

VARIABLE OFSET
VARIABLE VAR-EX
VARIABLE CR-TYPE?

HEX

: SEARCHW
  >R BL WORD COUNT 2DUP 1- 2* + 80 TOGGLE
  BEGIN
   2DUP R@ COUNT 1F AND S= NOT
   WHILE
   R> 5- @ ?DUP 0= ABORT" Undefined operation"
   >R
  REPEAT
  2DROP R> 1 TRAVERSE 2+ ;

: EX-OBJ-NOR
  DUP @ SEARCHW
  STATE @ 0=
  IF
   SWAP 5+ SWAP EXECUTE
  ELSE
   SWAP 5+ [COMPILE] LITERAL ,
  THEN ;

: EX-OBJ-TY
  DUP 5+ @ SEARCHW
  STATE @ 0=
  IF
   SWAP @ O@ + SWAP EXECUTE
  ELSE
   SWAP @ COMPILE LIT-TY , ,
  THEN ;

: DOES>
  E601C , F8 C, E713B , ; IMMEDIATE

: CR-OBJ
  CR-TYPE? @
  IF
   CREATE
   OFSET @ , DUP @ , 5+ @ OFSET +! IMMEDIATE
   DOES> EX-OBJ-TY
  ELSE
   CREATE
   DUP @ , 5+ @ NALLOT IMMEDIATE
   DOES> EX-OBJ-NOR
  THEN ;

: STr
  DOES> @ O@ + COUNT ;

: O>D O> DROP ;

: CALC-ADR-NOR
  DUP >R 5+ @ * R> 5+ 5+ + ;

: CALC-ADR-TY
  DUP >R 5+ 5+ @ * R> @ + O@ + ;

: EX-AR-TY
  DUP 5+ @ SEARCHW >R
  STATE @ 0=
  IF
   CALC-ADR-TY R> EXECUTE
  ELSE
   VAR-EX @
   IF
    0 VAR-EX ! CALC-ADR-TY [COMPILE] LITERAL R> ,
   ELSE
    [COMPILE] LITERAL COMPILE CALC-ADR-TY R> ,
   THEN
  THEN ;

: EX-AR-NOR
  DUP @ SEARCHW >R
  STATE @ 0=
  IF
   CALC-ADR-NOR R> EXECUTE
  ELSE
   VAR-EX @
   IF
    0 VAR-EX !
    CALC-ADR-NOR [COMPILE] LITERAL R> ,
   ELSE
    [COMPILE] LITERAL COMPILE CALC-ADR-NOR R> ,
   THEN
  THEN ;

FORTH DEFINITIONS

DECIMAL

: VAR vt
  CREATE
  OFSET @ DUP , + OFSET !
  DOES> @ O@ + ;

: STR vt
  CREATE
  DUP 2* OFSET @ 2+ DUP , + OFSET ! ,
  DOES> ['] STr 5+ 5+ OVER 5- !
  DUP @ O@ + SWAP 5+ @ OVER 2- ! 0 ;

: TYPE> vt
  CREATE
  1 CR-TYPE? ! 0 OFSET ! O0 0 VAR-EX ! 1 OKFLG !
  LATEST 5- DUP >O @ >O
  20 >O ;

: OPS> vt
  O> 20 <> ABORT" ERR:Illegal TYPE> structure"
  HERE >O 0 >O 21 >O ;

: INCLUDE> vt
  O> 21 <> ABORT" ERR:Illegal TYPE> structure"
  O> DROP ' 5+ @ >O 21 >O ;

: ENDTYPE> vt
  0 OKFLG ! 0 CR-TYPE? !
  O> 21 <> ABORT" ERR:Illegal TYPE> structure"
  CREATE
  LATEST 5- @ ,
  OFSET @ ,
  O> O> !
  O> LATEST 5- !
  O> ,
  DOES> CR-OBJ ;

: {{ vt [COMPILE] : COMPILE >O ;

: }} vt COMPILE O>D [COMPILE] ; ; IMMEDIATE

: ARRAY-OF vt
  ' CREATE
  CR-TYPE? @
  IF
   OFSET @ ,
   5+ DUP @ ,
   5+ @ DUP ,
   * OFSET +! IMMEDIATE
   DOES> EX-AR-TY
  ELSE
   5+ DUP @ ,
   5+ @ DUP ,
   * NALLOT IMMEDIATE
   DOES> EX-AR-NOR
  THEN ;

: VAR[ vt
  1 VAR-EX ! 0 STATE ! ; IMMEDIATE

: SELF vt O@ ;