Programmer 7500/MAX_PROGRAMMERS.iso/PROGRAMS/UTILS/LASER/FPC35_5.ZIP/FPCSRC.ZIP/KERNEL3.SEQ

Text File | 1989-08-19 | 25.0 KB | 799 lines

\ KERNEL3.SEQ   More kernel stuff

FILES DEFINITIONS

VARIABLE KERNEL3.SEQ

FORTH DEFINITIONS

: >TYPE         ( adr len -- )
                TUCK PAD SWAP CMOVE   PAD SWAP TYPE  ;

: .(            ( -- )  ASCII ) PARSE >TYPE  ; IMMEDIATE

: (             ( -- )  ASCII ) PARSE 2DROP  ; IMMEDIATE

CODE TRAVERSE   ( addr direction -- addr' )
                POP CX          POP BX
                ADD BX, CX      PUSH ES
                MOV ES, YSEG
          BEGIN
                MOV ES: AL, 0 [BX]      AND AL, # 128
       0= WHILE
                ADD BX, CX
          REPEAT
                POP ES          PUSH BX
                NEXT            END-CODE

CODE DONE?      ( n -- f )
                POP AX
                CMP AX, STATE
            0<> IF
                        MOV END? # 0 WORD
                        MOV AX, # -1
                        1PUSH
                THEN
                PUSH END?
                MOV END? # 0 WORD
                NEXT
                END-CODE

\ : DONE?         ( n -- f )
\                 STATE @ <>   END? @ OR   END? OFF   ;

: CNHASH        ( cfa -- ya )
                $0FE00 AND FLIP ;

CODE CNSRCH     ( cfa ya maxya -- nfa failf )
                pop dx          \ maxya
                pop bx          \ ya
                add bx, # 4
                pop di          \ cfa
                mov ds, yseg
        HERE    cmp dx, bx
             U> IF      mov ax, 0 [bx]
                        and ax, # 31
                        add bx, ax
                        inc bx
                        mov ax, 0 [bx]
                        cmp ax, di      \ if they match, then we found it
                     0= if      sub bx, # 2             \ 1 before last chr
                                begin   mov al, 0 [bx]  \ test high bit
                                        and al, # 128   \ loop till high set
                             0= while   dec bx          \ backup one char
                                repeat
                                push bx                 \ push pointer to chr
                                mov ax, cs              \ restore DS
                                mov ds, ax
                                mov ax, # false         \ push false flag
                                1push
                        then
                        add bx, # 6     \ step to next header
                        JMP ROT         \ bring HERE around Branch resolution
                                        \ used by IF and THEN
                THEN
                mov ax, cs      mov ds, ax
                mov ax, # true
                push ax
                1push           end-code

: N>LINK        ( anf -- alf)
                2-   ;

: L>NAME        ( alf -- anf )
                2+   ;

: BODY>         ( apf -- acf )
                3 -  ;

: NAME>         ( anf -- acf )
                1 TRAVERSE   1+ Y@  ;

: LINK>         ( alf -- acf )
                L>NAME   NAME>   ;

: >BODY         ( acf -- apf )
                3 +  ;

HERE-Y 4 +     \ Step from view field to name field

: NO-NAME       ( -- )
                ;

: >NAME         ( cfa -- nfa )
                DUP CNHASH DUP Y@ SWAP
                2+ Y@ ( cfa sya mxya ) CNSRCH
                IF      DROP (LIT) [ ROT ,-X ] THEN    ;

: >LINK         ( acf -- alf )
                >NAME   N>LINK   ;

: >VIEW         ( acf -- avf )
                >LINK   2-   ;

: VIEW>         ( avf -- acf )
                2+   LINK>   ;

COMMENT:

  The hash algorithm used is as follows:

        ((firstchar*2)+secondchar)*2)+count

  This seems to provide a good distribution across the 64 threads in
1000 word FORTH vocabulary.

