VolksForth/8080/CPM/cpmfiles/vf-core.fth

\ *** Block No. 2, Hexblock 2

\ FORTH Preamble and ID                            uho 19May2005

Assembler

nop  0 jmp   here 2- >label >boot
nop  0 jmp   here 2- >label >cold
nop  0 jmp   here 2- >label >restart

here dup origin!
\ Hier beginnen die Kaltstartwerte der Benutzervariablen

6 rst   0 jmp   end-code  \ for multitasker

$100 allot

| Create logo ," volksFORTH-83 rev. 3.80a"

\ *** Block No. 3, Hexblock 3

\ Assembler Labels Next Forth-Register                   29Jun86

Label dpush   D push    Label hpush   H push
Label >next
   IP ldax   IP inx   A L mov   IP ldax   IP inx   A H mov
Label >next1
   M E mov   H inx   M D mov   xchg   pchl
end-code

Variable RP
Variable UP
\ IP in BC
\ W  in DE
\ SP in SP
Variable IPsave


\ *** Block No. 4, Hexblock 4

\ Assembler Macros                                       20Oct86
Compiler Assembler also definitions  Forth
: Next    T >next jmp [ Forth ]  ;
T hpush Forth Constant hpush   T dpush Forth Constant dpush
T >next Forth Constant >next

: rpush ( reg -- )  RP lhld  H dcx  DUP M mov ( high )
   H dcx   1+ M mov ( low )   RP shld  [ Forth ] ;

: rpop  ( reg -- )  RP lhld   M over 1+ mov ( low )  H inx
   M swap mov ( high )  H inx   RP shld [ Forth ] ;
\  rpush und rpop gehen nicht mit HL

: mvx ( src dest -- )
   2dup  mov ( high )  1+ swap 1+ swap mov  ( low ) [ Forth ] ;
Target

\ *** Block No. 5, Hexblock 5

\ recover ;c: noop                                       20Oct86

Create recover   Assembler
   W pop   IP rpush   W IP mvx
Next end-code

Compiler Assembler also definitions   Forth

: ;c:   0 T recover call  end-code   ]  [ Forth ] ;

Target

| Code di   di Next end-code
| Code ei   ei Next end-code

Code noop   >next here 2- !   end-code

\ *** Block No. 6, Hexblock 6

\ User variables                                         04Oct87

Constant origin   8 uallot drop  \ Multitasker
     \ Felder: entry  link  spare  SPsave
     \ Laenge kompatibel zum 68000 und 6502 volksFORTH
User s0
User r0
User dp
User offset            0 offset !
User base              $0A base !
User output
User input
User errorhandler       \ pointer for Abort" -code
User voc-link
User udp                \ points to next free addr in User


\ *** Block No. 7, Hexblock 7

\ manipulate system pointers                             11Jun86

Code sp@  ( -- addr)   0 H lxi   SP dad   hpush jmp   end-code

Code sp!  ( addr --)   H pop   sphl   Next   end-code


Code up@  ( -- addr)   UP lhld   hpush jmp   end-code

Code up!  ( addr --)   H pop   UP shld   Next   end-code







\ *** Block No. 8, Hexblock 8

\ manipulate returnstack                                 11Jun86

Code rp@ ( -- addr )   RP lhld   hpush jmp   end-code

Code rp! ( addr -- )   H pop   RP shld   Next  end-code


Code >r  ( 16b -- )    D pop   D rpush   Next end-code restrict

Code r>  ( -- 16b )    D rpop   D push   Next end-code restrict







\ *** Block No. 9, Hexblock 9

\ r@ rdrop  exit unnest ?exit                            07Oct87
Code r@ ( -- 16b )
   RP lhld   M E mov   H inx   M D mov   D push   Next  end-code

Code rdrop
   RP lhld   H inx   H inx   RP shld   Next end-code   restrict

Code exit    Label >exit   IP rpop   Next  end-code
Code unnest   >exit  here 2- !

Code ?exit ( flag -- )
   H pop   H A mov   L ora   >exit jnz   Next end-code

Code 0=exit ( flag -- )
   H pop   H A mov   L ora   >exit jz    Next end-code
\ : ?exit ( flag -- )   IF rdrop THEN ;

\ *** Block No. 10, Hexblock a

\ execute  perform                             11Jun86   18Nov87

Code execute   ( cfa -- )
   H pop >Next1 jmp end-code

Code perform   ( 'cfa -- )
   H pop    M A mov   H inx   M H mov   A L mov  >Next1 jmp
end-code


\ \\
\ : perform   ( addr -- )      @ execute ;





\ *** Block No. 11, Hexblock b

\ c@ c! ctoggle                                          07Oct87

Code c@   ( addr -- 8b )
   H pop   M L mov   0 H mvi   hpush jmp   end-code

Code c!   ( 16b addr -- )
   H pop   D pop    E M mov   Next   end-code

Code flip ( 16b1 -- 16b2 )
   H pop   H A mov   L H mov   A L mov   Hpush jmp   end-code

Code ctoggle ( 8b addr -- )
   H pop   D pop   M A mov   E xra   A M mov   Next  end-code

\ \\
\ : ctoggle   ( 8b addr --)      under c@ xor swap c! ;

\ *** Block No. 12, Hexblock c

\ @ ! 2@ 2!                                    11Jun86   18Nov87

Code @  ( addr -- 16b )   H pop   Label fetch
  M E mov   H inx   M D mov   D push   Next   end-code

Code !  ( 16b addr -- )
   H pop   D pop   E M mov   H inx   D M mov   Next   end-code

Code 2@   ( addr -- 32b )   H pop   H push
   H inx  H inx   M E mov   H inx   M D mov   H pop   D push
   M E mov   H inx   M D mov  D push    Next   end-code

Code 2!   ( 32b addr -- )   H pop
   D pop    E M mov   H inx   D M mov   H inx
   D pop    E M mov   H inx   D M mov   Next   end-code


\ *** Block No. 13, Hexblock d

\ +! drop swap                                 11Jun86   18Nov87

Code +! ( 16b addr -- )  H pop
   Label +store   D pop
     M A mov   E add   A M mov   H inx
     M A mov   D adc   A M mov    Next   end-code

\  : +!   ( n addr -- )   under @ + swap ! ;


Code drop   ( 16b -- )   H pop   Next   end-code

Code swap   ( 16b1 16b2 -- 16b2 16b1 )
   H pop   xthl   hpush jmp   end-code



\ *** Block No. 14, Hexblock e

\ dup  ?dup                                              16May86

Code dup    ( 16b -- 16b 16b )
   H pop   H push   hpush jmp   end-code

Code ?dup ( 16b -- 16b 16b / false)
   H pop   H A mov   L ora   0<> ?[ H push ]?
   hpush jmp   end-code

\ \\
\ : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ;
\
\ : dup ( 16b -- 16b 16b )    sp@ @ ;




\ *** Block No. 15, Hexblock f

\ over rot nip under                                     11Jun86

Code over   ( 16b1 16b2 - 16b1 16b2 16b1 )
   D pop   H pop   H push   dpush jmp   end-code
Code rot    ( 16b1 16b2 16b3 - 16b2 16b3 16b1 )
   D pop   H pop   xthl   dpush jmp   end-code
Code nip ( 16b1 16b2 -- 16b2)
   H pop   D pop   hpush jmp   end-code
Code under ( 16b1 16b2 -- 16b2 16b1 16b2)
   H pop   D pop   H push  dpush jmp   end-code

\ \\
\ : over   >r swap r> swap ;
\ : rot   >r dup r> swap ;
\ : nip   swap drop ;
\ : under swap over ;

\ *** Block No. 16, Hexblock 10

\ -rot pick roll -roll                                   11Jun86
Code -rot    ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 )
   H pop    D pop   xthl   H push   D push   Next   end-code

