Power-Programmierung

home *** CD-ROM | disk | FTP | other *** search

/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / window.seq < prev next >

Wrap

Text File | 1989-09-26 | 13.1 KB | 428 lines

\ WINDOW.SEQ Window code for F83 by Graig A. Lindley POSTFIX \ Use the postfix assembler syntax. comment: IBM window program by Craig A. Lindley Manitou Springs, Colorado November 1985 Dr. Dobbs #117 July 1986 : ?comp state @ not abort" Compilation only" ; : ?pairs <> abort" Bad Case Statement" ; : case ?comp csp @ !csp 4 ; immediate : of 4 ?pairs compile over compile = compile ?branch here 0 , compile drop 5 ; immediate : endof 5 ?pairs compile branch here 0 , swap >resolve 4 ; immediate : endcase 4 ?pairs ( compile drop ) begin sp@ csp @ <> while >resolve repeat csp ! ; immediate comment; \ write count # of chars with attrib at cursor position code chra ( attrib,count--) cx pop ax pop ah bl mov bh bh xor 9 # ah mov \ char in al, func. code in ah si push 16 int si pop \ do video interrupt next end-code \ write 1 char with attrib at cursor - update cursor position code chra+ ( attrib--) ax pop ah bl mov bh bh xor 1 # cx mov 9 # ah mov \ char in al, func. code in ah si push 16 int \ count-1 write char/attrib 3 # ah mov 16 int dl inc 2 # ah mov 16 int si pop \ inc cursor position next end-code \ read char and attrib at cursor position code rdchra ( --attrib ) 0 # bh mov 8 # ah mov \ pg = 0 func. code = 8 si push 16 int si pop \ do video interrupt 1push end-code \ attrib to stack \ put char with attrib at x,y : putch ( x,y,attrib--) >r at r> 1 chra ; \ get char with attrib at x,y : getch ( x,y--attrib) at rdchra ; \ draw count # of chars starting at x,y : drawrow ( x,y,attrib,count--) >r >r at r> r> chra ; \ scroll specified window up n lines code scrlup ( xul,yul,xlr,ylr,n,attrib--) bx pop bl bh mov di pop dx pop dl dh mov ax pop al dl mov \ dx has lr x y cx pop cl ch mov ax pop al cl mov \ cx has ul x y di ax mov si push bp push \ save regs 6 # ah mov 16 int \ ax # of lines func code ah bp pop si pop \ restore forth regs next end-code \ DOS memory management support \ tell DOS to allocate memory bytes code calloc ( #bytes--seg,? ) bx pop 4 # cl mov bx cl shr \ -- maxp error code F bx inc 72 # ah mov 33 int \ func. code 48h, int 21h u< if bx push ax push ax ax xor \ if C then error else ax push -1 # ax mov then 1push end-code \ tell DOS to free memory segment code free ( seg--? ) 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 ax ax xor \ if C then error else -1 # ax mov then 1push end-code \ tell DOS to shrink or expand allocated memory segment code setblock ( #bytes--? ) bx pop es push cs ax mov ax es mov \ maxp error code F 4 # cl mov bx cl shr \ bx has # of paragraphs bx inc 74 # ah mov 33 int \ func code 4Ah, int 21h es pop u< if bx push ax push ax ax xor \ if C then error else -1 # ax mov then 1push end-code \ fetch word from extended memory code e@ ( seg,addr--n) bx pop ax pop \ seg in es, addr in bx es push ax es mov es: 0 [bx] ax mov \ get the data on stack es pop 1push end-code \ store word in extended memory code e! ( n,seg,addr--) bx pop dx pop ax pop es push dx es mov ax es: 0 [bx] mov \ store the data es pop next end-code \ read current cursor location code rdcur ( --x,y) si push 0 # bh mov 3 # ah mov 16 int \ func. code 3, int 10h si pop ah ah xor dl al mov ax push dh al mov 1push end-code \ Window Control Block (WCB) record layout 860704clz) 0 constant ulx 2 constant uly \ upper left corner 4 constant width 6 constant height 8 constant curx 10 constant cury \ current cursor pos 12 constant oldx 14 constant oldy \ old cursor pos 16 constant bufseg 18 constant oldwcbseg \ seg storage 20 constant attrib \ window attrib. 22 constant recordsize 15 constant border \ border attribute HEX B000 constant vseg \ start video memory \ B800 = color graphics adapter, B000 = monochrome monitor variable wcbseg \ current WCB seg DECIMAL \ WCB extended memory access \ store word n at addr in current WCB : wcbseg! ( n,addr--) wcbseg @ swap e! ; \ fetch word from addr in current WCB : wcbseg@ ( addr--n) wcbseg @ swap e@ ; : top ( --) ulx wcbseg@ uly wcbseg@ [ 201 border 256 * + ] literal putch ulx wcbseg@ 1+ uly wcbseg@ [ 205 border 256 * + ] literal width wcbseg@ drawrow ulx wcbseg@ width wcbseg@ + 1+ uly wcbseg@ [ 187 border 256 * + ] literal putch ; : bottom ( --) ulx wcbseg@ uly wcbseg@ height wcbseg@ + 1+ [ 200 border 256 * + ] literal putch ulx wcbseg@ 1+ uly wcbseg@ height wcbseg@ + 1+ [ 205 border 256 * + ] literal width wcbseg@ drawrow ulx wcbseg@ width wcbseg@ + 1+ uly wcbseg@ height wcbseg@ + 1+ [ 188 border 256 * + ] literal putch ; : sides ( --) uly wcbseg@ height wcbseg@ + 1+ uly wcbseg@ 1+ do ulx wcbseg@ i [ 186 border 256 * + ] literal putch ulx wcbseg@ width wcbseg@ + 1+ i [ 186 border 256 * + ] literal putch loop ; \ used by scn->buf and buf->scn label saveh nop nop \ storage for height parameter label savew nop nop \ width parameter label saveptr nop nop \ start pointer label savesi nop nop \ forth's IP reg label saveds nop nop \ current ds reg \ move data from screen to memory buffer HEX code scn->buf ( x,y,width,height,seg--) cld dx pop 0 # di mov saveh #) pop savew #) pop ax pop A0 # bl mov bl mul bx pop bx shl bx ax add ax saveptr #) mov si savesi #) mov ds ax mov ax saveds #) mov vseg # ax mov es push dx es mov ax ds mov cs: saveptr #) si mov cs: saveh #) cx mov here cx push cs: savew #) cx mov rep movs cs: saveptr #) si mov A0 # si add si cs: saveptr #) mov cx pop loop cs: saveds #) ax mov ax ds mov savesi #) si mov es pop next end-code DECIMAL \ move data from memory buffer to screen HEX code buf->scn ( seg,x,y,width,height--) cld saveh #) pop savew #) pop ax pop A0 # bl mov bl mul bx pop bx shl bx ax add ax saveptr #) mov si savesi #) mov ds ax mov ax saveds #) mov ax pop ax ds mov es push vseg # ax mov ax es mov 0 # si mov cs: saveptr #) di mov cs: saveh #) cx mov here cx push cs: savew #) cx mov rep movs cs: saveptr #) di mov A0 # di add di cs: saveptr #) mov cx pop loop cs: saveds #) ax mov ax ds mov savesi #) si mov es pop next end-code DECIMAL \ moves screen data to memory buffer \ and then draws the actual window frame : wndw ( --) ulx wcbseg@ uly wcbseg@ width wcbseg@ 2+ height wcbseg@ 2+ bufseg wcbseg@ scn->buf top sides bottom ; : clearwindow ( --) ulx wcbseg@ 1+ \ upper left x uly wcbseg@ 1+ \ upper right y ulx wcbseg@ width wcbseg@ + \ lower left x uly wcbseg@ height wcbseg@ + \ lower right y 0 attrib wcbseg@ scrlup \ scroll entire window 0 curx wcbseg! 0 cury wcbseg! ; \ home window cursor : window ( x,y,width,height,attrib--? ) recordsize calloc \ reserve space for wcb if wcbseg @ >r wcbseg ! r> oldwcbseg wcbseg! attrib wcbseg! 2dup 2+ swap 2+ * 2* calloc \ reserve space for scr buf if bufseg wcbseg! \ save buffer seg height wcbseg! width wcbseg! \ save parameters uly wcbseg! ulx wcbseg! \ in new wcb rdcur oldy wcbseg! oldx wcbseg! \ get old cur pos wndw clearwindow true else ." Buffer allocation failure." cr wcbseg @ free drop drop 0 then else ." WCB allocation failure." abort ( drop drop 0 ) then ; \ window parameter checking : wfit ( ?--) cr abort" Window won't fit on crt." ; : openwindow ( x,y,width,height,attrib--? ) depth 5 >= if >r 4dup rot + 2+ 24 <= if + 2+ 79 <= if r> window else cr ." ULX and/or WIDTH incorrect." wfit then else cr ." ULY and/or HEIGHT incorrect." wfit then else cr ." Incorrect # of parameters specified." quit then ; \ close the current window \ free wcb and buffer memory then unlink window : closewindow ( --) wcbseg @ 0 <> \ if window exists if bufseg wcbseg@ \ get buffer seg addr ulx wcbseg@ uly wcbseg@ width wcbseg@ 2+ height wcbseg@ 2+ buf->scn \ move data back to screen oldx wcbseg@ oldy wcbseg@ at bufseg wcbseg@ free drop \ free buffer seg memory wcbseg @ free drop \ free wcb seg memory oldwcbseg wcbseg@ wcbseg ! \ unlink this window else cr ." No open windows." cr then ; \ position cursor in window \ if paras out of range do the best and still stay in window : wat ( x,y--) swap dup abs width wcbseg@ 1- > \ x not within window if drop width wcbseg@ 1- \ set x to max in window then curx wcbseg! \ save new cursor x pos dup abs height wcbseg@ 1- > \ y not within window if drop height wcbseg@ 1- \ set y to max in window then cury wcbseg! \ save new cursor y pos curx wcbseg@ ulx wcbseg@ + 1+ \ actual cursor x cury wcbseg@ uly wcbseg@ + 1+ \ actual cursor y at ; \ read window cursor position : rdwcur ( --x,y) curx wcbseg@ cury wcbseg@ ; \ read attribute of character at cursor in window : rdwcha ( x,y--attrib) wat rdchra ; \ scroll window up for blank line at bottom : scrollwindow ( --) ulx wcbseg@ 1+ uly wcbseg@ 1+ \ upper left corner to scroll ulx wcbseg@ width wcbseg@ + \ lower right x coordinate uly wcbseg@ height wcbseg@ + \ lower right y coordinate 1 attrib wcbseg@ scrlup ; \ up one line \ cr in current window : crout ( --) rdwcur nip 0 swap wat ; \ line feed in current window : lfout ( --) rdwcur 1+ dup height wcbseg@ 1- > \ cursor out of window if 1- scrollwindow then wat ; \ execute backspace in current window : bsout ( --) rdwcur over if swap 1- swap wat else 2drop then ; : bell ( --) 7 (emit) ; : wemit ( char--) dup 32 < if case \ handle controls 7 of bell endof 8 of bsout endof 10 of lfout endof 13 of crout endof drop endcase else \ display character attrib wcbseg@ 256 * + \ char now char/attrib rdwcur rot chra+ \ output char & adv. cursor drop dup width wcbseg@ 1- = \ at end of line if drop lfout crout \ if do lfcr else 1+ curx wcbseg! \ store new x coordinate then then ; : wcr ( --) 13 wemit 10 wemit ; : wtype ( addr,n--) 0 ?do count wemit loop drop ; comment: \ use DOS memory manager to give forth a full 64k segment : initialize ( --) cr ." Memory management " -1 setblock \ request FFFF bytes if ." initialized." 0 wcbseg ! \ initialize link var else ." error." abort then cr ; comment; 7 constant normal 15 constant highint 112 constant reverse 128 constant blink : enterwindow ( x,y,width,height,attrib--) openwindow if ['] wemit is emit ['] wcr is cr 0 0 wat then ; : exitwindow ( --) closewindow wcbseg @ 0= if ['] (emit) is emit ['] crlf is cr then ; : smash ( --) exitwindow ; : window1 ( --) 0 0 20 10 reverse openwindow ; : window2 ( --) 2 1 70 8 normal openwindow ; : window3 ( --) 7 6 69 10 reverse openwindow ; : window4 ( --) 10 9 59 4 highint openwindow ; : msg1 ( --) " Attitudes are contagious. " wtype ; : msg2 ( --) " Is yours worth catching? " wtype ; : msg3 ( --) " ** Window 4 ** " wtype ; : msg1out ( --) 0 0 wat 20 0 do msg1 loop ; : msg2out ( --) 0 0 wat 20 0 do msg2 loop ; : msg3out ( --) 0 0 wat 80 0 do msg3 loop ; : fillscreen ( --) 0 0 \ fill with rev video A's [ ascii A reverse 256 * + ] \ calculate char/attrib code literal 2048 drawrow ; : wait ( --) 2 tenths ; : demo ( --) fillscreen window1 if 0 0 wat msg1 wait wcr wait 7 wemit wcr wait " Really ?" wtype wait 8 wemit 8 wemit wait 10 5 wat wait window2 if msg2out wait window3 if ( 0 10 wat 24 wtriad wait ) window4 if msg3out wait closewindow wait closewindow wait clearwindow msg2out wait closewindow ( 0 wlist wait wait wait ) closewindow then then then then dark ;