( START OF FILE "7BASIC2" -- 8 July 88 -- MFB)

( BASIC UCC 4th/86 SYSTEM.
  THIS FILE INCLUDES THE COMMON MATH FUNCTIONS
  FOR 16-BIT NUMBERS, THE ELEMENTARY STACK FUNCTIONS,
  THE CONSTANTS -1 THRU 10, AND THE CODE FOR THREAD AND VLOAD.)

( *******************************
  * Threaded code basic support *
  ******************************* )

( << WARNING >>  X;PUSH MUST PRECEED THREAD. DO NOT MOVE!)

code x;push	( entry to thread with push )
					   h push, ;nothread asm 

code thread	( primary code linker)
				mov-hl[bc], b inx, ;nothread asm 

code thpat	( patch point for TRACEON and TRACEOFF)
				      b inx, pchl, ;nothread asm 
						
code vload 	( load data word from definition to stack. 
             	  Used to load constants and to load the 
                      address of variables)
		h pop, mov-de[hl], h inx, d push,  ; asm

( VARIABLES USED BY THE INTERPRETER.)
2 BLOCK CSP ( CONTROL STACK POINTER) 

CODE PSHBC# ( PUSH BC ONTO THE CONTROL STACK)
  '' CSP LHLD, '' csp inxw, '' csp inxw, mov-[hl]bc, 
  ( PROTECT STACK FROM INTERRUPTS)
  RET, 
;NOTHREAD ASM

CODE POPBC# ( POP BC FROM THE CONTROL STACK.)
  '' CSP LHLD, H DCX, H DCX, mov-bc[hl],
  '' CSP SHLD, RET, 
;NOTHREAD ASM

CODE COLON ( EXECUTABLE CODE FOR ALL : DEFINITIONS.)
  ' PSHBC# CALL, ( STORE SEVENTH PC IN CS)
  B POP, 
; ASM

CODE RRET ( return for RETURN - will fall into SRET )
  NOP, ( the NOP is to force the defadr to be different 
         than that for SRET )
;NOTHREAD ASM

CODE SRET ( RETURN FROM SEVENTH DEFINITION)
  ' POPBC# CALL, ( GET PC FROM CS) 
; ASM

CODE EXEC ( EXECUTE WORD WHOSE
            DEFINITION ADDRESS IS ON THE STACK)
(  H POP, PCHL, 
)
   RET,
;NOTHREAD

CODE X:EXIT ( executor for :EXIT)
  B PUSH,  ' POPBC# CALL,  RET, 
;NOTHREAD ASM

CODE LDI ( LOAD IMMEDIATE)
  mov-hl[bc], b inx, B INX, 
;PUSH ASM

CODE LDIB ( LOAD IMMEDIATE SMALL )
    B LDAX, L A MOV, B INX, H 0 MVI, 
;PUSH ASM

CODE LDIS ( LOAD IMMEDIATE STRING)
  B PUSH, ( STRING ADDRESS TO STACK)
  B LDAX, C ADD, C A MOV, IFC ( DOUBLE PRECISION ADD A TO BC)
    B INR,
  THEN
  B INX, 
; ASM

 CODE ,LDI ( DBL PREC LOAD IMMEDIATE)
  mov-de[bc], b inx, b inx, mov-hl[bc], b inx, b inx, 
  H PUSH, D PUSH, 
; ASM

CODE BR ( UNCONDITIONAL BRANCH TO CODE AT PC)
  mov-bc[bc], 
; ASM

CODE BRZ ( BRANCH IF TOS=0, ELSE CONTINUE.)
  H POP, A L MOV, H ORA, IFNZ
    B INX, B INX,
  ELSE
    mov-bc[bc],
  THEN 
; ASM

CODE XOF ( Executor for OF in CASE structure)
  ( equiv to OVER = IF DROP ... )
  D POP, H POP, A E MOV, L SUB, E A MOV, A D MOV, H SUB,
  E ORA, IFNZ H PUSH, ' BR JMP, THEN B INX, B INX, ; ASM

( *****************************
  * Stack ops, load and store *
  ***************************** )

CODE OVER ( COPY NOS TO TOS)
  H POP, D POP, D PUSH, H PUSH, D PUSH, 
;

CODE DROP ( DROP TOP OF STACK.)
  H POP, 
;

