( Ver<870123>, John R Baker, FORTH/Saturn assembler revision )
(      if the version changes... )
(      be sure to update it in word EJLINE )
           
( This code fixes 5 bugs in the FORTH/Assembler ROM )
(     [1] B=B+B A which has bad class )
(     [2] D1=AS   which has bad opcode )
(     [3]         'not unique' errors for primitives )
(     [4]         decimal mode needed for assembly )
(     [5]         hex mode during Symbol table listing )
 
( It also enhances the assembly statistics listing somewhat )
(      it rewrites the code to output listing lines )
(      it also redefines EJECT and STITLE, of necessity )
(      EJECT is class 40d, 28h )
(      STITLE is class 41d, 29h )
(      both, have flag 1 set so no pass 1 processing is needed )

(      to work, EJECT needs only call EJLINE )
(      STITLE extracts and stores text, done in NEWSTITLE )
 
(      The code also redefines certain ops to accept \\ backslashes along )
(      with '' for ASCII delimiters. The code also bypasses the need for )
(      any FORTH ROM pseudo-ops such as LEX. This allows source code to be )
(      totally compatable with the HP Ipaetus {200 series} and Hand Held )
(      Products Saturn assemblers )
 
( NOTE... the NIBASC which defines the file name must be located in the )
(         first 7 lines of source code for error trapping to work correctly )
 
