home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
f88
/
qvideo.bak
< prev
next >
Wrap
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 ;