# 3
********* fig-FORTH MODEL ********* 

     Through the courtesy of

      FORTH INTEREST GROUP
         P. O. BOX 1105
     SAN CARLOS, CA.  94070






         RELEASE 1
     WITH COMPILER SECURITY
           AND
     VARIABLE LENGTH NAMES
# 4
( ERROR MESSAGES                  ) 
EMPTY STACK
DICTIONARY FULL
HAS INCORRECT ADDRESS MODE
ISN'T UNIQUE

DISC RANGE ?
FULL STACK
DISC ERROR ! (READ ERROR ?)
DISC DOOR OPEN/NO DISC
DISC IS WRITE PROTECTED
DISC ISN'T FORMATTED
NO DISC !


ABC80 CAS-1            (1982.06.10)
# 5
( ERROR MESSAGES                  ) 
COMPILATION ONLY, USE IN DEFINITION 
EXECUTION ONLY
CONDITIONALS NOT PAIRED
DEFINITION NOT FINISHED
IN PROTECTED DICTIONARY
USE ONLY WHEN LOADING
OFF CURRENT EDITING SCREEN
DECLARE VOCABULARY
# 6
( print&DUMP load, WHERE, ASCII   ) 
DECIMAL
 8 LOAD 12 LOAD



: WHERE ( PRINT SCR# AND IMAGE OF
          ERROR )
  DUP B/SCR / DUP SCR !
  ." SCR # " DECIMAL . SWAP C/L
  /MOD C/L * ROT BLOCK + CR C/L
  TYPE CR HERE C@ - SPACES 127 EMIT 
  QUIT ;

: ASCII ( transform ascii char to
           its number equivalent  ) 
  BL WORD HERE 1+ C@ /COMPILE/
  LITERAL ; IMMEDIATE
  ( FD III/3 page 72 )
-->
# 7
( LOADED-BY EDIT POLYED ASM       ) 
FORTH DEFINITIONS DECIMAL

: LOADED-BY
  <BUILDS , DOES> @ LOAD ;

15 LOADED-BY POLYED ( poly-FORTH)

PAGE
CR ." POLYED for poly-FORTH editor"
CR CR

1 DENSITY !
CR CR ." DENSITY set for double "
CR CR ;S
# 8
(  print screen                  ) 
FORTH DEFINITIONS DECIMAL
: LINEADDR ( N -- SCRADR-2,MEM-1)
  >R 0 R CURADDR R> 40 * HERE + ;
: 
  XCUR C@ YCUR C@ ( SAVE CURSOR)
( SAVE COPY OF SCREEN )
  24 0 DO ( TRANSFER LINE-BY-LINE)
        I LINEADDR 40 CMOVE
        LOOP ( TRANSFER FINISHED)
   PR-ON
   24 0 DO ( PRINT OUT SCREEN)
        10 SPACES
        I LINEADDR SWAP DROP
        40 TYPE CR
        LOOP ( PRINTING FINISHED)
   PR-OFF
   24 0 DO ( RESTORE SCREEN)
        I LINEADDR SWAP 40 CMOVE
        LOOP ( SCREEN RESTORED)
    YCUR C! XCUR C! ;      ;S
# 9
( PINDEX                          ) 
FORTH DEFINITIONS DECIMAL
: PINDEX
  ( FIRST SCR-2, LAST SCR-1 --    ) 
  PR-ON 1+ SWAP DO
      10 SPACES I 3 .R 2 SPACES
      0 I (LINE) TYPE CR LOOP
  CR  10 SPACES 15 MESSAGE PR-OFF
  ;
;S
# 10
( PRINT-BLOCKS                    ) 
FORTH DEFINITIONS DECIMAL

