( Ver<861223>, John R Baker )
(      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 )
 
( ****************************************************************************)
( This first section sets up )
( It defines six new opcode tables: B=B+B, D1=AS, EJECT, STITLE, LCASC, NIBASC)
HEX
VARIABLE LINECOUNT
     CREATE NEWB
       42502 , B423D , 20422 , 5304 , 1000 ,
 
     CREATE NEWD
       44505 , 13D31 , 20534 , 39305 , 1 ,

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

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

     CREATE NEWNIBASC
       4E62A , 14249 , 43534 , 00024 , E1000 ,
 
     CREATE NEWLCASC
       4C52B , 34143 , 20435 , 30220 , 23000 ,
 
( ****************************************************************************)
 
: 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 )
 
( ****************************************************************************)
: 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.<861223>, 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 )

( ****************************************************************************)
: OUT.LINE
     OUTLIN               ( send the line )
     [ E9AEC , ] @ PAGESIZE @ > IF    ( have lines exceeded pagesize ? )
     EJLINE THEN ;                    ( yes, eject )

( ****************************************************************************)
: 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 ;
( ****************************************************************************)
: 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 )
( ****************************************************************************)
: SLASH
       OVER C@ DUP 5C = IF DROP -1 ELSE 27 = THEN OVER AND DUP >R
       IF C@+ DROP THEN
       [ ED2D8 , ] DUP 5C = IF DROP -1 ELSE 27 = THEN DUP >R IF 1- THEN
       R> R> AND 0= IF 18 [ EC50A , ] THEN ;
( ****************************************************************************)
: ASCLEN
       [ E9BE6 , ] SLASH DUP 2* [ ED062 , ] ;
( ****************************************************************************)
: NNIBASC
       ASCLEN [ EC9F0 , ] 
       IF >R 2DROP R> ELSE
       >R 4 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 ;
( ****************************************************************************)
: 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 ;
( ****************************************************************************)
: 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
       DUP 5C = IF DROP -1 ELSE 27 = THEN
       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 ;
( ****************************************************************************)
: 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 , ] ! ;
( ****************************************************************************)
: 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 ;
( ****************************************************************************)
 
: NEWSTITLE
     [ ED9F1 , ] [ E9A6F , ] S! EJLINE ;  ( new STITLE handler )

( ****************************************************************************)
( 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@ DUP 0=    ( read symbol type )
     IF DROP " Pass 1 EQUate" ELSE
     2 = IF " EQUate" ELSE
     " Label" THEN 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" 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 ;

( ****************************************************************************)
( The following code is called if its' address is in 2FC79 )
( It checks for 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 -1 ELSE 2DUP
     " D1=AS" S= IF 2DROP NEWD -1 ELSE 2DUP
     " EJECT" S= IF 2DROP NEWEJE -1 ELSE
     " STITLE" S= IF NEWSTIT -1 ELSE 0
     THEN THEN THEN THEN THEN THEN ;

( ****************************************************************************)
( this is the new process routine code )
: NEWPROC
     DUP
     28 = IF DROP EJLINE ELSE DUP
     29 = IF DROP NEWSTITLE ELSE DUP
     2A = IF DROP NNIBASC ELSE
     2B = IF NLCASC
     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 , ] ( see if user screwed-up and used FiLeNd )
     IF 3D [ EA70A , ] THEN ( if so, shutdown; that's a no-no... )
     [ E998E , ] @ DUP " FiLeNd" [ EB6A7 , ] ( else add FiLeNd to Symbol table )
     [ 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 )
DECIMAL