home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / ibmcursr.seq < prev    next >
Text File  |  1989-09-07  |  5KB  |  154 lines
  1. \ IBMCURSR      IBM Specific display       Enhancements by Tom Zimmer
  2.  
  3. DECIMAL
  4.  
  5. CODE IBM-AT     ( col row -- )          \ set cursor position
  6.                 POP AX
  7.                 POP DX
  8.                 MOV DH, AL
  9.                 XOR BH, BH
  10.                 MOV AH, # 2
  11.                 PUSH SI         PUSH BP
  12.                 INT $10
  13.                 POP BP          POP SI
  14.                 NEXT   C;
  15.  
  16. \ CODE IBM-SCR@   ( --- N1 )
  17. \               XOR BH, BH
  18. \               MOV AH, # 8
  19. \               PUSH SI         PUSH BP
  20. \               INT $10
  21. \               POP BP          POP SI
  22. \               1PUSH           END-CODE
  23.  
  24. \ CODE IBM-SCR!   ( N1 --- )
  25. \               XOR BH, BH
  26. \               MOV CX, # 1                     \ one character
  27. \               POP AX
  28. \               MOV BL, AH                      \ attrib to BL
  29. \               MOV AH, # 9
  30. \               PUSH SI         PUSH BP
  31. \               INT $10
  32. \               POP BP          POP SI
  33. \               NEXT            END-CODE
  34.  
  35. CODE IBM-AT?    ( -- col row )          \ read cursor position
  36.                 XOR BH, BH
  37.                 MOV AH, # 3
  38.                 PUSH SI         PUSH BP
  39.                 INT $10
  40.                 POP BP          POP SI
  41.                 SUB AX, AX
  42.                 MOV AL, DH
  43.                 MOV DH, AH
  44.                 2PUSH           END-CODE
  45.  
  46. CODE IBM-DARK   ( -- )                  \ Clear the screen
  47.                 MOV AH, # $0F
  48.                 PUSH SI         PUSH BP
  49.                 INT $10
  50.                 SUB AH, AH
  51.                 INT $10                 \ send it back, clearing the screen
  52.                 POP BP          POP SI
  53.                 NEXT   C;
  54.  
  55. CODE LFILLW     (  seg start-addr BYTE-count WORD -- )
  56.                 CLD             POP AX
  57.                 POP CX
  58.                 SHR CX, # 1
  59.                 POP DI          POP BX
  60.                 MOV DX, ES      MOV ES, BX
  61.                 REPNZ           STOSW
  62.                 MOV ES, DX
  63.                 NEXT            END-CODE
  64.  
  65. \ : rev-dark      ( --- )
  66. \                 ?dosio
  67. \                 if      ibm-dark
  68. \                 else    blank.color
  69. \                         VIDEO-SEG @ 0 ROWS COLS 2* *
  70. \                         attrib c@ $10 /mod swap $10 * or flip $20 or LFILLW
  71. \                         show.color
  72. \                 then    0 0 at ;
  73.  
  74. : norm-dark     ( --- )
  75.                 ?dosio
  76.                 if      ibm-dark
  77.                 else    blank.color
  78.                         VIDEO-SEG @ 0 ROWS COLS 2* *
  79.                         attrib c@ flip $20 or LFILLW
  80.                         show.color
  81.                 then    0 0 at ;
  82.  
  83. CODE IBM--LINE  ( -- )
  84.                 PUSH SI         PUSH BP
  85.                 XOR BH, BH
  86.                 MOV AH, # 3
  87.                 INT   $10                       \ Read Cursor Position
  88.                 MOV CH, DH
  89.                 XOR CL, CL                      \ Upper left corner
  90.                 MOV DH, ' ROWS >BODY            \ bottom
  91.                 DEC DH
  92.                 MOV DL, ' COLS >BODY            \ right
  93.                 DEC DL
  94.                 MOV BH, # 7                     \ filler attribute
  95.                 MOV AH, # 6                     \ service scroll up
  96.                 MOV AL, # 1                     \ lines to scroll
  97.                 INT   $10
  98.                 POP BP          POP SI
  99.                 NEXT   C;
  100.  
  101. : >IBM          ( -- )
  102.                 ['] IBM-AT    IS AT
  103.                 ['] IBM-AT?   IS AT?
  104.                 ['] NORM-DARK IS DARK
  105.                 ['] IBM--LINE IS -LINE ;        >IBM
  106.  
  107. : CURSOR_POS_INIT       ( --- )
  108.                 IBM-AT? #LINE ! #OUT ! ;
  109.  
  110. ' CURSOR_POS_INIT IS CURSORSET
  111.  
  112. CURSOR_POS_INIT
  113.  
  114. \ Cursor shape control words by Tom Zimmer
  115.  
  116. CODE SET-CURSOR ( N1 --- )
  117.                 POP CX
  118.                 MOV AH, # 1
  119.                 PUSH SI         PUSH BP
  120.                 INT $10
  121.                 POP BP          POP SI
  122.                 NEXT C;
  123.  
  124. : GET-CURSOR    ( --- SHAPE ) 0 $460 @L ;
  125.  
  126. : CURSOR-OFF    ( --- ) GET-CURSOR $2000  OR SET-CURSOR ;
  127.  
  128. : CURSOR-ON     ( --- ) GET-CURSOR $0F0F AND SET-CURSOR ;
  129.  
  130. ONLY FORTH ALSO HIDDEN DEFINITIONS ALSO
  131.  
  132. : *NORM-CURSOR  ( --- )
  133.                 CROWS DUP 1- FLIP + SET-CURSOR ;
  134.  
  135. : *BIG-CURSOR   ( --- )
  136.                 CROWS SET-CURSOR ;
  137.  
  138. : *MED-CURSOR   ( --- )
  139.                 CROWS DUP 2/ FLIP + SET-CURSOR ;
  140.  
  141. FORTH DEFINITIONS
  142.  
  143. DEFER NORM-CURSOR       ' *NORM-CURSOR IS NORM-CURSOR
  144. DEFER BIG-CURSOR        ' *BIG-CURSOR IS BIG-CURSOR
  145. DEFER MED-CURSOR        ' *MED-CURSOR IS MED-CURSOR
  146.  
  147. DEFINED SRCON NIP
  148. #IF
  149.         SRCON           \ now default to source on for debugging
  150. #THEN
  151.  
  152. ONLY FORTH ALSO DEFINITIONS
  153.  
  154.