Code pick    ( n -- 16b.n )
   H pop   H dad   SP dad
   M E mov   H inx   M D mov   D push   Next   end-code

: roll   ( n -- )
   dup >r  pick sp@ dup 2+  r> 1+ 2* cmove> drop ;

: -roll   ( n -- ) >r dup sp@ dup 2+
   dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ;
\ \\
\ : -rot    ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 )   rot rot ;
\ : pick    ( n -- 16b.n )     1+ 2* sp@ + @ ;

\ *** Block No. 17, Hexblock 11

\ double word stack manipulation                         09May86
Code 2swap ( 32b1 32b2 -- 32b2 32b1)
   H pop   D pop   xthl   H push
   5 H lxi   SP dad   M A mov    D M mov   A D mov
   H dcx   M A mov   E M mov   A E mov   H pop   dpush jmp
end-code

Code 2drop ( 32b -- )   H pop   H pop   Next   end-code

Code 2dup ( 32b -- 32b 32b)
   H pop   D pop   D push   H push   dpush jmp   end-code

\ \\
\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ;
\ : 2drop ( 32b -- ) drop drop ;
\ : 2dup ( 32b -- 32b 32b) over over ;

\ *** Block No. 18, Hexblock 12

\ + and or xor not                                       09May86
Code +     ( n1 n2 -- n3 )
   H pop   D pop   D dad   hpush jmp end-code
Code or    ( 16b1 16b2 -- 16b3 )
   H pop   D pop   H A mov  D ora  A H mov
   L A mov   E ora   A L mov   hpush jmp end-code
Code and   ( 16b1 16b2 -- 16b3 )
   H pop   D pop   H A mov   D ana   A H mov
   L A mov   E ana   A L mov   hpush jmp   end-code
Code xor   ( 16b1 16b2 -- 16b3 )
   H pop   D pop   H A mov   D xra   A H mov
   L A mov   E xra   A L mov   hpush jmp   end-code
Code not   ( 16b1 -- 16b2 )  H pop  Label >not
   H A mov   cma    A H mov   L A mov   cma   A L mov
   hpush jmp   end-code


\ *** Block No. 19, Hexblock 13

\ -  negate                                              16May86

Code -    ( n1 n2 -- n3 )
   D pop   H pop
   L A mov   E sub   A L mov
   H A mov   D sbb   A H mov   hpush jmp end-code

Code negate ( n1 -- n2 )
   H pop   H dcx   >not jmp   end-code

\ \\
\ : -    ( n1 n2 -- n3 )   negate + ;





\ *** Block No. 20, Hexblock 14

\ dnegate d+                                   10Mar86   18Nov87

Code dnegate   ( d1 -- -d1 )  H pop
   Label >dnegate
      D pop   A sub   E sub   A E mov   0 A mvi   D sbb
      A D mov   0 A mvi   L sbb   A L mov   0 A mvi   H sbb
      A H mov   dpush jmp   end-code

Code d+        ( d1 d2 -- d3)
   6 H lxi   SP dad   M E mov   C M mov   H inx
   M D mov   B M mov  B pop   H pop   D dad   xchg
   H pop   L A mov   C adc   A L mov   H A mov   B adc
   A H mov   B pop   dpush jmp   end-code




\ *** Block No. 21, Hexblock 15

\ 1+ 2+ 3+ 4+ 6+    1- 2- 4-                             27Apr86
Code 1+ ( n1 -- n2 )    H pop   H inx   hpush jmp   end-code
Code 2+ ( n1 -- n2 )
   H pop    H inx   H inx   hpush jmp   end-code
Code 3+ ( n1 -- n2 )
   H pop   H inx   H inx   H inx   hpush jmp   end-code
Code 4+ ( n1 -- n2 )
   H pop   4 D lxi   D dad   hpush jmp   end-code
| Code  6+ ( n1 -- n2 )
   H pop   6 D lxi   D dad   hpush jmp   end-code
Code 1- ( n1 -- n2 )    H pop   H dcx   hpush jmp   end-code
Code 2- ( n1 -- n2 )
   H pop    H dcx   H dcx   hpush jmp   end-code
Code 4- ( n1 -- n2 )
   H pop   -4 D lxi   D dad   hpush jmp   end-code


\ *** Block No. 22, Hexblock 16

\ number Constants                                       07Oct87
-1 Constant true      0 Constant false

 0 ( --  0 )   Constant   0
 1 ( --  1 )   Constant   1
 2 ( --  2 )   Constant   2
 3 ( --  3 )   Constant   3
 4 ( --  4 )   Constant   4
-1 ( -- -1 )   Constant  -1

Code on ( addr -- )  H pop   $FF A mvi
 Label set   A M mov   H inx   A M mov   Next
Code off ( addr -- )   H pop   A xra   set jmp   end-code

\  : on   ( addr -- )   true  swap ! ;
\ : off  ( addr -- )   false swap ! ;

\ *** Block No. 23, Hexblock 17