: PRINT-BLOCKS
 ( FIRST BLK#-2 LAST BLK#-1 -- )
  PR-ON ( START THE PRINTER) CR
  1+ SWAP DO 0 #CR !
    10 SPACES ." SCR #" I 3 .R CR
    CR
    I SCR !
    21 0 DO
         10 SPACES I 2 .R 2 SPACES
         I SCR @ .LINE CR
    LOOP CR 10 SPACES
     15 MESSAGE 36 #CR @ DO CR LOOP 
    ?TERMINAL
         IF ( KEY HAS BEEN PRESSED) 
        KEY DROP LEAVE
        THEN
     LOOP PR-OFF ;
;S
# 11
( DR0->DR1, DR1->DR0 for backup   ) 
FORTH DEFINITIONS DECIMAL

: DISPLACEMENT ( -- between drives) 
  DRIVE @ DR1 OFFSET @ SWAP
  IF DR1 ELSE DR0 THEN ;

: ?FLUSH  ( block# -- )
  #BUFF MOD 0= IF FLUSH THEN ;

: DR0->DR1 ( first-block#, last# -) 
  DISPLACEMENT ROT ROT
  1+ SWAP DO
     DUP I BLOCK 2 - +! UPDATE
     I ?FLUSH LOOP DROP FLUSH ;

: DR1->DR0  ( first#, last# --    ) 
  1+ SWAP DO
     DR1 I DUP DUP BLOCK 2 - !
     UPDATE ?FLUSH LOOP FLUSH ;
;S
# 12
( DUMP 1 of 3                     ) 
FORTH DEFINITIONS DECIMAL
: CARRAY <BUILDS 32 C, 33 C, ALLOT
  DOES> 2 + ;
8 CARRAY DMPTXT
: BLANKTXT DMPTXT 8 BLANKS ;
0 VARIABLE TXTCOUNT
16 VARIABLE OLDBASE
: ASCIIS  ( N -- N or BLANK )
  DUP 32 <
  IF ( NO-PRINTING )
    DROP 46 ( REPLACE WITH BLANK )
  ELSE DUP 127 >
    IF ( NON-PRINTING )
       DROP 46 ( REPLACE WITH BL )
    THEN
  THEN ;
: ADDR ( N -- )
  0 OUT ! U. 5 OUT @ - SPACES ;
: TXT  ( -- )   DMPTXT 2 - 10
  TYPE BLANKTXT CR ; -->
# 13
( DUMP 2 of 3                     ) 
FORTH DEFINITIONS DECIMAL
: DUMPA  ( START-ADDR-2,#-1 -- )
  PAGE OVER + SWAP BASE @ OLDBASE ! 
  DUP 8 MOD DUP 0< IF 8 + THEN DUP
  IF ( NOT START OF LINE )
    OVER ADDR  DUP
    3 * SPACES
  THEN TXTCOUNT ! HEX
  DO
    TXTCOUNT @ 0=
    IF OLDBASE @ BASE ! I ADDR HEX
  THEN
    I C@ DUP 3 .R ASCIIS DMPTXT
    TXTCOUNT @ + C! TXTCOUNT DUP
    @ 1+ 8 MOD DUP 0=
    IF TXT
    THEN SWAP !
  LOOP TXTCOUNT @ -DUP IF 8 SWAP - 3
  * SPACES TXT
 THEN OLDBASE @ BASE !  ;   -->
# 14
( DUMP 3 of 3                     ) 
FORTH DEFINITIONS DECIMAL
: DUMP  ( START-ADDR-2,#-1 -- )
  PAGE OVER + SWAP BASE @ OLDBASE ! 
  0 TXTCOUNT ! HEX
  DO
    TXTCOUNT @ 0=
    IF OLDBASE @ BASE ! I ADDR HEX
  THEN
    I C@ DUP 3 .R ASCIIS DMPTXT
    TXTCOUNT @ + C! TXTCOUNT DUP
    @ 1+ 8 MOD DUP 0=
    IF TXT
    THEN SWAP !
  LOOP TXTCOUNT @ -DUP IF 8 SWAP - 3
  * SPACES TXT
 THEN OLDBASE @ BASE !  ;   ;S
DUMP presents a memory dump directly
as requested.  DUMPA adjusts the
dump so that the starting address is
evenly divisible by 8. Bob 82.06.07
# 15
( LOADING SCREEN FOR poly-ED      ) 
DECIMAL
16 LOAD 17 LOAD ( MATCH )
18 LOAD 19 LOAD ( COMMON BLOCKS   ) 
20 LOAD 21 LOAD 22 LOAD 23 LOAD
24 LOAD 25 LOAD 26 LOAD 27 LOAD
28 LOAD 29 LOAD 30 LOAD
FORTH DEFINITIONS DECIMAL
;S
# 16
( (MATCH-                         ) 

FORTH DEFINITIONS DECIMAL
: (MATCH)  ( ADDR-3, ADDR-2,
             COUNT-1 -- flag )
  -DUP IF OVER + SWAP
        DO
         DUP C@ I C@ -
         IF 0= LEAVE ELSE 1+ THEN
        LOOP
       ELSE DROP 0=
  THEN
;
;S
# 17
( MATCH                           ) 

FORTH DEFINITIONS DECIMAL
: MATCH
  ( cursor adr-4, bytes left-3,
    string adr-2, string count-1
    --- flag-2, cursor offset-1 )
  >R >R 2DUP R> R> 2SWAP OVER +
  SWAP DO
    2DUP I SWAP (MATCH)
    IF
       >R 2DROP R> - I SWAP - 0
       SWAP 0 0 LEAVE
    THEN
    LOOP
  2DROP SWAP 0= SWAP ;
;S
# 18
( TEXT LINE                       ) 
FORTH DEFINITIONS DECIMAL


: TEXT ( ACCEPT FOLLOWING TEXT
         TO PAD )
  HERE C/L 1+ BLANKS WORD
  HERE PAD C/L 1+ CMOVE ;

: LINE  ( RELATIVE TO SCR,
          LEAVE ADDRESS OF LINE )
  DUP 20 >
  IF ." NOT ON CURRENT EDIT SCREEN" 
     QUIT
  THEN SCR @ (LINE) DROP ;
;S
# 19
( #LOCATE #LEAD #LAG -MOVE        ) 
VOCABULARY EDITOR IMMEDIATE
EDITOR DEFINITIONS DECIMAL
: #LOCATE
  ( -- CURSOR OFFSET-2, LINE-1 )
  R# @ C/L /MOD ;

: #LEAD
  ( -- LINE ADDR-2, COUNT AFTER
    CURSOR-1 )
  #LOCATE LINE SWAP ;

: #LAG
  ( -- CURSOR ADR-2, COUNT
    AFTER CURSOR-1 )
  #LEAD DUP >R + C/L R> - ;

: -MOVE  ( MOVE FROM ADR-2, TO
           LINE-1 )
  LINE C/L CMOVE UPDATE ;  ;S
# 20
( BUF-MOVE, >LINE#, FIND&INSERT-BF) 
EDITOR DEFINITIONS HEX

: BUF-MOVE
  ( MOVE TEXT TO BUFFER-1, IF ANY)
  PAD 1+ C@
  IF PAD SWAP C/L 1+ CMOVE
  ELSE DROP THEN ;

: >LINE#  ( CONVERT CURRENT CURSOR
            POSITION TO LINE# )
  #LOCATE SWAP DROP ;

: FIND-BUF  ( BUFFER USED FOR ALL
              SEARCHES )
  PAD 50 + ;

: INSERT-BUF ( BUFFER USED FOR ALL
               INSERTIONS )
  FIND-BUF 50 + ;
DECIMAL ;S
# 21
( (HOLD-, (KILL-, (SPREAD-, X     ) 
EDITOR DEFINITIONS DECIMAL

: (HOLD)  ( MOVE LINE-1 FROM BLOCK
            TO INSERT BUFFER )
  LINE INSERT-BUF 1+ C/L DUP
  INSERT-BUF C! CMOVE ;

: (KILL) ( ERASE LINE-1 WITH BLANKS)
  LINE C/L BLANKS UPDATE ;

: (SPREAD)  ( SPREAD, MAKING LINE-1 
              BLANK )
  >LINE# DUP 1 - 19
  DO I LINE I 1+ -MOVE -1 +LOOP
  (KILL) ;

: X  ( DELETE LINE# FROM BLOCK,
       PUT IN INSERT BUFFER )
  >LINE# DUP (HOLD) 20 DUP ROT DO
  I 1+ LINE I -MOVE LOOP (KILL) ; ;S
# 22
( DISPLAY-CURSOR, T, L, N, B      ) 
EDITOR DEFINITIONS DECIMAL

: DISPLAY-CURSOR  ( - )
  CR SPACE #LEAD TYPE 127 EMIT
  #LAG TYPE #LOCATE . DROP ;

: T  ( TYPE LINE#-1 )
  C/L * R# ! 0 DISPLAY-CURSOR ;

: L  ( LIST CURRENT SCREEN )
  SCR @ LIST ;

: N  ( SELECT NEXT SEQUENTIAL SCR ) 
  1 SCR +! ;

: B  ( SELECT PREVIOUS SEQUENTIAL
       SCREEN )
  -1 SCR +! ;

;S
# 23
( (TOP-, SEEK-ERROR, (R-, P       ) 
EDITOR DEFINITIONS DECIMAL

: (TOP)  ( RESET CURSOR TO TOP OF
         BLOCK )
  0 R# ! ;

: SEEK-ERROR  ( OUTPUT ERROR MESS-
                AGE IF NO MATCH )
  (TOP) FIND-BUF HERE C/L 1+ CMOVE
  HERE COUNT TYPE ." NONE" QUIT ;

: (R)  ( REPLACE CURRENT LINE WITH
         INSERT BUFFER )
  >LINE# INSERT-BUF 1+ SWAP -MOVE ; 

: P  ( FOLLOWING TEXT IN INSERT
       BUFFER AND LINE )
  127 TEXT INSERT-BUF BUF-MOVE
  (R) ;
;S
# 24
( WIPE, COPY, 1LINE               ) 
EDITOR DEFINITIONS DECIMAL

: WIPE  ( CLEAR CURRENT SCREEN )
  SCR @ BLOCK DUP 768 BLANKS
  0 SWAP ! UPDATE ;
: COPY  ( COPY SCREEN-2 ONTO
         SCREEN-1 )
  B/SCR * OFFSET @ + SWAP B/SCR *
  B/SCR OVER + SWAP
  DO DUP FORTH I BLOCK 2 - ! 1+
  UPDATE LOOP DROP FLUSH ;

: 1LINE  ( SCAN CURRENT LINE FOR
           MATCH WITH FIND BUFFER
           UPDATE CURSOR, RETURN
           BOOLEAN )
  #LAG FIND-BUF COUNT MATCH R# +!
;
;S
# 25
( (SEEK-, (DELETE-                ) 
EDITOR DEFINITIONS DECIMAL

: (SEEK)  ( FIND BUFFER MATCH OVER
            FULL SCREEN, ELSE ERROR)
  BEGIN 755 R# @ <
    IF SEEK-ERROR THEN
    1LINE
  UNTIL ;

: (DELETE)  ( BACKWARDS AT CURSOR
              BY COUNT-1 )
  >R #LAG + R - ( SAVE BLANK FILL
                  LOCATION )
  #LAG R MINUS R# +! ( BACK UP
                       CURSOR )
  #LEAD + SWAP CMOVE
  R> BLANKS UPDATE ; ( FILL FROM
                       END OF TEXT) 

;S
# 26
( (F-, F, (E-, E                  ) 
EDITOR DEFINITIONS DECIMAL

: (F)  ( FIND OCCURANCE OF FOLLOW-
         ING TEXT )
  127 TEXT
  FIND-BUF BUF-MOVE (SEEK) ;

: F  ( FIND AND DISPLAY FOLLOWING
       TEXT )
  (F) DISPLAY-CURSOR ;

: (E)  ( ERASE BACKWARDS FROM
         CURSOR )
  FIND-BUF C@ (DELETE) ;

: E  ( ERASE AND DISPLAY LINE )
  (E) DISPLAY-CURSOR ;

 ;S
# 27
( D, TILL, COUNTER, BUMP          ) 
EDITOR DEFINITIONS DECIMAL

: D  ( FIND, DELETE, AND DISPLAY
       FOLLOWING TEXT )
  (F) E ;

: TILL  ( DELETE FROM CURSOR TO TEXT
          END )
  #LEAD + 127 TEXT FIND-BUF BUF-MOVE
  1LINE 0= IF SEEK-ERROR THEN
  #LEAD + SWAP - (DELETE)
  DISPLAY-CURSOR ;

: BUMP ( THE LINE AND HANDLE PAGING)
  #CR @
  56 > IF
  CR CR 15 MESSAGE ?PR
  IF 73 #CR @ DO CR LOOP
  THEN 0 #CR !
  THEN ;                    ;S
# 28
( S,  U                           ) 
EDITOR DEFINITIONS DECIMAL

: S  ( FROM CURRENT TO SCREEN-1
       FOR STRING )
   PAGE 127 TEXT 0 #CR !
  FIND-BUF BUF-MOVE
  SCR @ DUP >R DO I SCR !
  (TOP)
  BEGIN
    1LINE IF DISPLAY-CURSOR SCR ?
    BUMP
    THEN 755 R# @ <
  UNTIL
  LOOP R> SCR ! ;

: U  ( INSERT FOLLOWING TEXT
       UNDER CURRENT LINE    )
  C/L R# +! (SPREAD) P ;

;S
# 29
( I, R, M                         ) 
EDITOR DEFINITIONS DECIMAL

: I  ( INSERT TEXT WITHIN LINE )
  127 TEXT  ( LOAD INSERT BUFF )
  INSERT-BUF BUF-MOVE
  INSERT-BUF COUNT #LAG ROT OVER
  MIN >R R R# +! ( BUMP CURSOR )
  R - >R  ( CHARACTERS TO SAVE )
  DUP HERE R CMOVE ( FROM OLD
                   CURSOR TO HERE)
  HERE #LEAD + R> CMOVE ( HERE TO
                  CURSOR LOCATION)
  R> CMOVE UPDATE ( PAD TO OLD
                    CURSOR )
  DISPLAY-CURSOR ; ( LOOK AT NEW
                     LINE )
: R  ( REPLACE FOUND TEXT WITH
       INSERT BUFFER )
  (E) I ;
;S
# 30
( M, K                            ) 
EDITOR DEFINITIONS DECIMAL

: M  ( MOVE FROM CURRENT LINE ON
       CURRENT SCREEN TO SCREEN-2
       UNDER LINE-1 )
  SCR @ >R R# @ >R
  >LINE# (HOLD) SWAP SCR !
  1+ C/L * R# ! (SPREAD) (R)
  R> C/L + R# ! R> SCR ! ;

: K  ( PUT CONTENTS OF FIND BUFFER
       INTO INSERT BUFFER )
  FIND-BUF PAD 132 CMOVE PAD
  INSERT-BUF 66 CMOVE ;

: )!  ( put right parenthesis on
        comment line            )
  SCR @ BLOCK R# @ C/L / 1+ C/L *
  2 - + DUP
  41 SWAP C! 1+ 32 SWAP C! ; ;S
# 31
( READ.SECTOR                     ) 
FORTH DEFINITIONS DECIMAL
( sector#, track# -- buff.addr    ) 
: READ.SECTOR
  TRACK ! SEC !
  OFFSET @ IF 1 DRIVE ! THEN
  SET-DRIVE
  SEC-READ 62720 ;
;S
This definition will read a desired 
sector and track into the input
buffer and leave the input buffers
address on the stack.  Set the de-
sired drive (DR0 or DR1) before
using this function.
A double density disc must be treat-
ed as if it had 80 tracks with sec- 
tors 0-7 on each track.
1982.05.25
# 32
( WRITE.SECTOR                    ) 
FORTH DEFINITIONS DECIMAL
: WRITE.SECTOR
  ( sector#, track# -- buff-addr  ) 
  TRACK ! SEC ! OFFSET @ IF
     1 DRIVE ! THEN
  SET-DRIVE
  USE DUP @ SWAP 62720 SWAP !
  SEC-WRITE USE @ SWAP USE ! ;
;S
# 33
( DOUBLE#IN, SINGLE#IN            ) 
FORTH DEFINITIONS DECIMAL
: DOUBLE#IN
CR ." Input number "
QUERY        ( get # in TIB       ) 
HERE BL WORD ( transfer to HERE   ) 
NUMBER  ;    ( change to number   ) 
             ( and put on stack   ) 
: SINGLE#IN
  DOUBLE#IN DROP ;
;S
# 34
( NON-DESTRUCTIVE STACK PRINT     ) 
FORTH DEFINITIONS
: DEPTH
SP@ S0 @ - ;
: .S  CR DEPTH IF
 SP@ 2 - S0 @ 2 - DO I @ . -2 +LOOP 
  ELSE ." EMPTY " THEN ;
;S
# 35
( BRODIE'S LETTER F               ) 
FORTH DEFINITIONS DECIMAL
: STAR 42 EMIT ;
: STARS  0 DO STAR LOOP ;
: MARGIN  CR 10 SPACES ;
: BLIP  MARGIN STAR ;
: BAR MARGIN 4 STARS ;
: F PAGE BAR BLIP BLIP BAR BLIP
BLIP BLIP CR ;
;S
# 36
( to be continued                 ) 
CR ." fig-FORTH editor and assembler
" CR ." will come on the next casset
te" CR ;S

Some FORTH-79 definitions
: CREATE
  0 VARIABLE -2 ALLOT ;
: WORD
  WORD HERE ;
: 1-
  1 - ;
: 2-
  2 - ;

The above definition of CREATE will 
will work with Brodie's examples.
                   1982.06.10
                   Bob