COMMENT;

CODE HASH       ( str-addr voc-ptr -- thread )
                POP CX          POP BX
                MOV AX, 1 [BX]          \ Get first and second chars
                SHL AL, # 1             \ Shift first char left one
                ADD AL, AH              \ Plus second char
                SHL AX, # 1             \ The sum shifted left one again
                ADD AL, 0 [BX]          \ Plus count byte
                AND AX, # #THREADS 1-
                SHL AX, # 1     ADD AX, CX
                1PUSH           END-CODE

CODE (FIND)     ( here alf -- cfa flag | here false )
                POP BX
                OR BX, BX
             0= IF
                        SUB AX, AX
                        1PUSH
                THEN
                POP CX
                PUSH ES
                MOV ES, YSEG
                MOV DI, CX
            BEGIN
                MOV ES: AX, 2 [BX]
                XOR AX, 0 [DI]
                AND AX, # ( 63 ) $7F3F
             0= IF
                        MOV DX, BX
                        ADD BX, # 2
                        BEGIN
                                INC BX  INC DI
                                MOV ES: AL, 0 [BX]
                                XOR AL, 0 [DI]
                    0<> UNTIL
                        AND AL, # 127
                     0= IF
                                MOV ES: CX, 1 [BX]      \ pick up CFA
                                MOV BX, DX
                                MOV ES: AL, 2 [BX]
                                AND AL, # 64
                                0<> IF
                                    MOV AX, # 1
                                ELSE
                                    MOV AX, # -1
                                THEN
                                POP ES
                                PUSH CX
                                1PUSH
                        THEN
                        MOV BX, DX
                        MOV DI, CX
                THEN
                MOV ES: BX, 0 [BX]
                OR BX, BX
        0= UNTIL
                POP ES
                PUSH CX
                SUB AX, AX
                1PUSH           END-CODE

HEADERLESS      \ Disable generation of headers

CODE DROP.CONTEXT.I2*+@DUP   ( a1 -- n1 )
                ADD SP, # 2
                MOV AX, 0 [RP]
                ADD AX, 2 [RP]
                SHL AX, # 1
                MOV BX, # CONTEXT
                ADD BX, AX
                MOV AX, 0 [BX]
                PUSH AX
                1PUSH
                END-CODE

                                \ DUP PRIOR @ OVER PRIOR ! =
CODE PRIOR.CHECK ( n1 -- n1 f1 )
                MOV   BX, SP
                MOV   AX, 0 [BX]
                MOV BX, PRIOR
                MOV PRIOR AX
                CMP BX, AX
            0<> IF
                        SUB AX, AX
                        1PUSH
                THEN
                MOV AX, # TRUE
                1PUSH
                END-CODE

CODE OVER.SWAP.HASH.@     ( n1 n2 -- n1 n3 )
                POP AX
                MOV BX, SP
                MOV BX, 0 [BX]
                MOV CL, 0 [BX]
                MOV BX, 1 [BX]
                SHL BL, # 1
                ADD BL, BH
                SHL BL, # 1
                ADD BL, CL
                AND BX, # #THREADS 1-
                SHL BX, # 1
                ADD BX, AX
                PUSH 0 [BX]
                NEXT            END-CODE

HEADERS         \ Restore generation of TARGET HEADERS