CODE KILL ( DROP N ENTRIES FROM THE STACK)
  H POP, H DAD, DI, SP DAD, SPHL, EI, ( mfb)
;

CODE DUP ( DUPLICATE TOS)
  H POP, H PUSH, 
;PUSH

CODE ?DUP ( DUPLICATE TOS ONLY IF NON-ZERO)
  H POP, A H MOV, L ORA, IFNZ
    H PUSH,
  THEN
;PUSH

CODE SWAP ( SWAP TOS WITH NOS)
  H POP, DI, XTHL, EI, ( mfb)
;PUSH

CODE PICK ( PICK UP THE NTH ELEMENT OF THE STACK)
  H POP, H DCX, H DAD, DI, SP DAD, EI, ( mfb)
  mov-de[hl], D PUSH, 
;

CODE POKE ( PUT THE NOS INTO THE TOS'TH PLACE IN THE STACK.)
  H POP, H DAD, DI, SP DAD, EI, ( mfb) D POP, 
  mov-[hl]de, h inx, 
;

CODE ROT ( a b c -- b c a ) ( rotate stack)
  D POP, H POP, DI, XTHL, EI, ( mfb) D PUSH, ;PUSH

 CODE XTRCT ( extract element from stack)
  ( long stack rotate; ex: a b c d e 4 -- a c d e b )
  H POP, A L MOV, A DCR, IFNZ IFP
    H 0 MVI, L A MOV, H DAD, DI, SP DAD, EI, ( mfb)
    E M MOV, H INX, D M MOV, D PUSH, BEGIN
      H DCX, H DCX, D M MOV, H DCX, E M MOV, H INX, H INX,
      M E MOV, H INX, M D MOV, H DCX, H DCX, A DCR,
    ENDZ
    H POP, D POP, H PUSH,
  THEN THEN ; 

CODE INSRT  ( insert tos into stack)
  ( ex: a b c d e 4 -- a e b c d )
  H POP, A L MOV, A DCR, IFNZ  IFP
    H 0 LXI, DI, SP DAD, EI, ( mfb) D POP, D PUSH, D PUSH,
    BEGIN
      H INX, H INX, mov-de[hl], H DCX,
      h dcx, mov-[hl]de, H INX, H INX, A DCR,
    ENDZ
    D POP, mov-[hl]de, h inx,
  THEN THEN ;

( DUP@ must immediately precede @ because it is written
  such that it falls through to @ )

CODE DUP@ ( FETCH THE WORD AT THE ADDRESS ON TOS WITHOUT
            DESTROYING THE ADDRESS )
  H POP, H PUSH, H PUSH, 
;NOTHREAD ( Fall thru to @ )

CODE @ ( GET VALUE WHOSE ADDRESS IS ON THE STACK.)
  H POP, mov-de[hl], D PUSH, 
;

( DUPB@ must immediately precede B@ because it is written
  such that it falls through to B@ )

CODE DUPB@ ( fetch byte after duping addr )
  H POP, H PUSH, H PUSH, 
;NOTHREAD ( fall thru to B@)

CODE B@ ( GET THE BYTE VALUE WHOSE ADDRESS IS ON THE STACK.)
  H POP, E M MOV, D 0 MVI, ( FILL HIGH BYTE WITH 0)
  D PUSH, 
;

CODE SP@ ( GET THE CURRENT VALUE OF THE STACK POINTER TO TOS)
  H 0 LXI, DI, SP DAD, EI, ( mfb)
;PUSH

CODE ! ( STORE NOS AT ADDR TOS)
  H POP, D POP, mov-[hl]de, h inx,
;

CODE B! ( STORE NOS AS ONE BYTE AT ADDR TOS)
  H POP, D POP, M E MOV, 
;

( ***************
  * Logical ops *
  *************** )

CODE AND ( LOGICAL AND OF TOP TWO STACK ELEMENTS.)
  H POP, D POP, ( GET OPERANDS)
  A E MOV, L ANA, L A MOV, A D MOV, H ANA, H A MOV,
;PUSH ( ANSWER TO STACK)

CODE OR ( LOGICAL OR OF TOP TWO STACK ELEMENTS)
  H POP, D POP, ( GET OPERANDS)
  A E MOV, L ORA, L A MOV, A D MOV, H ORA, H A MOV,
;PUSH ( ANSWER TO STACK)

CODE XOR ( LOGICAL XOR OF TOP TWO STACK ELEMENTS)
  H POP, D POP, ( GET OPERANDS)
  A E MOV, L XRA, L A MOV, A D MOV, H XRA, H A MOV,
;PUSH ( ANSWER TO STACK)

CODE SHR8 ( GET HIGH BYTE OF TOS TO LOW BYTE)
  H POP, L H MOV, H 0 MVI, 
;PUSH

CODE SHL8 ( GET LOW BYTE OF TOS TO HIGH BYTE)
  H POP, H L MOV, L 0 MVI, 
;PUSH

( ******************
  * Arithmetic ops *
  ****************** )

CODE + ( ADD TWO ELEMENTS ON TOP OF THE STACK.)
  H POP, D POP, D DAD, 
;PUSH

CODE 1+ ( ADD ONE TO TOS )
  H POP, H INX, 
;PUSH

CODE 1- ( subtract one from the TOS )
  H POP, H DCX,
;PUSH

CODE 2+ ( ADD TWO TO TOS )
  H POP, H INX, H INX, 
;PUSH

CODE - ( SUBTRACT TOS FROM NOS, LEAVE RESULT ON STACK)
  D POP, H POP, ( A L MOV, E SUB, L A MOV, A H MOV, D SBB, H A MOV, ) 
                  sub-hlde,
;PUSH

CODE ABS
  H POP,  A H MOV,  A ORA,  IFM
    CMA,  H A MOV,  A L MOV,  CMA,  L A MOV,  H INX,
  THEN  
;PUSH

CODE +! ( add NOS to value addressed by TOS )
  H POP,  mov-de[hl], h inx, 
                   DI, XTHL, EI, ( mfb)
  D DAD,  XCHG,  H POP,
  h dcx, mov-[hl]de,
;

CODE -1* ( Negate TOS)
  H POP,  A H MOV,  CMA,  H A MOV,  A L MOV,  CMA,
  L A MOV,  H INX,  
;PUSH

CODE * ( 16-BIT SIGNED MULTIPLY.)
  D POP, H POP, B PUSH, ( SAVE SEVENTH PC)
  B H MOV, C L MOV, ( BC=HL)
  H 0 LXI, ( PRODUCT IS INITIALLY 0) A 16 MVI, ( DO 16 TIMES)
  BEGIN
    H DAD, ( SHIFT PRODUCT LEFT)
    XCHG, H DAD, XCHG, ( GET BIT OF MULTIPLIER TO CARRY)
    IFC
      B DAD, ( ADD MULTIPLICAND)
    THEN
    A DCR, ( BUMP LOOP COUNTER)
  ENDZ
  B POP, ( RESTORE SEVENTH PC) 
;PUSH ( RESULT TO STK)

CODE %DIVU# ( ASSEM SUBR. FOR UNSIGNED DIVIDE)
  ( ON ENTRY, HLDE=DIVIDEND, BC=DIVISOR. ON EXIT,
    HL=REMAINDER, DE=QUOTIENT)
   A 16 MVI, ( INIT LOOP COUNT)
   BEGIN
     PSW PUSH, ( SAVE LOOP COUNT)
     H DAD, XCHG, H DAD, XCHG, ( LEFT SHIFT)
     IFC ( DID DE HAVE A 1 IN THE MSB?)
       H INX, ( IF SO, PUT IN LSB OF HL FOR DOUBLE SHIFT.)
     THEN
     ( A L MOV, C SUB, L A MOV, A H MOV, B SBB, H A MOV, )  sub-hlbc,
     ( SUBTRACT BC FROM HL AND TEST)
     IFC ( IF A BORROW, RESTORE ELSE SET QUOTIENT BIT IN DE.)
       B DAD,
     ELSE
       D INX,
     THEN
     PSW POP, A DCR, ( UPDATE AND TEST LOOP COUNT.)
   ENDZ
   RET, ( ASSEMBLY LANGUAGE RETURN.) 
;NOTHREAD ASM

CODE NEGDE# ( ASSEM SUBR. TO NEGATE DE)
  A E MOV, CMA, E A MOV, A D MOV, CMA, D A MOV, D INX, RET,
;NOTHREAD ASM

CODE SGNBC# ( ASSEM SUBR. TO TEST THE SIGN OF BC. IF NEG, IT
  NEGATES BC AND INVERTS CARRY.)
  B INR, B DCR, IFM
    A B MOV, CMA, B A MOV, A C MOV, CMA, C A MOV, 
          ( mfb) PSW PUSH, B INX, PSW POP, CMC, 
  THEN
  RET, 