( ****************************************************************************)
( It defines 17  new opcode tables: B=B+B, D1=AS, EJECT, STITLE, LCASC, NIBASC)
( CON{1-5}, LC{1-5} and RDSYMB )
BASE @ HEX
VARIABLE LINECOUNT     ( current linecount )
VARIABLE SFIB          ( source FIB # )
VARIABLE SLN           ( source line # )
VARIABLE OPLEN         ( current opcode length )
60 STRING SLT          ( current source line text )
0A STRING LFLD         ( current label field )
0A STRING OFLD         ( current opcode field )
32 STRING EFLD         ( current expression field )
 
     CREATE NEWB=B+B
       42502 , B423D , 20422 , 5304 , 1000 ,
 
     CREATE NEWD1=AS
       44505 , 13D31 , 20534 , 39305 , 1 ,

     CREATE NEWEJECT
       45528 , 3454A , 20544 , 1 , 0 ,

     CREATE NEWSTITLE
       53629 , 44954 , 454C5 , 1 , 0  ,

     CREATE NEWNIBASC
       4E62A , 14249 , 43534 , 00024 , E1000 ,
 
     CREATE NEWLCASC
       4C52B , 34143 , 20435 , 30220 , 23000 ,

     CREATE NEWCON1
       4362C , 84E4F , 29312 , 131 , 11000 ,

     CREATE NEWCON2
       4362C , 84E4F , 29322 , 231 , 21000 ,

     CREATE NEWCON3
       4362C , 84E4F , 29332 , 331 , 31000 ,

     CREATE NEWCON4
       4362C , 84E4F , 29342 , 431 , 41000 ,

     CREATE NEWCON5
       4362C , 84E4F , 29352 , 531 , 51000 ,

     CREATE NEWLC1
       4C52C , 12843 , 20293 , 3B1 , 13003 ,

     CREATE NEWLC2
       4C52C , 22843 , 20293 , 4B1 , 23031 ,

     CREATE NEWLC3
       4C52C , 32843 , 20293 , 5B1 , 33320 ,

     CREATE NEWLC4
       4C52C , 42843 , 20293 , 6B1 , 43330 ,

     CREATE NEWLC5
       4C52C , 52843 , 20293 , 7B1 , 53340 ,
 
     CREATE NEWRDSYMB
       5262D , 95344 , 424D5 , 20 , 0 ,
 
( ****************************************************************************)
( this sends a line to a listing device, file or HPIL )
: OUTLIN   [ EF600 , ]    ( check ON )
     [ E9B69 , ] @ LISTING SWAP DROP
     [ E348B , ] IF      ( now listing ? )
     [ E9B1E , ] @ ?DUP IF  ( pil ? )
     PRIMARY ! OUTPUT CRLF OUTPUT ELSE      ( output pil )
     [ EAC68 , ] THEN        ( else print file )
     1 [ E9AEC , ] +!        ( increment line # )
     NULL$ THEN 2DROP [ EA3B0 , ] ;   ( clear stack & line var )
 
( ****************************************************************************)
( this does a page eject, prints headings )
: EJLINE     
     [ E9B69 , ] @ IF
     0 [ E9AEC , ] ! 1 [ E9B50 , ] +!  ( reset line#, increment page# )
     C CHR$ OUTLIN          ( send form feed )
 
     " FORTH Saturn Assembler,  " [ E9B05 , ] S!
     [ E9B05 , ] [ E9A56 , ] S<& ( add title )
     DUP 48 SWAP DO
     20 CHR$ S<& LOOP   ( push page # to far right of page )
     " Page: " S<&
     [ E9B50 , ] @ DECIMAL [ EA450 , ]    ( read page # )
     S<& OUTLIN

     " Rev.<870123>, JR Baker,  " [ E9B05 , ] S!
     [ E9B05 , ] [ E9A6F , ] S<&         ( add STITLE )
     DUP 48 SWAP DO
     20 CHR$ S<& LOOP     ( add spaces )
     " DATE$" BASIC$ S<&  ( add date after subtitle )
     OUTLIN               ( send line )

     NULL$ OUTLIN THEN ;  ( send one blank line )

( ****************************************************************************)
( this is a higher level line output, it does a formfeed every PAGESIZE )
: OUT.LINE
     OUTLIN               ( send the line )
     [ E9AEC , ] @ PAGESIZE @ > IF    ( have lines exceeded pagesize ? )
     EJLINE THEN ;                    ( yes, eject )

( ****************************************************************************)
( this prepares a line for listing from its' component parts )
: OUT.LIST
     LISTING SWAP DROP [ E9B69 , ] @ [ E348B , ] ( is listing on & specified )
     IF [ E9C4A , ] @ 18 MIN 7 + 8 / 1 MAX 0  ( only 8 nibs per line )
     DO 
     [ EA3B0 , ] [ E9B05 , ] [ E0A40 , ] 0=  ( clear list line variable )
     IF DECIMAL [ E9A88 , ] @ 1- [ EA46E , ] ELSE  ( generate line number )
     [ EA329 , ] THEN    ( unless multi-line needed )
     S<& HEX [ E998E , ] @ [ E0A40 , ] 8 * +  ( generate location counter )
     [ E9A0B , ] @ 1 > IF  ( check if LEX or BIN )
     [ E9EA2 , ] @ - THEN  ( if so make it relative )
     [ EA48C , ] S<& [ E0A40 , ]  ( add to line )
     8 * DUP 8 + SWAP  ( setup loop for 8 opcode nibs )
     DO
     [ E0A40 , ] [ E9C4A , ] @ 1- > IF  ( end of this opcode yet ? )
     [ EA360 , ] ELSE   ( yes, generate blanks )
     [ E0A40 , ] 11 > IF 0 ELSE  ( get opcode nibble )
     [ E0A40 , ] 1+ [ EA4C3 , ] @ THEN  ( this handles BSS opcodes )
     [ EA41E , ] THEN
     S<& LOOP     ( add nibble to opcode string )
     [ E0A40 , ] 0= IF  ( is this first line ? )
     [ EA347 , ] S<& [ E9ABA , ]  ( yes, append source to listing line )
     4B MIN S<& THEN
     OUT.LINE         ( send the line )
     LOOP
     THEN DECIMAL ;
( ****************************************************************************)
( this generates object code and listings, line by line )
: SPIT
     [ E99A7 , ] @ IF   ( check test match )
     [ EC6A0 , ] 0= [ E9C4A , ] @ [ E348B , ] IF ( only if line generates code )
     15 [ EB082 , ] THEN THEN  ( report error )
     [ EAAE4 , ]     ( output object code )
     OUT.LIST ;      ( output listing )
( ****************************************************************************)
( this parses either a "\" or "'" delimiter in an ASCII string )
: TSTSTR
       DUP 5C = IF DROP -1 ELSE 27 = THEN ;
( ****************************************************************************)
( this parses the text from a string )
: SLASH
       OVER C@ TSTSTR OVER AND DUP >R
       IF C@+ DROP THEN
       [ ED2D8 , ] TSTSTR DUP >R IF 1- THEN
       R> R> AND 0= IF 18 [ EC50A , ] THEN ;
( ****************************************************************************)
( this returns the length of an ASCII string )
: ASCLEN
       [ E9BE6 , ] SLASH DUP 2* [ ED062 , ] ;
( ****************************************************************************)
( this processes ASCII constants during expression evaluation )
: CONASC
       0 [ E9D2B , ] ! BEGIN OVER C@ TSTSTR 0= OVER AND WHILE
       C@+ 100 [ EBB00 , ] REPEAT 1 ;
( *****************************************************************************)
( this scans a source expression stream )
: LEXSCAN
       DUP 0= IF 0 ELSE OVER C@ DUP [ EBB28 , ] IF DROP [ EBB5F , ] ELSE
       DUP 23 = IF DROP C@+ DROP [ EBC09 , ] ELSE DUP TSTSTR IF DROP C@+    
       DROP CONASC >R C@+ TSTSTR 0= IF 18 [ EB082 , ] THEN R> ELSE
       DUP [ EBCEA , ] IF DROP C@+ ELSE DUP 3D = IF DROP C@+ THEN
       DROP [ EBDFD , ] THEN THEN THEN THEN THEN [ E9D44 , ] ! ;
( *****************************************************************************)
( this is the expression execution routine )
( in this first word, it is critical not to change code from the CFA to )
( the [ 0 , ] without also changing the code at the end of this file )
( doing so will invalidate the offset used )
: BASE0
       [ EC3FC , ] [ E9D44 , ] @ CASE
       1 OF [ E9D2B , ] @ ENDOF
       2 OF [ E9D5D , ] [ EB517 , ] [ E99D9 , ] @ 0= IF 25 [ EC50A , ]
              THEN ENDOF
       28 OF LEXSCAN
       [ 0 , ]     ( this is a placeholder, we later compile the CFA of )
                   ( TERM so as to implement recursion  )
       [ E9D44 , ] @ 29 = 0= IF 26 [ EC50A , ] THEN ENDOF
       2A OF [ E998E , ] @ ENDOF
       27 [ EC50A , ] 0 ENDCASE >R LEXSCAN R> ;

: UNARY
       [ EC3FC , ] [ E9D44 , ] @ 2D = IF LEXSCAN BASE0 NEGATE ELSE BASE0 THEN ;

: BOOLEAN
       [ EC3FC , ] UNARY BEGIN [ E9D44 , ] @ DUP 26 = OVER 21 = OR WHILE
       2SWAP LEXSCAN UNARY >R 2SWAP 26 = IF R> AND ELSE R> OR THEN REPEAT DROP ;

: FACTOR
       [ EC3FC , ] BOOLEAN BEGIN [ E9D44 , ] @ DUP 2A = OVER 2F = OR WHILE
       2SWAP LEXSCAN BOOLEAN >R 2SWAP 2A = IF R> * ELSE R> DUP 0= IF 27 
       [ EC50A , ] THEN / THEN REPEAT DROP ;

: TERM
       [ EC3FC , ] FACTOR BEGIN [ E9D44 , ] @ DUP 2B = OVER 2D = OR WHILE
       2SWAP LEXSCAN FACTOR >R 2SWAP 2B = IF R> + ELSE R> - THEN REPEAT DROP ;
( *****************************************************************************)
( this is the top level of expression execution )
: EXPR
       [ E9BE6 , ] RP@ [ E9CE0 , ] ! SP@ [ E9CF9 , ] ! LEXSCAN TERM
       >R 2DROP R> [ E9D44 , ] @ IF 28 [ EC50A , ] THEN ;
( *****************************************************************************)
( this is the new NIBASC process code )
: NNIBASC
       ASCLEN [ EC9F0 , ] 
       IF >R 2DROP R> ELSE
       >R 8 LINECOUNT @ < IF R> ELSE 2DUP [ E9B82 , ] S! R> THEN
       [ ED436 , ] DO C@+ DUP 10 / DUP I 1+ 2* [ EA4C3 , ] DUP >R
       ! 10 * - R> 5- ! LOOP [ ED49F , ] THEN ;
( ****************************************************************************)
( this is the new LCASC process code )
: NLCASC
       ASCLEN [ EC9F0 , ] IF >R 2DROP R> ELSE
       [ ED436 , ] DO C@+ DUP 10 / DUP [ E9D76 , ]
       @ I 2* - 4 MAX [ EA4C3 , ] DUP >R ! 10 * - R> 5- !
       LOOP [ ED49F , ] [ E9D76 , ] @ 3 - 0 MAX [ EC60F , ] ! THEN ;
( ****************************************************************************)
( this code parses a source line into component fields )
: PARSE
       [ E9ABA , ] 0 CHR$ S<& DROP [ E0C94 , ] ENCLOSE 2OVER + C@ 2A =
       IF [ EA388 , ] NULL$ 2DUP 2DUP [ E9BB4 , ] S!
       [ E9BCD , ] S! [ E9BE6 , ] S! [ E1C54 , ] [ E7586 , ] [ EF15D , ] ELSE
       3 PICK 3 < IF [ EF261 , ] A MIN [ E9BB4 , ] S! [ E0C94 , ]
       ENCLOSE ELSE NULL$ [ E9BB4 , ] S! THEN 
       [ EF261 , ] A MIN 2DUP [ E9BCD , ] S! [ EF103 , ] 0=
       IF 14 [ EC50A , ] [ E1C54 , ] [ E7586 , ] THEN [ EF15D , ] [ E0C94 , ]
       ENCLOSE [ E9C31 , ] @ 20 AND IF 2DROP + 0 OVER BEGIN 
       2+ DUP 2- C@ DUP [ E0C94 , ] = 0= 4 PICK OR OVER AND WHILE
       TSTSTR
       IF SWAP NOT SWAP THEN REPEAT
       DROP SWAP DROP OVER - 2- 2/ ELSE
       [ EF261 , ] ROT DROP THEN DUP 32 >
       IF 28 [ EC50A , ] DROP 32 THEN
       [ E9BE6 , ] S! THEN ;
( ****************************************************************************)
( this processes one line of source code, both pass 1 & 2 )
: DO.LINE
     [ EF600 , ] [ EF6DF , ] PARSE        ( check ON, disp ., parse source )
     1 LINECOUNT +!
     [ E9C18 , ] @ 16 = 0= IF ( check label field, except EQUs )
     [ EF972 , ] THEN  ( process labels )
     [ EC9F0 , ] IF    ( pass 1 ? )
     [ EC678 , ] 0= IF ( is flag 1 set ? )
     [ EF837 , ] THEN  ( no, determine length )
     [ E9A0B , ] @ 0= IF  ( is filetype declared ? )
     33 [ EA70A , ] THEN ELSE ( no, error out )
     [ EF837 , ]    ( pass 2 process routine )
     SPIT THEN      ( send to object & listing )
     [ EF931 , ] FFFF7 [ EA3EC , ] ( update location count, line errors )
     [ E99C0 , ] ! ;
( ****************************************************************************)
( this initiates each of the two passes through the assembler )
: DO.PASS
     [ EFAD5 , ]     ( initialise pass )
     [ E9A0B , ]   @ 0= IF 2 [ E9A0B , ] ! ELSE [ EDB44 , ] IF [ EAA76 , ]  
     THEN THEN 
     [ EC9F0 , ] IF [ EA179 , ] [ E9EA2 , ] @ [ E998E , ] !      
     ELSE 0 LINECOUNT ! THEN
     BEGIN
     [ EA98F , ] [ E99F2 , ] @ 0= AND ( read source until EOF )
     WHILE
     DO.LINE    ( process line )
     REPEAT ;
( ****************************************************************************)
( this is the new STITLE process code )
: NSTITLE
     [ ED9F1 , ] [ E9A6F , ] S! EJLINE ;  ( new STITLE handler )

( ****************************************************************************)
( this defines the new LC{x} and CON{x} handler )
: NLCCON
       EXPR [ E9C7C , ] @ [ E9CC7 , ] @ [ EC996 , ] ;
( ****************************************************************************)
( This outputs the Symbol table to the Listing device )
 
: OUTSYT
     " ------>> Assembler Symbol Table <<------"
     [ E9A6F , ] S! ( store in subtitle variable )

     EJLINE         ( eject )
     [ EA3B0 , ]    ( clear listing line )
     "  Text   Decimal  Hex     Type" OUT.LINE
     " ------  ------- -----   ------" OUT.LINE
 
     [ E9E0C , ] @ HEX ( get address of symbol table )

     BEGIN          ( while there are symbol table entries )
     DUP @ -1 = 0= WHILE

     DUP 6          ( extract label )

     [ E9B05 , ] 2SWAP S<& [ EA347 , ] S<& ( append to listing line )

     ROT C + DUP @ OVER ( extract value )

     5+ N@ 1 AND [ E9A0B , ] @ 1 > AND IF ( check if label & not FORTH )

     [ E9EA2 , ] @ - THEN ( not FORTH, get relative value )

     DUP >R DECIMAL 0
     <# [ EA405 , ] # # # # # # # #>
     ROT >R S<& R> R>
     HEX                ( this is actual bug fix... )
                        ( can also be changed in EJLINE )
     [ EA48C , ] ROT >R S<& R> ( append value to listing line )

     5+ DUP N@           ( read symbol type )
     2 = IF " Equate" ELSE
     " Label" THEN        ( --- addr cnt addr' addr" cnt" )
     ROT >R               ( --- addr cnt addr" cnt" )
     2SWAP [ EA347 , ] S<&  ( add two spaces after value )
     2SWAP S<& R>         ( add type of symbol  --- addr cnt addr' )
     ROT ROT  OUT.LINE   ( output the line )

     1+ REPEAT         ( get next entry & repeat  --- addr )

( ----------------------------------------------------------------------------)
     DROP           ( blow off address pointer, we're done )

     " ------->> Assembler Statistics <<-------" [ E9A6F , ] S! DECIMAL

     6 0 DO             ( send six blank lines )
     NULL$ OUT.LINE    LOOP

     " **********************>> Assembler Parameters <<**********************"
     OUT.LINE
     NULL$ OUT.LINE
     NULL$ OUT.LINE
 
     [ E9B05 , ] " Source File is  : " S<& [ E9AA1 , ] S<& OUT.LINE
     NULL$ OUT.LINE

     " Object File is  : " [ E9B05 , ] S!
     [ E9B05 , ] [ E9B82 , ] DUP 0= IF ( send object file name )
     2DROP " FORTHRAM" THEN   ( unless it is FORTHRAM )
     S<& OUT.LINE             ( send line )
     NULL$ OUT.LINE

     " Object File Size: " [ E9B05 , ] S!
     [ E9B05 , ] [ E9EBB , ] @ ( read object file size )
     [ EA48C , ] S<& " nibbles, w/header" S<& OUT.LINE
     NULL$ OUT.LINE
 
     " Object File Type: " [ E9B05 , ] S!
     [ E9B05 , ] [ E9A0B , ] @
     DUP 1 = IF DROP " FORTH" ELSE
     DUP 2 = IF DROP " LEX" ELSE
         3 = IF " BIN" ELSE " ?????"
     THEN THEN THEN
     S<& OUT.LINE
     NULL$ OUT.LINE
 
     [ E9B05 , ] " Listing File is : " S<& LISTING S<& OUT.LINE
     NULL$ OUT.LINE

     " Total Symbols   : " [ E9B05 , ] S!
     [ E9B05 , ] [ E9E25 , ] @ 1- ( read number of symbols )
     [ EA450 , ] S<& OUT.LINE     ( format & send line )
     NULL$ OUT.LINE

     " Assembly Date   : " [ E9B05 , ] S!
     [ E9B05 , ] " DATE$" BASIC$ S<&  ( setup date )
     OUT.LINE                  ( send line )
     NULL$ OUT.LINE
 
     " Assembly Time   : " [ E9B05 , ] S!  ( setup time )
     [ E9B05 , ] " TIME$" BASIC$ S<&
     OUT.LINE                  ( send time )
     NULL$ OUT.LINE

     " Assembly Errors : " [ E9B05 , ] S!
     [ E9B05 , ] [ E9A3D , ] @
     DUP 0= IF
     DROP " None" ELSE
     [ EA450 , ] THEN
     S<& OUT.LINE                ( send errors )
     NULL$ OUT.LINE
     
     " **********************>> end of assembly <<***************************"
     OUT.LINE
     NULL$ OUT.LINE
 
(                     subtract 1 from line count, do form feed )
     -1 [ E9AEC , ] +! C CHR$ OUT.LINE ;
 
( *****************************************************************************)
( this word processes the RDSYMB pseudo-op, since it opens a new file, we have )
( to save all needed pointers to return to the assembler )
: NRDSYMB  
       2FC88 @ SFIB !           ( save oGRAB )
       [ E9A88 , ] @ SLN !      ( save source line number )
       [ E9ABA , ] SLT S!       ( save source line text )
       [ E9BB4 , ] LFLD S!      ( save source label field )
       [ E9BCD , ] OFLD S!      ( save source opcode field )
       [ E9BE6 , ] EFLD S!      ( save source expression field )
       [ E9BE6 , ] [ EA903 , ] 1 [ E9A88 , ] ! ( open symbol file, set line # )
       BEGIN [ EA98F , ] WHILE PARSE [ EF837 , ] REPEAT ( read lines until EOF )
       LFLD [ E9BB4 , ] S!      ( restore label field )
       OFLD [ E9BCD , ] S!      ( restore opcode field )
       EFLD [ E9BE6 , ] S!      ( restore expression field )
       SLT  [ E9ABA , ] S!      ( restore source line text )
       SLN @ [ E9A88 , ] !      ( restore source line number )
       SCRFIB @ CLOSEF          ( close symbol file )
       0 [ E9C4A , ] !          ( set opcode length to 0 )
       2FC88 @ SCRFIB !         ( restore SCRFIB )
       SFIB @ 2FC88 !           ( restore oGRAB )
       [ EC9F0 , ] IF 0 THEN ;  ( return 0 length during pass 1 )

( ****************************************************************************)
( The following code is called if its' address is in 2FC79 )
( It parses mnemonics and returns false flag if not ours )
( If ours, returns opcode table address and true flag )
 
: NEWCODE
     2DUP
     " NIBASC" S= IF 2DROP NEWNIBASC -1 ELSE 2DUP
     " LCASC" S= IF 2DROP NEWLCASC -1 ELSE 2DUP
     " B=B+B" S= IF 2DROP NEWB=B+B -1 ELSE 2DUP
     " D1=AS" S= IF 2DROP NEWD1=AS -1 ELSE 2DUP
     " CON(1)" S= IF 2DROP NEWCON1 -1 ELSE 2DUP
     " CON(2)" S= IF 2DROP NEWCON2 -1 ELSE 2DUP
     " CON(3)" S= IF 2DROP NEWCON3 -1 ELSE 2DUP
     " CON(4)" S= IF 2DROP NEWCON4 -1 ELSE 2DUP
     " CON(5)" S= IF 2DROP NEWCON5 -1 ELSE 2DUP
     " LC(1)" S= IF 2DROP NEWLC1 -1 ELSE 2DUP
     " LC(2)" S= IF 2DROP NEWLC2 -1 ELSE 2DUP
     " LC(3)" S= IF 2DROP NEWLC3 -1 ELSE 2DUP
     " LC(4)" S= IF 2DROP NEWLC4 -1 ELSE 2DUP
     " LC(5)" S= IF 2DROP NEWLC5 -1 ELSE 2DUP
     " RDSYMB" S= IF 2DROP NEWRDSYMB -1 ELSE 2DUP
     " EJECT" S= IF 2DROP NEWEJECT -1 ELSE
     " STITLE" S= IF NEWSTITLE -1 ELSE 0
     THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN
     THEN THEN THEN THEN THEN THEN THEN ;

( ****************************************************************************)
( this is the new process routine code )
( we define 6 new classes of opcode processing )
: NEWPROC
     DUP
     28 = IF DROP EJLINE ELSE DUP
     29 = IF DROP NSTITLE ELSE DUP
     2A = IF DROP NNIBASC ELSE DUP
     2B = IF DROP NLCASC ELSE DUP
     2C = IF DROP NLCCON ELSE
     2D = IF NRDSYMB
     THEN THEN THEN THEN THEN THEN ;
 
( ****************************************************************************)
( This defines SASM as the word to invoke the assembler )
( It fixes the DECIMAL mode, WORD Not Unique, & Symbol table bugs )
 
( it also fixes two defective ROM opcodes )
: SASM
          (  clear dictionary from HERE to PAD )
     HERE PAD OVER - 0 NFILL
          ( check for a valid string at the PAD )
          ( tests if string end is past stack start )
     PAD 2+ DUP C@ 2* + 2+ SP@ 2DUP <
          ( now clear to top of data stack )
     IF OVER - 0 NFILL ELSE 2DROP THEN
     ['] NEWCODE 2FC79 ! ( invoke new opcode handler )
     ['] NEWPROC 2FC7E ! ( invoke new process routine )

     [ E45B1 , ] @   ( ensure FORTHX not executing )
     IF 3F [ E9ED4 , ] CR TYPE CR ABORT THEN
     BASE @ [ E1B1A , ] ! DECIMAL ( save current base value )
     [ EFC6C , ]  ( initiialise variables )
     1 [ E997A , ] ! DO.PASS     ( do pass 1 )
 
     " FILEND" [ EB517 , ] 0= IF 16 [ EA70A , ] THEN  ( abort if no FILEND ) 
 
     [ E998E , ] @      ( recall location counter at file end )
     [ E9EA2 , ] @ - [ E9EBB , ] ! ( compute & store filesize in nibs )
     [ EA976 , ] ( reset source file to start )
     2 [ E997A , ] ! DO.PASS     ( now do pass 2 )
     [ E9B69 , ] @ IF OUTSYT THEN ( output Symbol table if listing given )
     [ EA663 , ]  ( purge Symbol table & close files )
     0 2FC7E !
     0 2FC79 ! ;  ( reset new opcode flag )
( *****************************************************************************)
( this code compiles a forward reference into WORD BASE0 to implement )
( recursion. Use extreme care if changes are made to BASE0 ) 
' TERM ' BASE0 C8 + !
( *****************************************************************************)
BASE !