: %%FIND        ( addr false #vocs 0 -- cfa flag | addr false )
                DO      DROP.CONTEXT.I2*+@DUP
                        IF      PRIOR.CHECK
                                IF      DROP FALSE
                                ELSE    OVER.SWAP.HASH.@ (FIND)
                                        DUP ?LEAVE
                                THEN
                        THEN
                LOOP    ;

CODE %FIND      ( addr -- cfa flag | addr false )
                MOV DI, SP
                MOV BX, 0 [DI]
                CMP 0 [BX], # 0 BYTE
            0<> IF
                        MOV PRIOR # 0 WORD                      \ prior off
                        MOV BX, # 0             PUSH BX         \ false
                        MOV CX, # #VOCS         PUSH CX         \ #vocs
                                                PUSH BX         \ 0
                        MOV AX, # ' %%FIND
                        JMP AX
                THEN
                MOV END? # TRUE WORD
                MOV 0 [DI], # ' NOOP WORD
                MOV AX, # 1
                1PUSH           END-CODE

DEFER FIND      ' %FIND IS FIND

: DEFINED       ( -- here 0 | cfa [ -1 | 1 ] )
                BL WORD  ?UPPERCASE  FIND   ;

HEADERLESS

: STACKUNDER    ( -- )
                TRUE ABORT" Stack Underflow" ;

: STACKOVER     ( -- )
                TRUE ABORT" Stack Overflow" ;

: WARNOVER      ( -- )
                CR ."  Running out of CODE memory! " ;

HEADERS

CODE (?STACK)   ( -- )
                MOV CX, SP
                MOV BX, UP
                MOV DX, SP0 [BX]
                CMP DX, CX
             U< IF
                        MOV AX, # ' STACKUNDER
                        JMP AX
                THEN
                MOV DX, DP [BX]
                ADD DX, # 80
                CMP CX, DX
             U< IF
                        MOV AX, # ' STACKOVER
                        JMP AX
                THEN
                ADD DX, # 200
                CMP CX, DX
             U< IF
                        MOV AX, # ' WARNOVER
                        JMP AX
                THEN
                NEXT            END-CODE

DEFER ?STACK    ' (?STACK) IS ?STACK

: INTERP        ( -- )
                BEGIN   ?STACK DEFINED
                        IF     EXECUTE
                        ELSE   NUMBER  DOUBLE? NOT IF  DROP  THEN
                        THEN   FALSE DONE?
                UNTIL   ;

DEFER STATUS    ( -- )

DEFER INTERPRET ' INTERP IS INTERPRET

: PRINT         ( -- ) PRINTING ON INTERPRET PRINTING OFF ;

: ALLOT         ( n -- )      DP +!   ;

CODE ,          ( n -- )
                MOV BX, UP
                MOV AX, DP [BX]
                ADD DP [BX], # 2 WORD
                MOV BX, AX
                POP CX
                MOV 0 [BX], CX
                NEXT
                END-CODE

CODE C,         ( n -- )
                MOV BX, UP
                MOV AX, DP [BX]
                INC DP [BX] WORD
                MOV BX, AX
                POP CX
                MOV 0 [BX], CL
                NEXT
                END-CODE

: PARAGRAPH     ( offset -- paragraph-inc )
                15 + U16/ ;

: ALIGN         ( -- )
                ( HERE 1 AND IF  BL C,  THEN )  ; IMMEDIATE

: EVEN          ( n1 -- n2 )
                ( DUP 1 AND + ) ;  IMMEDIATE

: COMPILE       ( -- )
                2R@ R> 2+ >R @L X,   ;

: IMMEDIATE     ( -- )
                64 ( Precedence bit ) LAST @ YCSET  ;

: LITERAL       ( n -- )
                COMPILE (LIT) X, ; IMMEDIATE

: DLITERAL      ( d# -- )
                SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE

: ASCII         ( -- n )
                BL WORD   1+ C@
                STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE

: CONTROL       ( -- n )
                BL WORD   1+ C@  31 AND
                STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE

: CRASH         ( -- )
                2R@ 2- @L >NAME CR .ID TRUE
                ABORT" <- is an Uninitialized execution vector."  ;

: ?MISSING      ( f -- )
                IF      SPACE HERE COUNT TYPE
                        TRUE ABORT"  <- What? "
                THEN    ;

: '             ( -- cfa )
                DEFINED 0= ?MISSING   ;

: [']           ( -- )
                ' COMPILE <'> X, ; IMMEDIATE

: [COMPILE]     ( -- )
                ' X,   ; IMMEDIATE

VARIABLE  "BUF 132 ALLOT

: XEVEN         ( xdp -- xdp_even )
                DUP 1 AND + ;

: XALIGN        ( -- )
                XHERE NIP 1 AND XDP +! ;

: X>"BUF        ( -- "buf )
                2R>
                2R@ 2DUP C@L 1+ DUP XEVEN R> + >R
                        ?CS: "BUF ROT CMOVEL
                2>R "BUF ;

: (")           ( -- addr len )
                2R@ @L COUNT R> 2+ >R ;

: (X")           ( -- addr len )
                X>"BUF COUNT ;

: %(.")         ( -- )
                2R@ 2DUP C@L >R 1+ R@ TYPEL R> 1+ XEVEN R> + >R ;

DEFER (.")      ' %(.") IS (.")

: ,"            ( -- )
                ASCII " PARSE TUCK HERE PLACE 1+ ALLOT ;

: X,"           ( -- )
                ASCII " PARSE HERE PLACE
                ?CS: HERE DUP C@ 1+ >R XHERE R@ CMOVEL
                R> XEVEN XDP +! ;

: ."            ( -- )          COMPILE (.") X,"   ;   IMMEDIATE

: "             ( -- )          COMPILE (")  HERE X, ,"   ;   IMMEDIATE

: ""            ( -- )          COMPILE (X")  X,"   ;   IMMEDIATE

: ">$           ( a1 -- a2 )
                DROP 1- ;

VARIABLE FENCE

: TRIM          ( faddr voc-addr -- )
                #THREADS 0
                DO      2DUP @ BEGIN   2DUP U> NOT WHILE Y@ REPEAT
                        NIP OVER ! 2+
                LOOP    2DROP   ;

: (FRGET)       ( code-addr view-addr -- )
                DUP FENCE @ U< ABORT" Below fence"  ( ca va )
                OVER VOC-LINK @ BEGIN   2DUP U< WHILE   @ REPEAT
                DUP VOC-LINK !  ( ca va ca pt ) NIP
                BEGIN   DUP WHILE   2DUP #THREADS 2* - TRIM   @   REPEAT
                DROP    YDP !
                DUP 1+ @ OVER >BODY +
                (LIT)   TRIM DUP 1+ @ SWAP >BODY + =    \ If it's a : def
                IF      DUP >BODY @ +XSEG XDPSEG !   \ Set back XHERE too!
                        XDP OFF
                THEN    DP !  ;

DEFER ?ERROR

                                        \ 07/03/89 TJZ
: (ABORT")      ( f -- )                \ if f1 true, then display inline
                ?DUP                    \ compiled message from LIST space
                IF
                        X>"BUF COUNT ROT ?ERROR
                ELSE    2R@ C@L 1+ XEVEN R> + >R
                THEN    ;

: ABORT"        ( -- )
                COMPILE (ABORT") X," ;   IMMEDIATE

: ABORT         ( -- )
                TRUE ABORT" "  ;

: FORGET        ( -- )
                BL WORD ?UPPERCASE DUP CURRENT @ HASH @
                (FIND) 0= ?MISSING DUP >VIEW (FRGET) ;

: ?CONDITION    ( f -- )
                NOT ABORT" Conditionals Wrong"   ;

: >MARK         ( -- addr )
                XHERE NIP 0 X,   ;

: >RESOLVE      ( addr -- )
                XHERE -ROT SWAP !L   ;

: <MARK         ( -- addr )
                XHERE NIP ;

: <RESOLVE      ( addr -- )
                X, ;

: ?>MARK        ( -- f addr )
                TRUE >MARK   ;

: ?>RESOLVE     ( f addr -- )
                SWAP ?CONDITION >RESOLVE  ;

: ?<MARK        ( -- f addr )
                TRUE   <MARK   ;

: ?<RESOLVE     ( f addr -- )
                SWAP ?CONDITION <RESOLVE  ;

comment:
        LEAVE and ?LEAVE could be non-immediate in this system, but the 83
        standard specifies an immediate LEAVE, so they  both are for
        uniformity.
comment;

: LEAVE         ( -- )
                COMPILE (LEAVE)  ; IMMEDIATE

: ?LEAVE        ( f1 -- )
                COMPILE (?LEAVE) ; IMMEDIATE

comment:
        BEGIN, THEN, DO ?DO, LOOP, +LOOP, UNTIL, AGAIN, REPEAT, IF ELSE,
        WHILE: These are the compiling words needed to properly compile the
        Forth Conditional Structures. Each of them is immediate and they
        must compile their runtime routines along withwhatever addresses
        they need. A modest amount of errorchecking is done. If you want to
        rip out the error checking change the ?> and ?< words to > and <
        words, and all of the 2DUPs to DUPs and the 2SWAPs to SWAPs. The
        rest should stay the same.

        DOAGAIN, DOTHEN, DOBEGIN, ?UNTIL & ?WHILE are words that are NOOPs
        , or equivalant to ?BRANCH. They are provided to make it easier for
        the Decompiler to know where the control structures start and end.
comment;

: BEGIN         ( -- )
                COMPILE DOBEGIN ?<MARK                          ; IMMEDIATE

: AGAIN         ( -- )
                COMPILE DOAGAIN ?<RESOLVE                       ; IMMEDIATE

: UNTIL         ( n -- )
                COMPILE ?UNTIL  ?<RESOLVE                       ; IMMEDIATE

: WHILE         ( n -- )
                COMPILE ?WHILE ?>MARK 2SWAP ( <- added )        ; IMMEDIATE

: REPEAT        ( -- )       ( 2SWAP removed )
                COMPILE DOREPEAT ?<RESOLVE ?>RESOLVE            ; IMMEDIATE

: DO            ( lim start -- )
                COMPILE (DO)   ?>MARK                           ; IMMEDIATE

: ?DO           ( lim start -- )
                COMPILE (?DO)  ?>MARK                           ; IMMEDIATE

: LOOP          ( -- )
                COMPILE (LOOP)  2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE

: +LOOP         ( n -- )
                COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE

: IF            ( n -- )
                COMPILE  ?BRANCH  ?>MARK                        ; IMMEDIATE

: ELSE          ( -- )
                COMPILE  BRANCH ?>MARK  2SWAP ?>RESOLVE         ; IMMEDIATE

: THEN          ( -- )
                COMPILE DOTHEN ?>RESOLVE                        ; IMMEDIATE

: FORWARD       ( -- )
                COMPILE BRANCH ?>MARK                           ; IMMEDIATE

: CONTINUE      ( -- )
                2OVER [COMPILE] REPEAT                          ; IMMEDIATE

: BREAK         ( -- )
                COMPILE EXIT [COMPILE] THEN                     ; IMMEDIATE

: AFT           ( -- )
                2DROP [COMPILE] FORWARD ?<MARK 2SWAP            ; IMMEDIATE

: FOR           ( n1 -- )
                COMPILE >R ?<MARK                               ; IMMEDIATE

: NEXT          ( -- )
                COMPILE NEXT| ?<RESOLVE                         ; IMMEDIATE

: ,VIEW         ( -- )
                LOADLINE @ Y, ;

HEADERLESS

: NOHEADROOM    ( -- )
                TRUE ABORT" Out of HEAD memory!" ;

: NOLISTROOM    ( -- )
                TRUE ABORT" Out of LIST memory!" ;

HEADERS

CODE SPCHECK    ( -- f1 f2 )           \ HEAD AND LIST SPACE CHECK
                MOV AX, YDP             \ get head DP
                SHR AX, # 1             \ convert to ssegment
                SHR AX, # 1
                SHR AX, # 1
                SHR AX, # 1
                ADD AX, # 6             \ add 6 segments for headroom
                CMP AX, ' #HEADSEGS >BODY \ are we out of space yet
             >  IF      MOV AX, # ' NOHEADROOM
                        JMP AX
                THEN
                MOV AX, XDPSEG          \ load up LIST segment
                SUB AX, XSEG            \ convert to size of list so far
                ADD AX, # 6             \ add 6 for headroom
                CMP AX, ' #LISTSEGS >BODY \ are we out of space yet
             >  IF      MOV AX, # ' NOLISTROOM
                        JMP AX
                THEN
                NEXT
                END-CODE

: %ALREADY_DEF  ( a1 -- a1 )   \ Is the word at A1 already defined?
                WARNING @
                IF      DUP FIND NIP
                        IF      DUP  CR  COUNT TYPE ."  isn't unique "
                        THEN
                THEN    ;       ( str )

DEFER ?ALREADY_DEF      ' %ALREADY_DEF IS ?ALREADY_DEF

: "HEADER       ( str-addr -- )
                SPCHECK
                DUP C@ 31 > ABORT" Name TOO LONG, > 31 chars!"
                ?ALREADY_DEF
                ALIGN  YHERE 2- Y@ CNHASH  HERE CNHASH  <>
                IF      YHERE HERE CNHASH DUP Y@ ROT UMIN SWAP
                        Y! ( >NAME hash entry )
                THEN    ,VIEW
                YHERE OVER CURRENT @ HASH DUP @  Y,  ( link  ) ! ( current )
                YHERE LAST ! ( remember nfa )
                YHERE ?CS: ROT  DUP C@  WIDTH @  MIN 1+ >R  ( yh cs str )
                YHERE YS: R@ CMOVEL ( copy str ) R> YDP +! ALIGN ( nam )
                128 SWAP YCSET   128 YHERE 1- YCSET   ( delimiter Bits )
                HERE Y, ( CFA in header )
                YHERE HERE CNHASH 2+ Y! ( valid stopper in next n hash entry)
                ;

: ,CALL         ( -- )
                232 C, 0 HERE 2+ - , ;        \ Compiles addr 0000 !!!!

: ,JUMP         ( -- )
                233 C, 0 HERE 2+ - , ;

: <HEADER>      ( | name -- )
                BL WORD ?UPPERCASE "HEADER ;

DEFER HEADER    ' <HEADER> IS HEADER

: "CREATE       ( str-addr -- )
                "HEADER ,CALL ;USES >NEXT ,-X

: CREATE        ( | name -- )
                HEADER ,CALL ;USES >NEXT ,-X

: !CSP          ( -- )
                SP@ CSP !   ;

: ?CSP          ( -- )
                SP@ CSP @ <> ABORT" Stack Changed"   ;

: HIDE          ( -- )
                LAST @ DUP N>LINK Y@ SWAP CURRENT @ YHASH ! ;

: REVEAL        ( -- )
                LAST @ DUP N>LINK    SWAP CURRENT @ YHASH ! ;

: (;USES)       ( -- )
                2R> @L LAST @ NAME> dup>r 3 + - R> 1+ ! ;

: (;CODE)       ( -- )
                2R> @L LAST @ NAME>
                dup>r 232 ( CALL ) R@ C!       \ Make a CALL not JUMP
                3 + - R> 1+ !  ;

: DOES>         ( -- )
                COMPILE (;CODE) HERE X, 232 ( CALL ) C,
                [ [FORTH] ASSEMBLER DODOES META ] LITERAL
                HERE 2+ - , XHERE PARAGRAPH + DUP XDPSEG !
                XSEG @ - , XDP OFF ; IMMEDIATE

VOCABULARY ASSEMBLER

DEFER SETASSEM  \ Setup for assembly stuff to follow

' NOOP IS SETASSEM

: [             ( -- )
                STATE OFF   ;   IMMEDIATE

: ;USES         ( -- )
                ?CSP   COMPILE  (;USES)
                [COMPILE] [   REVEAL   ASSEMBLER   ; IMMEDIATE

: ;CODE         ( -- )
                ?CSP   COMPILE  (;CODE) HERE X,
                [COMPILE] [   REVEAL   SETASSEM ; IMMEDIATE

: (])           ( -- )
                STATE ON
                BEGIN   ?STACK  DEFINED DUP
                        IF      0>
                                IF      EXECUTE   ELSE   X,   THEN
                        ELSE    DROP    NUMBER  DOUBLE?
                                IF           [COMPILE] DLITERAL
                                ELSE    DROP [COMPILE] LITERAL
                                THEN
                        THEN    TRUE    DONE?
                UNTIL   ;

DEFER ]         ' (]) IS ]

: MAKEDUMMY     ( name -- )
                HEADER ,JUMP
                XHERE PARAGRAPH +       \ absolute paragraph of new def
                DUP XDPSEG !            \ set new XHERE segment
                XSEG @ - ,              \ compile relative paragraph of def
                XDP OFF
                COMPILE UNNEST
                ;USES  NEST ,-X

: ANEW          ( name -- )
                >IN @ >R DEFINED NIP  R@ >IN !
                IF      FORGET
                THEN    R> >IN !  MAKEDUMMY   ;
                                                        \ Add if needed
: (:)           ( -- )
                !CSP   CURRENT @ CONTEXT !
                HEADER ,JUMP
                XHERE PARAGRAPH +
                DUP XDPSEG !
                XSEG @ - ,
                XDP OFF
                HIDE
                ;USES   NEST ,-X

: :             ( -- )
                (:) ] ;

: ;             ( -- )
                STATE @ 0= ABORT" Not Compiling!"
                ?CSP   COMPILE UNNEST   REVEAL   [COMPILE] [  ; IMMEDIATE

: RECURSIVE     ( -- )
                REVEAL ;   IMMEDIATE

: CONSTANT      ( n -- )
                HEADER ,JUMP ,     ;USES DOCONSTANT ,-X

: VALUE         ( n -- )
                HEADER ,JUMP ,     ;USES DOVALUE    ,-X

: VARIABLE      ( -- )
                CREATE 0 ,         ;USES >NEXT      ,-X

: ARRAY         ( n1 -- )
                CREATE ALLOT       ;USES >NEXT      ,-X

: DEFER         ( -- )
                CREATE ['] CRASH , ;USES DODEFER    ,-X

DODEFER RESOLVES <DEFER>

: VOCABULARY    ( -- )
                CREATE   #THREADS 0 DO   0 ,  LOOP
                HERE  VOC-LINK @ ,  VOC-LINK !
                DOES> CONTEXT !  ;

 RESOLVES <VOCABULARY>

: DEFINITIONS   ( -- )
                CONTEXT @ CURRENT !   ;

: 2CONSTANT     ( d1 | <name> -- )
                CREATE   , ,    ( d# -- )
                DOES> 2@   ;    ( -- d# )   DROP

: 2VARIABLE     ( | <name> -- )
                0 0 2CONSTANT   ( -- )
                DOES> ;         ( -- addr )   DROP

: <RUN>         ( -- )
        STATE @ IF      ]
                        STATE @ NOT
                        IF   INTERPRET   THEN
                ELSE    INTERPRET   THEN   ;

DEFER RUN       ' <RUN> IS RUN

DEFER ERRFIX    ' NOOP IS ERRFIX

: (?ERROR)      ( adr len f -- )
                IF      ['] <RUN> IS RUN ERRFIX
                        2>R SP0 @ SP!   PRINTING OFF
                        2R> SPACE TYPE SPACE   QUIT
                ELSE    2DROP  THEN  ;

' (?ERROR) IS ?ERROR