;NOTHREAD ASM

CODE SGNDE# ( ASSEM SUBR. TO TEST THE SIGN OF DE. IF NEG, IT 
  NEGATES DE AND INVERTS CARRY.)
  D INR, D DCR, IFM
    ' NEGDE# CALL, CMC,
  THEN
  RET, 
;NOTHREAD ASM

CODE %CDIV# ( COMMON CODE FOR / AND /MOD.)
  B H MOV, C L MOV, ( CLEAR UPPER DIVIDEND) H 0 LXI,
  A ORA, ( CARRY=0)
  ' SGNBC# CALL, ' SGNDE# CALL, ( FIX UP SIGNS.)
  PSW PUSH, ( SAVE SIGN OF RESULT IN CARRY)
  ' %DIVU# CALL, ( DO THE DIVIDE.)
  PSW POP, IFC
    ' NEGDE# CALL, ( FIX SIGN OF RESULT)
  THEN
  RET, 
;NOTHREAD ASM

CODE / ( 16-BIT INTEGER DIVIDE.)
  H POP, D POP, B PUSH, ( SET UP FOR COMMON CODE.)
  ' %CDIV# CALL, ( DO COMMON CODE)
  B POP, D PUSH, ( DE=RESULT) 
;

CODE /MOD ( DIVIDE, LEAVE QUOTIENT AND REMAINDER)
  H POP, D POP, B PUSH, ' %CDIV# CALL,
  A B MOV, IFC ( COMPUT SIGN OF REMAINDER.)
    CMA,
  THEN
  A ORA, IFM 
    XCHG, ' NEGDE# CALL, XCHG,
  THEN
  B POP, H PUSH, D PUSH, 
