Drv Block  Contains                                                                                                                    
  0     0  Working system, 360 source 360 shadows                                              N O T I C E                             
  1   720                                                              The material on this disk is proprietary to FORTH, Inc.         
  2  1440                                                              It is copyright (c) 1985 by FORTH, Inc.  All rights reserved.   
  3  2160                                                              This notice must appear on  all authorized copies of this       
  4  2880                                                              software.                                                       
  5  3600                                                              This software has been provided to NOVIX for internal use and   
  6  4320                                                              licensing to its customers.  The chip technology is itself pro- 
  7  5040                                                              prietary; unauthorized use of this software on other equipment  
  8  5760  ... Rest of disk, thru 14 DRIVE.  20 unused tracks.         may abridge the rights of NOVIX as well as those of the software
----------------------------------------------------------------       developers.                                                     
 15 10800  Floppy, 360 blocks + 360 gap                                                                                                
 16 11520  (LSI) Serial disk, if installed                             While we believe this software to be bug free, FORTH, Inc. makes
----------------------------------------------------------------       no representations or warranties, including but not limited to  
Last backed up drive 0  to floppy:  02/12/87  GRC                      the implied warranties of merchantability or fitness for a      
BLOCKS 0-7 have latest TRY.  360-367 have Release 1 RAM system.        particular purpose.                                             
( Electives)   DECIMAL 100 H 2 + +!   HERE 30  DUP ALLOT ERASE                                                                         
: <CREATE>   >IN 2@  4 DO( 2/ )  SWAP 16 * + ,  (CREATE) ;             This block is loaded when, after booting, the operator          
   ' <CREATE> 'CREATE !   1 CONSTANT B/H  ( 0 if no LOCATE)               types  HI .  The routines loaded here are in the common      
( Wren II  CONFIGURATION HEX  400 OVER ! 1+  8 OVER ! 1+                  dictionary which is available to all users.                  
   39C OVER ! 1+  100 OVER ! 1+  800 SWAP !  HOME  DECIMAL)            The store into H 2 + in line zero bumps the low-memory dict-    
( Aids)  12 LOAD  139 LOAD  13 LOAD  14 LOAD  10 LOAD                     ionary limit so that low RAM may be more completely filled.  
( Errors)  33 LOAD   ( Buffers)  34 LOAD                                  If you get Dictionary Full during HI, RELOAD before editing! 
( 32-bit & extens)  15 17 THRU  19 LOAD  21 23 THRU                    The ALLOT in line zero extends the OPERATOR's user area as nec. 
( Calendar, clock)  30 32 THRU  ( Interrupt)  18 LOAD                     As shipped, 30 cells are added for a total of 128.           
: SYSTEM   11 DATED  ."  Time is " @TIME .TIME ;   SYSTEM              Lines 3 & 4 show how to dynamically reconfigure for diff. disk. 
( Past PROM)  H 2 + @ 90 - HERE - CR . .( low RAM cells left )         <CREATE> - This compiles, before each new entry, the block no.  
   HEX 2000 H !  7000 'ROM DUP 1000 = AND +  H 2 + !   DECIMAL            in which the source resides.  The cost is 1 cell/entry.      
( Compat)  141 LOAD   ( Tasks)  24 25 THRU   ( Edit)  20 LOAD             This information is used by  LOCATE  to display the block.   
                                                                       The strange phrase near the end of the block moves the operator 
( Tasks  27 LOAD)  FORTH GILD    WY50   ( SECOND PROMPT)                  dictionary pointer up above the PROM and sets new upper lim- 
( PC disk, printer  147 LOAD)   ' ?CREATE 'CREATE !                       it on dictionary space.  Use caution when adding to what's   
   ( Options)                                                             loaded before it or you may exhaust low RAM!                 
: OPTIONS   170 HELPS ;      : DISKS   8 HELPS ;                          These constants provide names for the utilities supplied     
 36 CONSTANT DISKING    39 CONSTANT PRINTING                           with your system.  The system "help screens" list them for      
 42 CONSTANT TESTING    45 CONSTANT COMPILER                           convenience.  The user is encouraged to add the names of        
 44 CONSTANT DIAGNOSTICS                                               additional utilities and application programs as they are       
120 CONSTANT FILES     222 CONSTANT DOS                                developed, both here and in the "help screens" in blocks 11,170.
228 CONSTANT PROMS     234 CONSTANT STREAMER                           Be careful with low memory, though!                             
                                                                          If you have a CRT other than the one for which the screen    
: LOADS ( n)   CREATE ,  DOES>   @ LOAD ;                              editor is defined in the system, you may specify one of these.  
156 LOADS GLASS       157 LOADS VT100   ( 164 LOADS VIEWPOINT)         If you wish, you may replace the CRT-dependent definitions in   
172 LOADS WY50                                                         block 59 with the ones for your CRT, or write new ones depending
                                                                       upon the actual hardware you have.  We include:                 
142 LOADS FORTH-83                                                          GLASS -- Any terminal without cursor positioning (ADM3)    
                                                                            ADM3A -- Lear Siegler ADM3A (with CUR CON enabled)         
                                                                            VT100 -- DEC VT100                                         
                                                                          You will find untested coding for many other terminals in    
   N O V I X    NC4000P   polyFORTH development system                 blocks 156-170.  Follow the examples and it will be easy.       
----------------------------------------------------------------          This is the system help screen.  Feel free to change it when 
   Release 1  05/01/86  Beta Board, serial terminal, SCSI disk.        you reconfigure the system.  Note that the utilities each have  
   Requires PROMs labeled  nF/Pb-0  or  nF/Pb-1                        their own help screens.  You can find them by typing            
                                                                          utility LIST   and looking for the phrase:  n HELPS or       
----------------------------------------------------------------       n DATED .  The number will be the block number of the help      
                                                                       screen.                                                         
SYSTEM              Displays this system-wide help screen.                                                                             
OPTIONS             Displays the major utilities available.               You may find it convenient to configure your application as a
DISKS               Displays current major disk assignments.           utility; if so, please include a help screen that comes up upon 
                                                                       loading, and add to the utility constants on block 10.          
RELOAD   HI         Reloads the entire system.                                                                                         
mm/dd/yy NOW        Sets today's date.                                    If your application utility is important, add an entry to    
hh:mm PST           Sets the current time.                             the system help screen in block 11 or 170.                      
                                                                                                                                       
Today's date is                                                           Note that in the utilities  HELP  is redefined to display the
   ( Dictionary management)                                            utility help screen.  SYSTEM  remains accessible by that name.  
: ~   31 WIDTH 2* C! ;   OCTAL                                         ~  forces the next definition to compile its full name.         
: RECOVER   HERE 1- @  100040 = ALLOT ;   DECIMAL                      RECOVER  deletes an unneeded  EXIT  that was just compiled.     
' RELOAD  -4096 AND  CONSTANT 'ROM                                     'ROM  is the base address of the system in use at present.      
: UNUSED ( - n)   H 2 + @  HERE - ;                                    UNUSED  returns the number of CELLS of unused dictionary.       
: GILD   CONTEXT GOLDEN 18 MOVE  HERE H 1+ ! ;                         GILD  appends the user's current dictionary contents to the sys-
                                                                          tem vocabulary underneath  GOLDEN  and makes it permanent.   
: IMMEDIATE   LAST @  0 @+  OVER @ OVER !  CONTEXT - 15 AND            IMMEDIATE marks the last word defined as immediate (executed    
   CONTEXT + 1+  DUP LAST !  2DUP @  SWAP !  ! ;                          during compilation).  It is used for adding to the compiler. 
: \   ' ,C ;  IMMEDIATE      ~ : [COMPILE]   \ \ ;  IMMEDIATE          [COMPILE]  compiles the following immediate word rather than    
~ : DOES>   COMPILE DOES  \ R>  32767 \ LITERAL                           executing it.  Used only in compiler macros or directives.   
   \ AND ;   IMMEDIATE                                                 \  is a synonym for  [COMPILE]  used in macros for readability. 
: uCODE ( n)   ~ CREATE , IMMEDIATE  DOES>   @ ,C ;                    DOES>  contains a temporary workaround for carry on return stack
( Rel 0 PROM)   OCTAL 177300 uCODE ND!   DECIMAL                       uCODE  defines a hardware instruction for compiling.            
: VOCABULARY ( n)   CREATE ,  DOES>   @  CONTEXT ! ;                   VOCABULARY  is defined here rather than in PROM to save space.  
: DEFINITIONS   CONTEXT @  CURRENT ! ;                                 DEFINITIONS  causes subsequent words to be compiled into the    
   ( Programmer aids)                                                     first vocabulary in the currently effective search order.    
: HELPS ( n)   PAGE  0 15 FOR  CR  OVER BLOCK 2*                       HELPS displays a block of text presumably helpful to the user.  
      OVER + 64 -TRAILING >TYPE  64 +  NEXT  SPACE 2DROP ;                                                                             
360 CONSTANT SHADOWS                                                   SHADOWS is the offset to the shadow blocks.                     
: CAST ( b n - b')   SWAP OVER /MOD  1 XOR  ROT * + ;                  Q displays a block of text associated with each block of code.  
: Q   SCR @  SHADOWS CAST  LIST ;                                         Termed shadow blocks, these keep comments out of the way     
: N   [ EDITOR ] N ;      : B   [ EDITOR ] B ;                            while permitting their easy retrieval and maintenance.       
                                                                       Defined here,  N  and  B  are accessible from  FORTH .          
: CELL ( b - a)   0 \ LITERAL  \ \\  \ +  \ &2/ ;  IMMEDIATE                                                                           
: BYTE ( a - b)   \ 2* ;  IMMEDIATE                                    .(  types out the text before a  ')' .  Executes IMMEDIATEly.   
: .(   41 WORD COUNT TYPE ;   IMMEDIATE                                BYTE  and  CELL  convert cell addr's to and from byte addr's.   
: .(   [COMPILE] .( ;      : BYTE   BYTE ;   : CELL   CELL ;                                                                           
                                                                       I'  and  J  return copies of the second and third items on the  
: I' ( - n)   R> R>  1 I@!  SWAP >R ;  ( 7)                               return stack, respectively.                                  
: J ( - n)   R> R> R>  I MD I!  >R >R >R  MD I@ ;  ( 10)               THRU loads a range of block numbers, inclusive.  THRU compacts  
: THRU ( f l)   DUP >R  SWAP - FOR  I' I - LOAD NEXT  R> DROP ;           load blocks and encourages sequential arrangement of code.   
   ( Dictionary visibility)                                                                                                            
: Can't ( a t - a)   OVER -4096 AND 'ROM = OR ABORT" can't" ;          'HEAD  returns the addr of the start (link B/H - ) of the word  
: 'HEAD ( - a)   1 STATE !  -' -COMPILE ABORT" ?"                         following in the input stream.                               
      SWAP DROP  B/H - ;                                               LOCATE types the source block of the next word.  It relies      
                                                                          upon the version of CREATE loaded in block 9.                
: LOCATE   'HEAD  DUP ['] <CREATE> U< Can't  @  64 1024 */MOD          FORGET forgets the next word and all words defined more recently
   ?DUP IF  SCR 2!  CONTEXT @  L  CONTEXT ! DUP  THEN DROP ;              than it.  It strips the 16 dictionary chains back to before  
: FORGET   'HEAD DUP  H 1+ 2@ WITHIN Can't  H !  CONTEXT 1+               the word being forgotten.  It won't forget the nucleus.      
   15 FOR  DUP BEGIN  @  DUP H 2 + @  HERE WITHIN UNTIL                                                                                
      OVER !  1+ NEXT  DROP ;                                          ?CREATE will generate a warning message when words are redefined
                                                                          It is useful as a debugging tool, although re-defined words  
: ?CREATE   >IN @  1 STATE !  -' NOT IF  CR  HERE COUNT TYPE              are not considered bad technique.  To make this check        
   ."  Redefined "  DROP  THEN DROP >IN !  -COMPILE <CREATE> ;            automatic, remove the  EXIT .  This version is not as bright 
( Remove  EXIT  to enable:)  EXIT      ' ?CREATE  'CREATE !               as we intend it to be for the chip's new vocabulary structure
                                                                          and it will be rewritten in a later release.                 
                                                                                                                                       
( 32-bit Operators)                                                                                                                    
: 2VARIABLE   VARIABLE  0 , ;                                          Double numbers appear on the stack with their most significant  
: 2CONSTANT ( d)   CREATE , ,  DOES> ( - d)   2@ ;                        16 bits on top.  Many of the 32-bit operators are useful for 
0 0 2CONSTANT 0.      1 0 2CONSTANT 1.                                    other data types of the same size but different meaning, as  
                                                                          for example 2-vectors.  Generally the prefix "2" denotes a   
: 2OVER ( d d - d d d)   >R >R  OVER MD I!  DUP SR I!                     word that can be used for any 32-bit type.                   
      BEGIN  R> R>  MD I@ SR I@ ;  ( 10)                                                                                               
: 2SWAP ( d d - d d)   >R >R  SR I!  MD I!  AGAIN ;  RECOVER           2VARIABLE  reserves pre-zeroed memory for a 32-bit variable;    
                                                                          the convention in memory is that the most significant cell   
: 2>R ( n n)   R> MD I!  SWAP >R >R  MD I@ >R ; ( 9)                      is stored at the lowest address.                             
: 2R> ( n n)   R> MD I!  R> R> SWAP  MD I@ >R ; ( 9)                   2CONSTANT  defines a 32-bit constant.                           
                                                                                                                                       
EXIT                                                                   NOTE that  2SWAP  and  2OVER  use MD and SR for speed.          
: 2SWAP ( d d - d d)   >R SWAP  R> SWAP                                                                                                
   >R >R SWAP  R> SWAP R> ; ( 12)                                      2>R  and  2R>  move 32-bit numbers to and from the return stack,
                                                                          respectively.  On the return stack, the most significant cell
   ( 32-bit arithmetic)                                                   from T appears in I.                                         
: D+ ( d d - d)   MD I! >R  SWAP R> +  SWAP MD I@ +c ; ( 8)               These versions of the 32-bit relational, MAX , and MIN words 
: DNEGATE ( d - d)   SWAP NEGATE  SWAP -1 XOR  0 +c ; ( 6)             are of the "half-range local" variety.  That is, they behave as 
: D- ( d d - d)   >R >R  SWAP R> -  SWAP R> -1 XOR +c ; ( 9)           signed operators (-2,000 is less than 1,000) when the arguments 
                                                                       are within half of the range of the numbers (2,147,483,648).    
: D0= ( d - t)   OR 0= ; ( 6)                                             However,  2,000,000,000 is seen as less than -2,000,000,000  
: D< ( d d - t)   D-  SWAP DROP 0< ; ( 12)                             since decisions are based on a 2's complement signed difference.
: DABS ( d - d)   DUP 0< IF  DNEGATE EXIT  THEN ; ( 10,5)                                                                              
                                                                          Note that the prefix 'D' in general denotes operators whose  
: DMAX ( d d - d)   2OVER D-  DUP 0< IF  BEGIN  2DROP ;                arguments are signed, 32-bit integers.                          
: DMIN ( d d - d)       2OVER D-  DUP 0< UNTIL  THEN D+ ;                                                                              
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Mixed Arithmetic)                                                                                                                 
: M+ ( d n - d)   DUP 0< D+ ;  ( 11)                                   The prefix 'M' denotes mixed-precision operations, some of      
                                                                          whose arguments are 16-bit and some 32-bit.                  
: U/MOD ( du u - ur uq)   u/MOD SWAP ;                                                                                                 
: S/MOD ( d n - q r)   DUP 0< DUP >R IF  NEGATE >R  DNEGATE R>         M+  adds a signed single number to a double.                    
      THEN  -M/MOD  R> IF  NEGATE  THEN ;  ( 33-45)                    U/MOD  is an unsigned divide, divisor < 8001 hex.               
                                                                       S/MOD  is a floored, signed divide with consistent rem sign.    
: T* ( d n - t)   DUP 0< IF  NEGATE >R  DNEGATE R>  THEN                                                                               
   DUP >R  SWAP >R  U*  R> R> M*  >R +  R> 0 +c ;  ( 67-102)           T*  produces the 48-bit product of a signed 32- and 16-bit nos. 
: T/ ( t +n - d)   DUP >R -M/MOD SWAP  R> SWAP >R                         "d" may be hex 8000.0000 if & only if "n" is positive.       
      -M/MOD  DROP R> ;  ( 58-64)                                         "n" may be hex 8000 iff "d" is 8000.0000  All other args ok. 
: M*/ ( d n +n - d)   >R T*  R> T/ ;  ( 128-169)                       T/  requires a positive divisor.  This restriction, rarely in-  
                                                                          convenient in practice, gives substantial speed improvement. 
                                                                       M*/  is an mixed precision version of  */ , which allows a 32-  
                                                                          bit number to be multiplied by a ratio of 16-bit numbers with
                                                                          a 48-bit intermediate product, giving a precise 32-bit result
   ( Clock interrupt)   HEX                                               All arguments must comply with restrictions of  T*  and  T/ .
: ISR   100 t@ DROP  200 t@ DROP  TOCKS 0 @+                           The system reserves 32 cells starting at octal 40 for the chip's
   400 @CTR SWAP ND!  - 0 TICKS 2@ D+  TICKS 2! ;                         interrupt routine.  This block is an example of such a rout- 
                                                                          ine that has been tested.  It implements a clock interrupt   
H 2@  OCTAL 40 40 H 2!   HEX                                              assuming that the 68B40 is the ONLY source of INT signals.   
   ]  R> DROP  R> 1- >R  ISR  EXIT [   H 2!                            The first  R> DROP  in the routine disposes of the extra entry  
                                                                          on the return stack.  The phrase  R> 1- >R  corrects for the 
: TRY   R> DROP  0F I@ DUP 100 OR  0F I!  0F I!                           chip's error in formulating the return address.  ISR is the  
      [ STATUS 1+ @ ,C ] \\ ;  RECOVER  ( 6)                              definition that actually does the work; we compute coarse    
' TRY  STATUS 1+ !                                                        clock ticks since the last interrupt, maintain TICKS, and    
                                                                          save time of this interrupt in TOCKS.  Since we make the 6840
                                                                          happy, the interrupt goes away till the next coarse tick.    
                                                                                                                                       
                                                                       TRY  is an example of a safe method for enabling interrupts.    
                                                                          We build it into the round robin so that it will "poll" for  
                                                                          an interrupt each time around the loop at a cost of six added
( String & character operators)                                           clocks per PAUSE.                                            
: C+! ( n b)   DUP >R C@ +  R> C! ;                                       The words in this block are used by the  DISKING  utility and
                                                                       the Data Base Support System.  Otherwise they may be omitted    
: -TEXT ( a n a - t)   MD I!  1- FOR  1 @+ SWAP  MD I@                 from block 9 if you wish to conserve space.                     
      1 @+  MD I!  XOR IF                                              C+!  adds an 8-bit value to a byte whose address is given.      
         1- @  MD I@ R> DROP  1- @ U<  2* 1+ EXIT                      -TEXT  takes the address of two strings and a length and returns
   THEN NEXT  DROP 0 ;                                                    +1 if the 1st string has a higher ASCII value, -1 if it has  
: <TEXT ( a n a - t)   -TEXT 0< ;                                         a lower value and 0 (false) if they are equal.  Pronounced   
                                                                          "not-text".  Note cell address and count input!              
: TEXT ( n)   CORE 72 BLANK  WORD COUNT  CORE SWAP <CMOVE ;            <TEXT  is like -TEXT , but returns "true" if the first string   
                                                                          has a lower value, "false" otherwise.                        
: ?KEY ( - ~t)   256 U@  2 AND ;                                       TEXT  takes a delimiter and parses the input stream, moving the 
                                                                          string from  >IN  to the delimiter or the end of the string  
: QUERY   TIB 80 EXPECT  CNT @ #TIB !  0 DUP >IN 2! ;                     to  PAD .                                                    
                                                                       ?KEY  returns a nonzero value if a key has been struck.  May be 
                                                                          executed ONLY by tasks using straight serial terminals.      
( Editor extensions)   EDITOR DEFINITIONS                              QUERY  expects into TIB exactly as  QUIT  does.                 
: M ( b n)   DEPTH 2 - ABORT" Accidental "  2DUP M  1+ ;               This block is the place to add non-standard editor enhancements.
: f   F ;     : d   D ;     : i   I ;     : e   E ;                       Most of these commands are editor commands in lower-case.    
: p   P ;     : x   X ;     : u   U ;     : r   R ;                       They are particularly useful when editing shadow blocks or   
: s   S ;     : k   K ;     : m   M ;   ~ : till   TILL ;                 other text.  A few common system commands are included for   
~ : wipe   WIPE ;      FORTH DEFINITIONS      : t   T ;                   convenience.                                                 
: l   L ;     : n   N ;     : b   B ;     : q   Q ;                                                                                    
: list   LIST ;      : copy   COPY ;      : flush   FLUSH ;            +COPY  is like  COPY , but the associated shadow block is copied
: empty   EMPTY ;    : load   LOAD ;      : locate   LOCATE ;             as well.                                                     
: +COPY ( s d)   OVER SHADOWS CAST  OVER SHADOWS CAST                                                                                  
      COPY COPY ;      : +copy   +COPY ;                               QX  displays a shorthand index of the index page (60 blocks)    
: QX ( n)   PAGE  60 / 60 * 60 0 DO  I 21 /MOD  26 * TAB  DUP 5           in which the given block lies.  NX  and  BX  display the     
   U.R SPACE  DUP 9 < OVER BLOCK 2* 16 -TRAILING SWAP DROP 0= OR          next and previous index pages, respectively.                 
   0= IF  DUP BLOCK 2* 20 >TYPE  THEN 1+ LOOP SCR ! 20 53 TAB ;                                                                        
: NX   SCR @ QX ;      : nx   NX ;      : qx   QX ;                                                                                    
: BX   SCR @ 120 - 0 MAX QX ;      : bx   BX ;                                                                                         
   ( 32-bit output)                                                                                                                    
: /DIGIT ( d - d n)   0  BASE @  DUP >R  u/MOD                         Note that  #  and  #S  are the only numeric output words        
   SWAP R>  SWAP >R u/MOD  R> SWAP ;                                      that need to be recoded to handle 32-bit numbers.            
: # ( d - d)   /DIGIT  DIGIT HOLD ;                                                                                                    
: #S ( d - d)   BEGIN  #  2DUP D0= UNTIL ;                             ?DIGIT  divides the 32-bit integer on the stack by  BASE ,      
                                                                          leaving the 32-bit quotient and the remainder, a digit to    
: (D.) ( d - b n)   SWAP OVER DABS  <# #S SIGN #> ;                       be put in an output string by  # .                           
: D. ( d)   (D.) TYPE  SPACE ;                                         #  converts the next low-order digit for output, appending it   
                                                                          to the output string.                                        
                                                                       #S  converts all remaining significant digits for output.  Adds 
                                                                          at least one digit (0 if the number is zero) to the string.  
                                                                                                                                       
                                                                       (D.)  converts a 32-bit signed integer for output, leaving the  
                                                                          address and length of the string as arguments for  TYPE .    
                                                                       D.  converts and types a 32-bit signed integer.                 
                                                                                                                                       
   ( 32-bit input)                                                                                                                     
: *DIGIT ( d b n - d b)   SWAP >R >R  BASE @ *                         The rules governing 32-bit numeric input are discussed at       
   R> SWAP >R >R  BASE @ U*  R> SWAP >R  +  R> R> +c  R> ;                length in Starting FORTH and other documentation.            
                                                                       Note that upon completion of input number conversion the number 
~ : CONVERT ( d b - d b)   BEGIN  ?DIGIT WHILE                            of digits to the right of the rightmost punctuation in a 32- 
      *DIGIT  1 PTR +!  REPEAT ;                                          bit number is given in  PTR .  PTR is negative if there was  
: (NUMBER) ( b - n | d)   -1025 PTR !  DUP 1+ C@  45 =                    no punctuation (e.g., a 16-bit result).  The high-order part 
   DUP >R -  0. ROT BEGIN  CONVERT DUP C@  DUP 44 48 WITHIN               of an unpunctuated number is left in  'NUMBER 1+  in case the
      SWAP 58 =  OR WHILE  0 PTR !  REPEAT  C@ 32 - ABORT" ?"             user wants to use it, allowing unpunctuated 32-bit numbers,  
   R> IF  DNEGATE  THEN  PTR @ 0< IF  'NUMBER 1+ !  THEN ;                or check it to prove that the number didn't overflow 16 bits.
                                                                                                                                       
' (NUMBER)  'NUMBER !                                                  *DIGIT  shifts the digit value on top of the stack into the 32- 
                                                                          bit number according to the current  BASE .                  
                                                                       CONVERT  shifts digits starting at  b+1  into the 32-bit number,
                                                                          returning the address of the first non-digit encountered.    
                                                                       (NUMBER)  converts a string whose count byte address is given to
   ( Misc. extensions)   OCTAL                                            binary, leaving a 16- or 32-bit number depending on punctuat.
: ARRAY   CREATE  144742 USE ;   DECIMAL                               ARRAY  defines an array of cells that executes by converting a  
: MSG   CREATE  DOES>   COUNT TYPE ;                                      0-relative cell index to an address in its parameter field.  
: Lo ( n - n)   255 AND ; ( 4)                                            Parameter space must be ALLOTted or initialized explicitly.  
: Hi ( n - n)   6 DO( 2/ )  Lo ;  ( 13)                                MSG  names a counted string that is TYPEd when executed.        
: Up ( n - n)   6 DO( 2* ; ( 11)                                       Lo  and  Hi  extract low and high bytes of a number respectively
: >< ( n - n)   DUP Hi  SWAP Up OR ;                                   UP  multiplies a number by 256.                                 
: TALLY ( a)   0 @+  SWAP 1+  SWAP ! ;                                 ><  swaps the bytes of the 16-bit word on top of the stack.     
: WFILL ( a n)   FILL ;                                                TALLY  adds 1 to the 16-bit number in the address given.        
: FILL ( b n c)   SWAP 1- >R  SWAP BEGIN                               WFILL  is a cell string operator; FILL is byte oriented.        
      2DUP C!  1+ NEXT  2DROP ;                                        ASSIGN  provides a facility for giving behavior to a vectored   
: ASSIGN   R> 32767 AND  SWAP ! ;                                         execution variable.  The usage is like this:                 
                                                                          : name  ASSIGN  desired behavior ;  variable name            
: !STACK   JK I@ 1+ 255 AND  S0 ! ;   !STACK   FORGET !STACK              The behavior can be performed by:   variable @ EXECUTE       
: DEPTH ( - n)   JK I@  S0 @ -  255 AND  -128 XOR  129 + ;             DEPTH  returns the number of cells on the stack, +/-128; this is
: ?STACK   DEPTH 0< ABORT" Stack empty" ;   ' ?STACK 'ST !                appropriate only for terminal tasks with private stacks.     
( Background tasks)                                                    ?STACK  defines a stack empty test for the interpreter.         
: HIS ( a a - a)   STATUS -  SWAP @ + ;                                BACKGROUND  makes a construct table for a background task given 
                                                                          its user area size, JK stack base, and stack select (0-7).   
: BACKGROUND ( u jk k)   CREATE  HERE 3 + ,  4 * , ,  ALLOT ;          The version of  BACKGROUND  given in this block are for         
: BUILD ( a)   DUP \\ @ >R  STATUS 2@ I 2!  I STATUS 1+ !                 resident applications only.  For an application which is     
      1+ 2@  R> 3 + 2! ;                                                  to be target compiled, it must be preceded by  FORTH  in     
                                                                          order to make it a  HOST  definition.  BUILD , on the other  
: ACTIVATE ( a)   @  STATUS 3 + @  MD I!  JK I@  SR I!                    hand, must be in the target dictionary, and is normally      
   WAKE OVER !  4 +  2 @- 0 !+  1 @+ @  -1 ! JK I!                        executed as part of the start-up initialization code.        
      DROP R>  R> DROP  >R >R  SR I@  MD I@  -1 ! JK I!                                                                                
   DROP DROP R> DROP ;                                                 The usage of the word  HIS is:  task  user-variable  HIS        
                                                                          NOTE that it doesn't work with TIB.                          
                                                                                                                                       
                                                                       ACTIVATE  starts a task whose address is given executing the    
                                                                          remainder of the colon definition in which  ACTIVATE  occurs.
                                                                          Note that this code must end in  STOP ,  QUIT (for a terminal
   ( Terminal tasks)                                                      task) or in an infinite loop.                                
: TERMINAL ( dev jk k n)   CREATE  26 LOAD ;                              The version of  TERMINAL  given in this block is for         
: CONSTRUCT ( a)   STATUS OVER @ 128 MOVE  DUP BUILD                   resident applications only.  For an application which is        
      DUP 3 +  OVER 'IDLE HIS 5 MOVE                                   to be target compiled, it must be preceded by  FORTH  in        
      DUP 8 +  SWAP DEVICE HIS 10 MOVE ;                               order to make it a  HOST  definitions.  CONSTRUCT ,             
                                                                       on the other hand, must be in the target dictionary, and is     
: PROMPT ( a)   ACTIVATE  DISK RELEASE                                 normally executed as part of the start-up initialization code.  
      EMPTY  SYSTEM  ABORT ;   RECOVER                                    For target applications with  TERMINAL  tasks, copy the      
                                                                       method of initializing  OPERATOR  in this system (blocks 106, 7)
: SEND ( a)   TIB CELL  2DUP HIS 40 MOVE                               to avoid the need for disk source as in block 25, although      
   OFFSET 1- 2DUP HIS 3 MOVE  >IN  2DUP HIS                            the latter is more flexible in resident applications.           
      [ WIDTH >IN - ] LITERAL MOVE  >IN @ #TIB !                                                                                       
   ACTIVATE  DISK RELEASE  >IN 2@ INTERPRET  ABORT ;  RECOVER          PROMPT  starts a terminal task awaiting input.                  
                                                                                                                                       
: >R ( n)   R> SWAP  >R >R ;                                           SEND  sends the rest of the current input stream to             
: R> ( - n)   R> R> SWAP  >R ;                                            another task for interpretation.                             
   ( Terminal parameters)   FORTH   DECIMAL                            Configured for 128-cell user areas.                             
( device jk k size TERMINAL name)                                         Refer to block 76 and the Processor Supplement for a map     
                                                                       of the  USER  variables initialized here.                       
   HERE 1 +  ( dictionary) DUP >R  OVER + ( STATUS) DUP >R ,              The arguments on the stack when this block is entered are:   
      ( k, S0) ROT ROT 4 * , ,                                               ( top)  The size of the entire terminal partition         
                                                                                     The stack select value (0-7) to use               
   ' QUIT ,  1 ( LIVE) ,  R> R> DUP ( H) , , ,                                       The stack base index rrss to use                  
   SWAP ( DEVICE) ,  ' emit ,  ' (TYPE) ,  ' (CR) ,  ' (PAGE) ,                      The device identifier for the task                
   ' (TAB) ,  ' (MARK) ,  ' (CLEAN) ,  ' key ,  ' (EXPECT) ,                                                                           
                                                                          This block is a good example of the use of interpretive      
   17 ( tdb) -  128 ( user) + ALLOT                                    execution to perform non-time critical and infrequently used    
                                                                       procedures.                                                     
                                                                                                                                       
                                                                       If you change the size of the OPERATOR's user area in block 9,  
                                                                          you will need to pay attention to the first MOVE in CONSTRUCT
                                                                          and the user area size in this block potentially.            
   ( Terminals)                                                                                                                        
(  Device rrss k  Mem          Name)                                   This block is an example of simple task creation.               
HEX  0000 0001 1 1000 TERMINAL SECOND   SECOND CONSTRUCT                                                                               
   DEVICE @  0 DEVICE !  9600 BAUD  DEVICE !                           The  BURNER  example makes a terminal task to operate the PROM  
                                                                          burner, at 9600 baud.                                        
EXIT                                                                   The  SECOND  example makes a terminal task for a second user    
HEX  0000 0001 1 1000 TERMINAL BURNER   BURNER CONSTRUCT                  on the system, at 19.2 Kbaud.                                
   DEVICE @  0 DEVICE !   9600 BAUD  DEVICE !                          Either task will use the second USART on the Beta Board, and    
                                                                          will have 4k cells of dictionary.  It will use stack 1       
                                                                          (the operator uses stack 0) and, if PROMPTed, will come up   
                                                                          configured as a glass TTY type terminal.                     
                                                                                                                                       
                                                                       It is customary to define tasks during the process of loading   
                                                                          block 9 and to PROMPT them or assign other desired work if   
                                                                          relevant at the end of block 9.                              
                                                                                                                                       
   ( Serial printer)                                                                                                                   
(  Device rrss k  Mem          Name)                                      The simple printer driver in this block uses the second USART
HEX  0000 0001 1 1000 TERMINAL TYPIST   TYPIST CONSTRUCT               on the Beta board.  BAUD  specifies its baud rate and sets the  
   DEVICE @  0 DEVICE !  19200 BAUD  DEVICE !                          chip up for 8-bit no parity 1 stop bit async.                   
                                                                                                                                       
: /PAGE/   C# 2@ OR IF  12 EMIT  THEN ;                                   This block uses a 'facility variable' and  GET/RELEASE to    
' /PAGE/  TYPIST 'PAGE HIS !   ' ABORT  TYPIST 'EXPECT HIS !           prevent conflicting use of the printer.  If a user sends a      
' STOP  TYPIST 'IDLE HIS !                                             command to the printer while it is responding to someone else's 
                                                                       request, the second user's task will wait until the printer is  
VARIABLE PRINTER                                                       ready.                                                          
: PRINT   PRINTER  DUP RELEASE  @ ABORT" Not available"                                                                                
      PRINTER GRAB  TYPIST SEND ;                                         This is a paper conserving driver;  PAGE  does not move paper
: OK   PAGE CR PAGE  0 PRINTER ! ;                                     unless something has been printed on the current page.  This is 
                                                                       convenient since most listings begin by saying  PAGE .  Consider
                                                                       PAGE  to mean "I want a clean sheet".  See the definition of  OK
                                                                       for an example of intentional blank paper ejection.             
   ( HP2686A Laser Printer)   VARIABLE PRINTER                                                                                         
(  Device rrss k  Mem          Name)                                      The simple printer driver in this block uses the second USART
HEX  0000 0001 1 1000 TERMINAL TYPIST   TYPIST CONSTRUCT               on the Beta board.  BAUD  specifies its baud rate and sets the  
   DEVICE @  0 DEVICE !  19200 BAUD  DEVICE !                          chip up for 8-bit no parity 1 stop bit async.  It specifically  
: PRINT   PRINTER  DUP RELEASE  @ ABORT" Not available"                supports the H-P LaserJet printer.  Additional support for this 
      PRINTER GRAB  TYPIST SEND ;                                      printer may optionally be loaded as part of the PRINTING utility
: OK   PAGE ( CR PAGE)  0 PRINTER ! ;      HEX                                                                                         
                                                                          This block uses a 'facility variable' and  GET/RELEASE to    
: /SLEEP/   BEGIN STOP  AGAIN ;  RECOVER                               prevent conflicting use of the printer.  If a user sends a      
: .HP ( n)   ?DUP IF  BASE @ SWAP  (.) TYPE  BASE !  THEN ;            command to the printer while it is responding to someone else's 
: +ESC ( n cc)   100 /MOD EMIT  SWAP .HP  EMIT ;                       request, the second user's task will wait until the printer is  
: ESC ( n cc)   1B EMIT  26 EMIT  +ESC ;                               ready.                                                          
: /PAGE/   C# 2@  0 6C65 ESC 0 6C4C +ESC  OR IF 0C EMIT  THEN ;           This is a paper conserving driver;  PAGE  does not move paper
: /TAB/ ( l c)   6163 ESC  2 + 6152 ESC ;                              unless something has been printed on the current page.  This is 
' /PAGE/  TYPIST 'PAGE HIS !  ' /SLEEP/  TYPIST 'IDLE HIS !            convenient since most listings begin by saying  PAGE .  Consider
' /TAB/  TYPIST 'TAB HIS !  0. TYPIST C# HIS 2!                        PAGE  to mean "I want a clean sheet".  See the definition of  OK
( Calendar - days since Sunday, 12/31/1899)                            for an example of intentional blank paper ejection.             
ARRAY mth  0 , 0 ,  31 , 59 , 90 ,  120 , 151 , 181 ,  212 ,              This calendar is appropriate for applications in which       
   243 , 273 ,  304 , 334 , 367 ,      365 4 * 1+ CONSTANT D/Y         dates entered are distributed over many years (birthdays, etc.).
: MTH ( n - a)   mth @ ;                                                                                                               
: M/D/Y ( d - n)   100 U/MOD SWAP >R  100 /MOD MTH 31 OVER < IF           This version requires 32-bit input number conversions, as the
   I 3 AND 0= - THEN +  R> 3 + D/Y 4 */MOD SWAP DROP + 1096 - ;        dates are originally entered in the form   mm/dd/yy   (a 32-bit 
: NOW ( m/d/y)   M/D/Y  TODAY ! ;                                      number).                                                        
: Y-MD ( n - y n n)   4 D/Y */MOD  SWAP 4 /MOD 1+                                                                                      
   DUP ROT 0= IF  DUP 60 > +  SWAP DUP 59 > +  THEN ;                                                                                  
: M-D ( n n - m d)   1 BEGIN  1+  2DUP MTH > 0= UNTIL  1-                                                                              
   SWAP DROP SWAP  OVER MTH - ;                                        To set the date:    12/27/82 NOW                                
: (DATE) ( n - a n)   Y-MD  ROT 0 <#  # #  2DROP  47 HOLD              To type the date:   TODAY @ .DATE  (responds) 12/27/82 ok       
   M-D 0 # #  2DROP  47 HOLD  0 #S  #> ;                                                                                               
: .DATE ( n)   (DATE) TYPE SPACE ;                                        The date is stored as a 16-bit count of days since Sunday,   
: DATED ( n)   HELPS  TODAY @ ?DUP IF  .DATE                           December 31, 1899.  Conversions are valid from 1 March 1900 thru
      ELSE  ." not entered yet. "  THEN ;                              the 21st century.                                               
   ( MC6840 clock, 1 MHz)                                              DATED  produces a dated help screen (see  SYSTEM ).             
TODAY 1+ CONSTANT TICKS   TICKS 2 + CONSTANT TOCKS                     This block initializes the timer chip on the Beta board for the 
6 ( MHz xtal)  8 2CONSTANT T/US   HEX                                     purposes of a high resolution interval timer and low frequen-
: t@ ( n - c)   D000 OR  DUP 4000 XOR  OVER D001  0 !+                    cy day clock.  Counter 3 runs with period of 32k, increments 
      DUP MD I!  1 !-  @  MD I@!  !  MD I@ 0FF AND ;                      ctr 2 at period of 64k.  Counter 1 free runs with period of  
: t! ( c n)   OR  5000 OR  DUP 4000 XOR  OVER D001                        64k.  The output of ctr 1 LEADS counter 3 by about 24 clocks 
      0 !+  0 !+  ( NOP) ! ;                                              as it's nominally initialized.  The actual lag varies due to 
: +CLOCK   1 100 t!  1 0 t!  C0 0 t!  80 100 t!  80 0 t!                  clk/8 quantization; the spin in COUNTER combats this at some 
      FF DUP 400 t! 500 t!  FF 700 7F 600 FF 300 OVER 200                 unsatisfying expense in time.  Measure tare before using!    
   t! t! t! t!  -1 TOCKS ! ;   +CLOCK                                  T/US  documents the clock frequency of the Beta board.  The num-
                                                                          erator is clock frequency in MHz; denominator is 8 to account
: @CTR ( n - n)   DUP t@ Up  SWAP 100 + t@ + ;                            for clock prescale.  Ratio is in ticks per microsecond.      
: COUNTER ( - d)   BEGIN  400 @CTR  200 @CTR SWAP                      +CLOCK  initializes the chip.  C0 to reg 0 enables interrupt.   
      17 FOR NEXT  400 @CTR OVER - WHILE  2DROP REPEAT ;                                                                               
: TIMER ( d)   COUNTER D-  T/US SWAP M*/ D. ;                          COUNTER  leaves the current time on the stack as a 32-bit number
                                                                       TIMER  displays the interval since the time on the stack in uS. 
   ( 65.536 ms Clock)                                                     Intervals as long as 1:10 hrs are measurable at 8 MHz.       
125  8192 T/US SWAP */  2CONSTANT T/MS                                 This coding, together with the interrupt routine for the Beta   
86,400,000 T/MS M*/ 2CONSTANT T/DAY                                       board, provides a day clock with resolution of 65.536 ms on  
                                                                          an 8 MHz machine (larger with slower CPU's).  TICKS is time  
: @TIME ( - d)   T/DAY TICKS 2@  BEGIN  2OVER D-                          since midnight in these units.  TOCKS is last high order     
      DUP 0< 1+ WHILE  1 TODAY +!  REPEAT  D+  2DUP TICKS 2! ;            counter value read, used by interrupt code.  You must load   
: (TIME) ( n)   0 <# #  6 BASE ! #  58 HOLD  DECIMAL # #  #> ;            block 18 if you want this day clock to operate continuously. 
: .TIME ( d)   T/MS SWAP M*/  30000 U/MOD 2/                              If clock is interrogated frequently the interrupt isn't vital
      (TIME) TYPE SPACE  DROP ;                                        T/MS  is a ratio of high order clock ticks per millisecond.     
: PST ( hh:mm)   100 U/MOD 60 * +  60000 U* T/MS M*/ TICKS 2! ;        T/DAY  is the number of ticks per day.                          
                                                                       @TIME  returns the current time of day in ticks and handles the 
: MS ( n)   1000 U*  T/US M*/  COUNTER 2SWAP D-                           date roll-over at midnight.  It will run for several days    
   BEGIN PAUSE  COUNTER 2OVER D< UNTIL  2DROP ;                           without having to be queried.                                
                                                                       If you do not live in the Pacific Standard Time zone you will   
                                                                          want to change the name of  PST  accordingly.  Feel free to  
                                                                          do so; it isn't used in a routine anywhere except by you.    
( Disk errors w/abort)                                                 The word  MS  delays about n milliseconds.                      
: -ER   0 DISK 1+ ! ;                                                  This block supports disk error detection in a device indepen-   
: .ERR ( d - 1)   DISK RELEASE  DISK 1+ @ >R  U. U.  R> U.  1 ;           dent manner. It is affected by changes in the buffer manager,
                                                                          however, such as 32-bit id's, IDENTIFY, (BUFFER) etc.        
: /BUFFER/   -ER  (BUFFER)  DISK 1+ @ IF  'BUFFER 1+ 2@                                                                                
      2DUP 0 ESTABLISH DROP  .ERR ABORT" Write error"  THEN ;          /BLOCK/ & /BUFFER/ must act the same as (BLOCK) & (BUFFER).     
                                                                          Note that they abort for unrecovered errors and must be      
: /BLOCK/   -ER  (BLOCK)  DISK 1+ @ IF  PREV @ 2@                         bypassed when doing a SWEEP. When they abort, /BLOCK/ leaves 
      -1 PREV @ !  .ERR ABORT" Read error"  THEN ;                        the block unread, while /BUFFER/ preserves buffer unupdated. 
                                                                                                                                       
' /BUFFER/ ' /BLOCK/ 'BLOCK 2!                                         Recovery is not bothered with here due to the nature of the disk
                                                                          subsystems we have:  In the case of SCSI, we normally enable 
                                                                          all of the recovery capabilities of the controller, while in 
                                                                          the case of the host computer support we presumably have the 
                                                                          full benefit of its disk I/O error recovery.  In either case 
                                                                          if we detect an error SOMEONE has retried the operation ad   
   ( Make Buffers)   DISK 1+ ?   0 DISK 1+ !                              nauseam, so there's little point to hassling it further.     
: TH ( n - a)   4 * PREV + 2 + ;                                       This block elaborates the buffer pool unless it has survived    
: LINK ( a n - a)   TH  SWAP OVER 2 + ! ;                                 from a previous boot of the system.                          
                                                                                                                                       
: BUFFERS ( n)   4 ( maximum) MIN 1-  PREV 1+ @ 1-  ?DUP IF            The first value appearing in the definition of  BUFFERS  is     
      OVER - ABORT" unmatched"                                            the maximum number of additional buffers for which space has 
         DUP >R  NB +!  0 BEGIN  I LINK NEXT                              been allocated in the target compilation.  The argument to   
   ELSE  DUP >R  NB +!  0 BEGIN  I LINK  -1 OVER !                        BUFFERS  is the total number of buffers you want to have.    
      I 512 * NB 1+ @ +  OVER 3 + !  NEXT  THEN PREV ! ;                  The argument to  BUFFERS  and the first literal within its   
                                                                          definition should be adjusted whenever  #BUF  is changed in  
4 ( total) BUFFERS   FORGET TH                                            block 61.                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Disk formatting)   HEX                                                                                                            
: 8-SEC   DISK GET  CONFIGURATION  0 C200 0 SCSI  0 100 0 SCSI         The words in this block should be used with considerable caution
   5 + 0 C040 088B SCSI  0 C240 0 SCSI  DROP  DISK RELEASE ;              since they are capable of eradicating great quantities of    
: 9-SEC   DISK GET  HOME  DISK RELEASE ;                                  disk space.  Remember that formatting a disk is tantamount   
: 10-SEC   DISK GET  CONFIGURATION  0 C200 0 SCSI  0 100 0 SCSI           to changing media, so you should always FLUSH before doing so
   5 + 0 C040 0A8B SCSI  0 C240 0 SCSI  DROP  DISK RELEASE ;           INITIALIZE  formats a floppy disk according to the structure    
                                                                          that's currently in use.  Default is 9 256-byte sectors in   
CREATE INTERLEAVE  500 ,                                                  each of the 40 tracks on each side of the disk, for a total  
: FMT   DISK GET  SCSI DROP  DISK RELEASE                                 of 360 blocks.  The interleave is optimized for our hardware.
   STS @ ABORT" Format error " ;                                       8-SEC  configures the controller for floppies with 8 sectors per
: INITIALIZE   PAD 0 0440 INTERLEAVE @ FMT ;                              track.  9-SEC  returns to the normal format.                 
                                                                                                                                       
: Format   ." the hard disk? " KEY 59 - ABORT" Killed."                Format  formats the ENTIRE hard disk.  Since this is such a     
      PAD 0 0400 0100 FMT ;                                               major event, we solicit the operator and require input of the
: 1TRACK ( n)   PAD SWAP 0600 0100 FMT ;                                  character "Y" before proceeding.                             
: ALTERNATE ( s d)   100 U* PAD 2!  PAD SWAP 0E00 0100 FMT ;           1TRACK  formats a single track whose ABSOLUTE block # is given. 
( Disk Utility)   DECIMAL   EMPTY                                      ALTERNATE  assigns block "d" as alternate for block "s".        
: HELP   38 HELPS ;   HELP   720 CONSTANT VOLUME                       FLOPPY  is the starting point of the floppy from the point of   
10800 CONSTANT FLOPPY   11520 CONSTANT LSI   37 LOAD  35 LOAD             view of  0 DRIVE .                                           
                                                                       BLOCKS  copies a given number of blocks from a source to a      
: BLOCKS ( s d n)   0 DO  I NB @ MOD  0= IF FLUSH  THEN                   destination.  Note that for this purpose all drives are      
      OVER I +  OVER I + COPY  LOOP  2DROP FLUSH ;                        considered to be a single, contiguous range of blocks.       
: <BLOCKS ( s d n)   FLUSH  0 SWAP 1- DO  OVER I + OVER I + COPY       <BLOCKS  is the same as  BLOCKS  except that the LAST block in  
      I NB @ MOD  0= IF FLUSH  THEN -1 +LOOP  2DROP ;                     the range is copied first.                                   
: +BLOCKS ( s d n)   >R  OVER SHADOWS CAST                             +BLOCKS  copies corresponding shadows along with source.        
      OVER SHADOWS CAST  I BLOCKS  R> BLOCKS ;                                                                                         
                                                                       RANGE  takes a range of block numbers (exclusive at the top)    
: RANGE ( l h - s d n)   OVER -  OVER VOLUME +  SWAP ;                    and returns arguments in the form "source, dest, count"      
: UP ( l h)   2DUP RANGE BLOCKS  ." Match "  RANGE MATCHES ;           UP  moves a range of blocks from the current logical drive to   
: BACKUP   0 DRIVE  0 VOLUME UP ;                                         the next higher one.                                         
                                                                       BACKUP  copies all blocks from drive 0 to drive 1.              
( Matching)  153 154 THRU                                                 Note that  RIGHT  and  BACKUP  automatically  MATCH  the     
   ( Disk diagnostic)                                                  blocks copied, to check for copy errors, but  BLOCKS  does not. 
: -ERR   ['] (BUFFER)  ['] (BLOCK) 'BLOCK 2!  0 DISK 1+ !              -ERR  disables all error recovery and reporting facilities, both
   CONFIGURATION 10 + DUP 2@  192 OR SWAP 192 OR SWAP  ROT 2! ;           in the disk controller and in the system.                    
: +ERR   [ 'BLOCK 2@ SWAP ] LITERAL LITERAL 'BLOCK 2!                  +ERR  re-enables them.                                          
   CONFIGURATION 10 + DUP 2@                                           SWEEP  is a read-only diagnostic that tests a range of blocks   
      -256 AND SWAP  -256 AND SWAP  ROT 2! ;                              reporting any read errors (including correctable ones!) that 
: SWEEP ( f l)   -ERR  OVER - 1- FOR  DISK GET  -ERR                      were encountered.                                            
      DUP BLOCK DROP  +ERR  DISK 1+ @  ?DUP IF 0 DISK 1+ !                                                                             
   CR OVER . ." Error " HEX U.  DECIMAL  THEN 1+ NEXT  DROP ;          MATCHES  compares a group of blocks, given two starting block   
                                                                          numbers and a count.                                         
: ?CR   C# @ 70 > IF  CR  THEN ;                                                                                                       
: MATCHES ( s d n)   CR 1- FOR  OVER BLOCK HERE 512 MOVE               OBLITERATE  blanks a range of blocks.                           
      DUP BLOCK 512 HERE -TEXT IF  ?CR OVER .  THEN                                                                                    
   1+ SWAP 1+ SWAP  NEXT  2DROP ;                                                                                                      
: OBLITERATE ( f l)   SWAP DO                                                                                                          
      I BUFFER 2* 1024 BLANK  UPDATE LOOP  FLUSH ;                                                                                     
HELP             Displays these  DISKING  instructions                                                                                 
INITIALIZE       Formats a new 360-block floppy.                          This is the disking help screen.  Feel free to change it if  
Format           Formats the hard disk (caution!)                      you add or change words in  DISKING .                           
BACKUP           Copies all of drive 0 to 1 (720 blocks)                                                                               
s d n BLOCKS     Copies  n  blocks from  s  to  d                                                                                      
s d n +BLOCKS    Same, but copies shadows as well.                                                                                     
s d n <BLOCKS    Like  BLOCKS , but copies last blocks first.                                                                          
l h SWEEP        Checks blocks  l to h  for read errors                                                                                
s d n MATCHES    Matches  n  blocks between  s  and  d .                                                                               
s d MATCHING     Sets starting blocks for visual matching.                                                                             
                   Defaults are  0  720 .                                                                                              
V                Shows differences between current and other.                                                                          
W                Shows other with differences from current.                                                                            
O                Shows other without differences.                                                                                      
G                Shows next block with differences limit:  n TO                                                                        
GIVE  and  TAKE  copy current to and from the other respectively                                                                       
( Program Documentation)   EMPTY   DECIMAL                                                                                             
: HELP   41 DATED  @TIME .TIME ;   HELP                                   This utility is designed to produce program listings.        
: LINE ( n n)   BLOCK 2* +  64 -TRAILING >TYPE ;                       Its use is documented in its help screen.                       
: VISIBLE ( n - t)   BLOCK 2* 16 -TRAILING  SWAP DROP ;                   A number of options are provided.  The simplest is single-   
: C   ."    FORTH, Inc. Proprietary   "                                sided output.  Alternatively, the program may print blocks      
   TODAY @ .DATE  SPACE  @TIME .TIME  960 39 LINE  CR ;                on both sides of the paper, or may print the program on one     
                                                                       side and the corresponding "shadow blocks" on the facing page.  
: INDEX ( f l)   DUP ROT DO  PAGE CR ( CR)  DUP I 60 + MIN  I DO          The procedure for obtaining double-sided output is given in  
      CR  I 10 U.R SPACE  7 I < IF  I VISIBLE IF  0 I LINE             the next two blocks.                                            
   THEN THEN LOOP  CR CR  C  60 +LOOP DROP ;                              The optional sextet utility is for the H-P LaserJet printer. 
: TRIAD   ( 9 MAX)  PAGE CR CR CR ( CR)  3 / 3 *  DUP 3 +                 To change the line at the bottom of each page, modify  C  or 
   SWAP DO  I 7 U.R ."  LIST"  CR  I VISIBLE IF                        line 15, whichever is easiest.                                  
         I  16 0 DO  CR  I 10 U.R SPACE  I 64 * OVER LINE  LOOP           INDEX  can safely be started at block 0 (it prints blanks for
      DROP 3  ELSE 19  THEN  0 DO  CR LOOP  LOOP  C ;                  blocks 0-8).  It's good to begin major applications on 60 block 
( Double-sided)  40 LOAD   ( Sextets  150 151 THRU)   EXIT             boundaries, so  INDEX  prints 60 lines to a page.  Load blocks, 
  nF/NC4000Pb  Release 1    STAND ALONE                                and blocks beginning a series of blocks, should not have        
   ( Shadow block/double-sided output)                                 their comment on line 0 indented.                               
: PRESENT ( n n - t)   OVER /  OVER *                                  To obtain a listing with program block on both sides of the     
      2DUP + SWAP DO  I VISIBLE NOT +  LOOP ;                             paper, follow this procedure:                                
                                                                       1.  Make sure that there is at least one blank sheet of paper   
: SHOW ( f l)   SWAP  3 / 3 * DO  3 I PRESENT IF                          past the print head in your printer.  This is normally the   
      I TRIAD  THEN 3 +LOOP ;                                             case if you use 'OK' at the end of all print commands.       
: SHADOW ( f l)   SWAP  3 / 3 * DO  3 I PRESENT IF                     2.  Type:  l h FRONT   using the total range of blocks you wish 
      I SHADOWS CAST TRIAD  THEN 3 +LOOP ;                                to list.  This will print every other triad, on the side of  
                                                                          the paper you will have on the right in your notebook.       
: FRONT ( f l)   SWAP  6 / 6 * DO  6 I PRESENT IF                      3.  Space the paper up at least one page so you have a blank    
      I TRIAD  THEN 6 +LOOP ;                                             page or two at the end.  Then remove the paper from the      
: BACK ( f l)   SWAP  6 / 6 * DO  6 I PRESENT IF                          printer.                                                     
      I 3 + TRIAD  THEN 6 +LOOP ;                                      4.  Turn the paper over and insert it so that the top of the 2nd
                                                                          page preceding the back of the first page of listing is under
                                                                          the print head.  This is because the paper will space up one 
                                                                          page before starting to print, and you want the first "left" 
HELP             Displays these  PRINTING  instructions                   on the back of the blank page before your listing.           
                                                                       5.  Type:   l h BACK  using the same block range as before to   
l h INDEX        Displays an index of blocks  l to h-1                    print the left sides of your paper.                          
                                                                                                                                       
l h SHOW         Lists all triads containing blocks  l to h-1          The procedure for printing listing with shadow blocks on the    
l h SHADOW       Lists "shadow" blocks corresponding to  SHOW          left side is the same, except for these steps:                  
n TRIAD          Displays the triad constaining block  n               2.  Instead of the command  FRONT , use:   l h SHOW  to         
                                                                          the program in the usual manner.                             
l h FRONT        Lists blocks on front side of paper                   5.  When the listing is finished and the paper turned, type:    
l h BACK         Lists blocks on back                                     l h SHADOW   using the same block range as for  SHOW  to     
                                                                          print the shadow blocks.                                     
To route output to printer, preface commands by  PRINT                 This procedure was followed to obtain this listing.             
Terminate command string by  OK  to space up paper                                                                                     
   ex.:   PRINT 0 180 INDEX OK                                         The procedure becomes somewhat simpler on printers for which we 
                                                                       support the paper conserving version of PAGE; terminate each    
Listings will be dated                                                 listing you print with OK, and in this way there will be no need
( Target testing)   EMPTY   DECIMAL                                    to plan on allowing for paper spacing before first pages print. 
0 CONSTANT NEW   : HELP   43 LIST ;   HELP   OCTAL                     This simple utility tests target-compiled programs.             
                                                                       NEW is the block in which target code starts.  It is presumed   
: SLAM   NEW 70000  7 FOR  OVER BLOCK OVER 1000 MOVE                      that 8 blocks of code exist.  This constant must agree with  
      SWAP 1+  SWAP 1000 +  NEXT  2DROP ;                                 its version in COMPILER.                                     
                                                                                                                                       
: TRY   ['] RELOAD 20000 > ABORT" only ok running from ROM"            SLAM  copies blocks 0-8 into the RAM test area at 70000.        
      SLAM  FLUSH  0 0 NB 2!  [ 70000 ,C ] ;                                                                                           
: PROM   0 0 NB 2!  [ 10000 ,C ] ;      DECIMAL                        TRY  moves the new program into RAM and activates its reset     
                                                                          coding.                                                      
: SAVE   7 FOR  I  I 360 + COPY  NEXT FLUSH ;                                                                                          
                                                                       SAVE  makes a backup of the new program.                        
EXIT                                                                                                                                   
: >MOVE< ( s d n)   1- FOR  OVER I + @  400 /MOD                                                                                       
      SWAP 400 * +  OVER I + !  NEXT  2DROP ;                                                                                          
                                                                                                                                       
HELP           Displays these target TESTING instructions                                                                              
               New programs are compiled to blocks 0-8                 This is the target testing help screen.  Feel free to change it 
                                                                       when you reconfigure the system.                                
TRY            Copies the new program into RAM at 70000,                                                                               
                  jumps to its reset entry point.                                                                                      
               Executable before  9 LOAD .  However NOT usable                                                                         
               while running under a TRY'd system.                                                                                     
                                                                                                                                       
PROM           Jumps to system PROM's reset entry point.                                                                               
                                                                                                                                       
SAVE           Saves a copy of the new program in 360-368.                                                                             
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Exhaustive redefinition check)   EMPTY   DECIMAL                                                                                     
: -FOUND ( - a t | p a f)   [ ' -'  5 + ,C ] ;                         This version of  ?CREATE  deals with all the hidden flaws in the
: AHEAD   >IN @  32 WORD DROP  >IN ! ;                                    premise of 31-character names.                               
: +T   HERE DUP @ Hi WIDTH @ Hi MIN 2/ +  DUP @ 128 OR SWAP ! ;        ... May redefine   indicates that the new word may hide another 
: HUNT ( n n - t)   STATE !  HERE SWAP -FOUND 0=  DUP >R IF               in one of the interpreting vocabularies in CURRENT.          
      DROP  THEN DROP  R> STATE @ IF  TODAY 1- @ 1 AND AND  THEN       ... May redefine immed   indicates that it may hide another     
   DUP IF  CR AHEAD HERE COUNT TYPE SPACE  THEN -COMPILE ;                in one of the IMMEDIATE vocabularies in CURRENT.             
: RDF ( n)   ." May redefine "  IF ." immed "  THEN ;                  ... Buried?   indicates that unless the new word is IMMEDIATE,  
: ?CREATE   AHEAD  CURRENT @ 15 AND 1 HUNT IF  ." Buried? " THEN          it may not be used in a colon definition since there is an   
   CURRENT @ 0 HUNT IF  0 RDF  ELSE                                       IMMEDIATE word in the first vocabulary searched that will be 
      +T  CURRENT @ 0 HUNT IF  0 RDF  THEN  THEN  AHEAD                   found first.                                                 
   CURRENT @  BEGIN  16 /MOD SWAP  ?DUP WHILE  1 HUNT IF                                                                               
      1 RDF DROP <CREATE> EXIT  THEN  REPEAT  DROP                     The tests are quite expensive so we suggest that they be enabled
   +T  CURRENT @  BEGIN  16 /MOD SWAP  ?DUP WHILE  1 HUNT IF              only when encountering a vocabulary problem or writing new   
      1 RDF DROP <CREATE> EXIT  THEN  REPEAT  DROP <CREATE> ;             code.  Among other things, burial of words that were indis-  
FORTH GILD   ( Enable)  ' ?CREATE  'CREATE !                              criminately tilde'd is detected, although figuring out what  
( Target Compiler)   EMPTY   DECIMAL                                      such word it was will be very difficult.                     
: HELP   47 HELPS  CR ;      ' <CREATE>  'CREATE !                     HEAD  holds the target dictionary links.  HDS has next, default,
0 CONSTANT NEW   61 CONSTANT CHIP   TODAY 1- CONSTANT IMM                and last total head sizes, in cells.  0 disables, 17 is max.  
: AHEAD ( - n)   >IN @  32 WORD  SWAP >IN ! ;                          ?TWO  is nonzero if next definition is to be twinned.           
   : LOG ;   ( 119 LOAD)   HELP                                        Last  contains the address in HEAD of the most recent definition
                                                                       W0  is target cell address corresponding to output image base.  
ARRAY HEAD  16 ALLOT   2VARIABLE HDS  0 ,   CREATE ?TWO  1 ,           'H  contains target  HERE  for PROM.                            
VARIABLE VOC   VARIABLE Last   VARIABLE 'H   VARIABLE 'R               'R  is the location counter for target RAM.                     
ARRAY ?CODE  4 ALLOT   CREATE OPT  -1 ,                                VOC  contains CURRENT and CONTEXT used for TARGET dictionary.   
( Meta)  46 LOAD      VARIABLE W0      HOST DEFINITIONS                                                                                
: ORG ( a)   'H ! ;            : HERE ( - a)   'H @ ;                  ORG  sets next PROM address and  GAP  reserves PROM space.      
: GAP ( n)   HERE + ORG ;      : THERE ( - a)   'R @ ;   HEX           HERE  returns next PROM address and  THERE  returns next RAM.   
: WINDOW ( n)   DUP ORG W0 !  0 'R !  000B VOC !                       WINDOW  resets pointers for a new target given origin address.  
   0 HEAD 10 ERASE ;      0 WINDOW      DECIMAL                        |  causes next definition to be headless.                       
( Compile to RAM)  48 LOAD      : |   0 HDS ! ;                        RECOVER  trims last cell from dictionary.                       
( Compiler)  49 LOAD      : ALLOT ( n)   'R +! ;                       ALLOT  reserves RAM space.                                      
   ( Host computer)                                                                                                                    
: NAME ( - a)   LAST @ @ 1+ ;                                          NAME  returns NFA of the last word created in the host machine. 
: SIZE ( - n)   NAME  DUP 1- CFA  SWAP - ;                             SIZE  returns the length of this name, in cells.                
: PREVIOUS ( - a)   NAME  1- CFA  1+ @ ;                               PREVIOUS  returns the last word's target CPFA if it was straight
: VOCAB ( - n)   NAME @  VOC @ +  10 - ;                                  EMPLACE type.                                                
: -' ( - a t | a a f)   CONTEXT @ >R                                   VOCAB  returns target vocabulary index for last word in host.   
      VOC @ CONTEXT !  -'  R> CONTEXT ! ;                              -'  returns the parameter and link addresses of a target word in
                                                                          the HOST's dictionary.                                       
HEX 0071 VOCABULARY FORTH   : FORTH   FORTH ;  IMMEDIATE                                                                               
    0017 VOCABULARY HOST   : HOST   HOST ;  IMMEDIATE   DECIMAL        Vocabs:  1  Host's FORTH.            9                          
: ONLY ( n)   VOC @  SWAP VOC !                                                 3  Host's EDITOR.           B  FORTH Emplace's         
   VOCAB 10 + 15 AND  CONTEXT + 1+  LAST @ 0 @+  OVER @ SWAP !                  5  Target IMMEDIATEs        D  EDITOR Emplace's        
   >R  DUP LAST !  0 @+  R> SWAP ND!  !  VOC ! ;                                7  HOST                     F                          
: TARGET   VOC @ ONLY  IMMEDIATE ;                                                                                                     
: TWIN ( n)   ?TWO @ IF  DUP  WIDTH @ >IN @                            ONLY  moves the last host definition to the given vocabulary.   
   ROT CONSTANT  >IN !  WIDTH !  THEN DROP ;                           TARGET  puts the last host definition in vocabulary 9.          
HELP          Displays these target COMPILER instructions              TWIN  constructs a host defn for a target value if ?TWIN is set.
                                                                                                                                       
CHIP LOAD     Compiles native system for Beta board.                                                                                   
62 LOAD       Compiles system that depends on IBM PC.                                                                                  
New programs are compiled to blocks 0-8.                                                                                               
                                                                                                                                       
s n DUMP      Dumps target address space,  n bytes at  s                                                                               
HERE U.       Current top of target dictionary                                                                                         
THERE U.      Next available target RAM location                                                                                       
                                                                                                                                       
TESTING LOAD  Simulates compiled program                                                                                               
                                                                                                                                       
288 LOAD  HUNT   Checks differences from installed system                                                                              
                                                                                                                                       
                                                                                                                                       
Nucleus Interp   Comp   Edit  Total RAM                                                                                                
   ( Compile to RAM)                                                                                                                   
ARRAY RAM  4096 ALLOT                                                  RAM  contains the output image and  DICTIONARY  clears it, set- 
: DICTIONARY ( n)   DUP HDS 2!  0 RAM 4096 -1 WFILL ;                     ting the next and default head size limits.                  
: >T ( a - a)   W0 @ -  4095 AND  RAM ;                                >T  converts target swapped byte address to RAM.  The mapping   
                                                                          used allows 8k target outputs destined for RAM test to be    
: T@ ( a - n)   >T @ ;            : T! ( n a)   >T ! ;                    split across the nonexistent 4k gaps in the Alpha boards.    
: T2@ ( a - n)   >T 2@ ;          : T2! ( d a)   >T 2! ;                                                                               
: H, ( n)   , ;                   : , ( n)   HERE T!  1 GAP ;          T@  and  T!  support cell addressing to and from the image.     
: TC! ( n a)   2 /MOD >T BYTE + C! ;   : T+! ( n a)   >T +! ;          ,  goes into target image;  H,  goes into host dictionary.      
: TMOVE ( s d #)   >R  >T  R> MOVE ;                                   TC!  supports chip-order byte addressing of the image.          
: TCMOVE ( s d #)   >R  >T  R> CMOVE ;                                 TMOVE  is in cells, but with source address in host units.      
                                                                       TCMOVE  is all in bytes, period.  Zero length is verboten.      
: DUMP ( a #)   1- 8 / FOR  ( L# @ 63 > IF PAGE  THEN) CR                                                                              
   DUP 5 U.R  7 FOR  DUP T@ 7 U.R  1+ NEXT  NEXT DROP SPACE ;          DUMP  displays the target image in cell units.                  
: FLUSH   7 FOR  I 512 * RAM  I NEW + BUFFER 512 MOVE                  FLUSH  preserves the target image on disk.                      
      UPDATE  NEXT  FLUSH ;                                                                                                            
   ( Target assembler)   OCTAL                                                                                                         
: -CODE   0 ?CODE 4 ERASE ;   104120 CONSTANT '2DUP                    TSIZE  returns the length in cells of the target link + name fld
: R>> ( - n)   R>  R> SWAP >R  77777 AND ;                                that will be made for the word following in the input stream.
: -EX ( t)   IF ELSE  R> DROP  THEN ;                                  EMPLACE  constructs a definition in VOC whose behavior is to    
                                                                          compile the given instruction.  WARNING:  CONSTANT is inapp- 
( Data base)  DECIMAL 109 LOAD                                            ropriate if we ever target for bottom of memory.  Unlikely.  
: TSIZE ( - n)   AHEAD @ WIDTH @ MIN  512 / 2 +  HDS @ MIN ;           (CREATE)  makes a head in the target machine with an EMPLACE    
: EMPLACE ( n)   LOG  CONSTANT  VOC @ ONLY  DOES>   @ ,C ;                definition in VOC to match it.  We'd like to redo the lead-in
: (CREATE)   HERE TSIZE + EMPLACE  HDS @ IF  HERE                         to accomodate ~.  The link field is laid down, headlinks are 
      VOCAB 15 AND HEAD  DUP Last !  DUP @ ,  !  NAME HERE                maintained, and the name is installed with forced truncate.  
   SIZE DUP GAP  TMOVE  THEN  HDS 2 @+  1 !-  1 @-  !  -CODE ;            In the chip, consecutive ASCII leads go into consecutive bins
: EQU ( n)   LOG CONSTANT ;                                                                                                            
: STRING ( c)   WORD HERE OVER @ 512 / 1+ DUP GAP TMOVE -CODE ;                                                                        
: USE ( n)   PREVIOUS T! ;                                             EQU  is an equated constant in  HOST  for interpretive use only.
                                                                       STRING  constructs a counted string in the target dictionary.   
( Compiler)  110 113 THRU  50 LOAD  114 118 THRU  51 LOAD              USE  replaces the first instruction of the last word defined.   
   ( Target compiler)   OCTAL                                                                                                          
: COMPILE   -' ABORT" ?" DROP  FORTH ,C ;  IMMEDIATE                   COMPILE  and  [COMPILE]  are used within HOST colon definitions 
: \   [COMPILE] COMPILE ;  IMMEDIATE                                      to provide their conventional services when the following    
: [COMPILE]   [COMPILE] COMPILE ;  IMMEDIATE                              words are host-executable definitions in TARGET vocabularies.
: '   -' ABORT" ?" DROP  1+ @ ;                                                                                                        
                                                                       '  returns the CFA in target memory for the given TARGET word.  
: [']   '  [COMPILE] LITERAL ;  TARGET                                                                                                 
: ]   1 STATE !  BEGIN  -' IF  BYTE NUMBER  \ LITERAL  ELSE            LITERAL  and  [']  are for use in target colon definitions.     
   1+ @ 0<  IMM @ 1 AND 1- AND IF  1+ @  DUP T@  DUP 0< IF  DUP           Short or long optimizable forms are made, as necessary.      
         130000 140000 WITHIN IF  7777 AND  OVER 170000 AND OR         ]  is the crosscompiler.  [  punches back out.                  
      ELSE  177737 AND  THEN THEN  ,C DROP  ELSE EXECUTE                                                                               
   THEN DEPTH 0< ABORT" stack empty"  THEN AGAIN ;                     DOES  generics call their behaviors from their code fields with 
: [   -COMPILE  R> DROP ;  TARGET      : does   R>> @  USE ;              one cell.  The behavior is entered with PFA in I.  This vers-
: DOES   FORTH COMPILE HOST does  HERE FORTH ,                            ion of  DOES  is used within the target compiler to make the 
   -CODE  -COMPILE  R> DROP  HOST ] ;  IMMEDIATE                          transition between host construction and target execution.   
: RECOVER   HERE 1- T@  100040 XOR IF EXIT  THEN -1 GAP ;                                                                              
   ( Compiler directives)   OCTAL                                                                                                      
: OR, ( a n)   -CODE  SWAP 7777 AND  OR , ;                            OR,  combines the low 12 bits of an address with an instruction.
                                                                          For greater than 8k compilation there should be a limit check
: BEGIN ( - a)   HERE  -CODE ;   TARGET                                   to avoid loud curses from customers.                         
: UNTIL ( a)   110000 OR, ;   TARGET                                                                                                   
: AGAIN ( a)   130000 OR, ;   TARGET                                   CREATE parameter fields start in the cell following code.  The  
                                                                          instruction used is a fetch from the PC with return set.     
: IF ( - a)   \ BEGIN  110000 , ;   TARGET                                                                                             
: THEN ( a)   \ BEGIN  7777 AND  SWAP T+! ;   TARGET                                                                                   
: ELSE ( a - a)  HERE  130000 ,  SWAP \ THEN ;   TARGET                                                                                
: WHILE ( a - a a)   \ IF  SWAP ;   TARGET                                                                                             
: REPEAT ( a a)   \ AGAIN  \ THEN ;   TARGET                                                                                           
                                                                                                                                       
: FOR ( - a)   COMPILE >R  \ BEGIN ;   TARGET                                                                                          
: NEXT ( a)   120000 OR, ;   TARGET                                                                                                    
: (   51 WORD DROP ;   TARGET                                                                                                          
   ( Defining Words)   OCTAL                                                                                                           
: FLAGS ( - a n)   PREVIOUS  SIZE -  DUP T@ ;                          FLAGS  returns addr and value of last name field in target image
: SMUDGE   NAME @ 20000 XOR  NAME ! ;                                  DIRECT  marks the last word for direct substitution.            
: DIRECT   NAME @ 100000 OR  NAME !                                    -DIRECT  removes this marking; used postfix for words that could
      HDS 2 + @ IF  FLAGS 100000 OR  SWAP T!  THEN ;                      directly substitute but which must be referenced indirectly. 
: -DIRECT   NAME @ 77777 AND  NAME  !                                  ?DIR  marks the current definition for direct substitution if   
      HDS 2 + @ IF  FLAGS 77777 AND  SWAP T!  THEN ;                      the entire definition (without its return arranged yet) would
: ?DIR   PREVIOUS 1+  HERE = IF                                           be legitimate for such treatment, and compiles an EXIT.      
      PREVIOUS T@ -MAGIC IF  DIRECT  THEN THEN \ EXIT ;                                                                                
: ;   SMUDGE  -COMPILE  R> DROP  ?DIR ;  TARGET  ( 0-1)                Colon definitions start in their Code Fields.                   
                                                                       Constants are compiled as returning literals.  Value is in the  
: CREATE   HERE TSIZE + 1+ TWIN  (CREATE)  147342 , ;  ( 2)               cell following code, with a Return instruction afterward on  
: :   CURRENT @ CONTEXT !  (CREATE)  SMUDGE  ] ;                          the first mask, except that short constants are embedded.    
FORTH : CONSTANT ( n)   DUP TWIN  (CREATE)  \ LITERAL  ?DIR ;                                                                          
FORTH : VARIABLE   THERE CONSTANT  1 ALLOT ;  ( 2)                                                                                     
FORTH : 2VARIABLE   VARIABLE  1 ALLOT ;                                                                                                
   ( IMMEDIATE words)   HEX                                                                                                            
FORTH : IMMEDIATE   HDS 2 + @ IF  Last @  DUP @ SWAP                   IMMEDIATE  moves an EMPLACEd definition to vocabulary 5, and it 
      OVER T@ OVER !  0 HEAD - 1+ 0F AND  HEAD DUP Last !                 also moves the definition in target memory to an immediate   
   2DUP @ SWAP T!  !  THEN  5 ONLY ;                                      vocabulary (if the definition has a head).                   
FORTH : [COMPILE]   FORTH  CONTEXT @  0005 CONTEXT !                                                                                   
   '  EXECUTE  CONTEXT ! ;  TARGET                                                                                                     
FORTH : \   [COMPILE] [COMPILE] ;  TARGET                                                                                              
                                                                                                                                       
FORTH : CELL   0 \ LITERAL  -CODE  \ +  \ &2/ ;  TARGET                                                                                
FORTH : BYTE   \ 2* ;  TARGET   HOST                                                                                                   
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Screen editor)                                                                                                                       
| : #I ( - b)   CORE 80 + ;      | : #F ( - b)   CORE 160 + ;          This screen editor uses simple, visible, 1-letter commands.  It 
| : R#@ ( - n)   R# @ ;          | : R#! ( n)   R# ! ;                    is compatible with previous polyFORTH screen editors and with
| 64 CONSTANT LW                                                          the instructions in Starting FORTH. Its modifications support
                                                                          cursor positioning commands which are present on most CRTs   
( String)  58 LOAD   ( Terminal)  59 LOAD   ( Common)  55 LOAD            marketed today.  Versions of these commands are available in 
| : WHOLE ( - n)   1024 REST ;                                            blocks 59 and 156 & up.  See instructions there and in block 
                                                                          10 for selecting the version most appropriate for you.  If   
HEX 00BD VOC !   DECIMAL   56 57 THRU                                     your CRT has no cursor positioning capability, we can supply 
   : WIPE   SCR @ BLOCK  512 8224 FILL UPDATE  0 R#!  L ;                 you with an editor which doesn't use it.                     
   : M ( b n)   -LINE  HOLD  SCR 2@ >R >R  LW *                        Notice that not all words defined in this section are in the    
      SWAP SCR 2!  u  R> R> SCR 2!  LW ADVANCE  .LINE ;                   EDITOR  vocabulary: those in blocks 55, 58, and 59, plus     
HEX 00DB VOC !   DECIMAL                                                  -TRAILING and  T  here are in  FORTH .  T  enters  EDITOR .  
   : T ( n)   -LINE  15 AND  LW *  R#!  .LINE ;   HEX                  N and B  move forward and back one block, respectively.         
HEX 000B VOC !   OCTAL HERE 7 U.R                                      WIPE erases the current (SCR) block to blanks, with 0 in the    
                                                                          first cell.                                                  
   ( Editor)                                                           M copies the current line to a specified block and line (under).
| : REST ( n - n)   DUP 1-  R# @ AND - ;                               These words, though intended for editing support, are in the    
| : AT ( - b n)   SCR @ BLOCK 2*  R# @ +  LW REST ;                       FORTH vocabulary.                                            
| : SET   R#@  LW /MOD  1+  SWAP 3 + TAB ;                                                                                             
: >TYPE ( b n)   >R  CORE I CMOVE  CORE R> TYPE ;                      >TYPE types a line after moving it to  PAD .  This is necessary 
| : -LINE   SET  AT -TRAILING >TYPE  CLEAN ;                              because in a multi-user environment you can't type from a    
| : .LINE   EDITOR SET  AT MARK  18 0 TAB CLEAN  17 0 TAB SPACE           block buffer.                                                
      SPACE  R#@ 63 AND  AT DROP OVER -  SWAP >TYPE  AT MARK ;                                                                         
| : ADVANCE ( n)   R# @ +  1023 MIN  R#! ;                             LIST lists a block in the form in which you see it now.         
: LIST ( n)   PAGE DUP .  0  15 FOR  CR DUP 2 U.R  SPACE               L  lists the current block, and selects  EDITOR .               
      OVER BLOCK 2*  OVER LW * +  LW -TRAILING >TYPE  1+ NEXT          COPY copies a block from one block number to another.  Note that
   SPACE  DROP SCR ! ;                                                    this done by changing the buffer ID; thus if you have changed
: L   SCR @ LIST  0 ADVANCE  .LINE ;                                      the block since it was last written, only the new location   
: COPY ( n n)   SWAP BLOCK DROP  IDENTIFY  UPDATE ;                       will contain the new information.                            
| : BODY   R#@  DUP -64 AND  DUP LW /  15 SWAP -                                                                                       
   0 MAX FOR  R# ND!  -LINE  64 + NEXT DROP  R#! ;                                                                                     
   ( Line editor)                                                                                                                      
| : ?BODY ( n)   EXTENT @ LW > IF  BODY  ELSE                             This editor uses two string buffers, a "find" buffer (#F)    
   DUP IF  -LINE THEN  THEN ADVANCE  .LINE ;                           and an "insert buffer" (#I).  Their use is described in Starting
| : STRING ( s - s')   ( 94)1 WORD  2* C@ IF                           FORTH.                                                          
      DUP 80 BLANK  HERE 2*  2DUP C@  1+ CMOVE  THEN 1+ ;                                                                              
| : DELETE ( d n n)   OVER MIN  DUP >R -  2DUP OVER I +                T  types a given line, leaving the cursor at its beginning.     
      ROT ROT CMOVE  + R> BLANK  UPDATE ;                              P  puts text following or the insert buffer in the current line.
| : INSERT ( s n d n)   ROT  OVER MIN  DUP >R -                        X  deletes the current line, moving lower lines up, with blank  
      OVER DUP I +  ROT <CMOVE  R> CMOVE  UPDATE ;                        fill from the bottom.                                        
| : AT0 ( - b n)   R#@  -64 AND  R#!  AT ;                             U  inserts the text following or the insert buffer under the    
| : HOLD   AT0 #I  2DUP C!  1+ SWAP CMOVE ;                               current line, moving lower lines down and dropping line 15   
: P   -LINE  #I STRING  AT0 CMOVE  UPDATE  .LINE ;                        off the bottom.                                              
: X   HOLD  AT0  WHOLE SWAP DELETE  BODY .LINE ;                       K  Swaps the insert and find buffers.                           
| : u   #I STRING  LW ADVANCE  AT0 SWAP  WHOLE INSERT ;                                                                                
: U   -LINE  u  BODY .LINE ;                                                                                                           
: K   #I CORE 160 CMOVE  CORE #F 80 CMOVE ;                                                                                            
   ( String editor)                                                                                                                    
| : ADV ( n)   SCR +!  0 R#! ;                                         TILL  deletes all the text from the character pointer up to     
: N   1 ADV  L ;      : B   -1 ADV  L ;                                   the find buffer.  TILL  sets the find buffer.                
| : -FOUND ( - b b' t)   #F STRING DROP  AT DROP                          The usage is:  TILL pattern                                  
      DUP WHOLE  #F 2/ COUNT  -MATCH ;                                 E  deletes backwards from the character pointer, the number of  
| : SEARCH   -LINE  -FOUND IF  #F  HERE 2* 80 CMOVE                       characters in the find buffer.  It's good for deleting       
      18 0 TAB CLEAN  1 ABORT" None"  THEN SWAP - ADVANCE ;               a piece of text which has been found by  F .                 
| : EXT ( - b n)   AT DROP  EXTENT @ REST ;                            I  inserts text, and sets the insert buffer.  Usage:  I text    
: TILL   R#@  SEARCH  R#@ SWAP  R# ND!                                 D  searches for and deletes the first occurrence of the find    
   -  EXT ROT DELETE  0 ?BODY ;                                           buffer.  D  sets the find buffer.  Usage:  D pattern         
| : e   #F C@  DUP NEGATE ADVANCE  EXT ROT DELETE ;                    F  finds the text in the find buffer.  It also sets the find    
: I   #I STRING  #I C@ EXT INSERT  #I C@ ?BODY ;                          buffer.  The usage is:  F pattern                            
: E   e  0 ?BODY ;         : D   SEARCH E ;                            R  replaces text found by  F  with the text in the insert buffer
: F   SEARCH  .LINE ;      : R   e I ;                                    and sets the insert buffer.  The usage is:  R text           
: S ( n)   DUP SCR @ -  1- 0 MAX FOR  -FOUND WHILE  2DROP              S  searches all the blocks starting at  SCR  up to and including
      1 ADV  NEXT DROP  ELSE R> DROP  SWAP - ADVANCE  L  THEN ;           the block whose number is the argument to  S .               
   ( String operators)                                                    The usage is:  n S pattern                                   
: -TRAILING ( b n - b n)   DUP IF  1- FOR  DUP I + C@                  -MATCH  takes the text address (d) and the text                 
      32 - IF  R> 1+ EXIT  THEN NEXT  0  THEN ;                           length (the first n) and tries to find a find buffer in it.  
: BLANK ( b #)   ?DUP IF 1- FOR  32 OVER C! 1+ NEXT THEN DROP ;           The find buffer begins at  s  and has a length of  (the 2nd) 
                                                                          n .   If the search is successful, the values returned are a 
: CMOVE ( s d #)   ?DUP IF  1- FOR  OVER C@  OVER C!                      false, and the address just after the end of the string.  If 
      1+ SWAP 1+ SWAP  NEXT  THEN 2DROP ;                                 the pattern is not found, the values returned are a true (non
: <CMOVE ( s d #)   ?DUP IF  1- FOR                                       zero) and garbage.                                           
      OVER I + C@  OVER I + C!  NEXT  THEN 2DROP ;                                                                                     
                                                                       CMOVE  is an ordinary character move, starting at the beginning 
: -MATCH ( d n s n - b t)   SWAP MD I!  DUP 1- SR I!                      of a string, and working forward. It's good for most copying,
   -  DUP 0< NOT IF  FOR  DUP C@  MD I@ C@ = IF  MD I@                    and when fields overlap, it copies to a field in lower       
         SR I@ FOR  OVER I + C@  OVER I + C@ = WHILE  NEXT                memory.                                                      
            DROP SR I@  R> DROP  + 1+ 0 EXIT                           <CMOVE  is a backwards character move.  It's good for copying   
      THEN DROP  R> DROP  THEN 1+ NEXT  1  THEN ;                         from a field into an overlapping field in higher memory.     
                                                                          <CMOVE  is backwards because it starts at the end of the     
   ( Default GLASS TTY terminal)   HEX                                    string and moves the rear-most characters first.             
: (CR)   0D EMIT  0A EMIT ;   DECIMAL                                     This block contains the hardware-specific features needed    
: (PAGE)   23 FOR  CR  NEXT ;                                          to implement the 'screen editor'.  They are implemented in such 
                                                                       a way that you may easily modify the key words for any CRT with 
: (TAB) ( l c)   2DROP CR ;                                            a simple cursor-positioning function.                           
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;                                                                              
                                                                       (TAB) - Given line (0-23) and column (0-80), positions the      
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                   cursor to that position.                                     
                                                                       (MARK) - The purpose of this routine is to highlight the        
                                                                          position of the editing cursor, by whatever means the hard-  
                                                                          ware permits: reverse video, underlining, etc.  If none of   
                                                                          these features are available, insert a caret (HEX 5E).       
                                                                          Given an address and count of a string to be highlighted,    
                                                                          sets the highlighting, outputs the string, and resets it.    
                                                                       (CLEAN)  is commonly known as "clear to end of line" on termin- 
                                                                          als that support the function.  Otherwise it is simulated.   
( NC4000P polyFORTH)                                                                                                                   
( Target compiler)  52 53 THRU                                            The definitions loaded in this block define polyFORTH for    
                    HERE                                               the NC4000P chip.  Environment-specific features such as disk & 
: X   R> DROP ;     HEX 00A0  OVER 1+ T!   DECIMAL                     terminal drivers are excluded; however, the multiprogrammer does
                    0 HEAD !   0 HEAD BYTE DUP 2 + 30 CMOVE            depend on external hardware present on the Beta board.  In all  
( Nucleus)  63 65 THRU  66 69 THRU                                     other respects, this coding is strictly for the chip itself.    
( Level 1)  70 73 THRU   OCTAL  HERE 7 U.R  DECIMAL                                                                                    
                                                                                                                                       
( Multiprogrammer)  75 ( 76)77 THRU                                                                                                    
( Terminal)  78 LOAD   ( Output)  84 86 THRU                                                                                           
( Disk)  93 94 THRU                                                                                                                    
( Interpreter)  87 90 THRU      OCTAL HERE 7 U.R   DECIMAL                                                                             
                                                                                                                                       
( Compiler)  108 LOAD  99 104 THRU   OCTAL HERE 7 U.R   DECIMAL                                                                        
( Editor)  54 LOAD                                                                                                                     
                                                                                                                                       
   ( Beta board, SCSI disk)   DECIMAL   HELP                                                                                           
HOST DEFINITIONS   FORGET ALLOT   : ALLOT ( n)   'R +! ;               This block directs the target compilation of a new system for   
OCTAL  ( 1)70000 EQU /PROM   21 DICTIONARY                                RAM or PROM, with environment dependencies in the form of    
   /PROM WINDOW  /PROM 1 + ORG   37 ALLOT                                 native serial terminal and SCSI disk drivers.  It also has   
   4 EQU #BUF   10000 1000 #BUF * - EQU FIRST   DECIMAL                   control over certain basic memory allocation parameters:     
                                                                                                                                       
( Nucleus)  60 LOAD                                                    /PROM  is the start of the nucleus; 10000 for PROM, 70000 RAM.  
( Terminal)  79 80 THRU                                                The phrase  /PROM 1 + ORG  reserves space for the reset entry   
( Disk)  96 98 THRU                                                       definition; 2 cells are required for tgt outputs >4k cells.  
( Initialize)  105 106 THRU                                            The phrase  37 ALLOT  reserves all of low RAM for applications  
                                                                          except the last cell, which is assigned to  U  in block 75.  
( Links)  HOST 0 HEAD  ram  FORTH 1+ 16 TMOVE                                                                                          
   OCTAL HOST  HERE 7 U.R  SPACE  THERE U.   FLUSH                     #BUF  is the maximum number of block buffers for which space in 
                                                                          the PREV table and in memory will be reserved.               
                                                                          The value 10000 at the start of the following phrase is the  
                                                                          address of the next cell above the block buffers.  In this   
   ( Beta board, IBM PC)   DECIMAL   HELP                                 system, buffers are allocated immediately underneath PROM.   
HOST DEFINITIONS   FORGET ALLOT   : ALLOT ( n)   'R +! ;               This block directs the target compilation of a new system for   
OCTAL  ( 1)70000 EQU /PROM   21 DICTIONARY                                RAM or PROM, with environment dependencies in the form of    
   /PROM WINDOW  /PROM 1 + ORG   37 ALLOT                                 terminal and disk support from a host using a serial protocol
   4 EQU #BUF   10000 1000 #BUF * - EQU FIRST   DECIMAL                   It also controls certain basic memory allocation parameters: 
                                                                                                                                       
( Nucleus)  60 LOAD                                                    /PROM  is the start of the nucleus; 10000 for PROM, 70000 RAM.  
( Terminal, disk)  79 LOAD  81 82 THRU                                 The phrase  /PROM 1 + ORG  reserves space for the reset entry   
                                                                          definition; 2 cells are required for tgt outputs >4k cells.  
( Initialize)  105 LOAD  107 LOAD                                      The phrase  37 ALLOT  reserves all of low RAM for applications  
                                                                          except the last cell, which is assigned to  U  in block 75.  
( Links)  HOST 0 HEAD  ram  FORTH 1+ 16 TMOVE                                                                                          
   OCTAL HOST  HERE 7 U.R  SPACE  THERE U.   FLUSH                     #BUF  is the maximum number of block buffers for which space in 
                                                                          the PREV table and in memory will be reserved.               
                                                                          The value 10000 at the start of the following phrase is the  
                                                                          address of the next cell above the block buffers.  In this   
( Nucleus)   OCTAL                                                        system, buffers are allocated immediately underneath PROM.   
 0 CONSTANT JK      4 CONSTANT MD      6 CONSTANT SR                   These definitions fulfill a somewhat different role in the chip 
10 CONSTANT Bport  14 CONSTANT Xport                                      than they do in a conventional FORTH system.  Since primitive
                                                                          operations (that compile to one instruction) must be repre-  
: OR   OR ;      : XOR   XOR ;      : AND   AND ;                         sented as compiler macros, there would not need to be an exe-
: +   + ;        : -   - ;                                                cutable definition of "+" as we would never compile a refer- 
: 1+   1+ ;      : 1-   1- ;        : NEGATE   NEGATE ;                   ence to it, but would rather compile the instruction.        
: 2*   2* ;      : 2/   2/ ;        : EXIT   R> DROP ;                                                                                 
                                                                       However, it is desirable that these instructions be usable      
: SWAP   SWAP ;      : OVER   OVER ;                                      interpretively; also it is desirable that there be a defin-  
: DUP   DUP ;        : DROP   DROP ;                                      ition of "+", for example, that one could tic and store into 
: ROT ( n n n - n n n)   >R SWAP  R> SWAP ; ( 5)                          a vector.  It is for these two needs that heads and compiled 
                                                                          object are committed to primitive operations.                
: 2DUP ( d - d d)   OVER OVER ; ( 3)                                                                                                   
   ' 2DUP  FORTH ' '2DUP 1+ !   HOST                                   We note, in passing, that this is more efficient than "state-   
                                                                          sensitive" compiling macros in units of speed, memory consum-
   ( Relationals)                                                         ption, and reusability of compiler source.                   
: 0< ( n - t)   0< ;                                                   The relationals in this system are of the classical, circular   
                                                                          variety.  On the next chip, words like  <  and  >  will      
: < ( n n - t)   - 0< ; ( 3)                                              compile to one instruction and be eligible for direct        
: > ( n n - t)   SWAP - 0< ; ( 3)                                         substitution.                                                
: U< ( u u - t)   - &2/  0< ; ( 3)                                     U<  works over the full range of unsigned numbers.              
                                                                                                                                       
: 0= ( n - t)   IF  0 EXIT  THEN -1 ; ( 3)                             <  and  >  should become macros on the next chip.               
: NOT ( n - t)   0= ; ( 3)                                                                                                             
: = ( n n - t)   XOR 0= ; ( 5)                                         Note that while the chip respects the 83-standard convention for
                                                                          normal "true" values as -1,  NOT  remains equivalent to  0= .
                                                                          The 83-standard version of  NOT  was a catastrophic blunder, 
                                                                          in that if NOT should do anything correctly it should invert 
                                                                          the condition of  IF .  Since  IF  considers anything nonzero
                                                                          to be "true", it is ESSENTIAL that NOT must convert any such 
                                                                          nonzero ("true") value to zero ("false").  This happens to be
   ( Carry on return stack)   HEX                                         the definition of  0= .                                      
| : R>> ( - n)   R>  R> SWAP >R  7FFF AND  \\ BEGIN ;                  The decision to save the carry latch on the return stack in the 
      EQU 'EXIT                                                           first chip was in retrospect unfortunate, mainly due to the  
FORTH : -EX ( t)   'EXIT \ UNTIL ;  TARGET                                burden it places on generics in cleaning up their parameter  
                                                                          addresses before use.  To conserve nucleus space and make it 
FORTH : DOES>   FORTH COMPILE HOST does  HERE FORTH ,                     easier to accomodate the anticipated changes in the second   
      HOST \ R>>  -CODE  R> DROP ] ;  FORTH IMMEDIATE  HOST               chip, this block defines several workarounds.                
                                                                                                                                       
                                                                       R>>  removes the top of the return stack with its possible      
                                                                          saved carry turned off.                                      
                                                                       -EXIT  may ONLY be used within the same page as 'EXIT occurs in.
                                                                          It compiles a conditional EXIT which takes if cond. is FALSE.
                                                                       DOES>  is a macro producing the old polyFORTH effects on entry  
                                                                          to generic behavior.  We keep it here because it enables us  
                                                                          to macro-ize the fixup for carry saved on the return stack.  
                                                                                                                                       
   ( Multiply, divide)   OCTAL                                                                                                         
| : U*+ ( u +r +neven - d)   MD I!  16 DO( *' ; ( 20)                  *' restrictions 1st mask:  NO step of a multiply may generate a 
: u/MOD ( +d +u - uq r)   MD I!  D2*  15 DO( /' )  /'' ; ( 21)            carry, T may never go negative during multiply, MD must be a 
                                                                          positive, even number.                                       
| : m* ( n r - d)   15 DO( *' )  *- ; ( 19)                                                                                            
: -M/MOD ( d +n - q r)   OVER 0< IF  DUP >R +  R> THEN                 U*+  is severely afflicted with the depicted arg restrictions.  
   u/MOD ; ( 25-28)                                                       So long as the sum of +r and +neven is far away from high bit
                                                                          we should be able to guarantee no carries will be generated. 
| : DNEGATE ( d - d)   SWAP NEGATE  SWAP -1 XOR  0 +c ; ( 6)                                                                           
: M/ ( d n - q)   DUP 0< IF  NEGATE >R  DNEGATE R> THEN                u/MOD  divides an unsigned 31-bit number by T, returning the    
   -M/MOD DROP ; ( 29-41)                                                 remainder ON TOP of quotient.  Divisor < 8001.               
                                                                       -M/MOD  is Chuck's divisor-positive signed, floored divide.     
                                                                                                                                       
                                                                       DNEGATE  changes the sign of a double number.                   
                                                                       M/  is the full range, floored version.                         
                                                                                                                                       
      ( Fixups)   OCTAL                                                                                                                
| : +U* ( +n +n - d)   DUP 1 AND IF  1-  MD I!  DUP  ELSE              This block works around problems in Mask 1.                     
      BEGIN [ SWAP ] MD I!  0  THEN  16 DO( *' ; ( 23-25)                                                                              
                                                                       +U*  is a fast fix of the N15 problem that's correct for low 16.
: U* ( u u - d)   DUP 100001 AND UNTIL  OVER SR I!  DUP MD I!             All correct for (+n +n) and can do (u +n) iff n even.        
      DUP 0< IF  0 SR I@ +D2/  ELSE  0 0  THEN                                                                                         
      MD I@  1 AND IF  SWAP SR I@ +  SWAP 0 +c  THEN                   U*  is the full fix, returning 32-bit unsigned product of any   
   SR I!  >R  77776 AND  MD I!  0  16 DO( *' )                            two 16-bit unsigned numbers.                                 
      SWAP R> +  SWAP SR I@ +c ; ( 25-51)                                                                                              
                                                                       M*  returns the 32-bit product of any two 16-bit signed numbers.
: M* ( n n - d)   DUP 1 AND IF  OVER SR I!  1-  DUP MD I!                                                                              
   0< DUP IF  m*  SWAP 1+  SWAP 0 +c                                                                                                   
         SWAP SR I@ +  SWAP  SR I@ 0< +c  EXIT  THEN      ( 40)                                                                        
      m*  SWAP SR I@ +  SWAP SR I@ 0< +c  EXIT  THEN      ( 36)                                                                        
   DUP MD I!  0< DUP IF  m*  SWAP 1+                      ( 31)                                                                        
      SWAP 0 +c  EXIT  THEN  m* ;                         ( 27)                                                                        
      ( Full range)                                                                                                                    
: /MOD ( u +u - r q)   0 SWAP  u/MOD SWAP ; ( 25)                      /MOD  works with any dividend, but divisor < 8001.              
: MOD ( u +u - r)   /MOD DROP ; ( 27)                                  MOD  works with any dividend, but divisor < 8001.               
: */MOD ( u u +u - r q)   >R U*  R> u/MOD SWAP ; ( 50-76)              */MOD  limits only the divisor.                                 
                                                                                                                                       
: */ ( n n n - q)   >R M*  R> M/ ; ( 60-85)                            */  is full range unlimited with floored divide.                
: * ( n n - n)   +U* DROP ; ( 25-27)                                   *  uses the fastest primitive it can get away with.             
: / ( n n - q)   >R  DUP 0<  R> M/ ; ( 33-45)                          /  is full range unlimited with floored divide.                 
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Memory reference operators)                                                                                                       
: @ ( a - n)   @ ;        : ! ( n a)   ! ;                             DO NOT FORGET that words like  @  and  !  use  CELL ADDRESSES,  
: +! ( n a)   DUP >R  @ +  R> ! ; ( 8)                                    whereas those like  C@  and  C!  use  BYTE ADDRESSES.        
                                                                                                                                       
: C@ ( b - n)   0 SWAP +D2/ @  SWAP IF  255 AND  EXIT                  In stack effect documentation, "a" always denotes a CELL address
   THEN  CELL 2/ 2/ 2/  2/ 2/ 2/ 2/ ; ( 11-17)                            and "b" a BYTE address.  In general FORTH words on this CPU  
                                                                          work in terms of cell addresses.  Exceptions are listed in a 
: C! ( n b)   0 SWAP +D2/  >R IF  255 AND                                 reference page of the CPU supplement.                        
      I @ -256 AND  ELSE  2* 2* 2* 2*  2* 2* 2* 2*                                                                                     
   I @ 255 AND  THEN OR  R> ! ; ( 19-24)                                                                                               
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( 32-bit operators)                                                                                                                 
: 2@ ( a - d)   1 @+ @ SWAP ; ( 6)                                     The prefix "2" indicates that these operators take arguments two
: 2! ( d a)   1 !+ ! ; ( 6)                                               cells long.  These may be 32-bit numbers or pairs of 16-bit  
                                                                          numbers.  The latter usage justifies the inclusion of these  
: 2DROP ( d)   DROP DROP ; ( 3)                                           primitives in the program; other double-length operations are
                                                                          loaded by block 9.                                           
| : D+ ( d d - d)   MD I! >R  SWAP R> +  SWAP MD I@ +c ; ( 7)                                                                          
                                                                       D+  is included here for the benefit of the 31-bit LRU manager. 
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( String operators)                                                                                                                 
: ?DUP ( n - n n, 0)   DUP -EX  DUP ; ( 4)                             Addressing decisions for string operations are based upon       
                                                                          historical experience with cell machines.                    
| : +MOVE ( s d n - s' d')   DUP >R +  MD I!  I DO( 1 @+ )                                                                             
   MD I@!  R> DO( 1 !- )  MD I@ SWAP ; ( 2* 14+)                       ?DUP  duplicates a number if it's nonzero.                      
                                                                          Using  ?DUP IF  makes an  ELSE DROP  phrase unnecessary.     
: MOVE ( s d n)   128 /MOD  ?DUP IF                                                                                                    
      SWAP >R  1- FOR  127 +MOVE  129 +  NEXT  R> THEN                 +MOVE  moves cells thru the stack given starting addresses and  
   ?DUP IF  1- ?DUP IF  +MOVE  ELSE  SWAP @ SWAP !  EXIT                  a count that's ONE SHORT.  Returns source advanced PAST data,
   THEN THEN 2DROP ; ( 2.13* over 1K)                                     and destination one AHEAD OF data.                           
                                                                       MOVE  moves any number of cells, which may be zero.  Uses 128   
: FILL ( a n n)   SWAP 1- >R  SWAP BEGIN  OVER SWAP 1 !+  NEXT            cells of stack for speed.  If this isn't acceptable, you may 
   2DROP ;                                                                redefine  MOVE  in the  9 LOAD  since it is only rarely used 
                                                                          in the nucleus, and then only for small strings.             
                                                                                                                                       
                                                                       FILL  operates in units of cells, and will fail on zero length. 
   ( Arithmetic)                                                          It's redefined later on in the  9 LOAD  as a byte operation. 
: WITHIN ( n l h - t)   OVER - >R  - R> U< ; ( 8)                      WITHIN  is true if the first argument lies within a range whose 
: ABS ( n - u)   DUP 0< -EX  NEGATE ; ( 4)                                lower value is the second argument and whose highest value is
                                                                          one less than the third.  The smallest range is of size zero 
: MAX ( n n - n)   2DUP < IF  BEGIN  SWAP DROP ; ( 9)                     and the largest is 65535.  The range proceeds circularly thru
: MIN ( n n - n)       2DUP < UNTIL  THEN DROP ; ( 9)                     the 2's complement space and does not respect any boundary:  
                                                                             -32768 0 WITHIN  is equivalent to  0< .                   
                                                                             0 -32768 WITHIN  is equivalent to  0< NOT .               
                                                                             -32768 SWAP WITHIN  is full range arithmetic  < .         
                                                                             1+ 32768 WITHIN  is full range arithmetic  > .            
                                                                                                                                       
                                                                       MAX  and  MIN  employ circular relationals.  They use each      
                                                                          other's code to save memory.                                 
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Miscellaneous)                                                                                                                    
: ERASE ( a n)   0 FILL ;                                              Note that ERASE works in units of CELLS and WILL NOT do zero!   
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( System variables)                                                                                                                    
VARIABLE U  ( 37!)   ( Interrupt)  32 ALLOT                            System Variables are those that do not need to be replicated for
                                                                          each task.  Vectors can be redirected through user variables 
VARIABLE GOLDEN  17 ALLOT   VARIABLE OPT                                  if it's desired to change their behaviors for different tasks
VARIABLE 'BLOCK      VARIABLE 'BUFFER  2 ALLOT                         U  contains the address of the currently executing user area.   
2VARIABLE 'NUMBER    VARIABLE 'CREATE     2VARIABLE NB                 There are 32 cells reserved starting at octal 40 for interrupts.
VARIABLE 'ST         VARIABLE CONFIGURATION  11 ALLOT                                                                                  
2VARIABLE DISK       2VARIABLE PREV  4 #BUF * ALLOT                    GOLDEN  holds the dictionary heads used by  EMPTY .             
| VARIABLE IMM       VARIABLE TODAY  4 ( TICKS) ALLOT                  OPT  is -1 if the optimizer is enabled, 0 if disabled.          
                                                                       'ST  vectors the stack empty test, if any.                      
                                                                       CONFIGURATION  holds SCSI disk characteristics for  HOME .      
                                                                       IMM  is odd following a dictionary search if immediate was found
                                                                       The space after  'BUFFER  holds the block number last written.  
                                                                       The space after  'NUMBER  holds the high-order part of the      
                                                                          last number converted if it lacked punctuation.              
                                                                       The space after  DISK  is nonzero in case of a disk error.      
   ( USER variables)                                                   The space after  PREV  contains the disk buffer management table
FORTH : USER ( n)   DUP TWIN  (CREATE)  U \ LITERAL  \ @               The  USER  variables for this system are documented in the CPU  
      ?DUP IF  \ LITERAL  \ +  THEN  \ EXIT ;  ( 4-6)                     supplement.  Additional USER variables are defined in blk 123
 0 USER STATUS   ( 1 next  2 JK save  3 stack sel)                     Most BACKGROUND tasks have shorter user areas than do TERMINAL  
 4 USER S0            5 USER 'IDLE          6 USER LIVE                   tasks.  One of the major constraints on user area ordering is
 7 USER H          | 10 USER 2OFFSET       11 USER OFFSET                 to keep this space to a bare minimum for typical background  
12 USER BASE         13 USER PTR           14 USER CNT                    type operations.                                             
15 USER DEVICE       16 USER 'EMIT         17 USER 'TYPE                                                                               
18 USER 'CR          19 USER 'PAGE         20 USER 'TAB                'IDLE  contains the address of this task's idle behavior, which 
21 USER 'MARK        22 USER 'CLEAN        23 USER 'KEY                   is executed following any ABORT.                             
24 USER 'EXPECT      25 USER C#            26 USER L#                  LIVE  may be used to differentiate manned terminals from others.
27 USER >IN          28 USER BLK           29 USER #TIB                H  contains the dictionary pointer, EMPTY point, and upper limit
: ?CODE ( n - a)   U @ +  30 + ;                                       OFFSET  is the low order 16 bits of the 32-bit 2OFFSET.         
34 USER CONTEXT      51 USER CURRENT       52 USER LAST                ?CODE  is an array of 4 cells used by the optimizing compiler.  
53 USER STATE        54 USER WIDTH         55 EQU tib ( 40)            STATE  is 1 if compiling.  Used only by HASH.                   
95 USER EXTENT       96 USER SCR           97 USER R#                  TIB  returns a BYTE address.  All others return CELL addresses. 
   ( Multiprogrammer)   OCTAL                                                                                                          
CREATE WAKE  ]  R> 1+  1 @+  3 @-  DUP >R  U !                         WAKE  is the instruction in STATUS for users ready to become    
      -1 !  JK I!  DROP  DROP 140721 R> !  EXIT [  ( 21)                  active.  Normally it contains an  R> DROP  for 2-clock loop. 
                                                                          The newly awakened task is marked asleep on the way into it. 
: PAUSE   WAKE  U @ 1 !+                                               PAUSE  is used to give up control of the CPU with the intent to 
   BEGIN  DUP >R  JK I@  SWAP 1+ ! ;  ( 15:  2*36+)                       continue executing at the next opportunity; marks task awake.
: STOP   U @ 1+  AGAIN ;  RECOVER  ( 13:  2*34+)                       STOP  gives up control until STATUS is found set = WAKE, usually
                                                                          done by another task or event (such as an interrupt).        
: GRAB ( a)   DUP @  U @ - IF  BEGIN                                      Note that this condition may already exist when we STOP.     
      DUP @ WHILE  PAUSE REPEAT  U @ OVER !  THEN DROP ; ( 8)                                                                          
: GET ( a)   PAUSE GRAB ;                                              GRAB  asserts control of a facility by storing the current      
                                                                          user's  STATUS  address in its facility variable.  If the    
: RELEASE ( a)   DUP @  U @ - IF  DROP EXIT                               facility isn't available (i.e., value nonzero and not this   
      THEN  0 SWAP ! ;  ( 12)                                             user) we wait in  PAUSE  until it is available.              
                                                                       GET  calls  GRAB  after one lap around the multiprogrammer.     
                                                                       RELEASE  relinquishes a facility by zeroing it.  Doesn't alter  
( Vectored terminal)                                                      the variable if it isn't owned by the current task.          
: EXECUTE ( a)   >R ; ( 3)                                             EXECUTE  and  @EXECUTE  clobber the carry on the way to their   
: @EXECUTE ( a)   @ >R ; ( 5)                                             destinations.  Upon reaching destination, I refers to the    
                                                                          code that called  EXECUTE .  Note that this version of       
: EMIT ( c)   1 C# +!  'EMIT @EXECUTE ;                                   @EXECUTE  does NOT test for a zero vector!                   
: TYPE ( b n)   ?DUP IF  DUP C# +!  'TYPE @EXECUTE  EXIT                                                                               
      THEN DROP ;                                                      Each of the basic terminal control functions is vectored through
: CR   1 L# +!  'CR @EXECUTE  0 C# ! ;                                    the user area so that different tasks may employ different   
: PAGE   'PAGE @EXECUTE  0 0 C# 2! ;                                      hardware.  TYPE and EXPECT are conventional.                 
: TAB ( l c)   2DUP 'TAB @EXECUTE  C# 2! ;                                                                                             
                                                                       EMIT  displays a single character.                              
: MARK   'MARK @EXECUTE ;      : CLEAN   'CLEAN @EXECUTE ;             KEY  expects a character from the keyboard with no echoing.     
: KEY   'KEY @EXECUTE ;        : EXPECT   'EXPECT @EXECUTE ;           CR  and  PAGE  perform device-specific carriage return and clean
                                                                          media functions.                                             
                                                                       TAB  is a cursor positioning function given a y-x vector.       
                                                                       MARK  is a version of  TYPE  that highlights in some way.       
   ( 2661B USARTs)   HEX                                               CLEAN  performs an erase to end of line.                        
: U@ ( n - c)   DEVICE @ OR  C000 OR  DUP 4000 XOR                     U70 is DEVICE 800; U71 is DEVICE 000.  U70 is OPERATOR's.       
      OVER D001  0 !+ 0 !+ DUP 1- @ >R  !  R> 0FF AND ;                Write protocol:                                                 
: U! ( c n)   OR  DEVICE @ OR  4000 OR  DUP 4000 XOR                      Set addr, subaddr, direction, data.                          
      OVER D001  0 !+  0 !+  NOP ! ;                                      Set chip enable.                                             
HERE  DECIMAL  38400 , 19200 , 9600 , 4800 , 2400 ,                       NOP (Perhaps two?)                                           
      2000 , 1800 , 1200 , 600 , 300 ,  0 ,  HEX                          Turn off chip enable (Preserve addr, dir)                    
: BAUD ( n)   LITERAL  0F FOR  2DUP @ U< WHILE                            ---  Allow 600 ns minimum recovery time before next cs.      
      1+ NEXT  THEN 2DROP  0 300 U!  300 U@ DROP                                                                                       
   4E 200 U!  R> F0 + 200 U!  37 300 U! ;                              Read protocol:                                                  
                                                                          Set addr, subaddr, direction.                                
: key ( - c)   BEGIN  PAUSE  100 U@ 2 AND UNTIL  0 U@ ;                   Set chip enable.                                             
: emit ( c)   BEGIN  PAUSE  100 U@  DUP 2 AND IF                          NOP, NOP                                                     
      0 U@ ( xoff) 13 = IF  DROP  BEGIN key  ( xon) 11 = UNTIL            Read data                                                    
   100 U@  THEN THEN  1 AND UNTIL  0 U! ;                                 Turn off chip enable (Preserve addr, dir)                    
: (TYPE) ( b n)   1- FOR  DUP C@ emit  1+ NEXT  DROP ;                    ---  Allow 600 ns min recov time before next cs.             
   ( EXPECT)   HEX                                                                                                                     
: (EXPECT) ( b #)   1- >R  0 SWAP  BEGIN  KEY                          EXPECT  will handle any number of characters on any byte bound- 
   DUP 0D XOR WHILE  DUP 7F XOR IF  DUP 8 XOR IF                          ary.  Within the loop, stack contains next buffer address    
            DUP EMIT  OVER C!  SWAP 1+  SWAP 1+                           underneath CNT value.  Backspace (08) and rubout (7F) are    
         ELSE  [ SWAP ] THEN  DROP  OVER IF                               both recognized, echoing as backspaces.  Backspace at begin- 
            SWAP 1-  SWAP 1-  2  ELSE 1  THEN                             ning of buffer does nothing but echoing a bell code (07).    
               DUP 6 + EMIT  R> + >R  THEN NEXT                                                                                        
   ELSE  R> DROP DROP  THEN SPACE  DROP CNT ! ;                        Since I/O in this system is polled, a great deal of background  
                                                                          activity can introduce latencies in the echoing of characters
                                                                          from the keyboard.                                           
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Polled PC network)                                                                                                                
| : type ( b n)   ?DUP IF  (TYPE) EXIT  THEN DROP ;                    The basic synchronized umbilical protocol always starts with a  
| : straight ( b n)   ?DUP IF  1- FOR  key OVER C!  1+ NEXT               3-byte request from the Beta board:  ll hh cc  where cc is a 
      THEN DROP ;                                                         request class number (even with high bit set), and ll and hh 
| : sync   key DROP ;      | : 2in ( - n)   key key 256 * + ;             are the low and high bytes of a parameter.  After sending the
| : rqst ( n c)   0 U@ DROP  SWAP 256 /MOD  SWAP emit emit                request, Beta expects either a sync character or a string of 
      128 + emit ;                                                        data depending on the protocol.  Directions switch as many   
| : easy ( n)   14 rqst  sync ;                                           times as needed to complete the transaction; in every case,  
: Ask ( a n - a)   10 rqst  DUP 2* 1024 straight                          a known number of bytes are moving in a known direction.  In 
      0 emit  2in DISK 1+ ! ;                                             every transaction, the last message moved is from host to the
: Tell ( a n - a)   12 rqst sync  DUP 2* 1024 type                        Beta board.                                                  
      2in DISK 1+ ! ;                                                  Since our I/O is polled, background activity can easily destroy 
                                                                          this protocol's integrity.  For that reason we do not recom- 
: (BUFFER) ( n - n a)   ?UPDATED DROP  Tell ;                             mend serious multiprogramming on the Beta board when using   
: (BLOCK) ( n - a)   ?ABSENT  'BUFFER @EXECUTE                            the PC as terminal/disk.  In fact since the protocol is not a
   >R OVER R> SWAP  Ask  ESTABLISH ;                                      polled multichannel system such as clusterFORTH, only the    
   ( PC terminal protocol)                                                operator may use disk or the PC's printer anyway.            
: (EXPECT) ( b n)   255 AND 0 rqst  ( 2in)key  DUP CNT !               Disk on the PC is subdivided in whatever way the user desires.  
      ?DUP IF  0 emit straight  DUP THEN  DROP ;                          For this reason, DRIVE is not defined in PROM.  Block zero   
                                                                          from the point of view of the PC is also block zero from the 
: (TYPE) ( b n)   DUP 4 rqst sync  type sync ;                            point of view of the Beta board.                             
: (MARK) ( b n)   ?DUP IF  DUP 6 rqst sync  type sync  EXIT                                                                            
      THEN DROP ;                                                      Terminal control sequences are all handled as protocols, so that
: (CR)   0 easy ;                       : (PAGE)   2 easy ;               the host may configure itself for whatever terminal it uses. 
: (TAB) ( l c)   256 * + 8 rqst sync ;  : (CLEAN)   4 easy ;                                                                           
: (PRINT) ( b n)   DUP 16 rqst sync  type sync ;                       (PRINT)  is a simple TYPE operation for the host's printer.  We 
                                                                          have elected to configure for different printers within the  
: WHO   ." Beta board " ;      : BYE   6 easy  WHO ;                      Beta board instead of the host, since the intended host is   
                                                                          the IBM PC and since it's much easier to configure for the   
| VARIABLE POO                                                            various PC printers in the Beta board's environment.         
: key ( - c)   POO 2* DUP 1 EXPECT  C@ ;                                                                                               
: emit ( c)   POO 2* C!  POO 2* 1 TYPE ;                                                                                               
   ( Bitbang serial I/O: 4X in, 0X out)                                                                                                
| : DELAY ( n)   FOR  NEXT ; ( n+4)                                    Bit-banged serial I/O.  SHORT DELAYS IFF T/B IN LOW RAM!        
: EMIT ( n)   30 DUP \\ 13 I! DROP  1 C# +!  256 + 2*  ( -1 XOR)       DELAY  consumes four more clocks than the given argument.  It's 
   9 FOR  DUP \\ Xport I!  2/ T/B @ ( 13)11 - DELAY NEXT DROP ;           incapable of consuming less.                                 
: TYPE ( b n)   ?DUP IF 1- FOR  DUP C@ EMIT 1+ NEXT THEN DROP ;                                                                        
                                                                                                                                       
: CR   13 EMIT  10 EMIT  L# @ 1+  23 MIN  0 C# 2! ;                    EMIT  serializes all 8 bits from low order given.  Stop bit will
: PAGE   12 EMIT  0 0 C# 2! ;                                             be incorrect if bit 8 is nonzero.  Waits till stop bit sent. 
                                                                          Leaves Xport mask set to enable Tx output ONLY.  1=Mark.     
: RX ( - n)   16  Xport I@ AND ; ( 3)                                  TYPE  cleans low bytes to 7 bits but sign extends hi bytes. This
: KEY ( - n)   0  BEGIN  RX 0= UNTIL  T/B @ DUP 2/ + ( 21)19 -            precludes typing binary data; lo bytes are masked and hi are 
      7 FOR  DELAY  2/  RX 2* 2* 2* OR  T/B @ ( 18)16 -  NEXT             sent with potentially bad framing.  Requires a counted string
   DROP  BEGIN  RX UNTIL ;                                                and will go nuts with a count greater than 127.  Returns the 
                                                                          address of first cell past the string.                       
                                                                       RX  tests the Rx bit; 1=Mark (mark in idle; space is start bit) 
                                                                       KEY  deserializes a character on bit centers; returns 8-bit data
( Output)                                                                 on lead edge of stop bit, or in middle of D7 if it was mark. 
: HERE ( - a)   H @ ;                                                  These are the basic output words plus some orphans:             
: PAD ( - a)   HERE 17 + ;                                             HERE  returns the address of the next available dictionary cell.
: CORE ( - b)   PAD 2* ;                                               PAD  returns the CELL address of a string scratch pad;          
                                                                       CORE  returns its BYTE address (historical usage).              
: COUNT ( a - b n)   2* 1+  DUP 1- C@ ;                                                                                                
                                                                       COUNT  takes the CELL address of a counted string and returns   
: SPACE   32 EMIT ;                                                       the BYTE address and BYTE COUNT of the string following the  
: SPACES ( n)   0 MAX  ?DUP IF  1- FOR  SPACE NEXT  THEN ;                count byte.                                                  
                                                                                                                                       
: HOLD ( c)   -1 PTR +!  PTR @ C! ;                                    SPACES  types spaces.  A zero or negative count does nothing.   
                                                                       SPACE  types a space.                                           
                                                                                                                                       
                                                                       HOLD  stores a character backwards in a string pointed at by PTR
                                                                          It is used during number conversion.  As used by the system, 
                                                                          these strings run backwards from PAD although they may be    
   ( Numbers)                                                             anywhere in byte addressable memory.                         
: DIGIT ( n - n)   DUP 9 >  7 AND +  48 + ;                            Number formatting words:                                        
: <#   CORE PTR ! ;                                                    DIGIT  converts a digit in any base [2..36] to ASCII.           
: #> ( b n)   2DROP  PTR @  CORE OVER - ;                                                                                              
: SIGN ( n d - d)   ROT 0< -EX  45 HOLD ;                              <#  opens conversion by initializing PTR.                       
                                                                       #>  discards the number and returns the string address and count
: # ( n 0 - n 0)   SWAP BASE @ /MOD  SWAP DIGIT HOLD  SWAP ;           SIGN  test the sign (from the 3rd stack position) and buffers a 
: #S ( n 0 - n 0)   BEGIN  #  OVER 0= UNTIL ;                             "-" if it's negative.  Intentionally not 83-standard.        
: (.) ( n - b n)   DUP ABS 0  <# #S  SIGN #> ;                         #  buffers a single digit from a 16-bit unsigned number.        
: . ( n)   (.) TYPE SPACE ;      : ? ( a)   @ . ;                      #S  buffers digits until the number reaches zero.               
                                                                                                                                       
: U.R ( u n)   DUP >R  <# #S #>  DUP R> SWAP - SPACES  TYPE ;          (.)  formats a signed integer.                                  
: U. ( u)   0 U.R  SPACE ;                                             .  types a signed integer, with a trailing space.               
                                                                       U.  types an unsigned integer, with trailing space.             
: DUMP ( a n)   1- 8 / FOR  CR DUP 5 U.R SPACE  7 FOR                  U.R  types an unsigned integer, right justified in a field.     
      1 @+  SWAP 7 U.R  NEXT  NEXT DROP SPACE ;                                                                                        
   ( Messages)   HEX                                                   DUMP  dumps cells in integral rows.  Zero count fails.          
: -COMPILE   0 STATE ! ;                                               -COMPILE  takes the system out of compile mode.                 
: ABORT   S0 @ JK I!  DROP DROP R> DROP -COMPILE  'IDLE @ >R ;         ABORT clears both stacks and performs this task's idle behavior.
                                                                                                                                       
: ?R@ ( t - | a)   R> SWAP  R>  DUP COUNT 1+  + &2/ >R                 ?R@  tests a truth value; if set, it returns with an in-line    
      SWAP IF  SWAP >R  EXIT  THEN  2DROP ;                               string address; otherwise it exits from the calling defn.    
| : abort" ( t)   ?R@  HERE COUNT TYPE SPACE  COUNT TYPE                                                                               
      CR  >IN 2@  OVER IF  SWAP SCR 2!  THEN  ABORT ;                  abort"  is the run-time code for ABORT" .  Upon error, it types 
| : dot"   1 ?R@  COUNT TYPE ;                                            the word at HERE , the message, and saves >IN in R# so that  
                                                                          the editor can display the point of error using  L .         
FORTH : ABORT"   COMPILE abort"  22 STRING ;  TARGET                   dot"  is the run-time code for  ." .  It types the message.     
FORTH : ."   COMPILE dot"  22 STRING ;  TARGET                                                                                         
                                                                       ABORT"  and  ."  are host definitions that compile references   
                                                                          to the above with inline character strings delimited by  " . 
                                                                                                                                       
                                                                                                                                       
( Interpreter)                                                                                                                         
: TIB ( - b)   U @  [ tib ] LITERAL +  2* ;                            This is the heart of the interpreter.                           
                                                                       PARSE  does the work of extracting a word from an input string. 
| : PARSE ( c n b - a)   1-  ROT MD I!  HERE 2* SR I!                     It's given the delimiter character, number of active bytes in
   DUP >IN @ +  ROT >IN @ -  ?DUP IF  1- FOR                              the buffer, and byte address of the start of the buffer.     
      1+ DUP C@  MD I@ XOR  0= WHILE  NEXT  ELSE                          Beginning with the relative character position in  >IN , we  
         1- BEGIN  1+ DUP C@  DUP MD I@ XOR WHILE                         skip over leading delimiters (if any) and then parse a string
               SR I@ 1+  DUP SR I!  C!  NEXT                              up to the next delimiter or end of buffer.  The characters of
            ELSE DROP  R> DROP  THEN                                      the string (if any) are stored starting in the low order byte
   THEN  THEN  SWAP -  >IN !  32 SR I@ 1+ C!                              of the cell at  HERE , followed by one space.  The number of 
      HERE 2*  DUP SR I@ SWAP -  SWAP C!  HERE ;                          characters, excluding the space, are stored in the high byte 
                                                                          at  HERE .  >IN  is advanced past the trailing delimiter but 
: WORD ( c - a)   BLK @ IF  1024 BLK @ BLOCK 2*                           is limited to the length of the buffer.  EOT's are returned  
      ELSE  #TIB @ TIB  THEN PARSE ;                                      forever at end of buffer.                                    
                                                                                                                                       
                                                                       WORD  uses the interpreter's normal input string:  BLK zero     
   ( Dictionary search)   HEX                                             indicates the message buffer, non-zero the disk block BLK.   
| : DESCEND ( pa la - pa)   1+ @  4000 AND IF  @  THEN ;               HASH  takes the address of a word and a vocabulary mask, and    
| : SAME ( ha la - h l 0 | p a t)   OVER MD I!  DUP 1+                    exits the caller with "true" if the mask is exhausted. Other-
   1 @+ SWAP  3FFF AND  BEGIN [ B000 ,C ]                                 wise isolates the low order vocabulary number and uses it to 
   BEGIN  1 @+ SWAP  [ SWAP ] THEN                                        select the proper dictionary link for the word, returning its
      MD I@  1 @+  MD I!  XOR DUP SR I! UNTIL                             address and the remainder of the mask.  Vocabulary numbers   
   SR I@  FF7F AND IF  0 AND EXIT  THEN                                   are odd.  Even numbers are used for compiler macros.         
      OVER DESCEND SWAP ROT ;                                                                                                          
                                                                       -FIND  takes the addresses of a word and dictionary link, and   
| : HASH ( a n - a a n | a t)   ?DUP IF  DUP IMM !                        the remainder of a mask.  Returns the word address and mask  
      STATE @ -  DUP 1 AND IF  10 /MOD  ELSE  2 + DUP  THEN >R            if not found.  Otherwise exits the caller with PCFA, link    
   OVER @ +  0F AND  1+ CONTEXT +  THEN R> ;                              field address, and "false".                                  
                                                                                                                                       
| : -FIND ( a a n - a n, p a f)   >R  BEGIN  @ DUP WHILE               Head structure:                                                 
       SAME UNTIL  R> DROP  R> 0 AND EXIT  THEN  R> XOR ;              +0  Link (points to link)                                       
                                                                       +1  drsn nnnn tccc cccc   Direct subst, Remote, Smudge, Truncate
   ( Number input)                                                     +n  0ccc cccc tccc cccc   As needed; last cell always has trunc.
: ?DIGIT ( b - b 0 | a n 1)   1+ DUP C@                                ?DIGIT  increments the address on the stack and then determines 
      DUP 57 > IF  DUP 64 >  7 AND -  THEN 48 -                           if the character at that location is a valid digit in the    
   DUP BASE @ U< IF  1 EXIT  THEN  0 AND ;                                current BASE.  If the character is valid, a true flag is left
                                                                          on the stack with the value of the digit underneath.  Other- 
| : 10*+ ( u n - u)   14 DO( *' )  DROP ;                                 wise, only a false flag is left.  In both cases, the address 
| : (NUMBER) ( b - n)   BASE @ MD I!                                      returned is that of the character just inspected.            
      DUP 1+ C@  45 =  DUP >R -                                                                                                        
   0 BEGIN  SWAP  ?DIGIT WHILE  ROT SWAP 10*+ REPEAT                   (NUMBER)  recognizes no punctuation except a leading sign, con- 
      C@ 32 XOR ABORT" ?"  I XOR  R> - ;                                  verting any signed integer and returning its low order 16    
                                                                          bits.                                                        
: NUMBER   'NUMBER @EXECUTE ;                                                                                                          
                                                                       Due to the arithmetic used, this version of NUMBER will only    
                                                                          work properly with EVEN bases.  The double number conversion 
                                                                          loaded by block 9 can handle any base.                       
                                                                                                                                       
   ( Control)                                                                                                                          
: -' ( - a t | p a f)   32 WORD  CONTEXT @                             -'  searches the dictionary for the word following in the input 
   BEGIN HASH  -FIND AGAIN ;  RECOVER                                     stream.  If found, returns 0 (false) with the link field add-
: ' ( - a)   -' ABORT" ?"  DROP ;                                         ress and parameter field address beneath.  If not found, it  
                                                                          returns "true" and  HERE .                                   
: INTERPRET ( n n)   >IN 2!  BEGIN  -' IF  BYTE NUMBER                 '  searches the dectionary for the word following in the input  
      ELSE  DROP EXECUTE  'ST @EXECUTE  THEN AGAIN ;  RECOVER             stream, returning its PFA if found, or aborting if not.      
                                                                                                                                       
: QUIT   BEGIN  TIB 80 EXPECT  CNT @ #TIB !                            INTERPRET  interprets the input stream, executing words found in
      0 0 INTERPRET  ." ok" CR  AGAIN ;  RECOVER                          the dictionary and converting numbers to binary, until either
                                                                          the input stream is exhausted or a word is found that cannot 
                                                                          be found or converted.                                       
                                                                       QUIT  stops whatever is executing and resumes the normal idle   
                                                                          behavior for terminals.  Neither stack is emptied.  Note that
                                                                          this implies that terminals may not use subdivided stacks,   
                                                                          which isn't a good idea anyway since debugging is likely to  
                                                                          wipe out an entire stack from time to time.                  
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( LRU buffer manager, 31-bit)                                                                                                          
| : FRONT ( a a - a)   DUP >R @  SWAP !  PREV @                        ?ABSENT  searches for a given block in memory, returning its    
      R> 1 !+  3 @-  PREV ! ;                                             buffer address and exiting the caller if found.  In this case
: ?ABSENT ( d - a | d)   MD I!  SR I!  PREV NB @ 1- FOR                   PREV points to the buffer descriptor, moved to top of chain. 
      DUP @  1 @+  1 @+ >R  SR I@ XOR IF  DROP  ELSE                   ESTABLISH  makes the oldest buffer the newest and identifies it.
         MD I@ XOR 2* WHILE  THEN DROP R>  [ SWAP ] NEXT                                                                               
      DROP  SR I@  MD I@ EXIT  THEN  R> FRONT  R> R> 2DROP ;           ?UPDATED  finds the oldest buffer, returning its address and ex-
: ESTABLISH ( d a - a)   MD I!  0 PREV  NB @ 1- FOR  SWAP DROP            iting caller if not updated, or returning to caller with the 
      DUP @ 2 + NEXT  DUP >R FRONT DROP  R> 2 - 2!  MD I@ ;               block's number on the stack and in 'BUFFER 1+ if updated.  In
                                                                          either case the block is left at end chain and marked empty. 
: ?UPDATED ( - a | a d)   PREV  NB @ 1- FOR  @ 2 + NEXT                UPDATE  marks the most recently accessed buffer as updated.     
      1+  2 @-  1 @-  0 @+  -1 SWAP !  DUP 0<  OVER 1+ AND IF                                                                          
   32767 AND 2DUP 'BUFFER 1+ 2!  ELSE DROP DROP R> DROP  THEN ;        2IDENTIFY  changes the identity of the most recent buffer.      
: UPDATE   PREV @  DUP @ 32768 OR  SWAP ! ;                            IDENTIFY  does the same but uses a 16-bit unsigned block #.     
| : 2IDENTIFY ( d)   2OFFSET 2@ D+  PREV @ 2! ;                                                                                        
: IDENTIFY ( n)   0 2IDENTIFY ;                                        PREV --> (0,1) Block #  (2) >next or 0  (3) >buffer             
   ( Block)                                                                     Sign bit of cell 0 is update flag.  Block # 31 bits.   
| : 2BUFFER ( d - a)   2OFFSET 2@ D+  DISK GET                         BUFFER  frees the oldest buffer, writing it to disk if necessary
   'BUFFER @EXECUTE  ESTABLISH  DISK RELEASE ;                            and then identifies the buffer with the block number given.  
: BUFFER ( n - a)   0 2BUFFER ;                                           Note that the buffer is NOT marked as updated!  Returns the  
                                                                          address of the buffer chosen.                                
| : 2BLOCK ( d - a)   2OFFSET 2@ D+  PAUSE ?ABSENT                     BLOCK  returns the address of a buffer containing the desired   
      DISK GRAB  'BLOCK @EXECUTE  DISK RELEASE ;                          block, performing any necessary I/O and making this buffer   
: BLOCK ( n - a)   0 2BLOCK ;                                             the most recently used.  In a later PROM, it will be able to 
                                                                          find a buffer in memory even if another task is performing   
: EMPTY-BUFFERS   NB @ 1- FOR  -1 DUP 0                                   I/O at the time.                                             
      ESTABLISH DROP  NEXT  PAUSE ;                                    FLUSH  writes out all updated buffers and leaves the pool empty.
: FLUSH   DISK GET  NB @ 1- FOR  -1 DUP 'BUFFER @EXECUTE               EMPTY-BUFFERS  erases all the block buffers.  It doesn't bother 
      ESTABLISH DROP  NEXT  DISK RELEASE ;                                to do a DISK GET since it should never be used in a system   
                                                                          with multiple active disk tasks anyway!                      
                                                                       2BUFFER  and  2BLOCK  are the versions that take 32-bit block   
                                                                          numbers.  While headless, they can still be located later    
   ( Serial disk)                                                         through their single precision cohorts.                      
| : ## ( a n - a b #)   0 EMIT  256 /MOD EMIT EMIT                     This is the basic disk protocol for direct terminal emulators.  
      DUP BYTE  1023 ;                                                                                                                 
                                                                       Disk read protocol:                                             
| : tell ( a n - a)   32768 OR  ## FOR                                    00 0hh ll>   <1024 bytes                                     
      DUP C@ EMIT  1+ NEXT  KEY 2DROP ;                                                                                                
| : ask ( a n - a)   ## FOR  KEY OVER C!  1+ NEXT  DROP ;              Disk write protocol:                                            
                                                                          00 1hh ll 1024 bytes>   <00                                  
EXIT                                                                                                                                   
| : buffer ( n - n a)   UPDATED tell ;                                 Chuck had a "50 us" open loop delay between the 1st and 2nd     
| : block ( n - a)   ABSENT buffer  OVER ask  ESTABLISH ;                 bytes received for each cell.  Damned if I have any idea at  
                                                                          all what on earth this could be for!                         
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( SCSI server)   HEX                                                                                                                   
| VARIABLE CP   VARIABLE STS                                           E000r  rb-- ---- p--a smci  REQ BSY  PTY  ACK SEL  MSG C/D_ I/O_
| : ACK   0 1 E001 1 !-  BEGIN  DUP @ 0< 1+ UNTIL  1+ ! ;              E001w  ---- ---- p--- -rsa  PTY  RST SEL ACK                    
                                                                       E002r  7654 3210 7654 3210  Two copies of DB0-7.                
| : ENSLAVE   E000 BEGIN  BEGIN  DUP @ 0< WHILE                        E003w  7654 3210 ---- ----  Drive DB0-7 enabled by I_/O high.   
      DUP @  DUP 1 AND IF  2 AND IF  DUP @ 4 AND IF  ACK                  ---- are garbage on input, don't care on output.             
            DROP EXIT  THEN  DUP 2 + @ ACK  3 AND  STS !                                                                               
         ELSE  DUP 2 + @ ACK  MD I@  DUP 1+ MD I!                      WARNING!  For max transfer rates, the byte addresses used here  
            DUP 1 AND IF  >R  0FF AND  SR I@ OR  R> 2/ !                  are NOT masked after shifting down.  Thus, the host adapter  
               ELSE  DROP  FF00 AND  SR I!  THEN  THEN                    may NOT be used for packets, data, or status that lies in    
      ELSE  2 AND IF  CP @  DUP 1+ CP !                                   memory above 7FFF as a byte address.  Since we're putting    
            ELSE  MD I@  DUP 1+ MD I!  THEN                               our buffers and so on in low memory this is cool.  Anyone who
         DUP 1 AND IF  2/ @  2* 2* 2* 2*  2* 2* 2* 2*                     needs to do direct I/O at higher addresses must add masking. 
            ELSE  2/ @  FF00 AND  THEN  E003 !  ACK                                                                                    
   THEN REPEAT  MD I@  SR I@  PAUSE  SR I!  MD I! AGAIN ;                                                                              
                                                                                                                                       
   ( SCSI host)   HEX                                                                                                                  
| : DELAY ( n)   DO( NOP ; ( n+4)                                      For courtesy in multiprogrammed systems, ENSLAVE pauses whenever
| : RST   0 4 E001 0 !+  0C8 DELAY !  18F FOR 1F40 DELAY NEXT ;           the controller doesn't come right back with REQ.  This will  
| : SEL   0 2 100 E003 3 !-  BEGIN  DUP @ 2* 0< 1+ UNTIL                  happen naturally when there's no activity on the bus and thus
   1+  1 !-  BEGIN  DUP @ 4000 AND UNTIL  1+ ! ;                          no reason to camp tightly on it for a while.  In extreme     
                                                                          cases the WHILE REPEAT could become an UNTIL enclosing the   
VARIABLE TBL  5 ALLOT                                                     code that safely does the PAUSE.  This might occur for exam- 
   2* CP !  DUP 2* MD I!  SEL ENSLAVE ;                                   ple when logging data to disk, although the disk transfer    
                                                                          rate thus sustainable will be quite disappointing.  There is 
                                                                          indeed no such thing as a free lunch.  On writes, pad may    
                                                                          need to be added for high speed processors.                  
                                                                                                                                       
                                                                       For speed, we assume that all input transfers involve an even   
                                                                          number of bytes.                                             
                                                                                                                                       
                                                                                                                                       
   ( 10980 block hard, 360 block floppy)   HEX                                                                                         
: HOME   RST RST  CONFIGURATION  0 C200 0 SCSI  0 100 0 SCSI           This driver supports an OMTI 5400 series SCSI disk controller.  
   5 + 0 C040 098B SCSI  0 C240 0 SCSI  DROP ;   DECIMAL                                                                               
                                                                       HOME  configures the controller for a TEAC SD-510 hard disk on  
: I/O ( a n f - a)   >R  10800 2DUP U< IF                                 logical unit zero and a TEAC FD-55B-20-U floppy disk drive   
      DROP R> 10  ELSE  - 2*  R> 64 +  11  THEN                           on logical unit 2.  Minor changes may be made at  hi  time   
   CONFIGURATION + @ SCSI  STS @ DISK 1+ ! ;                              by storing into the CONFIGURATION table in RAM.  No claims   
                                                                          are made that the support in PROM will work for any other    
: (BUFFER) ( d - d a)   ?UPDATED DROP  2560 I/O ;                         controller/drive combination.                                
: (BLOCK) ( d - a)   ?ABSENT  'BUFFER @EXECUTE                                                                                         
      >R OVER R> SWAP  2048 I/O  ESTABLISH ;                           Hard = 305 tracks, 4 heads, 9 1k sectors/track                  
                                                                          Precomp at 128  10980 blocks total, 10800 used.              
: DRIVE ( n)   720 * OFFSET ! ;                                        Floppy = 40 tracks, 2 heads, 9 512 sectors/track, no precomp.   
                                                                          360 blocks total (720 sectors).                              
                                                                                                                                       
                                                                       DRIVE  subdivides disk system into 720-block logical drives;    
( Compiler)   OCTAL                                                       0-14 hard disk, 15 floppy (half unused), 16 serial.          
| : compile ( a - n)   DUP @  DUP 0< IF  DUP                           compile  removes return from the addressed instruction and      
      130000 140000 WITHIN IF  7777 AND  OVER 170000 AND OR               converts branches into calls.                                
   ELSE  177737 AND  THEN THEN  SWAP DROP ;                                                                                            
                                                                       ]  starts the colon compiler executing.  It will continue to    
: [   R> DROP  -COMPILE ;  IMMEDIATE                                      compile until a  [  or  ;  or end of input buffer is seen.   
: ]   1 STATE !  BEGIN  -' IF  BYTE NUMBER  \ LITERAL  ELSE                                                                            
      IMM @ 1 AND IF  DROP EXECUTE  'ST @EXECUTE  ELSE  1+ @           [  leaves the compile mode.                                     
   0< IF  compile  THEN  ,C  THEN THEN  AGAIN ;  RECOVER                                                                               
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Compiler)   HEX                                                                                                                   
| : PREVIOUS ( - a n)   LAST @ @ 1+  DUP @ ;                           PREVIOUS  returns the address and value of the last word's name.
                                                                       SMUDGE  makes the last word un-findable.                        
| : SMUDGE   PREVIOUS 2000 XOR  SWAP ! ;                               RECURSIVE  un-does a SMUDGE.  It's IMMEDIATE so it may be used  
~ : RECURSIVE   PREVIOUS DFFF AND  SWAP ! ;  IMMEDIATE                    inside a recursive definition.                               
| : DIRECT   PREVIOUS 8000 OR  SWAP ! ;                                DIRECT  marks the last word for direct substitution.            
: -DIRECT   PREVIOUS 7FFF AND  SWAP ! ;                                -DIRECT  removes this mark; used postfix for words that could   
                                                                          substitute but which you wish referenced indirectly anyway.  
: CFA ( la - a)   DUP 1+ BEGIN  1 @+ SWAP  80 AND UNTIL                                                                                
      SWAP DESCEND ;                                                   CFA  takes the address of the link field of a definition and    
: USE ( a)   LAST @ @ CFA ! ;                                             returns its code/parameter field address.  This address will 
: DOES   R>>  USE ;                                                       be disjoint when CFA is used with a remote head.             
                                                                       USE  replaces the code field of the last word defined.          
: COMPILE   R>>  DUP 1+ >R  compile ,C ;                               DOES  alters the last word defined to call the following code.  
: [']   '  \ LITERAL ;  IMMEDIATE                                      COMPILE  is used with caution in compiler directives to move the
                                                                          single instruction following COMPILE into a defn being made. 
   ( Defining words)   OCTAL                                           [']  compiles the CPFA of the word following as a literal.      
: CREATE   'CREATE @EXECUTE ;                                          The words in this block allow the target system to compile      
: (CREATE)   HERE 0 ,  40 WORD  CURRENT @ HASH DROP  DUP LAST !           "data items".  The use of these words is documented in the   
      2DUP @  SWAP 1- !  SWAP 2* C@  DUP 0= ABORT" No name"               Reference Manual, Starting FORTH, and other sources.         
      WIDTH 2* C@ MIN  2/ 1+ ALLOT  200 HERE 1- +!  !                  CREATE  executes indirectly through the system vector  'CREATE .
   -CODE  147342 ,  WIDTH @  WIDTH 2* C! ;                             (CREATE)  makes a basic dictionary entry with a single code cell
                                                                          that returns the address of the cell following.  Other defin-
: :   CURRENT @ CONTEXT !  CREATE  -1 ALLOT  SMUDGE  ] ;                  ing words use CREATE to construct the head, and then add to  
                                                                          the parameters and/or substitute other behaviors as relevant.
: ?DIR   LAST @ @ CFA  DUP 1+ HERE = IF                                ?DIR  marks the last definition for direct substitution if the  
      DUP @ -MAGIC IF  DIRECT  THEN THEN DROP  \ EXIT ;                   entire definition (without its return arranged yet) would be 
: ;   \ RECURSIVE  R> DROP  ?DIR  -COMPILE ;  IMMEDIATE                   legitimate for such treatment.                               
                                                                       Note that CONSTANT will generate either of two forms depending  
: CONSTANT ( n)   CREATE  -1 ALLOT  \ LITERAL  ?DIR ;                     upon the size of the initial value.  The old trick of chang- 
: VARIABLE   CREATE  0 , ;                                                ing a CONSTANT's value by  n ['] name !  has to be written as
                                                                          n ['] name 1+ !  and will ONLY work with CONSTANTs whose init
   ( Compiler directives)   OCTAL                                         ial values are >31.  Otherwise make an approp. defining word.
| : ?LIM ( a - a)   ?NEAR 1+ ABORT" Limit" ;                           These compiling macros support the program flow structure dir-  
| : OR, ( a n)   -CODE  SWAP ?LIM  7777 AND  OR , ;                       ectives conventional in polyFORTH systems as well as the     
                                                                          FOR - NEXT construction for the NC4000A's count-down loop.   
~ : BEGIN ( - a)   HERE  -CODE ;  IMMEDIATE                                                                                            
~ : UNTIL ( a)   110000 OR, ;  IMMEDIATE                               The compiler directives use the compile-time stack to pass the  
~ : AGAIN ( a)   130000 OR, ;  IMMEDIATE                                  addresses needed to compile branches.  In this processor, all
                                                                          non-CALL branching instructions use 12-bit offsets within    
: IF ( - a)   \ BEGIN  110000 , ;  IMMEDIATE                              4k cell pages; attempts to branch across page boundaries are 
~ : THEN ( a)   ?LIM  \ BEGIN  7777 AND  SWAP +! ;  IMMEDIATE             met with the  Limit  diagnostic.  User manipulation of the   
~ : ELSE ( a - a)   \ BEGIN  130000 ,  SWAP \ THEN ;  IMMEDIATE           compiler's stack, either directly within  [ ]  or by creation
~ : WHILE ( a - a a)   \ IF  SWAP ;  IMMEDIATE                            of new structure words, is encouraged; performance is what   
~ : REPEAT ( a a)   \ AGAIN \ THEN ;  IMMEDIATE                           this computer is about, and you don't get performance by     
                                                                          executing endless streams of redundant ELSE clauses.         
: FOR ( - a)   [COMPILE] >R  \ BEGIN ;  IMMEDIATE                                                                                      
~ : NEXT ( a)   120000 OR, ;  IMMEDIATE                                Classical looping primitives are not in PROM; instead, they are 
   ( Vocabularies)                                                        compiled during the 9 LOAD.                                  
( : VOCABULARY   CREATE ,  DOES \\ ;  RECOVER)  FORTH                  VOCABULARY  defines a word that, when executed, will set CONTEXT
: VOCABULARY   (CREATE) 0 , ,  DOES>   @  CONTEXT ! ;                     to the sequence of vocabulary indices given.  The value is   
                                                                          organized in nibbles with the first vocabulary searched in   
HEX   0001 VOCABULARY FORTH                                               the low order nibble; up to 4 vocabularies may be specified, 
      0013 VOCABULARY EDITOR   DECIMAL                                    and unused high order nibbles must be set to zero.  Indices  
                                                                          specified must be ODD numbers; even vocabularies contain only
                                                                          IMMEDIATE words and are managed automatically by the compiler
                                                                                                                                       
                                                                       The system only defines the FORTH and EDITOR vocabularies, which
                                                                          occupy indices 1 and 3 respectively.  The target compiler    
                                                                          uses other indices, but the all other standard software only 
                                                                          depends upon these two.  BE WARNED that the vocabulary struc-
                                                                          ture on this machine is a bit different from that in standard
                                                                          polyFORTH systems; while it's the best compromise we could   
                                                                          think of for preserving a normal seeming search order, you   
   ( Miscellaneous)                                                       should read what the CPU supplement has to say on the subject
: EMPTY   H 1+  1 @- !  GOLDEN CONTEXT 18 MOVE ;                       EMPTY  resets  H  to the beginning of the task's dictionary     
                                                                          given by  H 1+ .  The system definition chains in  GOLDEN    
: STRING ( n)   WORD 2* C@  2/ 1+ ALLOT  -CODE ;                          are used to restore CONTEXT, CURRENT, and the sixteen link   
~ : ABORT"   COMPILE abort"  34 STRING ;  IMMEDIATE                       heads in the user area.                                      
: ."   COMPILE dot"  34 STRING ;  IMMEDIATE                            STRING  compiles a string terminated by a given ASCII character.
                                                                       ABORT"  compiles an error message which will be displayed along 
: DECIMAL   10  BEGIN BEGIN  BASE ! ;                                     with the word at  HERE  and the task aborted if the value on 
: HEX   16 AGAIN ;  RECOVER   : OCTAL   8 AGAIN ;  RECOVER                the stack at run-time is "true".                             
                                                                       ."  compiles a string that will be displayed at run-time.       
: LOAD ( n)  >IN 2@ >R >R                                                                                                              
      0 INTERPRET  R> R> >IN 2!  DECIMAL ;                             HEX ,  DECIMAL ,  and  OCTAL  change  BASE  appropriately.      
                                                                       (  stops interpreting (or compiling) until the delimiter ")" is 
: (   41 WORD DROP ;  IMMEDIATE                                           encountered.  It is defined twice since IMMEDIATE words can't
: (   \ ( ;                                                               be found in the dictionary by the interpreter.               
                                                                       LOAD  saves the current position in the input stream and calls  
( Initial RAM)   HEX                                                      INTERPRET  then restores the input stream pointer.           
| CREATE ram   1 ,  10 GAP  1 ,  -1 ( OPT) ,  ' (BLOCK) ,              ram  contains initial values for system variables.  These are   
   ' (BUFFER) , 0 , 0 ,  ' (NUMBER) , 0 ,  ' (CREATE) ,  1 ,              initialized on each warm or cold reset.                      
   FIRST ,  'EXIT ,  ( Hard) 0400 , 0003 , 0131 , 8000 , 0800 ,                                                                        
   ( Floppy) 0003 , 270F , 0000 , 0080 , 0000 ,  100 , 200 ,           'OPERATOR  allocates the operator's user area.  This must be the
   0 ( DISK) , 0 ,  PREV 2 + ,  0 ,  -1 , -1 , 0 , FIRST ,                last ALLOTment in the nucleus so that the user area can be   
                                                                          extended by an ALLOT at the beginning of block 9 if desired. 
| VARIABLE 'OPERATOR   DECIMAL 97 ALLOT                                                                                                
                                                                       OPERATOR  is the operator's Task Definition Block.  After the   
CREATE OPERATOR   'OPERATOR ,  OCTAL 140721 , 'OPERATOR ,                 system is up,  OPERATOR @  returns the address of the oper-  
      DECIMAL  0 ,  0 ( K) ,  1 ( S0) ,                                   ator's user area.                                            
   ' QUIT ,  1 ( LIVE) ,  THERE DUP ( H) , , FIRST ,                                                                                   
   0 0 ( OFFSET) , ,  10 ( BASE) ,  0 ( PTR) ,  0 ( CNT) ,             /INITIALIZE  sets up all I/O ports as OUTPUT and makes the      
   2048 ( DEVICE) ,  ' emit ,  ' (TYPE) ,  ' (CR) ,                       peripheral bus quiescent.  Note that we should program X&B as
   ' (PAGE) ,  ' (TAB) ,  ' (MARK) ,  ' (CLEAN) ,                         INPUT when pullups are available!                            
   ' key ,  ' (EXPECT) ,                                                                                                               
   ( Power-up initialization)   HEX                                                                                                    
| : /INITIALIZE  0 DUP 0D I!  DUP 0E I!  DUP 0F I!  Xport I!           Upon reset input, the CPU effectively executes a call to octal  
                 0 DUP 09 I!  DUP 0A I!  DUP 0B I!  Bport I!              10000, the first cell of PROM.  At this location we define   
      C000 D001 ! ;   DECIMAL                                             BOOT, which compiles only an unconditional branch to RELOAD. 
: HI   HOME  9 LOAD ;                                                     (note that with larger than 4k PROM this definition would    
                                                                          require two cells, accomodated by a change in block 61.)     
: RELOAD   -1 FOR  ( 8-16ms)  NEXT  0 -1 !                                                                                             
   'OPERATOR U !  /INITIALIZE  PREV 2 + 2@                             RELOAD  re-initializes the system for a cold or warm reboot.    
   NB 2@  SWAP [ FIRST ] LITERAL - IF  DROP -1 OR  1                      To ensure that power has stabilized enough for RAM to be     
      TODAY 5 ERASE  THEN ram GOLDEN 49 MOVE  PREV 1+ 1 !+ 2!             dependable, a 65k spin is entered.  This is required on the  
   STATUS 98 ERASE  OPERATOR 1+ STATUS 25 MOVE                            Beta board mark 1.  We then initialize the stack select reg- 
      64 EXTENT !  771 WIDTH !  9 SCR !  EMPTY   9600 BAUD                ister, set U for OPERATOR, initialize the I/O environment,   
   PAGE ." nF/Pb-1a 01 Oct"  CR ." hi "  ABORT ;                          and then initialize the data base in the customary order with
                                                                          block buffer preservation if GOLDEN is found equal to 1.     
HERE  /PROM ORG   | : BOOT   RELOAD ;   ORG                               The operator stack pointer is initialized by  ABORT .        
                                                                                                                                       
   ( PC Power-up initialization)   HEX                                                                                                 
| : /INITIALIZE  0 DUP 0D I!  DUP 0E I!  DUP 0F I!  Xport I!           Upon reset input, the CPU effectively executes a call to octal  
                 0 DUP 09 I!  DUP 0A I!  DUP 0B I!  Bport I!              10000, the first cell of PROM.  At this location we define   
      C000 D001 ! ;   DECIMAL                                             BOOT, which compiles only an unconditional branch to RELOAD. 
: HI   ( HOME)  9 LOAD ;                                                  (note that with larger than 4k PROM this definition would    
                                                                          require two cells, accomodated by a change in block 61.)     
: RELOAD   -1 FOR  ( 8-16ms)  NEXT  0 -1 !                                                                                             
   'OPERATOR U !  /INITIALIZE  PREV 2 + 2@                             RELOAD  re-initializes the system for a cold or warm reboot.    
   NB 2@  SWAP [ FIRST ] LITERAL - IF  DROP -1 OR  1                      To ensure that power has stabilized enough for RAM to be     
      TODAY 5 ERASE  THEN ram GOLDEN 49 MOVE  PREV 1+ 1 !+ 2!             dependable, a 65k spin is entered.  This is required on the  
   STATUS 98 ERASE  OPERATOR 1+ STATUS 25 MOVE  ( 0 DEVICE !)             Beta board mark 1.  We then initialize the stack select reg- 
      64 EXTENT !  771 WIDTH !  9 SCR !  EMPTY  38400 BAUD                ister, set U for OPERATOR, initialize the I/O environment,   
   PAGE ." nF/Pc-1a 01 Oct"  CR ." hi "  ABORT ;                          and then initialize the data base in the customary order with
                                                                          block buffer preservation if GOLDEN is found equal to 1.     
HERE  /PROM ORG   | : BOOT   RELOAD ;   ORG                               The operator stack pointer is initialized by  ABORT .        
                                                                                                                                       
( PROM assembler)                                                                                                                      
: ALLOT ( n)   HERE +  DUP 140 +                                       This block builds the optimizing compiler into PROM.            
      H 1+ 2@ WITHIN ABORT" Dictionary full"  H ! ;                                                                                    
: , ( n)   HERE !  1 ALLOT ;    | : -CODE   0 ?CODE 4 ERASE ;          ALLOT  reserves the given number of cells in the dictionary.    
' 2DUP  | CONSTANT '2DUP                                               ,  compiles the given value into the dictionary, as does        
                                                                       ,C  which also identifies it as an instruction for the compiler.
FORTH : T@   \ @ ;  TARGET      FORTH : T!   \ ! ;  TARGET                                                                             
FORTH : T2@   \ 2@ ;  TARGET    FORTH : T2!   \ 2! ;  TARGET           ?CODE  contains addresses of up to 4 recent instructions, with  
FORTH : ORG   \ H  \ ! ;  TARGET                                          the most recent first.  0 indicates non optimizable.         
FORTH : TARGET   IMMEDIATE ;    FORTH : H,   , ;                       -CODE  smites the optimizer with amnesia.                       
                                                                                                                                       
FORTH   0 ?TWO !   HOST                                                The definitions of  T@ , etc. enable the same source code to be 
   109 118 THRU                                                           used both by the target compiler and the target system.      
FORTH   1 ?TWO !   HOST                                                                                                                
                                                                                                                                       
                                                                                                                                       
   ( Data base)                                                                                                                        
| : CODE ( a)   OPT @ IF  0 ?CODE  1 @+ 1 @+ 1 @+                      CODE  shifts the given address into the  ?CODE  pipeline.       
      1 !- 1 !- 1 !-  !  EXIT  THEN DROP ;                             ,C  compiles an instruction that is optimizable.                
: ,C ( n)   HERE CODE  , ;                                                                                                             
                                                                       TH  returns the address of the nTH instruction back, or exits   
| : TH ( n - 0 | a)   ?CODE @  DUP 0= IF  R> DROP  THEN ;                 with false if it isn't worthy of consideration.              
| : INST ( n - n)   TH T@ ;   | : 0TH ( - n)   0 INST ;                INST  returns the value of the nTH instruction, zero if unworthy
| : SET ( n)   0 TH T! ;      | : MICRO ( n)   0TH XOR  SET ;          0TH  returns the value of the last instruction, zero if unworthy
| : EAT   0  3 ?CODE  1 @- 1 @- 1 @- 0 @-  SWAP ORG                    SET  replaces the last instruction with the value given.        
      1 !+ 1 !+ 1 !+  ! ;                                              MICRO  exclusive OR's the given value with the last instruction.
| : CLIP   0 TH T2@  1 TH T2!                                          EAT  eradicates the most recent instruction known in  ?CODE .   
   0 ?CODE 2@  HERE SWAP -  +  0 ?CODE !  EAT ;                        CLIP  eradicates the instruction before last.                   
                                                                                                                                       
: \\   -CODE ;   TARGET                                                \\  breaks optimization where it occurs in a definition.        
| : +OPT   OPT @ 0= -EX  HERE 1- 0 ?CODE ! ;                           +OPT  and  -OPT  locally enable and disable optimization when   
| : -OPT   OPT @ 0= -EX  -CODE ;                                          needed for compilation with OPT=0.  Guaranteed to work ONLY  
   ( Interrogators)   OCTAL                                               for code that compiles properly with optimizer enabled.      
FORTH : RNG ( m l h)   | CREATE  ROT H, H, H,  DOES ( n - t)           RNG  defines a testing word that is true if the given'th instr- 
   INST  R>>  1 @+ >R AND  R> 2@ WITHIN ;                                 uction after masking by  m  is within the range given.       
FORTH : TST ( m n)   | CREATE  SWAP H, H,  DOES ( n - t)               TST  defines a testing word that is true if the given'th instr- 
   INST  R>>  1 @+ >R AND  R> @ = ;                                       uction after masking by  m  is equal to  n .                 
FORTH : ID ( n)   | CREATE H,  DOES ( n - t)   INST  R>> @ = ;                                                                         
                                                                       F56  are I/O instructions from 15x4xx to 17xxxx.                
170777 150400 170000 RNG F56   000300 000000 000300 RNG M-3            M-3  are instructions with mode fields other than 3.            
170700 150200 160000 RNG F5s   000700 000400 000700 RNG M46            F5s  are 1-clock instructions in the 15... group.               
                                                                       PY15  are instructions with ALU 7 and mode fields 1 or 5.       
007300 007100 TST PY15   007700 007300 TST PY3                         PY3  are instructions with ALU 7 and mode field 3.              
170000 100000 TST ?ARI   170000 140000 TST F4                          ?ARI  are ARITH-type instructions.                              
160000 140000 TST ?LOW   170360 140300 TST ?I@                         F4  are I/O instructions with op code 14.                       
                                                                       ?LOW  are I/O instructions with op codes 15 or 15.              
107100 ID ?swap   107020 ID ?drop  140721 ID ?r>d                      ?I@  are internal fetches that don't pop the return stack.      
107120 ID ?over   100120 ID ?dup   100020 ID ?nip                      ?swap  and associates are unadorned versions of stack prim's.   
   ( Classification)   OCTAL                                                                                                           
| : ?FET ( n - t)   DUP F56  OVER M-3 AND  SWAP F4 OR ;                ?FET  identifies all straight internal, literal, and memory     
| : ?FULL ( n - t t)   DUP ?FET  SWAP PY15 ;                              fetches with or without binary ALU operations.               
| : -I ( n - t)   INST 17 AND  1 XOR ;                                 ?FULL  is true if an I/O instruction can accept a full ALU code.
| : =HI ( n n - t)   INST 177700 AND = ;                               -I  is true if the instruction does NOT address I directly.     
| : =IO ( n - t)   0 =HI ;                                             =HI  tests for equality in the high 10 bits of a given instr.   
                                                                       =IO  is true if the high 10 bits of the last instruction match. 
| : -NOP   0TH 100000 XOR IF  EXIT  THEN EAT ;                                                                                         
| : -SHORT ( - t)   157500 =IO  1+ ;                                   -NOP  kills no-op.  Some simplify thereby; mainly for 0< bug.   
                                                                       -SHORT  is true if the last instruction is not a short literal. 
| : -CY ( n - ~t)   200  SWAP OVER AND  XOR ;                                                                                          
| : ~100   100 MICRO ;      | : ~20   20 MICRO ;                       -CY  is nonzero if the 200 bit of the given number is zero.     
| : /ALU   0 PY3 500 AND MICRO  ~100 ;                                 ~100  and  ~20  twiddle the last instr, factored out for space. 
| : FLIP ( n - n)   100 10000 */MOD + ;                                /ALU  changes a ?FET instr. to or from an ALU type.             
| : -C ( n n - n t)   ?FULL AND  OVER -CY AND ;                        FLIP  reverses the effective arguments to the ALU operation.    
| : +ALU ( n)   7200 AND  /ALU MICRO ;                                 -C  are instrs with full arith capability and no carry used.    
   ( Literals)   OCTAL                                                 +ALU  appends ALU function to the last instruction.             
~ : LITERAL ( n)   -NOP  DUP -40 AND IF  147500                        LITERAL  compiles short and long literal forms; in addition, it 
         0 ?drop IF  EAT 100 XOR  THEN  ,C , EXIT  THEN                   recognizes the patterns  DROP n  @ n  and  ! n  that are     
      167100 =IO IF  600 XOR MICRO EXIT  THEN                             single instructions.                                         
      177000 =IO IF  700 XOR MICRO EXIT  THEN                                                                                          
   0 ?drop IF  EAT 100 +  THEN  BEGIN  157500 XOR ,C ;  TARGET         -LIT  "steals" a short literal from the preceding instruction,  
| : -LIT ( n n)   MICRO  AGAIN ;  RECOVER                                 given the literal value and what to change in the instruction
                                                                       /LIT  recovers the short literal from  DROP n  @ n  ! n .       
| : /LIT   0TH 37 AND  157400 =IO IF  107020 SET  0 -LIT EXIT                                                                          
   THEN  167700 =IO IF  DUP 600 OR  -LIT EXIT  THEN                                                                                    
      177700 =IO IF  DUP 700 OR  -LIT EXIT  THEN DROP ;                                                                                
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Primitives)   OCTAL                                                                                                               
FORTH : uCODE   ~ CREATE H,  TARGET  DOES>   -NOP  @ ,C ;              uCODE  are simple instructions that don't combine with preceding
                                                                       BIN  appends an ALU operation to any eligible instruction,      
FORTH : BIN ( n n)   uCODE  DOES> @  -NOP                                 changing stack activity and operation direction as necessary.
   0 ?swap IF  FLIP EAT  THEN                                          SHIFT permits modification of any ARITH instruction with ALU set
   0 ?over IF  1 -C IF  FLIP EAT ~100  +ALU EXIT  THEN                    for pass-T or any +- operation, given that Tmux is set for no
      1 ?swap IF  1 XOR FLIP  CLIP                                        transformation (pass).  This version insists that:           
         ELSE  1 ?over IF  1 XOR FLIP  EAT  ~20                              1.  0< may only append to pass-T, and makes trailing NOP. 
      THEN THEN  7300 AND 20 XOR MICRO  EXIT  THEN                           2.  2* may only append to pass T, adds, and subtracts.    
   0 ?LOW IF  1 ?dup IF  0 -C IF                                             3.  2/ may only append to pass T since only then is it    
      CLIP ~100  +ALU EXIT  THEN THEN THEN                                       a sign extending shift as we expect of 2/.            
   DUP 0 ?FULL  ROT -CY  0 PY3 AND OR  AND IF  +ALU EXIT  THEN               4.  &2/ is an interim kludge that MUST append to a pass T,
   FLIP 7200 AND  107020 XOR                                                     add, or subtract.  The discrepancy is that it will    
      0TH '2DUP = IF  EAT 100 XOR  THEN ,C ;                                     combine with pass-t; thus DUP and SWAP-DROP can have  
FORTH : SHIFT ( n)   uCODE H,  DOES>   2@                                        it which is no trouble.  HOWEVER we still lack the    
   0TH AND  100000 XOR IF  100000 XOR ,C EXIT  THEN MICRO ;                      mechanism to keep preceding +/- from combining with   
   ( Instructions)   OCTAL                                                       an earlier I/O, hence the diagnostic.                 
| 100120 uCODE dup   | 107020 uCODE drop  | 100020 uCODE nip           This block defines most of the generic instructions of the chip.
  107100 uCODE SWAP    107120 uCODE OVER                                                                                               
  100012 uCODE D2*     100011 uCODE D2/   | 104011 uCODE +D2/          D2*  shifts the actual ALU carry out from this cycle into N0.   
| 104411 uCODE *'    | 102411 uCODE *-    ( 102412 uCODE *F)              The result is generally garbage.                             
  102416 uCODE /'      102414 uCODE /''   ( 102616 uCODE S')           +D2/  takes a double whose low order must be zero; effects a    
  177300 uCODE ND!     100000 uCODE NOP                                   true logical shift down of one bit.  Can't be used twice.    
                                                                                                                                       
4141 BIN OR    2121 BIN XOR   6161 BIN AND                             ND!  is the store nondestructive of its data.                   
3131 BIN +     5111 BIN -     3333 BIN +c  ( 5313 BIN -c)                                                                              
                                                                       NOP  is a 1-clock no-op that passes T.                          
2 171003 SHIFT 2*   | 3 177003 SHIFT 0<                                                                                                
1 177003 SHIFT 2/   | 1 171003 SHIFT &2/                               &2/  is a right shift that will combine with a preceding arith- 
: 0<   \ 0<  \ NOP ;  TARGET                                              metic instruction to produce a + or - that shifts its result 
: &2/   +OPT  0TH 171003 AND  100000 XOR ABORT" op?"                      down 1 bit with carry shifted into the sign position.        
      \ &2/  -OPT ;  TARGET                                                                                                            
   ( Stack ops)   OCTAL                                                                                                                
~ : DUP   -NOP  0 ?drop IF  ~20 EXIT  THEN                             These definitions handle the myriad optimizable phrases that    
   0 ?nip IF  ~100 ~20 EXIT  THEN  150000 =IO                             end with the words  DUP  and  DROP .  It is somewhat ironic  
   157000 =IO  157200 =IO  OR OR IF  ~100 EXIT  THEN                      that the most complicated words known to the chip are those  
      140700 =IO IF  400 MICRO EXIT  THEN \ dup ;  TARGET                 that have been classically regarded as the very simplest we  
~ : DROP   -NOP  0 ?swap IF  1 ?ARI IF  1 INST 130 AND                    have!                                                        
         DUP 10 AND 0=  SWAP 20 XOR  AND IF  EAT                                                                                       
            0TH 177677 AND  20 XOR  DUP SET  3 AND                                                                                     
               3 = -EX  \ NOP EXIT  THEN THEN                                                                                          
      EAT  150300 =IO IF  ~100 EXIT  THEN                                                                                              
      157000 =IO IF  1 ?dup IF  CLIP 7000 MICRO EXIT  THEN THEN                                                                        
      0 ?FULL  0 PY3 OR AND IF  /ALU EXIT  THEN                                                                                        
         \ nip EXIT  THEN                                                                                                              
   0TH 147321 = IF   1 ?I@ IF  1 -I IF                                                                                                 
      EAT  ~20 EXIT  THEN THEN THEN                                                                                                    
   147300 =IO IF  7400 MICRO EXIT  THEN \ drop ;  TARGET                                                                               
   ( Memory)   OCTAL                                                                                                                   
| : FIX ( n)   157500 XOR  MICRO ;                                     These macros generate basic memory referencing instructions.    
: SHORT ( n)   +OPT /LIT  +OPT -SHORT ABORT" n?"  FIX -OPT ;                                                                           
                                                                       FIX  replaces everything but literal field of the preceding in- 
: @   /LIT  -SHORT IF  167100 ,C  EXIT  THEN                              struction with the given value.                              
   147100  1 ?drop IF  CLIP 100 XOR  THEN FIX ;  TARGET                SHORT  demands a preceding short literal and absorbs it with    
: !   /LIT  0 ?swap IF 1 ?over IF  EAT EAT \ ND! EXIT  THEN THEN          the given new instruction.                                   
   -SHORT IF  177000 ,C EXIT  THEN  157000 FIX ;  TARGET                                                                               
                                                                       @  and  !  absorb leading literals if they are simple & short.  
: !+   174700 SHORT ;  TARGET   : @+   164700 SHORT ;  TARGET                                                                          
: !-   172700 SHORT ;  TARGET   : @-   162700 SHORT ;  TARGET          Memory operations postfixed by an arithmetic operator are non-  
                                                                          destructive of the address, updating it with literal and op. 
: I@   /LIT  1 ?drop IF  CLIP 147700  ELSE 147300  THEN SHORT             The literal must have just been compiled.                    
   1 ?r>d -EX  0 ?I@ -EX  0 -I -EX  CLIP  ~20 ;  TARGET                                                                                
: I!   /LIT 157200 1 ?dup IF CLIP 7100 XOR  THEN SHORT ; TARGET        Internal access operators must be preceded by a literal.        
: I@!  157700 SHORT ;  TARGET                                                                                                          
   ( Macros)   OCTAL                                                                                                                   
: I   1 \ LITERAL  \ I@ ;  TARGET                                      While essentially primitives, these instructions are defined as 
: R>   21 \ LITERAL  \ I@ ;  TARGET                                       macros because they will get much more action out of the     
: >R   1 \ LITERAL  \ I! ;  TARGET                                        optimizer in that way.                                       
: DO(   21 \ LITERAL  \ I!  -CODE ;  TARGET                                                                                            
: )   -CODE ;  TARGET                                                                                                                  
                                                                                                                                       
: -1   3 \ LITERAL  \ I@ ;  TARGET                                                                                                     
: 1+   1 \ LITERAL  \ + ;  TARGET                                                                                                      
: 1-   1 \ LITERAL  \ - ;  TARGET                                                                                                      
~ : NEGATE   0 \ LITERAL  \ SWAP  \ - ;  TARGET                                                                                        
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Exits)   OCTAL                                                                                                                    
| : ?NEAR ( a - a t)   DUP HERE XOR  170000 AND 0= ;                   ?NEAR  is true if the address lies in the same page as HERE .   
                                                                       EXIT  optimizes returns by setting ; under the following cond's:
| : PACK ( n t)   -EX  40 XOR SET  R> DROP  -CODE ;                       1.  Any ari.   2.  Any 1-clock 14 that doesn't pop R.        
~ : EXIT   0TH  ?DUP IF  DUP 0< IF  0 ?ARI PACK  0 ?I@ PACK               3.  Any 1-clock 15 that doesn't store into I.                
         0 F5s  0 M46  0 -I OR  AND PACK                                  Calls within page are converted to jumps followed by nothing.
      ELSE  ?NEAR IF  7777 AND  130000 XOR  SET  -CODE EXIT               Specifically excluded are all 2-clock instructions since the 
   THEN  THEN DROP  THEN  100040 ,  -CODE ;  TARGET                          return doesn't work for these on the first mask.          
                                                                          Users may NOT ,C an instruction with exit set!!              
| : -MAGIC ( n - t)   DUP 160300 AND 140300 =                                                                                          
      OVER 170700 AND 150200 = OR -EX  DUP 20 AND                      -MAGIC  is true if the given instruction is insensitive to      
         OVER 17 AND 3 < OR -EX  0= ;                                     where it's executed from.  The failing cases are:            
                                                                             1.  Fetch or store to  JK , I , or P                      
                                                                             2.  Return stack activity or TIMES enabling.              
                                                                         This is used presently in ?DIR to determine whether a single  
                                                                            instruction can be safely substituted by the compiler.     
( Target compiler log)                                                                                                                 
: PAGE   PAGE  CR CR  5 SPACES  BASE @ DECIMAL                         This block may optionally be loaded in the Target Compiler.     
      TODAY @ .DATE  @TIME .TIME  2 SPACES  BASE ! ;                      See Block 45.  If loaded, it produces a map showing the      
: CR   L# @ 62 > IF  PAGE  THEN CR 5 SPACES ;                             target address of each word defined.  This map is of limited 
: HELP ( n)   PAGE ;                                                      usefulness on a CRT, but may be useful on a printing terminal
                                                                                                                                       
: LOAD ( n)   CR  DUP 0 <# #S #>  TYPE SPACE  LOAD ;                   LOAD  re-defines  LOAD  to display the block number.            
: THRU ( f l)   1+ SWAP DO  I LOAD  LOOP ;                             THRU  similarly displays each block number.                     
                                                                       LOG  types the name and address of a target word being defined. 
: LOG ( a - a)   BASE @ OCTAL  OVER 0  <# #S #>  DUP                      It detects the end of a line and performs an automatic  CR . 
   AHEAD BYTE C@ +  C# @ + 2 +  79 > IF  CR SPACE  THEN                HELP  avoids re-displaying the Target Compiler's help screen,   
   TYPE SPACE  AHEAD COUNT TYPE  SPACE  BASE ! ;                          as it's an inappropriate part of a log.                      
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Data Base Support)   ( EMPTY)   DECIMAL                                                                                              
: WORKING ( - a)   H 1+ @ ;                                               This is the principal load block for the Data Base Support   
                                                                       option.  It is required by any application that needs a simple, 
( USER variables)  123 LOAD   ( 2BLOCK)  122 LOAD                      organized method of managing data.                              
( Files)  126 127 THRU      ( Fields)  129 130 THRU                       If most tasks use it, it should be loaded by block 9 after   
( Subtotaling)  131 LOAD                                               switching out of low RAM.  Otherwise, applications that need it 
                                                                       should say  FILES LOAD .  Whenever more than one task is able to
VARIABLE ORDERED  ( Needed only for ordered indexes)                   access files at the same time, at least  ORDERED  should be def-
( Ordered index)  135 136 THRU   ( Chains)  137 LOAD                   ined under GOLDEN to serialize index updating.                  
( Reports)  132 134 THRU                                                  This file package supports only 16-bit record and block nos. 
( Directory)  121 LOAD                                                                                                                 
                                                                       WORKING  Returns the address of the working storage area used   
( FORTH GILD)                                                             by Ordered Indexes and Subtotaling.  Note that sufficient    
                                                                          space must be  ALLOTted  following an  EMPTY  if either of   
                                                                          these features are to be used.                               
                                                                       ORDERED  is a facility variable that controls access to         
( Bytes  records  blocks  origin        name      free   at)              ordered indexes during search and updating operations.       
(  1024        8       8       0        TARGET)                           This block describes the layout of the file area of the disk.
(  1024      352     352       8        SOURCE)                        On large hard disks, it's usually most convenient to reserve two
(  1024        8       8     360        TARGET BKUP)                   or more logical drives at the front for source and backup, then 
(  1024      352     352     368        SHADOW)                        start the file area.  On floppy based systems you must be more  
                                                                       stingy with space.  The comment lines at the beginning describe 
      8     8132      64    3600  FILE  EARTH                          the use of disk for program source and binary, neither of which 
                          ( 3664)                                      involves files.  All files should be defined here, and all other
                                                                       allocations of disk documented here for good management of disk.
                                                                          The two files defined here are examples of the use of  FILE  
                                                                       for and indexed mailing list.                                   
                                                                                                                                       
                                                                          The version of  RECORD  in block 126 subtracts OFFSET out of 
                                                                       block numbers being used to access files; as a result, disk     
                                                                       origins of these files are ABSOLUTE and insensitive to OFFSET   
                                                                       changes.  This is not always desired; change  RECORD  if not.   
   ( 32-bit block numbers)   HEX                                       Similar attention needs to be paid  INITIALIZE  in block 125.   
: 2IDENTIFY   [ ' IDENTIFY 1+ @  0FFF AND 'ROM + ,C ] ;                This block makes the 32-bit disk access words accessible; they  
: 2BLOCK   [ ' BLOCK 1+ @  0FFF AND 'ROM + ,C ] ;                         are headless in the PROM to save space.                      
: 2BUFFER   [ ' BUFFER 1+ @  0FFF AND 'ROM + ,C ] ;                                                                                    
                                                                                                                                       
OFFSET 1- STATUS -  USER 2OFFSET                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Additional USER variables)                                                                                                        
: USER ( n)   CREATE  -1 ALLOT  U \ LITERAL  \ @                          These user variables are used by FORTH, Inc.'s Data Base     
      ?DUP IF  \ LITERAL  \ +  THEN  \ EXIT ;  ( 4-6)                  Support System.                                                 
 98 USER F#     99 USER L/P   100 USER P#                                                                                              
101 USER #COL  102 USER RPT   103 USER HEAD                               If you are using DBSS, please note that  F#  here directly   
   ( 128 available)                                                    follows  R# .  This feature is utilized by several commands.    
                                                                                                                                       
( Operator)  24 L/P !                                                                                                                  
( Printer   63 TYPIST L/P HIS !)                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Comma output)                                                                                                                     
: D-D ( d - d)   #  2DUP D0= IF  R> DROP  THEN ;                       This block contains examples of pictured output conversions with
: #, ( d - d)   BEGIN  D-D  D-D  D-D  44 HOLD  AGAIN ; RECOVER            comma insertion and floating dollar signs.                   
: (D,)   SWAP OVER DABS  <#  #,  SIGN #> ;                                                                                             
: (D$,)  SWAP OVER DABS  <#  # # 46 HOLD  #, 36 HOLD  SIGN #> ;        D-D edits a digit from the number and exits the calling defin-  
                                                                          ition if the remaining number is zero.                       
: D,. ( d)   (D,) TYPE SPACE ;                                         #, exhausts all remaining digits from the number with commas.   
: ,. ( n)   DUP 0< NEGATE  (D,)  TYPE SPACE ;                          (D,) edits the signed number with commas every three digits.    
: D,R ( d n)   >R  (D,)  R> OVER - SPACES TYPE ;                       (D$,) edits signed integer cents with commas and floating $ sign
: ,R ( n n)   >R  DUP 0< NEGATE  (D,)  R> OVER - SPACES TYPE ;                                                                         
                                                                       ,. and D,. display single and double integers with commas.      
: D$, ( d)   (D$,) TYPE SPACE ;                                        ,R and D,R right-justify single and double integers with commas.
: $, ( n)   DUP 0< NEGATE  (D$,)  TYPE SPACE ;                                                                                         
: D$,R ( d n)   >R  (D$,)  R> OVER - SPACES TYPE ;                     $, and D$, display single and double cents with commas and $.   
: $,R ( n n)   >R DUP 0< NEGATE  (D$,)  R> OVER - SPACES TYPE ;        $,R and D$,R right-justify single and double cents with commas  
                                                                          and $.                                                       
   ( Privileged file operators)                                                                                                        
: #B ( nr b/r - nb)   1024 SWAP /  DUP 1- ROT +  SWAP / ;              This block is not routinely loaded.  It is used only when a new 
: #R ( nb b/r - nr)   1024 SWAP / * ;                                     file is being allocated and initialized.                     
                                                                                                                                       
: STOPPER   1 RECORD 1+  W/R @ 1-  -1 WFILL UPDATE ;                   #B  and  #R  are useful in determining how many blocks a file   
: INITIALIZE   ORG @  LIM @  W/R @ 2* #B +  ORG @ DO                      will require and how many records will fit in a range of     
      ( absolute)  I 0  2OFFSET 2@ D- 2BUFFER                             blocks.  Note that they are the converse of each other.      
   ( I BUFFER) 512 ERASE  UPDATE  LOOP  STOPPER ;                      STOPPER initializes a record to all "high values".  This is     
                                                                          required for Ordered Indexes, but is harmless for other files
                                                                          since the first  SLOT  will clear the record.                
                                                                       INITIALIZE erases the entire file to zeroes, except for the     
                                                                          STOPPER  in record 1.                                        
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( File definition & access)                                                                                                            
: SAVE   R>  R# 2@ 2>R  >R ;                                           SAVE  and  RESTORE  allow temporary use of a different file &   
: RESTORE   R>  2R> R# 2!  >R ;                                           record combination.  Since the Return Stack is used for      
                                                                          temporary storage, they must be used in the same definition  
~ : FILE ( b r n o)   CREATE ,  DROP ,  2/ DUP ,                          and at the same level with respect to any  DO  structure.    
      512 OVER / * ,  DOES>  F# ! ;                                       Note also that these words presume that  USER  variables  R# 
: (FILE) ( n)   CREATE ,  DOES> ( - a)   @  F# @ + ;                      and  F#  are adjacent.                                       
0 (FILE) ORG   1 (FILE) LIM   2 (FILE) W/R                             FILE  is used in block 121;  refer there for arguments & usage. 
                                                                       ORG , LIM , and  W/R  return parameters for the "current file"  
: SAFE ( n - n)   DUP LIM @ U<  1+ ABORT" Outside file" ;                 (i.e., the one selected by the use of its name, whose address
: READ ( n)   SAFE R# ! ;                                                 is in  F# ).  W/R  is words per record followed by active    
: RECORD ( n - a)   W/R 2@  SWAP */MOD  ORG @ +  ( BLOCK + ;)             words per block.                                             
      ( absolute)  0  2OFFSET 2@ D-  2BLOCK + ;                        READ  is a slightly misleading name, as it doesn't perform an   
                                                                          actual disk operation, but merely selects the current record.
                                                                                                                                       
                                                                       RECORD  is used to perform the actual disk I/O for the field    
   ( Record allocation)                                                   operators in Block 129.  Returns a CELL address!             
: AVAILABLE ( - a)   ORG @  BLOCK ;                                    AVAILABLE  contains the last assigned record#.  It will be      
: CHUNK ( n - r)   >R  AVAILABLE @ DUP  BEGIN  I +  LIM @ MOD             accurate for files managed by  SLOT  and  +ORDERED .         
      2DUP = ABORT" File full"  DUP RECORD  DUP @ WHILE                                                                                
   DROP REPEAT  DUP W/R @ R> * ERASE  -1 SWAP !  UPDATE                These words follow the convention that a record is "available"  
   DUP AVAILABLE !  UPDATE  SWAP DROP ;                                   if its 1st cell contains 0.  Fresh records are supplied with 
: SLOT ( - r)   1 CHUNK ;                                                 the first cell set to -1.                                    
                                                                       CHUNK allows fixed-length groups of shorter records.  All chunks
: SCRATCH ( r)   SAFE RECORD  0 SWAP !  UPDATE ;                          in a file must be the same size.  It returns the record# of  
                                                                          the 1st record in the group.                                 
~ : RECORDS ( l f)   AVAILABLE @ 1+  1 ;                               SLOT is used far more often than  CHUNK , allocating single     
: WHOLE ( l f)   LIM @ 1 ;                                                records.  The assigned record is cleared to zeroes.          
                                                                       SCRATCH de-allocates the record, but doesn't destroy its        
                                                                          contents except for the 1st cell.                            
                                                                       RECORDS returns loop values for an Ordered Index or other file  
                                                                          which has never "wrapped around".                            
                                                                       WHOLE returns loop values for the entire file.                  
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Field operators)                                                                                                                  
: ADDRESS ( a - a')   WORKING -  R# @ RECORD + ;                       These words operate on fields within records.  To access:       
: BADDRESS ( b - b')   WORKING BYTE -  R# @ RECORD BYTE + ;               Data type        in WORKING      in block buffers   use:     
                                                                            Number         @   !           N@  N!                      
: S@ ( n b)   CORE ROT CMOVE ;                                              Double         2@  2!          D@  D!                      
: S! ( n b)   CORE SWAP ROT CMOVE ;                                         1byte          C@  C!          1@  1!                      
: S. ( n b)   DROP CORE SWAP -TRAILING TYPE ;                               Bytes          S@  S!          B@  B!                      
                                                                                                                                       
: N@ ( a - n)   ADDRESS @ ;   : N! ( n a)   ADDRESS ! UPDATE ;         PUT moves the remainder of the input stream to the given field, 
: D@ ( a - d)   ADDRESS 2@ ;  : D! ( d a)   ADDRESS 2! UPDATE ;           left justified and blank filled.                             
: B@ ( n b)   BADDRESS S@ ;  : B! ( n b)   BADDRESS S! UPDATE ;        ASK expects a string and puts it in the given field.            
: 1@ ( b-n)   BADDRESS C@ ;  : 1! ( n b)   BADDRESS C! UPDATE ;                                                                        
( Rel 0 PROM)   : N!   COMPILE [ ' N! ,C ] \\ ;  IMMEDIATE             NOTE CAREFULLY which of these operators deal with byte addresses
                                                                          Historically the selection used in the file package has been 
: PUT ( n b)   124 TEXT  B! ;                                             the most convenient compromise on cell addressed machines.   
: ASK ( n b)   QUERY  PUT ;                                                                                                            
   ( Fields within records)                                                                                                            
: 1BYTE ( b)   CREATE  ,  DOES> ( - b)   @  WORKING BYTE + ;           Field definitions take a byte offset "b" within the record that 
: NUMERIC ( b)   2/ 1BYTE  DOES> ( - a)   @  WORKING + ;                  must be explicitly specified in each declarative phrase.     
: DOUBLE ( b)   NUMERIC ;                                                                                                              
: BYTES ( b n)   SWAP 1+ -2 AND  1BYTE ,                               EVEN forces its argument to be even by rounding up.             
      DOES> ( - n b)   2@  WORKING BYTE + ;                            1BYTE defines a 1-byte field, which may lie on a byte boundary. 
: FILLER ( b n)   2DROP ;                                              NUMERIC and DOUBLE define 16- and 32-bit numeric fields.  They  
                                                                          must lie on cell boundaries.                                 
: ENTIRE ( - n a)   W/R @ WORKING ;                                    BYTES defines a field that is a string of characters.  Lengths  
: BENTIRE ( - n b)   W/R @ 2*  WORKING BYTE ;                             and offsets of BYTES fields must be even.                    
0   NUMERIC LINK                                                       ENTIRE gives the entire record in WORKING as a cell string.     
                                                                       BENTIRE gives the entire record in WORKING as a BYTES field.    
: N? ( a)   N@ . ;      : D? ( a)   D@ D. ;                            FILLER reserves unnamed space in a record.                      
: 1? ( b)   1@ . ;                                                     LINK is the name of a numeric field at the start of a record.   
: B? ( n b)   OVER SWAP B@  CORE SWAP -TRAILING TYPE SPACE ;           N? ,  D? ,  1? ,  and  B?  are used to display their appropriate
                                                                          types of fields from the current record in as many characters
( Subtotaling)                                                            as needed, with a trailing space.                            
: REGISTER ( - a)   WORKING 8 + ;                                      REGISTER returns the address of the beginning of the sub-total  
: D+! ( d a)   >R  I 2@ D+  R> 2! ;                                      registers, normally in  WORKING .  Two cells plus 4 for each  
: REG ( - a)   REGISTER 2@ MOD 2 +  DUP REGISTER 1+ !                    total (subtotal & grand total, 32-bits ea.) must be allotted. 
   REGISTER + ;                                                        D+! adds a 32-bit value to the contents of an address.          
                                                                       REG returns the address of the next 32-bit register, treating   
: ZERO ( n)   2*  REGISTER  OVER 2 + 2* ERASE  REGISTER ! ;               the registers (as many as specified by  ZERO ) in a circle.  
: SUM ( d n)   2*  REGISTER +  D+! ;                                   ZERO initializes the subtotaling registers, given the number of 
: FOOT ( d - d)   2DUP REG  D+! ;                                         32-bit columnar totals to be maintained.  Must be used at the
                                                                          beginning of a report using this feature.                    
: SUB ( - d)   REG DUP >R  2@  2DUP REGISTER @ I + D+!                 SUM adds a 32-bit number to the sub-total register whose one-   
   0. R> 2! ;                                                             relative number is given.                                    
: GRAND   REGISTER @ >R  REGISTER 2 +  DUP I +  SWAP R> MOVE ;         FOOT is like  SUM , but uses the next register, and returns a   
                                                                          copy of the value.                                           
                                                                       SUB returns the next subtotal, leaving that register cleared    
                                                                          and adding the sum to the associated grand total.            
( Report formatting)                                                   GRAND copies the grand totals to the subtotals.                 
: 0COL   RPT @ 2 +  #COL ! ;                                           0COL resets the column pointer to the 1st column.               
: +L   CR  0COL ;                                                      +L performs a  CR  and increments the line counter.             
: COL ( - n)   1 #COL +!  #COL @ ;                                     COL returns the address of the next column width.               
: COLS ( - n)   COL @  ?DUP 0= IF  +L  COL @  THEN ;                   COLS returns the next column width.                             
                                                                       .TEXT given an ASCII code, reads forward in the input stream    
: .TEXT ( c)   WORD  COUNT 1+ TYPE ;                                      and types the string terminated by that delimiter.  Used to  
: HEADING ( a)   RPT !  >IN 2@  RPT @ 2@  >IN 2!  92 ( \) .TEXT           output titles & headings from disk.                          
   +L  93 ( ]) .TEXT  >IN 2!  +L ;                                     HEADING given the address of a title-heading table, outputs     
: TITLE   RPT @ HEADING ;                                                 the title and heading, and saves the address of the table to 
                                                                          control future columnar output.                              
: [R ( - a)   HERE  >IN 2@ , ,  ['] TITLE ,  93 ( ]) WORD DROP         TITLE outputs the current title/heading pair.                   
   >IN @  OVER @  >IN !  92 ( \) WORD DROP  >IN @ 1+                   [R  Constructs a title-heading table, and returns its starting  
   BEGIN  32 WORD DROP  >IN @  SWAP OVER  SWAP - ,                        address.                                                     
      OVER >IN @ < UNTIL  2DROP  -1 HERE 1- +!  0 , ;                  NOTE: This version of the Report Generator assumes the source of
                                                                          the application is available while it is running.  If you    
   ( Page formatting)                                                     need a Target Compilable version, phone FORTH, Inc.          
: SKIP   COLS SPACES ;                                                 SKIP skips one column.                                          
: SKIPS ( n)   0 DO  SKIP  LOOP ;                                      SKIPS skips a specified number of columns.                      
: RIGHT ( a n)   COLS OVER -  DUP 0< IF  1-  #COL @  DUP >R @          RIGHT types a string right-justified in the next report column. 
   OVER - I !  I 1+ @ + 0 MAX  R> 1+ ! 1  THEN SPACES TYPE ;              Used like  TYPE .                                            
: ?CRT ( - t)   L/P @ 60 < ;                                           ?CRT  determines whether the device in use is a terminal as     
: +PAGE   ( CR) PAGE  1 P# +!  ?CRT 1+ IF  +L +L  +L  THEN                opposed to a hard copy device.  Change the clue if needed.   
   ." FORTH, Inc."  45 SPACES                                          +PAGE performs the new-page functions for the report generator. 
   ." Page "  P# ?  2 SPACES  TODAY @ .DATE  +L                           To customize for your installation, edit  this definition    
   20 SPACES  RPT @ 2 + @EXECUTE ;                                        appropriately.                                               
                                                                       ?PAGE given a number of lines, goes to the next page if there   
: ?PAGE ( n)   L# @ +  L/P @ < IF  +L  ELSE  ?CRT IF                      aren't at least that many left on the current page.          
      KEY 32 - IF  ORDERED RELEASE  0 HERE !  1 ABORT" ?"                 Performs a  +L .                                             
   THEN THEN  +PAGE  THEN ;                                            +CR  performs a  CR  and checks for page-full.                  
: +CR   1 ?PAGE ;                                                      LAYOUT specifies that the title-heading table whose address is  
: LAYOUT ( a)   RPT !  0 P# !  +PAGE ;                                    given is the one for this report, and initializes the first  
   ( Report generator output)                                             page of the report.                                          
: .N ( n)   (.) RIGHT ;                                                .N  outputs a 16-bit number in the next report column.          
: .D ( d)   (D.) RIGHT ;                                               .D  outputs a 32-bit number in the next report column.          
: ?N ( a)   N@ .N ;                                                    ?N  fetches the contents of a specified  NUMERIC  field and     
: ?1 ( b)   1@ .N ;                                                       outputs it in the next report column.                        
: .S ( n b)   DROP CORE  SWAP  RIGHT ;                                 ?1  fetches the contents of a specified  1BYTE  field and       
: ?B ( n b)   2DUP B@  CORE C@ IF  .S  ELSE  2DROP SKIP  THEN ;           outputs it in the next report column.                        
                                                                       .S  outputs a specified  BYTES  field from  PAD .               
: .M/D/Y ( n)   ?DUP IF  (DATE) RIGHT  ELSE  SKIP  THEN ;              ?B  fetches the contents of a specified  BYTES  field and       
                                                                          outputs it in the next report column.                        
                                                                                                                                       
                                                                       .M/D/Y  given a Julian date, outputs it in the next report      
                                                                          column.  This works with either calendar, but most data base 
                                                                          applications prefer the mm/dd/yy calendar.                   
                                                                                                                                       
                                                                                                                                       
( Ordered Index updates)                                                                                                               
: RSWAP ( n a ra - n a)   MD I!  OVER 1- >R  DUP BEGIN                 These are the tools that modify Ordered indexes.                
      0 @+  MD I@!  0 @+  >R SWAP R>  1 !+  MD I@!  1 !+                                                                               
   NEXT  DROP ;                                                        RSWAP  swaps two cell strings.  Used to swap the record         
                                                                          in  WORKING  with one in the file.                           
: DIRECTION ( n - n a rl rf)   AVAILABLE +! UPDATE                                                                                     
      ENTIRE  AVAILABLE @ 2 +  SAFE R# @ ;                             DIRECTION  adjusts  AVAILABLE  depending upon the parameter:    
: +ORDERED   1 DIRECTION DO  I RECORD RSWAP UPDATE  LOOP                  1 indicates an insertion, -1 indicates a deletion.           
      2DROP  ORDERED RELEASE ;                                            It then returns the parameters for the loop that will        
: -ORDERED   ENTIRE SWAP ERASE  -1 DIRECTION SWAP DO                      update the index.                                            
      I RECORD RSWAP UPDATE  -1 +LOOP  2DROP  ORDERED RELEASE ;        +ORDERED  inserts the record in  WORKING  before the record     
                                                                          indicated by  R#  in an ordered index.                       
                                                                       -ORDERED  deletes the record to which  R#  points from an       
                                                                          ordered index.                                               
                                                                                                                                       
                                                                                                                                       
   ( Binary search)                                                                                                                    
: -BINARY ( n b - t)   ORDERED GET                                     -BINARY  performs a binary search on an ordered index, given:   
   CELL SWAP 1+ 2/  AVAILABLE @ 2/ 1+  DUP READ  BEGIN                    BYTES  field parameters (length, addr) on the stack          
      DUP 1+ 2/  2OVER OVER ADDRESS  -TEXT 0 > IF  NEGATE  THEN           A key in  WORKING  in the field specified                    
   NEGATE R# +!  2/ DUP 0= UNTIL  DROP  2DUP OVER ADDRESS                 F#  indicates the desired ordered index file.                
      -TEXT 0 >  NEGATE R# +!  OVER ADDRESS -TEXT ;                       Returns  R#  set to the record that the key should precede,  
                                                                          and "true" if an exact match was not found.  Note the two    
: BINARY ( n b - r)   -BINARY  ORDERED RELEASE  ABORT" Unknown"           phrases reading  -TEXT 0 > .  In cases of non-unique keys,   
      LINK N@ ;                                                           these arrange for  -BINARY  to find the key with the lowest  
                                                                          record number, and therefore new matching keys will be inser-
                                                                          ted in front of older keys.                                  
                                                                                                                                       
                                                                       BINARY  is used like  -BINARY , with the difference that, having
                                                                          performed the search, it will abort if a match is not found. 
                                                                          Otherwise, it returns the record number of the main file     
                                                                          record associated with the index record found.               
( Chained records)                                                                                                                     
: SNATCH ( a r - r)   OVER N@  SWAP ROT N! ;                           This block supports chains of records attached to a 'head' .    
: FIRST ( - t)   HEAD @ READ ;                                            This facility corresponds roughly to  CODASYL  "sets".       
: -NEXT ( - t)   LINK N@  0 OVER  < IF  READ 1 THEN  1- ;              SNATCH  takes a field address and record number.  It fetches    
                                                                          the record number from that field, replacing it with the     
: -LOCATE ( - r t)  1+ FIRST BEGIN  1- DUP WHILE -NEXT UNTIL              record number given.  It is used to update chains.           
   THEN ;   ( Returns nth record & 0 or true)                          -NEXT  reads the next record, assuming the chain is linked      
                                                                          through  LINK , returning 'true' if there is another.        
: CHAIN ( n)   -LOCATE DROP   ( nth record or end)                     FIRST  reads the 'head' record, returning 'true' if there are   
   SLOT LINK OVER  SNATCH  SWAP READ  LINK N! ;                           records appended to it through  LINK .                       
                                                                       -LOCATE  searches a chain for the  nth  record, returning 'true'
: UNCHAIN ( n)   DUP 0= ABORT" won't"  -LOCATE ABORT" can't"              if the chain isn't that long, in which case  R#  is at the   
   SAVE  LINK N@ READ  LINK 0 SNATCH  RESTORE  LINK N! ;                  end of the chain.                                            
                                                                       CHAIN  inserts a new record at the  nth  position or the end.   
                                                                       UNCHAIN  removes the  nth  record from the chain.               
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Compiler enhancements)                                                                                                               
: ?NOT ( - t)   0 ?CODE @  DUP IF  @  ['] 0= =  THEN ;                 This block extends the compiler with further optimizations:     
                                                                                                                                       
: IF ( - a)   ?NOT IF  -1 ALLOT  \ IF  \ ELSE  EXIT                    0= IF  or  NOT IF  are changed into  IF ELSE .  This saves lots 
      THEN  \ IF ;  IMMEDIATE                                             of time at no cost in space, making the 0= test in this case 
~ : WHILE ( a - a a)   \ IF  SWAP ;  IMMEDIATE                            no more expensive than 0< .  Similar transformations are done
~ : UNTIL ( a)   ?NOT IF  \ IF DROP  -1 ALLOT  \ AGAIN EXIT               for  WHILE  and  UNTIL .                                     
      THEN  \ UNTIL ;  IMMEDIATE                                                                                                       
                                                                       )  performs further checking to verify that only one single cell
: )   3 ?CODE  1 @- 1 @- 1 @-  @ >R  OR OR                                instruction has been recently generated.  This covers most of
   HERE R> - 1- OR ABORT" illegal"  \ ) ;  IMMEDIATE                      the possible simple mistakes in using  DO( .                 
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Byteswap files)   EMPTY                                                                                                              
: FLIP ( a n)   1- FOR  DUP @ ><  SWAP 1 !+  NEXT DROP ;                                                                               
                                                                                                                                       
: ONE ( n)   BLOCK 512 FLIP  UPDATE ;                                                                                                  
: MANY ( f l)   FLUSH SWAP DO  I NB @ MOD 0= IF FLUSH  THEN                                                                            
      I ONE  LOOP  FLUSH ;                                                                                                             
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Classical loops)                                                                                                                     
: DO   COMPILE 2>R  [COMPILE] BEGIN ;  IMMEDIATE                       This block defines the classical looping primitives provided in 
: LEAVE   R> R>  R> DROP  DUP >R  >R >R ;  ( 8)                           polyFORTH systems.  Since they consume twice as much return  
                                                                          stack and take more than ten times as long as does the basic 
: +loop ( n)   R> MD I!  DUP R> +  DUP I -  SWAP >R XOR                   FOR/NEXT construction supported by the hardware, they should 
   0< IF  MD I@ >R  EXIT  THEN  R> DROP R> DROP  MD I@ 1+ >R ;            be avoided in any time critical coding.  However we have pro-
~ : +LOOP   COMPILE +loop  \ AGAIN ;  IMMEDIATE  ( 12-15)                 vided them since this avoids the need to convert code that   
                                                                          is NOT time critical, and will facilitate conversions in     
: /loop ( n)   R> MD I!  R> +  I OVER SWAP - &2/  0< IF                   general by allowing you to delay the optimization of your    
      >R  MD I@ >R EXIT  THEN  R> DROP  DROP MD I@ 1+ >R ;                loops until you have time to get around to it.               
~ : /LOOP   COMPILE /loop  \ AGAIN ;  IMMEDIATE  ( 13-14)                                                                              
                                                                       Note:  PDP-11/73 SOB instruction running out of cache executes  
: loop   R>  R> 1+  I OVER SWAP - &2/  0< IF                              in about 1.34 uSec, which is comparable with these timings!  
      >R  >R EXIT  THEN  R> DROP  DROP  1+ >R ;                           Considering that SOB is basically the same instruction as    
~ : LOOP   COMPILE loop  \ AGAIN ;  IMMEDIATE  ( 11-13)                   the 1-clock hardware loop on the chip, this ratio should     
                                                                          tell you something.                                          
( FORTH 83 compatibility)   DECIMAL                                                                                                    
CREATE stack  256 ALLOT                                                These words are not used in the system or FORTH, Inc.  applic-  
: PICK ( n - n)   >R  stack I DO( 1 !+ )                                  ation packages.  They are included for compatibility with    
      1- DUP @  MD I!  R> DO( 1 @- ) DROP  MD I@ ;  ( 18+2n)              other systems, and closely approximate words in the FORTH-83 
: ROLL ( n)   >R  stack I DO( 1 !+ )  1-  1 @-  SWAP MD I!                Standard.                                                    
      R> DUP IF  1- DO( 1 @- ) DROP  MD I@ EXIT  THEN                                                                                  
   DROP DROP  MD I@ ;  ( 20+2n)                                        PICK  fetches a copy of the nth item on the stack.  0 PICK = DUP
                                                                          1 PICK = OVER .  NEVER use with n>255.                       
: R@ ( - n)   \ I ;  IMMEDIATE                                         ROLL  rotates the top n stack items.  2 ROLL  is equivalent to  
: SAVE-BUFFERS   FLUSH ;                                                  ROT ;  1 ROLL  is equivalent to  SWAP .  While PICK is highly
                                                                          inefficient on the chip, ROLL is quite the opposite.         
: D.R ( d n)   >R  (D.)  R> OVER - SPACES  TYPE ;                                                                                      
: D= ( d d - t)   D- D0= ;                                             R@  is identical to  I .                                        
                                                                       SAVE-BUFFERS  is identical to  FLUSH .                          
( More)  143 LOAD 300 LOAD ( GRC F83 Extensions )                                                                                      
                                                                       D.R  types a 32-bit number right-justified in a field.          
   ( More 83-standard)                                                 D=  returns 'true' if two 32-bit numbers are equal.             
: 0> ( n - t)   0 > ;                                                  Here are some more words that we don't normally define, or that 
                                                                          we don't ordinarily call by the 83-standard names.           
: CMOVE> ( s d n)   <CMOVE ;                                           >BODY  is nominally standard; for simple data types except short
: UM* ( u u - d)   U* ;                                                   constants or others that compile single instructions, >BODY  
: UM/MOD ( du u - ur uq)   U/MOD ;                                        will properly convert the address returned by  tic  to point 
                                                                          at the true parameter field of the word.  Note that this is  
: >BODY ( a - a)   1+ ;                                                   not true of straight colon definitions, since there is not a 
: SPAN ( - a)   CNT ;                                                     "code field" per se for such.  However for most uses this is 
                                                                          probably what was intended.                                  
: FORTH-83   ;                                                                                                                         
                                                                       FIND  is absent because its underpinnings happen to be headless.
                                                                                                                                       
                                                                       Some additional '83 incompatabilities exist; many are documented
                                                                          in the Supplement.  Major intentional deviations include the 
                                                                          behavior of DO/LOOP and LEAVE; structure implementation; the 
( Add SCSI to PC system)   EMPTY   HEX                                    stack effects of SIGN; and the behavior of NOT.              
VARIABLE CP   VARIABLE STS                                             This block, when loaded, adds SCSI capability to the PC-depend- 
: ACK   0 1 E001 1 !-  BEGIN  DUP @ 0< 1+ UNTIL  1+ ! ;                   ent version of novixFORTH for the Beta board.  It's config-  
: ENSLAVE   E000 BEGIN  BEGIN  DUP @ 0< WHILE                             ured for the same controller and drive combination that is   
      DUP @  DUP 1 AND IF  2 AND IF  DUP @ 4 AND IF  ACK                  recommended for the full blown Beta computer.  Unlike the    
            DROP EXIT  THEN  DUP 2 + @ ACK  3 AND  STS !                  communications protocol used with the PC, this I/O facility  
         ELSE  DUP 2 + @ ACK  MD I@  DUP 1+ MD I!                         imposes no timing restrictions when used in a multiprogramm- 
            DUP 1 AND IF  >R  0FF AND  SR I@ OR  R> 2/ !                  ing environment.  This is one major reason for preferring the
               ELSE  DROP  FF00 AND  SR I!  THEN  THEN                    native disk and straight serial terminal environment on the  
      ELSE  2 AND IF  CP @  DUP 1+ CP !                                   -P processor with its lack of interrupt capability.          
            ELSE  MD I@  DUP 1+ MD I!  THEN                                                                                            
         DUP 1 AND IF  2/ @  2* 2* 2* 2*  2* 2* 2* 2*                  WARNING!  For max transfer rates, the byte addresses used here  
            ELSE  2/ @  FF00 AND  THEN  E003 !  ACK                       are NOT masked after shifting down.  Thus, the host adapter  
   THEN REPEAT  MD I@  SR I@  PAUSE  SR I!  MD I! AGAIN ;                 may NOT be used for packets, data, or status that lies in    
                                                                          memory above 7FFF as a byte address.  Since we're putting    
( Rest)  DECIMAL 145 146 THRU  33 LOAD   FORTH GILD                       our buffers and so on in low memory this is cool.  Anyone who
   ( SCSI host)   HEX                                                     needs to do direct I/O at higher addresses must add masking. 
: DELAY ( n)   DO( NOP ; ( n+4)                                        For courtesy in multiprogrammed systems, ENSLAVE pauses whenever
: RST   0 4 E001 0 !+  0C8 DELAY !  18F FOR 1F40 DELAY NEXT ;             the controller doesn't come right back with REQ.  This will  
: SEL   0 2 100 E003 3 !-  BEGIN  DUP @ 2* 0< 1+ UNTIL                    happen naturally when there's no activity on the bus and thus
   1+  1 !-  BEGIN  DUP @ 4000 AND UNTIL  1+ ! ;                          no reason to camp tightly on it for a while.  In extreme     
                                                                          cases the WHILE REPEAT could become an UNTIL enclosing the   
VARIABLE TBL  5 ALLOT                                                     code that safely does the PAUSE.  This might occur for exam- 
: SCSI ( a n f m - a)   TBL 2 +  2 !-  1 !+  1 !-                         ple when logging data to disk, although the disk transfer    
   2* CP !  DUP 2* MD I!  SEL ENSLAVE ;                                   rate thus sustainable will be quite disappointing.  There is 
                                                                          indeed no such thing as a free lunch.  On writes, pad may    
                                                                          need to be added for high speed processors.                  
                                                                                                                                       
                                                                       For speed, we assume that all input transfers involve an even   
                                                                          number of bytes.                                             
                                                                                                                                       
                                                                                                                                       
   ( 10980 block hard, 360 block floppy)   HEX                                                                                         
: HOME   RST RST  CONFIGURATION  0 C200 0 SCSI  0 100 0 SCSI           This driver supports an OMTI 5400 series SCSI disk controller.  
   5 + 0 C040 098B SCSI  0 C240 0 SCSI  DROP ;   DECIMAL               HOME  configures the controller for a TEAC SD-510 hard disk on  
                                                                          logical unit zero and a TEAC FD-55B-20-U floppy disk drive   
600 CONSTANT HARD   HARD 10800 + CONSTANT FLOPPY                          on logical unit 2.  Minor changes may be made at  hi  time   
: I/O ( a n f - a)   >R  10800 2DUP U< IF                                 by storing into the CONFIGURATION table in RAM.  No claims   
      DROP R> 10  ELSE  - 2*  R> 64 +  11  THEN                           are made that the support in PROM will work for any other    
   CONFIGURATION + @ SCSI  STS @ DISK 1+ ! ;                              controller/drive combination.                                
                                                                       Hard = 305 tracks, 4 heads, 9 1k sectors/track                  
: PLEAT ( n n - n t)   2DUP U< IF  DROP 0 EXIT  THEN - 1 ;                Precomp at 128  10980 blocks total, 10800 used.              
: (BUFFER) ( d - d a)   ?UPDATED DROP                                  Floppy = 40 tracks, 2 heads, 9 512 sectors/track, no precomp.   
   HARD PLEAT IF  2560 I/O EXIT  THEN  Tell ;                             360 blocks total (720 sectors).  Starts 10800 blocks past the
: (BLOCK) ( d - a)   ?ABSENT  'BUFFER @EXECUTE  >R OVER R> SWAP           hard disk.                                                   
   HARD PLEAT IF  2048 I/O  ELSE  Ask  THEN ESTABLISH ;                Set HARD to the total size of the FORTH disk area on the PC, in 
                                                                          blocks.  This will make the hard disk start right past the   
                                                                          end of the PC disk, and the floppy starts 10800 blocks later.
( Add PC network to native system)   EMPTY                                SHADOWS and DRIVE are for you to define as appropriate.      
VARIABLE PC   VARIABLE SAVED                                           This block, when loaded, devotes the second serial port to com- 
: >PC   PC GET  DEVICE @ SAVED !  0 DEVICE ! ;                            munications with a PC or other network host for disk and/or  
: PC>   PC @ STATUS = IF  SAVED @ DEVICE !  PC RELEASE  THEN ;            printer access.  While all the mechanism is here for shared  
( UART)  >PC 38400 BAUD  PC>                                              use of the network, there are some restrictions due to the   
                                                                          lack of interrupts on the -P CPU.                            
: type ( b n)   ?DUP IF  (TYPE) EXIT  THEN DROP ;                                                                                      
: straight ( b n)   ?DUP IF  1- FOR  key OVER C!  1+ NEXT              PC  is a facility variable controlling use of the network.      
      THEN DROP ;                                                      >PC  gains network control & sets up for use of the 2nd USART;  
: sync   key DROP ;      : 2in ( - n)   key key 256 * + ;              PC>  releases the network & returns to normal device.           
: rqst ( n c)   >PC  0 U@ DROP  OVER Lo emit                                                                                           
      SWAP Hi emit  128 + emit ;                                       The remaining words in this block form the nuclear primitives   
: easy ( n)   14 rqst  sync  PC> ;                                        of the PC support protocol.                                  
                                                                                                                                       
( Disk)  148 LOAD  33 LOAD   ( Printer)  149 LOAD   FORTH GILD                                                                         
                                                                                                                                       
   ( PC disk at 16 DRIVE)                                                                                                              
: PLEAT ( n n - n t)   2DUP U< IF  DROP 0 EXIT  THEN - 1 ;             The PC's disk environment is made accessible starting at block  
                                                                          11520, also known as  16 DRIVE .  Errors are reported by the 
: Ask ( a n - a)   10 rqst  DUP 2* 1024 straight                          PC so that they may be handled by the chip.                  
      0 emit  2in DISK 1+ !  PC> ;                                                                                                     
: Tell ( a n - a)   12 rqst sync  DUP 2* 1024 type                     Disk access requires long message transfers at 38.4 Kbaud.  This
      2in DISK 1+ !  PC> ;                                                can lead to trouble if there's any other significant activity
                                                                          going on in the Beta board, since we need to get to the USART
: (BUFFER) ( - a)   ?UPDATED DROP                                         every 250 uS and we lack a working interrupt.  Thus, when any
   11520 PLEAT IF  Tell EXIT  THEN  2560 I/O ;                            task is accessing the PC's disk, that task should be the only
: (BLOCK) ( d - a)   ?ABSENT  'BUFFER @EXECUTE  >R OVER R> SWAP           one that's active for anything that can take significant time
   11520 PLEAT IF  Ask  ELSE  2048 I/O  THEN ESTABLISH ;                  between PAUSE's.  While this could be obviated by "shorting  
                                                                          out" the dispatcher loop during long receive's from the PC,  
                                                                          this would also leave the operator's keyboard dead and pre-  
                                                                          clude even such acts as typing RELOAD.  Instead caution is   
                                                                          advised while speaking to the PC.                            
   ( PC printer task)                                                                                                                  
(  Device rrss k  Mem          Name)   VARIABLE it                     If the Beta board is going to be routinely connected to the PC, 
HEX  0000 0001 1 1000 TERMINAL TYPIST   TYPIST CONSTRUCT                  which we DO NOT recommend, this print task may be loaded to  
                                                                          retain the ability to access a printer through the PC.  The  
HEX MSG {PAGE}  010C ,   MSG {CR}  020D , 0A00 ,   DECIMAL                control functions of the printer, normally simply PAGE and CR
: {TYPE} ( b n)   DUP 16 rqst sync  type sync  PC> ;                      are defined here and you should personalize them as needed.  
: {EMIT} ( c)   it 2* C!  it 2* 1 TYPE ;                                                                                               
                                                                       The only thing gained by plugging into the PC is the ability to 
' {PAGE}  TYPIST 'PAGE HIS !   ' {CR}  TYPIST 'CR HIS !                   read its hard disk.  Generally floppies are much easier and  
' {TYPE}  TYPIST 'TYPE HIS !   ' ABORT  TYPIST 'KEY HIS !                 faster to access on the SCSI floppy drive; and printers are  
' {EMIT}  TYPIST 'EMIT HIS !   ' ABORT  TYPIST 'EXPECT HIS !              much simpler and far more efficient when connected directly  
' STOP  TYPIST 'IDLE HIS !   VARIABLE PRINTER                             to the second serial port (see block 28).  Thus we expect    
                                                                          that you will only make this connection when it's absolutely 
: PRINT   PRINTER  DUP RELEASE  @ ABORT" Not available"                   necessary.                                                   
      PRINTER GRAB  TYPIST SEND ;                                                                                                      
: OK   PAGE CR PAGE  0 PRINTER ! ;                                                                                                     
( Sextets for H-P laser)   152 LOAD                                                                                                    
CREATE SRC  512 ALLOT      CREATE SHAD  512 ALLOT                         These three blocks support sextet printing on an H-P 2648A   
: ABSORB ( n)   DUP BLOCK  SRC 512 MOVE                                LaserJet printer with the 92286F font catridge.  Double sided   
      SHADOWS CAST BLOCK  SHAD 512 MOVE ;                              sextets are produced by printing FRONT first.  This actually    
CREATE MARGIN  8 ,                                                     prints the front sides of the pages backward, so that it's only 
: cr   CR  MARGIN @ SPACES ;                                           necessary to re-insert the output with printed side up back in  
: PAIR ( n)   63 SPACES  DUP 4 BOLD U.R ."  LIST"                      the hopper and then print the BACK.  In this way you won't need 
   TINY cr cr  DUP VISIBLE IF  ABSORB  1024 0 DO                       to shuffle the paper in between, and in fact the final pass pro-
         SHAD 2* I +  64 TYPE SPACE  I 64 /  3 U.R  SPACE              duces a listing that's ready to punch and bind without any shuf-
            SRC 2* I +  64 -TRAILING TYPE  cr  64 +LOOP                fling at that stage either.                                     
   ELSE  DROP  16 0 DO  cr  LOOP  THEN ;                                                                                               
                                                                                                                                       
: SEXTET ( n)   PAGE TINY  cr cr cr  3 / 3 *  DUP 3 + SWAP DO                                                                          
      I PAIR  cr cr  LOOP  BOLD C  NORMAL  8 MARGIN ! ;                                                                                
: PAIRS ( l h)   SWAP DO  3 I PRESENT IF                                                                                               
      8 MARGIN !  I SEXTET  THEN  3 /LOOP ;                                                                                            
   ( Double sided sextets)                                                                                                             
: 2-SIDED ( f l - f l)   5 + 6 / 6 *  SWAP 6 / 6 * ;                      Double sided sextets should always be printed as groups that 
                                                                       start and end on modulo 12 block boundaries.  For example, to   
: FRONT ( f l)   2-SIDED SWAP 6 - DO  6 I PRESENT IF                   produce a full listing of the first 240 blocks in the system,   
      8 MARGIN !  I SEXTET  THEN -6 +LOOP ;                            you could say:                                                  
: BACK ( f l)   2-SIDED DO  6 I PRESENT IF                                                                                             
      2 MARGIN !  I 3 + SEXTET  THEN 6 +LOOP ;                            PRINT 0 240 INDEX  9 SEXTET  12 240 FRONT OK                 
                                                                                                                                       
: INDEX ( f l)   C# 2@ NORMAL  C# 2! INDEX ;                           then remove the index and block 9 from the bottom of the pile,  
                                                                       put the rest back in the hopper print side up and top edge in,  
                                                                       and say:                                                        
                                                                                                                                       
                                                                          PRINT 12 240 BACK OK                                         
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Laser font selection)   HEX                                                                                                       
MSG reset  021B , 4500 ,                                               This block supports font selection operations on the H-P Laser  
: TRY ( n)   reset  1B EMIT  ." &l8c0e66F"                                printer.  What font you actually get will depend on the      
   1B EMIT ." &lL" ;                                                      cartridge that is loaded.                                    
: Kind ( n)   1B EMIT  ." (s"  .HP  ." P" ;                                                                                            
: FIXED   0 Kind ;      : PROPORTIONAL   1 Kind ;                                                                                      
: POINTS ( n)   1B EMIT  ." (s"  .HP  ." V" ;                                                                                          
: Style ( n)   1B EMIT  ." (s"  .HP  ." S" ;                                                                                           
: UPRIGHT   0 Style ;      : ITALIC   1 Style ;                                                                                        
: WEIGHT ( n)   1B EMIT  ." (s"  .HP  ." B" ;                                                                                          
: PITCH ( n)   1B EMIT  ." (s"  .HP  ." H" ;                                                                                           
: HM ( n.n)  1B EMIT ." &k"  0 <# # 2E HOLD #S #> TYPE  ." H" ;                                                                        
                                                                                                                                       
: BOLD   PROPORTIONAL  0A POINTS  3 WEIGHT ;   DECIMAL                                                                                 
: TINY   FIXED  8 POINTS  16 PITCH  0 WEIGHT  68 HM ;                                                                                  
: NORMAL   FIXED  10 POINTS  10 PITCH  0 WEIGHT ;                                                                                      
( Matching blocks)                                                                                                                     
VARIABLE BIAS   CREATE SEP  720 ,   CREATE HEAD  360 ,                 This block simplifies comparisons between source blocks.        
: OTHER ( n - n')   BIAS @ -  SEP @ CAST  BIAS @ + ;                                                                                   
: MATCHING ( n n)   2DUP U< IF  SWAP  THEN                             SEP  contains the absolute value of the difference between the  
      DUP BIAS !  - SEP ! ;                                               sets of blocks being compared.                               
                                                                       BIAS  is a number to which block numbers are relativized so that
: V+ ( v v - v)   SWAP >R +  SWAP R> +  SWAP ;  ( 7)                      they can be toggled using  CAST .                            
: RUNS ( d s n - d' s' n' ma n ta n)   OVER >R  1- FOR                 HEAD  is a limiting block number for  G .                       
      OVER C@ OVER C@ = WHILE  1 1 V+  NEXT  0  ELSE R> 1+                                                                             
   THEN  OVER >R  DUP IF  1- FOR  OVER C@ OVER C@ XOR WHILE            OTHER  returns te number of the companion to the current block. 
      1 1 V+ NEXT  0  ELSE R> 1+  THEN THEN                                                                                            
   OVER I -  I SWAP  R> I -  R> SWAP ;                                 MATCHING  defines source and destination disk areas given start-
                                                                          ing block numbers of each area.  Default is  0 5280 MATCHING 
: SPIN   8 FOR  1999 FOR NEXT NEXT ;                                                                                                   
                                                                                                                                       
                                                                                                                                       
   ( Matching blocks)                                                                                                                  
: REV   ( STATUS GREG @ = IF)  27 EMIT 48 EMIT 80 EMIT ( THEN);        This block displays differences between source blocks.          
: V   REV 0 0 TAB  SCR @ .  3 SPACES                                                                                                   
   1024 0 DO  SPIN  SCR @ OTHER BLOCK I 2/ + PAD 32 MOVE               REV  sets the Viewpoint attribute to reverse if appropriate.    
      SCR @ BLOCK I 2/ +  PAD 32 + 32 MOVE  I 64 / 1+ 3 TAB                                                                            
      CORE 64  2DUP + SWAP BEGIN  RUNS TYPE MARK  ?DUP NOT UNTIL       V  displays the current editing block, with characters that     
   2DROP  64 /LOOP  17 0 TAB CLEAN  16 67 TAB ;                           differ from its companion block higlighted in inverse video. 
                                                                       W  displays the "other" block like  V .                         
: O   SCR @ OTHER LIST ;    : W   SCR @ OTHER SCR !  V ;               O  displays the "other" block without highlighting.             
: GIVE   SCR @ DUP OTHER COPY  FLUSH V ;                                                                                               
: TAKE   SCR @ OTHER SCR @ COPY  FLUSH V ;                             GIVE  copies the block you are looking at to the "other" block. 
                                                                       TAKE  copies the "other" block to the one you are looking at.   
: TO ( n)   DUP OTHER MIN  HEAD ! ;                                                                                                    
: G   HEAD @  SCR @ 1+  DUP OTHER MIN  OVER 1- MIN DO                  TO  sets an upper limit block for comparisons.                  
      I BLOCK PAD 512 MOVE  PAD 512  I OTHER BLOCK                     G  matches blocks from the next one after the current editing   
   -TEXT IF  I LIST  V  LEAVE  THEN LOOP ;                                block up to this limit, stopping with a  V  on next mismatch.
( PC printer)                                                                                                                          
HERE  'TYPE @ ,  'CR @ ,  'PAGE @ ,                                    This block, designed to be loaded in the PC support environment,
: BACK   LITERAL 'TYPE 3 MOVE                                             supports the classical printer vocabulary  PRINT  and  OK .  
      [ 'EXPECT @ ] LITERAL 'EXPECT ! ;                                   Printing is sent to the PC and performed by the DOS calls.   
: {EXPECT}   BACK EXPECT ;                                                It works not as a print task, but rather by changing the     
                                                                          user's output vectors while printing.  Otherwise usage is the
HEX MSG {PAGE}  010C ,   MSG {CR}  020D , 0A00 ,   DECIMAL                same; to avoid  ok  appearing on the printer, it's necessary 
                                                                          to say  PRINT  ...  OK  all on the same line.                
HERE  ' (PRINT) ,  ' {CR} ,  ' {PAGE} ,                                                                                                
: PRINT   LITERAL 'TYPE 3 MOVE  ['] {EXPECT} 'EXPECT ! ;               For some printers you may need to change the control characters.
: OK   PAGE CR PAGE  BACK ;                                                                                                            
                                                                       The main reason it's done this way in the PC support system is  
                                                                          that multiple terminals may NOT use the PC's disk as long as 
                                                                          the PC is being used as a terminal.  Furthermore since the   
                                                                          interrupt doesn't work we have all of the aforementioned     
                                                                          problems guaranteeing that we can keep up with the serial    
( "Glass TTY" terminal--ADM3)   EMPTY   HEX                               line when receiving from the PC.                             
MSG (PAGE)   021E , 1A00 ,                                             This block supports a very plain CRT with no "tab" function.    
                                                                                                                                       
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;              The version of  (PAGE)  given here is for the Lear Siegler ADM3.
: (TAB) ( l c)   2DROP  CR ;   DECIMAL                                 For terminals that use "form-feed" (hex 0C), substitute:        
                                                                             MSG (PAGE)   010C ,                                       
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                                                                                
                                                                       This is a very poor terminal for ANY development use, since the 
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                      Editor assumes one at least modern enough to support the     
' (CLEAN) 'CLEAN !                                                        Tab function.                                                
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( VT100/240 Terminal)   HEX                                                                                                         
MSG (PAGE)   091B , 5B30 , 3B30 , 481B , 5B4A ,                        This block supports the DEC VT100 in native mode and the VT240  
MSG (CLEAN)   031B , 5B4B ,                                               in VT100 mode.  Similar routines will work for many of the   
: (TAB) ( l c)   BASE @ >R DECIMAL  <# 48 HOLD 1+  0 # # 2DROP            "ANSI" terminals made by other manufacturers.                
   3B HOLD  1+ 0 # # 5B HOLD  1B HOLD #>  TYPE  R> BASE ! ;                                                                            
                                                                       The version of INV with 5B37 will produce inverse video for     
MSG INV   041B , ( 5B34)5B37 , 6D00 ,                                     MARKed text.  5B34 will underscore.  Inverse video is recom- 
MSG NORM   041B , 5B30 , 6D00 ,                                           mended since that works best with the source reconciliation  
: (MARK)   INV TYPE  NORM ;                                               utilities in DISKING.                                        
                                                                                                                                       
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                   While slow, the DEC terminals are otherwise very good for all of
' (CLEAN) 'CLEAN !                                                        the terminal uses in a development environment.              
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
   ( ADM 3A terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                    
MSG (PAGE)  031A , 0000 ,                                              Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   1B EMIT  3D EMIT  SWAP 20 + EMIT  20 + EMIT ;         The ADM3A is acceptable for Editor use, although you would bene-
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;                 fit by adding a shift lock switch.  It's useless for the     
                                                                          source auditing utility.                                     
DECIMAL                                                                                                                                
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                                                                                
                                                                                                                                       
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                                                                                     
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Datamedia Elite terminal)   EMPTY   HEX   .( UNTESTED!)                                                                           
MSG (PAGE)  010C ,                                                     Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   1E EMIT  20 + EMIT  20 + EMIT ;                       This terminal is acceptable for Editor use; however, it's use-  
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;                 less for the source auditing utility.                        
                                                                                                                                       
DECIMAL                                                                CLEAN may be supported by the terminal; at the time of the      
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                   conversion we didn't have access to a manual.  You may want  
                                                                          to check this out for yourself.                              
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                                                                                     
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( SOROC terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                     
MSG (PAGE)  041B , 2A00 , 0000 ,                                       Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   1B EMIT  3D EMIT  SWAP 20 + EMIT  20 + EMIT ;         This terminal is acceptable for Editor use; however, it's use-  
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;                 less for the source auditing utility.                        
                                                                                                                                       
DECIMAL                                                                CLEAN may be supported by the terminal; at the time of the      
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                   conversion we didn't have access to a manual.  You may want  
                                                                          to check this out for yourself.                              
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                                                                                     
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Televideo terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                 
MSG (PAGE)  0126 ,                                                     Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   1B EMIT  3D EMIT  SWAP 20 + EMIT  20 + EMIT ;         Televideo makes many terminals, and it's uncertain exactly which
: (MARK) ( b n)   >R  CORE I CMOVE  1B EMIT ." G8"                        one this block supports.                                     
      CORE R> TYPE  1B EMIT ." G0" ;                                                                                                   
                                                                       On most Televideo terminals, attributes are NOT transparent so  
DECIMAL                                                                   you will see a spurious space in front of and trailing each  
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                   MARKed string.  While this is acceptable for editing once you
                                                                          become accustomed to seeing spaces that aren't really there, 
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                      it doesn't work at all well with source auditing.            
' (CLEAN) 'CLEAN !                                                                                                                     
                                                                       CLEAN may be supported by the terminal; at the time of the      
HERE H 1+ !   EMPTY                                                       conversion we didn't have access to a manual.  You may want  
                                                                          to check this out for yourself.                              
                                                                                                                                       
   ( Hazeltine Esprit terminal)   EMPTY   HEX   .( UNTESTED!)                                                                          
MSG (PAGE)  071B , 121B , 1700 , 0000 ,                                Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   1B EMIT  11 EMIT  DUP 0= IF  60 +  THEN               This terminal is acceptable for Editor use; however, it's use-  
   EMIT  60 + EMIT ;                                                      less for the source auditing utility.                        
: (MARK) ( b n)   >R  CORE I CMOVE  1B EMIT 1F EMIT                                                                                    
   ." ^"  CORE R> TYPE  1B EMIT 19 EMIT ;                              The only attribute combination that we've found usable on the   
                                                                          Hazeltine is intensification for MARKing.  Since an intensi- 
DECIMAL                                                                   fied space is hardly an attention grabber, we include the    
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                   caret cursor symbol as well at the beginning of a MARKed     
                                                                          field.                                                       
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                     CLEAN may be supported by the terminal; at the time of the      
                                                                          conversion we didn't have access to a manual.  You may want  
HERE H 1+ !   EMPTY                                                       to check this out for yourself.                              
                                                                                                                                       
   ( ADDS 20 terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                   
MSG (PAGE)  010C ,                                                     Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   1B EMIT  59 EMIT  SWAP 20 + EMIT  20 + EMIT ;         Some of the old ADDS terminals do not support attributes and so 
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;                 are useless with the source audit facilities.  If yours does,
                                                                          you might try the version of  MARK  used with the Viewpoint. 
DECIMAL                                                                                                                                
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                CLEAN may be supported by the terminal; at the time of the      
                                                                          conversion we didn't have access to a manual.  You may want  
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                      to check this out for yourself.                              
' (CLEAN) 'CLEAN !                                                                                                                     
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( ADDS Viewpoint terminal)   EMPTY   HEX                                                                                            
MSG (PAGE)   041B , 3060 , 0C00 ,                                      This block supports most native ADDS Viewpoint terminals.       
                                                                          Beware of the emulating terminals from ADDS, since these will
: (TAB) ( l c)   1B EMIT  59 EMIT  SWAP 20 + EMIT  20 + EMIT ;            usually support a hybrid protocol based on the emulated term-
: (MARK) ( b n)   >R  CORE I CMOVE                                        inal but including Viewpoint features as extensions.         
      0E EMIT  CORE R> TYPE  0F EMIT ;                                                                                                 
                                                                       Native viewpoints are extremely nice and cheap terminals.  They 
MSG (CLEAN)   021B , 4B00 ,                                               support one of a selection of transparent attributes at any  
                                                                          given time, which is adequate for all development software   
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                      included in this system.  Normally we use underscoring as the
' (CLEAN) 'CLEAN !                                                        attribute for the Editor, and inverse video to mark differen-
                                                                          ces in the source audit mechanism of  DISKING.               
HERE H 1+ !   EMPTY                                                                                                                    
                                                                       One of the best features of the Viewpoints is that they keep up 
                                                                          with the line, even at 19.2 Kbaud.  They don't even KNOW HOW 
                                                                          to say Xon/Xoff, nor do they ever need to.  Consequently they
   ( ADDS Viewpoint/3a+ terminal)   EMPTY   HEX   .( UNTESTED!)           are one of the highest performance terminals available today.
MSG (PAGE)  041A , 1B30 , 6000 ,                                       Converted for the chip, but not tested with a terminal.         
: (TAB) ( l c)   1B EMIT  3D EMIT  SWAP 20 + EMIT  20 + EMIT ;                                                                         
: ESC ( n)   1B EMIT  EMIT ;                                           This block supports the ADDS Viewpoint 3a/PLUS terminal.  In the
: (MARK) ( b n)   >R  CORE I CMOVE                                        non-"PLUS" mode, use ADM3A for this terminal.                
    29 ESC  CORE R> TYPE  28 ESC ;                                                                                                     
MSG (CLEAN)  021B , 5400 ,                                             EXPECT uses the cursor disable feature.  If you see the cursor  
                                                                          the computer is listening; otherwise it is not.              
: (EXPECT) ( b n)   18 EMIT                                                                                                            
      [ 'EXPECT @ ] LITERAL EXECUTE  17 EMIT ;                                                                                         
                                                                                                                                       
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !   ' (EXPECT) 'EXPECT !                                                                                              
                                                                                                                                       
HERE H 1+ !  EMPTY                                                                                                                     
                                                                                                                                       
   ( NCR 7900 terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                  
MSG (PAGE)  40C , 0 , 0 ,                                              Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   0B EMIT  SWAP EMIT                                    This terminal is acceptable for Editor use; however, it's use-  
      10 EMIT  0A /MOD 10 * + EMIT ;                                      less for the source auditing utility.  On the other hand, it 
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;                 shares with the Viewpoint the property of keeping up with    
                                                                          the line.                                                    
DECIMAL                                                                                                                                
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                CLEAN may be supported by the terminal; at the time of the      
                                                                          conversion we didn't have access to a manual.  You may want  
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                      to check this out for yourself.                              
' (CLEAN) 'CLEAN !                                                                                                                     
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
   ( NCR 7910 terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                  
MSG (PAGE)  10C ,                                                      Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   BASE @ >R DECIMAL  <# 48 HOLD 1+  0 # # 2DROP         Other transparent attributes besides underlining are available  
   3B HOLD 1+  0 # #  5B HOLD  1B HOLD #>  TYPE  R> BASE ! ;              with this terminal.                                          
MSG ul  71B ,  5033 ,  6241 ,  1B5C ,                                                                                                  
MSG -u  71B ,  5033 ,  6240 ,  1B5C ,                                  While extremely slow, this terminal is otherwise very good for  
: (MARK) ( a n)   >R  CORE I CMOVE  ul  CORE R> TYPE  -u ;                all of the terminal uses in a development environment.  It   
                                                                          has probably one of the easiest viewing displays available.  
DECIMAL                                                                                                                                
: (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                CLEAN is definitely supported by the terminal; at the time of   
                                                                          the conversion we didn't have access to a manual.  You may   
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                      want to check this out for yourself.                         
' (CLEAN) 'CLEAN !                                                                                                                     
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
   ( VT52 terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                      
MSG (PAGE)   41B ,  481B ,  4A00 ,                                     Converted for the chip, but not tested with a terminal.         
                                                                                                                                       
: (TAB) ( l c)   1B EMIT  59 EMIT  SWAP 20 + EMIT  20 + EMIT ;         This terminal is acceptable for Editor use; however, it's use-  
: (MARK) ( b n)   >R  CORE I CMOVE  ." ^"  CORE R> TYPE ;                 less for the source auditing utility.                        
                                                                                                                                       
MSG (CLEAN)  21B ,  4B00 ,                                                                                                             
                                                                                                                                       
' (TAB) 'TAB !   ' (PAGE) 'PAGE !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                                                                                     
                                                                                                                                       
HERE H 1+ !   EMPTY                                                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( MVI-7 XL13 terminal)   EMPTY   HEX   .( UNTESTED!)                                                                                
MSG (PAGE)   10C ,                                                     Converted for the chip, but not tested with a terminal.         
: (TAB) ( l c)   BASE @ >R DECIMAL  <# 48 HOLD 1+  0 # # 2DROP                                                                         
   3B HOLD 1+  0 # #  5B HOLD  1B HOLD  #> TYPE  R> BASE ! ;           This is a color graphic terminal that works acceptably for      
                                                                          everything.  On the other hand it has an abominable keyboard.
MSG TILLEND   31B ,  5B4A ,                                                                                                            
( MSG INV   41B ,  5B37 ,  6D00 ,)                                     CLEAN may be supported by the terminal; at the time of the      
MSG UL   41B ,  5B34 ,  6D00 ,                                            conversion we didn't have access to a manual.  You may want  
MSG NORM   41B ,  5B30 ,  6D00 ,                                          to check this out for yourself.                              
: (MARK) ( a n)   >R  CORE I CMOVE  UL  CORE R> TYPE  NORM ;                                                                           
                                                                                                                                       
DECIMAL   : (CLEAN)   78 C# @ - SPACES  13 EMIT ;                                                                                      
                                                                                                                                       
' (TAB) 'TAB !   ' (PAGE) 'PAGE !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                                                                                     
HERE H 1+ !   EMPTY                                                                                                                    
OPTIONS             Displays this  OPTIONS  help screen.                                                                               
                                                                       I/O ASSIGNMENTS:                                                
DISKING LOAD        Loads utility to copy and verify disks.            C000-C7FF  J1/2B-26                                             
STREAMER LOAD       Loads streaming tape utility.                      C800-CFFF  J1/2B-27                                             
PRINTING LOAD       Loads utility to print listings and indexes.       D000,D001  icaa asss dddd dddd  Peripheral bus read, write      
                                                                                    00 0               Second USART (U71)              
COMPILER LOAD       Re-compiles FORTH or target application.                        00 1               Operator USART (U70)            
TESTING LOAD        Tests recompiled FORTH or target appls.                         01 0               MC6840 timer chip               
PROMS LOAD          Loads DATA I/O 29B-UNIPAK 2 burner utility         D800-DFFF                                                       
                                                                       E000       rb-- ---- p--a smci  SCSI handshakes in              
FILES LOAD          Loads Data Base Support Option                     E001       ---- ---- p--- -rsa  SCSI handshakes out             
                                                                       E002       7654 3210 7654 3210  SCSI data in (2 copies)         
DOS LOAD            Loads utility for PC-DOS 360K floppies.            E003       7654 3210 ---- ----  SCSI data out                   
                                                                       E800-EFFF                                                       
                                                                       F000-F7FF                                                       
                                                                       F800-FFFF  ---- ---z ---s ss--  Stack selection register.       
( INTECOLOR 2400 Terminal)   HEX                                                                                                       
MSG (PAGE)   121B ,                                                    This is the terminal the folks at NOVIX use                     
                    5B33 , 343B , 3436 , 6D1B ,                                                                                        
                    5B30 , 3B30 , 481B , 5B4A ,                                                                                        
                    0F00 ,                                                                                                             
MSG (CLEAN)   031B , 5B4B ,                                                                                                            
: (TAB) ( l c)   BASE @ >R DECIMAL  <# 48 HOLD 1+  0 # # 2DROP                                                                         
   3B HOLD  1+ 0 # # 5B HOLD  1B HOLD #>  TYPE  R> BASE ! ;                                                                            
                                                                                                                                       
MSG INV    081B , 5B33 , 303B , 3432 , 6D00 ,                                                                                          
MSG NORM   081B , 5B33 , 343B , 3436 , 6D00 ,                                                                                          
: (MARK)   INV TYPE  NORM ;                                                                                                            
                                                                                                                                       
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                                                                                     
DECIMAL                                                                                                                                
  ( Wyse 50 Terminal )    EMPTY HEX                                                                                                    
MSG (PAGE)  031E , 1B59 ,                                              Wyse 50 terminal characteristics.                               
                                                                                                                                       
: (TAB) ( l c)   1B EMIT  3D EMIT  SWAP 20 + EMIT  20 + EMIT ;         Inverse Video implemented as a Set Video Attribute Esc G to DIM 
MSG INVERSE    031B , 4774 ,                                           & INVERSE. Note that the Attribute applies to the whole display 
MSG NORMAL  031B , 4730 ,                                              area & occupies a space.                                        
: (MARK) ( b n)   >R  CORE I CMOVE                                                                                                     
      INVERSE  CORE R> TYPE  NORMAL ;                                  The Wyse has a max transfer rate of 38.4 kBaud but the PROM     
MSG (CLEAN)   021B , 5400 ,                                            RELOAD sets it to 9600 BAUD, so its difficult to automatically  
                                                                       alter the BAUD rate as there is no terminal codes to do so.     
' (PAGE) 'PAGE !   ' (TAB) 'TAB !   ' (MARK) 'MARK !                                                                                   
' (CLEAN) 'CLEAN !                                                                                                                     
HERE H 1+ !   EMPTY DECIMAL                                                                                                            
                                                                                                                                       
CR .( Note: Using WYSE can change  to 38400 BAUD )                                                                                     
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( 860501jwr HOST <-> Beta Board )                                                                                                      
: type ( a n: ) 0 DO DUP C@ emit 1+ LOOP DROP ;                        This code is for your HOST machine; pretty much 83-Standard     
: keys ( a n: ) 0 DO key OVER C! 1+ LOOP DROP ;                        type     to Beta Board;   you must define "emit"                
 : ACCEPT ( n: n' )  PAD SWAP EXPECT SPACE SPAN @ DUP emit ;           keys     from Beta Board; you must define "key"                 
: KEYIN ( n: 0 ) ACCEPT DUP IF key DROP PAD SWAP type 0 THEN ;         ACCEPT   from your keyboard                                     
                                                                       KEYIN    to the Beta Board                                      
 : GRAB  ( a n: )  0 emit keys ;                                                                                                       
 : AQUIRE ( n: a n )  PAD SWAP  2DUP  GRAB ;                           GRAB     characters from the Beta Board ...                     
: SHOW  ( n: 0 )   AQUIRE TYPE 0 ;                                     AQUIRE   into a host buffer ...                                 
: ISHOW ( n: 0 )   AQUIRE MARK 0 ;                                     SHOW     them on your screen                                    
: TAB   ( n: 0 )   256 /MOD PTC  0 ;                                   ISHOW    them on your screen in inverse video; predefine MARK   
                                                                       TAB      your screen to given position: PTC ( r c: ) is MMSFORTH
 : R/W-ERR ( : n )  FLUSH  DISK-ERROR @ emit  BLOCK-ERROR @ ;                                                                          
: GET ( n: n') BLOCK  1024 type  key DROP  R/W-ERR ;                   R/W-ERR  report error: DISK-ERROR and BLOCK-ERROR are MMSFORTH  
: PUT ( n: n') BUFFER 1024 GRAB  UPDATE R/W-ERR ;                      GET      your block and send to Beta Board                      
: WRITE ( n: 0 )   AQUIRE  PRINT TYPE CRT 0 ;                          PUT      from Beta Board into your block                        
( 860501jwr HOST <-> Beta Board )                                      WRITE    from Beta Board to your printer; PRINT & CRT = MMSFORTH
 : WHO   ." Yourself " ;                                               You must define EEOL (erase to end of line), NULL, START & STOP 
: UNPLUG  WHO  R> DROP  R> DROP  R> DROP  STOP ;                       WHO     is in charge                                            
( sub#:  0     2     4       6     8    10    12    14 )               UNPLUG  from Beta Board; STOP disconnects the HOST serial port  
HERE  ] CR  PAGE  EEOL  UNPLUG  NULL  NULL  NULL  NULL [                      these numbers are sub-command codes                      
: SIMPLE ( n: 0)  14 AND  LITERAL + @ EXECUTE  0 ;                     HERE    is execution table for sub-commands                     
( cmd#:    0     2     4      6    8   10   12      14     16 )        SIMPLE  commands are sub-commands                               
HERE ] KEYIN  NULL  SHOW  ISHOW  TAB  GET  PUT  SIMPLE  WRITE [               these numbers are command codes                          
HERE OVER - CONSTANT #CMDS                                             HERE    is execution table for commands                         
: COMMAND ( n c: n' )  LITERAL + @ EXECUTE ;                           #CMDS   sets limit to valid command codes                       
: LISTEN ( n: n' c ) emit  PAD 3 keys  PAD @  PAD 2+ C@ 128 - ;        COMMAND executes a command                                      
: VALID? ( c: f )  DUP #CMDS > OVER 0< OR  SWAP 1 AND OR 0= ;          LISTEN  for 3 character command sequence                        
                                                                       VALID?  accepts even characters within range                    
: PLUG        START  0                                                                                                                 
   BEGIN  LISTEN  DUP VALID?  WHILE  COMMAND REPEAT                    PLUG    connects the HOST serial port ( START ), then sits in a 
   ." Garbage in " SWAP . . STOP ;                                             loop executing  valid commands; an invalid command      
                                                                               prints "Garbage in" and disconnects ( STOP )            
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( NEC printer task)   HEX                                                                                                              
(  Device rrss k  Mem          Name)                                   This screen defines a Centronics-style parallel printer task    
     0000 0001 2  400 TERMINAL NECPTR   NECPTR CONSTRUCT               It reads the BUSY flag and writes the DATA and STROBE lines     
HEX                                                                         here it is being used for the NEC8023A printer             
: SETUP 000F E I!  0001 C I!  00FF A I!  0000 8 I! ;  SETUP                                                                            
: {EMIT} ( n) BEGIN PAUSE C I@ 10 AND 10 XOR UNTIL 1E FOR NEXT         SETUP  initializes X4 for BUSY input & B0-7 and X0 for outputs  
      8 I!  5 FOR NEXT  0000 C I!  5 FOR NEXT  0001 C I! ;             {EMIT} pauses for BUSY to clear, then waits a tad before sending
: {TYPE} ( b n) ?DUP IF 1- FOR  DUP C@ EMIT 1+ NEXT THEN DROP ;               the data and toggling the strobe line                    
MSG {PAGE}  010C ,             MSG {CR}  010D ,                        {TYPE} just sends multiple characters                           
  ' {PAGE}  NECPTR 'PAGE HIS !   ' {CR}  NECPTR 'CR HIS !              {PAGE} is form-feed                {CR}  is return              
  ' {TYPE}  NECPTR 'TYPE HIS !   ' ABORT  NECPTR 'KEY HIS !                                                                            
  ' {EMIT}  NECPTR 'EMIT HIS !   ' ABORT  NECPTR 'EXPECT HIS !                these lines establish the task's behavior for all I/O    
  ' STOP  NECPTR 'IDLE HIS !   VARIABLE PRINTER                                                                                        
: PRINT   PRINTER  DUP RELEASE  @ ABORT" Not available"                PRINTER  is a resource flag                                     
      PRINTER GRAB  NECPTR SEND ;                                      PRINT   activates the print task if the printer is available    
: OK   CR PAGE   0 PRINTER ! ;  DECIMAL                                                                                                
( NEC printer control)   HEX                                           OK      releases the printer                                    
                                                                       This block defines some of the character sets available         
: PICA    1B EMIT  4E EMIT  1B EMIT  22 EMIT  0F EMIT ;                on an NEC 8023A printer                                         
: ELITE   1B EMIT  45 EMIT  1B EMIT  22 EMIT  0F EMIT ;                                                                                
: TINY    1B EMIT  51 EMIT  1B EMIT  22 EMIT  0F EMIT ;                The driver in the previous block requires NO special hardware!  
                                                                       A printer connector has been wired up directly to the B and X   
: 1DOT    1B EMIT  01 EMIT ; : 2DOT    1B EMIT  01 EMIT ;              ports:                                                          
: 3DOT    1B EMIT  03 EMIT ; : 4DOT    1B EMIT  02 EMIT ;                                                                              
: 5DOT    1B EMIT  05 EMIT ; : 6DOT    1B EMIT  06 EMIT ;              printer signal    connector pin         option module signal    
: ITALIC  1B EMIT  22 EMIT  1B EMIT  50 EMIT ;                           -strobe              1                     X0                 
                                                                         data lines           2-9                   B0-B7              
: BIG     0E EMIT ;                                                      busy                11                     X4                 
: BOLD    1B EMIT  21 EMIT ;                                             gnd                 19-30                 gnd                 
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( NEC printer Sextets)   DECIMAL                                                                                                       
CREATE SRC  512 ALLOT      CREATE SHAD  512 ALLOT                      This block replicates block 150 with cosmetic changes           
: ABSORB ( n)   DUP BLOCK  SRC 512 MOVE                                                                                                
      SHADOWS CAST BLOCK  SHAD 512 MOVE ;                                                                                              
CREATE MARGIN  2 ,                                                                                                                     
: cr   CR  MARGIN @ SPACES ;                                                                                                           
: PAIR ( n)   63 SPACES  DUP 4 BOLD ITALIC U.R ."  LIST"                                                                               
   TINY cr cr  DUP VISIBLE IF  ABSORB  1024 0 DO                                                                                       
         SHAD 2* I +  64 TYPE SPACE  I 64 /  3 U.R  SPACE                                                                              
            SRC 2* I +  64 -TRAILING TYPE  cr  64 +LOOP                                                                                
   ELSE  DROP  16 0 DO  cr  LOOP  THEN ;                                                                                               
                                                                                                                                       
: SEXTET ( n)   PAGE TINY  cr cr cr  3 / 3 *  DUP 3 + SWAP DO                                                                          
      I PAIR  cr cr  LOOP  BOLD ITALIC C  PICA  2 MARGIN ! ;                                                                           
: PAIRS ( l h)   SWAP DO  3 I PRESENT IF                                                                                               
      2 MARGIN !  I SEXTET  THEN  3 /LOOP ;                                                                                            
( 14-bit fraction arithmetic)                                                                                                          
16384 CONSTANT +1                                                      14-bit fractions are very convenient on a 16-bit machine, since 
                                                                          they permit exact representation of unity and, in fact, of   
: *. ( n f - n)   M*  D2* D2*  ( round) SWAP 0< - ;  ( 33-46)             numbers in  [-2,+2[ , with a resolution of 1/16384.          
: /. ( n n - f)   DUP 0< IF  NEGATE >R  NEGATE R>  THEN                +1  returns the scaled value assigned to exactly 1.000...       
   DUP >R  2* SWAP D2/ D2/  R> -M/MOD DROP ;  ( 36-43)                                                                                 
                                                                       *.  multiplies a fraction by a fraction, giving a fraction, or  
: '.'   46 HOLD ;                                                         an integer by a fraction, giving an integer.                 
: .F ( f)   10000 *.  DUP ABS 0  <#  # # # # '.' # SIGN #>             /.  divides a fraction by a fraction, giving a fraction, or an  
      TYPE SPACE ;                                                        integer by an integer, giving a fraction, or an integer by a 
: F ( n - f)   10000 /. ;                                                 fraction, giving an integer.  The results of both operations 
                                                                          are rounded away from zero at the 1/2 points.                
                                                                                                                                       
                                                                       '.'  inserts a decimal point in pictured output.                
                                                                       .F  displays a signed fraction with four decimal places.        
                                                                       F  converts a signed integer which represents a fraction with   
   ( Random numbers)                                                      four decimal places to 14-bit fraction format.               
CREATE SEED  7734 ,                                                    This is Greg's normal 15-bit generator.  It has been tested     
: RANDOM ( - n)   SEED DUP @  31421 *  6927 +                             with most of Knuth's criteria and is really quite nice.  It  
   32767 AND  SWAP ND! ;                                                  returns a uniformly distributed positive number less than    
                                                                          32768, with greatest randomness in most significant bits.    
: PICK ( n - n)   RANDOM M*  D2* SWAP DROP ;                              Cycle length is full 32k.                                    
                                                                                                                                       
EXIT                                                                   PICK  returns a uniformly distributed positive random number    
   30477 ( positive)  1 OVER -                                            less than its argument.  While this definition would look    
CREATE SEED   DUP ( no) ,  SWAP ( mult) ,  ( restart) ,                   cleaner as just  RANDOM 2/ *.  the rounding that is done     
: RANDOM ( - n)   SEED DUP >R  1 @+ @  M*  DUP 0< IF  I 1+ @ +            in the fractional multiply messes up the bins.               
   THEN -  -1 0 +c -  DUP 0= IF  I 2 + @ +  THEN R> ND! ;                                                                              
                                                                       The second routine, under  EXIT , is one of Chuck's random      
                                                                          number generators.  It is not very uniform, but it may have  
                                                                          other desirable properties.                                  
                                                                                                                                       
( 15-bit square-root of 30-bit integer)                                                                                                
OCTAL 102616 uCODE S'   DECIMAL                                        This square root functions properly for any number <4001.0000   
                                                                          and will thus produce any root expressable in a signed 16-bit
: SQRT ( d - n)   16384 6 I!  0 4 I!  13 DO( S' )  DUP 0< OR              number, completely suitable for normal fractions.  While the 
   D2*  1 6 I!  4 I@ 2*  4 I!  S'  DROP DROP  4 I@ ; ( 35)                S' primitive is intended to return root in N and MD and the  
                                                                          residual in T such that  N*N + T  reproduces the argument, it
: SQRT. ( f - f)   +1 M*  SQRT ;                                          has needed to be fixed up to avoid loss of carries so that T 
                                                                          and N are garbaged in the process.  Exhaustive tests for     
                                                                          reproduction of perfect roots and monotonicity in its working
                                                                          range have been made (about 4 hrs for 1 gigatest).           
                                                                       The old algorithm,                                              
                                                                          : SQRT ( d - n)   32768 6 I!  0 4 I!  D2*  14 TIMES  S'      
                                                                             DROP ; ( 25)                                              
                                                                          works only for squares of 0 to 16k.  It has been exhaustively
                                                                          tested for reproduction of perfect roots and monotonicity in 
                                                                          this range (took 1 hr for .25 gigatests at 159 ns).          
( Vector arithmetic)                                                   SQRT.  takes the square root of a fraction.                     
: V+ ( v v - v)   >R  SWAP >R +  R> R> + ;  ( 8)                       Vectors appear on the stack as ordered pairs, with X-component  
: V- ( v v - v)   >R  SWAP >R -  R> R> - ;  ( 8)                          on top and the Y-component underneath.  The components may be
: VSWAP- ( v v - v)   >R  SWAP >R SWAP -  R> R> SWAP - ;  ( 8)            of any 16-bit type or scale.                                 
: VNEGATE ( v - v)   NEGATE SWAP  NEGATE SWAP ;  ( 5)                                                                                  
                                                                       V+ ,  V- ,  and  VNEGATE  perform conventional vector addition, 
: 2ROT ( d d d - d d d)   >R >R >R >R  MD I! SR I!                        subtraction, and negation.                                   
      R> R> R> R>  SR I@ MD I@ ;  ( 13)                                VSWAP-  saves many clocks.                                      
                                                                                                                                       
: V*/ ( v n n - v)   DUP >R OVER >R  */ SWAP  R> R> */ SWAP ;          2ROT  is a conventional 32-bit ROT.                             
                                                                                                                                       
: VMAX ( v v - v)   ROT MAX >R  MAX R> ;                               V*/  multiplies a vector by a signed, rational scalar.          
: VMIN ( v v - v)   ROT MIN >R  MIN R> ;                                                                                               
: V? ( a)   2@ . . ;                                                   VMAX and VMIN independently maximize and minimize each component
                                                                          of a pair of vectors.                                        
                                                                       V?  displays a vector from memory, with X first.                
   ( Vector operators)                                                                                                                 
: /V/ ( v v - n)   V-  ABS SWAP  ABS MAX ;                             /V/  gives the largest absolute difference between two vectors  
                                                                          along whichever of the axes it lies.                         
: V* ( v - d)   >R DUP M*  R> DUP M* D+ ;                                                                                              
: MAG ( v - n)   V*  SQRT ;                                            V*  returns the squared magnitude of a 2-vector, with scale of  
                                                                          the vector also squared.                                     
: ^ ( v - v)   2DUP MAG  DUP >R /.  SWAP R> /.  SWAP ;                 MAG  returns the magnitude of a vector in its own scale.        
                                                                                                                                       
                                                                       ^  produces a unit vector of the same direction as the input,   
                                                                          which must be composed of 14-bit fractions.                  
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Products)                                                                                                                         
: DOT ( v v - d)   >R SWAP >R M*  R> R> M* D+ ;                        The appropriate units for vector products are application depen-
: DOT. ( v v - f)   >R SWAP >R *.  R> R> *. + ;                           dent.  These definitions illustrate two typical methods:     
                                                                                                                                       
: CROSS ( v v - d)   >R M*  ROT R> M* D- ;                             DOT  produces the scalar product of two 2-vectors, in squared   
: CROSS. ( v v - f)   >R *.  SWAP R> *. - ;                               scale.  You must postnormalize the result, but the definition
                                                                          itself is scale independent.                                 
                                                                       DOT.  takes the dot product of vectors whose components are 14- 
                                                                          bit fractions.  Since  a b DOT  is defined as  |a| |b| cos th
                                                                          the product is limited to +1 if the arguments are limited to 
                                                                          unit vectors.                                                
                                                                       CROSS  returns the magnitude of the cross product of two vectors
                                                                          in units similar to  DOT , and  CROSS.  is similar to  DOT.  
                                                                          Since the cross product of 2-vectors is always normal to the 
                                                                          X-Y plane, the product is returned as a scalar that is under-
                                                                          stood to be the magnitude of a pure Z vector  |a| |b| sin th 
( 14-bit SIN, COS and TAN of 14-bit angle)                                where sign of the mag is sign of the right-hand Z component. 
: TRIANGLE ( a - f)   2* 2* ABS  +1 SWAP - ; ( 10)                     Fixed-point fractions are convenient representations of angles  
                                                                          as fractions of a whole revolution (circle).  The 14-bit     
   ( Hart 3300: 1.57079  -.64589  .07943  -.00433)                        fixed-point fraction arithmetic routines provide angular     
: COS ( a - f)   TRIANGLE  DUP DUP *.  DUP -71 *. 1301 +                  resolution of approximately +|- 2 minutes of arc.            
   OVER *. -10582 +  *. 9352 +  OVER *. + ; ( 5*. 25+)                                                                                 
                                                                       TRIANGLE produces a triangle wave approximation to the cosine   
: SIN ( a - f)   4096 - COS ; ( 4+)                                       of the given angle.                                          
: TAN ( a - f f)   DUP SIN  SWAP COS ;                                 SIN  and  COS  give 14-bit approximations to the sine and cosine
                                                                          of an angle, respectively.  Log10 max abs err = -6.23 in the 
: COT ( a - f f)   TAN SWAP ;                                             basic polynomial.  SIN  averages 221 clocks.                 
: CSC ( a - f f)   SIN +1 SWAP ;                                       TAN ,  COT ,  CSC ,  and  SEC  can have infinite results, so we 
: SEC ( a - f f)   COS +1 SWAP ;                                          return rational numbers since they can express infinity.     
                                                                          TAN  takes about 442 clocks.  This version is faster, about  
                                                                          324 clocks, but the denominator contains a larger error:     
                                                                       : TAN ( a - f f)   DUP >R SIN  DUP ADJACENT                     
   ( 14-bit ATAN of signed ratio)                                         R> TRIANGLE 0< IF  NEGATE  THEN ;                            
: !SET ( n)   R> SWAP  DUP 1 AND  I + R> + >R  1+ + >R ;               !SET  shifts the bit on the stack into the low order position   
                                                                          of the number on top of the return stack.  If the bit was    
HERE HEX -0C00 ,   0400 ,   3400 ,  -3C00 ,                               zero, the following word is skipped.                         
          1400 ,  -1C00 ,  -2C00 ,   2400 ,   DECIMAL                                                                                  
   ( Hart 4960: .15920  -.05270  .02680  .41421)                       ATAN  returns a 4-quadrant angle that is the arctangent of the  
: ATAN ( n n - a)   DUP 0< 1 AND >R  ABS                                  ratio given.  The ratio need not satisfy the sum of squares  
   SWAP DUP 0<  !SET NEGATE  2DUP >  !SET SWAP  /.                        identity for sine and cosine.                                
   DUP -6768 + SWAP 6786 *.  +1 + /.                                                                                                   
   DUP DUP *.  DUP 438 *.  -864 + *.  2607 + *.                        ADJACENT  calculates a positive value such that the sum of the  
   R> LITERAL + @  + ABS ;                                                squares of it and the argument is one.                       
                                                                       ASIN  gives a 2-quadrant angle (+|- 90 degrees) that is the arc-
+1 +1 M*  SWAP                                                            sine of the value given.                                     
: ADJACENT ( f - f f)   DUP NEGATE M* LITERAL LITERAL D+ SQRT ;        ACOS  gives a 2-quadrant arc-cosine.                            
: ASIN ( f - a)   DUP ADJACENT ATAN ;                                                                                                  
: ACOS ( f - a)   DUP ADJACENT SWAP ATAN ;                                                                                             
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( 14-bit angle input)                                                                                                                  
512 1125 2CONSTANT D/REV      512 675 2CONSTANT '/REV                  D/REV is a ratio that converts  ddd.dd  to revolutions.         
                                                                       '/REV is a ratio that converts  ddd:mm  to revolutions.         
: DEG ( ddd - f)   360 /. ;                                                                                                            
: D ( dd.d - f)   D/REV M*/ DROP ;                                     DEG converts an integer angle in degrees to revolutions.        
: (D') ( m d - f)   60 * +  '/REV */ ;                                 D  converts an angle in  ddd.dd  to revolutions.                
: D' ( d:mm - f)   100 U/MOD  (D') ;                                                                                                   
                                                                       (D')  converts minutes and degrees to revolutions.              
: DEG. D ;                                                             D'  converts an angle in  ddd:mm  to revolutions.               
                                                                                                                                       
                                                                       DEG. Synonym for D for enter angles:  45.04 DEG.                
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Angle arithmetic)                                                                                                                 
: <1. ( f - f)   16383 AND ;                                           <1.  clips an angle to be less than 360 degrees.                
: <.5 ( f - f)   2* 2*  2/ 2/ ;                                        <.5  clips an angle to be in +-180 degrees.                     
                                                                                                                                       
: A- ( f f - f)   -  <1. ;                                             A-  subtracts two angles and returns a 360-clipped result.      
: A+ ( f f - f)   +  <1. ;                                             A+  adds two angles and returns a 360-clipped result.           
                                                                                                                                       
: CLIP ( n lim - n)   OVER ABS MIN  OVER ABS */ ;                      CLIP limits the magnitude of a given number to the positive     
                                                                          limit value given, without changing its sign.                
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Angle output)                                                                                                                     
: ALIGN ( a n w)   OVER - SPACES  TYPE ;                               ALIGN types a given string in a right-justified field.          
                                                                                                                                       
: :## ( d - d)   #  6 BASE !  #  DECIMAL  58 HOLD ;                    :##  edits a modulo 60 value preceded by a colon.               
: SEX ( n v - a n)   SWAP */  DUP ABS 0  <#  :## #S SIGN #> ;          SEX edits an angle, scaled by the inverse of the ratio given,   
: M. ( f)   <1.  '/REV SEX  TYPE SPACE ;      ( d:mm)                     as  ddd:mm .                                                 
: A. ( f)   <.5  '/REV SEX  TYPE SPACE ;     ( -d:mm)                  M.  types an angle as  ddd:mm  clipped 360.                     
                                                                       A.  types an angle as  ddd:mm  clipped +-180.                   
EXIT                                                                                                                                   
                                                                       GRC Additions for outputting angles with 2 decimal places rather
: ANGLE ( f )  D/REV SWAP */ DUP ABS 0 <# # # '.' #S SIGN #> ;          as degrees & minutes                                           
: M. ( f )  <1. ANGLE TYPE SPACE ;                                     ANGLE prepares angle for pictured output with 2 decimal places  
: A. ( f ) <.5 ANGLE TYPE SPACE ;                                      M. & A. as above but in degree format with 2 decimal places     
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( 5.14 bit logarithm of 31-bit integer-- GRC Addition LN)                                                                              
: LN2 ( d - f. f)   31 FOR  DUP 16384 AND IF                           These words compute logarithms of 32-bit integers.  The logs are
      MD I! DROP  0 R> D2/ D2/  MD I@ 2/ EXIT                             returned in a 19-bit format with the fractional part scaled  
   THEN  D2* SWAP  -2 AND SWAP  NEXT  0 ;                                 the same as in 14-bit fractions and a 5-bit integer above.   
                                                                          This form is denoted by  f.  in the stack effects.           
( Hart 2521: 4.14)                                                     NOTE: These may be output using the word .F.                    
: LOG2 ( d - f.)   LN2  8224 OVER *.  15587 +  OVER *.                 LN2 splits an integer into a double exponent, scaled 14, and a  
   -23811 +  SWAP 5769 + /.  3 + M+ ;                                     fraction less than one.                                      
( Note: Scale factors in following words are for change of base)                                                                       
: LOG ( d - n)   LOG2  204 11103 M*/ DROP ; ( LOG{2}*1000/+1)          LOG2 takes a 31-bit integer, giving a double logarithm to base 2
: LOG10 ( d - f.)   LOG2  8651 28738 M*/ ; ( LOG{2}=1/LOG2{10})           with the integer part scaled to +1.                          
: LN  ( d -- f. )  LOG2 7050 10171   M*/ ; ( LN{2}= 1/LOG2{e} )                                                                        
: CHAR ( d - n)   D2* D2*  SWAP DROP ;                                 LOG takes a double integer, returning its Log10 as a single     
: .F. ( f.)   OVER SWAP CHAR  (.) TYPE  ." ."                             binary number in the form  d.ddd .                           
      16383 AND  10000 *.  0  <# # # # #S #> TYPE SPACE ;              LOG10 gives the Log10 of a double integer in the same scale as  
                                                                          does LOG2 .                                                  
( 31-bit integer exponential of 5.14 bit fraction )                    LN  the natural logarithm of a double int. same scale as LOG2   
: SPLIT ( f - n n)   OVER MD I!  D2* D2* SWAP DROP  30 SWAP -          These words compute the 31-bit integer anti-log of a fraction   
      16383 MD I@ AND ;                                                   with 5 integer bits and 14 fractional bits (i.e., a 14-bit   
: SHIFT ( n n - d)   SWAP >R  0 SWAP  R> ?DUP IF                          fixed-point fraction).  Thus, these words are the converse   
      1- ?DUP IF  1- DO( THEN D2/ )  THEN ;                               of the words in the previous block.                          
                                                                       SPLIT  given a 14-bit logarithm, splits it into its fractional  
( Hart 1040:  4.12)                                                       component and integral (5-bit) component.                    
: EXP2 ( f. - d)   SPLIT  DUP 1277 *.  3704 +                          SHIFT  takes a count and number, and shifts the number by the   
      OVER *.  11399 + *.  +1 + SHIFT ;                                   specified number of bits.  The result is a double-precision  
: -LOG ( n - d)   0  11103 204 M*/  EXP2 ;                                number.                                                      
: EXP10 ( f. - d)   28738 8651 M*/  EXP2 ;                                                                                             
: EXP  ( f. -- d)   10171 7050 M*/  EXP2 ;                             EXP2  computes the base-2 anti-log of a 19-bit fraction.        
: .SCI ( f.)   OVER 16383 AND  1 EXP10  <#  # # # # 46 HOLD            -LOG  computes the base-10 anti-log of a value from  LOG .      
   #S #> TYPE  ."  E" CHAR . ;                                         EXP10  computes the base-10 anti-log of a 19-bit fraction.      
                                                                       EXP  computes the natural anti-log of a 19-bit fraction.        
                                                                       .SCI  displays a number whose LOG10 is given in scientific not- 
                                                                          ation.                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( 30-bit fraction multiply)                                                                                                            
: D*. ( d d - d)   MD I! >R  DUP >R OVER >R  MD I@ T*                  D*. multiplies two 30-bit signed fractions, giving a fraction,  
   SWAP ROT  R> R> R>  0 \\ + &2/ T*  D2* DUP 0< >R >R                    or an integer and a fraction, giving an integer.  This vers  
   SWAP DROP  +  MD I!  R> +c  DUP SR I!  SWAP R> +c                      delivers error on order of 1 LSB.  Arg limits for  T*  apply.
   D2* D2* SWAP DROP  MD I@ SR I@ D2* D2*                                 Non rounding version replaces the last two lines:            
      ( round) SWAP 0< NEGATE +  SWAP 0 +c ; ( 42+2*: 176-246)            MD I@ SR I@  D2* D2* SWAP DROP  SWAP ; ( 39+2*: 173-243)     
                                                                                                                                       
                                                                       Another version, about 30% faster, has been used by FORTH, Inc. 
                                                                          in many applics (particularly when data are accurate to 24   
                                                                          bits).  It has an error on the order of 4 LSB:               
                                                                                                                                       
                                                                       : SU* ( n u - d)   DUP 0< >R  OVER >R M*                        
                                                                             R> R> IF  + EXIT  THEN DROP ; ( 36-49)                    
                                                                       : '11 ( d d - d)   >R  OVER >R SU* SWAP  ROT R> 1 I@!  SWAP SU* 
                                                                          >R +  DROP  R> 2DUP + >R  0< SWAP 0< +c  R>                  
                                                                          R> R> M* >R +  SWAP R> +c  D2* D2* ; ( 31+3*: 130-169)       
   ( 32-bit normalization)   HEX                                                                                                       
: NORMALIZE ( d d - d d)   MD I!  SR I!  1D FOR                        NORMALIZE mutually normalizes a pair of double numbers to the   
   DUP DUP 2* XOR  MD I@ DUP 2* XOR OR  0< 1+ WHILE  D2*                  most significant 30-bit representation they will both allow. 
      SWAP -2 AND SWAP  SR I@ MD I@ D2*  MD I!  -2 AND SR I!                                                                           
   NEXT  ELSE  R> DROP  THEN  SR I@ MD I@ ; ( 18-246)                  NORM gives the most significant pair of 14-bit fractions that   
                                                                          are proportional to the pair of 30-bit numbers given.        
: TRUNCATE ( d d - f f)   SWAP DROP  ROT DROP ;                                                                                        
: NORM ( d d - f f)   NORMALIZE  TRUNCATE ;                            TRUNCATE  chops a pair of 30-bit fractions to 14 bits.          
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( 32-bit fraction quotient - divisor positive)                                                                                      
: D/. ( d +d - q)   DUP >R  SWAP >R  >R  D2/ D2/                       D/. divides a 30-bit fraction by a fraction, giving a fraction, 
      R> S/MOD  OVER OVER 0< SWAP  DUP I M*  SWAP DROP                    or an integer by a fraction, giving an integer, or an integer
   R> 0< IF  OVER +  THEN SWAP DROP  DUP 0< D-                            by an integer, giving a fraction.  The divisor must be a     
      >R 0 SWAP R>  R> T/  MD I! SWAP  MD I@ + ; ( 156-188)               positive number in any case.                                 
                                                                                                                                       
: D/. ( d +d - d)   NORMALIZE D/. ;                                    A piece of reference code that fails upon the overflow in add   
                                                                          and >FFFF in divide:                                         
                                                                       : D/. ( d +d - q)   SWAP >R >R  D2/ D2/ 0 ROT ROT  I T/         
                                                                          2DUP  R> R> SWAP >R  0 \\ + &2/ T*  R> T/ SWAP DROP          
                                                                          NEGATE  2*  >R  SWAP I +  SWAP R> 0< +c ;                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( 30-bit Angle input)                                                                                                                  
: 2lit ( - d)   R> DUP 2 + >R  32767 AND 1 @+ @ ;                      2LITERAL compiles a 32-bit literal.  Storage order is backward  
: 2LITERAL ( d)   COMPILE 2lit  \ \\  SWAP , , ;  IMMEDIATE               for speed.                                                   
0 +1 2CONSTANT +1.   1.000000000 2CONSTANT 1*9                         +1. is the scaled value assigned to +1.000...                   
: 9D ( d - d)   1*9 D/. ;      : 1.- ( d - d)   DNEGATE  +1 + ;        9D  converts a number in the form d.ddddddddd to a fraction.    
: M/MOD ( d n - d r)   >R  0 I U/MOD  1 I@!  U/MOD                     1.-  subtracts its argument from one.                           
      R> ROT  R> DROP ;                                                                                                                
                                                                       D/REV  is the ratio of ten-thousandths of degrees per revolution
360.0000 2CONSTANT D/REV                                               "/REV  is the ratio of arc seconds per revolution.              
1,296,000 2CONSTANT "/REV   864,000 2CONSTANT S./REV                   S/REV  is the ratio of 1/10 hour angle seconds per revolution.  
: D ( d.dddd - da)   D/REV D/. ;      : "/   "/REV D/. ;               S./REV  is some unknown ratio.                                  
: S ( hmmss.s - da)   1000 M/MOD >R DROP  100 /MOD 60 * +                                                                              
      600 M*  R> M+  S./REV D/. ;                                      D  converts an angle in  +|-ddd.dddd  to revolutions.           
: " ( ddmmss - da)   DUP >R DABS  100 M/MOD >R  100 M/MOD              S  converts an hour angle in  hh:mm:ss.s  to revolutions.       
      ROT 60 * + +  60 M*  R> M+ "/  R> 0< IF  DNEGATE  THEN ;         "  converts an angle in  +|-ddd:mm:ss  to revolutions.          
: D' ( dmm - da)   100 1 M*/  " ;                                      D'  converts an angle in  +|-ddd:mm  to revolutions.            
   ( Angle arithmetic)                                                                                                                 
: <1. ( f - f)   16383 AND ;                                           <1.  clips an angle to be less than 360 degrees.                
: <.5 ( f - f)   2* 2*  2/ 2/ ;                                        <.5  clips an angle to be in +-180 degrees.                     
                                                                       A-  subtracts two angles and returns a 180-clipped result.      
: DA- ( f f - f)   D-  <1. ;                                           M-  subtracts two angles, returning a 14-bit fraction.          
: DA+ ( f f - f)   D+  <1. ;                                                                                                           
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Angle output)                                                                                                                     
: ALIGN ( a n w)   OVER - SPACES  TYPE ;      : '.'   46 HOLD ;        ALIGN  types a given string in a right-justified field.         
: :## ( d - d)   #  6 BASE !  #  DECIMAL  58 HOLD ;                    :##  edits a modulo 60 value preceded by a colon.               
: SEX ( d d n)   >R  >R >R  SWAP OVER DABS  1 M+  R> R> D*.            SEX  given an angle, a ratio, and a number of decimal places,   
   R>  <# ?DUP IF  0 DO  # LOOP '.'  THEN  :## :## #S SIGN #> ;           edits the angle in degrees, minutes, seconds with that number
: S. ( d)   <1. S./REV  1 SEX  11 ALIGN ;   ( h:mm:ss.s)                  of decimal places after scaling by the inverse of the ratio. 
: T. ( d)   S./REV 1 SEX  2 - 10 ALIGN ;     ( h:mm:ss)                                                                                
: M. ( d)   S./REV 1 SEX  5 - 6 ALIGN ;     ( h:mm)                    S.  T.  and  M.  edit hour angles as shown.                     
: ". ( d)   "/REV 0 SEX  10 ALIGN ;        ( d:mm:ss)                  ".  edits degrees, minutes, and seconds as shown.               
: (..)   <#  ?DUP IF  0 DO  #  LOOP  '.'  THEN  #S SIGN #> ;                                                                           
: DEG ( da)   SWAP OVER DABS  2 M+  D/REV D*.  4 (..) ;                (..)  edits a number given sign, value, and number of decimal   
: .DEG ( da)   DEG 9 ALIGN ;      ( d.dddd)                               places, returning its address and length.                    
: .D. ( n wwd)   10 /MOD >R  OVER ABS 0 ROT (..)  R> ALIGN ;           DEG  formats an angle in degrees with 4 decimal places.         
: .DD. ( d wd)   10 /MOD >R >R  SWAP OVER DABS                         .DEG  edits an angle as shown.                                  
      R> (..)  R> ALIGN ;                                              .D.  edits a number given field width and decimal places;       
: .F ( df)   1*9 D*.  9 .DD.  SPACE ;                                  .DD.  does the same for double numbers.                         
( 30-bit sine & cosine of 30-bit fraction)                             .F  displays a 30-bit fraction with 9 decimal places.           
: QUAD ( da - da n)   <1.  DUP 0  D2* D2* D2* D2*  >R                  30-bit fractions are a powerful way of representing angles,     
   DROP  D2* D2* <1.  SWAP -4 AND SWAP  R> ;                              with +1. equivalent to one full revolution (360 degrees.)    
                                                                          Resolution is 5.8 picoradians, .9 picorevolutions, 1.2 ms of 
    .570796290 9D +1 +   -.645963360 9D   .079688481 9D                   arc, or 80.5 us of hour angle.                               
   -.004672228 9D    .000150821 9D   ( Hart 3301)                                                                                      
: APPROX ( df - df)   2DUP 2DUP D*.  2DUP 2LITERAL D*.                 QUAD  dismantles an angle into fraction of a quadrant and the   
   2LITERAL D+ 2OVER D*.  2LITERAL D+ 2OVER D*.                           quadrant number (0-3).                                       
   2LITERAL D+ D*.  2LITERAL D+ D*. ;                                  APPROX  is an approximation for the sine of a positive angle <90
                                                                                                                                       
HERE   0 ,  5 ,  6 ,  3 ,                                              DTAN  takes a 22-bit angle, returning its sine and cosine       
: DTAN ( da - df df)   QUAD  LITERAL + @ >R  2DUP 1.- APPROX              as 30-bit fractions.  Log10 max abs error:  -8.48            
   2SWAP APPROX  I 1 AND IF  2SWAP  THEN  I 2 AND IF                                                                                   
      DNEGATE  THEN  2SWAP  R> 4 AND IF  DNEGATE EXIT  THEN ;                                                                          
                                                                                                                                       
                                                                                                                                       
   ( 30-bit atan of 30-bit signed ratio)                                                                                               
: !SET ( n)   R> SWAP  DUP 1 AND  I + R> + >R  1+ + >R ;               DATAN  returns a 4-quadrant angle that is the arctangent of the 
                                                                          ratio given.  The ratio need not satisfy the sum of squares  
HERE  OCTAL  -6000 ,   2000 ,  32000 , -36000 ,                           identity for sine and cosine.                                
             12000 , -16000 , -26000 ,  22000 ,                                                                                        
DECIMAL .159154854 9D   -.053034798 9D   .031323390 9D                                                                                 
       -.017687390 9D    .414213562 9D   2DUP DNEGATE                                                                                  
                                                                                                                                       
: DATAN ( d d - da)   0 >R  DUP 0<  !SET DNEGATE                                                                                       
   2SWAP DUP 0<  !SET DNEGATE  2OVER 2OVER  2SWAP D< !SET 2SWAP                                                                        
   D/.  2DUP 2LITERAL D+  2SWAP 2LITERAL D*.  +1 + D/.                                                                                 
      2DUP 2DUP D*.  2DUP 2LITERAL D*.  2LITERAL D+  2OVER D*.                                                                         
      2LITERAL D+ D*.  2LITERAL D+ D*.                                                                                                 
   R> LITERAL + @ + DABS  <.5 ;                                                                                                        
                                                                                                                                       
                                                                                                                                       
   ( 30-bit square root of 30-bit fraction)                                                                                            
: 2NORM ( d - n d)   D2/ D2/  0 >R  2DUP OR IF  BEGIN                  2NORM  normalizes a 30-bit fraction and saves a negative count  
      DUP -1024 AND 0= WHILE  D2* D2* SWAP -4 AND SWAP                    for later use in denormalization.                            
         R> 1+ >R  REPEAT  THEN  MD I! SR I!  R>  SR I@ MD I@ ;                                                                        
: -NORM ( n d - d)   ROT ?DUP IF  1- FOR  D2/ NEXT  THEN ;             -NORM  denormalizes a 30-bit fraction according to the given    
                                                                          count.  The Non-EIS coding is intended to replace the ASHC   
: DSQRT ( df - df)   2NORM  2DUP SQRT >R                                  instruction in this definition for non-EIS systems.          
      D2*  SWAP -2 AND SWAP  +1 I M*/  0 R> D2/ D+ -NORM ;                                                                             
: R1-2 ( d - d)   2DUP D*.  1.- DSQRT ;                                SQRT,  calculates the square root of a 30-bit fraction.         
                                                                          Max error is on the order of 2 LSB.                          
                                                                                                                                       
                                                                       R1-2  returns the complement of a fraction in quadrature.       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( 48-bit data)                                                                                                                         
: 3ARRAY ( n)   CREATE 3 * ALLOT  DOES> ( n - a)  OVER 2* + + ;        This block supports 48-bit data items of any type.  Consistent  
: 3VARIABLE   2VARIABLE  0 , ;                                            with double precision conventions, the "most significant"    
                                                                          data (or "x" component of a 3-vector) is kept on top of the  
: 3@ ( a - fp)   2 +  1 @-  1 @-  @ ;                                     stack and is stored into the lowest memory address.          
: 3! ( fp a)   1 !+  1 !+  ! ;      : T, ( fp)   , , , ;                                                                               
: 3CONSTANT ( fp)   CREATE T,  DOES> ( - fp)   3@ ;                    3ARRAY  defines an array of triple numbers of the given size.   
                                                                       3VARIABLE  defines a triple valued variable, initialized zero.  
: 3DUP ( fp - fp fp)   MD I!  SR I!  DUP >R                            3@  and  3!  fetch and store triple numbers, exponent first.    
      SR I@  MD I@  R>  SR I@  MD I@ ; ( 9)                            T,  simply compiles a triple into the dictionary.               
: 3SWAP ( fp fp - fp fp)   MD I!  SR I!                                3CONSTANT  defines a triple constant.                           
   SWAP >R  SWAP >R  SWAP >R  SR I@  MD I@  R> R> R> ; ( 15)                                                                           
: 3DROP ( fp)   DROP DROP DROP ; ( 4)                                  The triple stack operators perform their classical functions.   
: 3OVER ( f f - f f f)   >R >R >R  MD I! DUP SR I! OVER >R MD I@                                                                       
   R>  R> SWAP  R> SWAP  R> SWAP  SR I@  MD I@ ;                                                                                       
                                                                                                                                       
( Floating normalization)                                                                                                              
: NORMALIZED ( df n - fp)   1+ MD I!  2DUP OR IF                       Floating point numbers are kept in a 3-cell format consisting of
      BEGIN  DUP DUP 2* XOR  0< 1+ WHILE  D2*                             a 30-bit signed mantissa and a 16-bit signed binary exponent.
         SWAP -2 AND SWAP  MD I@ 1- MD I!  REPEAT  D2/ MD I@              Mantissas are normalized if they are in the inclusive range  
   ELSE  DROP DROP 0 0  0  THEN ;                                         [ C000,0000 .. 3FFF,FFFF ] .  Any of the basic arithmetic    
                                                                          operators may be expected to fail if given unnormalized args.
: D>F ( d - fp)   30 NORMALIZED ;                                         True zero is represented by three zeroes.                    
: D.>F ( df - fp)   0 NORMALIZED ;                                     Exponents are on top of the stack and at lowest memory addresses
: N>F ( n - f)   0 SWAP  14 NORMALIZED ;                                                                                               
: F>D ( fp - d)   30 - DUP 0< IF  NEGATE 31 MIN 1- FOR  D2/ NEXT       D>F  and  D.>F  convert double integers and fractions to float. 
   EXIT  THEN IF  D2*  SWAP -2 AND SWAP  THEN ;                        N>F  does the same for a single precision number.               
: F>D. ( fp - d)   30 + F>D ;                                          F>D  converts floating to double; zero results for very small   
                                                                          numbers, while garbage ensues for those too big.             
: FNEGATE ( fp - fp)   >R DNEGATE  R> NORMALIZED ;                     F>D.  converts floating to 30-bit fraction; zero if too small,  
: FABS ( fp - fp)   OVER 0< IF  >R DNEGATE  R>  THEN ;                    garbage if outside range for 31-bit fractions.               
: F2/ ( fp - fp)   1- ;      : F2* ( fp - fp)   1+ ;                   The simple operators here are quite fast since they don't really
   ( Floating arithmetic)                                                 involve floating point arithmetic.                           
: EXPONENTS ( fp fp - df df n n)   >R  ROT R> ;                        Arithmetic operations should work across the entire range of two
: ALIGNED ( fp fp - df df n)   EXPONENTS  OVER 32768 +                    to the plus or minus 32k'th.  No special handling is given to
      OVER 32768 +  U< IF  >R >R  2SWAP  R> R> SWAP  THEN                 exponent over or underflow; if this becomes an issue, we will
   OVER >R -  ?DUP IF  DUP 31 U< IF  1- >R  DUP 0< SR I!                  suggest that underflow is the only remotely likely condition 
      DABS  BEGIN D2/  NEXT  SR I@ IF DNEGATE  THEN                       and that this could be tested for in NORMALIZED by limiting  
   ELSE  DROP DROP DROP 0 0  THEN  THEN R> ;                              numbers to approximately 1/2 the maximum negative exponent.  
: F+ ( fp fp - fp)   ALIGNED >R  D+  R> NORMALIZED ;                      The effort to maintain 30-bit precision has not been carried 
: F- ( fp fp - fp)   FNEGATE F+ ;                                         to extremes; speed is gained at the expense of low ord noise.
: F* ( fp fp - fp)   EXPONENTS + >R  D*.  R> NORMALIZED ;                                                                              
: F/ ( fp fp - fp)   EXPONENTS - >R  DUP 0< >R DABS                    The rest of the operators are conventional.                     
      D/.  R> IF  DNEGATE  THEN  R> NORMALIZED ;                                                                                       
: F< ( f f - t)   F- DROP 0<  SWAP DROP ;                              The relationals can only handle half the range of legal numbers 
: F> ( f f - t)   3SWAP F< ;                                              before they begin producing garbage.  Considering the ranges 
: FMAX ( f f - f)   3OVER 3OVER F< IF  3SWAP  THEN 3DROP ;                attainable with 16 bit exponents this is hardly an issue.    
: FMIN ( f f - f)   3OVER 3OVER F< NOT IF  3SWAP  THEN 3DROP ;                                                                         
   ( Simple conversion)                                                                                                                
0 3ARRAY 10**   1. D>F T,  10. D>F T,  100. D>F T,                     Often it's unnecessary to go through the whole hassle with      
   1,000 D>F T,  10,000 D>F T,  100,000 D>F T,                            full floating I/O conversion.  This block supports simple    
   1,000,000 D>F T,  10,000,000 D>F T,  100,000,000 D>F T,                conversion of numbers on the order of 10 to the +|- eighth   
   1,000,000,000 D>F T,                                                   with minimal space consumption.                              
                                                                                                                                       
: FLT ( d - f)   D>F  PTR @ 10** 3@ F/ ;                               10**  is a table of floating powers of ten from 0 thru 9.       
: F, ( d)   FLT  T, ;                                                  FLT  converts an input number with decimal to floating.         
   0.0 FLT 3CONSTANT F0.   1.0 FLT 3CONSTANT F1.                          Maximum is largest double integer; down to 9 decimal places. 
                                                                       F,  compiles such an input number into the dictionary.          
: (FP) ( f - a n)   >R SWAP OVER R> FABS  3DUP F>D                                                                                     
      2DUP >R >R D>F F-  9 10** 3@ F* F>D                              F0.  and  F1.  are floating zero and unity.                     
   <#  # # # # # # # # # 2DROP  46 HOLD  R> R> #S  SIGN #> ;                                                                           
: FP. ( f)   (FP) TYPE SPACE ;                                         (FP)  edits a floating number with 9 decimal places.            
                                                                       FP.  displays a number in that format.                          
                                                                                                                                       
   ( 30-bit log, exp)                                                                                                                  
( Hart 2524: 8.32)                                                     Anyone interested in programming approximations to the classical
   .035355343 9D  .454517087 9D  .642784209 9D  .099999999 9D             functions is encouraged to study "Computer Approximations" by
   .205466671 9D -.886265994 9D  .610585199 9D  .481147461 9D             John F. Hart, et al.  ISBN 0-88275-642-7.  Original edition  
: Dlog ( df - df)   2DUP  2LITERAL D*. 2LITERAL D+  2OVER D*.             1968, reprinted 1978 with corrections, John Wiley & Sons.    
   2LITERAL D+  2OVER D*. 2LITERAL D-  2SWAP  2DUP 2LITERAL D*.           Currently printed and published by:                          
   2LITERAL D+  2OVER D*. 2LITERAL D+  D*. 2LITERAL D+  D/. ;                                                                          
                                                                             Robert E. Krieger Publishing Company, Inc.                
( Hart 1043:  8.73)   .693146984 9D  .240229836 9D                           Krieger Drive                                             
   .055483342 9D  .009678841 9D  .001243969 9D  .000217023 9D                Malabar, Florida  32950                                   
: Dexp ( df - df)   2DUP 2LITERAL D*.  2LITERAL D+  2OVER D*.                                                                          
   2LITERAL D+  2OVER D*.  2LITERAL D+  2OVER D*.                      The time taken by any of these functions is determined by the   
   2LITERAL D+  2OVER D*.  2LITERAL D+ D*.  +1 +  1 M+ ;                  required accuracy.  Since multiplies vanish in great quantity
                                                                          as an application dismisses the need for digits of precision,
                                                                          the student is strongly encouraged to tailor his math to his 
                                                                          immediate needs in any time critical application.  Failure to
   ( Floating math)                                                       do so is symptomatic of wastefulness, hurry, and/or sloth.   
: FSQRT ( fp - fp)   DUP 1 AND IF  1- >R  D2*                                                                                          
      ELSE >R  THEN DSQRT  R> 2/ ;                                                                                                     
: SQUARED ( fp - fp)   3DUP F* ;                                                                                                       
: F1-2 ( fp - fp)   SQUARED FNEGATE  F1. F+  FSQRT ;                                                                                   
                                                                                                                                       
: FLOG2 ( fp - fp)   >R Dlog  D.>F  R> N>F F+ ;                                                                                        
: FEXP2 ( fp - fp)   3DUP F>D  OVER >R  D>F F- F>D.                                                                                    
   Dexp R> NORMALIZED ;                                                                                                                
                                                                                                                                       
( Base ten)  10 N>F FLOG2 3CONSTANT L10                                                                                                
   : FLOG ( fp - fp)   FLOG2  L10 F/ ;                                                                                                 
   : FEXP10 ( fp - fp)   L10 F*  FEXP2 ;                                                                                               
( Natural)  1.718281828 FLT 1 N>F F+ FLOG2 3CONSTANT L2E                                                                               
   : FLN ( fp - fp)   FLOG2  L2E F/ ;                                                                                                  
   : FEXP ( fp - fp)   L2E F*  FEXP2 ;                                                                                                 
( Least squares fitting)                                                                                                               
6 1+ CONSTANT NV      100 CONSTANT UNIT      VARIABLE PTS              NV  is one more than the upper limit on number of Variables,    
: K ( - n)   R> R> R> R>  I MD I!  >R >R >R >R  MD I@ ; ( 12)             or Parameters.  These are what we're solving for.            
: D+! ( d a)   DUP >R  2@ D+  R> 2! ;                                  P  is the array of variables.  Presumably it is initialized to  
                                                                          zero when we start this mess.                                
ARRAY P   NV ALLOT                                                     PTS  counts the number of times EQUATION has been used.         
ARRAY EQ   NV ALLOT                                                                                                                    
ARRAY M   NV DUP * 2* ALLOT                                            EQ  is scratch, used only within EQUATION.                      
: M ( j i - a)   SWAP NV * +  2* M ;                                                                                                   
                                                                                                                                       
: CORRECT   NV 1 DO  I 0 M 2@  UNIT M/  I P +!  LOOP ;                                                                                 
: YS ( - n)   0 0 M 2@  1 PTS @  NV 1- - M*/ SQRT ;                                                                                    
: XS ( n i - n)   DUP M 2@ SQRT  UNIT */ ;                                                                                             
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Normal equations and solution)                                                                                                    
: ZERO   0 PTS !  0 0 M  [ NV DUP * 2* ] LITERAL ERASE ;                                                                               
                                                                                                                                       
: EQUATION ( ..c o)   1 PTS +!  SWAP -  NV 0 DO  DUP I EQ !                                                                            
      I 1+ 0 DO  DUP I EQ @ M*  J I M D+!  LOOP DROP LOOP ;                                                                            
                                                                                                                                       
: SOLVE   NV 1 DO  I 1 DO  J I M 2@  I J M 2!  LOOP LOOP                                                                               
   NV 1 DO  I I M 2@  0 0 I I M 2!                                                                                                     
      NV 1 DO  I J - IF  2DUP I J M 2@  NORM SWAP                                                                                      
         NV 0 DO  K I M 2@  2OVER M*/ DNEGATE  J I M D+!  LOOP                                                                         
         UNIT DUP M*  2SWAP M*/ DNEGATE  I J M 2!                                                                                      
         THEN LOOP  UNIT DUP M*  2DUP I I M 2!  NORM SWAP                                                                              
      NV 0 DO  J I M 2@  2OVER M*/  J I M 2!  LOOP 2DROP                                                                               
      LOOP  CORRECT ;                                                                                                                  
                                                                                                                                       
                                                                                                                                       
   ( Numeric differentiation)                                                                                                          
VARIABLE 'F   : F ( - n)   'F @EXECUTE ;                                                                                               
                                                                                                                                       
: DIFF ( - ..c)   F >R  1 NV 1- DO  UNIT  I P +!  F J -                                                                                
      UNIT NEGATE  I P +!  -1 +LOOP  R> ;                                                                                              
: FUNCTION ( n - a)   1+ ['] NV !  'F ;                                                                                                
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Spline)                                                                                                                              
: 2ARRAY ( n)   CREATE 2* ALLOT  DOES> ( n - a)   OVER + + ;           The spline fit takes a set of  n  raw data points and produces  
20 CONSTANT PTS   PTS 2ARRAY raw   999 CONSTANT n                         coefficients for the  n-1  third degree functions composing  
: >raw ( v)   n raw 2!  1 ['] n 1+ +! ;                                   the spline function fitting those points.                    
                                                                       PTS  is the maximum number of data points that can be handled.  
: x ( i - f)   raw @ N>F ;                                             raw  contains  n  raw data points to be fit.  X stored first.   
: y ( i - f)   raw 1+ @ N>F ;                                          >raw  files an integer vector in  raw .  Points must be filed   
: h ( i - f)   DUP >R 1+ x  R> x F- ;                                     in increasing order of  x  with no replication of x values.  
: v ( i - f)   DUP >R 1- h  R> h F/ ;                                  x  and  y  return raw coordinates for the given data point.     
: w ( i - f)   DUP >R  1+ y  I y F-  R> h F/ ;                                                                                         
                                                                       To solve for the coefficients we first construct a system of n-2
6.0 FLT 3CONSTANT F6.   0.5 FLT 3CONSTANT F.5                             linear equations for the variables  1 phi  thru  n-2 phi .   
: ai ( i - f)   v ;                                                       By definition,  0 phi  and  n-1 phi  are zero.               
: bi ( i - f)   v  F1. F+  F2* ;                                       h , v , and w  are subexpressions factored out of  a  thru  d . 
: ci ( i - f)   DROP F1. ;                                             ai , bi , ci , and di  are the coefficients for the i'th linear 
: di ( i - f)   DUP >R w  I 1- w F-  F6. F*  R> h F/ ;                    equation needing to be solved.  They produce garbage for     
   ( Tridiagonal solution)                                                i = 0  and  i = n-1 .                                        
PTS 3ARRAY beta   PTS 3ARRAY gamma   PTS 3ARRAY phi                    MATRIX  solves a tridiagonal system of linear equations using   
                                                                          recursion formulae for beta, gamma, and phi.  The system     
: BETAS   1 bi  3DUP 1 beta 3!  n 1- 2 DO  I ai  I 1- ci F*               comes from the spline's equations for phi (u):               
      3SWAP F/  I bi 3SWAP F-  3DUP I beta 3!  LOOP  3DROP ;                                                                           
                                                                       i=1  a1 u0 + b1 u1 + c1 u2                          =  d1       
: GAMMAS   1 di  1 beta 3@ F/  3DUP 1 gamma 3!                         i=2          a2 u1 + b2 u2 + c2 u3                  =  d2       
   n 1- 2 DO  I ai F*  I di 3SWAP F-                                   i=3                  a3 u2 + b3 u3 + c3 u4          =  d3       
      I beta 3@ F/  3DUP I gamma 3!  LOOP  3DROP ;                     i=4                          a4 u3 + b4 u4 + c4 u5  =  d4       
                                                                                                                                       
: PHIS   0 phi  PTS 3 * ERASE  n 2 - gamma 3@                          The above system is for 6 raw data points (n=6), thus data pts  
   3DUP n 2 - phi 3!  1 n 3 - DO  I ci F*  I beta 3@ F/                   exist for i=0..n-1.  The set of equations always trims these 
      I gamma 3@ 3SWAP F-  3DUP I phi 3!  -1 +LOOP  3DROP ;               limits in by one.  Further, phi (u) sub zero and 5 are by    
                                                                          definition zero, which is fortunate since the tridiagonal    
: MATRIX   BETAS  GAMMAS  PHIS ;                                          solution assumes that  a1 u0  and  c4 u5  are both zero.     
                                                                       If memory is critical, phi and gamma can be allocated in the    
   ( Coefficients)                                                        same space as is obvious from the order of calculation.      
PTS 3ARRAY aj   PTS 3ARRAY bj   PTS 3ARRAY cj   PTS 3ARRAY dj          SOLVE  is used after filling the raw data table to solve the    
                                                                          system of linear equations and develop the coefficients for  
: SOLVE   MATRIX  n 1- 0 DO  I h  F6. F*                                  the set of cubic polynomials composing the spline function.  
      I phi 3@ 3OVER F/  I aj 3!                                                                                                       
   I 1+ phi 3@ 3SWAP F/  I bj 3!  I h  F6. F/                          SPLINE  evaluates the spline function for the given argument    
   I 1+ y I h F/  3OVER I 1+ phi 3@ F* F-  I cj 3!                        with rounding, in the same scale as the raw data.  Returns   
      I y I h F/  3SWAP I phi 3@ F* F-  I dj 3!  LOOP ;                   the largest negative value for arguments outside range.      
                                                                                                                                       
: SUBDIVIDE ( n - n i | -32K)   DUP 0 raw @  n 1- raw @ 1+             Test case:  0 ' n 1+ !  1 1 >raw  3 2 >raw  4 4 >raw  2 5 >raw  
   WITHIN IF  1 BEGIN  2DUP raw @ > WHILE  1+ REPEAT  1-               i  ai  bi    ci  bet   gam   phi     aj      bj     cj     dj   
      ELSE  R> 2DROP  32768  THEN ;                                    0  --  --   ---  ---   ---     0      0   -.125  3.125      1   
: SPLINE ( n - n)   SUBDIVIDE >R  N>F  I 1+ x 3OVER F-                 1  .5   3  -4.5    3  -1.5  -.75 -.0625  -.1875   2.75   1.75   
   3DUP  3DUP 3DUP F* F*  I aj 3@ F*  3SWAP I dj 3@ F*  F+             2   2   6   -15 16/3 -2.25 -2.25  -.375       0      2  4.375   
      3SWAP  I x F-  3DUP  3DUP 3DUP F* F*  I bj 3@ F*                 3  --  --   ---  ---   ---   ---    ---     ---    ---    ---   
   3SWAP R> cj 3@ F*  F+ F+  F.5 F+  F>D  ( CLIP)DROP ;                                                                                
( Rational approximations)                                                                                                             
: HELP   218 HELPS ;   HELP                                            This block derives 15-bit rational approximations for numbers   
( Arith)  217 LOAD   9999 CONSTANT KK   VARIABLE DONE                     that start out as 31-bit ratios.  It's useful for coming up  
ARRAY DD  6 ALLOT   ARRAY PP  3 ALLOT   ARRAY QQ  3 ALLOT                 with the nice ratios used by  */  for producing the effect of
                                                                          real arithmetic; for the errors in these ratios are often on 
: ADV ( - t)   0 DD 2@ 2 DD 2@ D/  SWAP ['] KK 1+ !                       the order of ten to the minus eighth or better.  The method  
   0 DD 2@  2 DD 2@ KK UM* D-  4 DD 2!                                    was pointed out by a nice fellow from Richmond, VA and is far
   1 PP @ KK M*  0 PP @ UM+ >R  DUP 2 PP !  0< OR  R> OR                  better than the exhaustive searches that were used earlier.  
   1 QQ @ KK M*  0 QQ @ UM+ >R  DUP 2 QQ !  0< OR  R> OR ;                In all cases it will produce the same or better ratios for   
: STEP   2 DD 0 DD 4 MOVE  1 PP 2@ 0 PP 2!  1 QQ 2@ 0 QQ 2! ;             the examples in  Starting FORTH.  Method derives from Euclid.
                                                                                                                                       
: RATIO ( +d +d - n n)   2OVER 2OVER D< DUP >R IF  2SWAP  THEN         RATIO  requires that both of its arguments be positive, 31-bit  
   2 DD 2! 0 DD 2!  1 0 PP !  0 1 PP !  0 0 QQ !  1 1 QQ !                numbers.  It returns a pair of 15-bit positive numbers in the
   BEGIN  2 DD 2@ OR WHILE  ADV 0= WHILE  STEP REPEAT THEN                same order that are a darned good approximation to the first 
      1 QQ @  1 PP @  R> IF  SWAP  THEN ;                                 pair.  Data management will some day be cleaned up if we ever
                                                                          get a  D/  that's fast enough to make this whole procedure   
   ( Arithmetic)                                                          attractive for application rather than design time use.      
: Q2* ( q - q)   >R >R >R  DUP +  I R> +c  I R> +c  I R> +c ;          The only unique piece of arithmetic required by the above is  D/
                                                                          which returns the 32-bit quotient of two 32-bit integers.    
: D/ ( d d - dq)   -1 XOR SR I!  MD I!  0 0  0                                                                                         
   15 FOR  >R Q2*  SWAP MD I@ -  SWAP SR I@ +c  I R> +c                There are several alternative ways of obtaining this quotient   
      DUP >R  1 AND 1- IF  SWAP MD I@ +  SWAP SR I@ -1 XOR +c             that are faster than the brute force, binary divide algorithm
         THEN  R> NEXT  >R  0                                             shown here.  However the applicability and fixups required   
   15 FOR  >R Q2*  SWAP MD I@ -  SWAP SR I@ +c  I R> +c                   in those methods are extremely hardware sensitive and take   
      DUP >R  1 AND 1- IF  SWAP MD I@ +  SWAP SR I@ -1 XOR +c             much careful testing.  This method can be easily implemented 
   THEN  R> NEXT  >R  DROP DROP DROP DROP  R> R> ;                        on just about anything so it's offered as a model.           
                                                                                                                                       
: UM* ( d u - d)   >R  SWAP I U*  ROT R> * + ;                                                                                         
: UM+ ( d u - d)   0 D+ ;                                                                                                              
                                                                                                                                       
: D.R ( d n)   >R  SWAP OVER DABS  <# #S SIGN #>                                                                                       
      R> OVER - SPACES TYPE ;                                                                                                          
       R A T I O N A L   A P P R O X I M A T I O N S                                                                                   
                                                                                                                                       
   Given a number expressed as a ratio of positive 31-bit                                                                              
integers, calculates a ratio of 15-bit numbers that very closely                                                                       
approximates the original ratio.  Such 15-bit ratios may then be                                                                       
used with */ for accurate multiplication by "real" constants.                                                                          
                                                                                                                                       
   Will reproduce, or improve upon, the conventional ratios used                                                                       
by FORTH, Inc. (see STARTING FORTH, Leo Brodie, p.122).                                                                                
   For best results, use the largest values (with the most sig-                                                                        
nificant bits) possible, as in these examples:                                                                                         
                                                                                                                                       
     18.84955592 6.00000000 RATIO . .   (Pi, gives 355/113)                                                                            
     19.02797280 7.00000000 RATIO . .   ( e, gives 25946/9545)                                                                         
                                                                                                                                       
                                                                                                                                       
( Remarkable algorithms)                                                                                                               
: INTERVAL ( n n - n)   / >R  1 1 BEGIN  OVER I < WHILE  1+            INTERVAL  calculates a nice logarithmic grid interval, given a  
   DUP 3 MOD  0= 4 SWAP -  ROT 2 */  SWAP REPEAT  R> 2DROP ;              positive range and a nominal maximum number of divisions.    
                                                                          This maximum may be doubled for ranges from 0 to 3* it.      
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
HELP             Displays these  DOS  instructions                                                                                     
INITIALIZE       Formats a 9-sector double sided 360k floppy.                                                                          
INIT             Clears the FAT and directory of a floppy.                                                                             
LABEL ______     Creates volume header of remaining text on line                                                                       
DIR              Displays active files in the DOS directory.                                                                           
.FAT             Displays the FAT for diagnostic purposes.                                                                             
OPEN name.ext    Opens the given file for IN or OUT use.                                                                               
DELETE name.ext  Deletes the given DOS file.                                                                                           
n ADD name.ext   Creates a new file with space for the given no.                                                                       
                    of FORTH blocks.                                                                                                   
                                                                                                                                       
s d n IN         Copies  n  blocks from DOS floppy starting at                                                                         
                    block  s  in the current file to normal disk                                                                       
                    starting at block  d .                                                                                             
s d n OUT        Copies in the other direction (from  s  on the                                                                        
                    normal disk to  d  in the DOS file.)                                                                               
( DOS floppies)   EMPTY   DECIMAL                                                                                                      
: HELP   221 HELPS ;      HELP                                         This utility supports limited access to DOS floppies.  They must
                                                                          be double sided, 40 cylinders, 9 sectors per track.  The main
356 0 2CONSTANT FATS   ~ 112 0 2CONSTANT RECORDS                          purpose for the utility is transfer of FORTH blocks to & from
VARIABLE 0TH   VARIABLE LIM   CREATE OPENED  0 ,                          IBM PC's.                                                    
VARIABLE #DIR   CREATE ORG  ( FLOPPY) 10800 ,   HEX                    FATS  returns the range of legal FAT indices as loop params.    
                                                                       RECORDS  returns the range of the directory as loop params.     
: Block ( n - a)   OFFSET @ - BLOCK ;                                  ORG  is the starting block number of the DOS floppy in use.     
: SECTOR ( n - b)   100 200 */MOD  ORG @ + Block +  BYTE ;             #DIR  is the index of the directory entry in use;               
: LEGAL   1 SECTOR C@  0FD - ABORT" Not 9-sector dbl sided!" ;         OPENED  is nonzero if its file has been "opened", in which case 
: READY   LEGAL  OPENED @ 0= ABORT" No file opened" ;                  0TH  is its 1st cluster and  LIM  is blocks in the file.        
: SHUT   0 OPENED ! ;                                                                                                                  
                                                                       Block  debiases block #s for the DOS floppy regardless of offset
( Format)  DECIMAL 35 LOAD                                             SECTOR  returns the starting byte address of a 0-relative sector
( Rest)  223 227 THRU                                                  LEGAL  aborts if the disk isn't marked as 9-sector dbl sided.   
                                                                       READY  aborts if a file isn't ready to use.                     
   ( File alloc table)   HEX                                           SHUT  indicates no file is ready.                               
: FAT ( n - b)   200 /MOD  1+ SECTOR + ;                               This block deals with the File Allocation Table which starts in 
: (FAT) ( n - t n)   3 2 */MOD                                            sector 1 for 2 copies of 2 sectors.  Its entries are 12 bits 
      DUP FAT C@  SWAP 1+ FAT C@  100 * + ;                               long with a funny mapping.  FAT indices are 0-relative; 2 is 
: @FAT ( n - n)   (FAT) SWAP IF  10 /  THEN 0FFF AND ;                    mapped onto the block starting in sector 12.                 
: !FAT ( n n)   DUP 3 2 */MOD  >R IF  SWAP 10 * SWAP  THEN                                                                             
      (FAT) SWAP IF  0F AND  ELSE F000 AND  THEN +                     FAT  returns the address of a given byte in the FAT.            
   100 /MOD  I 1+ FAT C! UPDATE  R> FAT C! UPDATE ;                    (FAT)  returns oddness and unshifted value of a FAT entry.      
                                                                       @FAT  returns the value in a given FAT cluster slot.            
: TH ( n - n)   READY  DUP LIM @ 0 WITHIN ABORT" Outside file!"        !FAT  stores a value in a given FAT cluster slot.               
   0TH @ SWAP  ?DUP IF  1- FOR  @FAT NEXT  THEN ORG @ +  4 + ;                                                                         
: FREE   READY  0TH @ BEGIN  DUP FATS SWAP WITHIN WHILE                TH  converts a 0-rel block number within the currently opened   
      DUP @FAT  0 ROT !FAT  REPEAT  DROP ;                                file to an absolute system-wide block number.                
                                                                       FREE  frees all blocks allocated to the current file.           
: #FREE ( - n)   0  FATS DO  I @FAT 0=  DUP IF                                                                                         
      OVER PAD +  I SWAP !  THEN -  LOOP ;                             #FREE  returns the number of free blocks on the disk.  In add-  
   ( Directory)   HEX                                                     ition, it leaves a list of their FAT's starting at  PAD .    
: READ ( n)   #DIR ! SHUT ;                                            This block deals with the DOS directory, composed of 112 entries
: NAME ( - b)   #DIR @  20 200 */MOD  5 + SECTOR + ;                      of 32 bytes each.  Date/time are superfluous & not maintained
: (DIR) ( n)   CREATE ,  DOES> ( - b)   @  NAME + ;                                                                                    
 8 (DIR) EXT    0B (DIR) ATTR   1A (DIR) 'FAT   1C (DIR) SIZE          READ  selects a directory entry.                                
: ?NULL ( n - t)   READ  NAME C@ DUP E5 =  SWAP 0= OR ;                NAME  returns the byte address of the current entry's name field
: -DIR ( n - t)   ?NULL  ATTR C@ 18 AND OR ;                           (DIR)  defines a named byte offset into the directory entry:    
                                                                       EXT  is extension,  ATTR  is attribute byte,  'FAT  is the 0th  
: #USED ( - n)   0 0TH @ BEGIN  DUP FATS SWAP WITHIN WHILE                cluster number for the file, and  SIZE  is file size in bytes
   SWAP 1+ SWAP  @FAT REPEAT  DROP ;                                   ?NULL  is true if the current entry is unused or scratched.     
: AUF   SHUT LEGAL  #DIR @ -DIR ABORT" Invalid directory"              -DIR  is true if this entry should not be searched.             
   'FAT CELL @ >< 0TH !  #USED LIM !  1 OPENED ! ;                                                                                     
: SLOT ( - n)   LEGAL RECORDS DO  I ?NULL NOT WHILE  LOOP              #USED  returns the number of blocks allocated to this file.     
      1 ABORT" Directory full"  THEN                                   AUF  is used after  READ  to open a file for access.            
   R> R> DROP  NAME CELL 10 ERASE UPDATE ;                                                                                             
: SCRATCH   READY  E5 NAME C! UPDATE  FREE  SHUT ;                     SLOT  returns the first unused directory entry number.          
   ( Reports)   HEX                                                    SCRATCH  deletes the current file and frees its space.          
: .FAT   HEX FATS DO  I 0F AND 0= IF  10 MS CR I 4 U.R  THEN           This block enables the operator to see what's going on with his 
      I 3 AND 0= IF  SPACE  THEN  I @FAT 4 U.R LOOP SPACE ;               disk.                                                        
                                                                                                                                       
: .DIR ( n)   -DIR NOT IF  CR 10 MS  #DIR @ 5 U.R 2 SPACES             .FAT  produces a dump of the FAT, in hex, for diagnostics.      
   NAME 8 >TYPE  ." ."  EXT 3 >TYPE  ATTR C@ HEX 4 U.R DECIMAL                                                                         
   'FAT CELL @ >< 5 U.R  2 SPACES  SIZE CELL 2@ >< SWAP >< D.          .DIR  displays a given directory entry.                         
   THEN ;                                                              .ID  displays the disk volume header if one is found.           
                                                                       DIR  displays the disk directory in a way reminiscent of what   
: .ID   RECORDS DO  I ?NULL NOT IF  ATTR C@ 8 AND IF                      DOS itself does given the same command.                      
      NAME 0B >TYPE  2R> 2DROP EXIT  THEN THEN LOOP ;                                                                                  
: DIR   LEGAL  CR ." Disk " .ID CR                                                                                                     
      RECORDS DO  I .DIR  LOOP  CR CR                                                                                                  
   ." Free " #FREE DUP . ." blocks, " 400 M* D. ." bytes.  " ;                                                                         
                                                                                                                                       
                                                                                                                                       
   ( Maintenance)   HEX                                                                                                                
: SAFE   FLUSH  3 1 DO  I SECTOR CORE 200 CMOVE                        SAFE  is used after changing the directory or FAT to ensure that
      CORE I 2 + SECTOR 200 CMOVE UPDATE  LOOP  FLUSH ;                   the disk is self consistent.  Its main problem  is to main-  
                                                                          tain the 2nd copy of the FAT.                                
: INIT   5 FOR  I ORG @ + Block  200 ERASE UPDATE  NEXT                                                                                
   55AA 0 SECTOR CELL 0FF + ! UPDATE                                   INIT  initializes a formatted floppy with empty FAT and dir.    
   FF00 FDFF 1 SECTOR CELL 2! UPDATE  SAFE ;                              Any FAT info obtained thru disk certification is lost.  If   
: LABEL   1 TEXT  SLOT READ  NAME CELL 10 ERASE  UPDATE                   you want to preserve this, delete all files instead.         
   CORE NAME 0B CMOVE UPDATE  8 ATTR C! UPDATE  FLUSH ;                LABEL  makes a disk label with the following name.  Should be   
                                                                          used only right after  INIT .                                
: SET   #DIR @ .DIR  ." bytes; "  AUF LIM ? ." blocks.  " ;                                                                            
: N+E   2E ( .) TEXT  20 WORD  COUNT DUP 0= ABORT" No ext!"            SET  opens and displays relevant info for the current file.     
   CORE 8 + SWAP CMOVE ;                                               N+E  parses a following name + extension, leaving 'em in CORE.  
: -FOUND ( - t)   -1  LEGAL RECORDS DO  I -DIR NOT IF                  -FOUND  searches for the file in  CORE , returning true if not  
      NAME 0B CORE 0B -MATCH  SWAP DROP 0= IF  0 AND LEAVE                found.  Otherwise returns false, opening the file and display
   THEN THEN  LOOP  DUP 0= IF  SET  THEN ;                                ing its directory entry.                                     
   ( Operations)   HEX                                                                                                                 
: OPEN ( _)   N+E -FOUND ABORT" Not there" ;                           OPEN  opens a file for access.                                  
: DELETE ( _)   OPEN SCRATCH  SAFE ;                                   DELETE  deletes a file and frees its blocks.                    
: ADD ( n _)   DUP #FREE > ABORT" Disk full"  0 SECTOR DROP            ADD  adds a file of the given no. of blocks to the disk.        
      UPDATE FLUSH  N+E -FOUND NOT ABORT" File already exists"            The blocks themselves are not initialized in any way.        
   SLOT READ  CORE NAME 0B CMOVE UPDATE  20 ATTR C! UPDATE                                                                             
   2100 NAME 24 + CELL ! UPDATE  DUP 400 U* >< SWAP ><                 OUT  moves blocks from the native disk subsystem to a DOS file, 
      SIZE CELL 2! UPDATE  #FREE DROP  0FFF OVER PAD + !               IN  moves from DOS disk to native.  Both take source and dest-  
   ?DUP IF  1- FOR  PAD I + 2@ !FAT  NEXT THEN  PAD @ ><                  ination block numbers and a count of blocks.  Block nos. on  
      'FAT CELL ! UPDATE  SAFE  SET ;                                     the DOS disk are always zero relative within the file.       
                                                                                                                                       
: OUT ( s d n)   FLUSH  0 DO  OVER I + BLOCK PAD 200 MOVE  PAD                                                                         
      OVER I + TH Block  200 MOVE UPDATE  LOOP  2DROP FLUSH ;                                                                          
: IN ( s d n)   FLUSH  0 DO  OVER I + TH Block PAD 200 MOVE                                                                            
      PAD OVER I + BLOCK  200 MOVE UPDATE  LOOP  2DROP FLUSH ;                                                                         
                                                                                                                                       
( Data I/O 29B burner)   EMPTY   DECIMAL                                                                                               
: HELP   233 HELPS ;      : SETUP   593 HELPS ;      HELP              This utility supports the DATA I/O 29B burner with Unipak 2.    
VARIABLE WHAT   2VARIABLE ARG   CREATE FATE  6 ALLOT                                                                                   
VARIABLE DONE   100 CONSTANT SIZE   CREATE RAM  4096 ALLOT             NEW  is the starting block of target compiler output, assumed to
RAM BYTE CONSTANT Ram                                                     be at zero in memory.                                        
                                                                       FATE  saves the counted string last received from the burner.   
: ?ESC   ?KEY IF  KEY ( 27)24 = ABORT" Escaped!"  THEN ;               SIZE  is the number of hunks in PROM.                           
                                                                                                                                       
~ : STRAIGHT ( b n)   1- FOR  KEY OVER C!  1+ NEXT  DROP ;             ACK  sends the carriage return terminating a transmission and   
: ack   12 1 DO  KEY  DUP FATE BYTE I + C!  1 FATE BYTE C+!               expects a response terminated by carriage return.  To avoid  
      13 = IF  LEAVE  THEN LOOP  1 DONE ! STOP ;                          writing interrupt code, this version requires a quiet machine
: ACK   13 EMIT  ack ;                                                 GOOD  is true if the last response from the burner was  > .     
: IT ( - a)   FATE 6 ERASE  0 DONE !  BURNER ;                                                                                         
: WAIT   BEGIN PAUSE  ?ESC  DONE @ UNTIL ;                                                                                             
                                                                                                                                       
( Rest)  229 232 THRU   0 START  16 BITS                                                                                               
   ( Protocols)   HEX                                                                                                                  
MSG Oa  249 , 0D00 ,   MSG Ob  2FF , 0 ,   MSG In  24F , 0D00 ,        ?ESC  tests for an escape key from the terminal, allowing the   
: digits   IT ACTIVATE  ARG 2@ 0 SWAP  HEX <#                             OPERATOR to punch out of an interminable wait for the burner.
      0 DO  # LOOP  #> TYPE  WHAT @ EMIT  ACK ;                                                                                        
: nil   IT ACTIVATE  WHAT @ EMIT  ACK ;                                WAIT  spins till the burner task has completed its work.        
: out   IT ACTIVATE  Oa  400 MS  Ob  Ram SIZE TYPE  ack ;              NIL  performs an exchange with a single character output.       
: in   IT ACTIVATE  In Ram 22 STRAIGHT  Ram SIZE STRAIGHT ack ;        DIGITS  transmits  n  hex low order digits of  u  followed by   
: NIL ( c)   WHAT !  nil WAIT ;                                           the control character  c  for the more complex exchanges.    
: DIGITS ( u n c)   WHAT !  ARG 2!  digits WAIT ;                                                                                      
                                                                       RESP  returns the address of the response classification byte.  
: RESP ( - b)   FATE COUNT +  2 - ;                                    GOOD  is true if the burner's response indicated success.       
: GOOD ( - t)  RESP C@  3E = ;                                                                                                         
: ?NUM ( - n)   RESP C@  20 RESP C!  BASE @ HEX                        ?NUM  parses a 16-bit hex number from the burner's response, and
      FATE BYTE NUMBER  PTR @ 0< NOT IF  'NUMBER 1+ !  THEN            ?DBL  parses a 32-bit number.                                   
   SWAP BASE !  SWAP RESP C! ;                                                                                                         
: ?DBL ( - d)   ?NUM  'NUMBER 1+ @ ;                                                                                                   
   ( Geometry)   HEX   FF CONSTANT BTS                                                                                                 
200 CONSTANT B/W   100 CONSTANT NBL   VARIABLE STARTS                  B/W  is the width of the bus in bits (8 or 16).                 
: 2** ( n)   1 SWAP  ?DUP IF 1- FOR  2* NEXT  THEN ;                   NBL  is the scale of the current hunk in a buswidth cell.       
                                                                       BTS  masks the number of low order bits in a hunk.              
: BITS ( n)   8 / 1 MAX  ['] B/W 1+ ! ;                                STARTS  is the starting block of the disk image.                
: NIBBLE ( n)   4 * 2**  ['] NBL 1+ ! ;                                2**  raises two to the given power.                             
: BYTE ( n)   2* NIBBLE ;      : START ( a)   STARTS ! ;               NIBBLE  selects one of four possible nibbles (0 = low order).   
                                                                       BYTE  selects a byte (0 = low order).                           
: /NBL ( n n - n)   DUP 1- IF  /MOD SWAP  THEN DROP ;                  START  sets the starting disk block.                            
: W@ ( a - n)   B/W 1- IF  CELL @  ELSE  C@  THEN ;                                                                                    
: W! ( n a)   B/W 1- IF  CELL !  ELSE  C!  THEN ;                                                                                      
: /B ( b - b)   B/W 400 */MOD  STARTS @ +  BLOCK BYTE + ;                                                                              
                                                                                                                                       
: D@ ( b - n)   /B W@  NBL /NBL  BTS AND ;                                                                                             
: D! ( n b)   /B DUP W@  BTS NBL *  -1 XOR AND                                                                                         
      ROT NBL * +  SWAP W!  UPDATE ;                                                                                                   
   ( Errors)                                                                                                                           
: /MSG ( n - b n)   64 1024 */MOD 32 * +  591 BLOCK BYTE + 32 ;        Error bit definitions:          I/O                             
: .ER ( d)   CR ." Errors:  "  32 1 DO  2DUP D+                        (30) ?                          (14) ?                          
      DUP 0< IF  I /MSG -TRAILING 1+ >TYPE  THEN LOOP  2DROP ;         (29) ?                          (13) ?                          
: ?ERROR ( - d)   BEGIN  70 NIL  GOOD UNTIL  ?DBL ;                    (28) ?                          Compare                         
: ERROR   GOOD NOT IF  ?ERROR .ER  THEN ;      HEX                     (27) ?                          Checksum                        
                                                                       OE                              Format                          
: DEVICE ( ff pp)   SWAP >< OR  DUP 4 40 DIGITS ERROR                  FE                              Address                         
   5B NIL  ?NUM ERROR  XOR ABORT" Device set failed!"                  CHOKED                          -Hex/Insuf                      
   52 NIL  ?DBL ERROR 1 10 M*/  10 U/MOD 1+  DUP ['] SIZE 1+ !         DEVICE                          RAM                             
      OVER 2** 1- ['] BTS 1+ !  ." Capacity " U.  ."  Width " .        Start line                      (6) ?                           
   011 3 41 DIGITS ERROR  SIZE 4 3B DIGITS ERROR ;                     Exceeded                        Exceeded                        
                                                                       Dac                             Center                          
: IS ( ff pp)   ~ 2CONSTANT  DOES>   2@ DEVICE ;                       -Blank                          Split                           
   27 24 IS I2732A   79 33 IS I2764   0EE 0AF IS CYPRESS               -Overlay                        Too small                       
                                                                       -Verify                         Failure                         
   ( Burning)                                                          Incomplete                      Boundary                        
: FETCH   SIZE *  SIZE 0 DO  DUP D@  Ram I + C!  1+ LOOP DROP ;        FETCH  and  STORE  read and write the image in PROM from and to 
: STORE   SIZE *  SIZE 0 DO  Ram I + C@ OVER D!  1+ LOOP DROP ;           the disk, given a PROM or PROM pair number.                  
                                                                                                                                       
: BURN ( n)   FETCH  out WAIT  ERROR  80 NIL ERROR ;                                                                                   
: READBACK   RAM SIZE 2/ ERASE  76 NIL ERROR  in WAIT  ERROR ;                                                                         
: SAVE ( n)   READBACK STORE ;                                                                                                         
                                                                                                                                       
: CHECK ( n)   READBACK  SIZE *  SIZE 0 DO  DUP D@  Ram I + C@                                                                         
      2DUP - IF  CR I 5 U.R  OVER 4 U.R  DUP 3 U.R                                                                                     
   THEN 2DROP  1+ LOOP  DROP ;                                                                                                         
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
HELP               Displays these PROMS instructions.                                                                                  
SETUP              Displays instructions for initial setup.            SETUP              Displays these instructions for setup.       
                                                                       HELP               Displays instructions for Burning operations.
To use any of the following you MUST have seleted a device!                                                                            
                                                                       n START            Specifies starting block # of PROM images.   
n NIBBLE  or       Used one of these to select the byte or                                  The default is  Zero .                     
n BYTE               nibble to be used (0 = low order).                n BITS             Specifies bus width.  Default is 16.         
                                                                                                                                       
n BURN             Burns a PROM in the  nTH  address range.            HEX ff pp DEVICE   Selects any PROM type known to the burner.   
n CHECK            Verifies the  nTH  PROM.                            I2732A  I2764      Select the corresponding device types.       
                                                                         CYPRESS            Use  DEVICE  for any not named.            
n SAVE             Reads the  nTH  PROM and saves it on disk.                                                                          
                                                                          1.  Connect serial cable to BURNER task's port.              
                                                                          2.  Apply power, wait for self test to finish.               
                                                                          3.  On keyboard:  SELECT F 1 START START.                    
                                                                          4.  Select device; Burn & check each PROM.                   
( Streaming tape utility)   EMPTY   DECIMAL                                                                                            
: HELP   236 HELPS ;   HELP      ( Slow SCSI)  237 238 THRU            This utility is fairly basic, since some experience yet remains 
2VARIABLE TAPE   CREATE STAT  HERE 8 DUP ALLOT  ERASE   HEX               to be had with streamers in general.                         
: <T   TAPE  DUP RELEASE  @ ABORT" Tape not available"                                                                                 
      TAPE GRAB  DISK GET ;                                            TAPE  serializes uses of the streamers; TAPE 1+ is nonzero if   
: tape ( a n f m)   <T SCSI DROP STS @ TAPE 1+ ! DISK RELEASE ;           the last operation had an error.                             
                                                                       <T  safely arranges for use of the tape and  tape  is like SCSI.
: WHY   STAT 0 360 0C00 tape ;   : HOW  STAT 0 300 0 tape ;                                                                            
: LOG   TAPE 1+ @ IF  ." Tape error: "  WHY STAT HEX 6 DUMP            WHY  gets tape status and  HOW  gets disk status.               
      HOW STAT 3 DUMP  DECIMAL  TAPE RELEASE  ABORT  THEN ;            LOG  displays full status array in event of a tape error.  Disk 
                                                                          status is shown to help in the event of a copy error.        
: -RDY ( - t)   PAD 0 60 0 tape  TAPE 1+ @ 0= 0= ;                                                                                     
: bum ( - t)   -RDY  WHY STAT 5 + @  90 AND 90 XOR  AND ;              -RDY  is true if the drive tests not ready.                     
: BUM ( - t)   bum DUP IF  DROP                                        bum  is true if a nonready drive doesn't indicate it's rewinding
      3E7 FOR  270F FOR  NEXT NEXT  bum  THEN ;                        BUM  is true if drive REALLY seems not ready.  It waits about a 
( Rest)  DECIMAL 235 LOAD                                                 second and a half to make sure condition still exists, since 
   ( Operations)   HEX                                                    we get "drive not ready" briefly at tail end of a rewind!    
: READY   BEGIN  PAUSE  -RDY WHILE  BUM IF                             READY  waits until rewinding drives are done, and aborts if the 
      TAPE RELEASE  1 ABORT" Tape not ready"  THEN REPEAT ;               drive appears to truly be non ready.                         
                                                                                                                                       
: >TAPE ( a n)   READY  2/ 7F00 AND >R 0 A60 R> tape LOG ;             <TAPE  and  >TAPE  transfer memory data from and to tape.  Count
: <TAPE ( a n)   READY  2/ 7F00 AND >R 0 860 R> tape LOG ;                is in BYTES and must be a multiple of 512.                   
                                                                                                                                       
: BACKUP ( f n)   READY  200 U*  20 M+ TBL 3 + 2!                      BACKUP and RESTORE  move data from disk to tape and back, given 
      PAD SWAP 2200 0 tape LOG ;                                          starting disk block and number of blocks.  The starting block
: RESTORE ( f n)   READY  200 U*  TBL 3 + 2!                              number is ABSOLUTE.  This will need twiddling if anyone but  
      PAD SWAP 2300 0 tape LOG ;                                          me ever puts a disk bigger than 60 Mb on one of these things.
: SKIP ( n)   ?DUP IF  READY                                              NOTE that these may ONLY be used with hard disk unit 0.      
      PAD SWAP  200 U*  1160 ROT tape LOG  THEN ;                      SKIP  makes the tape skip over the given number of disk blocks. 
                                                                       END-FILE  writes an EOF on the tape.                            
: END-FILE   READY  PAD 0 1060 100 tape LOG ;                          REWIND  rewinds and releases the tape.                          
: REWIND   READY  PAD 0 160 0 tape LOG  TAPE RELEASE ;                 When restoring EXACTLY as many blocks as exist in a file, the   
HELP             Displays these  STREAMER  instructions                  controller will report a spurious error.  Ignore it.          
                 All tape operations are sequential, based upon                                                                        
                 current position.                                                                                                     
                                                                                                                                       
REWIND           Rewinds the streamer and releases it.                                                                                 
f n BACKUP       Writes  n  disk blocks to tape, starting with                                                                         
                 ABSOLUTE block  f  from the hard disk.                                                                                
END-FILE         Writes an EOF.  Always do this at end of data!                                                                        
                                                                                                                                       
n SKIP           Skips over  n  disk blocks on tape.                                                                                   
f n RESTORE      Reads  n  disk blocks from tape.  If the group                                                                        
                 of blocks being restored is at or very near the                                                                       
                 total number in the file, a spurious error will                                                                       
                 be reported.  Ignore it; if you never want to                                                                         
                 see it, write 8 or more extra blocks in your                                                                          
                 backups.                                                                                                              
( SLOW SCSI banger)   HEX                                                                                                              
E000 CONSTANT SCS   E002 CONSTANT SCD                                  Registers (memory mapped):                                      
: DIN ( - c)   SCD @  ( -1 XOR)  0FF AND ;                             E000r  rb-- ---- p--a smci  REQ BSY  PTY  ACK SEL  MSG C/D_ I/O_
: CIN ( - n)   SCS @  ( -1 XOR)  C09F AND ;                            E001w  ---- ---- p--- -rsa  PTY  RST SEL ACK                    
: DATA ( c)   2* 2* 2* 2*  2* 2* 2* 2*  SCD 1+ ! ;                     E002r  7654 3210 7654 3210  Two copies of DB0-7.                
: CMD ( n)   SCS 1+ ! ;      : SEE   CIN U.  DIN U. ;                  E003w  7654 3210 ---- ----  Drive DB0-7 enabled by I_/O high.   
                                                                                                                                       
: uS ( n)   2* 2* 2*  8 - DO( NOP ;  ( 8 MHz)                          All bus signals are inverted on the way in and out.  PTY out is 
: RST   4 CMD  19 uS  0 CMD  18F FOR  3E8 uS  NEXT ;                      enabled by I_/O high just like data.  ---- are garbage on    
                                                                          input, don't care on output.                                 
: SEL   1 DATA  2 CMD  BEGIN  CIN 2* 0< UNTIL  0 CMD ;                                                                                 
: ACK   1 CMD  BEGIN  CIN 0< NOT UNTIL  0 CMD ;                                                                                        
: TOSS ( c)   DATA ACK ;      : FET ( - c)   DIN ACK ;                                                                                 
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( SCSI host)   HEX                                                                                                                  
: SNK  KEY DROP ;                                                                                                                      
VARIABLE CP   VARIABLE DP   VARIABLE SP                                                                                                
: D>   DP @ C@  TOSS  1 DP +! ;                                                                                                        
: <D   FET  DP @ C!  1 DP +! ;                                                                                                         
: C>   CP @ C@  TOSS  1 CP +! ;                                                                                                        
: <C   CIN 4 AND  FET  3 AND  SP @ C!                                                                                                  
   1 SP +! IF  R> DROP  THEN ;                                                                                                         
CREATE VECTOR ( ci)   ' D> ,  ' <D ,  ' C> ,  ' <C ,                                                                                   
: ENSLAVE   BEGIN  BEGIN  CIN 0< UNTIL                                                                                                 
      CIN 3 AND  VECTOR + @EXECUTE  AGAIN ;                                                                                            
                                                                                                                                       
: SCSI ( a n f m - a)   TBL 2 +  2 !-  1 !+  1 !-  2* CP !                                                                             
   DUP 2* DP !  STS 2* SP !  0 STS !  SEL ENSLAVE ;                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( BYTE sieve, bytes)   EMPTY   DECIMAL                                                                                                 
8190 CONSTANT SIZE   VARIABLE FLGS  SIZE 2/ ALLOT                      One iteration of: BYTE    Mine    Code    Source                
FLGS 2* CONSTANT FLAGS                                                 8086 5MHz Forth   6400ms   ---     ---    Mag                   
: DO-PRIME   COUNTER  FLGS SIZE 2/ -1 WFILL                            8085 5MHz pF 83   6098ms  3698ms   ---    BMCI, 3/84            
   0 ( count)  SIZE 0 DO  FLAGS I + C@ IF                              11/23 pF 83       3080ms  1864ms   ---    My box 3/84           
         I DUP + 3 +  DUP I + BEGIN  DUP SIZE < WHILE                  68K 8MHz Forth    2700ms   ---     ---    Mag                   
            0 OVER FLAGS + C!  OVER +  REPEAT                          11/73 pF 83       1485ms   906ms   ---    My box 4/84           
   DROP DROP  1+  THEN LOOP  >R TIMER  R> .  ." Primes " ;             11/70 DECUSForth  1180ms   ---     ---    Mag                   
                                                                       VAX 780 CYBOS/vms  760ms   ---     ---    Art 7/83 cell, MOVE.  
FLAGS SIZE + CONSTANT End                                              VAX 780 ADA/vms    560ms   ---     ---    Mag                   
: FASTER   COUNTER  FLGS SIZE 2/ -1 WFILL                              9300/150           512ms   305ms   24.2ms   23.7 -edit  1/84    
   0 ( count)  FLAGS SIZE + FLAGS DO  I C@ IF                          VAX 780 "C"        142ms   ---     ---    Mag                   
         I FLAGS - 2* 3 +  DUP I +  DUP End < IF                       Chip/8MHz          117ms   112ms   33.9ms   7/05/85             
            End SWAP DO  0 I C!  DUP /LOOP  DUP  THEN                  1100/83 FORT V      76ms   ---      17ms  Mag; Jack /60 -edit   
   2DROP  1+  THEN LOOP  >R TIMER  R> .  ." Primes " ;                 1100/82 FORT 77     67ms   ---     ---                          
: SEE ( n)   0 DO  I FLAGS + C@ IF  I 2* 3 + .  THEN LOOP ;            CRAY-1 FORTRAN      11ms   ---     ---                          
   ( BYTE sieve, cells)   EMPTY   DECIMAL                              3033 PL/1          3.6ms   ---     780us   Disbelieve           
8190 CONSTANT SIZE   VARIABLE FLAGS  SIZE 1+ ALLOT                     Old com New comp  8MHz timings for chip sieve flavors:          
: DO-PRIME   COUNTER  FLAGS SIZE 1 WFILL                               117.304 117.303ms  BYTE article code, literally, in bytes       
   0 ( count)  SIZE 0 DO  FLAGS I + @ IF                               111.940 111.669ms  My version of BYTE article code, bytes       
         I DUP + 3 +  DUP I + BEGIN  DUP SIZE < WHILE                   74.821  72.471ms  Count-up optimized, bits                     
            0 OVER FLAGS + !  OVER +  REPEAT                            66.374  66.372ms  Count-down optimized, bits                   
   DROP DROP  1+  THEN LOOP  >R TIMER  R> .  ." Primes " ;              64.719  64.717ms  BYTE article code, literally, in cells       
                                                                        64.677  64.405ms  My version of BYTE article code, cells       
FLAGS SIZE + CONSTANT End                                               43.137  40.786ms  Count-up optimized, cells                    
: FASTER   COUNTER  FLAGS SIZE 1 WFILL                                  35.540  35.538ms  Count-down optimized, cells                  
   0 ( count)  FLAGS SIZE + FLAGS DO  I @ IF                            33.967  33.965ms  Additional count down cell optimization      
         I FLAGS - 2* 3 +  DUP I +  DUP End < IF                                                                                       
            End SWAP DO  0 I !  DUP /LOOP  DUP  THEN                                                                                   
   2DROP  1+  THEN LOOP  >R TIMER  R> .  ." Primes " ;                                                                                 
: SEE ( n)   0 DO  I FLAGS + C@ IF  I 2* 3 + .  THEN LOOP ;                                                                            
                                                                                                                                       
   ( Down sieve, bits)   EMPTY                                                                                                         
OCTAL  144301 uCODE DUPI+c   DECIMAL                                                                                                   
8190 CONSTANT SIZE                                                                                                                     
                                                                                                                                       
ARRAY CELL  8192 16 / ALLOT      : \ ( n)   -1 XOR , ;                                                                                 
ARRAY BIT  1 \ 2 \ 4 \ 8 \  16 \ 32 \ 64 \ 128 \                                                                                       
   256 \ 512 \ 1024 \ 2048 \  4096 \ 8192 \ 16384 \ 32768 \                                                                            
                                                                                                                                       
: DO-PRIME   COUNTER  0 CELL  SIZE 2 + 16 /  -1 WFILL                                                                                  
   0 ( count)  SIZE 1 - FOR  I 15 AND BIT @  -1 XOR                                                                                    
      I 2/ 2/ 2/ 2/ CELL @  AND IF                                                                                                     
         I 2* 16381 -  DUPI+c BEGIN  DUP 0< 1+ WHILE                                                                                   
            DUP  DUP 2/ 2/ 2/ 2/ CELL                                                                                                  
               SWAP 15 AND BIT @  OVER @ AND  SWAP !                                                                                   
         OVER +  REPEAT  DROP DROP  1+                                                                                                 
   THEN  NEXT  >R TIMER  R> .  ." Primes " ;                                                                                           
   ( Up sieve, bits)   EMPTY                                                                                                           
8190 CONSTANT SIZE                                                     This version is a count-up sieve that's otherwise identical to  
                                                                          the above but slower.  Improvement of the above is:          
ARRAY CELL  8192 16 / ALLOT                                                  ___Portion___   Iterations      Clks    Total saved       
ARRAY BIT  1 , 2 , 4 , 8 ,  16 , 32 , 64 , 128 ,                             Outer Loop         8190           2         16380         
   256 , 512 , 1024 , 2048 ,  4096 , 8192 , 16384 , 32768 ,                  Primes Found       1899           4          7596         
                                                                             Inner Loop        14996           4         59984         
: DO-PRIME   COUNTER  0 CELL  SIZE 2 + 16 /  -1 WFILL                        -------------------------------------------------         
   0 ( count) 0 ( candidate)  SIZE 1 - FOR  DUP                              Total savings (in clocks)                  83,960         
      DUP 2/ 2/ 2/ 2/ CELL @  SWAP 15 AND BIT @  AND IF                The above 96.3 ms was observed on my board with a clock of 159ns
         DUP 2* 3 +  OVER OVER + BEGIN  DUP 8190 - 0< WHILE               Downcounting at that clock rate would yield 13.3 ms giving   
            DUP  DUP 2/ 2/ 2/ 2/ CELL  SWAP 15 AND BIT @                  83.0 ms without any further optimization.  Translated to:    
            -1 XOR  OVER @ AND  SWAP !                                       Chuck's 130ns clock --------- 67.8                        
         OVER +  REPEAT  DROP DROP  SWAP 1+ SWAP                             8 MHz (125ns)  -------------- 65.2                        
   THEN  1+ NEXT DROP  >R TIMER  R> .  ." Primes " ;                         10 MHz (100ns)  ------------- 52.2                        
                                                                                                                                       
   ( Sieves, cells)   EMPTY                                                                                                            
OCTAL  144301 uCODE DUPI+c   DECIMAL                                   DO-PRIME  is a count-up sieve using straightforward native      
8190 CONSTANT SIZE   ARRAY FLAGS  SIZE 2 + ALLOT                          chip code and a cell array.                                  
                                                                                                                                       
: DO-PRIME   COUNTER  0 FLAGS  SIZE 2 +  -1 WFILL                      FASTER  is a straightforward count-down sieve.                  
   0 ( count) 0 ( candidate)  SIZE 1 - FOR  DUP FLAGS @ IF                                                                             
         DUP 2* 3 +  OVER OVER + BEGIN  DUP 8190 - 0< WHILE                                                                            
            0 OVER FLAGS !  OVER +  REPEAT                                                                                             
      DROP DROP  SWAP 1+ SWAP                                                                                                          
   THEN  1+ NEXT DROP  >R TIMER  R> .  ." Primes " ;                                                                                   
                                                                                                                                       
: FASTER   COUNTER  0 FLAGS  SIZE 2 +  -1 WFILL                                                                                        
   0 ( count)  SIZE 1 - FOR  I FLAGS @ IF                                                                                              
         I 2* 16381 -  DUPI+c BEGIN  DUP 0< 1+ WHILE                                                                                   
            0 OVER FLAGS !  OVER +  REPEAT  DROP DROP  1+                                                                              
   THEN  NEXT  >R TIMER  R> .  ." Primes " ;                                                                                           
   ( Better cell sieve)   EMPTY                                                                                                        
OCTAL  144301 uCODE DUPI+c   162701 uCODE 1@-   DECIMAL                By not referencing FLAGS in the outer loop, we save 12582 clocks
8190 CONSTANT SIZE   ARRAY FLAGS  SIZE 2 + ALLOT                          for 1.572ms at 8MHz.                                         
                                                                                                                                       
: FASTER   COUNTER  0 FLAGS  SIZE 2 +  -1 WFILL                        By now it is becoming noisome indeed that FILL is taking        
   0 ( count)  SIZE 1- DUP >R  FLAGS BEGIN  1@- SWAP IF                   5141 usec of our total!                                      
         I 2* 16381 -  DUPI+c BEGIN  DUP 0< 1+ WHILE                                                                                   
            0 OVER FLAGS !  OVER +  REPEAT                                                                                             
         DROP DROP  SWAP 1+ SWAP                                                                                                       
   THEN  NEXT DROP  >R TIMER  R> .  ." Primes " ;                                                                                      
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( EDN Benchmark E)   EMPTY   DECIMAL                                                                                                   
CREATE DST  47 STRING 000000000000000000000000000000000000000000       This is a very convenient benchmark, since it precisely defines 
000000000000000000HERE00000000000000000000000000HERE IS A MATCH0          our standard word  -MATCH .                                  
00000000000000/                                                        On a 150 ns 9300, we get:                                       
                                                                          Compile test case    6.9 ms elapsed                          
CREATE SRC  47 STRING HERE IS A MATCH/                                                        72.6 ms including -MATCH assembly        
                                                                          Execute test case    128 us                                  
: TRY   COUNTER  DST COUNT SRC COUNT -MATCH  2DROP TIMER ;                                     120 us with tare removed                
                                                                          11/23               2808 us with tare removed                
: MANY   COUNTER  999 FOR  NOP NOP NOP                                    11/73               1326 us with tare removed                
      DST COUNT SRC COUNT -MATCH  2DROP NEXT  TIMER ;                     Chip/8MHz            477 us with tare removed                
: TARE   COUNTER  999 FOR                                                                                                              
      DST COUNT SRC COUNT  2DROP 2DROP NEXT  TIMER ;                   EDN claims  11/23    996 us  (How?  Well, ours is slow!)        
                                                                                   8085    1058 us   5 MHz  my measurement tare removed
                                                                                   8086     193 us  10 MHz                             
                                                                                   68000    244 us  10 MHz                             
( Sort benchmark)   EMPTY                                                          Z8000    237 us   6 MHz                             
ARRAY DATA  10001 ALLOT                                                This test case is a sort routine provided by Miller's group that
: COMP ( n n - t)   DATA @  SWAP DATA @  SWAP U< ;                        we helped them convert at the Rochester conference.          
: EXCH ( n n)   DATA  DUP >R @ >R  DATA 0 @+  R> SWAP !  R> ! ;                                                                        
                                                                       770~800 ms to sort 10000 random elements at 6 MHz.              
: UNORDERED?   1-  DUP DUP IF  DUP 1+ SWAP COMP  THEN ;                                                                                
: INSERTSORT ( n)   1+ 2 DO  I  BEGIN  UNORDERED? WHILE                                                                                
      DUP DUP 1+ EXCH  REPEAT  DROP LOOP ;                                                                                             
                                                                                                                                       
( Sort)  248 LOAD   ( Random)  181 LOAD                                                                                                
                                                                                                                                       
: RAN ( n)   COUNTER  ROT FOR  RANDOM I DATA !  NEXT  TIMER ;                                                                          
: SAME ( n)   0 DATA SWAP ERASE ;                                                                                                      
: BKWD ( n)   0 SWAP FOR  DUP I DATA !  1+ NEXT  DROP ;                                                                                
: TRY ( n)   COUNTER  ROT QUICKSORT  TIMER ;                                                                                           
: CHK ( n)   2 - FOR  I 2 + I 1+ COMP ABORT" Oops" NEXT ;                                                                              
   ( Quickersort)                                                                                                                      
: ?EXCH ( j i - j i)   2DUP COMP  0< IF  2DUP EXCH  THEN ;                                                                             
: MEDIAN ( j i - j i)   2DUP + &2/  OVER EXCH                                                                                          
   ?EXCH 1+  ?EXCH 1-  DUP 1+  ?EXCH DROP ;                                                                                            
: PARTITION ( l f - l u d- f)   >R  DUP I                                                                                              
   BEGIN BEGIN  1+ DUP I COMP  0< 1+ UNTIL  SWAP                                                                                       
      BEGIN  1- I OVER COMP  0< 1+ UNTIL  SWAP  2DUP >                                                                                 
   WHILE  2DUP EXCH  REPEAT  OVER I EXCH  SWAP 1- R> ;                                                                                 
                                                                                                                                       
10 CONSTANT M   : SMALL? ( j i - j i f)   2DUP - M < ;                                                                                 
: ORDER ( too damn complicated)   SMALL? IF  2DROP  SMALL? IF                                                                          
      2DROP  THEN EXIT  THEN 2DUP - >R  2SWAP  SMALL? IF                                                                               
      R> DROP  2DROP EXIT  THEN  2DUP - R> > IF  2SWAP  THEN ;                                                                         
                                                                                                                                       
: QUICKSORT ( n)   DUP M > IF  0  OVER 1 BEGIN  MEDIAN                                                                                 
      PARTITION  ORDER ?DUP 0= UNTIL  THEN  INSERTSORT ;                                                                               
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
 : BEGIN . " HELLO THERE THIS IS A NOVIX ND4000 " ;                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Timings)   EMPTY                                                                                                                     
: ONE   COUNTER  99 FOR  9999 FOR  NEXT NEXT TIMER ;                   NOTE  that there is substantial tare included in each of these  
: TWO   COUNTER  999 FOR  I I I */ DROP  NEXT TIMER ;                     measurements.                                                
                                                                                                                                       
: SEVEN   COUNTER  999 FOR  I I * DROP  NEXT TIMER ;                                                                                   
: EIGHT   COUNTER  999 FOR  1000 I / DROP  NEXT TIMER ;                                                                                
: NINE   COUNTER  999 FOR  1000 I /MOD 2DROP  NEXT TIMER ;                                                                             
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Add serial disk to native system)   EMPTY   DECIMAL                                                                                  
: ## ( a n - a b #)   0 EMIT  256 /MOD EMIT EMIT                       This is the basic disk protocol for direct terminal emulators.  
      DUP 2*  1023 ;                                                                                                                   
: tell ( a n - a)   32768 OR  ## FOR                                   Disk read protocol:                                             
      DUP C@ EMIT  1+ NEXT  KEY 2DROP ;                                   00 0hh ll>   <1024 bytes                                     
: ask ( a n - a)   ## FOR  KEY OVER C!  1+ NEXT  DROP ;                                                                                
                                                                       Disk write protocol:                                            
: PLEAT ( n n - n t)   2DUP U< IF  DROP 0 EXIT  THEN - 1 ;                00 1hh ll 1024 bytes>   <00                                  
: (BUFFER) ( d - d a)   ?UPDATED DROP                                                                                                  
   11520 PLEAT IF  tell EXIT  THEN  2560 I/O ;                         Chuck had a "50 us" open loop delay between the 1st and 2nd     
: (BLOCK) ( d - a)   ?ABSENT  'BUFFER @EXECUTE  >R OVER R> SWAP           bytes received for each cell.  Damned if I have any idea at  
   11520 PLEAT IF  ask  ELSE  2048 I/O  THEN ESTABLISH ;                  all what on earth this could be for!                         
                                                                                                                                       
' (BUFFER) ' (BLOCK) 'BLOCK 2!   ( Errors) 33 LOAD                                                                                     
CONTEXT GOLDEN 18 MOVE  HERE H 1+ !                                                                                                    
                                                                                                                                       
( Stack test)   EMPTY   HEX                                                                                                            
: BLOW ( n)   100 DO( DUP ;                                            This block performs some testing to build confidence in the     
: CHECK ( n)   4 I!  0FF FOR  6 I!  6 I@  4 I@ - IF                       stacks.                                                      
      6 I@ .  THEN NEXT ;                                                                                                              
: PATTERNS 0 BLOW 0 CHECK -1 BLOW -1 CHECK AAAA BLOW AAAA CHECK        UNIQUE  tests the parameter stack by filling it with unique     
: FULL   0  0FE FOR  DUP 1+  NEXT ;                                       values.  If it fails by saying  Oops  the problem can be     
: WELL   0FF FOR  I XOR IF  ." Oops!" THEN NEXT ;                         inspected by  ZUMP  which will fill the stack and store it   
: UNIQUE   FULL WELL ;                                                    down at  PAD .  What should exist at  PAD  is a series of    
                                                                          numbers starting at 255 and descending toward zero.  The last
: ZUMP   FULL  PAD  0FE DO( 1 !+ ;                                        number in PAD will be something nonzero (this is normal).    
                                                                                                                                       
CREATE IT  100 ALLOT  HERE CONSTANT it                                 !RET  is similar to  ZUMP  but uses the return stack instead.   
: !RET   100 BEGIN  DUP >R  1- DUP 0= UNTIL  DROP                         After execution, the values retrieved from the return stack  
   100 BEGIN  R> OVER [ it ] LITERAL SWAP - ! 1- DUP 0= UNTIL             will be found in the 256-cell table  IT .  The expected vals 
   100 BEGIN IT OVER 1- + @ OVER XOR IF ."  Oops!" ABORT THEN             start with 1 and will ascend to and including 256.           
     1- DUP 0= UNTIL ABORT ;                                                                                                           
( Memory diagnostic)   EMPTY   HEX                                                                                                     
: RAM ( n - a)   2000 + ;   8000 0 RAM - CONSTANT SIZE                 Preliminary RAM test for everything but the low page (under the 
: ALL ( n)   SIZE 1- FOR  DUP I RAM !  NEXT  DROP ;                       PROM).  There are two major phases:                          
                                                                                                                                       
: +CR   L# @ 16 > IF  ."  More? " KEY  0D = ABORT" Killed"             BITS  tests data bit function and interaction in each cell of   
      0 L# !  THEN  CR ;                                                  RAM.  In each subcase all of RAM is filled with the same pat-
                                                                          tern and then all of RAM is tested for containing it.  The   
: HOLDS ( n)   DUP ALL  SIZE 1- FOR  I RAM @ 2DUP XOR IF  +CR             patterns used are 0000, FFFF, AAAA, 5555, and the 16 singles.
   I RAM 5 U.R  OVER 6 U.R  DUP 5 U.R  THEN DROP NEXT  DROP ;                                                                          
: BITS   HEX  0 HOLDS  -1 HOLDS  AAAA HOLDS  5555 HOLDS                UNIQUE  checks addressing by storing into each cell of RAM its  
      1  0F FOR  DUP HOLDS  2* NEXT  DROP ;                               own cell number.  All of RAM is then inspected to see that   
                                                                          the predicted values are where expected.  Before the test,   
: UNIQUE   HEX  -1 ALL  SIZE 1- FOR  I DUP RAM !  NEXT                    all of RAM is set to a value that will not occur in the test.
   SIZE 1- FOR  I DUP RAM @  2DUP XOR IF  +CR                                                                                          
      I RAM 5 U.R  OVER 6 U.R  DUP 5 U.R  THEN 2DROP NEXT ;            This test MUST be executed on a CLEAN system immediately after  
                                                                          power up or RELOAD!  At 6 MHz, it should run for about 3 sec.
( Explore Bport)   EMPTY   HEX                                                                                                         
Bport 1+ CONSTANT Bx   Bx 1+ CONSTANT By   By 1+ CONSTANT Bz                                                                           
Xport 1+ CONSTANT Xx   Xx 1+ CONSTANT Xy   Xy 1+ CONSTANT Xz                                                                           
: SEE   Bport I@ U.  Bx I@ U.  By I@ U.  Bz I@ U. ;                                                                                    
: XXX   Xport I@ U.  Xx I@ U.  Xy I@ U.  Xz I@ U. ;                                                                                    
                                                                                                                                       
: DATA ( n)   Bport I! ;                                                                                                               
: MASK ( n)   Bx I! ;                                                                                                                  
: OUT ( n)   By I! ;                                                                                                                   
: TRI ( n)   Bz I! ;                                                                                                                   
                                                                                                                                       
: SPIN   100 FOR  NEXT ;                                                                                                               
: FARMS ( n)   FOR  0 DATA  1 DATA  NEXT ;                                                                                             
: ZORDS ( n)   FOR  -1 FARMS  NEXT ;                                                                                                   
                                                                                                                                       
                                                                                                                                       
( Low Ram Memory diagnostic -- Repeating Check)   EMPTY   HEX                                                                          
: RAM ( n - a)   0000 + ;   1000  CONSTANT SIZE                        Low RAM Memory Diagnostic -- Repeating Check     GRC Fri 11Sep87
: FAILURE ( n -- a) 5000 + ; : 0FAILURES 0 FAILURE SIZE ERASE ;                                                                        
: ALL ( n)   SIZE 1- FOR  DUP I RAM !  NEXT  DROP ;                    Adaptation of Screen 264                                        
: +CR   L# @ 16 > IF  ."  More? " KEY  0D = ABORT" Killed"                                                                             
      0 L# !  THEN  CR ;                                               This diagnostic must be loaded into high ram. Low RAM is checked
: HOLDS ( n)   DUP ALL  SIZE 1- FOR  I RAM @ 2DUP XOR                  the same way as the diagnositc in the previous screen, but low  
 IF  1 I FAILURE +! THEN DROP NEXT DROP ;                              ram is save before the test & restored after it.                
: PATTERNS     0 HOLDS  -1 HOLDS  AAAA HOLDS  5555 HOLDS                                                                               
      1  0F FOR  DUP HOLDS  2* NEXT  DROP ;                                                                                            
VARIABLE #TIMES   10 #TIMES !                                          CHECK -- Top level: Checks memory block & outputs results       
: TIMES ( n) DUP . ." Times..."  0FAILURES FOR PATTERNS NEXT ;                                                                         
: .FAILURES  SIZE 1- FOR  I FAILURE @ IF +CR                                                                                           
    I RAM 4 U.R  I FAILURE @ 5 U.R THEN NEXT +CR ;                                                                                     
                                                                                                                                       
DECIMAL                                                                                                                                
( Low Ram Memory diagnostic -- Repeating Check)      HEX                                                                               
4000 CONSTANT LOW.RAM                                                  ( Low Ram Memory Diagnostic )                                   
: SAVE.RAM  0 RAM LOW.RAM SIZE MOVE ;                                                                                                  
: RESTORE.RAM  LOW.RAM 0 RAM SIZE MOVE ;                               Rest of previous screen                                         
                                                                                                                                       
: CHECK HEX PAGE  ." Checking Low Ram "                                                                                                
   SAVE.RAM #TIMES @ TIMES RESTORE.RAM                                                                                                 
   CR  ." # Failures..." .FAILURES ;                                                                                                   
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
DECIMAL                                                                                                                                
( Dictionary sizing)                                                                                                                   
: ONE ( a - n)   -1 FOR  @  ?DUP WHILE  NEXT  1 ABORT" Oops!"                                                                          
   THEN  R> -1 XOR ;                                                                                                                   
: LINKS   16  CR  0  OVER 1- FOR  OVER I - CONTEXT + ONE                                                                               
   DUP 4 U.R  + NEXT  CR ." Total words " .  DROP ;                                                                                    
                                                                                                                                       
: +CR   L# @ 20 > IF  ."    More... " KEY 13 = ABORT" Done"                                                                            
      PAGE  ELSE CR  THEN ;                                                                                                            
: .HEAD ( a)   1+ 2*  DUP C@ 31 AND  1- 0 MAX >R  BEGIN                                                                                
      1+ DUP C@  DUP 127 AND EMIT  128 < WHILE  NEXT  DROP EXIT                                                                        
   THEN  R> ?DUP IF  1- FOR  95 EMIT  NEXT  THEN DROP SPACE ;                                                                          
: WUN ( a)   BEGIN  @  ?DUP WHILE  DUP 1+ @  0< IF                                                                                     
      +CR  DUP .  DUP .HEAD  THEN  REPEAT ;                                                                                            
: IMMEDS   PAGE  16  DUP 1- FOR  DUP I - CONTEXT + WUN                                                                                 
      NEXT DROP ;                                                                                                                      
                                                                                                                                       
( Arithmetic tests)   EMPTY-BUFFERS EMPTY                                                                                              
OCTAL  100011 uCODE D2/   DECIMAL                                      This studies what to do about unsigned multiply.                
                                                                       *,  is a multiply step that does NO shifting after its add.  We 
( Code under test)                                                        are guaranteed no carry since that's one of the failing cases
                                                                       *fix  is a normal multiply step that adds SR rather than MD.    
( 16 CONSTANT K)  : K  ( 8)256 ;      VARIABLE A  1 ALLOT              +c  won't fit with BINARY because md=2 is a special case.       
: ARG ( n - n)   0 SWAP D2/ D2/ +  K 2/ 2/ 2/ - ;                                                                                      
                                                                       US*  partly fixes the odd problem.  Can tolerate (u +n) as long 
: LOG   CR  A 2@ SWAP 6 U.R  6 U.R  2 SPACES ;                            as n is even.                                                
: D~ ( d d - t)   ROT XOR  ROT ROT XOR  OR ;                                                                                           
                                                                       STILL fails to pass identity test for FFFF as arg to RIP.       
( Exhaustive case)  268 LOAD                                                                                                           
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( Arithmetic tests)                                                                                                                 
: AB+ ( - d)   A 2@ U*  SWAP A @ 1- +  SWAP 0 +c ;                     Things tested for selected arguments:                           
: RUN   K FOR  I ARG A 1+ !  K FOR  I ARG A !                            1.  All three basic multiplies return same low order 16 bits. 
   A 2@ *  A 2@ U* DROP  OVER XOR  A 2@ M* DROP                          2.  Commutativity of M* and U* for full range.                
      ROT XOR OR IF  LOG ." Low 16 bits mult mismatch"  THEN             3.  Identity of M* and M/ with zero remainders.               
   A 2@ U*  A 2@ SWAP U*  D~ IF  LOG ." U* commute fail"  THEN           4.  Identity of U* and M/MOD for positive divisors, zero rem. 
   A 2@ M*  A 2@ SWAP M*  D~ IF  LOG ." M* commute fail"  THEN           5.  Same, but with rem = divisor-1.                           
   A @ 1 0 WITHIN IF  A 2@ M*  A @ M/                                                                                                  
      A 1+ @ XOR IF  LOG ." M* =/ M/"  THEN  THEN                                                                                      
   A @ 1 32768 WITHIN IF  A 2@ U*  A @ u/MOD  SWAP                                                                                     
      A 1+ @ XOR OR IF  LOG  ." U* =/ U/ zero rem."  THEN  THEN                                                                        
   A @ 1 32768 WITHIN IF  AB+  A @ u/MOD  A @ 1- XOR  SWAP                                                                             
      A 1+ @ XOR OR IF  LOG  ." U* =/ U/ nz rem."  THEN  THEN                                                                          
   NEXT  ( KEY DROP)  NEXT ;                                                                                                           
                                                                                                                                       
                                                                                                                                       
( Memory diagnostic -- Repeating Check)   EMPTY   HEX                                                                                  
: RAM ( n - a)   2000 + ;   3000 CONSTANT SIZE                         Memory Diagnostic -- Repeating Check     GRC Mon 07Sep87        
: FAILURE ( n -- a) 5000 + ; : 0FAILURES 0 FAILURE SIZE ERASE ;        Adaptation of Screen 262                                        
: ALL ( n)   SIZE 1- FOR  DUP I RAM !  NEXT  DROP ;                                                                                    
: +CR   L# @ 16 > IF  ."  More? " KEY  0D = ABORT" Killed"             Modification of memory diagnostic to  CHECK a section           
      0 L# !  THEN  CR ;                                               of RAM of a certain SIZE repeatedly,  n TIMES. The # of memory  
: HOLDS ( n)   DUP ALL  SIZE 1- FOR  I RAM @ 2DUP XOR                  failures is stored  in the memory block FAILURE of the same     
 IF  1 I FAILURE +! THEN DROP NEXT DROP ;                              SIZE, and the # of failures & address may be printed out..      
: PATTERNS     0 HOLDS  -1 HOLDS  AAAA HOLDS  5555 HOLDS                                                                               
      1  0F FOR  DUP HOLDS  2* NEXT  DROP ;                            That is, the RAM test area & FAILURE  area are the same size so 
VARIABLE #TIMES   10 #TIMES !                                          Can only check half the maximum ram at any one time             
: TIMES ( n) DUP . ." Times..."  0FAILURES FOR PATTERNS NEXT ;                                                                         
: .FAILURES  SIZE 1- FOR  I FAILURE @ IF +CR                           CHECK -- Top level: Checks memory block & outputs results       
    I RAM 4 U.R  I FAILURE @ 5 U.R THEN NEXT +CR ;                                                                                     
: CHECK HEX PAGE  ." Checking " #TIMES @ TIMES                                                                                         
   CR  ." # Failures..." .FAILURES ;                                                                                                   
( Diagnostics)   EMPTY  DECIMAL                                        This diagnostic is designed to test specific known failure modes
( 0< bug)  271 LOAD  272 LOAD  273 LOAD                                   of the chip that are due to timing, loading, or fabrication  
                                                                          errors (and therefore flakey) as opposed to known errors in  
EXIT                                                                      the logic equations (and therefore consistent).  For purposes
( Force errors)  OCTAL  3 SHIFT 0<   DECIMAL                              of monitoring and sensitivity testing, "Expected" errors are 
( Fix errors)                                                             displayed but should not be cause for alarm.  Other errors   
  : 0<   0 ?CODE !  [COMPILE] 0<  [COMPILE] NOP ;  IMMEDIATE              are catastrophic since they reflect the occurrence of side   
                                                                          effects that are theoretically possible but assumed to never 
                                                                          occur.                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( 0< IF)   HEX                                                      The  0<  multiplex is flakey because an MU20 is being used to   
: T=0   CR ."   T=0 latch incorrect (expected):  "                        drive at least 18 things.  It often fails to set the T=0     
   7FFF FOR  I 0< IF  I U. THEN                                           latch, although it appears to leave T clean.  Behavior is    
      I 8000 + 0< IF ELSE  I 8000 + U.  THEN  NEXT ;                      sensitive to at least speed, number of 1-bits in tested value
: TVAL   CR ."   T not all 1's or all 0's (catastrophic):  "              and contents of N before the operation.  There may exist a   
   7FFF FOR  I 0< NOP IF  I U.  THEN                                      failure mode in which T is itself not clean, which would be  
      I 8000 + 0< -1 XOR IF  I 8000 + U.  THEN  NEXT ;                    catastrophic.  It also appears that stack pointer value is   
                                                                          a factor in behavior.                                        
: 0N   CR ." With N=0:  "  0 T=0 TVAL DROP ;                                                                                           
: 7N   CR ." With N=7FFF:  "  7FFF T=0 TVAL DROP ;                                                                                     
: 1N   CR ." With N=FFFF:  "  -1 T=0 TVAL DROP ;                                                                                       
: 0<BUG   HEX  CR CR ." 0< error (Loading on F15):"  0N 7N 1N ;                                                                        
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( +0<)   HEX                                                        The  0<  multiplex is flakey because an MU20 is being used to   
: T=0   CR ."   T=0 latch incorrect (expected):  "                        drive at least 18 things.  It often fails to set the T=0     
   7FFE FOR  1 I NOP + 0< IF  I 1+ U. THEN                                latch, although it appears to leave T clean.  Behavior is    
      I 8001 NOP + 0< IF ELSE  I 8001 + U.  THEN  NEXT ;                  sensitive to at least speed, number of 1-bits in tested value
: TVAL   CR ."   T not all 1's or all 0's (catastrophic):  "              and contents of N before the operation.  There may exist a   
   7FFE FOR  1 I NOP + 0< NOP IF  I U.  THEN                              failure mode in which T is itself not clean, which would be  
      I 8001 NOP + 0< -1 XOR IF  I 8001 + U.  THEN  NEXT ;                catastrophic.  It also appears that stack pointer value is   
                                                                          a factor in behavior.                                        
: 0N   CR ." With N=0:  "  0 T=0 TVAL DROP ;                                                                                           
: 7N   CR ." With N=7FFF:  "  7FFF T=0 TVAL DROP ;                                                                                     
: 1N   CR ." With N=FFFF:  "  -1 T=0 TVAL DROP ;                                                                                       
: 0<ALU   HEX  CR CR ." 0< error on ALU output:"  0N 7N 1N ;                                                                           
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( -0< without ; bit or other strange effects)   HEX                 In actual fact more than just presence or absence of ; bit is   
: < ( n n - t)   - 0< ;                                                   involved here.  I've made definitions of  <  that work from  
: TRUST ( n n - t)   - 8000 AND  0= 0= ;                                  within a definition, but don't work inside the interpreter!  
: TRY   -1 FOR  I  -1 FOR  ( CR DUP . I .)                                                                                             
      DUP I NOP - 0<  ( DUP .)  OVER I TRUST  ( DUP .)                                                                                 
      OVER - IF  CR OVER U. I U. DUP U.                                                                                                
   THEN DROP NEXT  DROP NEXT ;                                                                                                         
                                                                                                                                       
: ENUMERATE   -1 FOR  CR I U.  0 I  -1 FOR                                                                                             
      DUP I NOP - 0<  OVER I TRUST  XOR IF  SWAP 1+ SWAP  THEN                                                                         
   NEXT DROP  ." fails " .  NEXT ;                                                                                                     
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
   ( -2/)   HEX                                                                                                                        
: < ( n n - t)   - 0< ;                                                                                                                
: TRUST ( n n - t)   - 8000 AND  0= 0= ;                                                                                               
: CARRY   -1 FOR  I  -1 FOR                                                                                                            
      I OVER U<  1+ IF                                                                                                                 
         CR OVER U. I U. DUP U.                                                                                                        
   THEN DROP NEXT  DROP NEXT ;                                                                                                         
                                                                                                                                       
: CARRIES   -1 FOR  I IF  I 7FF AND 0= IF  CR I U.  THEN                                                                               
   0 I  DUP 1- FOR                                                                                                                     
      I OVER U<  -1 XOR IF  SWAP 1+ SWAP  THEN  NEXT DROP                                                                              
   DUP IF  I U. ." fails " DUP .  THEN DROP  THEN NEXT ;                                                                               
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Chuck kludges)                                                       2/MOD  sign extends the address.  This one doesn't:             
: Lo ( n - n)   255 AND ; ( 4)                                            : 2/MOD ( n - r* q)   0 SWAP  +D2/ ; ( 4)                    
: Hi ( n - n)   6 DO( 2/ )  Lo ; ( 13)                                 2C@+  returns incremented address, clean low 7-bit byte,        
                                                                          and filthy high byte (sign extended).                        
: 2/MOD ( n - r q)   DUP 1 AND  SWAP 2/ ; ( 4)                         LO  and  HI  extract clean bytes from a number.                 
                                                                                                                                       
: 2C@+ ( a - a l h)   1 @+ SWAP  DUP 127 AND  SWAP 6 DO( 2/ ;          HL  packs a pair of bytes.                                      
   ( 19)                                                               2C!-  stores a pair of bytes and backs the address down.        
: HL ( l h - n)   6 DO( 2* )  OR ;                                                                                                     
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Worst case ALU test)   EMPTY                                                                                                         
: CARRY ( - n)   32767 1+ ;                                                                                                            
: TEST   BEGIN  CARRY 0< NOT UNTIL ;                                                                                                   
: TEST   BEGIN  CARRY 0< WHILE  REPEAT ;                                                                                               
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Test sqrt)   EMPTY                                                   This square root functions properly for any number <4001.0000   
OCTAL 102616 uCODE S'   DECIMAL                                           and will thus produce any root expressable in a signed 16-bit
                                                                          number, completely suitable for normal fractions.  While the 
: D+ ( d d - d)   >R >R  SWAP R> +  SWAP R> +c ; ( 7)                     S' primitive is intended to return root in N and MD and the  
: DNEGATE ( d - d)   SWAP NEGATE  SWAP -1 XOR  0 +c ; ( 6)                residual in T such that  N*N + T  reproduces the argument, it
: D- ( d d - d)   DNEGATE D+ ; ( 14)                                      has needed to be fixed up to avoid loss of carries so that T 
                                                                          and N are garbaged in the process.  Exhaustive tests for     
: SQRT ( d - n)   16384 6 I!  0 4 I!  13 DO( S' )  DUP 0< OR              reproduction of perfect roots and monotonicity in its working
      D2*  1 6 I!  4 I@ 2*  4 I!  S'  DROP DROP  4 I@ ; ( 35)             range have NOT been made yet.                                
                                                                                                                                       
: TRY ( n)   DUP  DUP U* SQRT  OVER - ?DUP IF  OVER . .  THEN ;        The old algorithm,                                              
: GO ( n)   FOR  I TRY DROP  NEXT ;                                       : SQRT ( d - n)   32768 6 I!  0 4 I!  D2*  14 TIMES  S'      
: MONO ( n)   CR  DUP  DUP U*  BEGIN  2DUP SQRT >R                           DROP ; ( 25)                                              
      ROT  DUP I XOR IF  13 EMIT I .  >R  2DUP U. U.                      works only for squares of 0 to 16k.  It has been exhaustively
   R> DUP 1- I XOR IF  ." <--- Bad "  I OVER - .  10 EMIT  THEN           tested for reproduction of perfect roots and monotonicity in 
   THEN  DROP  R> ROT ROT  -1 -1 D+ 2DUP OR 0= UNTIL 2DROP ;              this range (took 1 hr for .25 gigatests at 159 ns).          
( Stack sel reg test)   EMPTY                                                                                                          
: HMM   0 BEGIN  DUP -1 XOR  -1 ND!  AGAIN ;                                                                                           
                                                                                                                                       
: HAR   0 MD I!  -1 BEGIN  MD I@!  -1 ND!  AGAIN ;                                                                                     
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Local @)   EMPTY                                                     Well, the chip passes the L@ test and also the L@+ with XOR as  
: IS ( a - n)   DUP -1 XOR  256 * + ;                                     the operator.  It also works well with - as the operator.    
: SET   31 FOR  I IS  I !  NEXT ;   : SEE   0 32 DUMP ;                                                                                
: MATCH ( a n)   ?DUP IF  CR SWAP U. ." Fail "  U. EXIT                                                                                
   THEN  DROP ;                                                                                                                        
: TST ( n a)   DUP IS  ROT XOR MATCH ;                                                                                                 
: CHK   31 FOR                                                                                                                         
   I [COMPILE] LITERAL  [COMPILE] @  I [COMPILE] LITERAL                                                                               
   COMPILE TST  NEXT ;  IMMEDIATE                                                                                                      
: L@ ( n)   FOR  CHK NEXT ;                                                                                                            
: CHK   31 FOR  I [COMPILE] LITERAL  [COMPILE] DUP                                                                                     
   COMPILE IS  I [COMPILE] LITERAL  [COMPILE] @                                                                                        
   [COMPILE] -  COMPILE MATCH  NEXT ;  IMMEDIATE                                                                                       
: L@+ ( n)   FOR  CHK NEXT ;                                                                                                           
                                                                                                                                       
                                                                                                                                       
   ( Local !)                                                          Be damned if it doesn't pass this one, too.  Okay, Ralph; it's  
: ZERO   0 32 ERASE ;                                                     now time to get serious about checking the object that we    
: HMM ( a)   DUP @  -1 XOR IF  CR DUP U. ." Fail " DUP @ U.               generate.                                                    
      THEN  0 SWAP ! ;                                                                                                                 
: CHK   31 FOR  [COMPILE] -1                                                                                                           
   I [COMPILE] LITERAL  [COMPILE] !  I [COMPILE] LITERAL                                                                               
   COMPILE HMM  NEXT ;  IMMEDIATE                                                                                                      
: L! ( n)   FOR  CHK NEXT ;                                                                                                            
                                                                                                                                       
: SCN   31 FOR   I [COMPILE] LITERAL  [COMPILE] @                                                                                      
      NEXT ;  IMMEDIATE                                                                                                                
: SCOPE   BEGIN  SCN  RX 0= UNTIL ;                                                                                                    
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Matching target output)   EMPTY                                      BIAS  gets larger when the NEW program is SHORTER.              
VARIABLE ORG   VARIABLE BIAS   SHADOWS CONSTANT 'OLD                                                                                   
: OLD ( a - n)   BIAS @ +  512 /MOD  'OLD + BLOCK + @ ( ><) ;          BIASed addresses are in terms of the NEW program.               
: NEW ( a - n)   512 /MOD  BLOCK + @ ;                                                                                                 
                                                                                                                                       
: ?PAGE   L# @ 22 > IF  ." More..." KEY 32 - ABORT" quit"                                                                              
      PAGE  THEN ;                                                                                                                     
: HUNT   PAGE  4096 ORG @ DO  I OLD I NEW - IF  ?PAGE CR                                                                               
      HEX  I 4 U.R  I OLD 8 U.R  I NEW 8 U.R                                                                                           
         I OLD I NEW  2DUP XOR 8 U.R  - 2 SPACES .                                                                                     
   THEN LOOP  SPACE DECIMAL ;                                                                                                          
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( F83 & GRC Extensions to Novix PolyFORTH --- GRC Wed 09Dec87 )        ( F83 & GRC Extensions to Novix PolyFORTH --- GRC Wed 09Dec87 ) 
HEX 1F1F WIDTH ! DECIMAL                                                                                                               
305 LOAD  ( GRC Niceties & Synonyms )                                   Load block for Laxen & Perry F83 &  GRC Extensions & Niceties  
301 LOAD  ( More F83 words & Synonyms)                                                                                                 
302 LOAD  ( F83 Words )                                                                                                                
303 LOAD  ( F83 Vocabularies & ONLY-ALSO)                                                                                              
304 LOAD  ( F83 Iterated Interpretation)                                                                                               
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( F83 Extensions to Novix PolyFORTH --- GRC Fri 04Dec87 )              ( F83 Extensions to Novix PolyFORTH --- GRC Wed 09Dec87 )       
                                                                                                                                       
: VIEW LOCATE ;                      DECIMAL                           Some standard F83 words                                         
: -ROT  SWAP >R SWAP R> ;                                                                                                              
: TUCK SWAP OVER ;                                                                                                                     
: OFF 0 SWAP ! ;    : ON -1 SWAP ! ;                                                                                                   
: (S  [COMPILE] ( ; IMMEDIATE  : (s  [COMPILE] ( ; IMMEDIATE                                                                           
: \  >IN @ NEGATE 64 MOD >IN +! ; IMMEDIATE                                                                                            
: \  [COMPILE] \ ;   ( Interpretive version )                                                                                          
: KEY?  ?KEY ;                                                                                                                         
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( F83 Words --- GRC Mon 07Dec87)                                       ( Forth 83 version of Words  --- GRC Mon 07Dec87 )              
266 LOAD       ( Need These)       DECIMAL                             largest -- Given an address & # of cells, return address and    
16 CONSTANT #THREADS                                                       the value of the largest entry in the array                 
: LARGEST (s addr n --- addr' val )                                                                                                    
    OVER 0 SWAP ROT 0 DO 2DUP @ U< IF -ROT 2DROP DUP @ OVER THEN       ?HEAD -- Conditionally display the name of the word if it is in 
    1+ LOOP DROP ;                                                        the appropriate numbered thread for the 1st vocabulary nibble
: _HASH (s link-- index) 1+ @ 15 AND CONTEXT @ 15 AND + 15 AND ;          index in CONTEXT.                                            
                                                                       WORDS -- gives a listing of the words in the vocabulary         
: ?HEAD (s thread_addr link ) TUCK  _HASH SWAP PAD -  2DUP                corresponding to the first nibble in CONTEXT. Because of the 
   =  ROT 1+ 15 AND ROT = OR  IF .HEAD +CR ELSE DROP  THEN ;              vocabulary & linking structure of words in polyFORTH, a word 
: WORDS PAGE    CONTEXT 1+ PAD #THREADS MOVE                              is only displayed if its hashing value (ie 4bits of 1st char 
    BEGIN PAD #THREADS LARGEST DUP WHILE 2DUP ?HEAD                       added to vocabulary nibble) is equal or one less than the    
    @ SWAP !   REPEAT 2DROP ;                                             number of the thread containing that word ( ie normal &      
                                                                          immediate threads ).                                         
: .C CONTEXT 1+ 16 DUMP ;                                                                                                              
                                                                                                                                       
( F83 Like Vocabularies & ONLY-ALSO Concept ) HEX                      ( F83 Like Vocabularies & ONLY-ALSO )                           
~  VARIABLE VOC-INDEX    -1 VOC-INDEX !                                VOCABULARY is redefined to so its usage is similar to F83. That 
~ ARRAY VOC-TABLE  8 ALLOT   ( LINKS OF VOCS IN SYSTEM - MAX 8 )          is it automatically chooses the polyFORTH index and checks to
: VOCABULARY VOC-INDEX @ 0F = ABORT" Too Many Vocabularies"                see if the maximum number of vocabularies has been reached. 
  CREATE LAST @ @ VOC-INDEX @                                          ONLY ALSO concepts. Only  restriction max 4 vocs in search      
   2 + TUCK 2/ VOC-TABLE   ! DUP ,  VOC-INDEX !                           order.                                                       
;: @ CONTEXT @  FFF0 AND OR CONTEXT ! ;                                ORDER & VOCS same as F83                                        
  VOCABULARY FORTH     VOCABULARY EDITOR ( Redefine)                                                                                   
: ONLY   0 CONTEXT ! FORTH ;                                                                                                           
: ALSO  CONTEXT @ DUP 000F AND SWAP 10 * OR CONTEXT ! ;                                                                                
: ORDER CR ." Context: "  CONTEXT @ 4 FOR DUP 0F AND ?DUP                                                                              
   IF  2/ VOC-TABLE @ .HEAD SPACE THEN 10 / NEXT DROP                                                                                  
  CR ." Current: "  CURRENT @ 2/ VOC-TABLE @ .HEAD SPACE ;                                                                             
: VOCS  VOC-INDEX @ 2/ FOR I VOC-TABLE @ .HEAD SPACE  NEXT ;                                                                           
                                                                                                                                       
                                                                                                                                       
( F83 Iterated Interpretation --- GRC Wed 09Dec87)                     ( F83 Iterated Interpretation --- GRC Wed 09Dec87 )             
VARIABLE #TIMES  ( # times already performed)                          #TIMES  A variable which keeps track of how many times          
: TIMES (s n -- )                                                      TIMES (s n -- )                                                 
  1 #TIMES +! #TIMES @ <                                                Re-execute the input stream a specified number of times        
 IF 1 #TIMES ! ELSE >IN OFF THEN ;                                                                                                     
: MANY    KEY? NOT IF >IN OFF THEN ;                                   MANY  (s -- )                                                   
                                                                         Re-execute the input stream until the user presses a key      
\ : WHEN  (s f -- )                                                                                                                    
\   PAUSE NOT IF R> 4 - >R THEN ;                                      WHEN (s f -- )                                                  
                                                                         Reexecute the previous word until it returns a true flag      
: ::  (s -- )                                                           NOTE: WHEN is slightly magic.                                  
    HERE >R ] R@ EXECUTE R> H ! ;                                        Usage:  : TEST   READY WHEN BEEP ;                            
                                                                              where READY returns a flag                               
                                                                       ::  Compile & Execute the nameless FORTH code, then forget it   
                                                                                                                                       
                                                                                                                                       
( GRC Niceties & Synonyms    --- GRC Wed 09Dec87 )                     ( GRC Niceties & Synonyms --- GRC Wed 09Dec87 )                 
                                                                                                                                       
: +W  ['] ?CREATE 'CREATE ! ;  ( Warnings on )                         +W -W  -- Switch warnings on & off                              
: -W  ['] <CREATE> 'CREATE ! ; ( Warnings off )                        ;:  Synonym for DOES>                                           
                                                                       CUT Synonym for EMPTY                                           
: ;: \ DOES> ; IMMEDIATE                                               LOAD -- Restore current base after LOADing                      
: CUT EMPTY ;                                                                                                                          
                                                                                                                                       
: LOAD  BASE @ >R LOAD R> BASE ! ;                                                                                                     
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Testing of simple streaming operators )                                                                                              
 VARIABLE BOTTOM   9  BOTTOM !                                                                                                         
: 1024/  8 DO( 2/ )   ;                                                                                                                
: virtual ( byte_offset -- address )                                                                                                   
 DUP 1023 AND SWAP 1024/ BOTTOM @ + BLOCK BYTE + ;                                                                                     
VARIABLE POSITION  0 POSITION !                                                                                                        
: nextbyte  ( -- addr )                                                                                                                
   POSITION @ DUP 1+ POSITION ! virtual ;                                                                                              
: getbyte  ( -- byte )                                                                                                                 
  nextbyte C@ ;                                                                                                                        
: putbyte  ( byte -- )                                                                                                                 
   nextbyte C! UPDATE  ;                                                                                                               
: .line  63 FOR getbyte EMIT NEXT CR ;                                                                                                 
                                                                                                                                       
: .page PAGE  CR 15 FOR .line NEXT ;                                                                                                   
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( F83 Like Vocabularies & ONLY-ALSO Concept ) HEX                                                                                      
~  VARIABLE VOC-INDEX    -1 VOC-INDEX !                                                                                                
~ ARRAY VOC-TABLE  8 ALLOT   ( LINKS OF VOCS IN SYSTEM - MAX 8 )                                                                       
: VOCABULARY CREATE LAST @ @ VOC-INDEX @ DUP [ 0F 2 - ] LITERAL                                                                        
   ABORT" Too Many Vocabularies"                                                                                                       
   = ABORT" Too Many Vocabularies"                                                                                                     
   2 + TUCK 2/ VOC-TABLE   ! DUP ,  VOC-INDEX !                                                                                        
;: @ CONTEXT @  FFF0 AND OR CONTEXT ! ;                                                                                                
  VOCABULARY FORTH     VOCABULARY EDITOR ( Redefine)                                                                                   
: ONLY   0 CONTEXT ! FORTH ;                                                                                                           
: ALSO  CONTEXT @ DUP 000F AND SWAP 10 * OR CONTEXT ! ;                                                                                
: ORDER CR ." Context: "  CONTEXT @ 4 FOR DUP 0F AND ?DUP                                                                              
   IF  2/ VOC-TABLE @ .HEAD SPACE THEN 10 / NEXT DROP                                                                                  
  CR ." Current: "  CURRENT @ 2/ VOC-TABLE @ .HEAD SPACE ;                                                                             
: VOCS  VOC-INDEX @ 2/ FOR I VOC-TABLE @ .HEAD SPACE  NEXT ;                                                                           
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
HEX 1F1F WIDTH ! DECIMAL                                                                                                               
                                                                                                                                       
180 LOAD 192 LOAD 193 LOAD                                                                                                             
                                                                                                                                       
: D!  2! ;    : D@  2@ ;                                                                                                               
: DDUP  2DUP ;                                                                                                                         
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
: TEST ;   DECIMAL                                                                                                                     
2VARIABLE LOG(A)      2VARIABLE LOG(ALPHA)  2VARIABLE BETA                                                                             
+1 0 LOG2 DDUP LOG(A) D! LOG(ALPHA) D!  1 1 BETA D!                                                                                    
                                                                                                                                       
1 2 /. +1  2CONSTANT 1-GAMMA   +1 0 LOG2 2CONSTANT LOG(+1)                                                                             
 +1 0 LN 2CONSTANT LN(+1)                                                                                                              
: 1-P  LOG(A) D@ LOG(ALPHA) D@ D- BETA D@ M*/ LOG(+1) D+                                                                               
  EXP2      DNEGATE LN(+1)   D+ EXP    1-GAMMA M*/ ;                                                                                   
: P  1-P  +1 0 D- DNEGATE ;                                                                                                            
                                                                                                                                       
: A 0 LOG2 LOG(A) D! ;    : ALPHA 0 LOG2 LOG(ALPHA) D! ;                                                                               
                                                                                                                                       
: P(A)  A P .F. ;                                                                                                                      
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( Serial Disk Interface -- Novix <---> ForthKit GRC Wed 06Apr88)       ( Serial Disk Interface -- Novix <---> ForthKit )               
DECIMAL                                                                                                                                
: CONSOLE  2048 DEVICE ! ;       : AUX  0 DEVICE ! ;                   LSI-11 Serial Disk interface for the ForthKit adapted to Novix  
: RCV? ( -- f )  AUX ?KEY CONSOLE ;                                    Ting p 135.                                                     
: RCV  ( -- b )  AUX key CONSOLE ;                                                                                                     
: spit BEGIN PAUSE [ HEX ] 100 [ DECIMAL ] U@ 1 AND UNTIL 0 U! ;                                                                       
 : XMT  ( b )  AUX emit CONSOLE ;                                                                                                      
CREATE I/O 1024 CELL ALLOT                                                                                                             
                                                                                                                                       
: DISK ( n)  DUP 0<                                                                                                                    
  IF I/O 1024 DO RCV OVER C! 1+ LOOP DROP I/O SWAP [ HEX ]                                                                             
  7FFF [ DECIMAL ] AND BUFFER 1024 CELL MOVE ( UPDATE) 0 XMT                                                                           
   ELSE BLOCK 1024 DO DUP C@ XMT 1+ LOOP DROP THEN ;                                                                                   
: CHIP  BEGIN RCV? IF RCV ?DUP IF EMIT ELSE RCV 256 * RCV OR                                                                           
   DISK THEN THEN ?KEY IF KEY DUP 27 XOR IF XMT ELSE DROP                                                                              
EXIT THEN THEN  AGAIN ;                                                                                                                
( Serial Disk --- Continued )                                                                                                          
                                                                                                                                       
: TALK  BEGIN  ?KEY IF KEY DUP 27 = IF DROP EXIT THEN  XMT THEN                                                                        
    RCV? IF RCV EMIT THEN AGAIN ;                                                                                                      
                                                                                                                                       
: RESET  ( baud )  AUX BAUD CONSOLE 66 XMT CHIP ;                                                                                      
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
AUX 9600 BAUD CONSOLE                                                                                                                  
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( PDI INTERFACE READ         DRJ 5/88 )                                PDI TEST FUNCTIONS ( READ    DRJ 5/88 )                         
: BIN  2 BASE ! ;                                                                                                                      
                                                                       Port PDIREAD   | Continuously reads Port, displaying data in    
: DISP-DATA DUP HEX U. BIN U. CR ;                                                     the following format;                           
                                                                                                                                       
: PDIREAD                                                                   AAAA CCCC BBBBBBBBBBBBBBBB                                 
BEGIN DUP HEX DUP U. @ DISP-DATA                                                                                                       
-1 FOR NEXT ?KEY UNTIL HEX ;                                                         Where  AAAA is the Port address                   
                                                                                            CCCC is the hex data at the port.          
680 HELPS                                                                  BBBBBBBBBBBBBBBB is the Binary display of the data.         
                                                                                                                                       
                                                                                                                                       
                                                                       NOTE : HEX should be input to set the current base.             
                                                                                                                                       
                                                                                                                                       
                                                                                                                                       
( PDI INTERFACE WRITE TEST          DRJ 12/5/88 )                       PDI INTERFACE TEST FUNCTIONS ( WRITE   DRJ 5/88 )              
                                                                                                                                       
: PDIWRITE BEGIN 2DUP ! -1 FOR NEXT ?KEY UNTIL 2DROP ;                 Byte Port  PDIWRITE |  Writes Byte to Port till CR pressed      
                                                                                                                                       
: PDIB0             ( WRITE BYTE FOLLOWED BY 0 TO PORT )               Byte Port PDIB0    | Writes Byte to Port, then 0 to port then   
                    ( Byte Port   --      )                                                 repeats till key pressed.                  
 BEGIN   2DUP !     ( Write byte to the selected port )                                                                                
 DUP  0 SWAP   !    ( Copy the port address, write 0 to port )         NOTE :   HEX should be input to set the base before use.        
?KEY UNTIL 2DROP  ; ( Loop till a key is pressed )                                                                                     
                                                                                                                                       
681 HELPS