ANTIC FORTH#

'Screens Disk one'

  oK

SCR # 0
  0 ( SCREEN INDEX REV H   1/1 ) ;S
  1    >> INTERNAL USE ONLY <<
  2  SCREENS 10 TO 24 CONTAIN EDITOR
  3  SCREEN 30 GIVES FULL LOAD
  4 00/00 SCREEN INDEX
  5 01/01 SOURCE CREDITS
  6 02/06 ERROR MESSAGES
  7 07/0A SYSTEM SETUP / BOOTMAKER
  8 0B/0E SUPERCLONE
  9 0F/0F DECOMP DISSEMBLER DATA
  A       THE EDITOR PACKAGE
  B 10/10 EDITOR LOADER
  C 11/14 SCREEN EDITOR
  D 15/17 LINE EDITOR
  E 18/1A EDITOR ADDITIONS
  F 1B/22 DECOMP/STACKDSP/CDMP/PATCH
 10 23/24 COPIES/DUPLICATE
 11 25/26 FIND
 12 27/27 1.4S KERNEL MODS
 13 28/2E ASSEMBLER
 14 2F/2F DECUS MODS
 15 30/30  FULL LOAD
 16 31/35 HARDWARE/GRAPHICS/SOUND
 17 36/36 PON/POFF
 18 37/38 RS232C SUPPORT
 19 39/39 DISPLAY LIST STUFF
 1A 3A/3A PLAYER/MISSILE
 1B 3B/3B LINK/SETPHYS
 1C 3D/3E LPWORDS
 1D 40/44 FORMATTED LIST PROGRAM
 1E 45/4A CHARSETS/CASE
 1F 4B/4F FORTH79/VAR/SETSYS/BDUMP
 oK

SCR # 1
  0 ******  fig-FORTH  MODEL  ******
  1
  2
  3      Through the courtesy of
  4
  5
  6       FORTH INTEREST GROUP
  7          P. O. BOX 1105
  8       SAN CARLOS, CA. 94070
  9
  A        Implemented on the
  B          ATARI  800/400
  C                by
  D           Steve Calfee
  E              1/26/81
  F              4/01/82
 10    PETER LIPSON/ROBIN ZIEGLER
 11              4/10/82
 12          HARALD  STRIEPE
 13         5/5/82 - 10/16/82
 14  XL Mods - John Stanley 18Jun85
 15      RELEASE 1.4S     REV.H
 16      WITH COMPILER SECURITY
 17      VARIABLE  LENGTH NAMES
 18  SWITCHABLE TOP OF STACK DISPLAY
 19      DECOMPILER/DISSASSEMBLER
 1A   ENHANCED SCREEN EDITOR & FAST
 1B  EDIT WORDS, BASE BORDER DISPLAY
 1C  ENHANCED SYSTEM SET UP/BOOTMKR
 1D        DRIVE 2 LINK/UNLINK
 1E      Further distribution must
 1F      include the above notice.

SCR # 2
  0 BREAK Abort.
  1
  2 IOCB already open.
  3
  4 Non-existant device.
  5
  6 IOCB is write-only.
  7
  8 Invalid command (for this device
  9 )
  A Device or file not open.
  B
  C Bad IOCB #
  D
  E IOCB is read-only
  F
 10 End Of File
 11
 12 Truncated Record
 13
 14 Device Timeout
 15
 16 Device NAK (Negative AcKnowledge
 17 )
 18 Serial Bus input framing error
 19
 1A Cursor out of range
 1B
 1C Serial Bus data-frame overrun
 1D
 1E Serial Bus data-frame checksum e
 1F rror.

SCR # 3
  0 Device-done error
  1
  2 Read-after-write compare error
  3
  4 Function not implemented in hand
  5 ler
  6 Insufficient RAM
  7
  8
  9
  A
  B
  C
  D
  E
  F
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 4
  0 (  ERROR MESSAGES  )   135  159
  1  9  8  7  10  ;S
  2 empty stack
  3
  4 dictionary full
  5
  6 has incorrect address mode
  7
  8 isn't unique
  9
  A
  B
  C disc range ??
  D
  E full stack !
  F
 10 disc error !
 11
 12
 13
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C THIS IS IT
 1D
 1E HELP ME!
 1F

SCR # 5
  0 (  ERROR MESSAGES  )
  1
  2 compilation only, use in definit
  3 ion
  4 execution only
  5
  6 conditionals not paired
  7
  8 definition not finished
  9
  A in protected dictionary
  B
  C use only when loading
  D
  E off current editing screen
  F
 10 declare vocabulary
 11
 12 outside allocated file space
 13
 14 writing off current line
 15
 16
 17
 18
 19
 1A string stack empty !!
 1B
 1C
 1D
 1E
 1F

SCR # 6
  0 (  TARGET COMPILER ERROR MESSAGE
  1 S                 WFR-79JUN02 )
  2
  3
  4 below lower bound of virtual mem
  5 ory
  6 disc compiler assembly error in
  7 mode of
  8 can't find in TARGET
  9
  A target redef.
  B
  C T: error, is it paired with T;
  D ?
  E above virtual memory bounds
  F
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 7
  0  ( SYS/BOOTMKR 82AUG22 1/4 )
  1    FORTH DEFINITIONS   HEX
  2    SAVENFAs
  3  HERE 1C +ORIGIN !  ( FENCE )
  4
  5  HERE 1E +ORIGIN !  ( DP )
  6
  7  HERE DUP FENCE  ! 0 +ORIGIN -
  8
  9  80 / 1+  CONSTANT  #SECT
  A
  B   CODE CALLDK XSAVE STX, E453
  C    JSR, TYA, PHA, ( STATUS )
  D   XSAVE LDX, PUSH JMP, C;
  E
  F
 10 : DKIO 301 ! ( CMD, DRIVE # )
 11   30A ! ( SECT. # ) 304 !
 12   ( RAM BUFFER ) CALLDK ( DKHND)
 13   DUP 0< IF ." ERROR " 0FF AND
 14   BASE @ SWAP DECIMAL
 15   . BASE ! QUIT ENDIF DROP ;
 16 : WTSEC SWAP 304 ! 130 300 !
 17 ( verif $57->) 50 302 C! SECIO ;
 18  : RDSEC SWAP 304 ! 130 300 !
 19          52 302 C! SECIO   ;
 1A : FORMAT ." FORMAT DRIVE " DUP .
 1B   ." -ARE YOU SURE?" 0 PAD ! PAD
 1C  1      EXPECT PAD C@ 59 ( Y) =
 1D   IF 2100 OR PAD 0 ROT DKIO ELSE
 1E         DROP THEN ;
 1F  0 VARIABLE BOOT ( ->CODE ) -->

SCR # 8
  0 ( SYS SET UP/BOOTMKR   2/4 )
  1 : MAKEBOOT FLUSH  EMPTY-BUFFERS
  2  ." INSERT NEW DISK, TYPE Y" CR
  3 0 PAD ! ( DEFAULT ) PAD 3 EXPECT
  4  PAD C@ 59 = IF 1  52  C! CR
  5  ." Writing sectors:" CR CR BOOT
  6  @   1 DUP .  WTSEC #SECT 0 DO I
  7  80 * +ORIGIN I 2 + WTSEC I 2 +
  8  . LOOP 0 52 C! CR ." BOOT COMPL
  9 ETED" CR THEN ; ( BOOT CODE:)
  A  HERE BOOT ! ( PT TO US )
  B  ASSEMBLER 1FF , 480 , ' V1.4S ,
  C  #SECT # LDA, 0= IF, 0 +ORIGIN ,
  D  1 , ENDIF, N STA,    2C8 C@
  E  # LDA, 2C8 STA,  D01A STA,
  F     2C6  C@   # LDA, 2C6 STA,
 10   D018 STA,
 11  52 # LDA, 302 STA, 48C LDA, 30A
 12  STA, 48D LDA, 30B STA, ( SCT1 )
 13  1 # LDA, 301 STA, 48A LDA, 304
 14 STA, 48B LDA, 305 STA, ( ORIGIN)
 15  BEGIN, 30A INC, 0= IF, 30B INC,
 16        ENDIF, E453 JSR, 303 LDA,
 17  .A ASL, CS IF, RTS, ( FRETURN )
 18        ENDIF, 304 LDA, 80 # EOR,
 19  304 STA, 0< NOT IF, 305 INC,
 1A  ENDIF, ( BUMP PTR.) N DEC, 0=
 1B UNTIL, 48A LDA, 0A STA, 48B LDA,
 1C  0B STA,  E C@ # LDA, 2E7 STA,
 1D  F C@ # LDA, 2E8 STA, CLC, RTS,
 1E    FORTH
 1F   -->

SCR # 9
  0 ( BACKUP HES 82AUG15   3/4 ) (
  1 35F ARRAY BUCD BLK @ BLOCK A0 +
  2 BUCD 35F CMOVE CODE bg E474 JMP,
  3  C; : BACKUP  BUCD 480 35F CMOVE
  4  480 C ! STOF bg ; )       -->
 15 Fig-FORTH 1.4S FAST BACKUP
 14 Vers.1.2   BY H.E.STRIEPE 1982

 15  START   - commence I/O  SELECT
 16   - write with verify    OPTION
 17 - REBOOT               Insert source disk and
 18 press START,   or select OPTION
 19 to REBOOT              Reading SOURCE disk...
 1A Insert destination disk, press
 1B START, or SELECT Writing DESTINA
 1C TION disk...     }****** DUPLICATION
 1D  SUCCESSFUL ****** }***** DISK I
 1E /O ERROR!TRY AGAIN ***** }******
 1F   BREAK KEY INTERRUPT!  ******
 