\ words for number literals                              16May86

Code lit   ( -- 16b )
   IP ldax   A L mov   IP inx   IP ldax   A H mov   IP inx
hpush jmp end-code

Code clit   ( -- 8b )
   IP ldax   A L mov   0 H mvi   IP inx   hpush jmp
end-code

: Literal  ( 16b -- )
   dup $FF00 and   IF  compile lit , exit  THEN
   compile clit c, ; immediate restrict




\ *** Block No. 24, Hexblock 18

\ comparision words                                      18Nov87
Label  (u<  ( HL,DE  ->  HL u< DE  c,z )
   H A mov   D cmp   rnz   L A mov   E cmp   ret
Label  (<   ( HL,DE  ->  HL  < DE  c,z )
   H A mov   D xra   (u< jp    D A mov   H cmp   ret

Label yes  true  H lxi  hpush jmp
Code u< ( u1 u2 -- flag )   D pop   H pop
   Label uless   (u< call   yes jc
   Label no   false H lxi   hpush jmp

Code <     ( n1 n2 -- flag )   D pop   H pop
   Label less    (< call  yes jc  no jmp   end-code

Code u> ( u1 u2 -- flag )  H pop   D pop  uless jmp   end-code
Code >  ( n1 n2 -- flag )  H pop   D pop   less jmp   end-code

\ *** Block No. 25, Hexblock 19

\ comparision words                                      18Nov87
Code 0< ( n1 n2 -- flag )   H pop
   Label negative   H dad   yes jc   no jmp   end-code

Code 0> ( n -- flag )   H pop   H A mov   A ora   no jm
                        L ora   yes jnz   no jmp   end-code

Code 0= ( n -- flag )   H pop
   Label zero=   H A mov   L ora   yes jz    no jmp   end-code

Code 0<>  ( n -- flag )
   H pop   H A mov   L ora   yes jnz   no jmp   end-code

Code =    ( n1 n2 -- flag )  H pop   D pop
   L A mov   E cmp   no jnz
   H A mov   D cmp   no jnz   yes jmp   end-code

\ *** Block No. 26, Hexblock 1a

\ \\ comparision words high level                          18Nov87
\ : 0<  ( n1 -- flag )       8000 and 0<> ;
\ : >   ( n1 n2 -- flag )    swap < ;
\ : 0>  ( n -- flag )        negate 0< ;
\ : 0<> ( n -- flag )        0= not ;
\ : u>  ( u1 u2 -- flag )    swap u< ;
\ : =   ( n1 n2 -- flag )    - 0= ;
\ : uwithin  ( u1 [low up[ -- flag )    over - -rot  - u> ;
\ | : minimax  ( n1 n2 flag -- n3 )   rdrop IF swap THEN drop ;
\ : min  ( n1 n2 -- n3 )              2dup  > minimax ;
\ : max  ( n1 n2 -- n3 )              2dup  < minimax ;
\ : umax  ( u1 u2 -- u3 )             2dup u< minimax ;
\ : umin  ( u1 u2 -- u3 )             2dup u> minimax ;
\ : extend   ( n -- d )               dup 0< ;
\ : dabs  ( d -- ud )                 extend IF dnegate THEN ;
\ : abs   ( n -- u)                   extend IF  negate THEN ;

\ *** Block No. 27, Hexblock 1b

\ uwthin double number comparison words                  18Nov87

Code uwithin ( u1 [low up[ -- flag )  H pop   D pop   xthl
   (u< call   cs ?[    H pop   no jmp   ]?
   D pop   (u< call   yes jc   no jmp   end-code

Code d0= ( d -- flag )  H pop
   H A mov   L ora   H pop   no jnz   zero= jmp  end-code

: d=  ( d1 d2 -- flag )    rot =  -rot =  and ;
: d<  ( d1 d2 -- flag )
    rot 2dup =  IF 2drop u< exit THEN  > nip nip ;


\ \\
\ : d0= ( d -- flag )        or 0= ;

\ *** Block No. 28, Hexblock 1c

\ minimum maximum                                        18Nov87

Code umax ( u1 u2 -- u3 )
   H pop   D pop   (u< call
Label minimax  cs ?[ xchg ]?  hpush jmp   end-code

Code umin ( u1 u2 -- u3 )
   H pop   D pop   (u< call   cmc   minimax jmp   end-code

Code max ( n1 n2 -- n3 )
   H pop   D pop   (< call   minimax jmp   end-code

Code min ( n1 n2 -- n3 )
   H pop   D pop   (< call   cmc   minimax   jmp end-code



\ *** Block No. 29, Hexblock 1d

\ sign extension absolute values                         18Nov87

Code extend ( n -- d )  H pop   H push   negative jmp  end-code

Code abs    ( a -- u )  H pop   H A mov  A ora
   hpush jp   H dcx  >not jmp  end-code

Code dabs   ( d -- ud )  H pop   H A mov   A ora
   hpush jp   >dnegate jmp   end-code








\ *** Block No. 30, Hexblock 1e

\ branch ?branch                                         20Nov87

Code branch ( -- )  Label >branch
   IP H mvx   M E mov   H inx   M D mov   H dcx
   D dad   H IP mvx   Next   end-code

Code ?branch ( fl -- )
   H pop   H A mov   L ora  >branch jz
   IP inx   IP inx  Next   end-code


\ \\
\ : branch r> dup @ + >r ;




\ *** Block No. 31, Hexblock 1f

\ loop primitives                              11Jun86   20Nov87

Code bounds ( start count -- limit start )
   H pop   D pop   D dad    H push   D push   Next   end-code

Code endloop
   RP lhld   6 D lxi   D dad   RP shld   next  end-code restrict

\ \\ dodo puts "index | limit | adr.of.DO" on return-stack
\ : bounds ( start count -- limit start )     over + swap ;
\
\ | : dodo              rdrop r> 2+ dup >r rot >r swap >r >r ;
\
\ : (do  ( limit start -- )  over - dodo ;  restrict
\ : (?do ( limit start -- )  over - ?dup IF dodo THEN
\                            r> dup  @ +  >r drop ; restrict

\ *** Block No. 32, Hexblock 20

\ loop primitives                                        20Nov87

Code (do ( limit start -- )  H pop  D pop
  Label >do
    L A mov   E sub   A L mov
    H A mov   D sbb   A H mov
    H push   IP inx   IP inx
    RP lhld   H dcx  IP M mov   H dcx   IP' M mov
              H dcx   D M mov   H dcx    E  M mov
    D pop     H dcx   D M mov   H dcx    E  M mov   RP shld
    Next   end-code   restrict

Code (?do ( limit start -- )  H pop  D pop
    H A mov   D cmp   >do jnz
    L A mov   E cmp   >do jnz   >branch jmp
end-code  restrict

\ *** Block No. 33, Hexblock 21

\ (loop (+loop                                 14May86   20Nov87

Code (loop
   RP lhld   M inr   0= ?[ H inx   M inr   >next jz   ]?
Label doloop   RP lhld    4 D lxi  D dad
               M IP' mov   H inx   M IP mov   Next
end-code restrict

Code (+loop
   RP lhld   D pop
   M A mov   E add   A M mov   H inx
   M A mov   D adc   A M mov
   rar   D xra   doloop jp   Next
end-code restrict



\ *** Block No. 34, Hexblock 22

\ loop indices                                 06May86   20Nov87

Code I ( -- n )
   RP lhld
Label >I     M E mov   H inx   M D mov   D push
   H inx     M E mov   H inx   M D mov   H pop   D dad
   hpush jmp
end-code

Code J ( -- n )
   RP lhld   6 D lxi  D dad     >I jmp   end-code






\ *** Block No. 35, Hexblock 23

\ interpretive conditionals                           UH 25Jan88

| Create: remove>>  r> rp! ;
| : >>r ( addr len -- addr ) r>  over rp@  under swap - dup rp!
     swap >r remove>> >r swap >r  dup >r swap cmove r> ;

| Variable saved-dp     0 saved-dp !

| Variable level    0 level !

| : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit
      1 level !  here saved-dp ! ] ;

| : -level ( -- ) state @ 0= Abort" unstructured"
     level @ 0=exit -1 level +!  level @ ?exit  compile unnest
     [compile] [  saved-dp @  here over dp !  over -  >>r >r ;

\ *** Block No. 36, Hexblock 24

\ resolve loops and branches                          UH 25Jan88

: >mark     ( -- addr )           here 0 , ;

: +>mark    ( acf -- addr )       +level , >mark ;

: >resolve  ( addr -- )           here over - swap !  -level ;

: <mark     ( -- addr )           +level  here ;

: <resolve  ( addr -- )           here - , -level ;

: ?pairs    ( n1 n2 -- )          - Abort" unstructured" ;




\ *** Block No. 37, Hexblock 25

\ case?                                                  14May86

Code case? ( 16b1 16b2 -- 16b1 false / true )
   H pop   D pop
   H A mov   D cmp   0= ?[   L A mov   E cmp   yes jz ]?
   D push   no jmp   end-code

\ \\
\ : case? ( 16b1 16b2 -- 16b1 false / true )
\     over = dup  IF nip THEN ;







\ *** Block No. 38, Hexblock 26

\ Branching                                           UH 25Jan88

: IF             ['] ?branch +>mark 1 ; immediate
: THEN           abs 1 ?pairs >resolve ;   immediate
: ELSE           1 ?pairs  ['] branch +>mark swap
                 >resolve -1 ;             immediate
: BEGIN          <mark 2 ;                 immediate
: WHILE          2 ?pairs 2   ['] ?branch +>mark
                 -2 2swap ;                immediate

| : (reptil      <resolve
                 BEGIN dup -2 = WHILE drop >resolve REPEAT ;

: REPEAT         2 ?pairs compile  branch (reptil ; immediate
: UNTIL          2 ?pairs compile ?branch (reptil ; immediate


\ *** Block No. 39, Hexblock 27

\ Loops                                               UH 25Jan88

: DO        ['] (do  +>mark 3 ;       immediate
: ?DO       ['] (?do +>mark 3 ;       immediate
: LOOP      3 ?pairs compile  (loop compile endloop >resolve ;
                                         immediate
: +LOOP     3 ?pairs compile (+loop compile endloop >resolve ;
                                         immediate

Code LEAVE
   RP lhld   4 D lxi   D dad   M E mov   H inx   M D mov
   H inx   RP shld   xchg    H dcx   M D mov   H dcx   M E mov
   D dad   H IP mvx   Next   end-code   restrict

\ \\ Returnstack: calladr | index limit | adr of DO
\ : LEAVE     endloop r> 2- dup @ + >r ;             restrict

\ *** Block No. 40, Hexblock 28

\ um*                                                    16May86
Label (um*   0 H lxi   ( 0=Teil-Produkt )
             4 C mvi   ( Schleifen-Zaehler )
         [[  H dad ( Schiebe HL 24 bits nach links )
             ral cs ?[   D dad   0 aci   ]?
             H dad   ral   cs ?[   D dad   0 aci   ]?
      C dcr  0= ?]   ret

Code um*      ( u1 u2 -- ud )
   D pop      H pop     B push   H B mov   L A mov   (um* call
   H push   A H mov   B A mov    H B mov             (um* call
   D pop    D C mov     B dad      0 aci   L D mov    H L mov
   A H mov      B pop     dpush jmp end-code




\ *** Block No. 41, Hexblock 29

\ m* * 2* 2/                                             16May86

: m*  ( n1 n2 -- d )    dup 0< dup >r IF negate THEN
                        swap dup 0< IF negate r> not >r THEN
                        um* r> IF dnegate THEN ;

: *  ( n1 n2 - prod )   um* drop ;

Code 2*  ( n -- 2*n )   H pop   H dad   hpush jmp   end-code

Code 2/  ( n -- n/2 )
   H pop   H A mov   rlc   rrc   rar   A H mov
           L A mov   rar   A L mov   hpush jmp   end-code
\ \\
\ : 2*  ( n -- 2*n )   2 * ;
\ : 2/  ( n -- n/2 )   2 / ;

\ *** Block No. 42, Hexblock 2a

\ um/mod                                                 14May86
Label usl0
   A E mov   H A mov   C sub   A H mov   E A mov   B sbb
   cs ?[ H A mov   C add   A H mov   E A mov   D dcr rz
Label usla
         H dad   ral   usl0 jnc
         A E mov   H A mov   C sub   A H mov   E A mov   B sbb
      ]? L inr   D dcr   usla jnz   ret
Label usbad     -1 H lxi   B pop   H push   hpush jmp
Code um/mod   ( d1 n1 -- rem quot )
   IP H mvx     B pop   D pop   xthl   xchg
   L A mov   C sub   H A mov   B sbb   usbad jnc
   H A mov   L H mov   D L mov   8 D mvi   D push
   usla call   D pop   H push   E L mov   usla call
   A D mov   H E mov   B pop   C H mov   B pop
   D push   hpush jmp   end-code

\ *** Block No. 43, Hexblock 2b

\ m/mod                                                  16May86

: m/mod ( d n -- mod quot)
   dup >r  abs over 0< IF  under + swap  THEN
   um/mod  r@ 0< IF  negate over IF  swap r@ + swap 1-
   THEN THEN rdrop ;











\ *** Block No. 44, Hexblock 2c

\ /mod / mod */mod */ u/mod  ud/mod                      16May86

: /mod   ( n1 n2 -- rem quot )      >r extend r> m/mod ;

: /      ( n1 n2 --     quot )      /mod nip ;

: mod    ( n1 n2 -- rem )           /mod drop ;

: */mod  ( n1 n2 n3 -- rem quot )   >r m* r> m/mod ;

: */     ( n1 n2 n3 -- quot )       */mod nip ;

: u/mod  ( u1 u2 -- urem uquot )    0 swap um/mod ;

: ud/mod ( ud1 u2 -- urem udquot )  >r 0 r@ um/mod r> swap >r
                                    um/mod r> ;

\ *** Block No. 45, Hexblock 2d

\ cmove cmove>                                 16May86   18Nov87

Code cmove ( from to count -- )   IP H mvx   IPsave shld
     B pop   D pop   H pop
  Label (cmove
     [[ B A mov   C ora   0= not ?[[
        M A mov   H INX   D stax   D inx  B dcx
     ]]? IPsave lhld  H IP mvx   Next end-code

Code cmove>   ( from to count -- )   IP H mvx   IPsave shld
     B pop   D pop   H pop
  Label (cmove>
     B dad   H dcx   xchg   B dad   H dcx   xchg
     [[ B A mov   C ora   0= not ?[[
        M A mov   H dcx   D stax   D dcx   B dcx
     ]]? IPsave lhld  H IP mvx   Next end-code

\ *** Block No. 46, Hexblock 2e

\ move place count                             17Oct86   18Nov87

Code move  ( from to quan -- )
      IP H mvx  Ipsave shld   B pop   D pop   H pop
   Label domove  (u< call   (cmove jnc   (cmove> jmp   end-code

| Code (place ( addr len to -- len to )  IP H mvx  Ipsave shld
    D pop  B pop  H pop
    B push  D push   D inx   domove jmp   end-code

: place ( addr len to -- )  (place c! ;

Code count ( adr -- adr+1 len )   H pop   M E mov   0 D mvi
      H inx    H push   D push   Next  end-code



\ *** Block No. 47, Hexblock 2f

\ fill erase                                             18Nov87

Code fill ( addr quan 8b -- )
   IP H mvx   IPsave shld   D pop   B pop   H pop
   [[ B A mov   C ora   0<> ?[[
      E M mov   H inx   B dcx
   ]]?  IPsave lhld   H IP mvx   Next   end-code

: erase   ( addr quan --)            0 fill ;

\ \\ : fill ( addr quan 8b -- )
\    swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ;
\ : count ( adr -- adr+1 len )  dup 1+ swap c@ ;
\ : move   ( from to quan -- )
\    >r  2dup u< IF  r> cmove> exit  THEN  r> cmove ;
\ : place  ( addr len to --)  over >r  rot over 1+  r> move c! ;

\ *** Block No. 48, Hexblock 30

\ here allot , c, pad compile                  11Jun86   18Nov87

Code here ( -- addr )  user' dp  D lxi
   UP lhld   D dad   fetch jmp   end-code

Code allot ( n -- )    user' dp  D lxi
   UP lhld   D dad   +store jmp  end-code

: ,      ( 16b -- )  here  ! 2 allot ;
: c,     ( 8b -- )   here c! 1 allot ;

: pad    ( -- addr ) here $42 + ;
: compile            r> dup 2+ >r @ , ; restrict

\ : here   ( -- addr ) dp @ ;
\ : allot  ( n -- )    dp +! ;

\ *** Block No. 49, Hexblock 31

\ input strings                                          11Jun86

$84 Constant /tib
Variable #tib     0 #tib !
Variable >tib     here >tib ! /tib allot
Variable >in      0 >in !
Variable blk      0 blk !
Variable span     0 span !

: tib ( -- addr )  >tib @ ;

: query ( -- )  tib $50 expect span @ #tib !  >in off blk off ;






\ *** Block No. 50, Hexblock 32

\ \\ scan skip /string                           16May86   18Nov87
\
\ : scan ( addr0 len0 char -- addr1 len1 ) >r
\    BEGIN dup WHILE  over c@ r@ -  WHILE  1- swap 1+ swap REPEAT
\    rdrop ;
\
\ : skip ( addr len del -- addr1 len1 ) >r
\    BEGIN dup WHILE  over c@ r@ =  WHILE  1- swap 1+ swap REPEAT
\    rdrop ;
\
\ : /string ( addr0 len0 +n - addr1 len1 )
\    over umin rot over + -rot - ;





\ *** Block No. 51, Hexblock 33

\ skip scan                                              18Nov87
Label done    H push   B push   IPsave lhld   H IP mvx   Next
Code skip   ( addr len del -- addr1 len1 )
   IP H mvx   IPsave shld   D pop   B pop   H pop
   [[ B A mov   C ora   done jz
      M A mov   E cmp   done jnz   H inx   B dcx  ]] end-code

Code scan   ( addr len chr -- addr1 len1 )
   IP H mvx   IPsave shld   D pop   B pop   H pop
   [[ B A mov   C ora   done jz
      M A mov   E cmp   done jz   H inx   B dcx  ]] end-code

Code /string ( addr0 len0 +n - addr1 len1 )   H pop   D pop
   D push  (u< call  cs ?[ xchg ]?   H pop   xthl   D dad   xthl
   L A mov   E sub   A L mov   H A mov   D sbb   A H mov
   Hpush jmp   end-code

\ *** Block No. 52, Hexblock 34

\ capitalize    ohne Umlaute !!                16May86UH 25Jan88
Variable caps  0 caps !
Label ?capital   caps lda   A ana   rz
Label (capital ( e --> A,E )   E A mov  Ascii a cpi   rc
    Ascii z 1+ cpi   rnc   Ascii a Ascii A - sui  A E mov  ret

Code capital ( char -- char')  D pop
   (capital call    D push   Next  end-code
Code upper ( addr len -- )   D pop   E D mov   H pop   D inr
   [[ D dcr >next jz  M E mov  (capital call  E M mov  H inx ]]
end-code

\ \\ : capital ( char -- char')
\    dup  Ascii a   [ Ascii z 1+ ] Literal  uwithin not ?exit
\    [ Ascii a Ascii A - ] Literal - ;
\ : upper ( addr len -- )  bounds   ?DO I c@ capital I c! LOOP ;

\ *** Block No. 53, Hexblock 35

\ (word                                                  16May86

Code (word ( char adr0 len0 -- addr )
   IP H mvx   IPsave shld   B pop   B dcx  D pop
   >in lhld   D dad   xchg   xthl   xchg   H push   >in lhld
   C A mov   L sub   A L mov   B A mov   H sbb   A H mov
   cs ?[ B inx   C A mov   >in sta   B A mov   >in 1+ sta
                 D pop   H pop   D push
   ][ H inx   H B mvx   H pop
      [[  B A mov   C ora   0<>
      ?[[  M A mov   E cmp   0=   ?[[  H inx  B dcx ]]? ]?
      H push
      [[  B A mov  C ora   0<>
      ?[[  M A mov   E cmp   0<>   ?[[ H inx  B dcx ]]? ]?
      xchg    H pop   xthl
      E A mov   L sub   A L mov   D A mov   H sbb   A H mov

\ *** Block No. 54, Hexblock 36

\ (word Part2                                            16May86

      B A mov  C ora   0<> ?[ H inx ]?   >in shld   ]?
   H pop   E A mov   L sub   A C mov   D A mov   H sbb   A B mov
   H push   user' dp D lxi   UP lhld   D dad
   M A mov   H inx   M H mov  A L mov   D pop   H push
   C M mov   H inx
   [[ B A mov  C ora 0<>
   ?[[ D ldax  A M mov   H inx  D inx  B dcx ]]?   bl M mvi
   IPsave lhld   H IP mvx   Next   end-code
\ \\
\ : (word  ( char adr0 len0 -- addr )
\    rot  >r  over swap   >in @ /string
\    r@ skip   over swap   r> scan >r   rot over swap - r> 0<> -
\    >in !   over - here  dup >r  place  bl r@ count  + c!   r> ;


\ *** Block No. 55, Hexblock 37

\ source word parse name                       20Oct86UH 25Jan88

Variable loadfile

: source ( -- addr len )   blk @ ?dup
   IF loadfile @ (block  b/blk   exit  THEN  tib #tib @ ;

: word ( char -- addr )   source (word ;

: parse ( char -- addr len )
   >r  source  >in @ /string  over  swap r>  scan >r
   over - dup r>  0<> -  >in +! ;

: name ( -- addr )   bl word  dup count upper  exit ;



\ *** Block No. 56, Hexblock 38

\ state Ascii ," "lit ("  "                              18Nov87

Variable state   0 state !

: Ascii  ( char -- n )
   bl word  1+ c@  state @ IF [compile] Literal THEN ; immediate

Code "lit   RP lhld   M E mov   H inx   M D mov   H dcx
   D push   D ldax   D inx   E add   A M mov   H inx
   D A mov   0 aci   A M mov   Next  end-code

: ,"    Ascii " parse  here over 1+ allot place ;
: ("    "lit ; restrict
: "     compile (" ," align ; immediate restrict

\  : "lit  r> r> under  count + even  >r >r ;   restrict

\ *** Block No. 57, Hexblock 39

\ ." ( .( \ \\ hex decimal                               07Oct87

: (."      "lit count type ; restrict
: ."       compile (." ," align ; immediate restrict

: (        ascii ) parse 2drop ; immediate
: .(       ascii ) parse type ; immediate

: \        >in @ negate  c/l mod  >in +! ; immediate
: \\       b/blk >in ! ; immediate
: \needs   name find nip 0=exit [compile] \ ;

: hex      $10 base ! ;
: decimal  $0A base ! ;



\ *** Block No. 58, Hexblock 3a

\ number conversion: digit?                    16May86   18Nov87

Code digit?    ( char -- n true : false )
   user' base D lxi   UP lhld   D dad
   D pop   E A mov   Ascii 0 sui   no jc
   $0A cpi   cs not ?[ Ascii A Ascii 0 - cpi   no jc
                      Ascii A Ascii 9 - 1- sui  ]?
   M cmp   no jnc
   0 H mvi   A L mov   H push   yes jmp   end-code

\ \\
\ : digit? ( char -- digit true/ false )  dup Ascii 9 >
\    IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN
\    Ascii 0 - dup base @ u< dup ?exit nip ;



\ *** Block No. 59, Hexblock 3b

\ number conversion:  accumulate  convert                11Jun86

| : end?   ( -- flag )                   >in @ 0= ;
| : char   ( addr0 -- addr1 char )       count -1 >in +! ;
| : previous   ( addr0 -- addr0 char )   1- count ;

: accumulate ( +d0 adr digit - +d1 adr )
   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;

: convert ( +d1 addr0 -- +d2 addr2 )
   1+ BEGIN count digit? WHILE accumulate REPEAT 1- ;






\ *** Block No. 60, Hexblock 3c

\ number conversion: ?nonum punctuation?                 07Oct87

| : ?nonum    ( flag -- exit if true ) 0=exit
      rdrop 2drop drop rdrop false ;

| : punctuation?   ( char -- flag )
     Ascii , over =  swap  Ascii . =  or ;










\ *** Block No. 61, Hexblock 3d

\ number conversion: fixbase?                            07Oct87

| : fixbase?  ( char - char false / newbase true )  capital
   Ascii & case? IF $0A true exit  THEN
   Ascii $ case? IF $10 true exit  THEN
   Ascii H case? IF $10 true exit  THEN
   Ascii % case? IF   2 true exit  THEN     false ;










\ *** Block No. 62, Hexblock 3e

\ number conversion: ?num ?dpl                           07Oct87

Variable dpl      -1 dpl !

| : ?num      ( flag -- exit if true )  0=exit
      rdrop drop r> IF dnegate THEN
      rot drop dpl @ 1+ ?dup ?exit  drop true ;

| : ?dpl     dpl @  -1 =  ?exit  1 dpl +! ;








\ *** Block No. 63, Hexblock 3f

\ number conversion: number?  number                     11Jun86

: number?   ( string - string false / n 0< / d 0> )
   base push  >in push  dup count >in !  dpl on
   0 >r ( +sign) 0.0 rot end? ?nonum char
   Ascii - case?  IF  rdrop true >r end? ?nonum char  THEN
   fixbase?       IF  base !        end? ?nonum char  THEN
   BEGIN digit? 0= ?nonum
     BEGIN accumulate ?dpl end? ?num char digit? 0=  UNTIL
     previous  punctuation?  0= ?nonum  dpl off  end? ?num  char
   REPEAT ;

: number ( string -- d )
   number? ?dup 0= Abort" ?"  0< IF extend THEN ;



\ *** Block No. 64, Hexblock 40

\ hide reveal immediate restrict                         11Jun86

Variable last     0 last !
| : last?   ( -- false / acf true)    last @ ?dup ;
: hide          last?  IF  2- @ current @ !  THEN ;
: reveal        last?  IF  2-   current @ !  THEN ;
: Recursive     reveal ; immediate restrict

| : flag!    ( 8b --)
      last?  IF  under c@ or over c!  THEN   drop  ;

: immediate     $40 flag! ;
: restrict      $80 flag! ;




\ *** Block No. 65, Hexblock 41

\ clearstack hallot heap heap?                           04Sep86

Code clearstack
   user' s0 D lxi   UP lhld   D dad   M E mov   H inx   M D mov
   xchg   sphl   Next   end-code

: hallot ( quan -- )
   s0 @  over -  swap    sp@ 2+  dup rot -   dup s0 !
   2 pick  over -    di  move  clearstack  ei   s0 ! ;

: heap    ( -- addr )        s0 @ 6 + ;
: heap?   ( addr -- flag )   heap up@ uwithin ;

| : heapmove   ( from -- from )
     dup  here over -  dup hallot
     heap swap cmove   heap over - last +!  reveal ;

\ *** Block No. 66, Hexblock 42

\ Does>  ;                                     11Jun86   20Nov87

Label (dodoes>
   IP rpush   IP pop   W inx   W push   Next   end-code

: (;code          r> last @ name> ! ;

: Does>
   compile (;code      $CD ( 8080-Call ) c,
   compile (dodoes> ; immediate restrict







\ *** Block No. 67, Hexblock 43

\ ?head  |  alignments                         20Oct86   18Nov87

Variable ?head     0 ?head !

: |                ?head @  ?exit  -1 ?head ! ;

\ machen nichts beim 8080:
: even   ( addr -- addr1 ) ; immediate
: align  ( -- )            ; immediate
: halign ( -- )            ; immediate

Variable warning    0 warning !

| : exists?         warning @  ?exit  last @ current @
   (find nip 0=exit  space last @ .name ." exists " ?cr ;


\ *** Block No. 68, Hexblock 44

\ warning   Create                             20Oct86   18Nov87

Defer makeview          ' 0 Is makeview

: (create ( string -- ) align here
    swap count $1F and here 4+ place makeview ,  current @ @ ,
    here last !  here c@ 1+ allot  align  exists?
    ?head @ IF  1 ?head +!   dup ,    \ Pointer to Code
                halign  heapmove  $20 flag!  dup dp !
            THEN drop  reveal 0 ,
    ;Code   W inx   W push   Next   end-code

: Create   name count 1 $20 uwithin not
           Abort" invalid name" 1- (create ;



\ *** Block No. 69, Hexblock 45

\ nfa?                                                   30Jun86

Code nfa? ( thread cfa -- nfa / false )
   D pop   H pop
   [[ M A mov   H inx   M H mov   A L mov
     H ora   Hpush jz   H push   H inx   H inx   H push   D push
     M A mov   H inx   $1F ani   A E mov   0 D mvi  D dad
     D pop xthl  M A mov   H pop   $20 ani
     0<> ?[ M A mov   H inx   M H mov   A L mov ]?
     H A mov   D cmp   0= ?[ L A mov  E cmp ]?
     H pop   0= ?]   H inx  H inx  Hpush jmp
end-code
\ \\
\ : nfa?    ( thread cfa -- nfa / false)
\    >r  BEGIN @ dup 0= IF  rdrop exit  THEN  dup 2+ name> r@ =
\        UNTIL 2+ rdrop ;

\ *** Block No. 70, Hexblock 46

\ >name name> >body .name                      30Jun86   07Oct87

: >name   ( cfa -- nfa / false )        voc-link
   BEGIN @ dup WHILE  2dup 4 - swap nfa?
      ?dup IF  -rot 2drop exit  THEN   REPEAT nip ;

Code (name>  ( nfa -- cfa )  H pop   M A mov   H inx   $1F ani
   A E mov   0 D mvi   D dad   hpush jmp   end-code
\ : (name>   ( nfa -- cfa )   count  $1F and + ;

: name> ( nfa -- cfa )  dup (name> swap  c@ $20 and  IF @ THEN ;

: >body ( cfa -- pfa )  2+ ;    : body> ( pfa -- cfa )  2- ;

: .name   ( nfa -- ) ?dup  IF  dup heap?  IF ." |" THEN
    count $1F and type  ELSE ." ???"  THEN space ;

\ *** Block No. 71, Hexblock 47

\ : ; Constant Variable                                  07Nov87

: Create:  Create  hide  current @ context !  0 ] ;

: : Create: ;Code  IP rpush   W inx   W IP mvx   Next end-code

: ;        0 ?pairs   compile unnest   [compile] [   reveal ;
           immediate restrict

: Constant ( n -- )   Create , ;Code
   W inx   xchg   M E mov   H inx   M D mov   D push   Next
   end-code

: Variable         Create 0 , ;



\ *** Block No. 72, Hexblock 48

\ uallot User Alias Defer                      11Jun86   18Nov87
: uallot   ( quan -- offset )   even  dup  udp @ +
    $FF u> Abort" Userarea full" udp @ swap udp +! ;

: User   Create 2 uallot c,
   ;Code W inx   W ldax   A E mov   0 D mvi
         UP lhld   D dad   hpush jmp   end-code

: Alias ( cfa -- )   Create  last  @ dup c@ $20 and
   IF  -2 allot  ELSE  $20 flag!  THEN (name> ! ;

| : crash           true Abort" crash" ;

: Defer   Create ['] crash ,
    ;Code W inx   xchg   M E mov   H inx   M D mov
          xchg   >next1 jmp   end-code

\ *** Block No. 73, Hexblock 49

\ vp current context also toss                           11Jun86

Create vp  $10 allot             Variable current

: context   ( -- adr )              vp dup @ + 2+ ;

| : thru.vocstack ( -- from to )    vp 2+ context ;
\ "Only Forth also Assembler" gives
\ vp:  countword = 6 | Only | Forth | Assembler |

: also          vp @ $0A > Error" Vocabulary stack full"
                context @  2 vp +! context ! ;
: toss          vp @ IF  -2 vp +!  THEN  ;




\ *** Block No. 74, Hexblock 4a

\ Vocabulary Forth Only Onlyforth              24Nov85   18Nov87

: Vocabulary
Create   0 , 0 ,  here  voc-link @ ,  voc-link !
 Does>   context ! ;
\  | Name | Code | Thread | Coldthread | Voc-link |

Vocabulary Forth
Vocabulary Root

: Only   vp off   Root also ;

: Onlyforth Only Forth also definitions ;




\ *** Block No. 75, Hexblock 4b

\ definitions order words                      10Oct87   20Nov87

| : init-vocabularys        voc-link @
     BEGIN  dup 2- @ over 4- ! @ ?dup 0= UNTIL ;

: definitions            context @ current ! ;

| : .voc   ( adr -- )    @ 2- >name .name ;

: order    vp 4+ context DO I .voc -2 +LOOP
           2 spaces current .voc ;

: words          context @
   BEGIN   @ dup stop? 0= and
   WHILE   ?cr dup 2+ .name space
   REPEAT  drop ;

\ *** Block No. 76, Hexblock 4c

\ found -text                                            11Jun86
| : found ( nfa -- cfa n )
   dup c@ >r   (name> r@ $20 and  IF  @       THEN
                   -1 r@ $80 and  IF  1-      THEN
                      r> $40 and  IF  negate  THEN  ;

\ \\
\ : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1<str2)
\     over bounds DO   drop 1+ dup 1- c@ I c@ - dup
\                    IF dup abs / LEAVE THEN LOOP nip ;
\ | Variable string        | Variable strlen
\ : (find    ( string thread -- str false/NFA true )
\    >r count $1F and  strlen ! string !
\    BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ =
\     IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN
\       THEN drop   REPEAT  string @ 1- false ;

\ *** Block No. 77, Hexblock 4d

\ (find                                                  11Jun86

Code (find   ( str thr - str false/ NFA true )
   H pop   D pop   IP push   D ldax   $1F ani   A C mov   D inx
Label findloop
   M A mov   H inx   M H mov  A L mov
   H A mov   L ora   0= ?[  IP pop  D dcx   D push   no jmp ]?
   H push   H inx   H inx   M A mov   $1F ani   C cmp
   0<>   ?[   H pop   findloop jmp   ]?
   D push   H inx   C B mov   B inr
   [[ B dcr   0<>  ?[[
      D ldax   M cmp   0<>   ?[ D pop  H pop   findloop jmp ]?
      H inx   D inx   ]]?
   D pop   H pop   H inx   H inx   IP pop   H push   yes jmp
end-code
\ \\  HL: thread, nfa   DE: string   C: strlen   B: counter

\ *** Block No. 78, Hexblock 4e

\ find  '  [compile]  [']  nullstring?                   18Nov87

: find    ( string -- cfa n / string false )
   context dup @ over  2- @ = IF  2-  THEN
   BEGIN  under @ (find  IF  nip found  exit  THEN
     over vp 2+  u> WHILE  swap 2-  REPEAT  nip false ;

: '    ( -- cfa )      name find ?exit Error" ?" ;

: [compile]            ' , ;                 immediate restrict

: [']                  ' [compile] Literal ; immediate restrict

: nullstring?   ( string -- string false / true )
   dup c@  0= dup 0=exit  nip ;


\ *** Block No. 79, Hexblock 4f

\ notfound                                     17Oct86UH 25Jan88

: no.extensions  ( string -- )
    state @ IF Abort" ?" THEN  Error" ?" ;

Defer notfound                  ' no.extensions Is notfound











\ *** Block No. 80, Hexblock 50

\ interpret interpreter compiler parser               UH 25Jan88
Defer parser

: interpret ( -- )
    BEGIN  ?stack  name  nullstring? ?exit  parser REPEAT ;

| : interpreter ( str -- ) find ?dup
     IF  1 and  IF execute  exit THEN Error" compile only" THEN
     number? ?exit   notfound ;

' interpreter Is parser

| : compiler ( str -- ) find  ?dup
     IF  0> IF  execute exit THEN , exit THEN
     number? ?dup IF 0> IF swap [compile] Literal THEN
                     [compile] Literal exit THEN  notfound ;

\ *** Block No. 81, Hexblock 51

\ [ ]                                                 UH 25Jan88

: [      ['] interpreter Is Parser  state off ; immediate

: ]      ['] compiler    Is Parser  state on ;












\ *** Block No. 82, Hexblock 52

\  Is                                          09May86UH 25Jan88

: (is      r> dup 2+ >r @ ! ;

| : def?  ( cfa -- )
     @  [ ' notfound @ ] Literal  - Abort" not deferred" ;

: Is   ( adr -- )     ' dup def? >body
   state @ IF  compile (is , exit  THEN  ! ; immediate








\ *** Block No. 83, Hexblock 53

\ ?stack                                                 30Jun86
| : stackfull ( -- )     depth $20 > Abort" tight stack"
    reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN
    true Abort" Dictionary full" ;

Code ?stack
   UP lhld   user' dp D lxi   D dad   M E mov   H inx   M D mov
   0 H lxi  SP dad   L A mov   E sub   H A mov   D sbb
   0= ?[ ;c: stackfull ; Assembler ]?    H push
   UP lhld   user' s0 D lxi   D dad   M E mov   H inx   M D mov
   H pop    D A mov   H cmp  c0= ?[ 0= ?[ E A mov  L cmp ]? ]?
   >next jnc  ;c: true abort" Stack empty" ;
\ \\
\ : ?stack     sp@ here - 100 u< IF stackfull THEN
\                 sp@ s0 @ u> Abort" Stack empty" ;