QS-Forth Screens#


SCR # 1 
  0    FORTH DEFINITIONS HEX
  1 
  2  : L-ON  0780 ' CREATE ! ;
  3  : L-OFF ' FIRST CFA
  4          ' CREATE ! ; DECIMAL
  5  : LOCATE ~[COMPILE] ' DUP
  6         ~[ FENCE @ ] LITERAL >
  7    IF NFA 2 - @ DUP 0=
  8    IF    25 MESSAGE
  9    ELSE   DUP 0 <
 10    IF 5 MESSAGE QUIT ELSE LIST
 11    ENDIF ENDIF
 12    ELSE  9 MESSAGE ENDIF ;
 13 
 14  DECIMAL -->
 15 

SCR # 2 
  0  HEX
  1 
  2  : CASE: <BUILDS ] SMUDGE
  3          DOES> SWAP 2 * +
  4          @ EXECUTE ;
  5 
  6  6 USER S0  ( COMP STK ORG )
  7  8 USER R0  ( RET STK ORG )
  8 
  9 : UPDATE PREV @ @ 8000 OR PREV
 10     @ ! ;
 11 
 12 : DCX DECIMAL ;
 13 
 14   DECIMAL -->
 15 

SCR # 3 
  0  ( STACK WORDS )
  1 
  2  : .S ( PEEK AT STACK )
  3        S0 @  SP@ -  2 / 1 -
  4        IF SP@ 2 - S0 @  2 -
  5           DO I @ . -2 +LOOP
  6        ELSE ." STACK EMPTY "
  7        CR ENDIF ;
  8 
  9  : 2DUP OVER OVER ;
 10 
 11  : LOAD-ED     30 LOAD ;
 12  : LOAD-ASM    58 LOAD ;
 13  : LOAD-IO     6 LOAD ;
 14          DECIMAL -->
 15 

SCR # 4 
  0  ( TEXT LINE  )        HEX
  1 
  2 : TEXT ( TEXT --> PAD )
  3     HERE C/L 1+ BLANKS WORD HERE
  4     PAD C/L 1+ CMOVE ;
  5 
  6 : LINE  ( ADR OF LINE-->STK )
  7     DUP FFF0 AND 17 ?ERROR
  8     SCR @ (LINE) DROP ;
  9   : INVON FF 0668 C!
 10           FF 06BE C! ;
 11   : INVOF 7F 0668 C!
 12           7F 06BE C! ;
 13   : BELL  06BE C@ FF 06BE C!
 14       FD EMIT 06BE C!  ;
 15   INVOF   DECIMAL -->

SCR # 5 
  0  ( HDUMPER )   HEX
  1   : HXOT <# # # #> TYPE  ;
  2   : HPRT     C@ 7F AND DUP
  3        20 < IF DROP 2E THEN
  4  SPACE 1B EMIT EMIT SPACE ;
  5   : ADDR <# # # # # #> TYPE ;
  6   : DUMP ( ADDR CNT ) CR
  7       HEX 1 - 08 / 1+
  8        0 DO DUP 0 ADDR SPACE
  9      8 0 DO DUP I + C@ 0
 10        HXOT  SPACE  LOOP CR
 11           4 SPACES
 12    8 0 DO DUP I + HPRT LOOP
 13      08 + CR    LOOP DROP ;
 14   : U. 0 <# #S #> TYPE SPACE  ;
 15    DECIMAL    ;S