SCR # A
  0 ( scr# A   BOOTMKR/SYS 4/4 )
  1
  2  : DoFORget ( forgets below )
  3       ' TEXT NFA      ( FENCE )
  4         FENCE ! 0 FORGET TEXT ;
  5
  6  : SETSYS   ( SETS RESET PARAM )
  7       LMARGN @ DUP ( MARGINS )
  8       LSB ' V1.4S  4 + C!
  9       MSB ' V1.4S  8 + C!
  A       COL1   @ DUP ( COLORS  )
  B       LSB ' V1.4S  C + C!
  C       MSB ' V1.4S 11 + C!
  D       COL4  C@     ( BORDER  )
  E       LSB ' V1.4S 16 + C!   ;
  F
 10
 11  : HOOK  ( hooks your assembly )
 12        ( routine into WARMSTRT )
 13        ( ->use HOOK word       )
 14     ~[COMPILE] ' ' V1.4S 1+ ! ;
 15
 16  : UNHOOK     ( restore vector )
 17        E4C0 ' V1.4S 1+ ! ;
 18
 19
 1A
 1B   CR ." system words now availab
 1C le" CR
 1D
 1E  ;S
 1F

SCR # B
  0 ( SIO DISK HNDLR 1/2 )
  1   HX   0 DMACTL C!
  2 : CLNDSP  ." }" C 4 POS.
  3       ."  SUPER  CLONE " ;
  4
  5 CODE SIO XSAVE STX, BOT LDA,
  6          E459 JSR, XSAVE LDX,
  7          BOT STY, BOT 1+ STA,
  8      NEXT JMP, C;
  9 : SERR DUP 0< IF 0 100 U/ BASE @
  A        DECIMAL ." ERROR " SWAP
  B        . BASE ! THEN DROP ;
  C  246 CONSTANT DSKTIM
  D : DSIO ( DISK HNDLR VIA SIO )
  E ( BADDR AUXS UNIT-CMD DATFLG )
  F    303 C! ( SET DATA-FLAG )
 10    301 ! ( DUNIT,CMD) 31 300 C!
 11    ( DEVICE) 30A ! ( AUXES )
 12    304 ! ( BUFER-ADDR ) 0 SIO ;
 13
 14  : DIO DSKTIM @ 306 C! 80 308 !
 15          ( BUFLEN) DSIO ;
 16  : RDSEC 5200 OR 40 DIO ;
 17  : WTSEC 5700 OR 80 DIO ;
 18  : PTSEC 5000 OR 80 DIO ;
 19  : FORMAT PAD 0 ROT 2100 OR 40
 1A    DIO       ;
 1B  : STATUS 4 308 ! 1 306 ! 2EA 0
 1C    ROT 5300 OR 40 DSIO SERR ;
 1D  : BAILOUT CONSOL C@ 2 AND 0= ;
 1E
 1F -->

SCR # C
  0 ( BADSEC WORDS )
  1 TBL GRBGSECT 38A0 , B9 C, 8C ,
  2  99 C, 180 , 88 C, F710 , 60 C,
  3  20 C, D76 , 390 , 4C C, 924 ,
  4  20 C, E85 , 20 C, F32 , 20 C,
  5  E0A , 20 C, E8A , 20 C, FCD ,
  6  20 C, CCF , 57A9 , 85 , 3FA2 ,
  7  1370 , 2C C, 380 , F910 ,
  8  DAA9 , 385 , CA C, F410 ,
  9  2FA9 , 85 , 4C C, B7D , 4C C,
  A  B87 ,
  B 40 ARRAY ZERO-SECT ZERO-SECT
  C 80 ERASE
  D  CODE SIO XSAVE STX,
  E  E459 JSR, 0< IF, 1 # LDA,
  F  ELSE, 0 # LDA, ENDIF, PHA,
 10  0 # LDA, XSAVE LDX, PUSH
 11    JMP, C;
 12 : 1ERR? IF ." CAN'T DOWNLOAD"
 13   CR ABORT THEN ;
 14 : 2ERR? IF ." CAN'T WRITE BAD"
 15   ."  SECTOR" CR ABORT THEN ;
 16 : BINIT 2001 301 ! ( DOWNLOAD TO
 17  D1: )   GRBGSECT 304 !
 18  80 DUP 303 C! 308 ! 7 306 C!
 19  31 300 C! SIO 1ERR? ;
 1A   BINIT
 1B : BADSEC 30A ! FF01 301 !
 1C   ZERO-SECT 304 ! 80 DUP 303
 1D   C! 308 ! 7 306 C! 31 300 C!
 1E   SIO 2ERR? ;
 1F  -->

SCR # D
  0 ( SUPER-CLONE WORDS )
  1  180 ARRAY BDSECTS
  2  : WSTRT ." PRESS START " CR
  3   BEGIN CONSOL C@ 1 AND END
  4   BEGIN CONSOL C@ 1 AND 0= END
  5   0 4D C! 5 A  POS. ." DOING IT.
  6 .." ; : GSRC  0 GR. 2 C 4 SE.
  7    10  8 POS. ." READING" ;
  8  : GDST  0 GR. 2 3 4 SE.
  9    10  8 POS. ." WRITING" ;
  A  : RSOME ( START SECT., CNT )
  B    0 DO     I 80 *  PAD + OVER
  C    2 RDSEC FE AND BDSECTS I +
  D    C! BAILOUT IF LEAVE ENDIF
  E    1+ LOOP DROP ;
  F : WSOME ( START SECT., CNT )
 10    0 DO DUP I BDSECTS + C@ IF
 11   BADSEC ELSE I 80 *  PAD + SWAP
 12   1 PTSEC 1 = 0= IF 8 ERROR THEN
 13   THEN 1+ LOOP DROP ;
 14  : COPY-SOME ( START, CNT ) OVER
 15    OVER GSRC RSOME GDST WSOME ;
 16    0 VARIABLE ROOM
 17  : SUPER-CLONE2  ." SOURCE DISK
 18  IN DRIVE #2" CR ." DESTINATION
 19  IN DRIVE #1" CR WSTRT
 1A    HIMEM @  PAD - 80 / ROOM ! 1
 1B    2D0 BEGIN DUP 0 > WHILE OVER
 1C    OVER ROOM @ MIN COPY-SOME
 1D    ROOM @ - SWAP ROOM @ + SWAP
 1E    REPEAT DROP DROP 0 GR. ;
 1F     -->

SCR # E
  0 ( SUPER-CLONE WORDS    3/3 )
  1
  2      180 ARRAY BDSECTS
  3  : WSTRT ." PRESS RETURN " KEY
  4   CR DROP ." Doing it " ;
  5
  6  : CLNMSG   CR
  7    ." Source disk in Dr 2," CR
  8    ." Destin disk in Dr.1," CR ;
  9
  A  : RSOME ( START SECT., CNT )
  B    0 DO     I 80 *  PAD + OVER
  C    2 RDSEC FE AND BDSECTS I +
  D    C! BAILOUT IF LEAVE ENDIF
  E    1+ LOOP DROP ;
  F : WSOME ( START SECT., CNT )
 10    0 DO DUP I BDSECTS + C@ IF
 11   BADSEC ELSE I 80 *  PAD + SWAP
 12   1 WTSEC 1 = 0= IF 8 ERROR THEN
 13   THEN 1+ LOOP DROP ;
 14  : COPY-SOME ( START, CNT ) OVER
 15    OVER SPACE RSOME SPACE WSOME
 16    ;    0 VARIABLE ROOM
 17  : CLONE        CLNMSG   WSTRT
 18    HIMEM @  PAD - 80 / ROOM ! 1
 19    2D0 BEGIN DUP 0 > WHILE OVER
 1A    OVER ROOM @ MIN COPY-SOME
 1B    ROOM @ - SWAP ROOM @ + SWAP
 1C    REPEAT DROP DROP CR BELL ;
 1D  : BADM WSTRT
 1E       2D1 1 DO I  BADSEC LOOP ;
 1F   0 GR. GS DMACTL C! BASE ! ;S

SCR # F
 10 ???ADCANDASLBCCBCSBEQBITBMIBNEBP
 11 LBRKBVCBVSCLCCLDCLICLVCMPCPXCPYD
 12 ECDEXDEYEORINCINXINYJMPJSRLDALDX
 13 LDYLSRNOPORAPHAPHPPLAPLPROLROR
 14 RTIRTSSBCSECSEDSEISTASTXSTYTAXTA
 15 YTSXTXATXSTYA
 16
 17
 18    #X))Y,X,YN).A
 19
 1A
 1B
 1C
 1D >> DECOMP DISASSEMBLER STUFF <<
 1E  DO NOT MOVE FROM THIS SCREEN !
 1F

SCR # 10
  0 ( SCREEN ED. LOAD 1.4S 1/1 )
  1 (              HES  82aug4 )
  2    HEX FORTH DEFINITIONS
  3
  4 VOCABULARY EDITOR IMMEDIATE
  5
  6   ' EDITOR 2 + DUP
  7     VOC-LINK ! 20 +ORIGIN !
  8    FORTH DEFINITIONS
  9
  A  : EDIT    SCR ! POFF
  B         ~[COMPILE] EDITOR ;
  C  HEX 15 LOAD    ( LINE EDITOR )
  D  HEX 1B LOAD    ( DECOMPILER  )
  E  HEX 20 LOAD    ( STACKDISPLAY)
  F  HEX 11 LOAD    ( SCREEN EDIT )
 10     18 LOAD ( ENHANCEMENTS   )
 11     23 LOAD ( copies/backup  )
 12     25 LOAD ( FIND WORD      )
 13     3D LOAD ( PRINTER WORDS  )
 14     4D LOAD ( SYS WORDS      )
 15     3F LOAD ( PNS STUFF      )
 16   : VERIFY  57 245E C! ;
 17   : NOVERIFY 50 245E C! ;
 18   : SYS 0 DMACTL C! 7 LOAD 22
 19     DMACTL C! ; : CLONE B LOAD ;
 1A  CODE  GOBOOT  E477 JMP, C;
 1B   : GO STACKON GS ;
 1C   : ZV VLIST ;
 1D   : WARNON  1 WARNING ! ;
 1E   : WARNOFF 0 WARNING ! ;
 1F ;S

SCR # 11
  0 ( SCREEN EDITOR DLI    1/4 )
  1 (              HEH  2jul82 )
  2 HEX   EDITOR DEFINITIONS
  3 ( DLI for command window   )
  4      0 VARIABLE COL1T
  5      0 VARIABLE COL2T
  6  CODE EDLI    PHA, TXA, PHA,
  7    COL1T LDA, COLRSH  EOR,
  8    DRKMSK AND, TAX, COL2T LDA,
  9    COLRSH EOR, DRKMSK AND,
  A    WSYNC STA,
  B    D017 STX, D018 STA, PLA,
  C    TAX, PLA, RTI,     C;
  D  : COLSET   COL2 C@ DUP F AND
  E       COL1T C! F0 AND COL1 C@
  F       F AND + COL2T C!    ;
 10 ( Sound words for beeps    )
 11  0 VARIABLE TOPFLAG
 12  1 VAR       L#FLG
 13  0 VAR      SPTCH
 14  1 VAR      SFLG
 15  0 VAR      EDVEC
 16
 17 : SOUNDON  1 TO SFLG ;
 18 : SOUNDOFF 0 TO SFLG ;
 19  FORTH DEFINITIONS
 1A : SNDOFF 0 0 0 SOUND ;
 1B  EDITOR DEFINITIONS
 1C : PN  10 * TO SPTCH SFLG IF
 1D       28 0 DO 0      SPTCH A 8
 1E  SOUND LOOP 0 SNDOFF THEN ;
 1F  -->

SCR # 12
  0 ( SCREEN ED. DLSETMOD  2/4 )
  1 (               JDS 18JUN85 )
  2    EDITOR DEFINITIONS
  3    28 ARRAY EDBF C ARRAY DLSTMP
  4    TBL EDLST 82 C, 40 C, 202 ,
  5        202 , 02 C, 40 C, 47 C,
  6       EDBF , 41 C, DLST @ ,
  7 0 GR. DLST @ 14 + DLSTMP C CMOVE
  8  : DLSET 200 @ TO EDVEC ' EDLI 2
  9 00 ! EDBF TOPFLAG @ 0= IF " UPP"
  A  ELSE " LOW" THEN SYPE " ER HALF
  B  SCR # " SYPE SCR @ 0 <# #S #>
  C  SYPE   "     " SYPE DROP
  D  DLST @ EDLST C + !
  E  EDLST DLST @ 14 + E CMOVE
  F  FF D40E C!    ." }" ;
 10   208 @  VARIABLE KBDVC
 11  CODE KCHK    54 LDA, 10 # CMP,
 12       0< IF, D209 LDA, C # CMP,
 13       0= IF, PLA, RTI, THEN,
 14       THEN,  KBDVC ) JMP, C;
 15  CODE EDKIS  SEI, 209 LDA, C4 #
 16      CMP, >= IF, KBDVC 1+ STA,
 17      208 LDA, KBDVC STA,   THEN,
 18      ' KCHK LSB  # LDA, 208 STA,
 19      ' KCHK MSB  # LDA, 209 STA,
 1A               CLI, NEXT JMP, C;
 1B  CODE EDKIQ  SEI,
 1C        KBDVC       LDA, 208 STA,
 1D        KBDVC 1 +   LDA, 209 STA,
 1E               CLI, NEXT JMP, C;
 1F    -->

