figforth/STARTUP.FTH at main · dimitrit/figforth · GitHub

1
              10 0 DO                                                            DUP I + C@ B.                                                                                                  *************** fig FORTH MODEL ***********************                                                                                       FORTH INTEREST GROUP                                              P.O. BOX 1105                                                 SAN CARLOS, CA. 94070                                                                                                        RELEASE 1.1F  FOR CP/M                                          WITH COMPILER SECURITY                                                 AND                                                      VARIABLE LENGTH NAMES                                                                                                            ADAPTED TO CP/M 2.2                                     SCREENS ALLOCATED IN RANDOM ACCESS FILE                      HEX   : HOME 1A EMIT ;   0 VARIABLE I-STATE                     : A-L    SCR @ (LINE) ; ( 1/2 ADDRESS OF LINE)                  : GET-L  A-L F000 SWAP CMOVE ; ( /0 MOVE LINE TO SCREEN)        : PUT-L  A-L F000 ROT ROT CMOVE ; ( /0 MOVE LINE FR SCREEN)     : DISPATCH ( 1/0 EXECUTE CONTROL CHARACTER)                     ( ^D) DUP  4 = IF  1B EMIT  57 EMIT  DROP ELSE                  ( ^I) DUP  9 = IF  I-STATE 1 TOGGLE  DROP ELSE                  ( ^X) DUP 18 = IF  1B EMIT  45 EMIT  DROP ELSE                  ( ^Y) DUP 19 = IF  1B EMIT  52 EMIT  DROP ELSE                  ( ^Q) DUP 11 = IF  ." ABORTED"       QUIT ELSE                    EMIT THEN THEN THEN THEN THEN ;                               : EMIT1  I-STATE @ IF  1B EMIT  51 EMIT  THEN EMIT ; ( 1/0)     : XX     BEGIN  KEY DUP DUP 20 <                                             IF DISPATCH ELSE EMIT1 THEN ( ^E) 5 = UNTIL  ;     : E-L    HOME DUP GET-L XX A EMIT PUT-L UPDATE ;                : C-L    SWAP A-L DROP SWAP A-L CMOVE  ;  -->                   : GET-S   10 0 DO I A-L F000 I 80 * + SWAP CMOVE LOOP ;         : PUT-S   10 0 DO F000 I 80 * + I A-L UPDATE CMOVE LOOP ;       : CLEAN   F800 F000 DO I C@ 7F AND I C! LOOP ;                  : E-S     0 I-STATE !  HOME GET-S XX CLEAN PUT-S HOME ;         : EDIT SCR ! E-S ;                                                                                                              ( EXTENDING THE SPACE ALLOCATED )                               : LAST-SEC ( 0/1 LEAVES ONE MORE THAN THE LAST BLOCK NR)            0 BEGIN 1+ F000 OVER 1 R/W DISK-ERROR @ UNTIL               ;                                                               : EXTEND   ( 1/0 EXTENDS # BLOCKS WITH NUMBER-1 )                 8 * LAST-SEC HOME ( GET AMOUNT OF BLOCKS)                       SWAP OVER + SWAP DO F000 I 0 R/W LOOP                           FCB 10 BDOS DROP    ( CLOSE THE FILE,I.E. UPDATE DIRECTORY)     FCB 0F BDOS DROP    ( OPEN AGAIN  )                           ;                                                                       ( SCR # 3)                                              : COPY-SCREEN  ( 2/0 COPY SCREEN-2 TO SCREEN-1 )                     B/SCR * SWAP B/SCR * SWAP ( GET START BUFFER #'S)               B/SCR 0 DO DUP I + BUFFER DROP LOOP ( RESERVE BUFFERS)          B/SCR 0 DO                                                         OVER I + BLOCK                                                  OVER I + BLOCK                                                  B/BUF CMOVE UPDATE                                           LOOP                                                            DROP DROP FLUSH                                                                                                            ;                                                                                                                                                                                                                                                                                                                               ( ERROR MESSAGES   )                                            MSG # 1 : EMPTY STACK                                           MSG # 2 : DICTIONARY FULL                                       MSG # 3 : HAS INCORRECT ADDRESS MODE                            MSG # 4 : ISN'T UNIQUE                                                                                                          MSG # 6 : DISK RANGE ?                                          MSG # 7 : FULL STACK                                            MSG # 8 : DISC ERROR !                                                                                                                                                                                                                                                                                                                                                                                                                                          ( FIGFORTH CP/M 2.2 ** HOBBY COMPUTER CLUB HOLLAND **)          ( ERROR MESSAGES   )                                            MSG # 17 : COMPILATION ONLY, USE IN DEFINITION                  MSG # 18 : EXECUTION ONLY                                       MSG # 19 : CONDITIONALS NOT PAIRED                              MSG # 20 : DEFINITION NOT FINISHED                              MSG # 21 : IN PROTECTED DICTIONARY                              MSG # 22 : USE ONLY WHEN LOADING                                MSG # 23 : OFF CURRENT EDITING SCREEN                           MSG # 24 : DECLARE VOCABULARY                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    (  DEBUG   SCR#6)    0 VARIABLE BASE'                          : <HEX   BASE @ BASE' ! HEX ;       ( 0/1  SWITCH TO HEX)       : HEX>   BASE' @ BASE !     ;       ( 1/0  AND BACK)            (        1/0  PRINT IN HEX REGARDLESS OF BASE)                  : H.     <HEX 0 <# # # # # #> TYPE SPACE HEX> ;                 (        1/0  IDEM FOR A SINGLE BYTE)                           : B.     <HEX 0 <# # # #> TYPE HEX> ;                           : BASE?  BASE @ H. ;                ( 0/0 TRUE VALUE OF BASE)   : ^      ( 0/0 NON DESTRUCTIVE STACK PRINT)                              CR ." S: " SP@ S0 @ ( FIND LIMITS)                              BEGIN OVER OVER = 0=                                            WHILE 2 - DUP @ H.                                              REPEAT                                                          DROP DROP                                              ;                                                                                                              -->              <HEX ( DEBUG SCR#7 )                                            :  DUMP   ( 2/0  DUMPS FROM ADDRESS-2 AMOUNT-1 BYTES)                     OVER + SWAP FFF0 AND                                            DO                                                                 CR I H. ." : "                                                  I                                                               10 0 DO                                                            DUP I + C@ B.                                                   I 2 MOD IF SPACE THEN                                        LOOP                                                            1B EMIT 67 EMIT                                                 10 0 DO DUP I + C@ EMIT LOOP                                    1B EMIT 47 EMIT                                                 DROP                                                         10 +LOOP         CR                                   ;