Power-Programmierung/CD1.mdf/forth/compiler/f88/qvideo.bak

Text File | 1988-06-07 | 12KB | 410 lines

\ QVIDEO.SEQ    Fast video routine LINKAGE.             by Tom Zimmer
\               with additions by Mike Sperl

DECIMAL

                \ ARRAY OF SPACES FOR FAST SPACES OUTPUT
CREATE QSPS     80 ALLOT
       QSPS     80 BLANK

CODE FIX.COUNTERS   ( A1 N1 --- A1 N1 x y ) \ see QTYPE
    POP CX
    PUSH CX             \ save N1
    MOV AX, #) #OUT
    PUSH AX             \ column ( x )
    ADD AX, CX          \ will string go past eol?
    MOV CX, # 79        \ eol == 79
    CMP AX, CX
<= IF
        MOV #) #OUT AX  \ ok, bump out
    ELSE
        MOV #) #OUT CX
    THEN
    MOV AX, #) #LINE
    MOV CX, # 24
    CMP AX, CX          \ are we on line 24?
 <= IF
        MOV #) #LINE AX
        PUSH AX         \ row ( y )
        NEXT
    THEN
    MOV #) #LINE CX
    PUSH CX            \ row ( y )
    NEXT
END-CODE

DEFER QTYPE

: (QTYPE)         ( A1 N1 --- ) \ optimized for the cga card
    ?DUP
    IF      PRINTING @
            IF      (TYPE)
            ELSE    FIX.COUNTERS   \ optimizes the next two lines
\                    #OUT @ 2DUP + 79 MIN #OUT ! ( a1 n1 x -- )
\                    #LINE @ 24 MIN DUP #LINE ! ( a1 n1 x y -- )
                    VTYPE
            THEN
    ELSE    DROP
    THEN    ;

' (QTYPE) IS QTYPE

: QEMIT         ( C1 --- )
                SP@ 1 QTYPE DROP ;

: QSPACES       ( N1 --- )      \ FAST SPACE PRINTING TO SCREEN
                0 MAX 80 MIN QSPS SWAP QTYPE ;

\ ' QSPACES IS SRCSPACES

: QVINIT        ( --- )         \ Initialize the source segment
                ?CS: typeseg !
                DEFERS SEGSET ;

' QVINIT IS SEGSET

?CS: typeseg !                    \ Initialize typeseg for immediate use.