SCR # 13
  0 ( SCREEN ED. MOD 1.4S  3/4 )
  1            ( HES 82AUG18   )
  2  EDITOR DEFINITIONS
  3  : EDCLR   COL1 @ COL3 @ 0 GR.
  4        COL3 ! COL1 ! CHRST C@
  5        CHBAS C!  ;
  6  : EDLS           EDCLR COLSET
  7   0 DMACTL C! DLSET 22 DMACTL C!
  8           EDKIS 2203 LMARGN !
  9         COL4 C@ DUP F0 AND SWAP
  A        8 +  F AND + COL0 C! ;
  B  : EDLQ   8F D40E C! EDVEC 200 !
  C  EDKIQ ' V1.4S 4 + C@ 52 C! '
  D   V1.4S 8 + C@ 53 C! 0 DMACTL C!
  E    DLSTMP DLST @ 14 + C CMOVE 22
  F    DMACTL C! FF D40E C!  CR ;
 10
 11
 12  : .L# L#FLG IF 10 0 DO DUP 0 I
 13     POS. I + . LOOP THEN DROP 3
 14     12 POS. ;
 15  : ULL      DUP TOPFLAG ! SCR @
 16      EDLS  EDLQ    BLOCK EDLS
 17                 3 0 POS. + 200
 18       1 DUP 2F0 C! 2FE C! TYPE
 19      CR ." DOIT"  AAAA 2B2 ! ;
 1A  : UL   0 ULL 0 .L#
 1B    0 DUP 2FE C! 2F0 C! 6 PN ;
 1C  : LL   200 ULL 10 .L#
 1D    0 DUP 2FE C! 2F0 C! 7 PN ;
 1E        -->
 1F

