home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / monitor.seq < prev    next >
Encoding:
Text File  |  1988-05-22  |  7.8 KB  |  247 lines
  1. \ MONITOR.SEQ   Interactive Forth Monitor               by Zafar Essak
  2.  
  3. comment:
  4.   Zafar Essak, Box 46263 Stn.G, Vancouver, B.C.,Canada V6R 4G6
  5.  
  6.      Forth offers the advantage that it is interactive.  The
  7. user may examine the effects of a series of Forth words by
  8. direct execution.  This series of words may be added to the
  9. dictionary as new definitions or entered onto the disk for
  10. future use.
  11.  
  12.      To fully utilize the interactive features of the language,
  13. implementations of Forth need to provide a monitor state with
  14. editing functions.  Such a monitor would respond to the enter
  15. keystroke by transfering the contents of the current line to
  16. the terminal input buffer (TIB) and calling INTERPRET.
  17. Following interpretation, QUIT would return the user to the
  18. terminal monitor to resume "editing" instructions.
  19. comment;
  20.  
  21. \ Zafar Essak, Box 46263 Stn.G, Vancouver, B.C.,Canada V6R 4G6
  22.  
  23. comment:
  24.  
  25. References:
  26.     Craig A. Lindley, Forth Windows for the IBM PC,
  27.                                Dr.Dobbs 1986 JUL
  28.     Leo Brodie, Quick Text Formatter, FD:IV/4,p.28, 1982 NOV
  29.     Henry Laxen & Michael Perry, F83, 1984 APR
  30.     Ray Duncan, Advanced MS DOS
  31.     IBM-PC XT Technical Reference Manual, 1983 APR  p.2-18
  32.  
  33. comment;
  34.  
  35. POSTFIX         \ Use the postfix assembler syntax
  36.  
  37. CODE SETMODE    ( n--)  AX POP   16 INT   NEXT   END-CODE
  38.  
  39. : clearscreen   ( --)  2 SETMODE ;
  40.  
  41. \ CODE pos      ( x,y--)
  42. \     AX POP  DX POP  AL DH MOV  BH BH XOR  2 # AH MOV
  43. \     16 INT   NEXT   END-CODE
  44. \ : pos ( x,y--) 2DUP #LINE ! #OUT ! pos ;    \ for F83
  45.  
  46. : pos ( x,y--) at ;
  47.  
  48.         \ Craig A. Lindley, Dr.Dobbs 1986 JUL, p.46
  49.  
  50. CODE location   ( --x,y)               \ current cursor location
  51.     SI PUSH 0 # BH MOV 3 # AH MOV    \ int 10h func. 3
  52.     16 INT SI POP AH AH XOR
  53.     DL AL MOV AX PUSH DH AL MOV
  54.     1PUSH END-CODE
  55.  
  56.         \ scroll specified window n lines
  57.  
  58. CODE scrollup   ( xul,yul,xlr,ylr,n,attrib--)
  59.     BX POP BL BH MOV DI POP
  60.     DX POP DL DH MOV AX POP AL DL MOV   \ dx has lr x y
  61.     CX POP CL CH MOV AX POP AL CL MOV   \ cx has ul x y
  62.     DI AX MOV SI PUSH BP PUSH           \ save regs
  63.     6 # AH MOV 16 INT             \ ax # of lines func code ah
  64.     BP POP SI POP NEXT END-CODE   \ restore forth regs
  65.  
  66. CODE scrolldown ( xul,yul,xlr,ylr,n,attrib--)
  67.     BX POP BL BH MOV DI POP
  68.     DX POP DL DH MOV AX POP AL DL MOV   \ dx has lr x y
  69.     CX POP CL CH MOV AX POP AL CL MOV   \ cx has ul x y
  70.     DI AX MOV SI PUSH BP PUSH           \ save regs
  71.     7 # AH MOV 16 INT             \ ax # of lines func code ah
  72.     BP POP SI POP NEXT END-CODE   \ restore forth regs
  73.  
  74. CODE rdchar     ( --charattrib )   \ read char at current cursor
  75.     0 # BH MOV 8 # AH MOV       \ pg = 0  func. code = 8
  76.     SI PUSH 16 INT SI POP       \ do video interrupt
  77.     1PUSH  END-CODE             \ charattrib to stack
  78.  
  79. : getchar       ( x,y--charattrib) pos rdchar ;
  80.  
  81. : attribute     ( --n) rdchar 256 / ;
  82.  
  83. CODE charemit   ( charattrib--)
  84.     AX POP AH BL MOV BH BH XOR    \ char in al, attrib in bl
  85.     1 # CX MOV 9 # AH MOV         \ count=1, func. code in ah
  86.     SI PUSH 16 INT                \ write char/attrib
  87.     3 # AH MOV 16 INT             \ increment cursor
  88.     DL INC 2 # AH MOV 16 INT      \     position
  89.     SI POP NEXT END-CODE
  90.  
  91. CODE chars      ( charattrib,n--)    \ write n chars
  92.     CX POP AX POP AH BL MOV     \ count in cx, attrib in bl
  93.     BH BH XOR 9 # AH MOV        \ char in al, func. code in ah
  94.     SI PUSH 16 INT SI POP       \ do video interrupt
  95.     NEXT END-CODE
  96.  
  97. : drawrow       ( x,y,charatt,n--)  \ draw n chars starting at x,y
  98.                 >R >R pos R> R> chars ;
  99.  
  100. : putchar       ( x,y,charatt--) >R POS R> 1 chars ;
  101.  
  102. : acceptline    ( addr,n--) location       \ a,n,x,y
  103.     2 PICK 0
  104.         DO I OVER pos rdchar 255 AND    \ a,n,x,y,ascii
  105.             4 PICK I + C! LOOP          \ a,n,x,y
  106.     >R DROP -TRAILING 1+ DUP SPAN !
  107.      R> pos DROP ;
  108.  
  109. 80 CONSTANT crtwidth
  110.  
  111. : right         ( --n) crtwidth 1- ;
  112.  
  113. VARIABLE saddr
  114.  
  115. : saveaddr      ( --addr) saddr @ ;
  116.  
  117. : saveline      ( --) location saveaddr crtwidth acceptline pos ;
  118.  
  119. : forward       ( --) location SWAP DUP right <
  120.                 IF 1+ ELSE DROP 0 THEN SWAP pos ;
  121.  
  122. : backward      ( --) location SWAP ?DUP
  123.                 IF 1- ELSE right THEN SWAP pos ;
  124.  
  125. : down          ( n--) location DUP 24 <
  126.                 IF 1+ ELSE DROP 0 THEN pos ;
  127.  
  128. : goup          ( n--) location ?DUP
  129.                 IF 1- ELSE 24 THEN pos ;
  130.  
  131. : home          ( --) 0 0 pos ;
  132.  
  133. : end           ( --) right 24 pos ;
  134.  
  135. VARIABLE TABS   8 TABS !
  136.  
  137. : dotab         ( --) TABS @ location DROP over MOD - 0 DO forward LOOP ;
  138.  
  139. : lowerscreen   ( --xul,yul,xlr,ylr,1,attrib)
  140.                 location >R DROP 0 R> 79 24 1 attribute ;
  141.  
  142. : deleteline    ( --) lowerscreen scrollup ;
  143.  
  144. : spreadlines   ( --) lowerscreen scrolldown ;
  145.  
  146. : backspace     ( --) bs EMIT BL EMIT bs EMIT -4 #out +! ;
  147.  
  148. : gobble        ( --) location crtwidth 2 PICK - SPACES pos ;
  149.  
  150. : slough        ( --) gobble location 2DUP 1+ pos 24 OVER
  151.     DO deleteline LOOP pos ;
  152.  
  153. VARIABLE keypressed
  154.  
  155. : keyemit       ( --) keypressed @ EMIT ;
  156.  
  157. : insertblank   ( --) saveline location >R >R
  158.     saveaddr R@ + DUP 1+ crtwidth R@ - CMOVE>
  159.     BL saveaddr R@ + C!
  160.     R> R> 0 OVER pos saveaddr crtwidth TYPE pos ;
  161.  
  162. : deletechar    ( --) saveline location >R >R
  163.     saveaddr R@ + DUP 1+ SWAP crtwidth R@ - 1- CMOVE
  164.     BL saveaddr crtwidth + C!
  165.     R> R> 0 OVER pos saveaddr crtwidth TYPE pos ;
  166.  
  167. \ arranging the characters in the line buffer and then typing
  168. \ the entire line to the screen is extra work but appears to be
  169. \ necessary for F83.
  170.  
  171.     \ Leo Brodie, FD:IV/4,p.28
  172.  
  173. : ',            ( --) '  , ;
  174.  
  175. create lineactions ( --addr)    \   action
  176.       8 , ( bs )                ',  backspace
  177.       9 ,                       ',  dotab
  178.     199 , ( home )              ',  home
  179.     207 , ( end )               ',  end
  180.     203 ,                       ',  backward
  181.     205 ,                       ',  forward
  182.     200 ,                       ',  goup
  183.     208 ,                       ',  down
  184.     210 , ( ins )               ',  insertblank
  185.     211 , ( del )               ',  deletechar
  186.     245 , ( ctrl-end )          ',  gobble
  187.     246 , ( ctrl-PgDn)          ',  slough
  188.     247 , ( ctrl-home )         ',  clearscreen
  189.     159 , ( Alt-s)              ',  spreadlines
  190.     160 , ( Alt-d)              ',  deleteline
  191.       0 , ( others )            ',  keyemit
  192.  
  193. HERE CONSTANT endlineactions
  194.  
  195. endlineactions 4 - CONSTANT nomatch
  196.  
  197. : keyaction     ( ascii--) DUP keypressed !
  198.     nomatch SWAP
  199.     endlineactions lineactions
  200.         DO DUP I @ =
  201.             IF 2DROP I 0 LEAVE
  202.             THEN 4 +LOOP
  203.         DROP 2+ @ EXECUTE ;
  204.  
  205. : keys          ( --ascii) key ?DUP 0= IF KEY 128 + THEN ;
  206.  
  207. : ACCEPT        ( addr,n--) OVER saddr !
  208.     BEGIN keys DUP 13 = NOT
  209.     WHILE keyaction
  210.     REPEAT DROP acceptline ;
  211.  
  212. : IQUERY         ( --) TIB crtwidth ACCEPT SPAN @ #TIB ! 0 >IN ! ;
  213.  
  214. : ok            ( --) quit ;
  215.  
  216. \ Refill QUERY in F83 quit with new quit.
  217.  
  218. ' IQUERY ' QUIT >BODY @ XSEG @ + 22 !L
  219.  
  220.  
  221.  CR CR .( Forth monitor now interactive ! )
  222.  
  223.     \ Concept courtesy of Bill Muench, Santa Cruz
  224.  
  225. \ : U.R ( n1,n2--) 0 SWAP D.R ;
  226.  
  227. : ENOUGH? ( --?) KEY? IF KEY DROP KEY 13 = ELSE 0 THEN ;
  228.  
  229. : 8dump ( addr--) DUP 8 + SWAP DO I C@ 4 .R LOOP ;
  230.  
  231. : emitit ( n--) DUP 14 254 BETWEEN NOT
  232.     IF DUP >R R@ 7 = R@ 8 = R@ 10 = R@ 13 = R> 255 = OR OR OR OR
  233.         IF DROP BL THEN THEN EMIT ;
  234.  
  235. : 8cdump ( addr--) DUP 8 + SWAP DO I C@ emitit LOOP ;
  236.  
  237. : | ( addr,n1..n8--) 0 7            ( decrementing +loop )
  238.     DO I 1+ PICK I + C! -1 +LOOP
  239.     LOCATION >R DROP 45 R> POS 8cdump QUIT ;
  240.  
  241. : DUMP ( addr,n--) CR CR OVER + SWAP
  242.     DO 4 SPACES I 5 U.R SPACE I 8dump SPACE ASCII | EMIT SPACE
  243.         I 8cdump CR ENOUGH? IF LEAVE THEN 8 +LOOP ;
  244.  
  245. warning off     \ Dont want warnings about redefinitions.
  246.  
  247.