: FAST          ( --- )
                ['] QTYPE     IS TYPE ;

: SLOW          ( --- )
                ['] (TYPE)    IS TYPE ;

FAST            \ Select the high speed video drivers.

\ ---------------------------------------------------------
comment:
    Extensions for pop-up screens and paging by Mike Sperl.
They work with with page 0 on the monochrome card, and pages
0..3 on the cga card.  They have not been tested on all possible
combinations of hardware.  Please address comments etc. to me
c/o the NCFB BBS.

    These words support 2 methods of writing to the screen: ."
and type.

    The following can be used with ." to pop up a screen-full of
text on the cga without any snow or the blinking that occurs when
a lot of text is written even with the modified VTYPE (see
video.seq). Text is written to a buffer in ram, after first
initializing it by calling MBUF.INIT once and clearing it by
calling CLEAR.MSEGB each time before using the buffer. After
executing these two words, and before using ." , replace IBM-AT
by MAT and (QTYPE) by (QTYPEM) with:
            ['] MAT IS AT
            ['] (QTYPEM) IS QTYPE
and don't forget to:
            ['] IBM-AT IS AT
            ['] (QTYPE) IS QTYPE ( or FAST)
when done writing to the buffer.  Transfer the text to the screen
with MOVEM after first setting the ( cga) page by PAGEx and turn on
the page with x >PAGE afterwards, if you are using various pages
(0 .. 3) of the cga card.

    (qtypem) or ." leaves x and y on the stack, so (qtypem) has
to 2DROP them, or rewrite ." - sorry about that.

    To use TYPE, use:
            ['] (QTYPET) IS QTYPE
Don't change AT.  And after you have filled the buffer, write it
to the display with MOVEM as before and do:
            ['] (QTYPE) IS QTYPE ( or FAST)
to restore forth.

    MBUF.PREP, MBUF.TYPE, and MBUF.OFF are houskeeping words you
may use if you wish.

    Most of this is assembler for speed.
comment;

ONLY FORTH ALSO DEFINITIONS

DECIMAL

0 CONSTANT MSEGB   \ to hold addr of ram buffer

PREFIX
CODE PAGE0 ( -- )
    MOV #) PAGE# # 0
    NEXT
C;

CODE PAGE1 ( -- )
    MOV #) PAGE# # 1
    NEXT
C;

CODE PAGE2 ( -- )
    MOV #) PAGE# # 2
    NEXT
C;

CODE PAGE3 ( -- )
    MOV #) PAGE# # 3
    NEXT
C;

POSTFIX
( CALLOC and FREE are borrowed from WINDOW.SEQ.)
\ tell DOS to allocate memory BYTES
CODE CALLOC ( #bytes -- seg t | n1 n2 f )
    BX POP
    4 # CL MOV
    BX CL SHR       \ bytes/16 = para
    BX INC          \ round up
    72 # AH MOV
    33 INT          \ func. code 48h, int 21h
 U< IF  BX PUSH     \ largest size available
        AX PUSH     \ err code: 7 or 8
        AX AX XOR   \ false flag
    ELSE AX PUSH    \ sucess! seg addr
        -1 # AX MOV \ true flag
    THEN
    1PUSH
END-CODE

\ tell DOS to free memory segment
CODE FREE ( seg -- -1 | n 0 )
    AX POP
    ES PUSH
    AX ES MOV          \ error code F
    73 # AH MOV
    33 INT             \ func code 4Ah, int 21h
    ES POP
 U< IF AX PUSH         \ err code, 7, 8, or 9
        AX AX XOR      \ if carry, then false flag
    ELSE -1 # AX MOV   \ sucess! - true flag
    THEN
    1PUSH
END-CODE

PREFIX
HEX
CODE >PAGE   ( n -- ) \ display page n = 0..3
    POP AX
    MOV AH, # 5
    INT 10
    NEXT
C;

CODE CLEAR    \ clear the stack
    PUSH #) CSP
    POP SP
    NEXT
C;

\ This word clears one page.  DARK clears ALL FOUR pages!
CODE CLS    ( -- ) \ clear a cga or mono display page fast
    CLD             \ without snow
    PUSH SI
    PUSH ES           \ save forth
    MOV BX, #) PAGE#  \ 0 - 3 for cga
    MOV AX, # 1000  \ 4096 bytes per page
    MUL BX
    MOV DI, AX      \ this page
    MOV ES, #) VIDEO-SEG
    MOV CX, # 7D0   \ 2000 words
    MOV AX, CS: #) ENABLE_VAL   \ fetch enable val
    CMP AL, # 0     \ monochrome? (test)
    0<>
    IF              \ if so, do nothing
    MOV DX, # 3DA   \ address cga status port
    MOV BX, # 1     \ mask
    BEGIN
        IN AL, DX   \ fetch status
        TEST AL, BL \ mask vertical retrace bit
    0<> UNTIL       \ until retrace seen
    MOV DL, # D8    \ address cga control reg
    MOV AL, # 25    \ this val disables the crt
    OUT DX, AL      \ display is disabled
    THEN
    MOV AX, # 720   \ a blank with attrib 7
    REP STOSW       \ write the page
    MOV AX, CS: #) ENABLE_VAL   \ fetch enable val
    CMP AL, # 0          \ monochrome? (test)
    0<> IF                \ we didn't disable scr \ jz ret
    MOV AX, # 29    \ enable val 29H for mode 3
    MOV DX, # 3d8   \ adress cga mode control reg
    OUT DX, AL      \ send the enable value
    THEN
    POP ES
    POP SI          \ restore forth
    NEXT
C;

DECIMAL
: MBUF.INIT     ( --- )  \ Allocate the buffer
\    0 =: MSEGB           \ add error checking if desired
    4096 CALLOC
    IF =: MSEGB
    ELSE ABORT" MBUF allocation failure."
    THEN ;

\ substitute for IBM-AT when using the ram buffer
CODE MAT   ( x y x y -- addr.in.mseg x y ) \ x, y for the rest of AT !!!
    POP AX        \ y
    MOV BX, # 160
    MUL BX
    POP BX        \ x
    POP BX        \ y
    POP DX        \ x
    SHL DX, # 1
    ADD AX, DX    \ addr in mseg = 160y + 2x
    SHR DX, # 1
    PUSH AX       \ addr in mseg
    PUSH DX       \ x
    PUSH BX       \ y
    NEXT
C;

\ place text in ram buffer w/ ." or TYPE preparatory to writing
\ to screen.   Each ." *MUST* be preceeded by an 'x y at'.
LABEL MTYPE1
    LODSB
    STOSW           \ write the char and its attribute byte
    LOOP MTYPE1
    POP ES                          \ restore ES
    POP SI                          \ Restore IP
    MOV BX, CS      MOV DS, BX      \ restore DS
    NEXT
CODE MTYPE         ( addr a1 n1 --- ) \ to msegb, use w/ MAT
    POP CX          \ length
    POP BX          \ $addr
    POP DI          \ addr in msegb
    XCHG SI, BX     \ SI is the source
    PUSH BX         \ Save SI == IP
    PUSH ES         \ save ES == list segment
    MOV ES, #) ' MSEGB 3 +
    MOV DS, #) typeseg      \ source segment
    MOV AX, CS: #) ATTRIB     \ display attributes
    XCHG AH, AL
    JMP MTYPE1
END-CODE

\ substitute one of these for QTYPE when using the ram buffer

: (QTYPEM)   ( addr a1 n1 --- ) \ to msegb (use w/ ." on cga card)
    ?DUP
    IF MTYPE   \ fix.counters not wanted!
    ELSE 2DROP
    THEN ;

: (QTYPET)   ( a1 n1 --- ) \ to msegb (use w/ type on cga card)
    ?DUP
    IF
       FIX.COUNTERS 2DUP ( a1 n1 x y x y -- )
       MAT 2DROP -ROT ( msegb.addr $addr count -- )
       MTYPE
    ELSE DROP
    THEN ;

LABEL MOVEM2
    WORD LODS
    WORD STOS       \ write the attribute and char
    LOOP MOVEM2       \ loop till cx is zero
    MOV AX, # 41    \ enable val 29H for mode 3
    MOV DX, # 984   \ adress cga mode control reg
    OUT DX, AL      \ send the enable value
    POP ES          \ restore ES
    POP SI          \ Restore IP
    MOV BX, CS      MOV DS, BX      \ restore DS
    NEXT
LABEL MOVEM1
    CLD
    MOV BX, # 1     \ mask - bit 3
    MOV DX, # 986   \ address cga status port
    BEGIN
        IN AL, DX   \ fetch status
        TEST AL, BX \ mask vertical retrace bit (test)
    0<> UNTIL       \ until retrace seen
    MOV DL, # 216   \ address control reg
    MOV AL, # 37    \ this val disables the crt
    OUT DX, AL      \ display is disabled
    JMP MOVEM2
\ write to screen from ram buffer
CODE MOVEM      ( -- ) \ from msegb to video-seg
    PUSH SI         \ save SI == IP
    PUSH ES         \ save ES == list segment
    MOV CX, # 2000   \ length
    MOV SI, # 0
    MOV DI, # 0
    MOV AX, # 4096    \ offset per page
    MOV BX, #) PAGE#
    MUL BX
    ADD DI, AX      \ offset to the active page
    MOV ES, #) VIDEO-SEG   \ destination segment
    MOV DS, #) ' MSEGB 3 + \ source segment
    JMP MOVEM1
END-CODE

\ write from screen to ram buffer (for windows)
CODE MOVE>M      ( -- ) \ from msegb to video-seg
    PUSH SI         \ save SI == IP
    PUSH ES         \ save ES == list segment
    MOV CX, # 2000   \ length
    MOV SI, # 0
    MOV DI, # 0
    MOV AX, # 4096    \ offset per page
    MOV BX, #) PAGE#
    MUL BX
    ADD SI, AX      \ offset to the active page
    MOV ES, #) ' MSEGB 3 + \ source segment
    MOV DS, #) VIDEO-SEG   \ destination segment
    JMP MOVEM1
END-CODE

HEX PREFIX
CODE CLEAR.MSEGB    ( -- ) \ clear ram to attrib
    CLD
    PUSH SI
    PUSH ES           \ save forth
    MOV AX, CS: #) ATTRIB     \ display attributes
    XCHG AH, AL
    MOV AL, # 20   \ a blank
    MOV DI, # 0
\    MOV BX, # ' MSEGB
    MOV ES, #) ' MSEGB 3 +
    MOV CX, # 7d0   \ 2000 words
    REP STOSW       \ write the page
    POP ES
    POP SI          \ restore forth
    NEXT
C;

DECIMAL

\ the housekeeping words: clear the buffer only once for each screen
: MBUF.PREP  \ for use with ." *ONLY* (don't use with TYPE)
    CLEAR.MSEGB
    ['] (QTYPEM) IS QTYPE
    ['] MAT IS AT ;

: MBUF.TYPE \ prepare to TYPE to ram buffer
    CLEAR.MSEGB
    ['] (QTYPET) IS QTYPE ;

: MBUF.OFF  \ return to standard forth
    ['] (QTYPE) IS QTYPE
    ['] IBM-AT IS AT ;

comment:
AT and DARK are *INTERESTING* words.  Note that they
are not deferred!  They are worth studying.
comment;

\ These two words are useful for interspersing ." and TYPE on
\ the same screen.
\ You may use
\          " string" $.
\ with TYPE instead of ." and avoid this switching!
\ (see AISTRING.SEQ for $.)
: P->T    \ to use TYPE after using ." on the same screen
    ['] (QTYPET) IS QTYPE
    ['] IBM-AT IS AT ;

: T->P    \ to use ." after using TYPE on the same screen
    ['] (QTYPEM) IS QTYPE
    ['] MAT IS AT ;