SCR # 14
  0 ( SCREEN EDITOR 1.4S   4/4 )
  1   EDITOR DEFINITIONS
  2 : DOIT
  3     10 0 DO -1 2B2 ! 3 I POS.
  4     SCR @ BLOCK I 20 * +
  5     TOPFLAG @ + ICBAL ! 20
  6     ICBLL ! GET DROP LOOP
  7          UPDATE
  8     TOPFLAG @ 0= IF UL ELSE LL
  9     ENDIF ;
  A : FORTH   EDLQ ~[COMPILE] FORTH ;
  B
  C   EDITOR DEFINITIONS
  D : COPY    FORTH  COPY  ;
  E : FLUSH   FORTH  FLUSH ;
  F : FH   FLUSH ;
 10
 11 : L#ON 1 TO L#FLG BASE @ > 8 IF
 12             HEX THEN DOIT ;
 13
 14 : L#OFF  0 TO  L#FLG DOIT ;
 15
 16  FORTH DEFINITIONS
 17 ;S
 18
 19
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 15
  0 ( LINE EDITOR          1/3 )
  1 (  TEXT,  LINE, WHERE USED IN
  2  EDITOR    7/7/80-SRC )
  3 FORTH  DEFINITIONS   HEX
  4
  5
  6 : TEXT                  ( ACCEPT
  7  FOLLOWING TEXT TO PAD *)
  8     HERE  C/L  1+   BLANKS  WORD
  9   HERE  PAD  C/L  1+  CMOVE  ;
  A : #OFLINES B/BUF B/SCR * C/L / ;
  B
  C : LINE             ( RELATIVE TO
  D  SCR, LEAVE ADDRESS OF LINE *)
  E  DUP  #OFLINES            MINUS
  F AND IF ." NOT ON SCREEN" ABORT
 10 ENDIF  ( KEEP ON THIS SCREEN )
 11       SCR  @  (LINE)  DROP  ;
 12
 13
 14 : WHERE                  ( PRINT
 15  SCREEN # AND IMAGE OF ERROR *)
 16     DUP  B/SCR  /  DUP  SCR  !
 17  ." SCR # "   .
 18     SWAP  C/L  /MOD  C/L  *  ROT
 19   BLOCK  +  CR  C/L  TYPE
 1A     CR  HERE  C@  -  SPACES  5E
 1B  EMIT  ~[COMPILE] EDITOR  QUIT  ;
 1C
 1D
 1E -->
 1F

SCR # 16
  0 ( LINE EDITING COMNDS  2/3 )
  1   EDITOR DEFINITIONS
  2 : -MOVE   ( MOVE IN BLOCK BUFFER
  3  ADDR FROM-2,  LINE TO-1 *)
  4      LINE  C/L  CMOVE  UPDATE  ;
  5
  6 : HL                      ( HOLD
  7  NUMBERED LINE AT PAD *)
  8     LINE  PAD  1+  C/L  DUP  PAD
  9   C!  CMOVE  ;
  A : BL                     ( ERASE
  B  LINE-1 WITH BLANKS *)
  C LINE  C/L  BLANKS  UPDATE ;
  D
  E : SL                    ( SPREAD
  F  MAKING LINE # BLANK *)
 10       DUP  1  -  ( LIMIT )
 11 #OFLINES 2 -  ( FIRST TO MOVE )
 12       DO  I  LINE  I  1+  -MOVE
 13   -1  +LOOP  BL ;
 14 : DL            ( DELETE LINE-1,
 15  BUT HOLD IN PAD *)
 16    DUP  HL  #OFLINES   1   -
 17    DUP  ROT
 18       DO  I  1+  LINE  I  -MOVE
 19  LOOP  BL ;
 1A : CL  ( COPY LINE-2 OF SCREEN-1
 1B  TO PAD )
 1C SCR @ >R SCR ! HL R> SCR ! ;
 1D
 1E -->
 1F

SCR # 17
  0 ( LINE EDITING COMNDS  3/3 )
  1 (                 WFR-790105 )
  2 : RL
  3  ( REPLACE ON LINE-1, FROM PAD )
  4       PAD  1+  SWAP  -MOVE  ;
  5
  6
  7
  8 : $                        ( PUT
  9  FOLLOWING TEXT ON LINE-1 )
  A       1  TEXT  RL  ;
  B
  C
  D
  E : %                ( INSERT TEXT
  F  FOLLOWING AFTER LINE-1 *)
 10     1   TEXT  1+  DUP  SL  RL  ;
 11
 12 : IL       (  INSERT  PAD  AFTER
 13  LINE-1 ) 1+  DUP  SL  RL  ;
 14
 15 : TL   ( TYPE LINE BY #-1,  SAVE
 16  ALSO IN PAD *)
 17     DUP . ." $ "
 18     DUP C/L *  R#  !       HL
 19      PAD  1+  C/L  TYPE  CR ;
 1A
 1B    FORTH DEFINITIONS
 1C
 1D : COPY SWAP BLOCK SWAP BLOCK 400
 1E      CMOVE UPDATE FLUSH ;
 1F ;S

SCR # 18
  0 ( VERS 1.4S MODS  HES  1/3 )
  1    FORTH DEFINITIONS    HEX
  2  : HX HEX 93 2C8 C! ;   DECIMAL
  3  : DX DECIMAL  68  712  C! ;
  4  : BX BINARY  248 712 C! ; HEX
  5  : BS  0006 2C5 ! ;
  6  : WS  0A00 2C5 ! ;
  7  : GS  D006 2C5 ! ;
  8  : NS  94CA 2C5 ! ;
  9    EDITOR DEFINITIONS
  A  : LE  EDIT LL ;
  B  : UE  EDIT UL ;
  C  : N 8 PN SCR @ 1+ EDIT UL ;
  D  : P 4 PN SCR @ 1- EDIT UL ;
  E  : L   SCR @     EDIT UL ;
  F : T 4 PN 9 PN ALT @ @ EDIT UL ;
 10 : SL DUP SL 10 < IF UL ELSE
 11             LL THEN ;
 12
 13    FORTH DEFINITIONS
 14 : EDT ~[COMPILE] EDITOR ;
 15 : UE ~[COMPILE] EDITOR
 16      EDITOR UE ;
 17    FORTH DEFINITIONS
 18 : LE ~[COMPILE] EDITOR
 19      EDITOR LE ;
 1A    FORTH DEFINITIONS
 1B : L&  HEX   ( fast load )
 1C      0 DUP WARNING ! DMACTL C!
 1D      LOAD  22 DMACTL C! ;
 1E
 1F  -->

SCR # 19
  0 ( FAST EDIT WORDS      2/3 )
  1 ( ZIEGLER/STRIEPE STUFF )
  2   FORTH DEFINITIONS   HEX
  3 : L. LIST ; : L SCR @ LIST ;
  4 : N SCR @ 1+ LIST ;
  5 : P SCR @ 1- LIST ;
  6 : NL EMPTY-BUFFERS LIST ;
  7 : SHOW 1+ SWAP DO I LIST LOOP ;
  8 : LS ~[COMPILE] EDITOR 1 + SWAP
  9  27 53 C! DO I EDITOR TL LOOP ;
  A : SAVE-BUFFERS  FLUSH ;
  B : ERASE-CORE  EMPTY-BUFFERS ;
  C : TRC NFA ID. ;
  D : T  ALT @ @ LIST ;
  E CODE K  XSAVE STX, TSX, 109 ,X
  F   LDA, PHA, 10A ,X LDA, XSAVE
 10   LDX, PUSH JMP,            C;
 11  : EMPTY  0 8 C! COLD ;
 12    D  ARRAY CDAT
 13    22 TEXT ... ......."
 14    PAD 1+ CDAT C  CMOVE
 15  : DATE 1+ SWAP DO I BLOCK
 16      11 + CDAT SWAP  C CMOVE
 17       UPDATE FLUSH  LOOP ;
 18  : NEWDATE CR ." DATE: " CDAT C
 19     TYPE ." " QUIT ;
 1A  : DATE: 9B TEXT PAD 1+ CDAT C
 1B    CMOVE ; EDITOR DEFINITIONS
 1C  : DATE SCR @ BLOCK 11 + CDAT
 1D     SWAP C CMOVE UPDATE UL ;
 1E  : LIST EDLQ LIST ; : L. LIST ;
 1F   -->

SCR # 1A
  0 ( ZIEGLER/STRIEPE V1.4S 3/3 )
  1   FORTH DEFINITIONS
  2 : N->T  SCR C@ S->D
  3    <# #S #>      ;
  4 : ZERO-BLOCK
  5   SCR @ BLOCK DUP DUP
  6   400 20 FILL                 "
  7 \ scr#     empty block       1/1
  8  ;S "    ROT SWAP CMOVE
  9   7 + N->T ROT SWAP CMOVE
  A   UPDATE FLUSH ;
  B : LZERO  1+ SWAP DO I SCR !
  C          ZERO-BLOCK LOOP ;
  D   EDITOR DEFINITIONS
  E : ZERO-BLOCK
  F    EDLQ ZERO-BLOCK EDT UL ;
 10 : NUL EMPTY-BUFFERS UL ;
 11 : NLL EMPTY-BUFFERS LL ;
 12 : LOAD  FLUSH DEPTH 0= IF SCR @
 13         THEN LOAD ;
 14 : T. 9 PN 4 PN ALT @ @ EDIT LL ;
 15  : N. 9 PN SCR @ 1 + EDIT LL ;
 16 : P. 5 PN SCR @ 1 - EDIT LL ;
 17 : WIPE  ZERO-BLOCK ;
 18 : DRAIN EMPTY-BUFFERS ;
 19 : W    ." }RETURN to wipe, N to
 1A  abort "         KEY 4E NOT = IF
 1B              WIPE THEN ;
 1C   FORTH DEFINITIONS
 1D : DRAIN EMPTY-BUFFERS ;
 1E : WIPE  ZERO-BLOCK ;
 1F   ;S

SCR # 1B
  0 ( HIGH-LEVEL DISSASSEMBLER )
  1   FORTH DEFINITIONS
  2                        TASK DOG
  3 ' (;CODE)    CFA CN .;CODE
  4 ' ;S         CFA CN .;S
  5 ' BRANCH     CFA CN .BR
  6 ' 0BRANCH    CFA CN .0BR
  7 ' (DO)       CFA CN .DO
  8 ' (LOOP)     CFA CN .LOOP
  9 ' (+LOOP)    CFA CN .+LOOP
  A ' LIT        CFA CN .LIT
  B   0D6B           CN .CLIT
  C ' (.")       CFA CN .(.")
  D ' TASK CFA   @   CN .:
  E ' DOG CFA    @   CN .DOES>
  F ' COMPILE    CFA CN .COMP
 10
 11   0 VARIABLE .IP
 12
 13 ' BLK CFA    @   CN .USR
 14 ' .;S CFA    @   CN .CON
 15 ' .IP CFA    @   CN .VAR
 16    60            CN RTS,
 17    40            CN RTI,
 18
 19  -->
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 1C
  0 ( HIGH-LEVEL DISSASSEMBLER )
  1
  2 : PRNAME 2+ NFA ID. ;
  3
  4 : STRNG ( cfa--cfa   prnt strng)
  5   DUP .(.") = IF PRNAME .IP @
  6   DUP COUNT ROT OVER + 1+ .IP !
  7   TYPE CR R> DROP ENDIF ;
  8
  9 : LIT? ( cfa--cfa    prints lit)
  A   DUP .LIT = IF PRNAME .IP @ @ .
  B   CR 2 .IP +! R> DROP ELSE DUP
  C   .CLIT = IF ." CLIT " DROP .IP
  D   @ C@ . CR 1 .IP +! R> DROP
  E   ENDIF ENDIF ;
  F
 10 : COMP? DUP .COMP = IF PRNAME
 11   .IP @ @ PRNAME CR 2 .IP +! R>
 12   DROP ENDIF ;
 13
 14 : PROMPT 0 2FE ! ." ok " CR ;
 15
 16 : ENDEF ( cfa--cfa  aborts@end)
 17   DUP .;CODE = OVER .;S = OR IF
 18   PRNAME CR PROMPT QUIT ENDIF ;
 19
 1A : BRNCH ( cfa--cfa   prnts dst)
 1B   DUP .BR = OVER .0BR = OR OVER
 1C   .LOOP = OR OVER .+LOOP = OR
 1D   IF PRNAME ." to " .IP @ DUP @
 1E   + .  CR 2 .IP +! R> DROP ENDIF
 1F  ;    -->

SCR # 1D
  0 ( DECOMP DISSASSEMBLER  PBL 82)
  1
  2      F CN OPTAB  ( STD. $F )
  3    200 CN OPOFF  300 CN MODOFF
  4
  5 : 1OP .IP @ DUP HH ." : " C@ 1
  6  .IP +! DUP CHH  SPACE ; ( --op)
  7
  8 : INDX ( off base--addr) + B/BUF
  9  /MOD ~[ OPTAB B/SCR * ] LITERAL
  A  + BLOCK  + ;
  B
  C : OPLUK  ( op--opind modind #op)
  D  DUP + 0 INDX DUP C@ SWAP 1+ C@
  E  40 /MOD ;
  F
 10 : OPANDP ( #bytes--) DUP -DUP IF
 11  .IP @ C@ CHH  SPACE 1 - IF .IP
 12  @ 1+ C@ CHH  ELSE 2 SPACES
 13  ENDIF ELSE 5 SPACES ENDIF
 14  ."  - " -DUP IF 1 - IF .IP @ @
 15  2 ELSE .IP @ C@ 1 ENDIF .IP +!
 16  HH SPACE ELSE 5 SPACES ENDIF ;
 17
 18 : MODP ( modind--) MODOFF INDX 2
 19  TYPE SPACE ;
 1A
 1B : OPP ( opind--) OPOFF INDX 3
 1C  TYPE ." , " CR ;
 1D
 1E -->
 1F

SCR # 1E
  0 ( DECOMP DISSASSEMBLER  PBL 82)
  1 : BR? ( mode #op--mode) OVER 10
  2  = IF .IP @ DUP C@ CHH
  3  ."     - " DUP C@ DUP 80 AND IF
  4  FF00 OR ENDIF 1+ + HH   .IP +!
  5  SPACE ELSE OPANDP ENDIF ;
  6 : 1LINE 1OP OPLUK BR? MODP OPP ;
  7
  8 : JMPEX ( --f  test endef jmps)
  9  .IP @ C@ 4C = IF .IP @ 1+ @ DUP
  A  ASSEMBLER NEXT = OVER W 1 - =
  B  OR OVER               POP = OR
  C  OVER PUSH = OR OVER PUT = OR
  D  SWAP POPTWO FORTH = OR DUP IF
  E  ENDIF ELSE 0 ENDIF ;
  F
 10 : ;CEND .IP @ C@ DUP RTS, = SWAP
 11   RTI, = OR JMPEX OR ;
 12
 13 : 1WRD BEGIN 1LINE ;CEND UNTIL
 14   1LINE ; : CSEE 1WRD ;
 15
 16 : DIS .IP ! 1WRD ; : NDIS .IP !
 17   0 DO 1LINE LOOP ;
 18
 19 : ISCODE .IP @ DUP 2 - @ = IF
 1A   ." primitive " CR 1WRD ELSE
 1B   .IP @ CFA @ DUP 2 - @ SWAP
 1C   .IP ! .;CODE = IF
 1D   ." ;CODE word" CR      ELSE
 1E   ." odd entry point" CR ENDIF
 1F   1WRD  ENDIF ; -->

SCR # 1F
  0 ( HIGH-LEVEL DISSASSEMBLER )
  1
  2 : ISCOL ( -- <ff> or <pfa tf> )
  3   .IP @ DUP CFA @ .: - IF DUP
  4   CFA @ DUP .DOES> = IF .IP @ @
  5   .IP ! ." DOES> word" CR DROP 1
  6   ELSE SWAP DROP DUP .CON  = IF
  7   ." CONSTANT : " .IP @ @ HH
  8   CR DROP ELSE DUP .USR = IF
  9   ." USER variable " DROP CR
  A   ELSE .VAR = IF ." VARIABLE : "
  B   .IP @ DUP HH @ ."  = " HH CR
  C   ELSE ISCODE ENDIF ENDIF ENDIF
  D   0 ENDIF ELSE 1 ENDIF ;
  E
  F
 10 : NXTW 2 SPACES .IP @ DUP HH
 11   ."  : " @ 2 .IP +! 2 SPACES
 12   LIT? BRNCH COMP? STRNG ENDEF
 13    PRNAME CR    ;
 14
 15 : FETCHW ~[COMPILE] ' .IP !
 16   ISCOL  IF NFA C@ 40 AND IF
 17   ." immediate" CR ENDIF ELSE
 18            PROMPT QUIT ENDIF ;
 19
 1A : DECOMP  1 2FE C! FETCHW BEGIN
 1B   NXTW ?TERMINAL IF
 1C   PROMPT QUIT ENDIF AGAIN ;
 1D
 1E : ZZ DECOMP ;
 1F  ;S

SCR # 20
  0 ( CONSTANT INFO DISPLAY 1/3 )
  1   FORTH DEFINITIONS
  2
  3 HEX  4E LOAD
  4
  5 TBL XTRN 40 C, 0 C, 20 C, 60 C,
  6
  7 CODE ASCINT BOT LDA,
  8  .A ROL, .A ROL, .A ROL, .A ROL,
  9  03 # AND, TAY, BOT LDA,
  A  9F # AND, XTRN ,Y ORA,
  B  BOT STA,  NEXT JMP, C;
  C
  D : SYPE ( addr, straddr, cnt )
  E   OVER + SWAP DO I C@
  F   ASCINT OVER C! 1+ LOOP ;
 10
 11
 12
 13
 14 HERE DUP 3F + FFC0 AND
 15 SWAP -  ALLOT
 16
 17 28 ARRAY BUF
 18
 19 TBL DLIST
 1A 5070 , 42 C, BUF , 1 C, 0 ,
 1B
 1C HERE 2 - CN DLPTCH
 1D
 1E -->
 1F

SCR # 21
  0 ( CONSTANT INFO DISPLAY  2/3  )
  1  ' ABORT 6 + @  VARIABLE ABORT1
  2  ' QUIT  A + @  VARIABLE QUIT1
  3  : INIT 0 DMACTL C!
  4   DLST @ DUP C@ 1 -
  5   IF DUP 3 + DLPTCH !
  6   1 OVER C! DLIST SWAP 1+ !
  7   ELSE DROP THEN 22 DMACTL C! ;
  8 : DSPLY BUF " TOS->" SYPE >R
  9  ASSEMBLER UP FORTH @ 6 + @ SP@
  A  10 + MIN SP@ BEGIN 2+ OVER OVER
  B  > WHILE R> OVER @
  C   0 <# # # # # #>
  D  SYPE 1+ >R REPEAT DROP DROP R>
  E  "                      fig-FORT
  F H 1.4S"    SYPE  DROP ;
 10
 11 : SSK    DSPLY INIT CR
 12    BASE @ DUP A = IF 44 2C8 C! E
 13 LSE DUP 10 = IF 93 2C8 C! ELSE D
 14 UP 2 = IF F8 2C8 C! ELSE DUP 4 2
 15 C8 C! ENDIF ENDIF ENDIF DROP
 16 CHRST C@ CHBAS C! ;
 17
 18 : STACKON   (  HES MOD 12jun82 )
 19   ' SSK      CFA ' ABORT 6 + !
 1A   ' SSK      CFA ' QUIT  A + !
 1B   ' FIX~ CFA '  ~  40 + ! ;
 1C
 1D -->
 1E
 1F

SCR # 22
  0 ( CONST. INFO. / CDUMP 3/3 )
  1 : STACKOFF
  2     ABORT1 @ ' ABORT 6 + !
  3     QUIT1  @ ' QUIT  A + !
  4     2C5 @ 2C8 C@ 0 GR.
  5     2C8 C! 2C5 ! ;
  6
  7 : STON  STACKON ;
  8 : STOF  STACKOFF ;
  9
  A ( HES V.2.0 82SEP9          )
  B :     (  FETCHES LETTERS AND ! )
  C     7E TEXT 10 0 DO DUP
  D     PAD 1+ I + C@ SWAP I + C!
  E     LOOP DROP PAD FIX~ QUIT ;
  F
 10 : CDUMP   ( adr1 adr2 --- )
 11        1 2FE C! 1+ SWAP DO
 12     I HH ."          " I 10 0 DO
 13     DUP I + C@ EMIT LOOP
 14     DROP SPACE 7E EMIT CR
 15     10 +LOOP 0 2FE C! ;
 16 : PATCH \ new  old --- JAP AUG82
 17     ~[COMPILE] ' CFA ~[COMPILE] '
 18     DUP >R ! ' ;S CFA R> 2+ ! ;
 19 \ Debugging ML rout  HES17OCT82
 1A CODE JMP \ INDIRECT JMP/ML DEBUG
 1B     BOT LDA, N STA, BOT 1+ LDA,
 1C     N 1+ STA,  N ) JMP,  C;
 1D CODE JSR \ INDIRECT JSR/ML DEBUG
 1E     XSAVE STX, ' JMP JSR, XSAVE
 1F     LDX, POP JMP,   C;   ;S

SCR # 23
  0 ( ONE DRIVE.DUPSCR/COPS1/2 )
  1 (   by anonymous/HES 23jun82 )
  2  0 VARIABLE EBLK ( ENDING BLK )
  3  0 VARIABLE SBLK ( START. BLK )
  4  0 VARIABLE PSBLK
  5 : DISP ( -> DEST ADR INFRE RAM )
  6  PSBLK @ B/BUF * HERE 20 + + ;
  7 : GTPAR ( SET UP DO AND PSBLK )
  8 EBLK @ SBLK @ 0 PSBLK ! ;
  9 : MVIN ( MOVE BLOCKS INTO RAM )
  A GTPAR DO I BLOCK DISP B/BUF
  B CMOVE 1 PSBLK +! LOOP ;
  C : MOVOT ( WRITE RAM TO DISK )
  D GTPAR OFFSET @ + SWAP OFFSET @ +
  E
  F SWAP DO I BUFFER DISP SWAP B/BUF
 10  CMOVE 1 PSBLK +! UPDATE FLUSH
 11 LOOP ;
 12 : DUPLICATE  ( STARTSCR--ENDSCR)
 13  1+ B/SCR * EBLK ! B/SCR *
 14 SBLK ! EBLK @ SBLK @ -
 15  FREE 20 - 400 /
 16     > IF ." TOO MANY " QUIT
 17 ENDIF CR MVIN
 18 ." INSERT DESTINATION DISK " CR
 19  ." RETURN TO CONTINUE " KEY
 1A DROP CR MOVOT ;
 1B
 1C
 1D
 1E
 1F  -->

SCR # 24
  0 ( COPIES          HES  2/2 )
  1 (        82JUN18 / 82AUG14 )
  2   FORTH DEFINITIONS
  3
  4
  5
  6 : CPST     CR ." ? Incorrect scr
  7 een range" CR QUIT ;
  8 : CPNT CR ." scr# " SWAP DUP .
  9      ."  --> " SWAP DUP . ;
  A : CPMP EBLK @ SBLK @ - DUP PSBLK
  B      @ + PSBLK ! 1+ 0  DO
  C      EBLK @ I - PSBLK @ I - CPNT
  D      COPY LOOP ;
  E : CPMD  EBLK @ SBLK @ - 1+ 0 DO
  F      SBLK @ I + PSBLK @ I + CPNT
 10       COPY LOOP  ;
 11 : COPIES PSBLK ! EBLK ! SBLK !
 12       EBLK @ SBLK @ < IF CPST
 13       THEN PSBLK @ SBLK @ > IF
 14       CPMP ELSE CPMD
 15       ENDIF CR  ; IMMEDIATE
 16
 17
 18
 19
 1A
 1B  ;S
 1C
 1D
 1E
 1F

SCR # 25
  0 ( FIND  V.1.1          1/2 )
  1 ( by R.Mansfield/COMPUTE!  )
  2 ( adapt.&enhanced HES 82aug7 )
  3   FORTH DEFINITIONS   HEX
  4
  5   0 VARIABLE 1STCHAR
  6
  7 : ?CONSOL   -2FE1 C@ 7 XOR ;
  8 : MATCH  ( addr1 addr2 N --- F )
  9  -DUP IF OVER + SWAP
  A        DO DUP C@ I C@ -
  B         IF 0= LEAVE ELSE 1+ THEN
  C        LOOP
  D       ELSE DROP 0= THEN ;
  E : CHECKIT ( addr --- F )
  F        PAD 1+ PAD C@ MATCH ;
 10  : HEADER
 11       CR ." Searching for "
 12       22 EMIT SPACE PAD 1+ PAD
 13       C@ TYPE 22 EMIT CR CR
 14       ." on scr #"     ;
 15 : MARKSTRING
 16        ( scr# addr --- scr# )
 17      OVER BLOCK - C/L / CR DUP
 18      CR CR ." Found on LINE#"
 19      CR CR . SPACE OVER .LINE
 1A      CR CR CR ." scr#" ;
 1B : ?STCK    DEPTH 2 < IF
 1C      0 59 PHYSOFF @ -
 1D      ENDIF      ;
 1E   -->
 1F

SCR # 26
  0 ( FIND                 2/2 )
  1
  2  CODE ?CHAR  ( addr --- addr F )
  3    1 # LDA, SETUP JSR,
  4    N )Y LDA, 1STCHAR CMP, 0=
  5    IF, 1 # LDA, PHA, 0 # LDA,
  6    PUSH JMP, THEN,
  7    0 # LDA, PHA, PUSH JMP, C;
  8
  9  : ONEBLK     ( scr# addr --- )
  A     DUP 400 + SWAP
  B       DO I ?CHAR
  C         IF I CHECKIT
  D           IF I MARKSTRING ENDIF
  E         ENDIF
  F       LOOP DROP ;
 10
 11  : GTWRD  22 WORD HERE DUP C@ 1+
 12          PAD SWAP CMOVE ;
 13  : FIND ( scr#1 scr#2 text --- )
 14      ?STCK GTWRD
 15      0 SCR ! PAD 1+ C@ 1STCHAR !
 16      HEADER 1+ SWAP
 17       DO I DUP DUP SPACE
 18          . BLOCK  ONEBLK
 19          ?CONSOL IF CR
 1A          LEAVE ENDIF
 1B       LOOP CR CR
 1C      ." Search ended" CR ;
 1D   ;S
 1E
 1F

SCR # 27
  0 ( VERS1.4S KERNEL ADD  1/1 )
  1 (        REZ / HES 15sep82 )
  2 ( Already in kernel, doc.only)
  3   FORTH DEFINITIONS  HEX
  4   4F LOAD
  5 : NOT 0= ;
  6 : U. 0  D. ;
  7 : CN CONSTANT ;
  8
  9 : (") R> DUP COUNT + >R COUNT ;
  A : " COMPILE (") 22 WORD HERE C@
  B     1+ ALLOT ; IMMEDIATE
  C : DEPTH EA SP@ - 2 / ;
  D : .S CR DEPTH IF EA EA DEPTH 2 -
  E      2* - SWAP DO I ? -2 +LOOP
  F      ELSE 1 MESSAGE
 10     ENDIF ;
 11 : SAVENFAs  #LINKS  0 DO
 12     1CFC 4 + I 4 * + @ 22 I 2*
 13     + +ORIGIN !     LOOP ;
 14  (              HES 82AUG21  )
 15  CODE V1.4S  ( DOSINI VECTOR )
 16     E4C0 JSR, ( APPL.HOOK   )
 17     0 # LDA, 52 STA, ( MARGN )
 18    27 # LDA, 53 STA, (   "   )
 19     6 # LDA, 2C5 STA, D0 # LDA,
 1A     2C6 STA, 93 # LDA, 2C8 STA,
 1B               ( SCREEN COLORS )
 1C                  RTS,  C;
 1D
 1E
 1F    ;S

SCR # 28
  0 (  FORTH-65 ASSEMBLER  1/6 )
  1              ( WFR-79JUN03 )
  2 HEX
  3
  4 VOCABULARY  ASSEMBLER  IMMEDIATE
  5 ' ASSEMBLER 2 + DUP 20 +ORIGIN !
  6                     VOC-LINK !
  7      ASSEMBLER  DEFINITIONS
  8  ( LOCATE EXISTING REGISTERS )
  9
  A FF CONSTANT  XSAVE     0FB  CONS
  B TANT  W    0FD  CONSTANT  UP
  C F8  CONSTANT  IP          F0  CO
  D NSTANT  N
  E
  F
 10 (  LOCATE EXISTING CODE PROCEEDU
 11 RES )
 12 '  (DO)  0E  +    CONSTANT  POP
 13    ( FROM COMPUTATION STACK *)
 14 '  (DO)  0C  +    CONSTANT  POPT
 15 WO
 16 '  LIT  13  +  CONSTANT  PUT
 17
 18 '  LIT  11  +  CONSTANT  PUSH
 19
 1A '  LIT  18  +  CONSTANT  NEXT
 1B
 1C '  EXECUTE  NFA  11  -  CONSTANT
 1D   SETUP
 1E     -->
 1F

SCR # 29
  0 (  FORTH-65 ASSEMBLER  2/6 )
  1              ( WFR-78OCT03 )
  2    0 VARIABLE INDEX -2 ALLOT
  3
  4 0909 , 1505 , 0115 , 8011 , 8009
  5  , 1D0D , 8019 , 8080 , 0080 , 1
  6 404 , 8014 , 8080 , 8080 , 1C0C
  7 , 801C , 2C80 ,
  8
  9    2 VARIABLE MODE
  A
  B  : .A 0 MODE ! ; : # 1 MODE ! ;
  C  : MEM 2 MODE ! ;
  D  : ,X 3 MODE ! ; : ,Y 4 MODE ! ;
  E  : X) 5 MODE ! ; : )Y 6 MODE ! ;
  F  : )  F MODE ! ;
 10  : BOT   ,X 0 ; ( ADDRESS BOTTOM
 11                    OF STACK    )
 12
 13  : SEC   ,X 2 ; ( ADDRESS SECOND
 14                 ITEM ON STACK  )
 15
 16  : RP)   ,X 101 ;
 17                 ( ADDRESS BOTTOM
 18                OF RETURN STACK )
 19
 1A
 1B
 1C
 1D    -->
 1E
 1F

SCR # 2A
  0 (  UPMODE,  CPU        3/6 )
  1              ( WFR-78OCT23 )
  2
  3
  4 : UPMODE   IF  MODE  C@  8  AND
  5  0=  IF  8  MODE +! ENDIF ENDIF
  6      1 MODE C@  0F AND  -DUP  IF
  7   0  DO  DUP + LOOP  ENDIF
  8      OVER  1+  @  AND  0=  ;
  9
  A
  B
  C : CPU   <BUILDS  C,  DOES>  C@
  D  C,  MEM  ;
  E      00 CPU BRK,   18 CPU CLC,
  F  D8 CPU CLD,  58 CPU CLI,
 10      B8 CPU CLV,   CA CPU DEX,
 11  88 CPU DEY,  E8 CPU INX,
 12      C8 CPU INY,   EA CPU NOP,
 13  48 CPU PHA,  08 CPU PHP,
 14      68 CPU PLA,   28 CPU PLP,
 15  40 CPU RTI,  60 CPU RTS,
 16      38 CPU SEC,   F8 CPU SED,
 17  78 CPU SEI,  AA CPU TAX,
 18      A8 CPU TAY,   BA CPU TSX,
 19  8A CPU TXA,  9A CPU TXS,
 1A      98 CPU TYA,
 1B
 1C -->
 1D
 1E
 1F

SCR # 2B
  0 (  M/CPU,   MULTI-MODE 4/6 )
  1 (     OP-CODES    WFR-79MAR26 )
  2 : M/CPU   <BUILDS  C,  ,  DOES>
  3
  4        DUP  1+  C@  80  AND  IF
  5  10  MODE  +!  ENDIF  OVER
  6        FF00  AND  UPMODE  UPMODE
  7   IF  MEM  CR  LATEST  ID.
  8        3  ERROR  ENDIF  C@  MODE
  9   C@
  A        INDEX  +  C@  +  C,  MODE
  B   C@  7  AND  IF  MODE  C@
  C        0F  AND  7  <  IF  C,  EL
  D SE  ,  ENDIF  ENDIF  MEM  ;
  E
  F
 10    1C6E 60 M/CPU ADC,  1C6E 20 M
 11 /CPU AND,  1C6E C0 M/CPU CMP,
 12    1C6E 40 M/CPU EOR,  1C6E A0 M
 13 /CPU LDA,  1C6E 00 M/CPU ORA,
 14    1C6E E0 M/CPU SBC,  1C6C 80 M
 15 /CPU STA,  0D0D 01 M/CPU ASL,
 16    0C0C C1 M/CPU DEC,  0C0C E1 M
 17 /CPU INC,  0D0D 41 M/CPU LSR,
 18    0D0D 21 M/CPU ROL,  0D0D 61 M
 19 /CPU ROR,  0414 81 M/CPU STX,
 1A    0486 E0 M/CPU CPX,  0486 C0 M
 1B /CPU CPY,  1496 A2 M/CPU LDX,
 1C    0C8E A0 M/CPU LDY,  048C 80 M
 1D /CPU STY,  0480 14 M/CPU JSR,
 1E    8480 40 M/CPU JMP,  0484 20 M
 1F /CPU BIT,       -->

SCR # 2C
  0 ( ASSEMBLER CONDITIONALS 5/6)
  1               ( WFR-79MAR26 )
  2 : BEGIN,     HERE  1  ;
  3         IMMEDIATE
  4 : UNTIL,    ?EXEC >R 1 ?PAIRS R>
  5  C, HERE 1+ - C, ; IMMEDIATE
  6 : IF,       C,  HERE  0  C,  2
  7 ;       IMMEDIATE
  8 : ENDIF,   ?EXEC  2  ?PAIRS  HER
  9 E  OVER  C@
  A  IF  SWAP  !  ELSE  OVER  1+  -
  B  SWAP  C!  ENDIF  ; IMMEDIATE
  C : ELSE,    2  ?PAIRS  HERE  1+
  D 1  JMP,
  E       SWAP  HERE  OVER  1+  -  S
  F WAP  C!  2  ;  IMMEDIATE
 10 : NOT    20  +  ;
 11      ( REVERSE ASSEMBLY TEST )
 12 90  CONSTANT  CS               (
 13  ASSEMBLE TEST FOR CARRY SET )
 14 D0  CONSTANT  0=             ( A
 15 SSEMBLER TEST FOR EQUAL ZERO )
 16 10  CONSTANT  0<          ( ASSE
 17 MBLE TEST FOR LESS THAN ZERO )
 18 90  CONSTANT  >=   ( ASSEMBLE TE
 19 ST FOR GREATER OR EQUAL ZERO )
 1A                     ( >= IS ONLY
 1B  CORRECT AFTER SUB, OR CMP,  )
 1C CR   -->
 1D
 1E
 1F

SCR # 2D
  0 (  USE OF ASSEMBLER    6/6 )
  1              ( WFR-79APR28 )
  2 : C;
  3     ( END OF CODE DEFINITION *)
  4    CURRENT  @  CONTEXT  !  ?EXEC
  5   ?CSP  SMUDGE  ; IMMEDIATE
  6
  7
  8 FORTH  DEFINITIONS
  9
  A : CODE      ( CREATE WORD AT ASS
  B EMBLY CODE LEVEL *)
  C       ?EXEC  CREATE  ~[COMPILE]
  D ASSEMBLER
  E       ASSEMBLER  MEM  !CSP  ;
  F    IMMEDIATE
 10 DECIMAL   ;S    ( TILL figFORTH
 11 IS UP )
 12 '  ASSEMBLER  CFA    '  ;CODE  8
 13   +  !  ( OVER-WRITE SMUDGE )
 14 FORTH  DEFINITIONS  DECIMAL
 15 ;S
 16 LATEST  12  +ORIGIN  !  ( TOP NF
 17 A )
 18 HERE    28  +ORIGIN  !  ( FENCE
 19 )
 1A HERE    30  +ORIGIN  !  ( DP )
 1B
 1C '  ASSEMBLER  6  +    32  +ORIGI
 1D N  !  ( VOC-LINK )
 1E HERE  FENCE  !   ;S
 1F

SCR # 2E
  0 (  compile assembler   1/1 )
  1    and editor  SRC 7/6/80   )
  2 BASE  @  ( PRESERVE THE RADIX )
  3
  4 DECIMAL  31  WIDTH  !
  5
  6 HEX 28 LOAD ( ASSEMBLER )
  7
  8 HEX 2F LOAD ( DECUS FORTH ADDS)
  9
  A HEX 27 LOAD ( VERS 1.4S KERNEL )
  B
  C HEX 30 LOAD   ( EDITOR & OTHER
  D                     WORDS  )
  E FORTH  DEFINITIONS
  F
 10 25 CONSTANT LPWORDS
 11
 12 27 CONSTANT FORMAT DECIMAL
 13
 14 LATEST 12 +ORIGIN ! ( TOP NFA )
 15
 16 HERE  28 +ORIGIN ! ( FENCE )
 17
 18 HERE    30  +ORIGIN  !  ( DP )
 19
 1A HERE  FENCE  !
 1B
 1C 1 WARNING ! ( DISK WARNINGS )
 1D
 1E : TASK  ;  BASE !    ;S
 1F

SCR # 2F
  0 (  DECUS/FORTH MODS    1/1 )
  1
  2 : 1+! 1 SWAP +! ; : 1- 1 - ;
  3
  4 : 0SET 0 SWAP ! ;
  5
  6 : HD DUP 0A < IF 30 ELSE 37
  7   ENDIF + EMIT ;
  8 : CHH DUP 0F0 AND 10 / HD 0F AND
  9   HD ;
  A : CH? C@ CHH ;
  B
  C : HH DUP 0FF00 AND 100 / 0FF AND
  D   CHH  CHH  ;
  E : H? @ HH ;
  F
 10
 11 : BDUMP 1+ SWAP DO I HH ." : " I
 12   8 0 DO DUP I + CH? SPACE
 13   LOOP  DROP ." \" CR 8 +LOOP ;
 14
 15 : TBL <BUILDS DOES> ;
 16 : ALLOC DUP + ALLOT ; ( FOR RAM
 17 BASED SYSTEMS,)
 18 : ARRAY <BUILDS ALLOC DOES> ;
 19
 1A  ;S
 1B
 1C
 1D
 1E
 1F

SCR # 30
  0 ( FULL UTILITY LOAD REV H HES )
  1     FORTH DEFINITIONS  HEX
  2 ( VLIST patches   HES17OCT82  )
  3   : v1  ( patch beginning )
  4       1 2FE C! ;
  5   : v2  ( patch SPACE after ID.)
  6       55 @ D < IF D 55 ! ELSE 55
  7       @ 1A <  IF 1A 55 ! ELSE CR
  8       THEN THEN ;
  9   : v3  ( patch last CR )
  A       CR 0 2FE C! ;
  B  ' v1  CFA ' VLIST 6 + !
  C  ' DUP CFA ' VLIST 55 + !
  D  ' v2  CFA ' VLIST 95 + !
  E  ' v3  CFA ' VLIST 9B + !
  F  800 ' DR1 2 + ! ( FX DR1 - 810)
 10    HEX 4C LOAD ( VAR/VALUE )
 11    HEX 4A LOAD ( PICK/ROLL )
 12    HEX 45 LOAD ( CASE      )
 13    HEX 46 LOAD ( CHRSET    )
 14    HEX 4B LOAD ( FIG 79    )
 15    HEX 31 LOAD ( CIO/GRAPH )
 16    HEX 36 LOAD ( PON/POFF  )
 17    HEX 37 LOAD ( RS 232C   )
 18    HEX 39 LOAD ( DISPLLST  )
 19    HEX 3B LOAD ( DRIVE LINK)
 1A    HEX 10 LOAD ( EDITOR    )
 1B      FORTH DEFINITIONS
 1C   NOVERIFY GO 1 CHR       ;S
 1D
 1E
 1F

SCR # 31
  0 ( fig-FORTH 1.4S MODS  1/1 )
  1 (             HES 82JUN17  )
  2    FORTH DEFINITIONS  HEX
  3 : BELL C0 0 DO 8 D01F C! 6 0 DO
  4           LOOP 0 D01F C! 6 0 DO
  5           LOOP LOOP ;
  6   : BINARY  2 BASE ! ;
  7   : BIN   BINARY ;   HEX
  8   : OCTAL 8 BASE ! ;
  9   : OCT OCTAL ;  HEX
  A
  B   : TASK  <BUILDS DOES> ;
  C
  D   : MSBYTE 0 100 U/ SWAP DROP ;
  E   : LSBYTE FF AND ;
  F   : MSB MSBYTE ; : LSB LSBYTE ;
 10   : ><    DUP LSBYTE 100 * SWAP
 11           MSBYTE + ;
 12 CR ." CIO CALLS" CR    32 LOAD
 13 CR ." OS/HARDWARE" CR  33 LOAD
 14 CR ." GRAPH/SOUND" CR  34 LOAD
 15
 16   FORTH DEFINITIONS
 17 : THERE  MEMTOP @ ;
 18 : FREE THERE HERE - ;
 19
 1A ;S
 1B
 1C
 1D
 1E
 1F

SCR # 32
  0 ( CIO CALL ROUTINES )
  1
  2 340 VARIABLE IOC 0 VARIABLE IOB
  3
  4 : IOCB 7 MIN 0 MAX 10 * DUP IOB
  5 ! 340 + IOC ! ;
  6 : .IOC <BUILDS , DOES> @ IOC @ +
  7  ;
  8 1 .IOC ICDNO 2 .IOC ICCOM 3 .IOC
  9  ICSTA
  A 4 .IOC ICBAL 6 .IOC ICPTL
  B
  C 8 .IOC ICBLL A .IOC I1CAX B .IOC
  D  I2CAX
  E CODE CIO TXA, PHA, IOB LDX, E456
  F  JSR, PLA, TAX, NEXT JMP, C;
 10 CODE Get XSAVE STX, IOB LDX, E45
 11 6 JSR,
 12 XSAVE LDX, PHA, 0 # LDA, PUSH JM
 13 P, C;
 14 : GET 7 ICCOM C! Get ;
 15
 16 : CLOSE 0C ICCOM C! CIO ;
 17
 18 : OPEN 3 ICCOM C! ICBAL ! I1CAX
 19 C! I2CAX C! CIO ;
 1A CODE ACIO XSAVE STX, BOT LDA, IO
 1B B LDX, E456 JSR,
 1C XSAVE LDX, POP JMP, C;
 1D
 1E ;S
 1F

SCR # 33
  0 ( OS & HDW CONSTANTS   1/1 )
  1   FORTH DEFINITIONS    HEX
  2 D200 CN F1AUD D201 CN C1AUD
  3
  4 D202 CN F2AUD D203 CN C2AUD
  5
  6 D204 CN F3AUD D205 CN C3AUD
  7
  8 D206 CN F4AUD D207 CN C4AUD
  9
  A D20F CN SKCTL D208 CN AUDCTL
  B
  C  230 CN DLST   22F CN DMACTL
  D
  E   14 CN RTCLK  2F0 CN CRSINH
  F
 10  2F4 CN CHBAS  2C4 CN COL0
 11
 12  2C5 CN COL1   2C6 CN COL2
 13
 14  2C7 CN COL3   2C8 CN COL4
 15
 16 D01F CN CONSOL 2FC CN CH
 17
 18  2BF CN BOTSC   52 CN LMARGN
 19
 1A 2FB CN ATACHR  2E5 CN MEMTOP
 1B
 1C  4D CN ATRACT   4E CN DRKMSK
 1D
 1E  4F CN COLRSH D40A CN WSYNC
 1F   ;S

SCR # 34
  0 ( COLLEEN GRAPHICS     1/2 )
  1
  2 3A53 VARIABLE S: 1 VARIABLE COLO
  3 RC 0 VARIABLE Qbase
  4 : PBASE Qbase @ ;
  5 : GR. 1 IOCB CLOSE 0 ICBLL ! DUP
  6  F AND SWAP
  7 30 AND 10 XOR 0C + S: OPEN MEMTO
  8 P @ 1 + F800 AND 800 -
  9 DUP Qbase ! 17F + MEMTOP ! ; : P
  A OS. 54 C! 55 ! ;
  B 0 GR. : LOC. POS. GET ;
  C : C. DUP COLORC ! ATACHR C! ;
  D : SPB  HIMEM @ F800 AND 800 -
  E    DUP Qbase ! 17F + HIMEM ! ;
  F
 10 : PUT 0B ICCOM C! ACIO ;
 11
 12 : PL. POS. COLORC @ PUT ;
 13   2FD CN FILDAT
 14 : SE. SWAP 10 * + SWAP 2C4 + C!
 15 ; : DR.  POS. 11 ICCOM C! COLORC
 16          C@ DUP ATACHR C! FILDAT
 17          C! CIO ;
 18 : GRAPHICS GR. ; : PLOT PL. ;
 19 : LOCATE LOC. ;
 1A : SETCOLOR SE. ; : COLOR C. ;
 1B : POSITION POS. ; : DRAWTO DR. ;
 1C  : CLEAR 0 0 POS. 7D PUT ;
 1D  : XIO18 DUP FILDAT C! ATACHR C!
 1E          12 ICCOM C! CIO ;
 1F  -->

SCR # 35
  0 ( SOUND CONTROL / P/M  2/2 )
  1
  2 : SOUND 3 D20F C! 0 D208 C! SWAP
  3
  4 10 * + 100 * + SWAP 2 * D200 + !
  5  ;
  6 : PADDLE 270 + C@ ;
  7       : PTRIG 27C + C@ ;
  8 : STICK 278 + C@ ;
  9       : STRIG 284 + C@ ;
  A : RND D20A C@ ;
  B    (   22F CONSTANT DMACTL )
  C D01D CONSTANT GRACTL
  D       D407 CONSTANT PMBASE
  E D01B CONSTANT PRIOR
  F       D016 CONSTANT VDELAY
 10  2C0 CONSTANT COLPM
 11        26F CONSTANT GPRIOR
 12 PBASE 1 - HIMEM !
 13
 14 : PLAYER Qbase 1+ C@ PMBASE C! 3
 15         GRACTL C! 2 - IF 1C
 16   ELSE 0C ENDIF DMACTL @ E3 AND
 17 OR      DMACTL C! ;
 18 : HPOS! D000 + C! ;
 19         ( H-posn plyr# -> )
 1A : SIZE! D008 + C! ;
 1B         ( size-code plyr# -> )
 1C : COLPM! COLPM + C! ;
 1D         ( color plyr# -> )
 1E : NOPLY GRACTL 0SET D000 11 0 FI
 1F LL      ; ;S

SCR # 36
  0 ( PON/POFF             1/1 )
  1 (              JDS 18jun85 )
  2   FORTH DEFINITIONS
  3    E406 @ 1+ VARIABLE EOUTC
  4    E436 @ 1+ VARIABLE POUTC
  5         0 VARIABLE ECHR
  6         0 VARIABLE EVTBL F ALLOT
  7
  8 ( routine to send character )
  9 ( to both P: & E:           )
  A  CODE PPUTC POUTC ) JMP, RTS,
  B      C;
  C  CODE EPUTC
  D    ECHR STA, PHA, TXA, PHA,
  E    ECHR LDA, ' PPUTC JSR, PLA,
  F    TAX, PLA, EOUTC ) JMP, C;
 10  FORTH DEFINITIONS
 11
 12  : PON  E406 @ 1+ EOUTC !
 13         E436 @ 1+ POUTC !
 14       E400 ' EVTBL F CMOVE
 15       ' EPUTC 1- ' EVTBL 6 + !
 16       ' EVTBL 321 ! ;
 17  : POFF  E400 321 ! ;
 18
 19 ;S
 1A
 1B NOTE: the subroutine EPUTC will
 1C       drive decompiler crazy,
 1D       since it cannot find its
 1E       end.
 1F

SCR # 37
  0 ( RS232 SUPPORT        1/2 )
  1
  2 CODE SIO    XSAVE STX, BOT LDA,
  3 E459 JSR, ( SIOV) XSAVE LDX, BOT
  4   STA, BOT 1+ STY, NEXT JMP, C;
  5
  6 : SERR DUP 0< IF 0 100 U/ BASE @
  7         DECIMAL ." SIO ERROR "
  8   . BASE ! QUIT ELSE DROP THEN ;
  9
  A CODE DORL    XSAVE STX, 506 JSR,
  B         HERE 8 + JSR, XSAVE LDX,
  C         NEXT JMP, 0C ) JMP, C;
  D
  E : GETR: HERE 2E7 ! ( SET MEMLO )
  F             FLUSH EMPTY-BUFFERS
 10  150  300 !  ( DDEVIC,DUNIT)
 11  403F 302 !  ( ? CMD,EXPCT DATA)
 12  5    306 C! ( TIMEOUT)
 13  500  304 !  ( BUFFER ADDR)
 14  0C   308 !  ( LENGTH )
 15  0    30A !  ( AUXES )
 16  0 SIO SERR ( ERRORS?)
 17 500 300 0C CMOVE 0 SIO SERR DORL
 18  ( RUN RELOCATOR ) 2E7 @ HERE -
 19  ALLOT HERE FENCE ! ;
 1A
 1B  : R1: " R1: " DROP ;
 1C
 1D  ;S  ( other words not needed )
 1E
 1F   -->

SCR # 38
  0 ( RS232                2/2 )
  1
  2
  3
  4 : R1OPEN 0 8 R1: OPEN ICSTA CH?
  5 ;
  6 : RYPE -DUP IF 1 IOCB 0B ICCOM C
  7 !       ICBLL ! ICBAL ! CIO
  8   20 ICCOM C! 0 I1CAX ! CIO ELSE
  9         DROP THEN ;
  A : CRR 0A9B SP@ 2 RYPE DROP ;
  B       : REMIT SP@ 1 RYPE DROP ;
  C : SET9600 1 IOCB 0E I1CAX ! 24
  D         ICCOM C! R1: ICBAL !
  E   CIO ICSTA CH? ;
  F
 10 : LINER SCR @ (LINE) -TRAILING
 11         RYPE ;
 12 100 VARIABLE LSPD
 13
 14 : LISTR DUP SCR ! CRR " SCR#" RY
 15 PE      0 <# #S #> RYPE CRR 10 0
 16   DO I 0 <# # # #> RYPE I LINER
 17         CRR LOOP ;
 18  ;S
 19
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 39
  0 ( DISPLAY LIST STUFF   1/1 )
  1   HEX
  2 0 VARIABLE 3BYT 0 VARIABLE DLADR
  3
  4 : DINST DLADR @ C@ DUP 0F AND IF
  5
  6 DUP 0F AND 1 = IF 40 AND IF ." J
  7 VB "
  8 ELSE ." JMP " ENDIF DLADR 1+! DL
  9 ADR  @
  A @ DUP DLADR ! HH 3BYT 0SET ELSE
  B DUP 0F AND
  C 8 OVER < IF ." MAP" ELSE ." CHR"
  D
  E ENDIF 7 AND . DUP 10 AND IF ." H
  F "
 10 THEN DUP 20 AND IF ." V" THEN DU
 11 P
 12 80 AND IF ." I" ENDIF DUP 0B0
 13
 14 AND IF DUP 40 AND IF ." ," ENDIF
 15
 16 ENDIF 40 AND IF 3 DLADR @ 1+ H?
 17 ELSE
 18 1 ENDIF 3BYT ! ENDIF ELSE ." BLK
 19 "
 1A DUP 80 AND IF ." I," ENDIF 70
 1B
 1C AND 10 / . 1 3BYT ! ENDIF CR
 1D
 1E 3BYT @ DLADR +! ; ;S
 1F

SCR # 3A
  0 ( PLAYER/MISS.STUFF-RZ 1/1 )
  1 HEX 0 VARIABLE 0VP 64 VARIABLE
  2 0HP 0 VARIABLE 0VPOLD
  3 ( : SPB  HIMEM @ 1+  F800 AND
  4     800 - DUP Qbase ! 17F +
  5               HIMEM ! ; )
  6 : GETPS  0VP  ! ROT BLOCK ROT +
  7     Qbase @ 400 + 0VP  @ + ROT
  8     CMOVE ;
  9 : SPLAY  0 0 HPOS! 7 GR. SPB
  A   Qbase 1+ C@  PMBASE C!
  B   2A 0 COLPM!
  C   0 0 SIZE!   3E D400 C!
  D   3E DMACTL C! 3 GRACTL C!
  E   1C 20 8 64 GETPS  ;
  F  : CLRPM  Qbase @ 800 ERASE ;
 10 : MOVEH   0 STICK F XOR C AND
 11    DUP IF 2 / 3 - ENDIF 0HP @
 12    + DUP 0HP ! 0 HPOS!  ;
 13 : VPOS!  0VPOLD @ 9C00 + DUP
 14   9800 8 CMOVE  8 ERASE  9C00 +
 15   9800 SWAP 8 CMOVE ;
 16 : MOVEV        0 STICK F XOR
 17   3 AND   DUP IF 2 * 3 - ENDIF
 18   -DUP IF 0VP @ DUP 0VPOLD ! +
 19   DUP 0VP !  VPOS! ENDIF ;
 1A : RUNIT BEGIN   MOVEH MOVEV
 1B     2FC C@ FF = NOT END ;
 1C : B/H DUP HEX ." H
 1D EX =" . DECIMAL ." DEC.=" . BIN
 1E QUIT ;          HEX     ;S
 1F

SCR # 3B
  0 \ 3B  DRIVE LINK             1/1
  1  : r/w
  2      301 C@ 1 = IF @ ELSE DROP
  3      0 ENDIF ;
  4
  5  : UNLINK   EMPTY-BUFFERS DR0
  6      ' r/w CFA ' R/W B1 + ! ;
  7
  8  : LINK     EMPTY-BUFFERS DR0
  9      ' @   CFA ' R/W B1 + ! ;
  A   1A VAR  TMPHYS
  B
  C \ SETS BOTH DRIVES
  D
  E : SETPHYS     1FB5 C@ 1FCE C@
  F      100 * + TO TMPHYS DUP
 10   LSB 1FB5 C! MSB 1FCE C! DR0 ;
 11  : RESPHYS     TMPHYS @ DUP LSB
 12      1FB5 C! MSB 1FCE C! DR0 ;
 13 ;S
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 3C
  0 \ scr# 3C  empty block       1/1
  1  ;S
  2
  3
  4
  5
  6
  7
  8
  9
  A
  B
  C
  D
  E
  F
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 3D
  0 ( LINE PRINTER WORDS   1/2 )
  1 ( 0181 SRC ) 3A50 VARIABLE P:
  2  CODE PCIO XSAVE STX, 70 # LDX,
  3 E456 JSR, XSAVE LDX,  TYA, PHA,
  4 PUSH JMP, C; 0 VARIABLE LPCNT
  5 : PERR? DUP 0< IF FF AND
  6 ." P: ERROR "   ERROR THEN
  7  DROP ;
  8 : LPOPEN 3 3B2 C! P: 3B4 ! 2 3B8
  9  ! 8 3BA ! PCIO PERR? ;
  A : LYP1 3B8 ! 3B4 ! 0B 3B2 C! PCI
  B O PERR? ; : LPEMIT SP@ 1 LYP1 DR
  C OP ; : LPCR 9B LPEMIT 1 LPCNT +!
  D  ; : LYPE DUP IF DUP 50 > IF
  E  1 LPCNT +! THEN LYP1 ELSE DROP
  F DROP THEN 20 SP@ 1 LYP1 DROP ;
 10 : CRLP LPCR LPCNT @ 3D > IF
 11 LPCR LPCR LPCR LPCR 0 LPCNT !
 12 THEN ;
 13 : FFLP CRLP BEGIN LPCNT @ WHILE
 14 CRLP REPEAT ;
 15 : SHRINK 1B LPEMIT 14 LPEMIT
 16  CRLP ; : EXPAND 1B LPEMIT 13
 17  LPEMIT CRLP ;
 18 : .CLP 0 <# # # #> LYPE ;
 19 : .LP 0 <# #S #>  LYPE ;
 1A : LINELP DUP .CLP SCR @ (LINE)
 1B  -TRAILING 1 MAX LYPE CRLP   ;
 1C 4353 VARIABLE SCR# 2052 , 2023 ,
 1D  : LISTLP DUP SCR ! SCR# 6 LYPE
 1E .LP LPCR B/SCR B/BUF * C/L /
 1F 0 DO I LINELP LOOP ; -->

SCR # 3E
  0 ( LINE PRINTER WORDS   2/2 )
  1 ( 1/27/81  SRC )
  2 : LPSPC 0 DO 20 LPEMIT LOOP ;
  3 : SHOWLP 1+ SWAP C/L 20 = IF
  4   DO CRLP
  5   SCR# 6 LYPE I .LP
  6   1F LPSPC SCR# 6 LYPE I 1+
  7   .LP CRLP
  8   I 20 0 DO DUP SCR ! I .CLP
  9   I SCR @ (LINE) LYPE
  A   5 LPSPC
  B   DUP 1+ SCR ! I LINELP LOOP
  C   DROP 2 +LOOP
  D   ELSE DO CRLP    I LISTLP LOOP
  E   ENDIF FFLP ;
  F
 10 : LPINDEX 1+ SWAP DO I .LP
 11 0 I (LINE) -TRAILING LYPE LPCR
 12 LOOP ;
 13
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C                              ;S
 1D
 1E
 1F

SCR # 3F
  0 \ pns TRANSLATOR HES 16SEP82 1/1
  1 \ moves screens from drive 2 to
  2 \ same place on drive 1.
  3   FORTH DEFINITIONS  HEX
  4 \ Expects byte on TOS
  5  : translate    ( n --- n )
  6     DUP  0= IF 20 + \  
  7       ELSE
  8     DUP DUP     \ lwr case
  9      60 > SWAP 7B < AND IF
  A         20 - ENDIF ENDIF ;
  B
  C \ Expects buffer address on TOS
  D \
  E  : trnsblk     ( adr1 --- )
  F      3FF 0 DO DUP I + DUP C@
 10    translate SWAP C! LOOP DROP ;
 11
 12 \ Expexts source destin scr TOS
 13  : PNSCOPY      ( n1 n2 --- )
 14    SWAP BLOCK DUP trnsblk SWAP
 15   BLOCK 400 CMOVE UPDATE FLUSH ;
 16
 17
 18  EDITOR DEFINITIONS
 19
 1A  : PNS      EDLQ SCR @ BLOCK
 1B         trnsblk UPDATE EDT  UL ;
 1C
 1D  FORTH DEFINITIONS
 1E  : DR2  800 + ;
 1F    ;S

SCR # 40
  0 ( FORMATTED LIST PROG. 1/5 )
  1
  2  VOCABULARY FORMY   IMMEDIATE
  3  FORMY   DEFINITIONS
  4   BASE @ OCTAL 40 CN SPACBYT 54
  5 CN COMCHR : IARRAY 0 VARIABLE -2
  6  ALLOT ; : 0> DUP 0= IF DROP  0
  7 ELSE  0< 0= THEN ;
  8 0 VARIABLE INDENT 106 CN FCONS
  9 111 CN ICONS 0 VARIABLE TLFLG
  A 0 VARIABLE KERKNT 100 CN MAXLIN
  B : NXSPACE >R 1+ >R 0   R> R> DO
  C SPACBYT I C@ = IF DROP I LEAVE
  D THEN LOOP ; : NXNSPACE >R 1+ >R
  E 0 R> R> DO SPACBYT I C@ = 0= IF
  F
 10  DROP I LEAVE THEN LOOP ; : GTNX
 11 WD DUP IF + OVER SWAP NXSPACE
 12 ELSE DROP THEN DUP IF OVER SWAP
 13 NXNSPACE DUP IF OVER OVER
 14 NXSPACE DUP IF OVER - ELSE DROP
 15 OVER OVER - 1+ THEN ELSE DUP
 16 THEN ELSE DUP THEN ; : TORLCR TL
 17 FLG @ IF CRLP ELSE CR THEN KERKN
 18 T 0SET ; : TORLY DUP 1+ KERKNT +
 19 ! TLFLG @ IF LYPE ELSE TYPE SPAC
 1A E THEN ; : DOIND INDENT @ 0> IF
 1B INDENT @ 0 DO 0 0 TORLY LOOP THE
 1C N ; : PRWORD DUP 1+ KERKNT @ + M
 1D AXLIN > IF TORLCR THEN KERKNT @
 1E 0= IF DOIND THEN OVER OVER TORLY
 1F  ; : 1SET 1 SWAP ! ;  -->

SCR # 41
  0 ( FORMATTED LIST PROG. 2/5 )
  1 : ( 51 WORD 6 ALLOT ;
  2 : IA IARRAY ; IA L1G 10  , ( :)
  3 ( CODE) ( ,CODE) ( SUBROUTINE)
  4  ( IA) ( IARRAY) ( LABEL) ( TBL)
  5  IA L2G 2 , ( ;) ( C;)
  6  IA L3G 2 , ( NXT,) ( NEXT,) IA
  7 L4G 6 , ( IF) ( DO) ( IF,)
  8   ( CASE) ( BEGIN) ( BEGIN,) IA
  9 L5G 3 , ( ELSE,) ( ELSE)
  A   ( WHILE) IA L6G 16 , ( THEN,)
  B ( THEN) ( END,) ( END) ( SOB,)
  C ( BACK) ( UNTIL) ( AGAIN) ( REPE
  D AT) ( ENDIF,)
  E   ( UNTIL,) ( LOOP) ( +LOOP) ( E
  F NDIF) IA L7G 7 , ( CONSTANT)
 10 ( IR)   ( VARIABLE)       ( CN)
 11 ( ARRAY) ( INTEGER) ( ORCON)
 12    IA L8G 1 , ( () IA L9G 3 , (
 13 LD,) ( ST,) ( LOAD)
 14 IA LAG 1 , ( ;CODE)
 15
 16 : CMPWORD DUP >R C@ OVER = R>
 17 SWAP IF >R OVER
 18   R> SWAP OVER DUP C@ DUP 4 > IF
 19  DROP 4 THEN 0
 1A   DO I OVER + 1+ C@ >R OVER R>
 1B SWAP I + C@
 1C   = 0= IF 0 LEAVE THEN LOOP
 1D
 1E   0= IF DROP DROP 0 THEN ELSE 0
 1F THEN ;   -->

SCR # 42
  0 ( FORMATTED LIST PROG. 3/5 )
  1 : GSCAN DUP @ SWAP 2+ SWAP 0 DO
  2 CMPWORD IF LEAVE
  3   0 ELSE 6 + THEN LOOP IF 0 ELSE
  4  DROP 1 THEN ;
  5 : NEWCR KERKNT @ IF TORLCR THEN
  6 ;
  7 : DUPBC OVER >R >R OVER R> SWAP
  8 R> ;
  9 : FINDCHAR SWAP >R SWAP 1+ R>
  A DO DUP I C@ =
  B   IF DROP I LEAVE 0 THEN LOOP IF
  C  0 THEN ;
  D : PRNEWL PRWORD TORLCR ;
  E : >= OVER OVER = IF DROP DROP
  F 1 ELSE > THEN ;   -->
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C
 1D
 1E
 1F

SCR # 43
  0 ( FORMATTED LIST PROG. 4/5 )
  1 : EL1G NEWCR INDENT 0SET PRWORD
  2 GTNXWD PRNEWL
  3   10 INDENT ! ;
  4 : EL2G NEWCR PRNEWL INDENT 0SET
  5 ;
  6 : EL3G NEWCR PRNEWL ;
  7
  8 : EL4G NEWCR PRNEWL 2 INDENT +!
  9 ;
  A : EL5G NEWCR -2 INDENT +! PRNEWL
  B  2 INDENT +! ;
  C : EL6G NEWCR -2 INDENT +! PRNEWL
  D  ;
  E : EL7G PRWORD GTNXWD PRNEWL INDE
  F NT 0SET ;
 10 : EL8G DUPBC 51 FINDCHAR DUP
 11
 12   IF SWAP DROP OVER - 1+ PRNEWL
 13 ELSE DROP PRWORD THEN ;
 14 : EL9G PRNEWL ;
 15
 16 : ELAG NEWCR 10 INDENT ! PRNEWL
 17 ;
 18 : ASSWRD DUP 4 >= IF OVER OVER +
 19  1- C@ COMCHR = IF
 1A    OVER DUP C@ ICONS =  SWAP 1+
 1B C@ FCONS = AND
 1C   IF 2 ELSE 1 THEN ELSE 0 THEN E
 1D LSE 0 THEN ;
 1E -->
 1F

SCR # 44
  0 ( FORMATTED LIST PROG. 5/5 )
  1 : PRCWRD L1G GSCAN IF EL1G ELSE
  2 L2G GSCAN IF EL2G ELSE
  3   L3G GSCAN IF EL3G ELSE L4G GSC
  4 AN IF EL4G ELSE L5G GSCAN
  5   IF EL5G ELSE L6G GSCAN IF EL6G
  6  ELSE L7G GSCAN IF EL7G
  7   ELSE L8G GSCAN IF EL8G ELSE L9
  8 G GSCAN IF EL9G ELSE
  9   LAG GSCAN IF ELAG ELSE ASSWRD
  A IF ASSWRD 2 =
  B   IF EL4G ELSE PRNEWL THEN ELSE
  C PRWORD THEN THEN THEN THEN THEN
  D THEN THEN THEN THEN THEN THEN ;
  E : FORLST TORLCR DUP TLFLG @ IF L
  F ISTLP ELSE
 10  TORLCR LIST THEN TORLCR TORLCR
 11 DUP BLK !
 12   BLOCK DUP 1777 + SWAP KERKNT 0
 13 SET INDENT 0SET 0 BEGIN GTNXWD
 14   DUP IF PRCWRD THEN DUP 0= END
 15 DROP DROP DROP BLK 0SET ;
 16 : ASTER TORLCR 40 0 DO 52 SP@ 1
 17 TORLY DROP LOOP TORLCR ;
 18 : FORSHW 1+ OVER DO ASTER I FORL
 19 ST TORLCR LOOP DROP ;
 1A FORTH DEFINITIONS : FLST FORMY T
 1B LFLG 0SET FORLST ; : FLSTLP FORM
 1C Y TLFLG 1SET FORLST FFLP ; : FSH
 1D W FORMY TLFLG 0SET FORSHW ; : FS
 1E HWLP FORMY  TLFLG 1SET FORSHW
 1F FFLP  ;         ;S

SCR # 45
  0 ( CASE                 1/1 )
  1    FORTH DEFINITIONS   HEX
  2  : CASE  ?COMP CSP @ !CSP 4 ;
  3         IMMEDIATE
  4  : OF   4 ?PAIRS COMPILE OVER
  5     COMPILE = COMPILE 0BRANCH
  6     HERE 0 , COMPILE DROP 5 ;
  7         IMMEDIATE
  8  : ENDOF  5 ?PAIRS COMPILE
  9     BRANCH HERE 0 , SWAP 2
  A     ~[COMPILE] ENDIF 4 ;
  B         IMMEDIATE
  C  : ENDCASE 4 ?PAIRS COMPILE DROP
  D     BEGIN SP@ CSP @ = 0= WHILE
  E     2 ~[COMPILE] ENDIF REPEAT
  F     CSP ! ;   IMMEDIATE
 10
 11   ;S
 12
 13
 14
 15
 16
 17
 18
 19
 1A
 1B
 1C
 1D
 1E
 1F

Add new attachment

Only authorized users are allowed to upload new attachments.
« This page (revision-2) was last changed on 05-Apr-2010 22:11 by Carsten Strotmann