;

CODE %MPYU# ( UNSIGNED MULTIPLY AND ADD SUBROUTINE.)
  ( ON ENTRY, BC=MULTIPLICAND, DE=MULTIPLIER, HL=ADDER.
    ON EXIT, HLDE=BC*DE+HL)
  A 16 MVI, ( DO 16 TIMES.)
  BEGIN PSW PUSH, ( SAVE LOOP COUNTER.)
    A E MOV, RAR, IFC ( TEST LSB OF MULTIPLIER)
      B DAD, ( IF 1, ADD)
    THEN
    ( NOW, DO A 32- BIT RIGHT SHIFT OF HLDE.)
    A ORA, A H MOV, RAR, H A MOV,
    A L MOV, RAR, L A MOV,
    A D MOV, RAR, D A MOV,
    A E MOV, RAR, E A MOV,
    PSW POP, A DCR, ( DECREMENT AND TEST LOOP COUNTER.)
  ENDZ RET, 
;NOTHREAD ASM

CODE */ ( MULTIPLY, THEN DIVIDE,
          USING 32 BITS FOR THE PRODUCT.)
  H B MOV, L C MOV, ( HL= SEVENTH PC)
  D POP, ( DIVISOR) B POP, ( MULTIPLIER)
  DI, XTHL, EI, ( mfb) ( HL=MULTIPLICAND, TOS=PC)
  XCHG, H PUSH, ( SAVE DIVISOR)
  H 0 LXI, ( ADDER=0) A ORA, ( CY=0)
  ' SGNBC# CALL, ' SGNDE# CALL,
  PSW PUSH, ( CY=SIGN OF PROD.)
  ' %MPYU# CALL, 
  PSW POP, B POP, ( GET DIVISOR TO BC) 
  ' SGNBC# CALL, PSW PUSH, ( CY=SIGN OF RESULT)
  ' %DIVU# CALL, PSW POP, 
  ' NEGDE# CC, ( IF CARRY, NEGATE RESULT.)
  B POP, D PUSH, 
;

( ******************
  * Relational ops *
  ****************** )

CODE 0= ( TEST:  IS TOS=0)
  H POP, A L MOV, H ORA, H 0 LXI, IFZ
    H INX,
  THEN
;PUSH

CODE RELAT# ( if de > hl then hl=1 else hl=0)
            ( this is for signed 16 bit integers)
  B PUSH, A H MOV, RAL, A SBB, C A MOV,
          A D MOV, RAL, A SBB, B A MOV,
  A L MOV, E SUB, A H MOV, D SBB,
  A C MOV, B SBB, B POP, H 0 LXI, IFM
    L INR,
  THEN
  RET, 
