home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTH / FORTH.ZIP / MVPDECO2.4TH < prev    next >
Encoding:
Text File  |  1985-06-18  |  7.4 KB  |  267 lines
  1. \ GOESINTO a recursive decomplier                     02Nov83RSW
  2.  \ from FORTH DIMENSIONS p28 Vol IV, No. 2
  3.  
  4. : MYSELF LATEST PFA CFA , ; IMMEDIATE \ regular FIG PFA & LFA
  5.  
  6. 0 VARIABLE GIN                  \ # to indent
  7. : GIN+ CR GIN @ 2+ DUP GIN ! SPACES ;
  8. : DIN  CR GIN @ SPACES ;
  9. : CLIT ;                        \ no CLIT in 8086 FORTHs
  10. : GCHK DUP @ 2+ ' COMPILE =
  11.     IF  2+ DUP @ 2+ NFA ID. 2+
  12.     ELSE DUP @ 2+ DUP ' LIT =
  13.          OVER ' BRANCH  = OR
  14.            OVER ' 0BRANCH  = OR
  15.            OVER ' <LOOP>   = OR OVER ' </LOOP> = OR
  16.            SWAP ' <+LOOP>  = OR  -->
  17. \ GOESINTO -- continued                               05Nov83RSW
  18.  
  19.        IF 2+ DUP @ SPACE . 2+
  20.          ELSE DUP @ 2+ ' CLIT =
  21.         IF 2+ DUP C@ SPACE . 1+         \ no CLIT in 8086 FORTH
  22.         ELSE DUP @ 2+ DUP ' <."> = SWAP ' <ABORT"> = OR
  23.          IF 2+ DUP COUNT TYPE
  24.             DUP C@ 1+ +
  25.          ELSE 2+ THEN THEN THEN THEN
  26.     -2 GIN +! ;
  27.  
  28.   -->
  29.  
  30.  
  31.  
  32.  
  33. \ GOESINTO  -- continued                              05Nov83RSW
  34.  
  35. : <GOESINTO>          ( PFA...) \ handle special cases
  36.       DUP CFA @ ' : CFA @ =
  37.  \    OVER ' ERROR = 0= AND     \ no ERROR in MVPFORTH
  38.  IF                             \ colon def. & not 'ERROR'
  39.    BEGIN DUP @ DUP ' EXIT CFA =
  40.      OVER ' <;CODE> CFA = OR 0=
  41.    WHILE              \ high level & not end of colon definition
  42.      2+ DUP GIN+ NFA ID. KEY DUP 81 =
  43.    IF  ( 'Q' )  SP! QUIT
  44.    ELSE 13 =  ( RETURN )
  45.  
  46.  
  47.   -->
  48.  
  49. \ GOESINTO  -- continued                              02Nov83RSW
  50.  
  51.     IF  ( go down one level  )  MYSELF
  52.     ELSE DROP THEN
  53.   THEN GCHK
  54.  REPEAT                         \ show last word
  55.  2+ DIN NFA ID.
  56.  THEN DROP ;
  57.  
  58. : GOESINTO  -FIND IF DROP 0 GIN !
  59.    <GOESINTO> ELSE ." NOT FOUND" THEN ;
  60.  
  61.  
  62.  
  63.  
  64.  
  65. \ IDISK          clear disk utility                   10Dec83RSW
  66.         FORTH DEFINITIONS DECIMAL
  67. : IDISK
  68.      CR ." initializing current selected drive - hit a CR"
  69.      CR KEY 13 = NOT IF
  70.        CR ABORT" aborted intialization OK"
  71.      THEN
  72.      0 CLEAR FLUSH      \ make sure drive variables updated
  73.      BPDRV 0 DO
  74.        I CLEAR                  \ blank out blocks
  75.        I . ?TERMINAL 27 = IF    \ exit if operator hits ESC
  76.          LEAVE
  77.        THEN
  78.      LOOP FLUSH CR ;    \ write the last blocks
  79.  
  80.  
  81. \ PEMIT ENCHAR SMCHAR NOCHAR FF RESETLP DR1->DR0      17Dec83RSW
  82.         FORTH DEFINITIONS DECIMAL
  83. : PEMIT  ( char --- )  ( sends char to printer   26Oct83 RSW )
  84.    0 0 0 23 INTCALL DROP ; : NOCHAR 18 PEMIT ;
  85. : ENCHAR  27 PEMIT 69 PEMIT ; : SMCHAR 15 PEMIT ;
  86. : FF  12 PEMIT ;
  87. : RESETLP  27 PEMIT 64 PEMIT ;
  88. : DR1->DR0    ( COPY EVERYTHING FROM DRIVE 1 TO DRIVE 0 )
  89.    BPDRV 0 DO
  90.      I BPDRV +   ( n --- )   \ COMPUTE SOURCE SCREEN
  91.      I         ( n n1 --- )  \ COMPUTE DESTINATION SCREEN
  92.      COPY CR I .             \ COPY & DISPLAY SCR #
  93.      UPDATE I 4 MOD 0= IF
  94.        FLUSH
  95.      THEN ?TERMINAL 27 = IF LEAVE THEN  \ ESC causes exit
  96.    LOOP UPDATE FLUSH CR ." Done" CR ;
  97. \ ASCII ESC CLLINE NOLINE TOLINE                       9Nov83RSW
  98.         FORTH DEFINITIONS DECIMAL
  99. : ASCII  \ converts following char to ASCII code
  100.    BL WORD 1+ C@ STATE @
  101.    IF [COMPILE] LITERAL
  102.    THEN ; IMMEDIATE
  103.  
  104. 27 CONSTANT ESC
  105.  
  106. : CLLINE        \ sets printer to 1/8" line spacing
  107.     ESC PEMIT ASCII 0 PEMIT ;
  108. : NOLINE        \ sets printer to normal 1/6" line spacing
  109.     ESC PEMIT ASCII 2 PEMIT ESC PEMIT ASCII T PEMIT ;
  110. : TOLINE        \ sets printer to 7/72" touching line spacing
  111.     ESC PEMIT ASCII 1 PEMIT ESC PEMIT ASCII S PEMIT 1 PEMIT ;
  112.  
  113. \ 1TODR1 1FROMDR1 DOCCHAR PON POFF                    17Dec83RSW
  114.         FORTH DEFINITIONS DECIMAL
  115.  
  116. : 1TODR1 EMPTY-BUFFERS DR0  DUP BPDRV + COPY FLUSH ;
  117.  
  118. : 1FROMDR1 EMPTY-BUFFERS DR0  DUP BPDRV + SWAP COPY FLUSH ;
  119.  
  120. : DOCCHAR
  121.     ESC PEMIT  ASCII B PEMIT  2 PEMIT
  122.     ESC PEMIT  ASCII N PEMIT  3 PEMIT
  123.     ESC PEMIT  ASCII M PEMIT  4 PEMIT ;
  124.  
  125. : PON 1 EPRINT ! ;
  126.  
  127. : POFF 0 EPRINT ! ;
  128.  
  129. \ PTRIADS   ( firstscr lastscr --- ) prints screens   11Nov83RSW
  130.         DECIMAL
  131. : PTRIADS
  132.         1+ SWAP DOCCHAR 1 EPRINT !
  133.         DO
  134.                 I TRIAD FF
  135.                 ?TERMINAL 27 = IF LEAVE THEN
  136.         3 +LOOP
  137.         FF 0 EPRINT !
  138.         ;
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145. \ PRINT-INDEX list disk INDEX on line printer         14Dec83RSW
  146.         FORTH DEFINITIONS DECIMAL
  147. : PRINT-INDEX
  148.         1 EPRINT !      \ turn on printer
  149.         EMPTY-BUFFERS
  150.         BPDRV 1- 56 / 1+ 0 DO   \ calculate block range
  151.           I 56 * DUP 55 +
  152.           DUP BPDRV 1- > IF     \ last computed block > max?
  153.             DROP BPDRV 1-       \  yes - use max block
  154.           THEN
  155.         \ CR SWAP . . ." INDEX" CR      \ debug stuff
  156.           INDEX CR
  157.           12 EMIT    \ print one page of index
  158.         LOOP
  159.  \      CR CR CR CR CR CR
  160.         0 EPRINT ! ;    \ turn off printer
  161. \ MVUP ( first last dest --- )move several screens up 01Nov83RSW
  162.  
  163. : MVUP   ( first last dest --- )
  164.         OVER 4 PICK ( first last dest last first --- )
  165.         - +     (  dest = dest + { last - first } )
  166.         ROT      ( last dest first --- )
  167.         ROT      ( dest first last --- )
  168.         DO
  169.           DUP I SWAP COPY CR I . ." to " DUP .
  170.           FLUSH
  171.         1- -1 +LOOP CR ."  done " CR
  172.         ;
  173.  
  174.  
  175.  
  176.  
  177. \ 2PICK 2ROLL UD. 0. 1.                               01Nov83RSW
  178.  
  179. : 2PICK  ( d --- d1  copy the d-th double number to the top)
  180. (        of the stack)
  181.  2*           ( leave index to high-order 16 bits)
  182.  DUP 1+       ( leave index to low-order 16 bits)
  183.  PICK         ( copy low-order 16 bits to top of stack)
  184.  SWAP         ( put high-order index on top of stack)
  185.  PICK ;       ( copy high-order 16 bits to top of stack)
  186.  
  187. : 2ROLL  ( d --- d1  roll the d-th double number to TOS )
  188.   2* DUP 1+ ROLL SWAP ROLL ;  ( similar to 2PICK )
  189.  
  190. : UD.  <# #S #> TYPE SPACE ;
  191. 0. 2CONSTANT 0.
  192. 1. 2CONSTANT 1.
  193. \ **  single number exponentation                     14Dec83RSW
  194.  
  195. : **   ( n1 n2 --- n3 )
  196.   DUP 1 >
  197.   IF           ( n2 > 1 )
  198.    OVER SWAP   ( n1 n2 --- n1 n1 n2 )
  199.    1 DO OVER * LOOP  ( multiply current product by n1 )
  200.    SWAP DROP
  201.   ELSE ?DUP 0=
  202.    IF DROP 1      ( n2 = 0 ::= 1 )
  203.    ELSE 0<
  204.      IF DROP 0    ( n2 < 0 ::= 0 )
  205.      THEN
  206.    THEN           ( n2 = 1 ::= n1 )
  207.   THEN ;
  208.  
  209. \ DT* D*  unsigned double->triple double->double *    06Nov83RSW
  210.  
  211.  VARIABLE LO1  0 LO1 ! VARIABLE LO2  0 LO2 !
  212.  VARIABLE HI1  0 HI1 ! VARIABLE HI2  0 HI2 !
  213.  VARIABLE R1  0 R1 !   VARIABLE R2  0 R2 !
  214.  VARIABLE R3  0 R3 !   VARIABLE R4  0 R4 !
  215.  
  216. : DT*  HI2 ! LO2 ! HI1 ! LO1 ! ( d1 d2 --- t3 )
  217.       LO1 @ LO2 @ U* SWAP R1 ! 0
  218.       HI1 @ LO2 @ U* D+
  219.       HI2 @ LO1 @ U* D+ SWAP R2 ! 0
  220.       HI1 @ HI2 @ U* D+ R4 ! R3 !
  221.       R1 @ R2 @ R3 @ R4 @ ;
  222.  
  223. : D*   DT* DROP ;
  224.  
  225. \ D** ( d1 n2 --- d3 ) raise d1 to n2 power           01Nov83RSW
  226.         DECIMAL
  227. : D**
  228.   DUP 0>
  229.   IF
  230.     ROT ROT 1. 5 PICK  ( d1 1. n2 --- )
  231.     0 DO
  232.       2SWAP 2DUP 3 2ROLL  ( d1 d1 d3 --- )
  233.       D*             ( d1 d3 --- )
  234.  \      CR I . 2DUP UD.   ( debug stuff )
  235.     LOOP
  236.    2SWAP 2DROP
  237.   ELSE
  238.     DROP 2DROP 1.
  239.   THEN
  240.   ;
  241. \ <PAGEW> clear video utility                         17Dec83RSW
  242.         FORTH DEFINITIONS DECIMAL
  243.  
  244. ( <PAGEW> -- SETS 80 COLUMN B&W MODE FOR COLOR GRAPHICS ADPTR )
  245.  
  246. : <PAGEW>  2 0 0 0 16 INTCALL DROP ;
  247.  
  248.    FIND <PAGEW> 'PAGE !         ( update init video vector )
  249.    FREEZE
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.                 EXIT
  257. 6 INTCALL DROP ;
  258.  
  259.    FIND <PAGEW> 'PAGE !         ( update init video vector )
  260.    FREEZE
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.