SCR # 6 
  0   FORTH DEFINITIONS
  1  ( CIO CALL CHEATER )  HEX
  2   ." I/O MODULE LOADING..." CR
  3   CREATE JSRCIO ( CALL TO )
  4                 ( CH #6   )
  5     B5 C, 00 C, ( LDA TOS )
  6     86 C, B5 C, ( STX XSAVE )
  7     A2 C, 60 C, ( LDX #$60  )
  8     20 C, C4 C, E4 C, ( JSR )
  9     A6 C, B5 C, ( LDX XSAVE )
 10     E8 C, E8 C, ( CLR STK  )
 11     4C C, DF C, 0A C, ( 0A  )
 12 
 13     SMUDGE
 14 
 15           DECIMAL -->

SCR # 7 
  0  ( IOCB CONTSTANTS  )    HEX
  1 
  2  60 VARIABLE IO#
  3 
  4  : IO#@ IO# @ + ;
  5 
  6  : CHANID 340 IO#@   ;
  7  : CDEV#  341 IO#@   ;
  8  : CCMD   342 IO#@   ;
  9  : CSTAT  343 IO#@   ;
 10  : BUFADR 344 IO#@   ;
 11  : BUFLEN 348 IO#@   ;
 12  : CAUX1  34A IO#@   ;
 13  : CAUX2  34B IO#@   ;
 14 
 15  DECIMAL -->

SCR # 8 
  0  ( IOCB COMMANDS )       HEX
  1 
  2  04 CONSTANT INOP
  3  08 CONSTANT OUTOP
  4 
  5  : #-> ( ASSIGNS I0CB # )
  6     10 *  DUP IO# !
  7           ' JSRCIO 5 +  C! ;
  8 
  9  0 VARIABLE "K" -2 ALLOT
 10     4B C, 3A C, 9B C,
 11 
 12  0 VARIABLE "S" -2 ALLOT
 13     53 C, 3A C, 9B C,
 14 
 15  DECIMAL -->

SCR # 9 
  0  ( IOCB CONT )
  1  HEX
  2  0 VARIABLE "P" -2 ALLOT
  3     50 C, 3A C, 9B C,
  4 
  5  0 VARIABLE "C" -2 ALLOT
  6     43 C, 3A C, 9B C,
  7 
  8  0 VARIABLE "E" -2 ALLOT
  9     45 C, 3A C, 9B C,
 10 
 11  : CKSTAT CSTAT C@ DUP 80 AND
 12      IF 7F AND 21 + DUP ?ERROR
 13         ELSE DROP ENDIF ;
 14                DECIMAL -->
 15 

SCR # 10 
  0  ( OPEN IOCB )
  1   HEX
  2  ( "K" INOP 0 I0CB# OPEN )
  3 
  4  : OPEN #->        ( IOCB# )
  5         03 CCMD C! ( OPEN CMD)
  6         CAUX2 C!   ( 0 USUAL )
  7         CAUX1 C!   ( IN/OUT  )
  8         BUFADR !   ( -> K:   )
  9         JSRCIO     ( SET TO 6)
 10         CKSTAT ;   ( ERROR?  )
 11 
 12 
 13           DECIMAL -->
 14 
 15 

SCR # 11 
  0  ( GET A CHAR TO STACK ) HEX
  1  ( GET ... ASCII TO STACK )
  2 
  3  : GET #->     0 ( DUMMY )
  4        07 CCMD C! ( GET CHAR )
  5        0  BUFADR ! ( 0 -> A  )
  6        JSRCIO  CKSTAT ;
  7 
  8  : PUT #->
  9        0B CCMD C! ( PUT CHAR )
 10        0 BUFADR ! ( 0-> A   )
 11        JSRCIO  CKSTAT DROP  ;
 12   HEX
 13  : CLOSE #->
 14          0C CCMD C! JSRCIO
 15          CKSTAT ; DECIMAL -->

SCR # 12 
  0  ( PRINTER WORDS )
  1 
  2  : PRON  4 CLOSE
  3      "P" OUTOP 0 4 OPEN ;
  4 
  5  : PROF 4 CLOSE
  6      "E" OUTOP 0 4 OPEN ;
  7 
  8          -->
  9 
 10 
 11 
 12 
 13 
 14 
 15 

SCR # 13 
  0  ( VOL,DIST,FREQ,VOICE, SND )
  1  HEX
  2   : SOUND 0232 C@ 07 AND
  3      D20F C!  0 D208 C!
  4      DUP 3 > IF
  5  ." ILLEGAL CHAN" ABORT ENDIF
  6     2 * D200 + >R >R 10 * OR
  7     EF AND
  8     100 * R>  OR R> ! ;
  9 
 10 
 11   : XSND D208 D200 DO
 12           0 I C! LOOP ;
 13   DECIMAL
 14   -->
 15 

SCR # 14 
  0  ." GRAPHICS LOADING..." CR
  1  ( ALL USE CH # 6 )
  2  : GRN 6 OPEN ;
  3  : GR.  ( MODE 7 SPLIT )
  4      6 CLOSE >R
  5      "S" OUTOP 16 OR R> GRN ;
  6 
  7  : GR.16 6 CLOSE >R "S"
  8      OUTOP R> GRN  ;  HEX
  9 
 10  : SETCOLOR  DUP 4 > IF
 11     ." ILLEGAL COLOR"
 12      . . .           ELSE
 13     02C4 + >R 10 * OR
 14       R>  C!         ENDIF ;
 15     DECIMAL -->

SCR # 15 
  0  ( PLOT DRAWTO ) HEX
  1  : CKER CSTAT C@ 8D = IF
  2            ." RANGE ERROR "
  3    QUIT ELSE CKSTAT ENDIF ;
  4 
  5  : DRAWTO ( Y,X,C ) 02FB C!
  6      54 C! 55 ! 6 #->
  7          11 CCMD C!  ( DRAW)
  8    0 BUFADR ! JSRCIO CKER ;
  9 
 10  : PLOT >R OVER OVER OVER
 11    OVER DUP 0= IF 2+ ENDIF 1 -
 12    5A C! 5B ! I DRAWTO R>
 13    DRAWTO ;
 14   DECIMAL -->
 15 

SCR # 16 
  0  ( POS.     GR."  ) HEX
  1  : POS. 54 C! 55 ! ;
  2 
  3  : GRTYPE -DUP IF OVER +
  4    SWAP DO I C@ 6 #-> 0B
  5    CCMD C! 0 BUFADR ! JSRCIO
  6    CKER DROP LOOP ELSE
  7     DROP ENDIF ;
  8  : GR(.") R COUNT DUP 1+ R>
  9    + >R GRTYPE ;
 10 
 11  : GR." 22 STATE @ IF COMPILE
 12    GR(.") WORD HERE C@ 1+
 13    ALLOT ELSE WORD HERE COUNT
 14    GRTYPE ENDIF ; IMMEDIATE
 15        DECIMAL ;S

SCR # 19 
  0 (ERROR MESSAGES )
  1 EMPTY STACK
  2 DICTIONARY FULL
  3 INCORRECT ADDRESS MODE
  4 NAME NOT UNIQUE
  5 LOCATE OUT OF RANGE
  6 DISK OUT OF RANGE
  7 FULL STACK
  8 DISK ERROR !!
  9 IN BOOT
 10 
 11 
 12 
 13 
 14 
 15  QS FORTH VER 1.0 3/27/81

SCR # 20 
  0 ( ERROR MESSAGES )
  1 COMPILATION ONLY, USE IN DEF
  2 EXECUTION ONLY
  3 CONDITIONALS NOT PAIRED
  4 INCOMPLETE DEFINITION
  5 IN PROTECTED DICTIONARY
  6 USE ONLY WHEN LOADING
  7 OFF CURRENT EDIT SCREEN
  8 
  9 NOT COMPILED FROM DISK
 10 # OPERAND > $FF
 11 ILLEGAL USE OF Z-PAGE
 12 ILLEGAL ADDR MODE
 13 
 14 
 15 

SCR # 21 
  0  ( IOCB ERRORS )
  1  BREAK ABORT
  2  IOCB OPEN
  3  NONEXISTENT DEVICE
  4  IOCB WRITE ONLY
  5  INVALID COMMAND
  6  DEVICE NOT OPEN
  7  BAD IOCB #
  8  IOCB READ ONLY ERROR
  9  EOF
 10  TRUNCATED RECORD
 11  DEVICE TIMEOUT
 12  DEVICE NOT ACKNOWLEDGE CMD
 13  SERIAL BUS FRAMING ERROR
 14  CURSOR OUT OF RANGE
 15  SERIAL BUS FRAME OVERRUN

SCR # 22 
  0  SERIAL CHECKSUM ERROR
  1  DEVICE ERROR
  2  BAD SCREEN MODE #
  3  FUNCTION NOT SUPPORTED
  4  SCREEN MODE EXCEEDED MEMORY
  5 
  6 
  7 
  8 
  9 
 10 
 11 
 12 
 13 
 14 
 15 

SCR # 23 
  0 
  1 
  2 
  3 
  4 
  5 
  6 
  7 
  8 
  9 
 10 
 11 
 12 
 13 
 14 
 15 

SCR # 24 
  0  ( SET COLD START )
  1 
  2  FORTH DEFINITIONS
  3 
  4 
  5  HEX
  6  ' FORTH 4 + @ C +ORIGIN !
  7  HERE  1E +ORIGIN !
  8  VOC-LINK @ 20 +ORIGIN !
  9  HERE     1C +ORIGIN ! ( FENCE)
 10  HERE 600 - 80 / 2+
 11  601 C!    ( BOOT CNT )
 12  DECIMAL ;S
 13 
 14 
 15 

SCR # 25 
  0 ( BOOTMAKER )
  1 HEX
  2     0 VARIABLE BOOTSTART
  3 
  4 : MAKEBOOT
  5                 600 BOOTSTART !
  6    HERE BOOTSTART @ - 80 / 2+
  7           1 DO
  8    BOOTSTART @ I 0 R/W
  9         80 BOOTSTART +! LOOP ;
 10 
 11 
 12 
 13   DECIMAL ;S
 14 
 15 

SCR # 26 
  0  ( MEMORY REF POINTER SET )
  1  HEX
  2 
  3  : MEMSET
  4    02E5 @ ( FETCH HI LIMIT )
  5    DUP
  6    ' LIMIT !
  7    420 -
  8    DUP ' FIRST !
  9    DUP   USE  ! PREV  !
 10    COLD ;   ;S
 11 
 12 
 13 
 14 
 15 

SCR # 30 
  0  FORTH DEFINITIONS
  1  VOCABULARY EDITOR IMMEDIATE
  2  ( EDITOR CONT )    HEX
  3 : WHERE  ( PRINT ERROR )
  4     DUP B/SCR / DUP SCR !
  5     ." SCR # " DECIMAL . SWAP
  6     C/L /MOD C/L * ROT BLOCK +
  7     CR C/L TYPE CR HERE C@ -
  8     SPACES 5E EMIT ~[COMPILE]
  9     EDITOR QUIT ;
 10 
 11 EDITOR DEFINITIONS
 12  CR ." EDITOR LOADING..."
 13 
 14                     -->
 15 

SCR # 31 
  0  ( EDITOR CONT ) HEX
  1  : -MOVE ( BLOCK ADR->LINE )
  2      LINE C/L CMOVE UPDATE ;
  3 
  4 
  5  : E ( ERASE LINE )
  6    LINE C/L BLANKS UPDATE ;
  7 
  8  : S DUP 1 - 0E DO I LINE I
  9     1+ -MOVE -1 +LOOP E ;
 10  : /R PAD 1+ SWAP -MOVE ;
 11                   -->
 12 
 13 
 14 
 15 

SCR # 32 
  0  ( EDITOR CONT )
  1  : CLEAR SCR ! 10 0 DO FORTH
  2        I EDITOR E LOOP ;
  3 
  4  : COPY B/SCR * OFFSET @ +
  5       SWAP B/SCR * B/SCR OVER
  6       + SWAP DO DUP FORTH
  7       I BLOCK 2 - ! 1+ UPDATE
  8       LOOP DROP FLUSH ;
  9 
 10  : D 0F DUP ROT DO I 1+ LINE
 11      I -MOVE LOOP E ;
 12 
 13 
 14  : P 1 TEXT /R ;
 15            -->

SCR # 33 
  0 ( DUPLICATE )
  1 0 VARIABLE EBLK  ( ENDING BLK )
  2 0 VARIABLE SBLK  ( STARTIN BLK )
  3 0 VARIABLE PSBLK
  4 : DISP ( ->DEST ADR IN FRE RAM )
  5    PSBLK @ B/BUF * HERE + ;
  6 
  7 : GTPAR ( SET UP DO AND PSBLK )
  8    EBLK @ SBLK @ 0 PSBLK ! ;
  9 
 10 : MVIN ( MOVE BLKS INTO RAM )
 11     GTPAR DO I BLOCK DISP
 12     B/BUF CMOVE 1 PSBLK +!
 13     LOOP ;
 14          DECIMAL -->
 15 

SCR # 34 
  0 : MOVOT ( WRITE RAM TO DISC )
  1     GTPAR OFFSET @ + SWAP OFFSET
  2     @ + SWAP  DO I BUFFER DISP
  3     SWAP B/BUF CMOVE 1 PSBLK +!
  4     UPDATE FLUSH LOOP ;
  5 
  6  : DUPLICATE ( STARTSCR ENDSCR )
  7    1+ B/SCR * EBLK ! B/SCR *
  8     SBLK ! EBLK @ SBLK @ -
  9   ' FIRST 1+ C@ DP 1+ C@ -
 10   2 * 2 -   > IF ." TOO MANY "
 11    QUIT ENDIF CR    MVIN
 12   ." INSERT DESTINATION DISK
 13   " CR ." RETURN TO CONTINUE "
 14   KEY DROP CR    MOVOT  ;
 15        DECIMAL -->

SCR # 35 
  0  ( ATARI FORTH EDITOR ) HEX
  1 
  2  0 VARIABLE COL ( USR COL PTR )
  3  0 VARIABLE LIN ( USR LIN PTR )
  4 
  5 
  6  : EDLIST ( SPEC LIST FOR ED  )
  7    7D EMIT
  8    DECIMAL CR DUP SCR !
  9    ." SCR # " . 10 0 DO
 10    CR I 3 .R I SCR @ .LINE
 11    LOOP CR ;
 12 
 13 
 14                        -->
 15 

SCR # 36 
  0 ( ATARI ED OS ACCESS WORDS ) HEX
  1 
  2  : ONCUR 0 02F0 C! ;
  3 
  4  : OFCUR 1 02F0 C! ;
  5 
  6   DECIMAL -->
  7 
  8 
  9 
 10 
 11 
 12 
 13 
 14 
 15 

SCR # 37 
  0  ( SMOVE )     DECIMAL
  1 
  2  : SMOVE ( SOURCE DEST # TOMV )
  3     CR   FLUSH EMPTY-BUFFERS
  4    ." CAUTION !!! " CR
  5      >R 2DUP SWAP
  6   ." MOVE " DUP . ." THRU " R +
  7   1 - . ." -->" DUP . ." THRU "
  8   R + 1 - . SPACE ." Y OR N" CR
  9   R>   KEY 89 = IF
 10   0 DO OVER I + OVER I +
 11   COPY    LOOP DROP DROP
 12   ELSE QUIT ENDIF ;
 13  DECIMAL  -->
 14 
 15 

SCR # 38 
  0  ( LFCUR RTCUR ) HEX
  1  : (LFCUR) 1E EMIT ;
  2  : (RTCUR) 1F EMIT ;
  3  DECIMAL
  4  : RTCUR OFCUR COL @ 31 =
  5        IF 31 0 DO (LFCUR) LOOP
  6        0 COL ! ELSE (RTCUR)
  7      1 COL +! ENDIF ONCUR ;
  8 
  9 
 10   : LFCUR OFCUR COL @
 11      IF (LFCUR) -1 COL +!
 12      ELSE 31 0 DO (RTCUR) LOOP
 13      31 COL ! ENDIF ONCUR ;
 14 
 15  DECIMAL           -->

SCR # 39 
  0 ( UPCUR DNCUR )  HEX
  1 : (DNCUR) 1D EMIT ;
  2 : (UPCUR) 1C EMIT ;
  3 
  4 : DNCUR OFCUR LIN @
  5       F = IF F 0 DO (UPCUR)
  6              LOOP 0 LIN !
  7       ELSE (DNCUR) 1 LIN +!
  8       ENDIF ONCUR ;
  9 
 10 : UPCUR OFCUR LIN @
 11    IF (UPCUR) -1 LIN +!
 12     ELSE F 0 DO (DNCUR)
 13     LOOP F LIN ! ENDIF
 14     ONCUR ;
 15  DECIMAL -->

SCR # 40 
  0   ( HOME CURSOR ) HEX
  1 
  2  : LINCLEAR ( CURSOR->LIN 0 )
  3     LIN @ DUP IF 0 DO UPCUR
  4     LOOP ELSE DROP ENDIF ;
  5  : COLCLEAR ( CURSOR->COL 0 )
  6     COL @ DUP IF 0 DO LFCUR
  7     LOOP ELSE DROP ENDIF ;
  8 
  9  : HOMECUR ( CURSOR->HOME )
 10   LINCLEAR COLCLEAR ;
 11 
 12 
 13  : CURSHOW (RTCUR) (LFCUR) ;
 14 
 15    -->

SCR # 41 
  0 ( ED CONT EDCR...TAB ) DECIMAL
  1 
  2  : BUFF-> ( BUFFER CHAR ADR )
  3           LIN @ SCR @ (LINE)
  4           DROP COL @ + ;
  5 
  6  : EDCR ( SPECIAL CR FOR ED )
  7       COL @ IF COLCLEAR ENDIF
  8                 DNCUR ;
  9 
 10  5 VARIABLE (TAB)
 11  : TAB 31  COL @ - (TAB) @ <
 12       IF COLCLEAR ELSE
 13    (TAB) @ COL @ OVER MOD -
 14       0 DO RTCUR LOOP ENDIF ;
 15     DECIMAL -->

SCR # 42 
  0  ( ED CONT EDMIT )   HEX
  1 
  2  : ((EDEMIT))
  3      EMIT (LFCUR) RTCUR
  4      COL @ 0= IF DNCUR ENDIF ;
  5 
  6  : TOBUFF ( SENDS CHAR TO LINE )
  7      DUP ( CHAR )
  8       BUFF-> C! ;
  9 
 10  : EDMIT DUP 20 < IF BELL DROP
 11    ELSE TOBUFF ((EDEMIT))
 12    ENDIF  UPDATE 0 ;
 13       DECIMAL -->
 14 
 15 

SCR # 43 
  0  ( LIN PRINT WORDS )  DECIMAL
  1  0 VARIABLE TEMP1
  2  0 VARIABLE TEMP2
  3 
  4  : PTRSAV COL @ TEMP1 !
  5           LIN @ TEMP2 ! ;
  6 
  7 
  8  : LINOUT
  9        COLCLEAR BUFF-> 32
 10    TYPE  32 COL ! COLCLEAR ;
 11 
 12   : CURREST  COLCLEAR TEMP1 @
 13     -DUP IF 0 DO RTCUR LOOP
 14          ENDIF ;
 15                        -->

SCR # 44 
  0   HEX
  1 
  2 : REFRESH ( OUTPUT ALL LINS)
  3                     PTRSAV
  4        10 LIN @ DO  LINOUT
  5           DNCUR LOOP TEMP2 @
  6       -DUP IF 0 DO DNCUR LOOP
  7            ENDIF  ;
  8 
  9  DECIMAL -->
 10 
 11 
 12 
 13 
 14 
 15 

SCR # 45 
  0  ( CHAR INSERT WORDS )
  1 
  2  : MOVRT DUP OVER 1 - C@
  3         SWAP C! 1 - ;
  4 
  5  : XPAND ( SPREAD LIN AT CUR )
  6      PTRSAV ( SAVE POINTERS )
  7             31  COL @ -
  8      DUP BUFF-> + SWAP 0
  9      DO MOVRT LOOP
 10      BL SWAP C!
 11      LINOUT CURREST UPDATE ;
 12 
 13      DECIMAL -->
 14 
 15 

SCR # 46 
  0  ( CHAR INSERT WORDS )
  1 
  2  : MOVLF DUP OVER 1+  C@
  3         SWAP C! 1+  ;
  4 
  5  : CPAND ( SHRINK LIN AT CUR )
  6      PTRSAV ( SAVE POINTERS )
  7      BUFF-> 31  COL @ -  0
  8      DO MOVLF LOOP
  9      BL SWAP C! ONCUR
 10      LINOUT CURREST UPDATE ;
 11 
 12      DECIMAL -->
 13 
 14 
 15 

SCR # 47 
  0  HEX
  1 
  2  : BKSP COL @ IF LFCUR ENDIF 20
  3      EDMIT LFCUR DROP ;
  4  : FINI ( WRAP-UP ON ESC )
  5      HOMECUR UPCUR (DNCUR)
  6      CR (UPCUR) ;
  7 
  8  :  INSL ( SPREAD AT LIN # )
  9       LIN @ S REFRESH ;
 10 
 11  : DELL ( DELETE LINE )
 12       LIN @ D REFRESH ;
 13               DECIMAL   -->
 14 
 15 

SCR # 48 
  0  ( EDITOR LOOK UP TABLE ) HEX
  1  EDITOR DEFINITIONS
  2  10 VARIABLE  XTABLE
  3  1C C, ( UP ) 1D C, ( DN )
  4  1E C, ( LF ) 1F C, ( RT )
  5  7D C, ( HM ) 7E C, ( BS )
  6  0D C, ( CR ) 9D C, ( IL )
  7  9C C, ( DL ) FF C, ( XL )
  8  FE C, ( CL ) 7F C, ( TB )
  9  9F C, ( ST ) 9E C, ( CT )
 10  FD C, ( BL )  DECIMAL
 11  : KEYLIT  0 XTABLE @ 0
 12       DO DROP DUP I XTABLE 2
 13     + +   C@ = IF LEAVE ENDIF
 14             I LOOP ;
 15  DECIMAL  -->

SCR # 49 
  0   ( CONTROL WORDS )
  1 
  2  CASE: CONTROL
  3      UPCUR DNCUR LFCUR RTCUR
  4      HOMECUR BKSP  EDCR INSL
  5      DELL XPAND CPAND TAB
  6      BELL BELL  BELL EDMIT ;
  7 
  8  : +KEY ( LIST BACK ONE )
  9      SCR @ DUP 1 >
 10      IF 1 - ENDIF EDLIST ;
 11 
 12  : *KEY SCR @ 1+ EDLIST ;
 13 
 14                     -->
 15 

SCR # 50 
  0  ( ED MODE CONTROL ) HEX
  1 
  2 : ED (UPCUR) (RTCUR) (RTCUR)
  3   (RTCUR) (RTCUR)
  4    INVON
  5    1 COL ! F LIN ! HOMECUR
  6    CURSHOW BEGIN KEY
  7    DUP 1B XOR WHILE
  8    KEYLIT CONTROL  DROP
  9    CURSHOW REPEAT FINI
 10    INVOF
 11                  DROP ;
 12       DECIMAL  -->
 13 
 14 
 15 

SCR # 51 
  0  ( ED MODE CONTROL ) DECIMAL
  1 : 0-> DROP 0 ;
  2 : L        ( LIST SCREEN,WAIT )
  3     INVON        EDLIST
  4                  BEGIN KEY
  5   DUP 27 XOR WHILE
  6   DUP 43 = IF +KEY 0-> ENDIF
  7   DUP 42 = IF *KEY 0-> ENDIF
  8   DUP 45 = IF ED 0-> ENDIF
  9   IF BELL ENDIF REPEAT
 10   DROP  INVOF ;
 11 
 12   FORTH DEFINITIONS
 13   : KL ~[COMPILE] EDITOR  EDITOR
 14     SCR @ L ; DECIMAL -->
 15 

SCR # 52 
  0  ( INVERSE ADDR, CNT ) HEX
  1   EDITOR DEFINITIONS
  2   : INTYPE INVON 0 DO I OVER +
  3       C@ 80 OR EMIT LOOP
  4        DROP INVOF ;
  5 
  6   : <L> ( T IF BETWEEN L#'S )
  7       DUP SBLK @ < 0= SWAP
  8       EBLK @ > 0= AND ;
  9 
 10   : IN.LINE  (LINE) INTYPE ;
 11 
 12          DECIMAL -->
 13 
 14 
 15 

SCR # 53 
  0  ( ATARI FORTH EDITOR ) HEX
  1 
  2  : INVLIST 7D EMIT
  3    DECIMAL CR DUP SCR !
  4    ." SCR # " . 10 0 DO
  5    CR I 3 .R I SCR @
  6    OVER <L> IF IN.LINE ELSE
  7    .LINE ENDIF  LOOP CR ;
  8 
  9  0 VARIABLE STBLK
 10  0 VARIABLE SBBLK
 11  0 VARIABLE SSCR
 12  0 VARIABLE DTBLK
 13  0 VARIABLE DBBLK
 14  0 VARIABLE DSCR
 15         DECIMAL -->

SCR # 54 
  0 
  1  : FROM ( SCR LO HI L# )
  2    15 MIN
  3    DUP STBLK ! EBLK !
  4    DUP SBBLK ! SBLK ! DUP
  5    SSCR ! INVLIST ;
  6 
  7  : /H LINE PAD 1+ C/L DUP PAD
  8        C! CMOVE ;
  9 
 10  : SS->DD
 11    STBLK @ 1+ SBBLK @ - 0
 12    DO SSCR @ SCR ! I SBBLK @ +
 13   /H  DSCR @ SCR ! I DBBLK @ +
 14   /R  LOOP ;
 15               DECIMAL -->

SCR # 55 
  0 
  1 
  2 
  3 
  4  : INTO DUP SBLK ! DBBLK !
  5    DSCR ! STBLK @ SBBLK @ -
  6    DBBLK @ + DUP EBLK ! DTBLK !
  7     SS->DD   DSCR @ INVLIST
  8     CR ." OK? Y/N " KEY
  9     89 = IF KL ELSE
 10     EMPTY-BUFFERS ENDIF ;
 11 
 12 
 13         ;S
 14 
 15 

SCR # 58 
  0  ( ATARI ASSMBLER  9/19/80 )
  1  FORTH DEFINITIONS
  2  VOCABULARY ASSEMBLER IMMEDIATE
  3  ' ASSEMBLER CFA
  4  ' ;CODE  8 + !
  5  10 VARIABLE ADRMD
  6  : CODE: ?EXEC    !CSP
  7      10 ADRMD !    CREATE
  8     ~[COMPILE] ASSEMBLER  ;
  9    IMMEDIATE
 10 
 11  : C; CURRENT @ CONTEXT !
 12       ?EXEC ?CSP SMUDGE ;
 13    IMMEDIATE
 14  CR ." ASSEMBLER LOADING..."
 15                     -->

SCR # 59 
  0  ( MSC LABELS TO FIG CODE )
  1 
  2  ASSEMBLER DEFINITIONS
  3 
  4  HEX
  5  47  +ORIGIN CONSTANT NEXT
  6  3DF +ORIGIN CONSTANT PUSH0A
  7  B5  CONSTANT XSAVE
  8 
  9  0 VARIABLE INCLS
 10  DECIMAL -->
 11 
 12 
 13 
 14 
 15 

SCR # 60 
  0  -->
  1 
  2 
  3 
  4 
  5 
  6 
  7 
  8 
  9 
 10 
 11 
 12 
 13 
 14 
 15 

SCR # 61 
  0  ( OPCODE TABLE )   HEX
  1  0 VARIABLE OPTBL ( FF ILLEGAL )
  2 ( A:)   FF C, FF C, FF C, FF C,
  3         08 C, FF C, FF C, FF C,
  4 ( 16)   0C C, 08 C, 08 C, 08 C,
  5         0C C, 0C C, 0C C, 0C C,
  6 ( 8A)   04 C, 00 C, 00 C, 00 C,
  7         04 C, 04 C, 04 C, 04 C,
  8 ( # )   08 C, FF C, FF C, FF C,
  9         FF C, 00 C, 00 C, 00 C,
 10 ( 16,X) 1C C, 18 C, FF C, FF C,
 11         1C C, FF C, FF C, 1C C,
 12 ( 16,Y) 18 C, FF C, FF C, FF C,
 13         FF C, FF C, 1C C, FF C,
 14 
 15                DECIMAL   -->

SCR # 62 
  0 ( '8,X' )      HEX
  1      00 C, FF C, FF C, FF C,
  2      FF C, FF C, FF C, FF C,
  3 ( '8',Y)
  4      10 C, FF C, FF C, FF C,
  5      FF C, FF C, FF C, FF C,
  6 ( 8,X )
  7      14 C, 10 C, FF C, 10 C,
  8      14 C, FF C, FF C, 14 C,
  9 ( 8,Y )
 10      FF C, FF C, 10 C, FF C,
 11      FF C, FF C, 14 C, FF C,
 12 
 13 
 14 
 15           DECIMAL   -->

SCR # 63 
  0  ( TABLE FETCH WORDS )   DECIMAL
  1 
  2  : ?TABLE
  3      ADRMD @ 8 *
  4      INCLS @ +
  5      OPTBL 2 + + C@ ;
  6 
  7  HEX
  8  : AMDCK  ?TABLE
  9       DUP FF = 1C ?ERROR ;
 10  ( ADR MODE ERROR )
 11                     DECIMAL -->
 12 
 13 
 14 
 15 

SCR # 64 
  0   HEX
  1  : ?HI DUP FF00 AND ;
  2 
  3  DECIMAL
  4  : ADRMD! ADRMD ! ;
  5 
  6  : 16/8     ?HI
  7       IF   ( LONG  ADR )
  8           1
  9       ELSE ( SHORT ADR )
 10           2 ENDIF ADRMD ! ;
 11 
 12  : #: ?HI 26 ?ERROR
 13                3 ADRMD! ;
 14 
 15   : A: 0 ADRMD! ; DECIMAL   -->

SCR # 65 
  0 
  1  : ,X  ?HI ( TEST FOR 16/8 )
  2            IF  ( 16 )
  3               4
  4            ELSE  8
  5            ENDIF ADRMD! ;
  6 
  7 
  8 
  9                     -->
 10 
 11 
 12 
 13 
 14 
 15 

SCR # 66 
  0 
  1  : ,Y ?HI
  2           IF ( 16 OR 8 )
  3               5
  4                 ELSE
  5               9
  6           ENDIF ADRMD! ;
  7 
  8 
  9 
 10                     -->
 11 
 12 
 13 
 14 
 15 

SCR # 67 
  0  : ,X)
  1       ?HI  27 ?ERROR
  2              6 ADRMD! ;
  3 
  4  : ),Y ?HI 27 ?ERROR
  5              7 ADRMD! ;
  6 
  7                     -->
  8 
  9 
 10  ( 1B IS Z-PAGE ERROR MSG )
 11 
 12 
 13 
 14 
 15 

SCR # 68 
  0    ( CODE BUILDERS AAA CLASS )
  1 
  2  : BLDCD INCLS ! ( CLASS )
  3        10 ADRMD @ =
  4    IF SWAP 16/8 SWAP  ENDIF
  5       AMDCK OR C, ( TEST MODE )
  6       ADRMD @ IF  ( NOT A: )
  7       ?HI IF , ELSE C, ENDIF
  8             ENDIF 10 ADRMD ! ;
  9 
 10   : T3A <BUILDS SWAP  C, C,
 11           DOES>
 12           DUP C@ SWAP 1+ C@
 13           BLDCD ;
 14      -->
 15 

SCR # 69 
  0  ( OPCODE FOLLIES ) HEX
  1  ( AAA CLASS INCLS 0 )
  2 
  3  61 0 T3A ADC, 21 0 T3A AND,
  4  C1 0 T3A CMP, A1 0 T3A LDA,
  5  01 0 T3A ORA, E1 0 T3A SBC,
  6  81 0 T3A STA, 41 0 T3A EOR,
  7 
  8  ( BB1 CLASS INCLS 1 )
  9 
 10  C6 1 T3A DEC, E6 1 T3A INC,
 11 
 12  ( BBX CLASS INCLS 2 )
 13 
 14  86 2 T3A STX,
 15              DECIMAL -->

SCR # 70 
  0  ( BBY CLASS 3 INCLS )   HEX
  1 
  2  84 3 T3A STY,
  3 
  4  ( BBB CLASS 4 INCLS )
  5 
  6  02 4 T3A ASL,  42 4 T3A LSR,
  7  22 4 T3A ROL,  62 4 T3A ROR,
  8 
  9  ( CC CLASS 5 INCLS )
 10 
 11  E0 5 T3A CPX,  C0 5 T3A CPY,
 12 
 13 
 14 
 15                DECIMAL -->

SCR # 71 
  0  ( DDDX CLASS 6 INCLS )  HEX
  1 
  2  A2 6 T3A LDX,
  3 
  4  ( DDDY CLASS 7 INCLS )
  5 
  6  A0 7 T3A LDY,
  7 
  8 
  9 
 10 
 11 
 12 
 13                DECIMAL -->
 14 
 15 

SCR # 72 
  0  : IMPL <BUILDS C, ( IMPLIED )
  1      DOES> C@ C,      ; HEX
  2 
  3   00 IMPL BRK, 18 IMPL CLC,
  4   D8 IMPL CLD, 58 IMPL CLI,
  5   B8 IMPL CLV, CA IMPL DEX,
  6   88 IMPL DEY, E8 IMPL INX,
  7   C8 IMPL INY, EA IMPL NOP,
  8   48 IMPL PHA, 8A IMPL TXA,
  9   98 IMPL TYA, 08 IMPL PHP,
 10   68 IMPL PLA, 28 IMPL PLP,
 11   40 IMPL RTI, 60 IMPL RTS,
 12   38 IMPL SEC, F8 IMPL SED,
 13   78 IMPL SEI, AA IMPL TAX,
 14   A8 IMPL TAY, BA IMPL TSX,
 15   9A IMPL TXS,  DECIMAL -->

SCR # 73 
  0  ( REL BRANCH )     DECIMAL
  1 
  2  HEX
  3  : RBR <BUILDS C,
  4          DOES> C@ C, 3 C, ;
  5 
  6  ( BRANCH AROUND JMP )
  7 
  8  90 RBR BCC, B0 RBR BCS,
  9  F0 RBR BEQ, 30 RBR BMI,
 10  D0 RBR BNE, 10 RBR BPL,
 11  50 RBR BVC, 70 RBR BVS,
 12                DECIMAL -->
 13 
 14 
 15 

SCR # 74 
  0  ( JMP & BIT )      HEX
  1 
  2  : JMP, 4C C, , ;
  3 
  4  : (JMP), 6C C, , ;
  5 
  6  : JSR, 20 C, , ;
  7 
  8  : BIT, ?HI  IF 2C C, ,
  9             ELSE 24 C, C,
 10        ENDIF   ;
 11 
 12 
 13 
 14 
 15                DECIMAL   -->

Add new attachment

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