;NOTHREAD ASM

CODE < ( TEST: IS NOS<TOS)
  D POP, H POP, ' RELAT# CALL, 
;PUSH

CODE > ( TEST: IS NOS>TOS)
  H POP, D POP, ' RELAT# CALL, 
;PUSH

CODE = ( TEST: IS TOS=NOS)
  H POP, D POP, ( A L MOV, E SUB, L A MOV, A H MOV, D SBB, L ORA,)
            sub-hlde, a h mov, l ora,
  H 0 LXI, IFZ
    H INX,
  THEN
;PUSH

CODE >= ( TEST: IS NOS>=TOS)
  D POP, H POP, ' RELAT# CALL,
  A L MOV, 1 XRI, L A MOV, 
;PUSH

CODE 0> ( TEST: IS TOS>0)
  H 0 LXI, D POP, ' RELAT# CALL, 
;PUSH

CODE U> ( LEAVE TRUE IF NOS > TOS UNSIGNED )
  H POP, D POP, A L MOV, E SUB, A H MOV, D SBB,
  RAL, 1 ANI, L A MOV, H 0 MVI, 
;PUSH

( ********************
  * Strings and move *
  ******************** )


CODE MOVE# ( ASM LANG MOVE. HL=SOURCE, DE=DEST, BC=COUNT)
  REPEAT   A B MOV, C ORA,  WHILENZ
    A M MOV, D STAX, H INX, D INX, B DCX,
  ENDWHILE
  RET, 
;NOTHREAD ASM

( MOVE - move bytes: TOS = count, NOS = dest, 3OS = source)

CODE MOVE ( source dest count -- )
  L C MOV, H B MOV,  B POP, D POP, DI, XTHL, EI, ( mfb)
  ' MOVE# CALL,
  B POP, 
;

CODE FILL ( value count address -- ) ( fill memory)
  L C MOV, H B MOV, D POP, B POP, DI, XTHL, EI, ( mfb) XCHG,
  REPEAT  A B MOV, C ORA, WHILENZ
  M E MOV, H INX, B DCX, ENDWHILE B POP, ;

CODE $! ( MOVE STRING AT NOS TO ADDR AT TOS)
  D POP, H POP, B PUSH, C M MOV, B 0 MVI, B INX,
  ' MOVE# CALL, B POP, 
;

( *******************
  * Local variables *
  ******************* )

( CODE TO HANDLE COMPILED-IN LOCAL VARIABLES.)

8 BLOCK FP ( 4 FRAME POINTERS FOR LOCAL CONTEXT.)

CODE LVLOAD ( EXECUTABLE CODE FOR GETTING ADDR. OF A LOCAL)
  H POP, mov-de[hl], h inx, 
					( DE=DISPLACEMENT FROM FP)
  H INX, mov-hl[hl], h inx, 
					( HL=ADDR. OF FP)
  mov-hl[hl], h inx, 
					( HL=FRAME POINTER)
  D DAD, ( HL=ADDRESS OF VARIABLE) 
;PUSH

CODE XENTR ( COMPILED-IN ROUTINE TO START A STACK FRAME.)
  ( AFTER ENTER-FRAME COMES THE ADDRESS OF THE FRAME POINTER, ) 
  ( FOLLOWED BY THE NEGATIVE FRAME SIZE.)
  H POP, H DAD, ( get number of stack entries (two bytes long)
                  to be included in the current stack frame
                  from the top of the stack. )
  DI, SP DAD, EI, ( mfb)  ( HL=NEW FP VALUE.)
  XCHG, mov-hl[bc], b inx,
                  ( B LDAX, L A MOV, B INX, B LDAX, H A MOV, ) B INX,
  ( HL=ADDRESS OF FP. FIRST, PUSH CURRENT VALUE )
  ( ON THE CONTROL STACK.)
  B PUSH, mov-bc[hl], h inx,
					( BC=CURRENT VALUE)
  mov-[hl]de, ( FP=NEW VALUE.)
  ' PSHBC# CALL, B POP,
  mov-hl[bc], b inx,
  ( B LDAX, L A MOV, B INX, B LDAX, H A MOV, ) B INX, D DAD,
  ( HL=NEW VALUE FOR SP) DI, SPHL, EI, ( mfb)
;

CODE XEXIT ( COMPILED-IN ROUTINE TO TERMINATE A STACK FRAME)
  ( AFTER EXIT-FRAME COMES THE ADDRESS OF THE FRAME POINTER.)
       mov-de[bc], b inx, B INX, B PUSH,
  ( DE=FP ADDRESS. NOW, POP PRIOR VALUE.)
  ' POPBC# CALL, XCHG, ( NOW, GET CURRENT FP VALUE.)
  mov-de[hl], ( h inx, ) ( STORE POPPED VALUE)
  mov-hl[bc], B POP,
  H POP, H DAD, ( HL=NO. OF STACK ENTRIES (two bytes) 
                     TO BE LEFT ON THE STACK.)
  sub-dehl, mov-hlde,
  DI, SPHL, EI, ( mfb) ( HL=RESTORED SP VALUE WITH SPECIFIED OVERLAP) 
;

( ***********************
  * DO ... LOOP support *
  *********************** )

CODE CSPICK
  H POP,  H DAD,  XCHG,  '' CSP LHLD,  
  sub-hlde,
  mov-de[hl], h inx, D PUSH,  
;

CODE %CSPSH#
  XCHG,  '' CSP LHLD,  H INX,  H INX,  '' CSP SHLD,
  H DCX,  
  h dcx, mov-[hl]de, RET,  
;NOTHREAD ASM


CODE XDO ( limit initial --)
  H POP, D POP,
  XCHG, B PUSH,
  A H MOV, RAL, A SBB, C A MOV, A D MOV, RAL, A SBB, B A MOV,
  A L MOV, E SUB, A H MOV, D SBB, A C MOV, B SBB, 
  B POP, IFM ( current > limit (signed 16-bit))
    B LDAX, L A MOV, B INX, B LDAX, B A MOV, C L MOV, ( exit loop)
  ELSE
    D PUSH, H PUSH,
    B LDAX, L A MOV, B INX, B LDAX, H A MOV, B INX, ( get top of loop address)
    ' %CSPSH# CALL, ( save top of loop address)
    H POP, ' %CSPSH# CALL, ( save limit)
    H POP, ' %CSPSH# CALL, ( save initial=current)
  THEN
;
(  CODE XDO ( limit initial --)
  d pop, h pop, B PUSH,
  A H MOV, RAL, A SBB, C A MOV, 
  A D MOV, RAL, A SBB, B A MOV,
(  mov-axhl, sub-axde, mov-bcax, -- doesn't work -- )
  B POP, IFM ( current > limit (signed 16-bit))
      mov-bc[bc], b inx, ( exit loop)
  ELSE
    D PUSH, H PUSH,
    mov-hl[bc], b inx,
                           B INX, ( get top of loop address)
    ' %CSPSH# CALL, ( save top of loop address)
    H POP, ' %CSPSH# CALL, ( save limit)
    H POP, ' %CSPSH# CALL, ( save initial=current)
  THEN
; )

( XLOOP must immediately precede X+LOOP because it is
  written so that it will fall into X+LOOP )

CODE XLOOP
  H 1 LXI,  H PUSH,
;NOTHREAD

 CODE X+LOOP ( increment --)
  '' CSP LHLD, 
    h dcx, h dcx, mov-de[hl], ( get current)
  DI, XTHL, EI, ( mfb) D DAD, ( get increment and add to current)
  IFNC A D MOV, H XRA, IFM ( overflow ?)
    B INX, B INX, H POP, D -4 LXI, D DAD, '' CSP SHLD, ' THREAD JMP, ( exit)
  THEN THEN
  DI, XTHL, EI, ( mfb) H DCX, D M MOV, H DCX, E M MOV, ( get limit)
  DI, XTHL, EI, ( mfb) XCHG, B PUSH, ( de=current hl=limit)
  mov-axhl, sub-axde,
  B POP, IFM ( current > limit (signed 16-bit))
    B INX, B INX, H POP, H DCX, H DCX, '' CSP SHLD, ( exit loop)
  ELSE
    H POP, H INX, H INX, 
    mov-[hl]de, h inx, ( get top of loop address)
           mov-bc[bc], ( thread to top of loop)
  THEN
;  

CODE XDOI 
  H 1 LXI,  H PUSH,  ' CSPICK JMP, 
;NOTHREAD

CODE XDOJ 
  H 4 LXI,  H PUSH,  ' CSPICK JMP, 
;NOTHREAD

CODE XDOK  
  H 7 LXI,  H PUSH,  ' CSPICK JMP, 
;NOTHREAD

CODE XDOEXIT ( DO LOOP EXIT)
  '' CSP LHLD,  D -5 LXI,  D DAD,
  h dcx, mov-bc[hl],  '' CSP SHLD,  
; ASM

( *************************
  * IF[ and END[ executor *
  ************************* )

CODE XIF[ ( EXECUTOR FOR THE IF[...] OPERATION.)
  H POP, ( GET TEST VALUE FROM THE STACK.)
  BEGIN ( SEARCH LOOP FOR MATCH.)
    B LDAX, B INX, ( GET TYPE OF TEST BYTE.)
    A ORA, IFZ ( IF =0, THIS IS THE ELSE BRANCH.)
       mov-bc[bc], mov-axbc,  ( 4TH PC=BRANCH ADDRESS.-- but al seems
					to matter as well ???? )
      ' THREAD JMP, ( GO TO NEXT OPERATION.)
    THEN
    A DCR, IFZ ( IF TYPE=1, SINGLE VALUE TEST.)
      B LDAX,  B INX,  L XRA,
      B LDAX, ( mfb) PSW PUSH,  B INX, PSW POP,
      IFZ ( IF LSB IS =, TEST MSB.)
        H XRA,
      THEN
      IFNZ ( IF EITHER NOT =, CY=1)
        STC,
      THEN
    ELSE
      A DCR, IFZ ( IF TYPE=2, RANGE TEST.)
	 mov-ax[bc], sub-axhl, b inx, b inx, 
	  mov-de[bc], b inx, b inx,
        IFNC ( IF HI LIM>=VAL)
	sub-hlde,
        THEN ( TEST FOR VAL>=LOW LIM.)
      ELSE ( IF TYPE =3, STRING MATCH TEST.)
        B LDAX,  E A MOV,  E INR, ( E=COUNT.)
        H PUSH, ( SAVE STRING ADDRESS.)
        BEGIN
          B LDAX,  M XRA, IFZ ( DO BYTES MATCH?)
            B INX,  H INX, ( BUMP POINTERS.)
            E DCR, IFZ ( UPDATE COUNT, TEST)
              STC, ( IF END, EXIT LOOP.)
            THEN
          ELSE
            STC, ( EXIT, NO MATCH.)
          THEN
        ENDC ( IF Z IS SET, MATCH IS FOUND.)
        H POP, ( RESTORE STRING POINTER.)
        IFNZ 
          A C MOV,  E ADD,  C A MOV,
          IFC ( ADD REMAINING COUNT TO BC.)
            B INR,
          THEN
          STC, ( CY=1 FOR NO MATCH.)
        ELSE
          A ORA, ( CY=0 IF MATCH.)
        THEN
      THEN
    THEN
  ENDNC ( MATCH IS FOUND IF CY=0)
  BEGIN ( SKIP TO END OF LIST.)
    B LDAX,  B INX,  ( A=TYPE OF ENTRY.)
    A ORA,  IFZ ( IF TYPE=0, WE ARE AT THE END.)
      B INX,  B INX,  ( SKIP THE BRANCH ADDRESS.)
      ' THREAD JMP, ( GO EXECUTE.)
    THEN
    A DCR,  IFZ ( TYPE=1, SINGLE VALUE TEST.)
      B INX,  B INX,
    ELSE
      A DCR,  IFZ ( TYPE=2, RANGE TEST.)
        B INX,  B INX,  B INX,  B INX,
      ELSE ( TYPE=3, STRING MATCH.)
        B LDAX,  C ADD,  C A MOV,  IFC
          B INR, ( SKIP OVER STRING.)
        THEN
        B INX, ( GO PAST END.)
      THEN
    THEN
  ENDU ( LOOP.)
;NOTHREAD ASM

( COMMONLY USED CONSTANTS)
-1 CONST -1
 0 CONST  0
 1 CONST  1
 2 CONST  2
 3 CONST  3
 4 CONST  4
 5 CONST  5
 6 CONST  6
 7 CONST  7
 8 CONST  8
 9 CONST  9
10 CONST 10

( END OF FILE "7BASIC")