IMD 1.17: 14/03/2012 8:53:20 CRTS: B3466A 3.5" DS  €CRTS    p %EC_HOOKT___éK “W€ƒBCCRTT____éKC“€BCATASMT___éK_ž“W€˝3CATCRTT___éK˜“3€—ÍFASSMT____éKľÝ“#€ÜFCRTT_____éK’““W€’¸GASSMT____éK%U“€T„GBCRTT____éKz;“4€:GGCRTT_____éKľ9“I€8ňBCASSMT___éK'€ŁCATREGST__éK’“3€ňGBASSMT___éK˘m“Y€lĺCRTT______éKT“ €SMAKE_CRTSTéKc“$€KREADMET___i“ $€|READMET___éKk“ &€ś ˙˙@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@{ } { HP 9836C graphics hooks, and workstation init module } { } { Module = C_HOOK  } { Programer = BJS } { Date = 2-7-83 } {  } { Purpose: To initialize the graphics crt state variables for the HP 9836C. } { Rev history } { Created - 02-07-83  } { Modified - 01-18-84 jws } { (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival pur poses is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado } $modcal$ program c_hook(output); import sysdevs,sysglobals; type sysflag_def = packed record bit7,bit6,hpib,crt_config, kbd,high,big_graph,alpha50 : boolean; end; crt_reg_def = packed record selfinit,bit14,bit13,top1,top2,highlite, graph,alpha, bit7,bit6,bit5,bit4,bit3,bit2,bit1,bit0 : boolean; end; c_map_def = packed array [0..15] of shortint; var my_sysflag [ hex('fffffed2') ] : sysflag_def; {ext to 8 digits SFB 4/26/85} crt_reg [ hex('0051fffe') ] : crt_reg_def; {SFB 4/26/85} c_map [ hex('0051fb00') ] : c_map_def; {SFB 4/26/85} g_on [ hex ('0051fffc') ] : shortint; {SFB 4/26/85} old_toggle_hook : procedure; old_dump_hook : procedure; graphics_base ['GRAPHICSBASE'] : integer; procedure dump_c; { Purpose: To dump 'C' bit map } label 1; const gwidthb = 64; gmaxheight = 512; gbuffersize = gwidthb + 6; type gbyte = 0..255; row_def = packed array [0..(512*390)-1] of gbyte; var row : ^row_def; gbuffer : packed array [1..gbuffersize] of char; i,j : integer; index : integer; bit_mask : integer; result : integer; begin row := anyptr(graphics_base); gbuffer[1] := chr(27); { escape sequence for graphics } gbuffer[2] := '*'; gbuffer[3] := 'b'; gbuffer[4] := '6'; gbuffer[5] := '4'; gbuffer[6] := 'W'; for j := 0 to 389 do begin  for i := 0 to 63 do begin result := 0; index := j*512+i*8; bit_mask := 256; for index := index to index+7 do begin bit_mask := bit_mask div 2; if row^[index] <> 0 then result := bit_mask+result; end; gbuffer[i+7] := chr(result); end; write(gfiles[4]^,gbuffer:gwidthb+6); if ioresult <> ord(inoerror) then goto 1; end; write(gfiles[4]^,#27'*rB'); { terminate graphics sequence } 1: end; procedure toggle_c; begin graphicstate := not graphicstate; if graphicstate then g_on := 1 else g_on := 0; end; procedure init_c; var i : integer; begin g_on := 0; { turn off graphics screen } c_map[0] := -1; for i := 1 to 15 do c_map[i] := 0; { init color map is b&w } graphics_base := hex('00520000'); {SFB 4/26/85} togglegraphicshook := toggle_c; dumpgraphicshook := dump_c; end; $partial_eval on$ { check for a HP 9836C } begin if (currentcrt = alphatype) and { jws 1/18/84 } my_sysflag.big_graph and my_sysflag.crt_config and (not crt_reg.top1) and (crt_reg.top2) then init_c; end.  (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $DEBUG OFF$ $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $stackcheck off$ $ALLOW_PACKED ON$ {{ $search 'INITLOAD','ASM','INIT','SYSDEVS'$ {} program initcrtbc(OUTPUT); module crtbc; import sysglobals, asm, misc, sysdevs; export function bobcattype: boolean; implement const environc=environ[miscinfo:crtfrec[ nobreak:false, stupi d :false, slowterm:false, hasxycrt:true, haslccrt:FALSE, {INDICATES BITMAP} hasclock:true,  canupscroll:true, candownscroll:true], crttype:0, crtctrl:crtcrec[ rlf:chr(31), ndfs:chr(28),  eraseeol:chr(9), eraseeos:chr(11), home:chr(1), escape:chr(0), backspace:chr(8), fillcount:10, clearscreen:chr(0), clearline:chr(0), prefixed:b9[9 of false]], crtinfo:crtirec[ width :128,height:47, crtmemaddr:0, crtcontroladdr:0, keybufferaddr: 0,  progstateinfoaddr: 0, keybuffersize: 119, crtcon: crtconsttype [ 0, 0, 0, 0, 0, 0, 0, 0,0, 0, 0,0],  right{FS}:chr(28), left{BS}:chr(8), down{LF}:chr(10), up{US}:chr(31), badch{?}:chr(63), chardel{BS}:chr(8),stop{DC3} :chr(19), break{DLE}:chr(16), flush{ACK}:chr(6), eof{ETX}:chr(3), altmode{ESC}:chr(27), linedel{DEL}:chr(127), backspace{BS}:chr(8), etx:chr(3),prefix:chr(0), prefixed:b14[14 of false], cursormask : 0, spare : 0]]; var fontwidth: shortint; fontht: shortint; screenwidth: shortint; screenheight:shortint; maxx: shortint; maxy: shortint; screensize:shortint; defaulthighlight: shortint; highlight: shortint; planemask: shortint; lowres: boolean; hascolor: boolean; holdcursor : array[0..3] of integer; {SFB 9/24/86 - for 98549A} cursoraddr : integer; {SFB 9/24/86 - for 98549A} softcursor : boolean; {SFB 9/24/86 - for 98549A} procedure cchar(c,x,y:shortint);external; procedure cursoroff; external; procedure cursoron; external; procedure cscrollup;external; procedure cscrolldown;external; procedure cclear(x,y,n:shortint);external; procedure cupdatecursor(x,y:shortint);external; procedure cbuildtable;external; procedure cshiftleft; external; procedure cshiftright; external; procedure cexchange( savearea: windowp; ymin, ymax, xmin, width: shortint); external; procedure cscrollwindow( ymin, ymax, xmin, width: shortint); external; procedure cscrollwinddn( ymin, ymax, xmin, width: shortint); external; procedure cdbscrolll( ymin, ymax, xmin, width: shortint); external; procedure cdbscrollr( ymin, ymax, xmin, width: shortint); external; procedure cclearall; external; procedure dumpg ; label 1; const gwidthb = 128; gmaxheight = 512; gbuffersize = gwidthb + 7; type gbyte = 0..255; row_def = packed array [0..(1024*768)-1] of gbyte; var row : ^row_def; gbuffer : packed array [1..gbuffersize] of char; i,j : integer; index : integer; bit_mask : integer; result : integer; nrows: integer; begin row := anyptr(frameaddr); write(gfiles[4]^,#27'*rA'); { initiate graphics sequence } gbuffer[1] := chr(27); { escape sequence for graphics } gbuffer[2] := '*'; gbuffer [3] := 'b'; gbuffer[4] := '1'; gbuffer[5] := '2'; gbuffer[6] := '8'; gbuffer[7] := 'W'; if lowres then nrows:=399 else nrows:=767; for j := 0 to nrows do begin for i := 0 to 127 do begin result := 0;  index := j*1024+i*8; bit_mask := 256; for index := index to index+7 do begin bit_mask := bit_mask div 2; { fix for low-res mono display 7/23/85 JWS} if iand(row^[index],planemask div 256)<>0 then result := bit_mask+result; end; gbuffer[i+8] := chr(result); end; write(gfiles[4]^,gbuffer:gwidthb+7); if ioresult <> ord(inoerror) then goto 1; if lowres then write(gfiles[4]^,gbuffer:gwidthb+7); if ioresult <> ord(inoerror) then goto 1; end; write(gfiles[4]^,#27'*rB'); { terminate graphics sequence } 1: end; procedure doupdatecursor; begin cupdatecursor(xpos,ypos); end; procedure getxy(var x,y: integer); begin x := xpos; y := ypos; end; procedure setxy(x, y: shortint); begin if x>=screenwidth then xpos:=maxx else if x<0 then xpos:=0 else xpos := x; if y>=screenheight then ypos:=maxy else if y<0 then ypos:=0 else ypos := y; end; procedure gotoxy(x,y: integer); begin setxy(x,y); doupdatecursor; end; procedure clear(number: shortint); var x,y: shortint; clearchars: shortint; begin x:=xpos; y:=ypos; while number>0 do begin if maxx-x+10 do begin kbdio(fp, readtoeol, s, 1, 0); if strlen(s)=0 then length := 0 { else if s[1] = chr(etx) then length := 0 } else begin length := length - 1; crtio(fp, writebytes, s[1], 1, 0); buf := addr(buf^, 1); buffer[0] := chr(ord(buffer[0])+1); end; end;  end; startread, readbytes: begin while length>0 do begin kbdio(fp, readbytes, buf^, 1, 0); if buf^ = chr(etx) then length := 0 else length := length - 1; if buf^ = eol then crtio(fp, writeeol, buf^, 1, 0) else crtio(fp, writebytes, buf^, 1, 0); buf := addr(buf^, 1); end; if request = startread then call(fp^.feot, fp); end; writeeol: begin if ypos=maxy then scrollup; gotoxy(0, ypos+1); end; startwrite, writebytes: begin while length>0 do begin c:=buf^; buf:=addr(buf^,1); length:=length-1; case c of homechar: setxy(0,0); leftchar: if (xpos = 0) and (ypos>0)  then setxy(maxx, ypos-1) else setxy(xpos-1, ypos); rightchar: if (xpos = maxx) and (ypos0 then setxy(xpos, ypos-1); end; downchar: if ypos=maxy then scrollup else setxy(xpos, ypos+1); bellchar: beep; cteos: clear(screensize-(ypos*screenwidth+xpos));  cteol: clear(screenwidth-xpos); clearscr: begin setxy(0,0); clear(screensize); end; eol: setxy(0, ypos); chr(etx): length:=0; otherwise if (ord(c)>=128) and (ord(c)<144) then if hascolor then if (ord(c)>=136) then highlight:= highlight mod 2048 + (ord(c)-136)*4096 else highlight:=((highlight div 2048)*8  +(ord(c)-128))*256 else highlight:=(ord(c)-128)*256 else begin cursoroff; {SFB 9/24/86 - for 98549A} cchar(maptocrt(c),xpos,ypos); cursoron; {SFB 9/24/86 - for 98549A} if xpos = maxx then begin if ypos = maxy then scrollup; setxy(0, ypos+1);  end else setxy(xpos+1, ypos); end; end; doupdatecursor; end; {while} if request = startwrite then call(fp^.feot, fp); end; otherwise ioresult := ord(ibadrequest); end; {case} end; procedure lineops(op: crtllops; anyvar position: integer; c: char); var i,j: shortint; sptr: ^string255; begin j:=highlight; highlight:=defaulthighlight; case op of cllput: cchar(maptocrt(c), position, screenheight); cllshiftl: begin cshiftleft; cchar(ord(' '), maxx-8, screenheight); end; cllshiftr: begin cshiftright; cchar(ord(' '), 0, screenheight); end; cllclear: cclear(0, screenheight, maxx-7); clldisplay: begin sptr:=addr(position); for i:=1 to strlen(sptr^) do cchar(maptocrt(sptr^[i]), i-1, screenheight); for i:=strlen(sptr^) to (maxx-8) do cchar(ord(' '), i, screenheight); end; putstatus: cchar(ord(c), maxx-7+position, screenheight); end; { of case } highlight:=j; end; procedure crtdebug(op: dbcrtops; var dbrec: dbcinfo); type iptr = ^iarray; iarray = array[0..maxint] of shortint; var i: shortint; j: integer; tempaddr : integer; xtemp: shortint; ytemp: shortint; begin with dbrec do begin case op of dbinfo: savesize:=(xmax-xmin+1)*(ymax-ymin+1)*fontwidth * fontht; dbgotoxy: cupdatecursor(cursx, cursy); dbscrollup: begin if ymax > ymin {DEW 11/1/88 DEFECT: FSDdt00760} then cscrollwindow( ymin, ymax, xmin, xmax-xmin+1); cclear(xmin, ymax, xmax-xmin+1); end; dbscrolldn: begin if ymax > ymin {DEW 11/1/88 DEFECT: FSDdt00760} then cscrollwinddn(ymin, ymax, xmin, xmax-xmin+1); cclear(xmin, ymin, xmax-xmin+1); end; dbscrolll: begin cdbscrolll(ymin, ymax, xmin, xmax-xmin+1); cursoroff; {SFB 9/24/86 - for 98549A} for i:=ymin to ymax do cchar (ord(' '), xmax, i); cursoron; {SFB 9/24/86 - for 98549A} end; dbscrollr: begin cdbscrollr(ymin, ymax, xmin, xmax-xmin+1); cursoroff; {SFB 9/24/86 - for 98549A} for i:=ymin to ymax do cchar (ord(' '), xmin, i); cursoron; {SFB  9/24/86 - for 98549A} end; dbhighl: ; { Not implemented for color bitmap displays } dbput: begin cursoroff; {SFB 9/24/86 - for 98549A} i:=highlight; highlight:=debughighlight; if charismapped then cchar( maptocrt(c), cursx, cursy) else cchar( ord(c), cursx, cursy); highlight:=i; cursoron; {SFB 9/24/86 - for 98549A} end; dbclear: for i:=ymin to ymax do cclear( xmin, i, xmax-xmin+1); dbcline: cclear( cursx, cursy, xmax-cursx+1); dbinit: begin for j:= 0 to (savesize div 2)-1 do iptr(savearea)^[j]:=0; cursx:=xmin; cursy:=ymin; dcursoraddr:=frameaddr; areaisdbcrt:=true; charismapped:=false; debughighlight:=0; end; dbexcg: begin if softcursor then cursoroff; {SFB 9/24/86 - for 98549A} cexchange( savearea, ymin, ymax, xmin, (xmax-xmin+1)*fontwidth); if softcursor then begin tempaddr := cursoraddr; cursoraddr := dcursoraddr; dcursoraddr := tempaddr; cursoron; {SFB 9/24/86 - for 98549A} end else if areaisdbcrt then cupdatecursor(cursx, cursy) else doupdatecursor; areaisdbcrt:=not areaisdbcrt; end; end; { of case } end; { of with } end; { crtdebug procedure } procedure dummy; begin end; procedure bobcatinit; var i: shortint; begin idle:=245; { set io char to roman8 value } with syscom^.crtinfo do begin hascolor:=false; screenwidth:=width; screenheight:=height; maxx:=screenwidth-1; maxy:=screenheight-1; screensize:=screenwidth*screenheight; cbuildtable; highlight:=0; defaulthighlight:=0; gotoxy(0,0); dumpalphahook := dumpg; dumpgraphicshook := dumpg; updatecursorhook:=doupdatecursor; dbcrthook:=crtdebug; crtllhook:=lineops; crtiohook:=docrtio; crtinithook:=bobcatinit; togglealphahook:=dummy; togglegraphicshook:=dummy; currentcrt:=bitmaptype; keybuffer^.maxsize:=maxx-8; end; end; function bobcattype:boolean; const newbitmapid=57; {primary id for new bitmap displays} bobcatsecid=2; {bobcat secondary id} catseyesecid=5; {bobcat secondary id} var ptr: ^shortint; i: shortint; dummy: shortint; found: boolean; begin found:=false; ptr:=anyptr(hex('560000')); try dummy:=ptr^; if (dummy mod 128) = newbitmapid then begin ptr:=anyptr(integer(ptr)+20); { look at secondary id } dummy:=ptr^ mod 128; if (dummy=bobcatsecid) {or (dummy=catseyesecid)} then begin {SFB 9/22/86} {removed catseyesecid filter because this dvr doesn't support LCC 6/8/88 SFB} found:=true; bitmapaddr:=integer(ptr)-20; ptr:=anyptr(integer(bitmapaddr)+22); softcursor := false; {(dummy=catseyesecid); {SFB 9/25/86} {set softcursor to false because this dvr doesn't support LCC (which requires soft cursor) 6/8/88 SFB} dummy:=ptr^ ; if odd(dummy) then lowres:=true else lowres:=false; end; end; recover if escapecode<>-12 then escape(escapecode); if found then begin syscom^:=environc; if lowres then begin syscom^.crtinfo.width:=80; syscom^.crtinfo.height:=25; end; bobcatinit; end; bobcattype:=found; end; { bobcattype } end; { of module -- I hope } import crtbc, loader; begin if bobcattype then markuser; end.   page * * CATSEYE family bit-mapped alpha driver * * Pascal 3.21 version by S. Bayes (SFB) * * Note that there are many commented-out line of source. These are usually * enhancements that I wasn't allowed to implement. They're left in because * they  may be instructive to people who wish to make certain kinds of * enhancements: split alpha/graphics, character micro-spacing, various * cursor-restoration strategies, etc. * * The data structures in the source "CATCRT.TEXT" will give more hints as to * what might have been. SFB * * 11/17/88 - many small bug fixes for unusual cases: * o autoscrolling characters out of plane 0 (depends on alpha color) * was clearing top of display (planemode probem) * o wrr1 was not getting set due to badly aligned word move of #$ff * to tcwen1. Caused debug window shifts to change colors * o was adding dispx instead of dispy to position (effectless bug) def cscrollup,cscrolldown,cupdatecursor,cchar,cclear def cbuildtable,cshiftleft,cshiftright def cexchange,cscrollwindow,cursoroff def cscrollwinddn,cdbscrolll,cdbscrollr,cclearall def csetcolormap,csetreg,csavecatenv,crestorecatenv def cromshort,cputfontchar,csetupcchar,cprepdumpline def setupcchar rorg.l 0  refa catseyedvr,sysdevs nosyms sprint crtinfo equ catseyedvr-4 cpl equ crtinfo-2 cppl equ cpl-2 fb_fontchars equ cppl-2 maxy equ fb_fontchars-2 cursx equ maxy-2 cursy  equ cursx-2 hascolor equ cursy-1 midres equ hascolor-1 controladdr equ sysdevs-86 screen equ sysdevs-90 doblit equ $90 {literal to set RUGCMD to blit mode} * OFFSETS FOR CRTPARAMS fbwidth equ 0 fbheight equ fbwidth+2 dispx equ fbheight+2 dispy equ dispx+2 dispw equ dispy+2 disph equ dispw+2 printx equ disph+2 printy equ  printx+2 printw equ printy+2 printh equ printw+2 offx equ printh+2 offy equ offx+2 offw equ offy+2 offh equ offw+2 charw equ offh+2 charh equ  charw+2 fb_fontstartx equ charh+2 fb_fontstarty equ fb_fontstartx+2 fb_font_line_len equ fb_fontstarty+2 fb_fontlines equ fb_font_line_len+2 nfontchars equ fb_fontlines+2 fb_cursorx equ nfontchars+4 fb_cursory  equ fb_cursorx+2 set_colormap_proc equ fb_cursory+2 planemask equ set_colormap_proc+8 alphacolor equ planemask+4 cursorcolor equ alphacolor+2 *lowalphaplane equ writeyoffset+2 *highlight equ lowalphaplane+1 highlight equ cursorcolor+2 creplrule0 equ highlight+2 creplrule1 equ creplrule0+1 cursreplrule0 equ creplrule1+1 cursreplrule1 equ cursreplrule0+1 flags equ cursreplrule1+1 togglealpha equ 7  bit number togglegraphics equ 6 bit number copy_under_cursor equ 5 bit number use_fib_xy equ 4 bit number disable_low_ctl equ 3 bit number disable_hi_ctl equ 2 bit number copy_to_abuf equ 1 bit number * CATSEYE REGISTER OFFSETS (ADD CONTROL BASE ADDRESS) IDREG equ $0000 INTREG equ $0002 CATSTAT equ $4800 CMSTAT equ $6002 VBSTAT equ $6040 BLANKALL equ $605C OVERLAYCTL equ $60A2 CMINDEX equ $60B0 CMRED equ $60B2 CMGREEN equ $60B4 CMBLUE equ $60B6 PLANEMASKREG equ $60BA CMAPWRITE equ $60F0 CMAPREAD equ $60F8 WMSTAT equ $4044 TCWEN1 equ $4508 TCWEN2 equ $4708 TCREN1 equ $4504 TCREN2 equ $4704 FBEN1 equ $4500 FBEN2 equ $4700 STARTMOVE equ $409C RUGCMD equ $4206 RUGSTAT equ $4206 WMWIDTH equ $4208 WMHEIGHT equ $420A WMSOURCEX equ $4210 WMSOURCEY equ $4212 WMDESTX equ $4214 WMDESTY equ $4216 LINEPATT equ $420C LI NETYPE equ $420E TWMWIDTH equ $4308 TWMHEIGHT equ $430A TWMSOURCEX equ $4310 TWMSOURCEY equ $4312 TWMDESTX equ $4314 TWMDESTY equ $4316 WMSTART equ $409C WMCLIPLEFT equ $4218 WMCLIPRIGHT equ $421A WMCLIPTOP equ $421C WMCLIPBOTTOM equ $421E PRR1 equ $4502 WRR1 equ $4506 PRR2 equ $4702 WRR2 equ $4706 PATTERNS equ $4400 TRR equ $450C COLOR1 equ $450E COLOR2 equ $470E VB equ $4510 TRRCTL equ $4512 ACNTRL1 equ $4514 ACNTRL2 equ $4714 PLANEMODE equ $4516 * GRAPHICS ROM OFFSETS initoffset equ $23 offset to initialization offset fontoffset equ $3B offset to font info offset frameoffset equ $5D offset to frame buffer reg. offset cmapaddr equ $33  addr of color map (0 = monochrome) cmapidoff equ $57 offset to color map id offset cmapinitoff equ $3F offset to cmap 0 init region offset framecnt equ $5B offset of number of frames fbw equ $5 width of frame buffer fbh equ $9 height of frame buffer dspw equ $D width of displayed frame buffer dsph equ $11 height of displayed frame buffer * * cromshort returns a shortint from the graphics ID ROM. * it picks up the byte at the offset, and the one 2 bytes away from * it and composes a shortint * cromshort equ * movea.l controladdr(a5),a0 movea.l (sp)+,a1 return address adda.l (sp)+,a0 offset movep 0(a0),d0 move.w d0,(sp) store on stack as function value jmp (a1) * * csetreg sets the register which is offset from the graphics control * address to the value * csetreg equ * movea.l controladdr(a5),a0 movea.l (sp)+,a1 return address move (sp)+,d0 value waitset equ * btst #0,catstat+1(a0) bne.s waitset adda.l (sp)+,a0 offset move d0,(a0) set the register jmp (a1) * * cputfontchar takes a fontchardata structure from the address (dataptr) passed * in, moves it to the phantom plane, thence to the cell for font storage * in the framebuf. It does not restore CATSEYE registers when done. * cputfontchar equ * movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 movea.l (sp)+,a1 return address move.b (sp)+,d1 oddbytes addq #1,d1 1+ord(oddbytes) movea.l (sp)+,a2 dataptr move (sp)+,d2 yposition move (sp)+,d0 plane number move d0,d4 in case it's negative ext.l d4 blt.s charplaneready move #1,d4 generate destination plane mask asl d0,d4 single plane to enable charplaneready equ * btst #0,catstat+1(a0) bne.s charplaneready move d2,wmdesty(a0) yposition move (sp)+,wmdestx(a0) xposition move #0,wmsourcex(a0) move #0,wmsourcey(a0) move charw(a3),wmwidth(a0) move charh(a3),wmheight(a0) btst #0,midres(a5) bne lccputfontc btst #1,planemask+3(a3) bne.s hrcputfontc hrmputfontc equ * move.b #2,fben1(a0) disable display/enable phantom plane move.b #2,tcwen1(a0) set rule for phantom plane only move.b #3,prr1(a0) source rule for pixel moves move.b #1,acntrl1(a0) set "bit-per-pixel" bsr movetophantom move.b #$11,planemode(a0) select phantom plane as move source move.b d4,tcwen1(a0) font storage plane move.b #3,wrr1+1(a0) set source rule move.b d4,fb en1(a0) enable only target font plane move.b #0,wmstart(a0) trigger the move bsr waitforready move.b #0,acntrl1(a0) set "byte-per-pixel" jmp (a1) return hrcputfontc equ * move.b #0,fben1(a0) disable display planes move.b #4,fben2(a0) enable phantom plane move.b #4,tcwen2(a0) set rule for phantom plane only move.b #3,prr2(a0) source rule for pixel moves move.b #3,acntrl2(a0) set "bit-per-pixel"/"BARC bank 2" bsr movetophantom move.b #$1a,planemode(a0) select phantom plane as move source move.b d4,tcwen1(a0) font storage plane move.b #3,wrr1+1(a0) set source rule move.b d4,fben1(a0) enable only target font plane move.b #0,fben2(a0) disable upper 3 planes move.b #0,wmstart(a0) trigger the move bsr waitforready move.b #0,acntrl2(a0) set "byte-per-pixel" jmp (a1)  return lccputfontc move.b #$20,fben1(a0) disable non-phantom planes move.b #$80,catstat+1(a0) select phantom plane destination move.b #$20,tcwen1(a0) move.b #3,prr1(a0) source rule for pixel moves move.b #1,acntrl1(a0) set "bit-per-pixel" bsr movetophantom move.b #$40,catstat+1(a0) select phantom plane source move.b #$15,planemode(a0) select phantom plane as move source move.b d4,tcwen1(a0) move.b #3,wrr1+1(a0)  set source rule move.b d4,fben1(a0) enable only target font plane move.b #0,wmstart(a0) trigger the move bsr waitforready move.b #$0,catstat+1(a0) disable phantom access move.b #0,acntrl1(a0) set "byte-per-pixel" jmp (a1) return movetophantom equ * * move the fontchar in datastructure pointed to by dataptr to the * cell in phantom plane whose upper left corner is at 0,0. * oddbytes=true implies use only every second byte (ie font is in ROM) * some setup for this done at putfontchar * implements fbelement:=0; * k:=0; * for i:=0 to charh-1 do * begin * for j:=0 to (charw-1) div 8 do * begin *  framebuf[fbelement+j*8+ord(odd(j))]:=dataptr^[k]; * k:=k+ord(oddbyte); * endl * fbelement:=fbelement+fbwidth; * end; * previous setup a2 dataptr * ditto d1 ord(oddbyte)+1 movea.l screen(a5),a4 a4 framebuffer address move charw(a3),d6 width loop limit subq #1,d6 asr.w #3,d6 d6 (charw-1) div 8 moveq #0,d3 d3 indexes dataptr (k) move charh(a3),d0 d0 height loop (i) subq #1,d0 for use in dbra iloop equ * moveq #0,d2 d2 pixel this scanline (like fbelement kinda) moveq #0,d5  d5 width loop (j) jloop equ * btst #0,d5 beq.s evenj oddj move.b 0(a2,d3),1(a4,d2) copy the byte bra.s finishloop evenj move.b 0(a2,d3),0(a4,d2) copy the byte finishloop add.b d1,d3 k:=k+ord(oddbyte)+1 add #8,d2 fbelement+j*8 addq #1,d5 cmp d5,d6 bge jloop adda.w fbwidth(a3),a4 next scanline dbra d0,iloop rts * * cbuildtable * cbuildtable movea.l controladdr(a5),a0 get pointer to ROM start movea.l crtinfo(a5),a3 crtparamrec movep initoffset(a0),d1 form pointer to init block movea.l a0,a1 make copy of ROM start addr adda d1,a1  a1 points to init info now bsr ginitblock call the initialization routine clr.b hascolor(a5) movep cmapaddr(a0),d0 get color map addr tst d0 beq.s cnocolor if 0 then  no color init moveq #0,d1 movep cmapidoff(a0),d0 get ptr to color map id reg tst d0 if ptr=0, then use init region 0 beq.s cinitclr move.b 0(a0,d0),d1 get cmap id into d1 cinitclr and #3,d1 look at least sig bits lsl #2,d1 move.b cmapinitoff(a0,d1.w),d2 form cmap init block addr lsl #8,d2 move.b cmapinitoff+2(a0,d1.w),d2 movea.l a0,a1 adda d2,a1  a1 points to cmap init block bsr ginitblock st hascolor(a5) set color boolean cnocolor clr.l screen(a5) clear space for frame buffer addr movep.w frameoffset(a0),d0 get offset of frame buffer loc. move.b 0(a0,d0),screen+1(a5) form frame buffer addr move.b framecnt(a0),d0 d0=# of planes in system beq.s cnumplanes if zero then read planes moveq #8,d1 else make the mask up moveq #$FF,d2 sub d0,d1 d1 has shift count lsr.b d1,d2 after shift d2 has mask bra.s csetplanes go setup planemask cnumplanes moveq #0,d2 movea.l screen(a5),a1 addr of fb in a1 move.b #$FF,(a1) write all 1's move.b (a1),d2 get plane mask in d2 csetplanes move.l #0,planemask(a3) clear MSBs, as this is full 32 bits move.b d2,3+planemask(a3) save as plane mask tst.b hascolor(a5) monochrome ? beq.s cnocolor2 if so then skip color map init move d2,planemaskreg(a0) set color map mask bsr loadcmap load the color map st hascolor(a5) set color boolean cnocolor2 moveq #0,d0 {we don't clear framebuf here, as the graphics * ID ROM will do it anyway on CATSEYE. SFB} move d0,dispx(a3) move d0,printx(a3) move d0,dispy(a3) move d0,printy(a3) movep.w fbw(a0),d2 get width from ROM move d2,fbwidth(a3) movep.w dspw(a0),d2 set visible widthas window width SFB movep.w fbh(a0),d2 get height from ROM move d2,fbheight(a3) movep.w dspw(a0),d2 cmp #1024,d2 beq.s setuplcc setuphrx equ * move #1280,offx(a3) move #0,offy(a3) move #768,offw(a3) move #1024,offh(a3) bra.s donesetupoff setuplcc  equ * move #0,offx(a3) move #768,offy(a3) move #1024,offw(a3) move #256,offh(a3) donesetupoff equ * move d2,dispw(a3) move d2,printw(a3) movep.w dsph(a0),d2 move d2,disph(a3) * sub charh(a3),d2 would like to do this now, but can't, * move d2,printh(a3) as we haven't sorted out the font yet cclrtst btst #0,catstat+1(a0) bne cclrtst cfbclrdone move.b #$3,prr1(a0)  setup pixel repl rule * bsr catseyedvr_loadfonts set up all 3 fonts @ 128 char each * We'll do this from Pascal rts * * misc utilities for initialization * * loadcmap lea cmaptable,a1 initialize the color map moveq #0,d1 clear some registers move.l d1,d2 move.l d1,d3 move.l d1,d4 cmaploop1 move.b (a1)+,d2 get rgb values in d2-d4 move.b (a1)+,d3 move.b (a1)+,d4 bsr cmapenter stuff the color map entry addq #1,d1 bump cmap pointer value cmp #16,d1 have we done 16 yet? bne cmaploop1 if not then continue moveq #-1,d2 set entries 16-255 to white move.l d2,d3 move.l d2,d4 cmaploop2 bsr cmapenter addq #1,d1 cmp #256,d1 done with cmap init? bne cmaploop2 rts csetcolormap equ *   callable from pascal movea.l controladdr(a5),a0 move.l (sp)+,d1 colormap index parameter move.l (sp)+,d2 red value move.l (sp)+,d3 green value move.l (sp)+,d4 blue value cmapenter btst #2,cmstat+1(a0) check for color map busy bne cmapenter loop till bit is clear move d1,cmindex(a0) set pointer register move d2,cmred(a0) stuff the rgb regs move d3,cmgreen(a0) move d4,cmblue(a0) move d5,cmapwrite(a0) hit the write trigger rts done with cmap entry write * * * ginitblock moveq #0,d1 clear some regs moveq #0,d0 move.b 2(a1),d0 get word count to initialize movep 4(a1),d1 form destination offset add.l a0,d1 d1 points to dest addr lea 8(a1),a2 a2 points to first data byte movea.l d1,a4  a4 points to destination btst #0,(a1) is this a bit test block? bne.s ginitbtst if so go handle it ginitloop movep 0(a2),d1 form a data word in d1 move.w d1,(a4)+  move data to the destination addr btst #6,(a1) increment data pointer bne.s ginit1 based on control byte addq #4,a2 ginit1 dbra d0,ginitloop loop till word count exhausted  btst #7,(a1) was this last block? bne.s ginitdone yes -- go return btst #6,(a1) adjust data pointer beq.s ginit2 to point to next init block ginit3 addq #4,a2 ginit2 movea.l a2,a1 a1 points to new init block bra ginitblock do the initialize ginitdone rts ginitbtst moveq #0,d2 handle bit test blocks here move.b 2(a2),d2 d2 = bit # to test ginittst2 move (a4),d3 d3 = data word to test btst #0,(a2) check for sense of test bne.s ginittst3 comp if waiting for 0 not d3 ginittst3 btst d2,d3  check the bit beq ginittst2 if not 1 then loop btst #7,(a1) was this last block? bne ginitdone if so then return bra ginit3 else do next block * * cmaptable equ * initial color map contents (r,g,b) dc.b 0,0,0 0 dc.b 255,255,255 1 dc.b 255,0,0 2 dc.b 255,255,0 3 dc.b 0,255,0  4 dc.b 0,255,255 5 dc.b 0,0,255 6 dc.b 255,0,255 7 dc.b 0,0,0 8 dc.b 204,187,51 9 dc.b 51,170,119 10 dc.b 136,102,170 11 dc.b 204,68,102 12 dc.b 255,102,51 13 dc.b 255,119,0 14 dc.b 221,136,68 15 * * waitforready: wait till window mover done * * waitforready equ * movea.l controladdr(a5),a0 waitmready equ * btst #0,catstat+1(a0) bne.s waitmready rts * * * csavecatenv: preserve CATSEYE registers used by alpha driver * and set up for future cchar and cupdatecursor calls (optimization). * Register contents are stored in CATSEYEDVR stack frame buffer * allocated for that purpose, whose address is passed in. * csavecatenv equ * movea.l (sp)+,a2 save return addr movea.l (sp)+,a1 buffer address move.l a2,-(sp) prepare for regular rts movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 get crtparams ptr lea rugcmd(a0),a2 address of first catseye reg to save waitsave equ * wait for registers idl e btst #0,catstat+1(a0) bne.s waitsave move.w (a2)+,(a1)+ RUGCMD (not on longword boundary) move.l (a2)+,(a1)+ WMWIDTH & WMHEIGHT (now in longwords) * move.l (a2)+,(a1)+ LINEPATT & LINETYPE (not saved) addq #4,a2 instead, skip linepatt & linetype move.l (a2)+,(a1)+ WMSOURCEX & WMSOURCEY move.l (a2)+,(a1)+ WMDESTX & WMDESTY move.w fben1(a0),(a1)+ get other regs * *  the tcwen and tcren registers provide floating * bits when read if all 8 planes are not loaded. * Because writing these registers with more * than one bit set will cause h/w problems, need * to 'and' out the floating bits. 6/2/88 SFB/DEW * move.w tcren1(a0),d0 move.w planemask+2(a3),d2 d2 will hold the adjusted plane lsl.w #8,d2 mask for the tcwen register. and.w d2,d0 move.w d0,(a1)+ * moveq #7,d0 moveq #1,d1 select plane 0 getwrr equ * preserve all 8 wrrs move.b d1,tcren1(a0) address next plane wrr move.b wrr1+1(a0),(a1)+ and save wrr asl  #1,d1 select next plane dbra d0,getwrr * move.w tcwen1(a0),d0 6/2/88 SFB/DEW (see comment above) and.w d2,d0 move.w d0,(a1)+ * move.w vb(a0),(a1)+ move.w trrctl(a0),(a1)+ added save of TRRCTL 5/24/88 SFB/DEW move.w planemode(a0),(a1) * now drop through and set up driver state of CATSEYE * sets up CATSEYE regs to the state we mostly maintain during driver execution, * ready for a cchar call (as it's the most common call) * At entry to setupcchar, a0=controladdr(a5), a3=crtinfo(a5), a5=global ptr, * and return address is on stack setupcchar equ * callable from elsewhere in this code lea rugcmd(a0),a2 set up regs for cchar & cupdatecursor  move.w #doblit,(a2)+ RUGCMD move.l charw(a3),(a2)+ WMWIDTH & WMHEIGHT * move.b lowalphaplane(a3),d0 set up fben1 mask for split * moveq #$ff,d1 alpha and graphics * lsl.l d0,d1  mask is in d1 (d0 <= 7 for CATSEYE) * move.b d1,fben1(a0) move.b #$ff,fben1(a0) move.w alphacolor(a3),d1 prepare wrrs for putting characters * move.w alphacolor(a3),d2 prepare wrrs for putting characters *  lsl d0,d2 according to alphacolor and * and d2,d1 lowalphaplane. d1 is bit mask for move.b d1,tcwen1(a0) for 1s in color. move.b creplrule1(a3),wrr1+1(a0) not d1 move.b d1,tcwen1(a0) now set up for 0s move.b creplrule0(a3),wrr1+1(a0) move.b #0,vb(a0) move.b #0,trrctl(a0) added set not TRRCTL. SFB/DEW 5/24/88 rts * * csetupcchar sets up window mover params without csavecatenv. Meant for * call from Pascal when color or inverse video enhancement enable change. * csetupcchar equ * movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 get crtparams ptr waitcsetup equ * wait for registers idle btst  #0,catstat+1(a0) bne.s waitcsetup bra setupcchar * * * restorecatenv: restore CATSEYE registers used by alpha driver. * Register contents were stored in CATSEYEDVR stack frame buffer * allocated for that purpose, whose address is passed in. * crestorecatenv equ * movea.l (sp)+,a2 save return addr movea.l (sp)+,a1 buffer address move.l a2,-(sp) prepare for regular rts movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 get crtparams ptr lea rugcmd(a0),a2 address of first catseye reg to save waitrestore equ * wait for registers idle btst #0,catstat+1(a0) bne.s waitrestore move.w (a1)+,(a2)+ RUGCMD (not on longwo rd boundary) move.l (a1)+,(a2)+ WMWIDTH & WMHEIGHT (now in longwords) * move.l (a1)+,(a2)+ LINEPATT & LINETYPE (not saved) addq #4,a2 instead, skip linepatt & linetype move.l (a1)+,(a2)+ WMSOURCEX & WMSOURCEY move.l (a1)+,(a2)+ WMDESTX & WMDESTY move.w (a1)+,fben1(a0) restore other regs move.w (a1)+,tcren1(a0) moveq #7,d0 moveq #1,d1 select plane 0 setwrr equ *  restore all 8 wrrs move.b d1,tcwen1(a0) address next plane wrr move.b (a1)+,wrr1+1(a0) and restore wrr asl #1,d1 select next plane dbra d0,setwrr move.w (a1)+,tcwen1(a0) move.w (a1)+,vb(a0) move.w (a1)+,trrctl(a0) added restore of TRRCTL 5/24/88 SFB/DEW move.w (a1),planemode(a0) rts * * * procedure cclearall: clears all of visible area except typeahead * cclearall equ * movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 crtparamrec cclralltst btst #0,catstat+1(a0) bne cclralltst move.b #$ff,tcwen1(a0) to clear on all planes 11/18/88 SFB move #0,wrr1(a0) set repl rule move dispx(a3),wmsourcex(a0) setup x,y move dispy(a3),wmsourcey(a0) move dispx(a3),wmdestx(a0) move dispy(a3),wmdesty(a0) move dispw(a3),wmwidth(a0) set width, height move disph(a3),twmheight(a0) and do move *  don't need to set up for cchar, as cclearall can't be called in * same invocation of driver as cchar rts * * * procedure cchar(ord(char),x,y:shortint); * * note that we place the character in one window move in cchar, *  because setupcchar or csetupcchar has already set up all windowmover replacement * rules on a per plane basis to move 1s and 0s where necessary, as well as * setting up the move height and width to character cell size, * and this is a run-on sentence :-) cchar movea.l (sp)+,a4 return address movea.l controladdr(a5),a0 CATSEYE registers movea.l crtinfo(a5),a3 crtparamrec move.w (sp)+,d0 d0 = dest y char offset mulu charh(a3),d0  d0 = pixel row offset add.w printy(a3),d0 adjust to display window * add.w writeyoffset(a3),d0 pixel y offset of chars * d0 is y-destination move.w (sp)+,d1 d1 = x char offset mulu.w charw(a3),d1 d1 = pixel column offset add.w printx(a3),d1 adjust to display window * add.w writexoffset(a3),d1 pixel x offset of chars * d1 is x-destination moveq #0,d2 clear longword for divide move.w (sp)+,d2 character index cmp.w fb_fontchars(a5),d2 see if char is in frame buf, or RAM bge offscreenchar * font character is somewhere in frame buffer * calculate x,y,plane of fontchar * cppl and cpl precomputed at driver init time, global to catseyedvr * cppl=characters in one fontline rectangle 1 plane deep (characters per * plane line) * cpl=characters in one fontline rectangle n planes deep (characters per * line) * x=fb_fontstartx+(c mod cppl)*charw * =fb_fontstartx+((c mod cpl) mod cppl)*charw * (because cpl=n*cppl, and the code works out shorter this way) * y=fonty+(c div cpl)*fonth *  p=(c mod cpl) div cppl divu.w cpl(a5),d2 move.w d2,d6 c div cpl=y index of fontchar mulu.w charh(a3),d6 add.w fb_fontstarty(a3),d6 d6=font y position move.w #0,d2 blank out lower word, then swap d2 c mod cpl divu.w cppl(a5),d2 (c mod cpl) div cppl=plane of fontchar move.w d2,d7 ori.w #16,d7 d7=plane select for "between planes" move swap d2 (c mod cpl) mod cppl==c mod c ppl mulu.w charw(a3),d2 add.w fb_fontstartx(a3),d2 d2=font x position waitcchar1 equ * wait for windowmover idle btst #0,catstat+1(a0) bne.s waitcchar1 move.b d7,planemode(a0) fontchar source plane to CATSEYE move.w d0,wmdesty(a0) destination y-position to CATSEYE move.w d1,wmdestx(a0) destination x-position to CATSEYE move.w d2,wmsourcex(a0) fontchar source x-position to CATSEYE move.w d6,twmsourcey(a0) fontchar source y-position to CATSEYE * and trigger the move btst #2,highlight(a3) underline? bne.s do_underline jmp (a4) back to caller of cchar do_underline equ * add charh(a3),d0  subq #1,d0 get y pos for underline * move.b lowalphaplane(a3),d1 set up to complement under 1s in color move.w alphacolor(a3),d2 * lsl d1,d2 color adjusted by alpha/graphics split waitcchar2 equ * wait for character finished writing btst #0,catstat+1(a0) bne.s waitcchar2 move.b d2,tcwen1(a0) d2 is bit mask for 1s in color. move.b #10,wrr1+1(a0) complement under the underline move.w d0,wmdesty(a0) move.w #1,twmheight(a0) trigger the one-line underbar move waitcchar3 equ * wait for underline finished writing btst #0,catstat+1(a0) bne.s waitcchar3 move.b creplrule1(a3),wrr1+1(a0) and restore the regs (don't need to move.w charh(a3),wmheight(a0) call setupcchar for this small stuff) offscreenchar equ * jmp (a4) * * * cscrollup; * * scrolls the screen up one line of alpha text * cscrollup movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 move printy(a3),d0 add charh(a3),d0 start one line width down move printh(a3),d1 set up window size sub.w charh(a3),d1 one line less waitscrollup equ * btst #0,catstat+1(a0) bne.s waitscrollup move.b #$ff,tcwen1(a0) ALL planes * DGL planes protected by fben1 move.b #0,planemode(a0) added 11/17/88 SFB/DEW move.b #3,wrr1+1(a0) repl rule to replace move printx(a3),wmsourcex(a0) set up src loc move d0,wmsourcey(a0) move printw(a3),wmwidth(a0) move d1,wmheight(a0) move printx(a3),wmdestx(a0) set up dest. loc move printy(a3),twmdesty(a0) and trigger the move * clear bottom line on screen move maxy(a5),d2 mulu charh(a3),d2 d2 = y offset of bottom line waitscrollup2 equ * btst #0,catstat+1(a0) bne.s waitscrollup2 move.b #0,wrr1+1(a0) repl rule to clear move d2,wmdesty(a0) move charh(a3),twmheight(a0) clear one char line ht bra waitcsetup restore regs for next cchar * rts * * cscrolldown * * scrolls the screen down one text line * cscrolldown movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 move printh(a3),d0 set up window size sub.w charh(a3),d0 one line less waitscrolldn equ * btst #0,catstat+1(a0) bne.s waitscrolldn move.b #$ff,tcwen1(a0) ALL planes * DGL planes protected by fben1 move.b #0,planemode(a0) added 11/17/88 SFB/DEW move.b #3,wrr1+1(a0) setup repl rule move printx(a3),wmsourcex(a0) set up src origin move printy(a3),wmsourcey(a0) move printx(a3),wmdestx(a0) setup dest. origin move charh(a3),wmdesty(a0) move d0,wmheight(a0) move printw(a3),twmwidth(a0) and trigger the move * clear top line on screen waitscrolldn2 equ * btst #0,catstat+1(a0) bne.s waitscrolldn2 move.b #0,wrr1+1(a0) repl rule to clear move printy(a 3),wmdesty(a0) move charh(a3),twmheight(a0) clear one char line ht bra waitcsetup restore regs for next cchar * * cclear(xpos,ypos,nchars:shortint); * -- clears nchars starting at xpos, ypos * -- nchars + xpos must not exceed screenwidth * no range checking is done * cclear equ * movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 movea.l (sp)+,a4 a4 = return address move (sp)+,d1 d4 = number of characters to clear mulu charw(a3),d1 move (sp)+,d3 d3 = y to begin at mulu charh(a3),d3 d3 = y in pixels move (sp)+,d5 d5 = x mulu charw(a3),d5 d5 = x in pixels move.l a4,-(sp) stack return address waitcclear equ * btst #0,catstat+1(a0) bne.s waitcclear move d3,wmdesty(a0) cclear2 move d5,wmdestx(a0) setup dest. x reg move charh(a3),wmheight(a0) setup window size move d1,wmwidth(a0) move.b #$ff,tcwen1(a0) move.b #0,wrr1+1(a0) repl rule to clear move printx(a3),wmsourcex(a0) move printy(a3),twmsourcey(a0) bsr csetupcchar rts * * cupdatecursor(x,y:shortint); * cupdatecursor equ * movea.l crtinfo(a5),a3 movea.l (sp)+,a4 a4 = return addr move (sp)+,d5 y in chars mulu charh(a3),d5 move d5,cursy(a5) y in pixels move (sp)+,d5 x in chars mulu charw(a3),d5 move d5,cursx(a5) x in pixels bsr.s cursoron1 turn on soft cursor jmp (a4) cursoron1 movea.l controladdr(a5),a0 move fb_cursorx(a3),d0  save beside cursor cell add charw(a3),d0 in anticipation of save waitcurson equ * btst #0,catstat+1(a0) bne.s waitcurson move.b #0,planemode(a0) move cursx(a5),wmsourcex(a0) move cursy(a5),wmsourcey(a0) * btst #copy_under_cursor,flags(a3) * beq.s drawcursor move.b #$ff,tcwen1(a0) save all planes of character move.b #3,wrr1+1(a0) sourcerule to save under cursor move d0,wmdestx(a0) move fb_cursory(a3),twmdesty(a0) drawcursor equ * * move.b lowalphaplane(a3),d0 set up mask for split * moveq #$ff,d1 alpha and graphics *  lsl.l d0,d1 mask is in d1 (d0 <= 7 for CATSEYE) * move.w cursorcolor(a3),d2 prepare wrrs for putting cursor * lsl d0,d2 according to cursorcolor and * and d2,d1  lowalphaplane. d1 is bit mask for * 1s in cursor color. move.w cursorcolor(a3),d1 prepare wrrs for putting cursor waitcurson2 equ * btst #0,catstat+1(a0) bne.s waitcurson2  move.b d1,tcwen1(a0) only LSBs of color significant in CATSEYE move.b cursreplrule1(a3),wrr1+1(a0) not.b d1 move.b d1,tcwen1(a0) now set up for 0s move.b cursreplrule0(a3),wrr1+1(a0) move wmsourcex(a0),wmdestx(a0) move wmsourcey(a0),wmdesty(a0) move fb_cursorx(a3),wmsourcex(a0) move fb_cursory(a3),twmsourcey(a0) * don't need to setupcchar, as cupdatecursor never called BEFORE * cchar, except in cbdscrllr/l, which do restore themselves rts cursoroff equ * disable cursor movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 move fb_cursorx(a3),d0 was saved next to cursor cell  add charw(a3),d0 prepare for probable restore waitcursoff equ * btst #0,catstat+1(a0) bne.s waitcursoff move.b #0,planemode(a0) * btst #copy_under_cursor,flags(a3) *   beq.s reversecursor move.b #$ff,tcwen1(a0) restore all planes of character move.b #3,wrr1+1(a0) sourcerule to restore character move d0,wmsourcex(a0) move fb_cursory(a3),wmsourcey(a0)  move cursx(a5),wmdestx(a0) move cursy(a5),twmdesty(a0) bra csetupcchar and prepare for cchar reversecursor equ * * move.b lowalphaplane(a3),d0 set up mask for split * move.b #$ff,d1 alpha and graphics * lsl.l d0,d1 mask is in d1 (d0 <= 7 for CATSEYE) * move.w cursorcolor(a3),d2 prepare wrrs for putting cursor * lsl d0,d2 according to cursorcolor and *  and d2,d1 lowalphaplane. d1 is bit mask for * move.b d1,tcwen1(a0) 1s in cursorcolor. 11/17/88 SFB/DEW * move.w cursreplrule1(a3),wrr1(a0) * not.w d1 * move.b d1,tcwen1(a0) now set up for 0s. 11/17/88 SFB/DEW * move.w cursreplrule0(a3),wrr1(a0) * * move cursx(a5),wmdestx(a0) * move cursy(a5),wmdesty(a0) * move fb_cursorx(a3),wmsourcex(a0) * move fb_cursory(a3),twmsourcey(a0) * rts cshiftleft equ * movea.l crtinfo(a5),a3 move printx(a3),d1 destx for left shift move charw(a3),d0 sourcex for left shift add d1,d0 cshift1 equ * movea.l controladdr(a5),a0 move printw(a3),d2 calculate width of lastline in pixels move charw(a3),d3 mulu #8,d3 lastline ends 8 from right edge sub d3,d2 width of last line move printy(a3),d3 find position of lastline add printh(a3),d3 waitcshift equ * btst #0,catstat+1(a0) bne.s waitcshift move.b #$ff,tcwen1(a0) talk to all wrrs. Added .b 11/17/88 SFB/DEW  move.b #0,planemode(a0) added 11/17/88 SFB/DEW move #3,wrr1(a0) setup replacement rule move d0,wmsourcex(a0) move d3,wmsourcey(a0) move d2,wmwidth(a0) move charh(a3),wmheight(a0) move  d1,wmdestx(a0) move d3,twmdesty(a0) setup destination and trigger bsr waitmready bsr setupcchar because we will do a cchar next rts cshiftright equ * movea.l crtinfo(a5),a3 move printx(a3),d0 src x location move charw(a3),d1 dest x location add d0,d1 bra cshift1 now do same as shift left * procedure cexchange(savearea: windowp; ymin, ymax, xmin, width: shortint); cexchange movea.l (sp)+,a4 a4 = temp return addr movea.l controladdr(a5),a0 movea.l crtinfo(a5),a3 move.w (sp)+,d0 width of window in bytes in d0 move.w (sp)+,d4 d4 = x offset in chars mulu.w charw(a3),d4 d4 = x offset in pixels move.w (sp)+,d5 d5 = ymax move.w (sp)+,d1 d1 = ymin movea.l (sp)+,a1 a1 = ptr to save area move.l a4,-(sp) sub.w d1,d5 addq #1,d5 d5 has # of char rows to move mulu.w charh(a3),d5 now has # of pixel rows to move subi.w #1,d5 setup for outer loop mulu.w charh(a3),d1 d1 = y offset in pixels mulu.w fbwidth(a3),d1 d1 = y address offset  movea.l screen(a5),a4 a4 points to frame buffer start adda.l d1,a4 now points to correct row adda.l d4,a4 do x offset into row waitexchg equ * btst #0,catstat+1(a0) bne.s waitexchg move.b #$ff,tcwen1(a0) added .b 11/17/88 SFB/DEW move.b #3,prr1(a0) setup pixel repl rule all planes cexchg1 lsr.w #2,d0 d0=window width in long integers subq #1,d0 setup for later loop ing cexchg2 movea.l a4,a2 make a working copy move.w d0,d7 initialize inner loop cexchg3 move.l (a2),d6 screen to temp move.l (a1),(a2)+ save area to screen move.l d6,(a1)+  temp to save area dbra d7,cexchg3 inner loop (pixel row move) adda.w fbwidth(a3),a4 bump row pointer dbra d5,cexchg2 outer loop (row count) rts * procedure cscrollwindow( ymin, ymax, xmin, width: shortint); cscrollwindow equ * moveq #0,d6 set upscroll flag in d6 cscrollwindc movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 movea.l (sp)+,a4 a4 = return addr move (sp)+,d1 d1 = width in chars mulu charw(a3),d1 d1 = width in pixels move (sp)+,d0 d0 = x offset of window in chars mulu charw(a3),d0 d0 = x offset in pixels (bytes) add printx(a3),d0 adjusted to diplayable portion of fb move  (sp)+,d2 d2 = ymax move (sp)+,d3 d3 = ymin sub d3,d2 d2 has # of char rows to move mulu charh(a3),d2 now d2 has height to move mulu charh(a3),d3 d3 = y offset in bytes of origin add printy(a3),d3 adjusted to displayable portion of fb tst d6 check up/down flag bne.s cscrollwindb and branch if dn move d3,wmdesty(a0) set ymin to dest y origin add charh(a3),d3 move d3,wmsourcey(a0) one row down is src y origin cscrollwincom move.b #0,planemode(a0) added 11/17/88 SFB/DEW move.b #$ff,tcwen1(a0) added .b 11/17/88 SFB/DEW move #3,wrr1(a0) move d1,wmwidth(a0) setup width reg move d2,wmheight(a0) setup height reg move d0,wmsourcex(a0) setup x coordinates move d0,twmdestx(a0) and trigger move jmp (a4) cscrollwindb move d3,wmsourcey(a0) ymin = src y origin add charh(a3),d3 move d3,wmdesty(a0) one row down is dest y bra cscrollwincom cscrollwinddn equ * moveq #1,d6 set down scroll flag bra cscrollwindc go to common code cdbscrolll equ * moveq  #0,d6 set left scroll flag cdbscrollb movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 movea.l (sp)+,a4 pickup return addr move (sp)+,d1 width in chars subq #1,d1 actual width to move is 1 less mulu charw(a3),d1 width in pixels in d1 move (sp)+,d0 x offset in chars mulu charw(a3),d0 d0 = x offset in pixels add dispx(a3),d0 adjusted for displayable framebuf move (sp)+,d5 d5 = ymax move (sp)+,d3 d3 = ymin sub d3,d5 addq #1,d5 d5 = # char rows to move mulu charh(a3),d5 d5 = # pixel rows to move mulu charh(a3),d3 d3 = y window start offset add dispy(a3),d3 adjusted for displayable framebuf dispx->dispy SFB 11/17/88 tst d6 check left/right flag bne.s cdbscroll2 if right, skip move d0,wmdestx(a0) if left xmin= dest x add charw(a3),d0  move d0,wmsourcex(a0) and src is 1 char to rt cdbscrollc move.b #0,planemode(a0) added 11/17/88 SFB/DEW move #3,wrr1(a0) setup repl rule move d1,wmwidth(a0) setup width reg move d5,wmheight(a0) setup height reg move d3,wmsourcey(a0) y is same for src and dest move d3,twmdesty(a0) and trigger move move.l a4,-(sp) * rts finished! * no longer return because the assumptions made with csavecatenv *  (which is csetupcchar) are no longer valid. * branch to waitcsetup to wait for the shift to finish and then branch * to csetupchar. * DEW/SFB 11/01/88 * bra waitcsetup cdbscroll2 move d0,wmsourcex(a0) xmin is src x for rt move   add charw(a3),d0 move d0,wmdestx(a0) dest is 1 char to rt bra cdbscrollc goto common code cdbscrollr equ * moveq #1,d6 set right shift flag bra cdbscrollb go to common code * procedure cprepdumpline(mybuf:windowp; size:shortint; rowstart:anyptr); * takes the data in the frame buffer at rowstart, for size*8 bytes, and * preps it for graphic output by creating an array of size number of bytes * which has 1 bits where there are non-0 pixels in rowstart array, and 0 bits * elsewhere. This is the format of PCL graphics data. The mybuf pointer * is actually a pointer 8 bytes into a pascal string structure. * the routine detects the last non-0 output byte, and adjusts both the * strlen of the Pascal string, and the ASCII numeric string to that. The * adjustment is done to minimize data transmission to printer, especially * for RS232 printers. * The ASCII string header looks like #27'*bxxxW' where xxx is a * 3-digit number, which reflects the length of FOLLOWING binary data. * called by dumpg in CATCRT - SFB/LAF Jan 26, '88 cprepdumpline equ * move.l (sp)+,a0 return address move.l (sp)+,a3 rowstart move.w (sp)+,d0 size move.l (sp),a1 outbufptr, leave on stack for later move.w d0,d1 copy for adjusting strlen, etc later ext.l d1 ensure MSBs are 0 for later divide move.l d1,d5 keeps track of last non-zero outbuf char movea.l crtinfo(a5),a2 get access to crt description bra.s initcharbuf start up the process preploop equ * move.b (a3)+,d2 prepare to test non-zero pixel and.b planemask+3(a2),d2 mask out "floating" bits in pixel subi.b #1,d2 will set X in CCR if (a3) is zero roxl.b #1,d3 put X into output char buf LSB dbra d4,preploop do it 8 times per out char not.b d3 because X was wrong sense move.b d3,(a1)+ put character into outbuf beq.s initcharbuf if it wasn't empty, then  move.w d0,d5 keep track of last non-empty char initcharbuf equ * move.w #7,d4 8 bits per output char dbra d0,preploop n chars/line move.l (sp)+,a1 recover initial outbufptr, and clr stack sub.w d5,d1 bne.s fixstrlen line has something on it moveq #1,d1 must have min of 1 to force slew (we wish!) fixstrlen equ * move.b d1,-8(a1) stick correct length in strlen of outbuf addi.b #7,-8(a1) and adjust for #27'*bxxxW' header * compute ASCII representation of d1 into longword, with trailing 'W' divu #10,d1 remainder->upper word of d1 move.w d1,d2 ext.l d2 clear MSBs of d2 divu #10,d2 remainder->upper word of d2 swap d2 rol.w #8,d2 clr.w d1 clear LSBs swap d1 or.l d2,d1 ori.l #'000',d1 attach ASCII numeric headers rol.l #8,d1 justify for copy to outbuf ori.b #'W',d1 now have 'xxxW' in longword move.l d1,-4(a1) copy to outbuf jmp (a0) and return end  (* (c) Copyright Hewlett-Packard Company, 1987. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $DEBUG OFF$ $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $stackcheck off$ $ALLOW_PACKED ON$ {{ $search 'INITLOAD','ASM','INIT','SYSDEVS'$ {} { Note that   some of the data structures and some of the code have been commented out. These comments usually represent enhancements I was not allowed to or did not have time to put into the driver. The original intent was to export the "new" data structures by putting them into SYSDEVS. These structures would have provided the access needed by the Internals Programmer to be able to change such quantities as the font loaded, fontsize, planes used by the alpha driver, character positioning (micro-spacing), replacement rules used in writing characters/cursors, etc. The assembly source "CATASM.TEXT" also contains references to these quantities. SFB } {11/17/88 SFB/DEW: bugfixes for the Philips bugs. o fixed the STOP key bug by putting csetupcchar in RECOVER blocks of docrtio and crtdebug. o other fixes were in CATASM. } program initcatseye(OUTPUT,INPUT); module catseyedvr; import sysglobals, asm, misc, sysdevs {, catasm}, fs; export type fontdatatype = packed array[0..maxint] of byte;  fontdataptr = ^fontdatatype; {must point to word boundary } screeninforec = record fbwidth : shortint; {defaults: LCC = 1024, 768 } fbheight : shortint; { HRx = 2048, 1024 }  dispx : shortint; {defaults: LCC = 0, 0 } dispy : shortint; { HRx = 0, 0 } dispw : shortint; {defaults: LCC = 1024, 768 } disph : shortint;  { HRx = 1280, 1024 } printx : shortint; {defaults: LCC = 0, 0 } printy : shortint; { HRx = 0, 0 } printw : shortint; {defaults: LCC = 1024, 752 }  printh : shortint; { HRx = 1280, 1004 } offx : shortint; {defaults: LCC = 0, 768 } offy : shortint; { HRx = 1280, 0 } offw : shortint; {defaults: LCC = 1024, 256 } offh : shortint; { HRx = 768, 1024 } charw : shortint; {defaults: LCC = 8, 16 } charh : shortint; { HRx = 10, 20 } fb_fontstartx : shortint; {defaults: LCC = (0,768) } fb_fontstarty : shortint; { HRx = (1280,0) } fb_font_line_length: shortint; {defaults: LCC = 128 }  { HRx = 64 } fb_fontlines : shortint; {defaults: LCC = 1 } { HRC = 1 } { HRM = 6 }  nfontchars : integer; {default = 3 x 128 } fb_cursorx : shortint; {defaults: LCC = (0, 784) } fb_cursory : shortint; { HRx = (1920,0) } end; type colormap_proc_type = procedure(index : integer; r, g, b : integer); crtiocontrolrec = packed record set_colormap_proc : colormap_proc_type; {sets ANY cmap entry} planes : integer; {1s where planes loaded (bitmap)} alphacolor : shortint; {color for characters. Can be set 0..7 by sending 136..143 to CRT tm, or set to any by setting this field.} cursorcolor : shortint; {default = 2^(-1)} {{ lowalphaplane : byte; {keeps track of lowest plane used  by alpha. All physical planes above this one are used by alpha, and all below it are untouched. (for   DGL's exclusive use) } highlight : shortint; {bit fielded: b8 = inverse, b9 = underline  b10 = flash, b11 = halfbright} creplrule0 : byte; {repl rule for char 0s, 0..15 } creplrule1 : byte; {repl rule for char 1s, 0..15 } cursreplrule0 : byte; {rule for cursor 0s, 0..15 } cursreplrule1 : byte; {rule for cursor 1s, 0..15 } togglealpha, {TRUE=disable alpha planes display when alphastate=TRUE } togglegraphics, {TRUE=disable graphics planes display when graphicstate=TRUE } copy_under_cursor, {TRUE=save char pattern before writing cursor, restore after removing cursor } use_fib_xy, {FALSE=ignore fxpos, fypos from fib} disable_low_ctl, {TRUE=chr(0)..chr(31) not interpreted} disable_hi_ctl, {TRUE=chr(128)..chr(143) not interpreted} copy_to_abuf, {TRUE=copy input to abuf for dump alpha} pad1 : boolean; {filler } end; pcrtparamrec = ^crtparamrec; crtparamrec = record screeninfo : screeninforec; iocontrol : crtiocontrolrec; {capabilities : capability_descriprec;} end; var crtparams : pcrtparamrec; function catseyetype: boolean; implement $include 'CATREGS'$ const catregbytes=38; {increased from 36 to save TRRCTL. SFB/DEW 5/24/88} environc=environ[miscinfo:crtfrec[ nobreak:false,  stupid :false, slowterm:false, hasxycrt:true, haslccrt:FALSE, {INDICATES BITMAP} hasclock:true,  canupscroll:true, candownscroll:true], crttype:0, crtctrl:crtcrec[ rlf:chr(31), ndfs:chr(28), eraseeol:chr(9), eraseeos:chr(11), home:chr(1), escape:chr(0), backspace:chr(8), fillcount:10, clearscreen:chr(0), clearline:chr(0), prefixed:b9[9 of false]], crtinfo:crtirec[ width :128,height:47, crtmemaddr:0, crtcontroladdr:0, keybufferaddr: 0,  progstateinfoaddr: 0, keybuffersize: 119, crtcon: crtconsttype [ 0, 0, 0, 0, 0, 0, 0, 0,0, 0, 0,0],  right{FS}:chr(28), left{BS}:chr(8), down{LF}:chr(10), up{US}:chr(31), badch{?}:chr(63),  chardel{BS}:chr(8),stop{DC3} :chr(19), break{DLE}:chr(16), flush{ACK}:chr(6), eof{ETX}:chr(3), altmode{ESC}:chr(27),    linedel{DEL}:chr(127), backspace{BS}:chr(8), etx:chr(3),prefix:chr(0), prefixed:b14[14 of false], cursormask : 0, spare : 0]]; DEFAULT_ALPHACOLOR=1; var cpl: shortint; cppl: shortint; fb_fontchars: shortint; maxy: shortint; xcurs: shortint; ycurs: shortint; hascolor: boolean; midres: boolean; { CATASM uses all variables above this point. Don't modify.} screenwidth: shortint; screenheight: shortint; maxx: shortint; screensize: shortint; defaulthighlight: shortint; firsttimeinit: boolean; {DEW 01/04/89; DEFECT #FSDdt02039} function cromshort(offset:integer):shortint;external; procedure csetreg(register:integer; value:shortint);external; procedure csavecatenv(anyvar buffer:window);external; procedure crestorecatenv(anyvar buffer:window);external; procedure csetupcchar;external; procedure csetcolormap(indx:integer; r,g,b:integer);external; procedure cchar(c,x,y:shortint);external; procedure cursoroff; external; procedure cscrollup;external; procedure cscrolldown;external; procedure cclear(x,y,n:shortint);external; procedure cupdatecursor(x,y:shortint);external; procedure cbuildtable;external; procedure cshiftleft; external; procedure cshiftright; external; procedure cexchange( savearea: windowp; ymin, ymax, xmin, width: shortint);  external; procedure cscrollwindow( ymin, ymax, xmin, width: shortint); external; procedure cscrollwinddn( ymin, ymax, xmin, width: shortint); external; procedure cdbscrolll( ymin, ymax, xmin, width: shortint); external; procedure cdbscrollr( ymin, ymax, xmin, width: shortint); external; procedure cclearall; external; procedure cputfontchar(x,p,y : shortint; datap : fontdataptr; oddbytes : boolean);external; procedure cprepdumpline(mybuf:windowp; size:shortint; rowstart:anyptr); external; procedure dummy_setcmap(index:integer; r,g,b:integer); begin end; procedure init_crtparams; begin if crtparams=NIL then new(crtparams); with crtparams^, screeninfo, iocontrol do begin charw:=0; charh:=0; fb_fontstartx:=0; fb_fontstarty:=0; fb_font_line_length:=0; fb_fontlines:=0; nfontchars:=0; fb_cursorx:=0; fb_cursory:=0; cursorcolor:=0; {{ lowalphaplane:=0; {} highlight:=0; alphacolor:=1; creplrule0:=0; creplrule1:=3; cursreplrule0:=0; cursreplrule1:=3; togglealpha:=false; togglegraphics:=false; copy_under_cursor:=true; use_fib_xy:=true; disable_low_ctl:=false; disable_hi_ctl:=false; copy_to_abuf:=false; set_colormap_proc:=dummy_setcmap;  end; end; procedure dumpg ; label 1; const gwidth_lcc = 128; gwidth_hrx = 160; gbuffersize = gwidth_hrx + 7; type gbyte = 0..255; row_def = packed array [0..maxint] of gbyte; var row : ^row_def; abyte : byte; gbuffer : string[gbuffersize]; lenstr : string[3]; i,j,rowstart : integer; bitnum, charpos,datalen : shortint; begin row := anyptr(frameaddr); { write(gfiles[4]^,#27'*t150R'); { SET RESOLUTION 150 FOR DESKJET} { write(gfiles[4]^,#27'*t192R'); { SET RESOLUTION 192 FOR QUIETJET} write(gfiles[4]^,#27'*rA'); { initiate graphics sequence } gbuffer:=#27'*bxxxW'; {xxx will be replaced in cprepdumpline by actual number of non-0 bytes in buffer} with crtparams^, screeninfo, iocontrol do begin datalen:=(dispw+7) div 8; rowstart:=0; for j := 0 to disph-1 do begin cprepdumpline(addr(gbuffer[8]), datalen, addr(row^[rowstart])); write(gfiles[4]^,gbuffer); if ioresult <> ord(inoerror) then goto 1; rowstart:=rowstart+fbwidth; end; end; write(gfiles[4]^,#27'*rB'); { terminate graphics sequence } 1: end; procedure doupdatecursor; var stackbuf: packed array[1..catregbytes] of byte; begin csavecatenv(  stackbuf); cursoroff; cupdatecursor(xpos,ypos); crestorecatenv(stackbuf); end; procedure getxy(var x,y: integer); begin x := xpos; y := ypos; end; procedure setxy(x, y: shortint); begin if x>=screenwidth then xpos:=maxx else if x<0 then xpos:=0 else xpos := x; if y>=screenheight then ypos:=maxy else if y<0 then ypos:=0 else ypos := y; end; procedure clear(number: shortint); var x,y: shortint; clearchars: shortint; begin x:=xpos; y:=ypos; while number>0 do begin if maxx-x+1=128 and c<144} begin needs_setup:=false; with crtparams^, iocontrol do if ((c<136) and hascolor) or (not hascolor) then begin {hilite request, color or mono} if ((highlight div 256) mod 2) <> (c mod 2) then begin {for inverse video. Underline is handled in cchar} creplrule1:=3+9*(c mod 2); needs_setup:=true; end; if not hascolor then highlight:=(c-128)*256 else highlight:=((highlight div 2048)*8 + (c-128))*256; end else begin {set color request on color machine} alphacolor:=((c-136) {MOD 8}) + 1; cursorcolor:=alphacolor; highlight:=highlight mod 2048 + (c-136)*4096; needs_setup:=true; end; end; {needs_setup} {Added bug fixes for "STOP" key. Symptom was that color would change to white from whatever it was if "STOP" key hit while idling in CI. Cause was that "Io" character in lower right corner, done by "kbdwaithook" was being interrupted by "STOP", and wasn't setting color back from white to "old" color. Any escape(-20) or escape(-28) from an ISR could also cause this symptom (see "interrupt" routine in POWERUP.TEXT for reasons. The fix is the same in all of docrtio, lineops and crtdebug: in essence we "protect" the H/W setup by setting level 7, then set the level back down to its old value to allow ISRs to execute, if they want. We put a try/recover around the main execution, as we can't afford to stay at level 7 for very long. This allows us to set level back own to old level during I/O, knowing we can restore the previous H/W state, because "STOP", etc will trigger the recover block. We do not try to complete the I/O if a "STOP" key hits during the driver; we merely try to restore the entry state of the CATSEYE H/W and system globals. We do not protect against NMI at all (this is very hard to do.) 2 known "bugs": in the recover block, a second escape occurring before the setintlevel(7) will cause H/W restoration to not be executed, and another escape in the recovery anywhere after the setintlevel(7) and before the if.. then escape(savesc) will cause the first escapecode to be lost. SFB 5/31/88 } procedure docrtio(fp: fibp; request: amrequesttype; anyvar buffer: window; length, position: integer); type cursor_affected_set=set of amrequesttype; const cursor_affected=cursor_affected_set[setcursor, clearunit, writeeol,  startwrite, writebytes]; var stackbuf: packed array[1..catregbytes] of byte; c: char; s: string[1]; savesc, oldlevel: shortint; {to fix stopkey bug. SFB 5/31/88} change_cursor: boolean; {to shorten level 7 lockout time. S  FB 5/31/88} buf: charptr; begin change_cursor:=request in cursor_affected; {precompute for speed. SFB 5/31/88} savesc:=0; {in case driver gets escaped away from, we clean up, then escape with the correct escape code. SFB 5/31/88} oldlevel:=intlevel; {so we can restore level after protecting "atomic operations". SFB 5/31/88} setintlevel(7); {prepare for "atomic operation". SFB 5/31/88} csavecatenv(stackbuf); if change_cursor then begin with crtparams^, iocontrol do alphacolor:=cursorcolor; {KLUGE ALERT! This only works because we define alphacolor and cursorcolor to be always the same. It rescues the alphacolor in the case that an ISR executed during lineops (when alphacolor<>cursorcolor), and did escape(-20), not allowing lineops to put back the global describing alphacolor. It hasn't modified cursorcolor, though, so we can recover alphacolor from it. NOTE: if cursorcolor is ever made accessible outside this driver, this kluge should be removed, or changing cursorcolor will magically change alphacolor. SFB/DEW 5/31/88} cursoroff; end; try {now ensure we get a chance to clean up if "STOP" key hits. SFB 5/31/88} setintlevel(oldlevel); {finish "atomic operation" SFB 5/31/88} ioresult := ord(inoerror); buf := addr(buffer); with crtparams^, iocontrol do case request of setcursor: begin setxy(fp^.fxpos, fp^.fypos); end; {cupdatecursor is called at end of docrtio} getcursor: getxy (fp^.fxpos, fp^.fypos); flush: {do nothing}; unitstatus: kbdio(fp, request, buffer, length, position); clearunit: begin {will not clear screen content, as this is not appropriate} highlight := defaulthighlight; alphacolor:= default_alphacolor; cursorcolor:=alphacolor; creplrule1:=3; csetupcchar;  setxy(0,0); end; readtoeol: begin buf := addr(buf^, 1); buffer[0] := chr(0); while length>0 do begin kbdio(fp, readtoeol, s, 1, 0); if strlen(s)=0 then length := 0  else begin length := length - 1; crtio(fp, writebytes, s[1], 1, 0); buf := addr(buf^, 1); buffer[0] := chr(ord(buffer[0])+1); end; end; end; startread, readbytes: begin while length>0 do begin kbdio(fp, readbytes, buf^, 1, 0); if buf^ = chr(etx) then length := 0 else length := length - 1; if buf^ = eol then crtio(fp, writeeol, buf^, 1, 0)  else crtio(fp, writebytes, buf^, 1, 0); buf := addr(buf^, 1); end; if request = startread then call(fp^.feot, fp); end; writeeol: begin if ypos=maxy then cscrollup; setxy(0, ypos+1); end; startwrite, writebytes: begin while length>0 do begin c:=buf^; buf:=addr(buf^,1); length:=length-1; case c of homechar: setxy(0,0); leftchar: if (xpos = 0) and (ypos>0) then setxy(maxx, ypos-1) else setxy(xpos-1, ypos); rightchar: if (xpos = maxx) and (ypos0 then setxy(xpos, ypos-1); end; downchar: if ypos=maxy then cscrollup else setxy(xpos, ypos+1); bellchar: beep; cteos: clear(screensize-(ypos*screenwidth+xpos)); cteol: clear(screenwidth-xpos); clearscr: begin setxy(0,0); clear(screensize); end; eol: setxy(0, ypos); chr(etx): length:=0; otherwise if (ord(c)>=128) and (  ord(c)<144) then {display enhancement} if needs_setup(ord(c)) then {modified setup} csetupcchar else {didn't modify setup, so do nothing} else {printable char} begin cchar(maptocrt(c),xpos,ypos); if xpos = maxx then begin if ypos = maxy then cscrollup;  setxy(0, ypos+1); end else setxy(xpos+1, ypos); end; end; {case} end; {while} if request = startwrite then call(fp^.feot, fp); end; otherwise ioresult := ord(ibadrequest); end; {case} setintlevel(7); {prepare for "atomic" cleanup operation" SFB 5/31/88} recover {SFB 5/31/88} begin setintlevel(7); {prepare for "atomic" cleanup operation". Possible bug: What if interrupt hits in recover block before setintlevel(7) executes? We would lose chance to restore H/W setup.} savesc:=escapecode; {so we can "transparently" let escape through} csetupcchar; {added 11/17/88 to set up environment for cupdatecursor, in case STOP was hit during scroll, etc, where CATSEYE setup is different. SFB/DEW} end; if change_cursor then {SFB 5/31/88} begin cupdatecursor(xpos,ypos); {no change, but see comment in recover block about csetupcchar. SFB/DEW 11/17/88} end; crestorecatenv(stackbuf); setintlevel(oldlevel); {finish at level we started at. SFB 5/31/88} if savesc<>0 then escape(savesc); {possible bug: what if interrupt hits during intlevel 7? We would never execute this code. SFB 5/31/88} end; {docrtio} procedure lineops(op: crtllops; anyvar position: integer; c: char); var stackbuf: packed array[1..catregbytes] of byte; i,oldhilite,oldcolor,oldrule: shortint; savesc, oldlevel: shortint; {to fix stopkey bug. SFB 5/31/88} sptr: ^string255; begin savesc:=0; {in case driver gets escaped away from, we clean up, then escape  with the correct escape code. SFB 5/31/88} oldlevel:=intlevel; {so we can restore level after protecting "atomic operations". SFB 5/31/88} setintlevel(7); {prepare for "atomic operation". SFB 5/31/88} with crtparams^, iocontrol do begin oldrule:=creplrule1; oldcolor:=alphacolor; oldhilite:=highlight; creplrule1:=3; {no enhancements supported in lastline} alphacolor:=default_alphacolor; {only white in last line} {cursorcolor:=alphacolor; {no cursor in last line} highlight:=defaulthighlight; end; csavecatenv(stackbuf); try {now ensure we get a chance to clean up if "STOP" key hits. SFB 5/31/88} setintlevel(oldlevel); {finish "atomic operation" SFB 5/31/88} case op of cllput: cchar(maptocrt(c), position, screenheight); cllshiftl: begin cshiftleft; cchar(ord(' '), maxx-8, screenheight); end; cllshiftr: begin cshiftright; cchar(ord(' '), 0, screenheight); end; cllclear: cclear(0, screenheight, maxx-7); clldisplay: begin sptr:=addr(position); for i:=1 to strlen(sptr^) do cchar(maptocrt(sptr^[i]), i-1, screenheight); for i:=strlen(sptr^) to (maxx-8) do cchar(ord(' '), i, screenheight); end; putstatus: cchar(ord(c), maxx-7+position, screenheight); end; { of case } setintlevel(7); {prepare for "atomic" cleanup operation" SFB 5/31/88} recover {SFB 5/31/88} begin setintlevel(7); {prepare for "atomic" cleanup operation". Possible bug: What if interrupt hits in recover block before setintlevel(7) executes? We would lose chance to restore H/W setup.} savesc:=escapecode; {so we can   "transparently" let escape through} end; with crtparams^, iocontrol do begin creplrule1:=oldrule; alphacolor:=oldcolor; highlight:=oldhilite; end; crestorecatenv(stackbuf); setintlevel(oldlevel); {finish at level we started at. SFB 5/31/88} if savesc<>0 then escape(savesc); {possible bug: what if interrupt hits during intlevel 7? We would never execute this code. SFB 5/31/88} end; procedure crtdebug(op: dbcrtops; var dbrec: dbcinfo); type cursor_affected_set=set of dbcrtops; const cursor_affected=cursor_affected_set[dbgotoxy, dbscrollup, dbscrolldn, dbscrolll, dbscrollr, dbput, dbclear, dbcline, dbexcg]; type iptr = ^iarray; iarray = array[0..maxint] of shortint; var stackbuf: packed array[1..catregbytes] of byte; {oldalphacolor and oldcursorcolor keep track of alpha and cursor colors separately, because if a linops call is interrupted by another use of the driver, it may have left alphacolor<>cursorcolor, so restoring cursorcolor:= alphacolor at the end of this routine is a Bad Thing. Note also that calling the tm in the middle of the lineops execution may cause a similar problem, as lastline color might be different from alphacolor, and cursorcolor will still == alphacolor. SFB/DEW 5/31/88} i, oldhilite, oldalphacolor, oldcursorcolor, oldrule: shortint; j: integer; savesc, oldlevel: shortint; {to fix stopkey bug. SFB 5/31/88} change_cursor: boolean; {to shorten level 7 lockout time. SFB 5/31/88} tempaddr : integer; begin {Need to do following steps BEFORE csavecatenv, as they will affect driver setup via drop-through to setupcchar} change_cursor:=op in cursor_affected; {precompute for speed. SFB 5/31/88} savesc:=0; {in case driver gets escaped away from, we clean up, then escape with the correct escape code. SFB 5/31/88} oldlevel:=intlevel; {so we can restore level after protecting "atomic operations". SFB 5/31/88} setintlevel(7); {prepare for "atomic operation". SFB 5/31/88} with crtparams^, iocontrol do begin oldrule:=creplrule1; {to restore for later} oldalphacolor:=alphacolor; {ditto} oldcursorcolor:=cursorcolor; {ditto} oldhilite:=highlight; {set up debugger window conditions} highlight:=dbrec.debughighlight; {set relprule to 3 (regular) or 12 (inverse video)} creplrule1:=3+9*((highlight div 256) mod 2); if hascolor then begin {set color according to debugwindow} alphacolor:=((highlight div 4096) mod 8) + 1; cursorcolor:=alphacolor; end; end; {This also sets up color and inverse/forward video in driver, via drop- through to setupcchar} csavecatenv(stackbuf); with dbrec do if change_cursor then begin cursoroff; xcurs:=cursx; ycurs:=cursy; end; try {now ensure we get a chance to clean up if "STOP" key hits. SFB 5/31/88} setintlevel(oldlevel); {finish "atomic operation" SFB 5/31/88} with dbrec do begin case op of dbinfo: with crtparams^.screeninfo do begin savesize:=(xmax-xmin+1)*(ymax-ymin+1)*charw*charh; end; dbgotoxy: begin {Implemented by prior call to cursoroff, and following call to cupdatecursor} end; dbscrollup: begin cscrollwindow( ymin, ymax, xmin, xmax-xmin+1);  cclear(xmin, ymax, xmax-xmin+1); end; dbscrolldn: begin cscrollwinddn(ymin, ymax, xmin, xmax-xmin+1); cclear(xmin, ymin, xmax-xmin+1); end; dbscrolll: begin  cdbscrolll(ymin, ymax, xmin, xmax-xmin+1); for i:=ymin to ymax do cchar (ord(' '), xmax, i); end; dbscrollr: begin cdbscrollr(ymin, ymax, xmin, xmax-xmin+1);    for i:=ymin to ymax do cchar (ord(' '), xmin, i); end; dbhighl: ; { Not implemented for color bitmap displays } dbput: begin if charismapped then cchar( maptocrt(c), cursx, cursy)  else cchar( ord(c), cursx, cursy); end; dbclear: for i:=ymin to ymax do cclear( xmin, i, xmax-xmin+1); dbcline: cclear( cursx, cursy, xmax-cursx+1); dbinit: begin for j:=0 to (savesize div 2)-1 do iptr(savearea)^[j]:=0; cursx:=xmin; cursy:=ymin; areaisdbcrt:=false; charismapped:=false; debughighlight:=0; end; dbexcg: with crtparams^, iocontrol do begin cexchange( savearea, ymin, ymax, xmin, (xmax-xmin+1)*crtparams^.screeninfo.charw); areaisdbcrt:=not areaisdbcrt; if areaisdbcrt then begin if hascolor then {set cursor color according to debugwindow}  cursorcolor:=((highlight div 4096) mod 8) + 1; xcurs:=cursx; ycurs:=cursy; end else begin if hascolor then {set cursor color according to alpha window} cursorcolor:=oldcursorcolor; xcurs:=xpos; ycurs:=ypos; end; end; end; { of case } end; { of with } setintlevel(7); {prepare for "atomic" cleanup operation" SFB 5/31/88} recover {SFB 5/31/88} begin setintlevel(7); {prepare for "atomic" cleanup operation". Possible bug: What if interrupt hits in recover block before setintlevel(7) executes? We would lose chance to restore H/W setup.} savesc:=escapecode; {so we can "transparently" let escape through} csetupcchar; {added 11/17/88 to set up environment for cupdatecursor, in case STOP was hit during scroll, etc, where CATSEYE setup is different. SFB/DEW} end; if change_cursor then  cupdatecursor(xcurs, ycurs);{possibly with new cursor color} {no change, but see comment in recover block about csetupcchar. SFB/DEW 11/17/88} with crtparams^, iocontrol do begin  creplrule1:=oldrule; highlight:=oldhilite; alphacolor:=oldalphacolor; cursorcolor:=oldcursorcolor; end; crestorecatenv(stackbuf); setintlevel(oldlevel); {finish at level we started at. SFB 5/31/88} if savesc<>0 then escape(savesc); {possible bug: what if interrupt hits during intlevel 7? We would never execute this code. SFB 5/31/88} end; { crtdebug procedure } procedure dummy; begin end; procedure loadfont(fax,fay,faw,fah : integer); type barray=packed array[0..maxint] of byte; cursorconstyp=packed array[0..39] of byte; const oddbyte=true; {font ROM contains data only at odd addresses} blk_lcc_cursorconst=cursorconstyp[{255,14 of 129,25 of 255} 126,14 of 255,126,24 of 255];  lcc_cursorconst=cursorconstyp[13 of 0, 2 of 255, 1 of 0,24 of 255]; blk_hrx_cursorconst=cursorconstyp[127, 128, 36 of 255, 127, 128]; hrx_cursorconst=cursorconstyp[34 of 0, 4 of 255, 2 of 0]; spacecurs=cursorconstyp[40 of 0]; var t, id, td, ttd, i, j, nfonts, firstchar, lastchar, mask : integer; tfontc : ^barray; pcursor : fontdataptr; c:char; {REMOVE} begin with crtparams^, screeninfo, iocontrol do begin fb_fontstartx:=fax; {save this info for system use} fb_fontstarty:=fay; fb_font_line_length:=faw; td:=cromshort(hex('3b')); {start of font storage} ttd:=td; tfontc:=anyptr(bitmapaddr+td); nfonts:=tfontc^[0]; nfontchars:=0; {save this info for system use} for i:=1 to nfonts do begin tfontc:=anyptr(bitmapaddr+td); id:=tfontc^[6*(i-1)+2]; if id<>0 then begin ttd:=cromshort(td+4+(i-1)*6); tfontc:=anyptr(bitmapaddr+ttd); charh:=tfontc^[0]; {save this info for for sy  stem use} charw:=tfontc^[2]; {save this info for for system use} firstchar:=tfontc^[6]; lastchar:=tfontc^[8]; cppl:=(faw div charw); cpl:=0; mask:=planes; while mask <> 0 do begin cpl:=cpl+cppl; mask:=mask div 2; end; for j:=firstchar to lastchar do begin {general computations of where font char is located in graphics ROM space, and where it goes in framebuf} cputfontchar(  fax+(nfontchars mod cppl)*charw, (nfontchars mod cpl) div cppl, fay+(nfontchars div cpl)*charh, addr(tfontc^ [10+(j-firstchar)*(1+ord(oddbyte))*((charw+7) div 8)*charh]), oddbyte); nfontchars:=nfontchars+1; end; {for j:=firstchar to lastchar} end; {if id <> 0} end; {for i:=1 to nfonts do} {{ fontproc:=cfontproc; {} fb_fontlines:=((nfontchars-1) div cpl)+1; fb_fontchars:=nfontchars; fb_cursorx:=fax+faw; fb_cursory:=fay; if midres then begin pcursor:=addr(blk_lcc_cursorconst); {{ pcursor:=addr(lcc_cursorconst); {} end else begin {{ pcursor:=addr(hrx_cursorconst); {} pcursor:=addr(blk_hrx_cursorconst); end; cputfontchar(fb_cursorx,-1,fb_cursory,pcursor,false); {cursor pattern} {now clear the saved character, in case it's not yet clear} cputfontchar(fb_cursorx+charw,-1,fb_cursory,addr(spacecurs),false); csetreg(tcwen1,-1); {be nice to later catseye users} csetreg(prr,3*256); {be nice to later catseye users} end; {with crtinfo^.screeninfo} end; {loadfont} procedure getcrtinfo; var stackbuf: packed array[1..catregbytes] of byte; begin with crtparams^, screeninfo, iocontrol do begin cbuildtable; csavecatenv(stackbuf); {to set up cchar} if midres then loadfont(offx,offy,512,offh) else loadfont(offx,offy,740,offh); {} hascolor:=planes<>1; {} alphacolor:=1;  cursorcolor:=alphacolor; { DEW 01/04/89; DEFECT #FSDdt02039 User can programatically adjust screen height/width on bit map displays. This is accomplished by the user changing height and width in syscom^.crtinfo and calling the sysdevs hook, crtinithook. This code used to always copy in environc into syscom, making height/width fixed. Now, if this is not the power up init (new flag firsttimeinit) then use the user supplied values of height and width. Note other values in this record are not examined. To maintain compatibility with bobcat, these values are not reset to their original and correct values either. } if firsttimeinit then begin printh:=((disph-charh) DIV charh)*charh; {should be done in cbuildtable. See note in CATASM. SFB} maxx:=(printw div charw)-1; maxy:=(printh div charh)-1; screenwidth:=maxx+1; screenheight:=maxy+1; end else begin screenwidth :=syscom^.crtinfo.width; screenheight:=syscom^.crtinfo.height; maxx := screenwidth-1; maxy := screenheight-1; printw := (maxx+1)*charw; printh := (maxy+1)*charh; end; screensize:=screenwidth*screenheight; cursreplrule0:=5; cursreplrule1:=6; copy_under_cursor:=true; set_colormap_proc:=csetcolormap; setxy(0,0); cupdatecursor(0,0); crestorecatenv(stackbuf); end; end; procedure catseyeinit; var i: shortint; achar:char; stackbuf: packed array[1..catregbytes] of byte; begin init_crtparams; if firsttimeinit then {DEW 01/04/89; DEFECT #FSDdt02039} syscom^:=environc; idle:=245; { set io char to roman8 value } with syscom^.crtinfo do begin getcrtinfo; height:=screenheight; defaulthighlight:=0; dumpalphahook := dumpg; dumpgraphicshook := dumpg; updatecursorhook:=doupdatecursor; crtiohook:=docrtio; dbcrthook:=crtdebug; crtllhook:=lineops; crtinithook:=catseyeinit; toggle  alphahook:=dummy; togglegraphicshook:=dummy; currentcrt:=bitmaptype; keybuffer^.maxsize:=maxx-8; end; end; function catseyetype:boolean; const newbitmapid=57; {primary id for new bitmap displays} LCCid=5; {Low Cost Catseye secondary id} HRCid=6; {High Resolution Color Catseye secondary id} HRMid=7; {High Resolution Monochrome Catseye secondary id} var ptr: ^shortint; i: shortint; dummy: shortint; found: boolean; begin found:=false; {check DIO I space} ptr:=anyptr(hex('560000')); try dummy:=ptr^; if (dummy mod 128) = newbitmapid then begin ptr:=anyptr(integer(ptr)+20); { look at secondary id } dummy:=ptr^ mod 128; midres:=(dummy=LCCid); if (dummy>=LCCid) and (dummy<=HRMid) then begin  found:=true; bitmapaddr:=integer(ptr)-20; end; end; recover if escapecode<>-12 then escape(escapecode); if found then begin firsttimeinit := true; {DEW 01/04/89; DEFECT #FSDdt02039} catseyeinit; firsttimeinit := false;  {DEW 01/04/89; DEFECT #FSDdt02039} end; catseyetype:=found; end; { catseyetype } end; { of module } import catseyedvr, loader; begin if catseyetype then begin markuser; end; end.  page * * WOODCUT family bit-mapped alpha driver * * Pascal 3.25 version by C. Brett * * In most routines registers are used as follows: * a0 CRT control space base address * a1 scratch *  a2 scratch * a3 CRT information base address * a4 scratch * a5 Global Base used by PAWS * a6 Stack Frame Pointer used by PAWS * a7 stack pointer SP (don't modify) * * d0 scratch * d1 scratch * d2 scratch * d3 scratch * d4 scratch * d5 scratch * d6 scratch * d7  scratch def cscrollup,cscrolldown,cupdatecursor,cchar,cclear def cbuildtable,cshiftleft,cshiftright def cexchange,cscrollwindow,cursoroff def cscrollwinddn,cdbscrolll,cdbscrollr,cclearall def csetcolormap,csetreg,csavewoodenv,crestorewoodenv def cromshort,csetupcchar,cprepdumpline def setupcchar rorg.l 0 refa woodcutdvr,sysdevs refa misc_lockup,misc_lockdown nosyms sprint crtinfo equ woodcutdvr-4 cpl equ crtinfo-2 cppl equ cpl-2 fb_fontchars equ cppl-2 maxy equ fb_fontchars-2 xcurs equ maxy-2 ycurs equ xcurs-2 hascolor equ ycurs-1 midres equ hascolor-1 screenwidth equ midres-2 screenheight equ screenwidth-2 maxx equ screenheight-2 screensize equ maxx-2 defaulthighlight equ screensize-2 controladdr equ sysdevs-86 screen equ sysdevs-90 * OFFSETS FOR CRTPARAMS fbwidth equ 0 fbheight equ 2+fbwidth dispx equ 2+fbheight dispy equ 2+dispx dispw equ 2+dispy disph equ 2+dispw printx equ 2+disph printy equ 2+printx printw equ 2+printy printh equ 2+printw offx equ 2+printh offy equ 2+offx offw equ 2+offy offh equ 2+offw charw equ 2+offh charh equ 2+charw fb_fontstartx equ 2+charh fb_fontstarty equ 2+fb_fontstartx fb_font_line_len equ 2+fb_fontstarty fb_fontlines equ 2+fb_font_line_len nfontchars equ 2+fb_fontlines fb_cursorx equ 4+nfontchars fb_cursory equ 2+fb_cursorx set_colormap_proc equ 2+fb_cursory planemask equ 8+set_colormap_proc alphacolor equ 4+planemask cursorcolor equ 2+alphacolor highlight equ 2+cursorcolor creplrule0 equ 2+highlight creplrule1 equ   1+creplrule0 cursreplrule0 equ 1+creplrule1 cursreplrule1 equ 1+cursreplrule0 flags equ 1+cursreplrule1 togglealpha equ 7 bit number togglegraphics equ 6 bit number copy_under_cursor equ 5 bit number use_fib_xy equ 4 bit number disable_low_ctl equ 3 bit number disable_hi_ctl equ 2 bit number copy_to_abuf equ 1 bit number *pad equ 0 bit number * WOODCUT REGISTER OFFSETS (ADD TO CONTROL BASE ADDRESS) dio2base equ $01000000 -$01FFFFFF 16 Meg (DIO-II Select Code 132) sgcbase equ $02000000 -$02FFFFFF 32 Meg stirom equ $00000000 ashregs equ $00040000 -$0004FFFF refreshrate equ $00050000 refresh rate select (60Hz or 72Hz) alphaplane equ $00050004 not used vramcolor1 equ $00060000 colormask used for rows 0-511 dacregs equ $00060200 vramcolor2 equ $00060400  colormask used for rows 512-1023 beechregs equ $00060600 * $00060800 -$001FFFFF unused framebuffer equ $00200000 -$003FFFFF * $00400000 -$005FFFFF unused *cachedfb equ $00600000 -$007FFFFF unused - HPUX caches this space * $00800000 -$00FFFFFF unused * ASH registers visiblemask equ $00040000 -$00040FFF bits 19-16 only colormask equ $00041000 -$00041FFF bits 19-16 only cursorcontrol0 equ $00042000 cursorcontrol1 equ $00042004 cursoronmask equ $fffb 1111 1111 1111 1011 (and in) cursoroffmask equ $0004 0000 0000 0000 0100 (or in) cursorbusy equ 3 0000 0000 0000 1000 (bit to test) * BEECH registers byteshift equ $00060600 blankandtest equ $00060604 blockmode equ $00060608 pagemode equ $0006060c blueregimage equ $00060610 blueregcursor equ $00060614 maskreg equ $00060618 cursorposition equ $0006061c timingh0 equ $00060620 timingh1 equ $00060624 timingv0 equ $00060628 timingv1 equ $0006062c testvideo equ $00060630 testcursorup equ $00060634 testcursorsh equ $00060638 testvideocount equ $0006063c * common DAC registers dacimagewrite equ $00060202 colormapvalue equ $00060206 * low/medium resolution DAC registers on bt474 pixelreadmask equ $0006020a dacimageread equ $0006020e dacoverlaywrite equ $00060212 dacoverlayregs equ $00060216 * $0006021a reserved dacoverlayread equ $0006021e daccommandreg0 equ $00060222 daccommandreg1 equ $00060226 dacidreg  equ $0006022a value should be $11 for WOODCUT family dacstatusreg equ $0006022e * high resolution DAC registers on bt458 overlaycolor1 equ 2 overlaycolor2 equ 3 readmask equ 4 blinkmask equ 5 commandreg  equ 6 cntlstatreg equ 7 hrdacoverlaywrite equ $0006020e * GRAPHICS ROM OFFSETS framewidth equ $00000005 width of frame buffer frameheight equ $00000009 height of frame buffer displaywidth equ $0000000D width of displayed frame buffer displayheight equ $00000011 height of displayed frame buffer displayid equ $00000015 secondary ID byte initoffset equ $00000023 offset to initialization offset fontoffset  equ $0000003B offset to font info offset framecount equ $0000005B number of frames frameoffset equ $0000005D offset to frame buffer width equ 2048 width is always 2048 on WOODCUT widthdiv16 equ 128 pixels / 16 for block mode * BOOT ROM ADDRESSES sysflag2 equ $FFFFFEDA * USEFUL CONSTANTS * kludge because MOVE16 is 16 byte aligned *   and we don't know where zero16 will be dc.l 0,0,0,0 16 bytes of zeros zero16 dc.l 0,0,0,0 16 bytes of zeros dc.l 0,0,0,0 16 bytes of zeros currentintlevel ds.l 1 current interrupt level hires ds.l 1 hires flag (0 med or low, 1 high) fontstorage ds.b 15360 ((256 + 128) * 16 * 20) / 8 * ******************************************************************* * * misc utilities for initialization * uses register a1 contrary to intro comments * loadcmap lea cmaptable,a1 initialize the color map tst.b hascolor(a5) color? bne cmapstart yes, jump over greyscale lea gmaptable,a1 initialize the greyscale color map cmapstart moveq #0,d1 clear some registers move.l d1,d2 move.l d1,d3 move.l d1,d4 cmaploop1 move.b (a1)+,d2 get rgb values in d2-d4 move.b (a1)+,d3 move.b (a1)+,d4 jsr cmapenter call the color map entry routine addq #1,d1 bump cmap pointer value cmp #16,d1 have we done 16 yet? bne.s cmaploop1 if not then continue moveq #-1,d2 set entries 16-255 to white move.l d2,d3 move.l d2,d4 cmaploop2 jsr cmapenter addq #1,d1 cmp #256,d1 done with cmap init? bne.s cmaploop2 move.l #blueregcursor,d6 move.l #colormapvalue,d7 move.l #dacoverlaywrite,d5 cursorcmapwait btst #0,1(a0,d6.l) check for color map busy bne.s cursorcmapwait loop till bit is clear move.b #2,0(a0,d5.l) write the index to the DAC move.b #0,0(a0,d7.l)  then red to the DAC move.b #0,0(a0,d7.l) then green to the DAC move.b #0,3(a0,d6.l) then blue to BEECH cursorcmapwait2 btst #0,1(a0,d6.l) check for color map busy bne.s cursorcmapwait2 loop till bit is clear move.b #3,0(a0,d5.l) write the index to the DAC move.b #255,0(a0,d7.l) then red to the DAC move.b #255,0(a0,d7.l) then green to the DAC move.b #255,3(a0,d6.l) then blue to BEECH rts cmapenter move.l #blueregimage,d6 move.l #dacimagewrite,d5 move.l #colormapvalue,d7 cmapwait btst #0,1(a0,d6.l) check for color map busy bne.s cmapwait loop till bit is clear move.b d1,0(a0,d5.l) write the index to the DAC move.b d2,0(a0,d7.l) then red to the DAC move.b d3,0(a0,d7.l) then green to the DAC move.b d4,3(a0,d6.l) then blue to BEECH rts done with cmap entry write * ************************************************************************* * * font unpacking routines (unpacking moved to cchar) * a2 points to font ROM * a3 points to crtinfo * a4 points to font storage *  d3 number of characters * unpkroman equ * moveq #0,d0 move.l d0,d1 move charw(a3),d0 move charh(a3),d1 addq #7,d0 round off to the nearest byte andi.b #$f8,d0 to fix HIRES  24OCT91 - CFB mulu d0,d1 number of pixels/char lsr #3,d1 number of bytes/char subq #1,d1 subtract 1 to make loop correct unpackchar move.l d1,d5 unpack d1 bytes/char unpackrow move.b (a2),(a4)+ copy over byte addq.l #2,a2 look at next font byte dbra d5,unpackrow and loop till bytes in char done dbra d3,unpackchar loop till all chars done rts * ************************************************************************* * * ginit routines * ginitblock moveq #0,d1 clear some regs moveq #0,d0 move.b 2(a1),d0 get word count to initialize m ovep 4(a1),d1 form destination offset add.l a0,d1 d1 points to dest addr lea 8(a1),a2 a2 points to first data byte movea.l d1,a4 a4 points to destination btst #0,(a1) is this a bit test block? bne.s ginitbtst if so go handle it ginitloop movep 0(a2),d1 form a data word in d1 move.w d1,(a4)+ move data to the destination addr btst #6,(a1) increment data pointer bne.s ginit1 based on control byte addq #4,a2 ginit1 dbra d0,ginitloop loop till word count exhausted btst #7,(a1) was this last block? bne.s ginitdone yes -- go return btst #6,(a1)  adjust data pointer beq.s ginit2 to point to next init block ginit3 addq #4,a2 ginit2 movea.l a2,a1 a1 points to new init block bra ginitblock do the initialize ginitbtst  moveq #0,d2 handle bit test blocks here move.b 2(a2),d2 d2 = bit # to test ginittst2 move (a4),d3 d3 = data word to test btst #0,(a2) check for sense of test bne.s ginittst3  comp if waiting for 0 not d3 ginittst3 btst d2,d3 check the bit beq ginittst2 if not 1 then loop btst #7,(a1) was this last block? bne.s ginitdone if so then return bra ginit3 else do next block ginitdone rts * ************************************************************************* * * variable initialization and font table building routines * cbuildtable movea.l controladdr(a5),a0  get pointer to ROM start movea.l crtinfo(a5),a3 crtparamrec movep initoffset(a0),d1 form pointer to init block movea.l a0,a1 make copy of ROM start addr adda.l d1,a1 a1 points to init info now jsr ginitblock call the initialization routine clr.b hascolor(a5) clear color flag cmpi.b #17,displayid(a0) greyscale? bgt cframeaddr yes, don't set color st hascolor(a5) set for color cframeaddr movea.l a0,a1 make copy of ROM start addr adda.l #framebuffer,a1 add offset to frame buffer move.l a1,screen(a5) form frame buffer addr move.b framecount(a0),d0 d0=# of planes in system beq.s cnumplanes if zero then read planes moveq #8,d1 else make the mask up moveq #$ff,d2 sub d0,d1 d1 has shift count lsr.b d1,d2 after shift d2 has mask bra.s csetplanes go setup planemask cnumplanes moveq #0,d2 determine how many planes movea.l screen(a5),a1 addr of fb in a1 move.b #$FF,(a1) write all 1's move.b (a1),d2  read it back to get plane mask csetplanes move.l #0,planemask(a3) clear full 32 bits move.b d2,3+planemask(a3) save as plane mask cnocolor2 moveq #0,d0 move.l d0,hires clear hires flag move d0,dispx(a3) set positions to (0,0) move d0,dispy(a3) move d0,printx(a3) move d0,printy(a3) movep.w framewidth(a0),d2 get width from ROM move d2,fbwidth(a3) movep.w displaywidth(a0),d2 set visible width as window width movep.w frameheight(a0),d2 get height from ROM move d2,fbheight(a3) movep.w displayheight(a0),d2 move d2,disph(a3) movep.w displaywidth(a0),d2 move d2,dispw(a3) move d2,printw(a3) cmp #1024,d2 beq.s setuplcc cmp #640,d2 no offscreen available beq.s setupvga setuphrx equ * offscreen available to right move #1280,offx(a3) move #0,offy(a3) move #768,offw(a3) move #1024,offh(a3) st hires   set hires flag bra.s donesetupoff setuplcc equ * no offscreen available move #0,offx(a3) move #0,offy(a3) move #0,offw(a3) move #0,offh(a3) bra.s donesetupoff setupvga equ * offscreen available to right move #640,offx(a3) and at the bottom. right larger move #0,offy(a3) move #384,offw(a3) move #512,offh(a3) donesetupoff equ * jsr loadcmap  load the color map moveq #0,d0 move.l d0,d1 move.l d0,d2 move.l d0,d7 movep fontoffset(a0),d1 get font info offset move.b (a0,d1.w),d7 d3 = number of fonts subq #1,d7 subtract 1 to make loop correct lea 4(a0,d1.w),a1 a1 = address of font offset lea (fontstorage),a4 a4 = address of font storage getfontinfo movep 0(a1),d2 d2 = offset to font info lea 0(a0,d2.l),a2 a2 = address of font info moveq #0,d1 clear d1 for re-use move.b (a2),d0 d0 = font height move.b 2(a2),d1 d1 = font width move d0,charh(a3) store them for later use move d1,charw(a3) moveq  #0,d3 move.b 8(a2),d3 get last char value sub.b 6(a2),d3 subtract first char value * d3 = number of chars in font adda.l #10,a2 a2 now points to first char jsr unpkroman go unpack it adda.l #6,a1 a1 = address of next font dbra d7,getfontinfo buildcursor equ * jsr cursoroff move.l #cursorcontrol1,d2 move.l #colormask,d0 write to the cursor image move.l #1023,d1 clear the entire cursor buildcursorclr btst #cursorbusy,1(a0,d2.l) wait until the cursor not busy bne.s buildcursorclr move #0,0(a0,d0.l) addq.l #4,d0 dbra d1,buildcursorclr move.l #colormask,d0 create cursor image moveq #1,d4 2 rows buildcursorclr3 moveq #1,d3 2 nybbles wide move.l d0,d1 beginning of row buildcursorclr2 btst #cursorbusy,1(a0,d2.l) wait until the cursor not busy bne.s buildcursorclr2 move #-1,0(a0,d1.l) addq.l #4,d1 next 4 pixels dbra d3,buildcursorclr2 tst hires beq buildcursorclr1 move #$000c,0(a0,d1.l) buildcursorclr1 addi.l #64,d0 next row dbra d4,buildcursorclr3 move.l #visiblemask,d0 write to the cursor mask move.l #1023,d1 clear the entire mask buildcursorvis btst #cursorbusy,1(a0,d2.l) wait until the cursor not busy bne.s buildcursorvis move #0,0(a0,d0.l) addq.l #4,d0 dbra d1,buildcursorvis move.l #visiblemask,d0 create "cookie cutter" moveq #1,d4 2 rows buildcursorvis3 moveq #1,d3 8 nybbles wide move.l d0,d1 beginning of row buildcursorvis2 btst #cursorbusy,1(a0,d2.l) wait until the cursor not busy bne.s buildcursorvis2 move #-1,0(a0,d1.l) addq.l #4,d1 next 4 pixels dbra d3,buildcursorvis2  tst hires beq buildcursorvis1 move #$000c,0(a0,d1.l) buildcursorvis1 addi.l #64,d0 next row dbra d4,buildcursorvis3 move.l #cursorcontrol0,d0 move.l #0,0(a0,d0.l) clear y-clip LSB's move.l #cursorcontrol1,d0 andi #$000c0,0(a0,d0.l) clear y-clip MSB's jsr cursoron move.l #readmask,d2 move.b #255,0(a0,d2) turn on all planes rts * **************************************************************** * * cmaptable  equ * initial color map contents (r,g,b) dc.b 0,0,0 0 dc.b 255,255,255 1 dc.b 255,0,0 2 dc.b 255,255,0 3 dc.b 0,255,0 4 dc.b 0,25 5,255 5 dc.b 0,0,255 6 dc.b 255,0,255 7 dc.b 0,0,0 8 dc.b 204,187,51 9 dc.b 51,170,119 10 dc.b 136,102,170 11 dc.b 204,68,102 12 dc.b 255,102,51 13 dc.b 255,119,0 14 dc.b 221,136,68 15 gmaptable equ * initial greyscale color map contents (r,g,b) dc.b 0,0,0 0 dc.b 0,255,0 1 dc.b 0,239,0 2 dc.b 0,233,0 3 dc.b 0,207,0 4 dc.b 0,191,0 5 dc.b 0,175,0 6 dc.b 0,159,0 7 dc.b 0,143,0 8 dc.b 0,128,0 9 dc.b 0,112,0 10 dc.b 0,96,0 11 dc.b 0,80,0 12 dc.b 0,64,0 13 dc.b 0,48,0 14 dc.b 0,32,0 15 dc.b 0,16,0 16 * * end of misc utilities **************************************************************** * * procedure cscrollup * scroll up one line * cscrollup movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 moveq #0,d0 move.l d0,d1 move.l d0,d2 move.l d0,d3 move printy(a3),d0 move printh(a3),d1 set up window size sub charh(a3),d1 one less row sub d0,d1 d1 = number of rows subq #1,d1 subtract 1 to make loop correct mulu #width,d0 d0 = address of first row movea.l screen(a5),a1 get base address of framebuffer adda.l d0,a1  a1 = destination row move charh(a3),d3 mulu #width,d3 number of rows per line height move printw(a3),d2 lsr #2,d2 number of longs per line movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 move.l #pagemode,d7 turn on page mode move.l #0,0(a0,d7.l) btst #3,sysflag2 test for 68040 to use move16 bne cscroll68030 * 68040 section lsr #2,d2 number of move16's subq #1,d2 subtract 1 to make loop correct cscrollnextrow move.l d2,d4 reset column counter movea.l a1,a2 set up destination address movea.l a1,a4 adda.l d3,a4 set up source address cscrollnextword move16 (a4)+,(a2)+ move from one line to the other dbra d4,cscrollnextword and loop adda.l #width,a1 increment row by width dbra d1,cscrollnextrow and loop again move charh(a3),d1 set up to clear next line subq #1,d1 cscrollclrrow move.l d2,d4 reset column counter movea.l a1,a2 cscrollclrword move16 zero16,(a2)+ clear line dbra d4,cscrollclrword and loop adda.l #width,a1 increment row by width dbra d1,cscrollclrrow and loop again bra cscrollpageoff * 68030 section cscroll68030 subq #1,d2  subtract 1 to make loop correct cscrollnextrow2 move.l d2,d4 reset column counter movea.l a1,a2 set up destination address movea.l a1,a4 adda.l d3,a4 set up source address cscrollnextword2 move.l (a4)+,(a2)+ move from one line to the other dbra d4,cscrollnextword2 and loop adda.l #width,a1 increment row by width dbra d1,cscrollnextrow2 and loop again move charh(a3),d1  set up to clear next line subq #1,d1 cscrollclrrow2 move.l d2,d4 reset column counter movea.l a1,a2 cscrollclrword2 move.l #0,(a2)+ clear line dbra d4,cscrollclrword2 and loop adda.l #width,a1   increment row by width dbra d1,cscrollclrrow2 and loop again cscrollpageoff move.l #pagemode,d7 turn off page mode move.l #1,0(a0,d7.l) jsr misc_lockdown enable STOP key rts * **************************************************************** * * procedure cscrolldown * scroll down one line * cscrolldown movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 moveq #0,d0 move.l d0,d1 move.l d0,d2 move.l d0,d3 move printh(a3),d0 get last row sub charh(a3),d0 start one line height up move d0,d1 set up window size sub printy(a3),d1 d1 = number of rows subq #1,d1 subtract 1 to make loop correct mulu #width,d0 d0 = address of last row movea.l screen(a5),a1 get base address of framebuffer adda.l d0,a1 a1 = source row move charh(a3),d3 mulu #width,d3  number of rows per line height move printw(a3),d2 lsr #2,d2 number of longs per line movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 move.l #pagemode,d7  turn on page mode move.l #0,0(a0,d7.l) btst #3,sysflag2 test for 68040 to use move16 bne cscrolld68030 * 68040 section lsr #2,d2 number of move16's subq #1,d2 cscrolldnextrow move.l d2,d4 reset column counter movea.l a1,a2 movea.l a1,a4 adda.l d3,a4 set up source address cscrolldnextword move16 (a2)+,(a4)+ move from one line to the other dbra d4,cscrolldnextword and loop suba.l #width,a1 decrement row by width dbra d1,cscrolldnextrow and loop again move charh(a3),d1 set up to clear next line subq #1,d1 cscrolldclrrow move.l d2,d4 reset column counter movea.l a1,a2 cscrolldclrword move16 zero16,(a2)+ move from one line to the other dbra d4,cscrolldclrword and loop adda.l #width,a1 decrement row by width dbra d1,cscrolldclrrow and loop again bra cscrolldpageoff * 68030 section cscrolld68030 subq #1,d2 cscrolldnextrow2 move.l d2,d4 reset column counter movea.l a1,a2 movea.l a1,a4 adda.l d3,a4 set up source address cscrolldnextword2 move.l (a2)+,(a4)+ move from one line to the other dbra d4,cscrolldnextword2 and loop suba.l #width,a1 decrement row by width dbra d1,cscrolldnextrow2 and loop again move charh(a3),d1  set up to clear next line subq #1,d1 cscrolldclrrow2 move.l d2,d4 reset column counter movea.l a1,a2 cscrolldclrword2 move.l #0,(a2)+ move from one line to the other dbra d4,cscrolldclrword2 and loop adda.l #width,a1 decrement row by width dbra d1,cscrolldclrrow2 and loop again cscrolldpageoff move.l #pagemode,d7 turn off page mode move.l #1,0(a0,d7.l) jsr misc_lockdown enable STOP key  rts * ******************************************************************** * * procedure cupdatecursor(xpos,ypos:shortint); * positions cursor on screen at (x,y) cupdatecursor movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 moveq #0,d0 clear some registers move.l d0,d1 move.l d0,d2 move.l d0,d3 move.l d0,d4 movea.l (sp)+,a4 a4 = return addr move (sp)+,d1 y in chars move (sp)+,d2 x in chars move.l a4,-(sp) stack return address mulu charh(a3),d1 add charh(a3),d1 put cursor under the character subq #1,d1 move.l #timingv0,d3 add 0(a0,d3.l),d1 add yoffset (see WOODCUT ERS ) move d1,ycurs(a5) y position in pixels mulu charw(a3),d2 move.l #timingh0,d3 move 0(a0,d3.l),d4 subq #4,d4 lsl #2,d4 multiply by 4 add d4,d2 add xoffset (see WOODCUT ERS)  move d2,xcurs(a5) x position in pixels * added test for cursor status to keep cursor from appearing when it is off * to begin with 25OCT91 - CFB move.l #cursorcontrol1,d0 btst #2,1(a0,d0.l) bne donttoggle jsr cursoroff move.l #cursorposition,d3 update cursor position move d1,0(a0,d3.l) move d2,2(a0,d3.l) jsr cursoron rts donttoggle move.l #cursorposition,d3 update cursor position move d1,0(a0,d3.l) move d2,2(a0,d3.l) rts * ******************************************************************** * * procedure cchar(ord(char),xpos,ypos:shortint); * places character on screen at (x,y) cchar movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 movea.l (sp)+,a1 get the return address moveq #0,d0 clear some registers move.l d0,d1 move.l d0,d2 move.l d0,d4 move.l d0,d5 move (sp)+,d0 y coordinate in rows move (sp)+,d1 x coordinate in chars move (sp)+,d2 character to write move.l a1,-(sp) put the return address back lea (fontstorage),a2 get font base address move charh(a3),d4 d4 = font height move charw(a3),d5 d5 = font width mulu d4,d0 d0 = y coordinate in pixels mulu d5,d1 d1 = x coordinate in pixels mulu d4,d2 char # times height addq #7,d5 round off to the nearest byte andi.b #$f8,d5 to fix HIRES 24OCT91 - CFB mulu d5,d2 times width lsr.l #3,d2 / 8 -> font offset move.l d0,d3 start with row number mulu #width,d3 times row width add d1,d3 plus column number addi.l #framebuffer,d3 plus frame buffer base movea.l a0,a4 adda.l d3,a4 now a4 has address of FB suba #width,a4 add back later subq #1,d4 subtract 1 to make loop correct move charw(a3),d5 d5 = font width subq #1,d5 moveq #0,d1 re-use d1 for alpha color mask move alphacolor(a3),d1 get color (will only be a byte) move.l #maskreg,d6 move.l #-1,0(a0,d6.l) enable writes to all planes adda.l d2,a2 a2 = char start addr movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup  disable STOP key movem.l (sp)+,d0-d7/a0-a5 ccharnextrow adda.l #width,a4 beginning of frame buffer row movea.l a4,a1 make copy to be incremented move.l d5,d6 moveq #0,d7 clear d7 for subtract at dbra ccharnextcol dbra d7,ccharnextbit still have bits?, don't reset moveq #7,d7 all done?, reset to bit 7 move.b (a2)+,d3 get next byte of packed font ccharnextbit moveq #0,d0  clear d0 btst d7,d3 test bit in font sne d0 set d0 if not 0 btst #0,highlight(a3) inverse video? beq.s ccharputchar no, skip over invert not.b d0 ccharputchar and.b d1,d0 and in color mask move.b d0,(a1)+ write to frame buffer dbra d6,ccharnextcol dbra d4,ccharnextrow btst #2,highlight(a3) underline? bne.s dounderline yes, do the underline jsr misc_lockdown enable STOP key rts dounderline btst #0,highlight(a3) inverse video? beq.s dounderline1 no, skip over invert moveq #0,d1 make underline pen 0 dounderline1 moveq  #0,d5 move charw(a3),d5 d5 = font width subq #1,d5 subtract 1 to make loop correct dounderline2 move.b d1,-(a1) underline going backward dbra d5,dounderline2 jsr misc_lockdown  enable STOP key rts * ******************************************************************** * * cclear(xpos,ypos,nchars:shortint); * -- clears nchars starting at xpos, ypos * -- nchars + xpos must not exceed screenwidth * no range checking is done * cclear movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 moveq #0,d1 move.l d1,d2 move.l d1,d3 movea.l (sp)+,a1 return address move (sp)+,d1  d1 = number of chars to clear move (sp)+,d2 d2 = y to begin at move (sp)+,d3 d3 = x to begin at move.l a1,-(sp) put back the return address mulu charw(a3),d1 d1 = length in pixels lsr #1,d1 length in long words mulu charh(a3),d2 d2 = y in pixels mulu charw(a3),d3 d3 = x in pixels move.l #vramcolor1,d7 move.l #0,0(a0,d7.l) set color registers to 0 move.l #maskreg,d7 move.l #-1,0(a0,d7.l) to clear on all planes move.l screen(a5),a1 base address of FB mulu #width,d2 multiply row * width adda.l d2,a1 add to the FB address adda.l d3,a1  add on the column moveq #0,d2 move charh(a3),d2 d2 = # of rows subq #1,d2 subq #1,d1 subtract 1 to make loop correct movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 cclearnextrow move.l d1,d4 reset column counter movea.l a1,a2 reset to next line cclearnextword move.w #0,(a2)+ write to the display dbra d4,cclearnextword and loop adda.l #width,a1 increment row by width dbra d2,cclearnextrow and loop again jsr misc_lockdown enable STOP key rts * ************************************************************************ * * procedure shiftleft * cshiftleft movea.l crtinfo(a5),a3 moveq #0,d1 move.l d1,d2 move.l d1,d3 move printw(a3),d2 calculate width of lastline move charw(a3),d3 mulu #8,d3 lastline ends 8 from right edge sub d3,d2 width of last line lsr #1,d2 d2 = width in words move printy(a3),d3 start at upper y add printh(a3),d3 add print height -> last row mulu #width,d3  offset address of last line add printx(a3),d3 add on column movea.l screen(a5),a1 get base address of framebuffer adda.l d3,a1 a1 = destination address move charh(a3),d1 d1 = number of rows moveq #0,d3 move charw(a3),d3 d3 = width of char subq #1,d1 subtract 1 to make loop correct subq #1,d2 movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 cshiftlnextrow move.w d2,d4 reset column counter movea.l a1,a2 cshiftlnextword move.w 0(a2,d3),(a2)+ move from one word to the other dbra d4,cshiftlnextword and loop adda.l #width,a1 next row dbra d1,cshiftlnextrow and loop jsr misc_lockdown enable STOP key rts * ************************************************************************ * * procedure shiftright * cshiftright movea.l crtinfo(a5),a3  moveq #0,d1 move.l d1,d2 move.l d1,d3 move printw(a3),d2 calculate width of lastline move charw(a3),d3 mulu #9,d3 lastline ends 9 from right edge sub d3,d2 width of last line mo ve printy(a3),d3 start at upper y add printh(a3),d3 add print height -> last row mulu #width,d3 offset address of last line add printx(a3),d3 add on column add d2,d3 add width lsr #1,d2 d2 = width in words movea.l screen(a5),a1 get base address of framebuffer adda.l d3,a1 a1 = destination address move charh(a3),d1 d1 = number of rows moveq #0,d3 move charw(a3),d3 d3 = width of char subq #1,d1 subtract 1 to make loop correct movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 cshiftrnextrow move.l  d2,d4 reset column counter movea.l a1,a2 cshiftrnextword move.w (a2),0(a2,d3) move from one word to the other subq #2,a2 dbra d4,cshiftrnextword and loop adda.l #width,a1 next row dbra d1,cshiftrnextrow and loop jsr misc_lockdown enable STOP key rts * ************************************************************************ * * procedure cexchange( savearea: windowp; ymin, ymax, xmin, width: shortint) * cexchange movea.l crtinfo(a5),a3 moveq #0,d0 move.l d0,d1 move.l d0,d2 move.l d0,d3 movea.l (sp)+,a1 return address move.w (sp)+,d2 width in pixels move.w (sp)+,d3 xmin move.w (sp)+,d1  ymax move.w (sp)+,d0 ymin movea.l (sp)+,a2 pointer to the window move.l a1,-(sp) stack return address mulu charh(a3),d0 d0 = first row in pixels mulu charh(a3),d1  d1 = last row in pixels sub d0,d1 d1 = number of rows add charh(a3),d1 don't forget last row subq #1,d1 subtract 1 to make loop correct mulu charw(a3),d3 x offset in pixels mulu #width,d0 add.l d3,d0 d0 = address of first row movea.l screen(a5),a1 get base address of framebuffer adda.l d0,a1 a1 = source address lsr #1,d2 number of words per line subq #1,d2 subtract 1 to make loop correct movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 cexchangenextrow move.l d2,d4 reset column counter  movea.l a1,a4 cexchangenextword move.w (a4),d7 move display to temp space move.w (a2),(a4)+ replace display with save move.w d7,(a2)+ replace save with temp dbra d4,cexchangenextword and loop adda.l #width,a1 increment row by width dbra d1,cexchangenextrow and loop again jsr misc_lockdown enable STOP key rts * ************************************************************************ * * procedure cscrollwindow( ymin, ymax, xmin, width: shortint) * cscrollwindow movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 moveq #0,d0 move.l d0,d1 move.l d0,d2 move.l d0,d3 movea.l (sp)+,a1 return address move.w (sp)+,d2 width in characters move.w (sp)+,d3 xmin in characters move.w (sp)+,d1 ymax in lines move.w (sp)+,d0 ymin in lines move.l a1,-(sp) stack return address sub d0,d1 d1 = number of rows - 1 tst d1 beq cscrollwinrts 1 line window mulu charh(a3),d0 d0 = first row in pixels mulu charh(a3),d1 d1 = number of rows in pixels subq #1,d1  subtract 1 to make loop correct mulu charw(a3),d3 x offset in pixels mulu charw(a3),d2 x width in pixels mulu #width,d0 add.l d3,d0 d0 = address of first row movea.l screen(a5),a1   get base address of framebuffer adda.l d0,a1 a1 = destination row moveq #0,d3 reuse d3 move charh(a3),d3 mulu #width,d3 number of rows per line height lsr #2,d2  number of longs per line movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 move.l #pagemode,d7 turn on page mode move.l #0,0(a0,d7.l) btst #3,sysflag2 test for 68040 to use move16 bne cscrollwin68030 * 68040 section lsr #2,d2 number of move16's subq #1,d2 subtract 1 to make loop correct cscrollwinnextrow move.l d2,d4 reset column counter movea.l a1,a2 set up destination address movea.l a1,a4 adda.l d3,a4 set up source address cscrollwinnextword move16 (a4)+,(a2)+ move from one line to the other dbra d4,cscrollwinnextword and loop adda.l #width,a1 increment row by width dbra d1,cscrollwinnextrow and loop again bra cscrollwinpageoff * 68030 section cscrollwin68030 subq #1,d2 subtract 1 to make loop correct cscrollwinnextrow2 move.l d2,d4 reset column counter movea.l a1,a2 set up destination address movea.l a1,a4 adda.l d3,a4 set up source address cscrollwinnextword2 move.l (a4)+,(a2)+ move from one line to the other dbra d4,cscrollwinnextword2 and loop adda.l #width,a1 increment row by width dbra d1,cscrollwinnextrow2 and loop again cscrollwinpageoff move.l #pagemode,d7 turn off page mode move.l #1,0(a0,d7.l) jsr misc_lockdown enable STOP key cscrollwinrts rts * ************************************************************************ * * procedure cursoroff * cursoroff movea.l controladdr(a5),a0 move.l #cursorcontrol1,d0 ori #cursoroffmask,0(a0,d0.l) rts * ************************************************************************ * * procedure cursoron * cursoron movea.l controladdr(a5),a0 move.l #cursorcontrol1,d0 andi #cursoronmask,0(a0,d0.l) rts * ************************************************************************ * * procedure cscrollwinddn( ymin, ymax, xmin, width: shortint) * cscrollwinddn movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 moveq #0,d0 move.l d0,d1 move.l d0,d2 move.l d0,d3 movea.l (sp)+,a1 return address move.w (sp)+,d2 width in characters move.w (sp)+,d3 xmin in characters move.w (sp)+,d1 ymax in lines move.w (sp)+,d0 ymin in lines move.l a1,-(sp) stack return address move.l d1,d4 sub d0,d4 number of lines-1 tst d4 beq cscrollwindnrts 1 line window mulu charh(a3),d4 d4 = number of rows in pixels subq #1,d4 subtract 1 to make loop correct move.l d4,d0 d0 = number of rows-1 addq #1,d1 1 more line down mulu charh(a3),d1 d1 = last row in pixels subq #1,d1 1 row up (last row of dest) mulu charw(a3),d3 x offset in pixels mulu charw(a3),d2 x width in pixels mulu #width,d1 add.l d3,d1  d1 = address of last row movea.l screen(a5),a1 get base address of framebuffer adda.l d1,a1 a1 = destination row moveq #0,d3 reuse d3 move charh(a3),d3 mulu #width,d3  number of rows per line height lsr #2,d2 number of longs per line movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 move.l #pagemode,d7 turn on page mod e move.l #0,0(a0,d7.l) btst #3,sysflag2 test for 68040 to use move16 bne cscrollwindn68030 * 68040 section lsr #2,d2 number of move16's subq #1,d2 subtract 1 to make loop correct cscrollwindnnextrow move.l d2,d4 reset column counter movea.l a1,a2 set up destination address movea.l a1,a4 suba.l d3,a4 set up source address cscrollwindnnextword move16 (a4)+,(a2)+ move from one line to the other dbra d4,cscrollwindnnextword and loop suba.l #width,a1 decrement row by width dbra d0,cscrollwindnnextrow and loop again bra cscrollwindnpageoff * 68030 section cscrollwindn68030 subq #1,d2 subtract 1 to make loop correct cscrollwindnnextrow2 move.l d2,d4 reset column counter movea.l a1,a2 set up destination address movea.l a1,a4 suba.l d3,a4  set up source address cscrollwindnnextword2 move.l (a4)+,(a2)+ move from one line to the other dbra d4,cscrollwindnnextword2 and loop suba.l #width,a1 increment row by width dbra d0,cscrollwindnnextrow2 and loop again cscrollwindnpageoff move.l #pagemode,d7 turn off page mode move.l #1,0(a0,d7.l) jsr misc_lockdown enable STOP key cscrollwindnrts rts * ************************************************************************ * *  procedure cscrolll(ymin, ymax, xmin, width: shortint) * cdbscrolll movea.l crtinfo(a5),a3 moveq #0,d1 move.l d1,d2 move.l d1,d3 move.l d1,d4 movea.l (sp)+,a1 return address move.w (sp)+,d4 width (in chars) move.w (sp)+,d3 xmin (in chars) move.w (sp)+,d2 ymax (in lines) move.w (sp)+,d1 ymin (in lines) move.l a1,-(sp) stack return address sub d1,d2 addq #1,d2  add 1 to lines mulu charh(a3),d2 d2 = number of rows in pixels mulu charh(a3),d1 d1 = first row in pixels mulu charw(a3),d3 d3 = first column subq #1,d4 1 char less beq cdbscrolllrts 1 column window mulu charw(a3),d4 number of columns lsr #2,d4 d4 = number of long words movea.l screen(a5),a1 mulu #width,d1 adda.l d1,a1 adda.l d3,a1 address of first pixel subq #1,d2 subtract 1 to make loop correct subq #1,d4 subtract 1 to make loop correct movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 cdbscrolllnextrow movea.l a1,a2 set up destination address movea.l a2,a4 move.l d4,d3 reuse d3 for counter adda charw(a3),a4 set up source address cdbscrolllnextword move.l (a4)+,(a2)+ dbra  d3,cdbscrolllnextword adda.l #width,a1 dbra d2,cdbscrolllnextrow jsr misc_lockdown enable STOP key cdbscrolllrts rts * ************************************************************************ * * procedure cscrollr( ymin, ymax, xmin, width: shortint) * cdbscrollr movea.l crtinfo(a5),a3 moveq #0,d1 move.l d1,d2 move.l d1,d3 move.l d1,d4 movea.l (sp)+,a1 return address move.w (sp)+,d4 width move.w (sp)+,d3  xmin move.w (sp)+,d2 ymax move.w (sp)+,d1 ymin move.l a1,-(sp) stack return address sub d1,d2 addq #1,d2 add 1 to lines mulu charh(a3),d2 d2 = number of rows mulu charh(a3),d1 d1 = first row mulu charw(a3),d3 d3 = first column subq #1,d4 1 less char beq cdbscrollrrts 1 column window mulu charw(a3),d4 number of  columns move.l screen(a5),a1 mulu #width,d1 adda.l d1,a1 adda.l d3,a1 adda.l d4,a1 address of first pixel addq #4,a1 subtract later with pre-dec lsr #2,d4 d4 = number of long words subq #1,d2 subtract 1 to make loop correct movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 cdbscrollrnextrow movea.l a1,a2 set up source address  movea.l a2,a4 move.l d4,d3 reuse d3 for counter adda charw(a3),a4 set up destination address cdbscrollrnextword move.l -(a2),-(a4) dbra d3,cdbscrollrnextword adda.l #width,a1 dbra d2,cdbscrollrnextrow  jsr misc_lockdown enable STOP key cdbscrollrrts rts * ********************************************************************* * * procedure cclearall * clears all of visible area except typeahead * cclearall  movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 moveq #0,d2 move.l d1,d3 movem.l d0-d7/a0-a5,-(sp) jsr misc_lockup disable STOP key movem.l (sp)+,d0-d7/a0-a5 move.l #blockmode,d6 move.l #0,0(a0,d6.l) turn on block mode move.l #vramcolor1,d5 move.l #0,0(a0,d5.l) set color registers to 0 move.l #maskreg,d5 move.l #-1,0(a0,d5.l) to clear on all planes move.l screen(a5),a1 base address of FB move disph(a3),d2 get width and height in pixels move dispw(a3),d3 lsr #4,d3 change to number of words subq #1,d2 subq #1,d3 movea.l a1,a2 make a copy for reference nextrow move.l d3,d4  reset column counter movea.l a2,a1 reset to beginning of next line nextword move.w #-1,(a1)+ write to the display dbra d4,nextword and loop adda.l #widthdiv16,a2 increment row by width dbra d2,nextrow and loop again move.l #1,0(a0,d6.l) turn off block mode jsr misc_lockdown enable STOP key rts * ************************************************************************ * * procedure csetcolormap(index,red,green,blue:integer) * Set a color map entry * To minimize flicker, wait for BEECH blue register * to go not busy. Then write the index, red, and * green data to the DAC. Then write the blue data * to BEECH. BEECH will send the blue data to the * DAC and the DAC will then update. * csetcolormap movea.l controladdr(a5),a0 movea.l (sp)+,a1 return address move.l (sp)+,d3 move.l (sp)+,d2 move.l (sp)+,d1 move.l (sp)+,d0 get data off stack as longs move.l a1,-(sp) stack return address move.l #blueregimage,d5 ccheckblue btst #0,2(a0,d5.l) check for color map busy bne.s ccheckblue loop until bit is clear move.l #dacimagewrite,d6 move.b d0,0(a0,d6.l) write the index to the DAC move.b d1,4(a0,d6.l) then red to the DAC move.b d2,4(a0,d6.l) then green to the DAC move.b d3,3(a0,d5.l) then blue to BEECH rts * ************************************************************************ * * procedure csetreg(register:integer; value:shortint) * csetreg movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 movea.l (sp)+,a1 return address move.w (sp)+,d2 register value move.l (sp)+,d1 register number move.l a1,-(sp) stack return address rts * ************************************************************************ * * procedure csavewoodenv(anyvar buffer:window) * csavewoodenv movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 movea.l (sp)+,a1 return address move a.l (sp)+,a2 move.l a1,-(sp) stack return address rts * ************************************************************************ * * procedure crestorewoodenv(anyvar buffer:window) * crestorewoodenv movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 movea.l (sp)+,a1 return address movea.l (sp)+,a2 move.l a1,-(sp) stack return address rts * ************************************************************************ * * function cromshort(offset:integer):shortint * cromshort equ * movea.l controladdr(a5),a0 movea.l (sp)+,a1 return address adda.l (sp)+,a0 offset movep 0(a0),d0 move d0,(sp) store on stack as function value jmp (a1) * ************************************************************************ * * procedure csetupcchar * csetupcchar movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 rts * ************************************************************************ * * procedure cprepdumpline(mybuf:windowp; size:shortint; * rowstart:anyptr); * * Takes the data in the frame buffer at rowstart, for size*8 bytes, and * preps it for graphic output by creating an array of size number of bytes * which has 1 bits where there are non-0 pixels in rowstart array, and 0 bits * elsewhere. This is the format of PCL graphics data. The mybuf pointer * is actually a pointer 8 bytes into a pascal string structure. * the routine detects the last non-0 output byte, and adjusts both the * strlen of the Pascal string, and the ASCII numeric string to that. The * adjustment is done to minimize data transmission to printer, especially * for RS232 printers. * The ASCII string header looks like #27'*bxxxW' where xxx is a * 3-digit number, which reflects the length of FOLLOWING binary data. * called by dumpg in CATCRT - SFB/LAF Jan 26, '88 cprepdumpline equ * move.l (sp)+,a0  return address move.l (sp)+,a3 rowstart move.w (sp)+,d0 size move.l (sp),a1 outbufptr, leave on stack for later move.w d0,d1 copy for adjusting strlen, etc later ext.l d1 ensure MSBs are 0 for later divide move.l d1,d5 keeps track of last non-zero outbuf char movea.l crtinfo(a5),a2 get access to crt description bra.s initcharbuf start up the process preploop equ * move.b (a3)+,d2 prepare to test non-zero pixel and.b planemask+3(a2),d2 mask out "floating" bits in pixel subi.b #1,d2 will set X in CCR if (a3) is zero roxl.b #1,d3 put X into output char buf LSB dbra d4,preploop do it 8 times per out char not.b d3 because X was wrong sense move.b d3,(a1)+ put character into outbuf beq.s initcharbuf if it wasn't empty, then move.w d0,d5 keep track of last non-empty char initcharbuf equ * move.w #7,d4 8 bits per output char dbra d0,preploop n chars/line move.l (sp)+,a1 recover initial outbufptr, and clr stack sub.w d5,d1 bne.s fixstrlen line has something on it moveq #1,d1 must have min of 1 to force slew (we wish!) fixstrlen equ * move.b d1,-8(a1) stick correct length in strlen of outbuf addi.b #7,-8(a1) and adjust for #27'*bxxxW' header * compute ASCII representation of d1 into longword, with trailing 'W' divu #10,d1 remainder->upper word of d1 move.w d1,d2 ext.l d2 clear MSBs of d2 divu #10,d2 remainder->upper word of d2 swap d2 rol.w #8,d2 clr.w d1 clear LSBs swap d1 or.l d2,d1 ori.l #'000',d1  attach ASCII numeric headers rol.l #8,d1 justify for copy to outbuf ori.b #'W',d1 now have 'xxxW' in longword move.l d1,-4(a1) copy to outbuf jmp (a0) and return * ******************************** **************************************** * * procedure setupcchar * setupcchar movea.l crtinfo(a5),a3 movea.l controladdr(a5),a0 rts * ************************************************************************ * end of code  (* (c) Copyright Hewlett-Packard Company, 1991. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $DEBUG OFF$ $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $stackcheck off$ $ALLOW_PACKED ON$ {{ $search 'INITLOAD','ASM','INIT','SYSDEVS'$ {} { The core for this code was taken from the CATSEYE driver. That's why it looks so similar. Modifications were made to use FASSM hardware driver. WOODCUT has a hardware cursor and byte per pixel architecture, which makes life much easier. } program initwoodcut(OUTPUT,INPUT); module woodcutdvr; import sysglobals, asm, misc, sysdevs {, fassm}, fs; export type screeninforec = record fbwidth : shortint; {defaults: LCC = 1024, 768 } fbheight : shortint; {  HRx = 2048, 1024 } { VGA = 640, 480 } dispx : shortint; {defaults: LCC = 0, 0 } dispy : shortint; { HRx = 0, 0 }  { VGA - 0, 0 } dispw : shortint; {defaults: LCC = 1024, 768 } disph : shortint; { HRx = 1280, 1024 }  { VGA = 640, 480 } printx : shortint; {defaults: LCC = 0, 0 } printy : shortint; { HRx = 0, 0 } { VGA - 0, 0 }  printw : shortint; {defaults: LCC = 1024, 752 } { VGA = 640, 464 } printh : shortint; { HRx = 1280, 1004 } offx : shortint; {defaults: LCC = 0, 0 } offy : shortint; { HRx = 1280, 0 } { VGA = 0, 480 } offw : shortint; {defaults: LCC = 0, 0 }  offh : shortint; { HRx = 768, 1024 } { VGA = 544, 1024 } charw : shortint; {defaults: LCC = 8, 16 } charh : shortint; { HRx = 10, 20 } { VGA = 8, 16 } fb_fontstartx : shortint; {defaults: LCC = N/A } fb_fontstarty : shortint; { HRx = N/A }  { VGA = N/A } fb_font_line_length: shortint; {defaults: LCC = N/A } { HRx = N/A } {  VGA = N/A } fb_fontlines : shortint; {defaults: LCC = N/A } { HRC = N/A } { HRM = N/A }   { VGA = N/A } nfontchars : integer; {default = 3 x 128 } fb_cursorx : shortint; {defaults: LCC = N/A } fb_cursory : shortint; { HRx = N/A }  { VGA = N/A } end; colormap_proc_type = procedure(index : integer; r, g, b : integer); crtiocontrolrec = packed record set_colormap_proc : colormap_proc_type; {sets ANY cmap entry} planes : integer; {1s where planes loaded (bitmap)} alphacolor : shortint; {color for characters. Can be set 0..7 by sending 136..143 to CRT  tm, or set to any by setting this field.} cursorcolor : shortint; {default = 2^(-1)} {{ lowalphaplane : byte; {keeps track of lowest plane used by alpha. All physical planes above this one are used by alpha,  and all below it are untouched. (for DGL's exclusive use) } highlight : shortint; {bit fielded: b0 = inverse,  b1 = blink, (nop) b2 = underline, b3 = halfbright (nop)} creplrule0 : byte;  {repl rule for char 0s, 0..15 } creplrule1 : byte; {repl rule for char 1s, 0..15 } cursreplrule0 : byte; {rule for cursor 0s, 0..15 } cursreplrule1 : byte; {rule for cursor 1s, 0..15 } togglealpha, {TRUE=disable alpha planes display when alphastate=TRUE } togglegraphics, {TRUE=disable graphics planes display when  graphicstate=TRUE } copy_under_cursor, {TRUE=save char pattern before writing cursor, restore after removing cursor } use_fib_xy, {FALSE=ignore fxpos, fypos from fib} disable_low_ctl, {TRUE=chr(0)..chr(31) not interpreted} disable_hi_ctl, {TRUE=chr(128)..chr(143) not interpreted} copy_to_abuf, {TRUE=copy input to abuf for dump alpha}  pad1 : boolean; {filler } end; pcrtparamrec = ^crtparamrec; crtparamrec = record screeninfo : screeninforec; iocontrol : crtiocontrolrec; {capabilities : capability_descriprec;} end; { 256 chars of ROMAN-8 and 128 chars of KATAKANA } { 10x20 pixel cell size : (256+128)*10*20 = 76,800 } var crtparams : pcrtparamrec; function woodcuttype : boolean; implement const  woodcutregbytes = 38; {increased from 36 to save TRRCTL. SFB/DEW 5/24/88} environc = environ[miscinfo : crtfrec[ nobreak : false, stupid : false,  slowterm : false, hasxycrt : true, haslccrt : FALSE, {INDICATES BITMAP} hasclock : true,  canupscroll : true, candownscroll : true], crttype : 0, crtctrl : crtcrec[ rlf : chr(31),   ndfs : chr(28), eraseeol : chr(9), eraseeos : chr(11), home : chr(1), escape : chr(0), backspace : chr(8), fillcount : 10, clearscreen: chr(0), clearline : chr(0),  prefixed : b9[9 of false]], crtinfo : crtirec[ width : 128, height : 47, { VGA = 80, 29 } crtmemaddr : 0, crtcontroladdr : 0, keybufferaddr : 0, progstateinfoaddr : 0,  keybuffersize : 119, crtcon : crtconsttype [ 0, 0, 0, 0, 0, 0,  0, 0, 0, 0, 0, 0], right{FS} : chr(28), left{BS} : chr(8),  down{LF} : chr(10), up{US} : chr(31), badch{?} : chr(63), chardel{BS} : chr(8),  stop{DC3} : chr(19), break{DLE} : chr(16), flush{ACK} : chr(6), eof{ETX} : chr(3),  altmode{ESC} : chr(27), linedel{DEL} : chr(127), backspace{BS} : chr(8), etx : chr(3),  prefix : chr(0), prefixed : b14[14 of false], cursormask : 0, spare : 0]];  DEFAULT_ALPHACOLOR = 1; var cpl : shortint; cppl : shortint; fb_fontchars : shortint; maxy : shortint; xcurs : shortint; ycurs : shortint; hascolor : boolean; midres : boolean; lowres : boolean; screenwidth : shortint; screenheight : shortint; maxx : shortint; screensize : shortint; defaulthighlight : shortint; function cromshort(offset : integer) : shortint; external; procedure csetreg(register : integer; value : shortint); external; procedure csavewoodenv(anyvar buffer : window); external; procedure crestorewoodenv(anyvar buffer : window); external; procedure csetupcchar; external; procedure csetcolormap(indx : integer; r, g, b : integer); external; procedure cchar(c, x, y : shortint); external; procedure cscrollup; external; procedure cscrolldown; external; procedure cclear(x, y, n : shortint); external; procedure cupdatecursor(x, y : shortint); external; procedure cbuildtable; external; procedure cshiftleft; external; procedure cshiftright; external; procedure cexchange(savearea : windowp; ymin, ymax, xmin, width : shortint); external; procedure cscrollwindow(ymin, ymax, xmin, width : shortint); external; procedure cscrollwinddn(ymin, ymax, xmin, width : shortint); external; procedure cdbscrolll(ymin, ymax, xmin, width : shortint); external; procedure cdbscrollr(ymin, ymax, xmin, width : shortint); external; procedu re cclearall; external; procedure cprepdumpline(mybuf : windowp; size : shortint; rowstart : anyptr); external; procedure dummy_setcmap(index : integer; r, g, b : integer); begin end; procedure init_crtparams; begin if crtparams=NIL then new(crtparams); with crtparams^, screeninfo, iocontrol do begin charw := 0; charh := 0; fb_fontstartx := 0; fb_fontstarty := 0; fb_font_line_length := 0; fb_fontlines := 0; nfontchars := 0; fb_cursorx := 0; fb_cursory := 0; cursorcolor := 0; {{ lowalphaplane := 0; {} highlight := 0; alphacolor := 1; creplrule0 := 0; creplrule1 := 3; cursreplrule0 := 0; cursreplrule1 := 3; togglealpha := false; togglegraphics := false; copy_under_cursor := true; use_fib_xy := true; disable_low_ctl := false; disable_hi_ctl := false; copy_to_abuf := false; set_colormap_proc := dummy_setcmap; end; end; {init_crtparams} procedure dumpg; label 1; const gwidth_lcc = 128; gwidth_hrx = 160; gbuffersize = gwidth_hrx + 7; type gbyte = 0..255; row_def = packed array [0..maxint] of gbyte; var row : ^row_def; abyte : byte; gbuffer : string[gbuffersize]; lenstr : string[3]; i : integer; j : integer; rowstart : integer; bitnum : shortint; charpos : shortint; datalen : shortint; begin row := anyptr(frameaddr); { write(gfiles[4]^, #27'*t150R'); { SET RESOLUTION 150 FOR DESKJET} { write(gfiles[4]^, #27'*t192R'); { SET RESOLUTION 192 FOR QUIETJET} write(gfiles[4]^, #27'*rA'); { initiate graphics sequence } gbuffer := #27'*bxxxW'; { xxx will be replaced in cprepdumpline by actual number of non-0 bytes in buffer} with crtparams^, screeninfo, iocontrol do begin datalen := (dispw+7) div 8; rowstart := 0; for j := 0 to disph-1 do begin cprepdumpline(addr(gbuffer[8]), datalen, addr(row^[rowstart])); write(gfiles[4]^, gbuffer); if ioresult <> ord(inoerror) then goto 1; rowstart := rowstart+fbwidth; end; end; write(gfiles[4]^, #27'*rB'); { terminate graphics sequence } 1: end; procedure doupdatecursor; begin cupdatecursor(xpos, ypos); end; procedure getxy(var x, y : integer); begin x := xpos; y := ypos; end; procedure setxy(x, y : shortint); begin if x>= screenwidth then xpos := maxx else if x<0 then xpos := 0 else xpos := x; if y >= screenheight then ypos := maxy else if y < 0 then ypos := 0 else ypos := y; end; procedure clear(number : shortint); var x : shortint; y : shortint; clearchars : shortint; begin x := xpos; y := ypos; while number > 0 do begin if maxx-x+1 < number then clearchars := maxx-x+1 else clearchars := number; cclear(x, y, clearchars); number := number-clearchars; x := 0; if y=128 and c<144} begin needs_setup := false; with crtparams^, iocontrol do if ((c<136) and hascolor) or (not hascolor) then begin   {hilite request, color or mono} if ((highlight div 256) mod 2) <> (c mod 2) then begin {for inverse video. Underline is handled in cchar} creplrule1 := 3+9*(c mod 2); needs_setup := true; end; if not hascolor then highlight := (c-128)*256 else highlight := ((highlight div 2048)*8 + (c-128))*256; end else begin {set color request on color machine} alphacolor := ((c-136) {MOD 8}) + 1; cursorcolor := alphacolor; highlight := highlight mod 2048 + (c-136)*4096; needs_setup := true; end; end; {needs_setup} {Added bug fixes for "STOP" key. Symptom was that color would change to white from whatever it was if "STOP" key hit while idling in CI. Cause was that "Io" character in lower right corner, done by "kbdwaithook" was being interrupted by "STOP", and wasn't setting color back from white to "old" color. Any escape(-20) or escape(-28) from an ISR could also cause this symptom (see "interrupt" routine in POWERUP.TEXT for reasons. The fix is the same in all of docrtio, lineops and crtdebug: in essence we "protect" the H/W setup by setting level 7, then set the level back down to its old value to allow ISRs to execute, if they want. We put a try/recover around the main execution, as we can't afford to stay at level 7 for very long. This allows us to set level back own to old level during I/O, knowing we can restore the previous H/W state, because "STOP", etc will trigger the recover block. We do not try to complete the I/O if a "STOP" key hits during the driver; we merely try to restore the entry state of the CATSEYE H/W and system globals. We do not protect against NMI at all (this is very hard to do.) 2 known "bugs": in the recover block, a second escape occurring before the setintlevel(7) will cause H/W restoration to not be executed, and another escape in the recovery anywhere after the setintlevel(7) and before the if.. then escape(savesc) will cause the first escapecode to be lost. SFB 5/31/88 } procedure docrtio(fp : fibp; request : amrequesttype; anyvar buffer : window; length, position : integer); type cursor_affected_set = set of amrequesttype; const cursor_affected = cursor_affected_set[setcursor, clearunit, writeeol, startwrite, writebytes]; var stackbuf : packed array[1..woodcutregbytes] of byte; c  : char; s : string[1]; savesc : shortint; {to fix stopkey bug. SFB 5/31/88} oldlevel : shortint; {to fix stopkey bug. SFB 5/31/88} change_cursor : boolean; {to shorten level 7 lockout time. SFB 5/31/88} buf : charptr; begin change_cursor := request in cursor_affected;{precompute for speed.SFB 5/31/88} savesc:=0; {in case driver gets escaped away from, we clean up, then escape with the correct escape code. SFB 5/31/88}  oldlevel := intlevel; {so we can restore level after protecting "atomic operations". SFB 5/31/88} setintlevel(7); {prepare for "atomic operation". SFB 5/31/88} { csavewoodenv(stackbuf);} if change_cursor then  begin with crtparams^, iocontrol do alphacolor := cursorcolor; { KLUGE ALERT! This only works because we define alphacolor and cursorcolor to be always the same. It rescues the alphacolor in the case that an ISR executed during lineops (when alphacolor<>cursorcolor), and did escape(-20), not allowing lineops to put back the global describing alphacolor. It hasn't modified cursorcolor, though, so we can recover alphacolor from it. NOTE: if cursorcolor is ever made accessible outside this driver, this kluge should be removed, or changing cursorcolor will magically change alphacolor. SFB/DEW 5/31/88 } end; try {now ensure we get a chance to clean up if "STOP" key hits. SFB 5/31/88} setintlevel(oldlevel); {finish "atomic operation"  SFB 5/31/88} ioresult := ord(inoerror); buf := addr(buffer); with crtparams^, iocontrol do case request of setcursor: begin setxy(fp^.fxpos, fp^.fypos); end; {cupdatecursor is called at end of docrtio} getcursor: getxy(fp^.fxpos, fp^.fypos); flush: {do nothing}; unitstatus: kbdio(fp, request, buffer, length, position); clearunit: begin {will not clear screen content, as this is not appropriate} highlight := defaulthighlight; alphacolor := default_alphacolor; cursorcolor := alphacolor; creplrule1 := 3; csetupcchar; setxy(0, 0); end; readtoeol: begin buf := addr(buf^, 1); buffer[0] := chr(0); while length>0 do begin kbdio(fp, readtoeol, s, 1, 0); if strlen(s) = 0 then length := 0 else begin length := length - 1; crtio(fp, writebytes, s[1], 1, 0); buf := addr(buf^, 1); buffer[0] := chr(ord(buffer[0])+1); end; end; end; startread, readbytes: begin while length > 0 do begin kbdio(fp, readbytes, buf^, 1, 0); if buf^ = chr(etx) then length := 0 else length := length - 1; if buf^ = eol then crtio(fp, writeeol, buf^, 1, 0) else crtio(fp, writebytes, buf^, 1, 0);  buf := addr(buf^, 1); end; if request = startread then call(fp^.feot, fp); end; writeeol : begin if ypos=maxy then cscrollup; setxy(0, ypos+1); end; startwrite, writebytes: begin  while length>0 do begin c := buf^; buf := addr(buf^,1); length := length-1; case c of homechar: setxy(0, 0); leftchar: if (xpos = 0) and (ypos>0) then  setxy(maxx, ypos-1) else setxy(xpos-1, ypos); rightchar: if (xpos = maxx) and (ypos0 then setxy(xpos, ypos-1); end; downchar: if ypos=maxy then cscrollup else setxy(xpos, ypos+1); bellchar: beep; cteos: clear(screensize-(ypos*screenwidth+xpos)); cteol: clear(screenwidth-xpos); clearscr:  begin setxy(0,0); clear(screensize); end; eol: setxy(0, ypos); chr(etx): length:=0; otherwise if (ord(c)>=128) and (ord(c)<144) then { display enhancement } if needs_setup(ord(c)) then { modified setup } csetupcchar else { didn't modify setup, so do nothing } else { printable char } begin cchar(maptocrt(c), xpos, ypos); if xpos = maxx then begin if ypos = maxy then cscrollup; setxy(0, ypos+1); end else  setxy(xpos+1, ypos); end; end; {case} end; {while} if request = startwrite then call(fp^.feot, fp); end; otherwise ioresult := ord(ibadrequest); end; {case} setintlevel(7); {prepare for "atomic" cleanup operation" SFB 5/31/88} recover {SFB 5/31/88} begin setintlevel(7); { prepare for "atomic" cleanup operation". Possible bug: What if interrupt hits in recover block before setintlevel(7)   executes? We would lose chance to restore H/W setup. } savesc := escapecode; { so we can "transparently" let escape through } end; if change_cursor then {SFB 5/31/88} cupdatecursor(xpos, ypos); { crestorewoodenv(stackbuf);} setintlevel(oldlevel); {finish at level we started at. SFB 5/31/88} if savesc <> 0 then escape(savesc); {possible bug: what if interrupt hits during intlevel 7?  We would never execute this code. SFB 5/31/88} end; {docrtio} procedure lineops(op : crtllops; anyvar position : integer; c : char); var stackbuf : packed array[1..woodcutregbytes] of byte; i : shortint; oldhilite : shortint; oldcolor : shortint; oldrule : shortint; savesc : shortint; {to fix stopkey bug. SFB 5/31/88} oldlevel : shortint; {to fix stopkey bug. SFB 5/31/88} sptr : ^string255; begin savesc := 0; {in case driver gets escaped away from, we clean up, then escape with the correct escape code. SFB 5/31/88} oldlevel := intlevel; {so we can restore level after protecting "atomic operations". SFB 5/31/88} setintlevel(7); {prepare for "atomic operation". SFB 5/31/88} with crtparams^, iocontrol do begin oldrule := creplrule1; oldcolor := alphacolor; oldhilite := highlight; creplrule1 := 3; {no enhancements supported in lastline} alphacolor := default_alphacolor; {only white in last line} {cursorcolor := alphacolor; {no cursor in last line} highlight := defaulthighlight; end; { csavewoodenv(stackbuf);} try {now ensure we get a chance to clean up if "STOP" key hits. SFB 5/31/88} setintlevel(oldlevel); {finish "atomic operation" SFB 5/31/88} case op of cllput: cchar(maptocrt(c), position, screenheight); cllshiftl: begin cshiftleft; cchar(ord(' '), maxx-8, screenheight); end; cllshiftr: begin cshiftright; cchar(ord(' '), 0, screenheight); end; cllclear: cclear(0, screenheight, maxx-7); clldisplay: begin sptr := addr(position); for i := 1 to strlen(sptr^) do cchar(maptocrt(sptr^[i]), i-1, screenheight); for i:=strlen(sptr^) to (maxx-8) do cchar(ord(' '), i, screenheight); end; putstatus: cchar(ord(c), maxx-7+position, screenheight); end; {case} setintlevel(7); {prepare for "atomic" cleanup operation" SFB 5/31/88} recover {SFB 5/31/88} begin setintlevel(7); {prepare for "atomic" cleanup operation". Possible bug: What if interrupt hits in recover block before setintlevel(7) executes? We would lose chance to restore H/W setup.} savesc := escapecode; {so we can "transparently" let escape through} end; with crtparams^, iocontrol do begin creplrule1 := oldrule; alphacolor := oldcolor; highlight := oldhilite; end; { crestorewoodenv(stackbuf);} setintlevel(oldlevel); {finish at level we started at. SFB 5/31/88} if savesc <> 0 then escape(savesc);{possible bug: what if interrupt hits during intlevel 7? We would never execute this code. SFB 5/31/88} end; {lineops} procedure crtdebug(op : dbcrtops; var dbrec : dbcinfo); type cursor_affected_set = set of dbcrtops; const cursor_affected = cursor_affected_set[dbgotoxy, dbscrollup, dbscrolldn, dbscrolll, dbscrollr, dbput, dbclear, dbcline, dbexcg]; type iptr = ^iarray; iarray = array[0..maxint] of shortint; var stackbuf : packed array[1..woodcutregbytes] of byte; { oldalphacolor and oldcursorcolor keep track of alpha and cursor colors separately, because if a linops call is interrupted by another use o f the driver, it may have left alphacolor<>cursorcolor, so restoring cursorcolor:= alphacolor at the end of this routine is a Bad Thing. Note also that calling the tm in the middle of the lineops execution may cause a similar problem, as lastline color might be different from alphacolor, and cursorcolor will still == alphacolor. SFB/DEW 5/31/88 } i : shortint; oldhilite : shortint; oldalphacolor : shortint; oldcursorcolor : shortint; oldrule : shortint; j : integer; savesc : shortint; {to fix stopkey bug. SFB 5/31/88} oldlevel : shortint; {to fix stopkey bug. SFB 5/31/88} change_cursor : boolean; {to shorten level 7 lockout time. SFB 5/31/88} tempaddr : integer; begin {Need to do following steps BEFORE csavewoodenv, as they will affect driver setup via drop-through to setupcchar} change_cursor := op in cursor_affected; {precompute for speed. SFB 5/31/88} savesc := 0; {in case driver gets escaped away from, we clean up, then escape with the correct escape code. SFB 5/31/88} oldlevel := intlevel; {so we can restore level after protecting "atomic operations". SFB 5/31/88} setintlevel(7); {prepare for "atomic operation". SFB 5/31/88} with crtparams^, iocontrol do begin oldrule := creplrule1; {to restore for later} oldalphacolor := alphacolor;  {ditto} oldcursorcolor := cursorcolor; {ditto} oldhilite := highlight; {set up debugger window conditions} highlight := dbrec.debughighlight;  {set relprule to 3 (regular) or 12 (inverse video)} creplrule1 := 3+9*((highlight div 256) mod 2); if hascolor then begin {set color according to debugwindow} alphacolor := ((highlight div 4096) mod 8) + 1; cursorcolor := alphacolor; end; end; { This also sets up color and inverse/forward video in driver, via drop- through to setupcchar} { csavewoodenv(stackbuf);} with dbrec do if change_cursor then begin xcurs := cursx;  ycurs := cursy; end; try {now ensure we get a chance to clean up if "STOP" key hits. SFB 5/31/88} setintlevel(oldlevel); {finish "atomic operation" SFB 5/31/88} with dbrec do begin case op of dbinfo: with crtparams^.screeninfo do begin savesize:=(xmax-xmin+1)*(ymax-ymin+1)*charw*charh; end; dbgotoxy: begin {Implemented by prior call to cursoroff, and following call to cupdatecursor} end;  dbscrollup: begin cscrollwindow( ymin, ymax, xmin, xmax-xmin+1); cclear(xmin, ymax, xmax-xmin+1); end; dbscrolldn: begin cscrollwinddn(ymin, ymax, xmin, xmax-xmin+1); cclear(xmin, ymin, xmax-xmin+1); end; dbscrolll: begin cdbscrolll(ymin, ymax, xmin, xmax-xmin+1); for i := ymin to ymax do cchar(ord(' '), xmax, i); end; dbscrollr: begin cdbscrollr(ymin, ymax, xmin, xmax-xmin+1); for i := ymin to ymax do cchar(ord(' '), xmin, i); end; dbhighl: ; { Not implemented for color bitmap displays } dbput: begin if charismapped then cchar(maptocrt(c), cursx, cursy) else cchar(ord(c), cursx, cursy); end; dbclear: for i := ymin to ymax do cclear(xmin, i, xmax-xmin+1); dbcline: cclear(cursx, cursy, xmax-cursx+1); dbinit: begin  for j := 0 to (savesize div 2)-1 do iptr(savearea)^[j] := 0; cursx := xmin; cursy := ymin; areaisdbcrt := false; charismapped := false; debughighlight := 0; end; d bexcg: with crtparams^, iocontrol do begin cexchange(savearea, ymin, ymax, xmin, (xmax-xmin+1)*crtparams^.screeninfo.charw); areaisdbcrt := not areaisdbcrt; if areaisdbcrt then begin if hascolor then {set cursor color according to debugwindow} cursorcolor := ((highlight div 4096) mod 8) + 1; xcurs := cursx; ycurs := cursy; end else begin if hascolor then {set cursor color according to alpha window} cursorcolor := oldcursorcolor; xcurs := xpos; ycurs := ypos; end; end; end; {case} end; {with} setintlevel(7); {prepare for "atomic" cleanup operation" SFB 5/31/88} recover {SFB 5/31/88} begin setintlevel(7); {prepare for "atomic" cleanup operation". Possible bug: What if interrupt hits in recover block before setintlevel(7) executes? We would lose chance to restore H/W setup.} savesc := escapecode; {so we can "transparently" let escape through} end; if change_cursor then cupdatecursor(xcurs, ycurs); {possibly with new cursor color} with crtparams^, iocontrol do begin creplrule1 := oldrule; highlight := oldhilite; alphacolor := oldalphacolor; cursorcolor := oldcursorcolor; end; { crestorewoodenv(stackbuf);} setintlevel(oldlevel); {finish at level we started at. SFB 5/31/88} if savesc <> 0 then escape(savesc); {possible bug: what if interrupt hits during intlevel 7? We would never execute  this code. SFB 5/31/88} end; {crtdebug} procedure dummy; begin end; procedure getcrtinfo; var stackbuf : packed array[1..woodcutregbytes] of byte; begin with crtparams^, screeninfo, iocontrol do begin cbuildtable; { csavewoodenv(stackbuf); {to set up cchar} printh := ((disph-charh) DIV charh)*charh; hascolor := true; { WOODCUT always has color } alphacolor := 1; cursorcolor  := alphacolor; cursreplrule0 := 5; cursreplrule1 := 6; copy_under_cursor := true; set_colormap_proc := csetcolormap; setxy(0, 0); cupdatecursor(0, 0); cclearall; { crestorewoodenv(stackbuf);} end; end; {getcrtinfo} procedure woodcutinit; begin init_crtparams; idle := 245; { set io char to roman8 value } with syscom^.crtinfo, crtparams^.screeninfo do begin getcrtinfo; screenwidth := width; screenheight := height; screensize := screenwidth*screenheight; maxx := screenwidth-1; maxy := screenheight-1; printh := screenheight * charh; printw := screenwidth * charw; defaulthighlight := 0; dumpalphahook := dumpg; dumpgraphicshook := dumpg; updatecursorhook := doupdatecursor; crtiohook := docrtio; dbcrthook := crtdebug; crtllhook := lineops; crtinithook  := woodcutinit; togglealphahook := dummy; togglegraphicshook := dummy; currentcrt := bitmaptype; keybuffer^.maxsize := maxx-8; end; end; {woodcutinit} function woodcuttype : boolean; const newbitmapid = 57; {primary id for new bitmap displays} MHRCid = 19; {High Resolution Color Greyscale Woodcut secondary id} MVGAid = 18; {VGA Greyscale Woodcut secondary id} VGAid = 17; {VGA Resolution Woodcut secondary id} LCCid = 16; {Med Resolution Woodcut secondary id} HRCid = 15; {High Resolution Color Woodcut secondary id} var ptr : ^shortint; i : shortint; dummy : shortint; found : boolean; begin found := false; {check  DIO-II space} ptr := anyptr(hex('1000000')); { changed to DIO-II space CFB - 30APR91} try dummy := ptr^ mod 128; if dummy = newbitmapid then begin { look at primary id } ptr := anyptr(integer(ptr)+20); { look at secondary id } dummy := ptr^ mod 128; if (dummy >= HRCid) and (dummy <= MHRCid) then begin found := true; bitmapaddr := integer(ptr)-20; lowres := false; midres := false;  if (dummy = VGAid) or (dummy = MVGAid) then lowres := true else if (dummy = LCCid) then midres := true; end; end; recover if escapecode <> -12 then escape(escapecode); if found then begin syscom^ := environc;  if lowres then begin syscom^.crtinfo.width := 80; syscom^.crtinfo.height := 29; end else { make hires 50 lines - 25OCT91 - CFB } if not midres then {must be hires} syscom^.crtinfo.height := 50; woodcutinit; end; woodcuttype := found; end; {woodcuttype} end; { of module } import woodcutdvr, loader; begin if woodcuttype then markuser; end.  page * * GATOR bit-mapped alpha driver * * Pascal 3.0 version by J. Schmidt * def cscrollup,cscrolldown,cupdatecursor,cchar,cclear def cbuildtable,cshiftleft,cshiftright def cexchange,cscrollwindow,changecursor def cscrollwinddn,cdbscrolll,cdbscrollr,cdbhighl rorg.l 0 refa crtb,sysdevs nosyms clearl equ $CC000 blank pixel row offset maxx equ crtb-10 maxy equ crtb-12 cursoraddr equ crtb-4 highlight equ crtb-18 controladdr equ sysdevs-86 screen equ sysdevs-90 replcopy equ sysdevs-92 windcopy equ sysdevs-94 replreg equ $4008 windreg equ $400c status equ $4001 width equ 1024 initoffset equ $23 offset to initialization offset fontoffset equ $3B offset to font info offset * gbuildtable(ptr); cbuildtable movea.l (sp)+,a4 a4 = return address movea.l controladdr(a5),a0 get pointer to ROM start moveq #0,d0 moveq #0,d1  move.b status(a0),d0 get status reg again lsr.b #2,d0 get monitor type bits and.b #12,d0 move.b initoffset(a0,d0.w),d1 get MSB of info addr offset lsl.w #8,d1 move.b initoffset+2(a0,d0.w),d1 get LSB of info addr offset movea.l a0,a1 make copy of ROM start addr adda d1,a1 a1 points to init info now ginitblock moveq #0,d1 clear some regs moveq #0,d0 move.b 2(a1),d0 get word count to initialize movep 4(a1),d1 form destination offset add.l a0,d1 d1 points to dest addr lea 8(a1),a2 a2 points to first data byte movea.l d1,a3 a3 points to destination ginitloop movep 0(a2),d1 form a data word in d1 move.w d1,(a3)+ move data to the destination addr btst #6,(a1) increment data pointer bne.s ginit1 based on control byte addq #4,a2 ginit1 dbra d0,ginitloop loop till word count exhausted btst #7,(a1) was this last block? bne.s ginitdone yes -- go return btst #6,(a1) adjust data pointer beq.s ginit2 to point to next init block addq #4,a2 ginit2 movea.l a2,a1 a1 points to new init block bra ginitblock do the initialize ginitdone move.w #128,replreg(a0) set repl rule to clear move.w #0,windreg(a0) moveq #0,d0 move.b status(a0),d0 and #15,d0 get frame buffer location moveq #20,d1 lsl.l d1,d0   put it in right place move.l d0,screen(a5) movea.l d0,a1 clear the whole frame buffer move #1019,d0 except last 4 pixel lines zloop move.b #00,(a1) adda.l #width,a1 zcheck btst #7,status(a0) beq zcheck dbra d0,zloop move #3,replreg(a0) move #3,replcopy(a5) clr windcopy(a5) movep fontoffset(a0),d1 get font info offset lea 2(a0,d1.w),a1 point to font id code moveq #2,d7 count number of font found with d7 fontidchk movep 2(a1),d2 get offset of font info lea 10(a0,d2.w),a3 a3 points to first char of font cmpi.b #1,(a1) is font = roman8 ? beq.s unpkroman if so go unpack it cmpi.b #2,(a1) is font = kana8 upper half? beq.s unpkkana if so go unpack it nextfont addq #6,a1 point to next font id tst d7  have we found both fonts? bne fontidchk if not look at this one move.l screen(a5),cursoraddr(a5) initialize cursor location bsr changecursor turn it on jmp (a4) return unpkroman  move #256,d3 #chars to unpack movea.l #$C0000,a2 start at beginning of font storage unpackit adda.l screen(a5),a2 subq #1,d7 count a found font lsl #4,d3 get number of pixel rows to unpack subq #1,d3 unpackrow moveq #7,d4 we need to look at 8 bits/byte unpackrow2 btst d4,(a3) is bit set in font? sne (a2)+ set frame buffer byte accordingly dbra  d4,unpackrow2 loop till all 8 bits done addq #2,a3 look at next font byte dbra d3,unpackrow and loop till all font rows done bra nextfont go look at next font unpkkana move #128,d3 kana8 upper half has 128 chars movea.l #$C8000,a2 store at font storage + 256*128 bra unpackit * savecrtstate: preserve bit mover state * Entry: d0= replacement rule * d1= window width * * Uses: a2,a3 * savecrtstate equ * movea.l controladdr(a5),a3 savestate1 btst #7,status(a3) wait for not busy beq savestate1 movea.l (sp)+,a2 save ret addr move replcopy(a5),-(sp) save old copy move windcopy(a5),-(sp) move d0,replcopy(a5) setup new values move d1,windcopy(a5) move d0,replreg(a3) setup the registers move d1,windreg(a3) jmp (a2) * * restcrtstate: restores window width and replacement rule regs * * Uses: a3 * restcrtstate equ * movea.l controladdr(a5),a3 restcrt1 btst #7,status(a3) wait for not busy beq restcrt1 move 4(sp),windcopy(a5) restore copy variables move 6(sp),replcopy(a5) move windcopy(a5),windreg(a3) restore the registers move replcopy(a5),replreg(a3) move.l (sp)+,(sp) move up return addr rts and return * procedure cchar(ord(char),x,y:shortint); cchar movea.l (sp)+,a4 move (sp)+,d0 d0 = y mulu #16384,d0 movea.l d0,a0 adda.l screen(a5),a0 move (sp)+,d5 d5 = x (this will be used later also) lsl #3,d5 adda d5,a0 a0 = address of byte to begin at movea.l screen(a5),a1 setup font addr in a1 adda.l #$C0000,a1 fonts are just past visible space move (sp)+,d0 d0 = character mulu #128,d0 lea 0(a1,d0.l),a1 a1 = address of char in font storage move #width-8,d7 move #3,d0 set repl rule to replace btst #0,highlight(a5) inverse video? beq.s ccharb if not, skip next instruction move #12,d0 else set repl rule to invert ccharb moveq #0,d1 bsr savecrtstate move.l (a1)+,(a0)+ move.l  (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ adda d7,a0 move.l (a1)+,(a0)+ move.l (a1)+,(a0)+ btst #2,highlight(a5) underline? beq.s cchar1 no, skip next part bsr restcrtstate move #138,d0 setup to invert line 16 moveq #-8,d1 bsr savecrtstate adda #-8,a0 a0 points to line 16 move.b #0,(a0) do the invert cchar1 bsr restcrtstate jmp (a4) * * * cscrollup; * * scrolls the screen up one line of alpha text (16 graphics lines) * cscrollup bsr changecursor movea.l screen(a5),a0 movea.l a0,a1 adda #16384,a0 move.w #131,d0 moveq #0,d1 bsr savecrtstate move maxy(a5),d0 subq #1,d0 suloop2 moveq #15,d1 suloop move.b (a0),(a1) adda #width,a0 adda #width,a1 sucheck btst #7,status(a3) a3 setup by savecrtstate beq sucheck dbra d1,suloop dbra d0,suloop2 * Clear bottom line on screen * movea.l #clearl,a0 adda.l screen(a5),a0 move #15,d0 bclrloop move.b (a0),(a1) adda #width,a1 bcheck btst #7,status(a3) beq bcheck dbra d0,bclrloop bsr restcrtstate bra changecursor * * cscrolldown * * scrolls the screen down one text line * cscrolldown bsr changecursor movea.l screen(a5),a0 move maxy(a5),d0 mulu #16384,d0 sub.l #width,d0 adda.l d0,a0 movea.l a0,a1 adda #16384,a0 point to 1 char row past a1 move.w #131,d0 moveq #0,d1 bsr savecrtstate move maxy(a5),d0 subq #1,d0 sdloop2 moveq #15,d1 sdloop move.b (a1),(a0) suba #width,a0 suba #width,a1 sdcheck btst  #7,status(a3) a3 setup by savecrtstate beq sdcheck dbra d1,sdloop dbra d0,sdloop2 movea.l screen(a5),a0 moveq #15,d0 movea.l #clearl,a1 adda.l a0,a1 topclear move.b (a1),(a0) adda #width,a0 topcheck btst #7,status(a3) a3 setup by savecrtstate beq topcheck dbra d0,topclear bsr restcrtstate bra changecursor * * cupdatecursor(x,y:shortint); * cupdatecursor movea.l cursoraddr(a5),a1 movea.l (sp)+,a4 a4 = return addr move (sp)+,d5 d5 = y move (sp)+,d3 d3 = x move.w #138,d0 moveq #-8,d1 bsr savecrtstate move.b #0,(a1) adda #width,a1 curscheck btst #7,status(a3)  a3 setup in savecrtstate beq curscheck move.b #0,(a1) mulu #16384,d5 16*1024 add.l #14336,d5 spaces you to line 15 of character for cursor lsl #3,d3 movea.l screen(a5),a0 adda d3,a0  adda.l d5,a0 move.l a0,cursoraddr(a5) curscheck1 btst #7,status(a3) beq curscheck1 move.b #0,(a0) adda #width,a0 curcheck2 btst #7,status(a3) beq curcheck2 move.b #0,(a0) curcheck3 bsr restcrtstate jmp (a4) * * cclear(xpos,ypos,nchars:shortint); REVISED FOR 3.01 9/13/84 * -- clears nchars starting at xpos, ypos * -- nchars + xpos must not exceed 128 * no range checking is done * cclear bsr  changecursor movea.l (sp)+,a4 a4 = return address move (sp)+,d4 d4 = number of characters to clear move (sp)+,d3 d3 = y to begin at mulu #16384,d3 d3.l = offset to y move (sp)+,d5 d5 = x move.l a4,-(sp) stack return address lsl #3,d5 d5 = byte offset to begin at movea.l screen(a5),a0 movea.l #clearl,a1 adda.l a0,a1 blank line addr in a1 adda.l d3,a0 a0 = where to begin it all adda d5,a0 after adding x offset move d4,d3 use requested length lsl #3,d3 convert to pixels neg d3 complement move.w d3,d1 move.w #131,d0 bsr savecrtstate setup control regs moveq #15,d3 16 pixel rows per character line clearpart move.b (a1),(a0) adda #width,a0 clearcheck btst #7,status(a3) a3 setup in savecrtstate beq clearcheck dbra d3,clearpart bsr restcrtstate doneclear equ * changecursor movea.l cursoraddr(a5),a1 move.w #138,d0 moveq #-8,d1 bsr savecrtstate move.b #0,(a1) adda.l #width,a1 curchcheck btst #7,status(a3) a3 setup by savecrtstate beq curchcheck move.b #0,(a1) bsr restcrtstate rts cshiftleft moveq #1,d0 get pointer to last line of screen add maxy(a5),d0 mulu #16384,d0 16*1024*screenheight in d0 movea.l screen(a5),a0 adda.l d0,a0 pointer to last char line now in a0 movea.l a0,a1 addq #8,a1 a1 will be source cshift1 moveq #-8,d0 get # pixels to move add maxx(a5),d0 lsl #3,d0 d0 has # pixels in keybuffer neg d0 moveq #15,d4 counter for row move move d0,d1 set up width register move #131,d0 and replacement rule bsr savecrtstate cshift3  move.b (a1),(a0) and go for it adda #width,a0 bump addresses adda #width,a1 to get next pixel row cshift4 btst #7,status(a3) wait for move done beq cshift4 dbra d4,cshift3 count till 16 rows done bsr restcrtstate fix replacement rule reg and return rts cshiftright moveq #1,d0 get pointer to last row add maxy(a5),d0 mulu #16384,d0 movea.l screen(a5),a0 adda.l d0,a0 a0 points to last char row movea.l a0,a1 make a copy addq #8,a0 dest in a0 -- 1 char to right bra cshift1 now do same stuff as shift left * procedure cexchange(savearea: windowp; ymin, ymax, xmin, width: shortint); cexchange movea.l (sp)+,a4 a4 = return addr move (sp)+,d0 width of window in pixels in d0 lsr #2,d0 d0=window width in long integers subq #1,d0 setup for later looping move (sp)+,d3 d3 = x offset in chars lsl #3,d3 d3 = x offset in pixels move (sp)+,d5 d5 = ymax move (sp)+,d1 d1 = ymin movea.l (sp)+,a1 a1 = ptr to save area sub d1,d5 addq #1,d5 d5 has # of char rows to move lsl #4,d5 now has # of pixel rows to move subq #1,d5 setup for outer loop mulu #16384,d1 d1 = y offset into frame buffer move d0,d4 save d0 temporarily moveq #3,d0 setup replacement rule bsr savecrtstate move d4,d0 restore d0 movea.l screen(a5),a0 a0 points to frame buffer start adda.l d1,a0 now points to correct row adda d3,a0 do x offset into row cexchg2 movea.l a0,a2 make a working copy move d0,d7 initialize inner loop cexchg3 move.l (a2),d6 screen to temp move.l (a1),(a2)+ save area to screen move.l d6,(a1)+ tem p to save area dbra d7,cexchg3 inner loop (pixel row move) adda.l #width,a0 bump row pointer dbra d5,cexchg2 outer loop (row count) bsr restcrtstate restore control regs jmp (a4) done * procedure cscrollwindow( ymin, ymax, xmin, width: shortint); cscrollwindow bsr changecursor moveq #0,d2 set upscroll flag in d2 cscrollwindc movea.l (sp)+,a4 a4 = return addr move (sp)+,d0 d0 = width in chars lsl #3,d0 d0 = width in pixels neg d0 setup for repl rule reg move (sp)+,d1 d1 = x offset of window in chars lsl #3,d1 d1 = x offset in pixels (bytes) move (sp)+,d5  d5 = ymax move (sp)+,d3 d3 = ymin sub d3,d5 d5 has # of rows to move mulu #16,d5 now d5 has # of pixel rows to move subq #1,d5 setup for loop movea.l screen(a5),a0 frame buffer addr in a0 mulu #16384,d3 get y offset in bytes adda.l d3,a0 a0 points to first row of window adda d1,a0 now add in x offset tst d2 check up/down flag bne.s cscrollwindb and branch if dn movea.l a0,a1 make a copy for source pointer adda.l #16384,a1 which starts 1 char row down move d0,d1 move #131,d0 set up control regs bsr savecrtstate cscrollwin1 move.b (a1),(a0) move a row adda #width,a0 adda #width,a1 cscrollwin2 btst #7,status(a3) a3 setup by savecrtstate beq cscrollwin2 dbra d5,cscrollwin1 loop till all rows moved cscrollw2b moveq #15,d5 clear first or last line of window movea.l #clearl,a1 adda.l screen(a5),a1 cscrollwin3 move.b (a1),(a0) clear a pixel row adda #width,a0 cscrollwin4 btst #7,status(a3) wait for bitmover beq  cscrollwin4 dbra d5,cscrollwin3 do 16 rows bsr restcrtstate move.l a4,-(sp) restack return addr bra changecursor and fixup cursor cscrollwindb moveq #0,d4 calculate first source row loc.  move d5,d4 addq #1,d4 d4 = #pixel rows to move moveq #10,d2 lsl.l d2,d4 mpy by 1024 to get offset in FB adda.l d4,a0 add to prev. calculated pointer suba #width,a0 point to bottom row to move movea.l a0,a1 a1 is source pointer adda #16384,a0 a0 points to destination move d0,d1 d1 has width for window reg move #131,d0 setup repl rule value bsr  savecrtstate cscrollwin5 move.b (a1),(a0) move a pixel row suba #width,a0 point to next src and dst suba #width,a1 cscrollwin6 btst #7,status(a3) wait till bit mover done beq cscrollwin6 dbra  d5,cscrollwin5 go till all rows moved movea.l a1,a0 adda #width,a0 a0 points to char row to clear bra cscrollw2b cscrollwinddn bsr changecursor moveq #1,d2 set down scroll flag bra cscrollwindc go to common code cdbscrolll bsr changecursor moveq #0,d2 set left scroll flag cdbscrollb movea.l (sp)+,a4 pickup return addr move (sp)+,d1 width in chars subq #1,d1 actual width to move is 1 less lsl #3,d1 width in pixels in d1 neg d1 setup for window width reg move (sp)+,d0 x offset in chars lsl #3,d0 d0 = x offset in pixels move (sp)+,d5 d5 = ymax moveq #0,d3 move (sp)+,d3 d3 = ymin sub d3,d5 addq #1,d5 d5 = # char rows to move lsl #4,d5 d5 = # pixel rows to move subq #1,d5 setup d5 for  loop movea.l screen(a5),a0 moveq #14,d4 lsl.l d4,d3 d3 = d3*16384 ( y window start offset) adda.l d3,a0 adda d0,a0 add in x offset movea.l a0,a1 copy to a1 tst d2  check left/right flag bne.s cdbscroll2 if right, skip adda #8,a0 else src is to right of dest bra.s cdbscroll3 cdbscroll2 adda #8,a1 if right then src is left of dest cdbscroll3 move #131,d0 setup replacement rule bsr savecrtstate cdbscroll4 move.b (a0),(a1) move a pixel row adda #width,a0 point to next row adda #width,a1 cdbscroll5 btst #7,status(a3) check status beq cdbscroll5 dbra d5,cdbscroll4 loop till all rows moved bsr restcrtstate move.l a4,-(sp) bra changecursor finished! cdbscrollr bsr changecursor moveq #1,d2 set right shift flag bra  cdbscrollb go to common code * procedure cdbhighl(ord(char),x,y:shortint); * * Assumes the character is in the highlight range * Does not know about current highlight state of character * cdbhighl movea.l (sp)+,a4 move (sp)+,d0 d0 = y  mulu #16384,d0 movea.l d0,a0 adda.l screen(a5),a0 move (sp)+,d5 d5 = x (this will be used later also) lsl #3,d5 adda d5,a0 a0 = address of byte to begin at move (sp)+,d2 d2 = highlight char bsr changecursor take off the cursor move #138,d0 repl rule = negate moveq #-8,d1 we will work with 8 byte wide chars bsr savecrtstate btst #0,d2 invert? beq.s cdbhigh3 no, try for underline moveq #15,d3 setup loop for invert char movea.l a0,a1 copy pointer to the char cdbhigh1 move.b #0,(a1) do a row RQ adda #width,a1 point to next row cdbhigh2 btst #7,status(a3) is move done? beq cdbhigh2 wait here till done dbra  d3,cdbhigh1 loop till 16 rows done cdbhigh3 btst #2,d2 underline? beq.s cdbhigh5 no -- drop out adda #15360,a0 point a0 to last row of char move.b #0,(a0) and negate it cdbhigh4 btst #7,status(a3) wait for done beq cdbhigh4 cdbhigh5 bsr restcrtstate move.l a4,-(sp) bra changecursor put the cursor back end  (* (c) Copyright Hewlett-Packard Company, 1984. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $stackcheck off$ $ALLOW_PACKED ON$ { $search 'INITLOAD','ASM','INIT','SYSDEVS'$ } program initcrtgb; module crtgb; import sysglobals, asm, misc, sysdevs; export function gatorboxtype: boolean; implement const environc=environ[miscinfo:crtfrec[ nobreak:false, stupid :false,  slowterm:false, hasxycrt:true, haslccrt:FALSE, {INDICATES BITMAP} hasclock:true, canupscroll:true, candownscroll:true], crttype:0, crtctrl:crtcrec[ rlf:chr(31), ndfs:chr(28),   eraseeol:chr(9), eraseeos:chr(11), home:chr(1), escape:chr(0), backspace:chr(8),  fillcount:10, clearscreen:chr(0), clearline:chr(0), prefixed:b9[9 of false]], crtinfo:crtirec[  width :128,height:47, crtmemaddr:0, crtcontroladdr:0, keybufferaddr: 0, progstateinfoaddr: 0, keybuffersize: 119, crtcon: crtconsttype [ 0, 0, 0, 0, 0, 0, 0, 0,0, 0, 0,0], right{FS}:chr(28), left{BS}:chr(8), down{LF}:chr(10), up{US}:chr(31), badch{?}:chr(63), chardel{BS}:chr(8),stop{DC3} :chr(19), break{DLE}:chr(16), flush{ACK}:chr(6), eof{ETX}:chr(3), altmode{ESC}:chr(27), linedel{DEL}:chr(127), backspace{BS}:chr(8), etx:chr(3),prefix:chr(0), prefixed:b14[14 of false], cursormask : 0, spare : 0]];  type scrtype = packed array[0..maxint] of crtword; scrptr=^scrtype; crtregtype = 0..15; var cursoraddr: integer; screenwidth: shortint; screenheight:shortint; maxx: shortint; maxy: shortint; screensize:shortint; defaulthighlight: shortint; highlight: shortint; holdcursor: packed array[0..3] of integer; {cursor content} procedure cchar(c,x,y:shortint);external; procedure cursoroff; external; procedure cursoron; external; procedure cscrollup;external; procedure cscrolldown;external; procedure  cclear(x,y,n:shortint);external; procedure cupdatecursor(x,y:shortint);external; procedure cbuildtable;external; procedure cshiftleft; external; procedure cshiftright; external; procedure cexchange( savearea: windowp; ymin, ymax, xmin, width: shortint); external; procedure cscrollwindow( ymin, ymax, xmin, width: shortint); external; procedure cscrollwinddn( ymin, ymax, xmin, width: shortint); external; procedure cdbscrolll( ymin, ymax, xmin, width: shortint); external; procedure cdbscrollr( ymin, ymax, xmin, width: shortint); external; procedure dumpg ; label 1; const gwidthb = 128; gmaxheight = 512; gbuffersize = gwidthb + 7; type gbyte = 0..255; row_def = packed array [0..(1024*768)-1] of gbyte; var row : ^row_def;  gbuffer : packed array [1..gbuffersize] of char; i,j : integer; index : integer; bit_mask : integer; result : integer; begin row := anyptr(frameaddr); write(gfiles[4]^,#27'*rA'); { initiate graphics sequence } gbuffer[1] := chr(27); { escape sequence for graphics } gbuffer[2] := '*'; gbuffer[3] := 'b'; gbuffer[4] := '1'; gbuffer[5] := '2'; gbuffer[6] := '8'; gbuffer[7] := 'W'; for j := 0 to 767 do begin for i := 0 to 127 do begin result := 0;  index := j*1024+i*8; bit_mask := 256; for index := index to index+7 do begin bit_mask := bit_mask div 2; if row^[index]<>0 then result := bit_mask+result; end; gbuffer[i+8] := chr(result); end; write(gfiles[4]^,gbuffer:gwidthb+7); if ioresult <> ord(inoerror) then goto 1; end; write(gfiles[4]^,#27'*rB'); { terminate graphics sequence } 1: end; procedure doupdatecursor; begin cup datecursor(xpos,ypos); end; procedure getxy(var x,y: integer); begin x := xpos; y := ypos; end; procedure setxy(x, y: shortint); begin if x>=screenwidth then xpos:=maxx else if x<0 then xpos:=0 else xpos := x; if y>=screenheight then ypos:=maxy else if y<0 then ypos:=0 else ypos := y; end; procedure gotoxy(x,y: integer); begin setxy(x,y); doupdatecursor; end; procedure clear(number: shortint); { REVISED FOR 3.01 } var x,y: shortint; clearchars: shortint; begin x:=xpos; y:=ypos; while number>0 do begin if maxx-x+10 do begin kbdio(fp, readtoeol, s, 1, 0);  if strlen(s)=0 then length := 0 { else if s[1] = chr(etx) then length := 0 } else begin length := length - 1; crtio(fp, writebytes, s[1], 1, 0); buf := addr(buf^, 1); buffer[0] := chr(ord(buffer[0])+1); end; end; end; startread, readbytes: begin while length>0 do begin kbdio(fp, readbytes, buf^, 1, 0); if buf^ = chr(etx) then length := 0 else length := length - 1; if buf^ = eol then crtio(fp, writeeol, buf^, 1, 0) else crtio(fp, writebytes, buf^, 1, 0); buf := addr(buf^, 1); end; if request = startread then call(fp^.feot, fp); end; writeeol: begin  if ypos=maxy then scrollup; gotoxy(0, ypos+1); end; startwrite, writebytes: begin while length>0 do begin c:=buf^; buf:=addr(buf^,1); length:=length-1; case c of homechar: setxy(0,0); leftchar: if (xpos = 0) and (ypos>0) then setxy(maxx, ypos-1) else setxy(xpos-1, ypos); rightchar: if (xpos = maxx) and (ypos0 then setxy(xpos, ypos-1); end; downchar: if ypos=maxy then scrollup else setxy(xpos, ypos+1); bellchar: beep; cteos:  clear(screensize-(ypos*screenwidth+xpos)); cteol: clear(screenwidth-xpos); clearscr: begin setxy(0,0); clear(screensize); end; eol: setxy(0, ypos); chr(etx): length:=0; otherwise if (ord(c)>=128) and (ord(c)<144) then if (ord(c)>=136) then highlight:= highlight mod 2048 + (ord(c)-136)*4096 else highlight:=((highlight div 2048)*8   +(ord(c)-128))*256 else begin cursoroff; cchar(maptocrt(c),xpos,ypos); cursoron; if xpos = maxx then  begin if ypos = maxy then scrollup; setxy(0, ypos+1); end else setxy(xpos+1, ypos); end; end; doupdatecursor;  end; {while} if request = startwrite then call(fp^.feot, fp); end; otherwise ioresult := ord(ibadrequest); end; {case} end; procedure lineops(op: crtllops; anyvar position: integer; c: char); var i,j: shortint; sptr: ^string255; begin j:=highlight; highlight:=defaulthighlight; case op of cllput: cchar(maptocrt(c), position, screenheight); cllshiftl: begin cshiftleft; cchar(ord(' '), maxx-8, screenheight); end; cllshiftr: begin cshiftright; cchar(ord(' '), 0, screenheight); end; cllclear: cclear(0, screenheight, maxx-7); clldisplay: begin sptr:=addr(position); for i:=1 to strlen(sptr^) do cchar(maptocrt(sptr^[i]), i-1, screenheight); for i:=strlen(sptr^) to (maxx-8) do cchar(ord(' '), i, screenheight); end; putstatus: cchar(ord(c), maxx-7+position, screenheight); end; { of case } highlight:=j; end; procedure crtdebug(op: dbcrtops; var dbrec: dbcinfo); type iptr = ^iarray; iarray = array[0..maxint] of shortint; var i: shortint; j: integer; tempaddr: integer; begin with dbrec do begin case op of dbinfo: savesize:=(xmax-xmin+1)*(ymax-ymin+1)*128; {assumes 8x16 char} dbgotoxy: cupdatecursor(cursx, cursy); dbscrollup: begin cscrollwindow( ymin, ymax, xmin, xmax-xmin+1); cclear(xmin, ymax, xmax-xmin+1); end; dbscrolldn: begin cscrollwinddn(ymin, ymax, xmin, xmax-xmin+1);  cclear(xmin, ymin, xmax-xmin+1); end; dbscrolll: begin cdbscrolll(ymin, ymax, xmin, xmax-xmin+1); cursoroff; for i:=ymin to ymax do cchar (ord(' '), xmax, i); cursoron; end; dbscrollr: begin cdbscrollr(ymin, ymax, xmin, xmax-xmin+1); cursoroff; for i:=ymin to ymax do cchar (ord(' '), xmin, i);  cursoron; end; dbhighl: ; { Not implemented for color bitmap displays } dbput: begin cursoroff; i:=highlight; highlight:=debughighlight; if charismapped then cchar( maptocrt(c), cursx, cursy) else cchar( ord(c), cursx, cursy); highlight:=i; cursoron; end; dbclear: for i:=ymin to ymax do cclear( xmin, i, xmax-xmin+1); dbcline: cclear( cursx, cursy, xmax-cursx+1); dbinit: begin for j:= 0 to (savesize div 2)-1 do iptr(savearea)^[j]:=0; cursx:=xmin; cursy:=ymin; dcursoraddr:=frameaddr; charismapped:=true; debughighlight:=0; areaisdbcrt:=true; end; dbexcg: begin cursoroff; cexchange( savearea, ymin, ymax, xmin, (xmax-xmin+1)*8); tempaddr:=cursoraddr; cursoraddr:=dcursoraddr; dcursoraddr:=tempaddr; cursoron; areaisdbcrt:=not areaisdbcrt; end; end; { of case } end; { of with } end; { crtdebug procedure } procedure dummy; begin end; procedure gatorboxinit; var i: shortint; begin idle:=245; { set io char to roman8 value } with syscom^.crtinfo do begin screenwidth:=width; screenheight:=height; maxx:=screenwidth-1; maxy:=screenheight-1; screensize:=screenwidth*screenheight; cbuildtable; highlight:=0; defaulthighlight:=0; gotoxy(0,0);   dumpalphahook := dumpg; dumpgraphicshook := dumpg; updatecursorhook:=doupdatecursor; dbcrthook:=crtdebug; crtllhook:=lineops; crtiohook:=docrtio; crtinithook:=gatorboxinit; togglealphahook:=dummy; togglegraphicshook:=dummy; currentcrt:=bitmaptype; keybuffer^.maxsize:=maxx-8; end; end; function gatorboxtype:boolean; const newbitmapid=57; {primary id for new bitmap displays} gboxsecid=1; {gatorbox secondary id} var ptr: ^shortint; i: shortint; dummy: shortint; found: boolean; begin found:=false; ptr:=anyptr(hex('560000')); try dummy:=ptr^; if (dummy mod 128) = newbitmapid then begin ptr:=anyptr(integer(ptr)+20); { look at secondary id } dummy:=ptr^ mod 128; if dummy=gboxsecid then begin  found:=true; bitmapaddr:=integer(ptr)-20; end; end; recover if escapecode<>-12 then escape(escapecode); if found then begin syscom^:=environc; gatorboxinit; end; gatorboxtype:=found; end; { gatorboxtype } end; { of module -- I hope } import crtgb, loader; begin if gatorboxtype then markuser; end.  (* (c) Copyright Hewlett-Packard Company, 1984. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $stackcheck off$ { $search 'INITLOAD','ASM','INIT','SYSDEVS'$ } $ALLOW_PACKED ON$ { 4/10/85 JWS } program initcrtb; module crtb; import sysglobals, asm, misc, sysdevs; export function gatorcrttype: boolean; implement const environc=environ[miscinfo:crtfrec[ nobreak:false, stupid :false, slowterm:false, hasxycrt:true, haslccrt:FALSE, {INDICATES BITMAP} hasclock:true,  canupscroll:true, candownscroll:true], crttype:0, crtctrl:crtcrec[ rlf:chr(31), ndfs:chr(28),  eraseeol:chr(9), eraseeos:chr(11), home:chr(1), escape:chr(0), backspace:chr(8),  fillcount:10, clearscreen:chr(0), clearline:chr(0), prefixed:b9[9 of false]], crtinfo:crtirec[ width :128,height:47, crtmemaddr:0, crtcontroladdr:0, keybufferaddr: 0, progstateinfoaddr: 0, keybuffersize: 119, crtcon: crtconsttype [ 0, 0, 0, 0, 0, 0, 0, 0,0, 0, 0,0],  right{FS}:chr(28), left{BS}:chr(8), down{LF}:chr(10), up{US}:chr(31), badch{?}:chr(63), chardel{BS}:c hr(8),stop{DC3} :chr(19), break{DLE}:chr(16), flush{ACK}:chr(6), eof{ETX}:chr(3), altmode{ESC}:chr(27), linedel{DEL}:chr(127), backspace{BS}:chr(8), etx:chr(3),prefix:chr(0), prefixed:b14[14 of false], cursormask : 0, spare : 0]]; type scrtype = packed array[0..maxint] of crtword; scrptr=^scrtype; crtregtype = 0..15; crtcmdwrd = packed record case integer of 0: (topbyte, botbyte: byte); 1: (longword: shortint); 2: (p1,p2, textfield, softfield: boolean); end; var cursoraddr: integer; screenwidth: shortint; screenheight:shortint; maxx: shortint; maxy: shortint; screensize:shortint; defaulthighlight: shortint; highlight: shortint; procedure cchar(c,x,y:shortint);external; procedure changecursor; external; procedure cscrollup;external; procedure cscrolldown;external; procedure cclear(x,y,n:shortint);external; procedure cupdatecursor(x,y:shortint);external; procedure cbuildtable;external; procedure cshiftleft; external; procedure cshiftright; external; procedure cexchange( savearea: windowp; ymin, ymax, xmin, width: shortint); external; procedure cscrollwindow( ymin, ymax, xmin, width: shortint); external; procedure cscrollwinddn( ymin, ymax, xmin, width: shortint); external; procedure cdbscrolll( ymin, ymax, xmin, width: shortint); external; procedure cdbscrollr( ymin, ymax, xmin, width: shortint); external; procedure cdbhighl( c, x, y: shortint); external; procedure dumpg ; label 1; const gwidthb = 128; gmaxheight = 512; gbuffersize = gwidthb + 7; type gbyte = 0..255; row_def = packed array [0..(1024*768)-1] of gbyte; var row : ^row_def; gbuffer : packed array [1..gbuffersize] of char; i,j : integer; index : integer; bit_mask : integer; result : integer; begin row := anyptr(frameaddr); write(gfiles[4]^,#27'*rA'); { initiate graphics sequence } gbuffer[1] := chr(27); { escape sequence for graphics } gbuffer[2] := '*'; gbuffer[3] := 'b';  gbuffer[4] := '1'; gbuffer[5] := '2'; gbuffer[6] := '8'; gbuffer[7] := 'W'; for j := 0 to 767 do begin for i := 0 to 127 do begin result := 0; index := j*1024+i*8; bit_mask := 256; for index := index to index+7 do begin bit_mask := bit_mask div 2; if odd(row^[index]) then result := bit_mask+result; end; gbuffer[i+8] := chr(result); end; write(gfiles[4]^,gbuffer:gwidthb+7); if ioresult <> ord(inoerror) then goto 1; end; write(gfiles[4]^,#27'*rB'); { terminate graphics sequence } 1: end; procedure doupdatecursor; var cursaddr: crtcmdwrd; begin cupdatecursor(xpos,ypos); end; procedure getxy(var x,y: integer); begin x := xpos; y := ypos; end; procedure setxy(x, y: shortint); begin if x>=screenwidth then xpos:=maxx else if x<0 then xpos:=0 else xpos := x; if y>=screenheight then ypos:=maxy else if y<0 then ypos:=0 else ypos := y; end; procedure gotoxy(x,y: integer); begin setxy(x,y); doupdatecursor; end; procedure clear(number: shortint); { REVISED FOR 3.01 } var x,y: shortint; clearchars: shortint; begin x:=xpos; y:=ypos; while number>0 do begin if maxx-x+10 do begin kbdio(fp, readtoeol, s, 1, 0); if strlen(s)=0 then length := 0  { else if s[1] = chr(etx) then length := 0 } else begin length := length - 1; crtio(fp, writebytes, s[1], 1, 0); buf := addr(buf^, 1); buffer[0] := chr(ord(buffer[0])+1); end; end;  end; startread, readbytes: begin while length>0 do begin kbdio(fp, readbytes, buf^, 1, 0); if buf^ = chr(etx) then length := 0 else length := length - 1; if buf^ = eol then crtio(fp, writeeol, buf^, 1, 0) else crtio(fp, writebytes, buf^, 1, 0); buf := addr(buf^, 1); end; if request = startread then call(fp^.feot, fp); end; writeeol: begin if ypos=maxy then scrollup;  gotoxy(0, ypos+1); end; startwrite, writebytes: begin while length>0 do begin c:=buf^; buf:=addr(buf^,1); length:=length-1; case c of homechar: setxy(0,0); leftchar: if (xpos = 0) and (ypos>0) then setxy(maxx, ypos-1) else setxy(xpos-1, ypos); rightchar: if (xpos = maxx) and (ypos0 then setxy(xpos, ypos-1); end; downchar: if ypos=maxy then scrollup else setxy(xpos, ypos+1); bellchar: beep; cteos: clear(screensize-(ypos*screenwidth+xpos));  cteol: clear(screenwidth-xpos); clearscr: begin setxy(0,0); clear(screensize); end; eol: setxy(0, ypos); chr(etx): length:=0; otherwise if (ord(c)>=128) and (ord(c)<144) then highlight:= (ord(c)-128)*256 else begin changecursor; cchar(maptocrt(c),xpos,ypos); changecursor; if xpos = maxx then  begin if ypos = maxy then scrollup; setxy(0, ypos+1); end else setxy(xpos+1, ypos); end; end; doupdatecursor; end; {while} if request = startwrite then call(fp^.feot, fp); end; otherwise ioresult := ord(ibadrequest); end; {case} end; procedure lineops(op: crtllops; anyvar position: integer; c: char); var i,j: shortint; sptr: ^string255; begin j:=highlight; highlight:=defaulthighlight; case op of cllput: cchar(maptocrt(c), position, screenheight); cllshiftl: begin cshiftleft; cchar(ord(' '), maxx-8, screenheight); end; cllshiftr: begin cshiftright; cchar(ord(' '), 0, screenheight); end; cllclear: cclear(0, screenheight, maxx-7); clldisplay: begin sptr:=addr(position); for i:=1 to strlen(sptr^) do cchar(maptocrt(sptr^[i]), i-1, screenheight); for i:=strlen(spt r^) to (maxx-8) do cchar(ord(' '), i, screenheight); end; putstatus: cchar(ord(c), maxx-7+position, screenheight); end; { of case } highlight:=j; end; procedure crtdebug(op: dbcrtops; var dbrec: dbcinfo); type iptr = ^iarray; iarray = array[0..maxint] of shortint; var i: shortint; j: integer; tempaddr: integer; begin with dbrec do begin case op of dbinfo: savesize:=(xmax-xmin+1)*(ymax-ymin+1)*128; {assumes 8x14 char} dbgotoxy: cupdatecursor(cursx, cursy);  dbscrollup: cscrollwindow( ymin, ymax, xmin, xmax-xmin+1); dbscrolldn: cscrollwinddn(ymin, ymax, xmin, xmax-xmin+1); dbscrolll: begin cdbscrolll(ymin, ymax, xmin, xmax-xmin+1); changecursor; for i:=ymin to ymax do cchar (ord(' '), xmax, i); changecursor; end; dbscrollr: begin cdbscrollr(ymin, ymax, xmin, xmax-xmin+1); changecursor; for i:=ymin to ymax do cchar (ord(' '), xmin, i); changecursor; end; dbhighl: cdbhighl( ord(c), cursx, cursy); dbput: begin changecursor; i:=highlight; highlight:=debughighlight; if charismapped then {3/25/85} cchar( maptocrt(c), cursx, cursy) {3/25/85} else {3/25/85} cchar( ord(c), cursx, cursy); highlight:=i; changecursor; end; dbclear: for i:=ymin to ymax do cclear( xmin, i, xmax-xmin+1); dbcline: cclear( cursx, cursy, xmax-cursx+1); dbinit: begin for j:= 0 to (savesize div 2)-1 do iptr(savearea)^[j]:=0; cursx:=xmin; cursy:=ymin; dcursoraddr:=frameaddr; areaisdbcrt:=true; charismapped:=false; debughighlight:=0; end; dbexcg: begin changecursor; cexchange( savearea, ymin, ymax, xmin, (xmax-xmin+1)*8); tempaddr:=cursoraddr; cursoraddr:=dcursoraddr; dcursoraddr:=tempaddr; changecursor; areaisdbcrt:=not areaisdbcrt; end; end; { of case } end; { of with } end; { crtdebug procedure } procedure dummy; begin end; procedure gatorcrtinit; var i: shortint; begin idle:=245; { set io char to roman8 value } with syscom^.crtinfo do begin screenwidth:=width; screenheight:=height; maxx:=screenwidth-1; maxy:=screenheight-1; screensize:=screenwidth*screenheight; cbuildtable; highlight:=0; defaulthighlight:=0; gotoxy(0,0); dumpalphahook := dumpg; dumpgraphicshook := dumpg; updatecursorhook:=doupdatecursor; dbcrthook:=crtdebug; crtllhook:=lineops; crtiohook:=docrtio; crtinithook:=gatorcrtinit; togglealphahook:=dummy; togglegraphicshook:=dummy; currentcrt:=bitmaptype; keybuffer^.maxsize:=maxx-8; end; end; function gatorcrttype:boolean; const gatorid=25; var ptr: ^shortint; i: shortint; dummy: shortint; found: boolean; begin found:=false; ptr:=anyptr(hex('560000')); try dummy:=ptr^; if (dummy mod 128) = gatorid then begin found:=true; bitmapaddr:=integer(ptr); end; recover  if escapecode<>-12 then escape(escapecode); gatorcrttype:=found; if found then begin syscom^:=environc; gatorcrtinit; end; end; end; { of module -- I hope } import crtb, loader; begin if gatorcrttype then markuser; end.  page * * BOBCAT family bit-mapped alpha driver * * Pascal 3.1 version by J. Schmidt * def cscrollup,cscrolldown,cupdatecursor,cchar,cclear def cbuildtable,cshiftleft,cshiftright def cexchange,cscrollwindow,cursoron,cursoroff  def cscrollwinddn,cdbscrolll,cdbscrollr,cclearall rorg.l 0 refa crtbc,sysdevs,delay_timer lmode delay_timer nosyms sprint lowresfont equ $64000 400*1024 fontoff1 equ $3C00 15*1024 fontoff2 equ $7800 30*1024 fontoff3   equ $B400 45*1024 fontwidth equ crtbc-2 fontht equ crtbc-4 maxx equ crtbc-10 maxy equ crtbc-12 highlight equ crtbc-18 planemask equ crtbc-20 lowres equ crtbc-21 hascolor equ crtbc-22 holdcursor equ crtbc-38 {SFB 9/22/86} cursoraddr equ crtbc-42 {SFB 9/22/86} softcursor equ crtbc-43 {SFB 9/22/86} controladdr equ sysdevs-86 screen equ sysdevs-90 * TOPCAT status registers (bitslice) vblank equ $4040 vertical retrace status busy equ $4044 window mover busy intv equ $4048 requesting vert. blank interrupt intb equ $404C requesting not busy interrupt * TOPCAT control registers (bit slice) nblank equ $4080 enable display ensync equ $4084 turn on sync tcwen equ $4088 TOPCAT write enable tcren equ $408C TOPCAT read enable fben equ $4090 frame buffer write enable intenv equ $4094 enable int. on vert. blanking intenb equ $4098 enable int. on not busy wmove equ $409C window move trigger blink equ $40A0 blink enable onecas equ $40A4 altframe equ $40A8 curon equ $40AC cursor enable * TOPCAT control registers (word wide) prr equ $40EA pixel replacement rule wrr equ $40EE window move replacement rule sox equ $40F2 src window origin x soy equ $40F6 src window origin y dox equ $40FA dest. window origin x doy equ $40FE dest. window origin y ww equ $4102 window width wh equ $4106 window height cax equ $410A cursor x position cay equ $410E cursor y position cul  equ $4112 cursor length * NEREID color map registers cmapbusy equ $6003 color map busy cmapptr equ $60B8 color map ptr reg (word) cmapmask equ $60BA plane mask cmapred equ $61B2 color map red (word) cmapgrn equ $61B4 color map green (word) cmapblu equ $61B6 color map blue (word) cmapwrt equ $60F0 color map write trigger (word) width equ 1024 initoffset equ $23 offset to initialization offset fontoffset equ $3B offset to font info offset frameoffset equ $5D offset to frame buffer reg. offset cmapaddr equ $33 addr of color map (0 = monochrome) cmapidoff equ $57 offset to color map id offset cmapinitoff equ $3F offset to cmap 0 init region offset framecnt equ $5B offset of number of frames nonsquare equ $17 flag for non-square pixels (low res) fbwidth equ $5  width of frame buffer fbht equ $9 height of frame buffer dispht equ $11 height of displayed frame buffer * * cbuildtable * cbuildtable movea.l controladdr(a5),a0 get pointer to ROM start movep initoffset(a0),d1 form pointer to init block movea.l a0,a1 make copy of ROM start addr adda d1,a1 a1 points to init info now jsr ginitblock call the initializatiion routine  clr.b hascolor(a5) movep cmapaddr(a0),d0 get color map addr tst d0 beq.s cnocolor if 0 then no color init moveq #0,d1 movep cmapidoff(a0),d0 get ptr to color map id reg tst  d0 if ptr=0, then use init region 0 beq.s cinitclr move.b 0(a0,d0),d1 get cmap id into d1 cinitclr and #3,d1 look at least sig bits lsl #2,d1 move.b cmapinitoff(a0,d1.w),d2 form cmap init block addr lsl #8,d2 move.b cmapinitoff+2(a0,d1.w),d2 movea.l a0,a1 adda d2,a1 a1 points to cmap init block jsr ginitblock st hascolor(a5) set color bo  olean cnocolor clr.l screen(a5) clear space for frame buffer addr movep.w frameoffset(a0),d0 get offset of frame buffer loc. move.b 0(a0,d0),screen+1(a5) form frame buffer addr moveq #-1,d1 set all 1's in d1 moveq #0,d0 clear d0 move d1,ensync(a0) enable sync on all planes move d1,tcwen(a0) enable writes to all TOPCATS move d1,fben(a0) enable writes to all planes  move.b #1,tcren(a0) read from plane 0 TOPCAT move d0,intenv(a0) disable interrupts move d0,intenb(a0) move d0,blink(a0) turn off blinking move.b framecnt(a0),d0 d0=# of planes in system beq.s cnumplanes if zero then read planes moveq #8,d1 else make the mask up moveq #$FF,d2 sub d0,d1 d1 has shift count lsr.b d1,d2 after shift d2 has mask  bra.s csetplanes go setup planemask cnumplanes moveq #0,d2 movea.l screen(a5),a1 addr of fb in a1 move.b #$FF,(a1) write all 1's move.b (a1),d2 get plane mask in d2 csetplanes move.b d2,nblank(a0) blank nonexistent planes move.b d2,planemask(a5) save as plane mask tst.b hascolor(a5) monochrome ? beq.s cnocolor2 if so then skip color map init move d2,cmapmask(a0)  set color map mask jsr loadcmap load the color map st hascolor(a5) set color boolean cnocolor2 moveq #0,d0 move d0,wrr(a0) setup to clear frame buffer move d0,dox(a0)  dest is 0,0 move d0,doy(a0) move d0,sox(a0) move d0,soy(a0) movep.w fbwidth(a0),d2 get width from ROM move d2,ww(a0) set as window width movep.w fbht(a0),d2 get height from ROM subq #4,d2 don't touch last 4 lines move d2,wh(a0) set as window height move.b planemask(a5),wmove(a0) trigger the move cclrtst move.b wmove(a0),d2 check for move done and.b planemask(a5),d2 beq.s cfbclrdone moveq #50,d2 kill time dbra d2,* bra cclrtst cfbclrdone move #$300,prr(a0) setup pixel repl rule move.l d0,d1 move.l d0,d2 movep fontoffset(a0),d1 get font info offset lea 2(a0,d1.w),a1 point to font id code moveq #2,d7 count number of font found with d7 btst #0,nonsquare(a0) find 2 for high res, 1 for low res beq.s fontidchk moveq #1,d7 fontidchk movep 2(a1),d2 get offset of font info lea 0(a0,d2.l),a3 a3 points to font info move.b (a3),d0 d0 = font height moveq #0,d1 move.b 2(a3),d1 d1 = font width move d0,fontht(a5) move d1,fontwidth(a5) adda #10,a3 a3 now points to first char cmpi.b #1,(a1) is font = roman8 ? bne.s kanachk bsr unpkroman if so go unpack it kanachk btst #0,nonsquare(a0) is this low res??? bne.s nextfont if so then skip kana for now cmpi.b #2,(a1) is font = kana8 upper half? bne.s nextfont bsr unpkkana  if so go unpack it nextfont addq #6,a1 point to next font id tst d7 have we found both fonts? bne fontidchk if not look at this one btst #0,nonsquare(a0) is this low res?  beq.s curset if not then skip jsr lowreskanafix else do kana unpack curset move #0,cax(a0) set cursor to 0,0 move #0,cay(a0) move fontwidth(a5),cul(a0) set cursor length move.b   planemask(a5),curon(a0) enable cursor on all planes move.l screen(a5),cursoraddr(a5) save init cursoraddr for 98549A bra cursoron turn on 98549A soft cursor SFB 9/24/86 * rts * * misc utilities for initialization * * loadcmap lea cmaptable,a1 initialize the color map moveq #0,d1 clear some registers move.l d1,d2 move.l d1,d3 move.l d1,d4 cmaploop1 move.b (a1)+,d2 get rgb values in d2-d4 move.b (a1)+,d3 move.b (a1)+,d4 bsr cmapenter stuff the color map entry addq #1,d1 bump cmap pointer value cmp #16,d1 have we done 16 yet? bne cmaploop1 if not then continue moveq #-1,d2 set entries 16-255 to white move.l d2,d3 move.l d2,d4 cmaploop2 bsr cmapenter addq #1,d1 cmp #256,d1 done with cmap init? bne cmaploop2 cmaploop3 btst #2,cmapbusy(a0) wait for not busy bne cmaploop3 moveq #0,d2 move d2,cmapred(a0) zero the rgb regs move 0,d1 force DIO uncached read for delay SFB move d2,cmapgrn(a0) move 0,d1 force DIO uncached read for delay SFB move d2,cmapblu(a0) rts cmapenter btst #2,cmapbusy(a0) check for color map busy bne cmapenter loop till bit is clear move d1,d5 not d5  kludge for NEREID move d5,cmapptr(a0) set pointer register move 0,d5 force DIO uncached read for delay SFB move d2,cmapred(a0) stuff the rgb regs move 0,d5 force DIO uncached read for delay SFB move d3,cmapgrn(a0) move 0,d5 force DIO uncached read for delay SFB move d4,cmapblu(a0) move 0,d5 force DIO uncached read for delay SFB move d1,cmapwrt(a0) hit the write trigger move 0,d5 force DIO uncached read for delay SFB * nop kludge for NERIED - replaced w/move SFB rts done with cmap entry write * * * unpkroman subq #1,d7 count a found font btst #0,nonsquare(a0) check for low-res beq.s unpkromanhr if not unpack hi-res moveq #63,d3 do a blocks of 64 movea.l #lowresfont,a2 bsr.s unpackit moveq #63,d3 do a blocks of 64 movea.l #lowresfont+fontoff1,a2 bsr.s unpackit moveq #63,d3 do a blocks of 64 movea.l #lowresfont+fontoff2,a2 bsr.s unpackit moveq #63,d3 do a blocks of 64 movea.l #lowresfont+fontoff3,a2 bra.s unpackit unpkromanhr moveq #127,d3 #chars to unpack-1 movea.l #$C0000,a2 start at beginning of font storage bsr.s unpackit moveq #127,d3 now unpack second half of font movea.l #$C4000,a2 bra.s unpackit unpkkana subq #1,d7 moveq #127,d3 kana8 upper half has 128 chars movea.l #$C8000,a2 store at font storage + 256*128 unpackit adda.l screen(a5),a2 movea.l a2,a4 a4 points to font char start addr suba fontwidth(a5),a4 unpackchar move d0,d5 unpack d0 rows/char subq #1,d5 adda fontwidth(a5),a4 point to char storage start movea.l a4,a2 make the working copy unpackrow moveq #7,d4 we need to look at 8 bits/byte unpackrow2 btst d4,(a3) is bit set in font? sne (a2)+  set frame buffer byte accordingly dbra d4,unpackrow2 loop till all 8 bits done addq #2,a3 look at next font byte btst #0,nonsquare(a0) is this low-res? beq.s nextrow if not!  then do next row moveq #7,d4 else do last part of font row moveq #3,d6 unpackrow3 btst d4,(a3) sne (a2)+ subq #1,d4 dbra d6,unpackrow3 addq #2,a3 point to next font byte nextrow adda #width,a2 adjust storage pointer suba fontwidth(a5),a2 dbra d5,unpackrow and loop till rows in char done dbra d3,unpackchar loop till all chars done rts go look at next font ginitblock moveq #0,d1 clear some regs moveq #0,d0 move.b 2(a1),d0 get word count to initialize movep 4(a1),d1 form destination offset add.l a0,d1  d1 points to dest addr lea 8(a1),a2 a2 points to first data byte movea.l d1,a3 a3 points to destination btst #0,(a1) is this a bit test block? bne.s ginitbtst  if so go handle it ginitloop movep 0(a2),d1 form a data word in d1 move.w d1,(a3)+ move data to the destination addr btst #6,(a1) increment data pointer bne.s ginit1  based on control byte addq #4,a2 ginit1 dbra d0,ginitloop loop till word count exhausted btst #7,(a1) was this last block? bne.s ginitdone yes -- go return btst #6,(a1)  adjust data pointer beq.s ginit2 to point to next init block ginit3 addq #4,a2 ginit2 movea.l a2,a1 a1 points to new init block bra ginitblock do the initialize ginitdone rts ginitbtst moveq #0,d2 handle bit test blocks here move.b 2(a2),d2 d2 = bit # to test ginittst2 move (a3),d3 d3 = data word to test btst #0,(a2) check for sense of test bne.s ginittst3 comp if waiting for 0 not d3 ginittst3 btst d2,d3 check the bit beq ginittst2 if not 1 then loop btst #7,(a1) was this last block? bne ginitdone if so then return bra ginit3 else do next block * * cmaptable equ * initial color map contents (r,g,b) dc.b 0,0,0 0 dc.b 255,255,255 1 dc.b 255,0,0 2 dc.b 255,255,0 3 dc.b 0,255,0 4 dc.b 0,255,255 5 dc.b 0,0,255 6 dc.b 255,0,255 7  dc.b 0,0,0 8 dc.b 204,187,51 9 dc.b 51,170,119 10 dc.b 136,102,170 11 dc.b 204,68,102 12 dc.b 255,102,51 13 dc.b 255,119,0 14 dc.b 221,136,68 15 first_blk_offset equ $73000+396 460*1024+(33 chars) first_blk_width equ 23 24 words (31 chars + junk) second_blk_offset equ $73000+fontoff1 second_blk_width equ 47 48 words (64 chars) * lowreskanafix equ * movep dispht(a0),d0 move roman font over kana area add #30,d0 move d0,soy(a0) add #30,d0 move d0,doy(a0) moveq #0,d0 move d0,sox(a0) move d0,dox(a0) move #width,ww(a0) move #30,wh(a0) move #3,wrr(a0) move.b planemask(a5),wmove(a0) trigger the move jsr waitforready * move first block lea block1,a1 movea.l screen(a5),a2 adda.l  #first_blk_offset,a2 move #first_blk_width,d4 bsr.s unpk_kana_blk * move second block lea block2,a1 movea.l screen(a5),a2 adda.l #second_blk_offset,a2 move #second_blk_width,d4 * unpack kana font bloc! k unpk_kana_blk equ * move #14,d0 setup to move 15 rows upb0 movea.l a2,a3 a2=line start, a3=current move d4,d1 pre-adjusted word count upb1 moveq #15,d2 bit pointer move (a1)+,d3 get data word upb2  btst d2,d3 test a bit sne (a3)+ set byte in font space dbra d2,upb2 count bits dbra d1,upb1 count words in row adda #width,a2 point to next row dbra d0,upb0 count rows rts block1 equ * KANA CHARS 161-191 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$0001F801 dc.l $80000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000606,$00000180,$C0060000,$18000019,$80000001 dc.l $80000000,$00018001,$80000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000C06,$00000180,$C0060000 dc.l $18000019,$80000001,$80000000,$00018001,$80000007 dc.l $FE000000,$00000000,$00000000,$00000000,$7FC0187F dc.l $E3FC7FE7,$FE3FC1FE,$1FE3F87F,$E3C07FC7,$FC60E000 dc.l $00018001,$80000000,$0600000C,$06000003,$01800000 dc.l $00000000,$00603860,$60600380,$C6060306,$31800C19 dc.l $80000061,$86346000,$00018001,$80000E03,$FE3FC030 dc.l $3FC0007F,$C7FC1F83,$FC6C67FC,$0660D860,$60600780 dc.l $C67FE606,$61800C19,$87860061,$8C186000,$00018001 dc.l $80000E00,$0C00C0E0,$30C3FC07,$018C0180,$0C366000 dc.l $07871800,$60600D80,$C606000C,$01800C01,$80060181 dc.l $80006000,$00018001,$80000000,$18078760,$00C0600F dc.l $01980301,$FC00C000,$06001800,$C0601981,$86060018 dc.l $01800C01,$800C0601,$8000C000,$0E018001,$80E00000 dc.l $60060060,$0180601B,$01800600,$0C018000,$06001801 dc.l $80606181,$86060060,$03000C03,$03181981,$86018000 dc.l $0E01801F,$80E00003,$80180060,$0E03FC63,$01807FE7 dc.l $FC0E0000,$3800180E,$07FE0183,$1C060380,$1C07FC1C dc.l $03E06060,$FC0E0000,$00000000,$00600000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00C00000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 block2 equ * KANA CHARS 192-255 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $003301E0,$7C07C07C,$07C07C07,$C07C07C0,$7C07C07C dc.l $07C07C07,$C07C07C0,$7C07C07C,$07C07C07,$C07C07C0 dc.l $7C07C07C,$07C07C07,$C07C03FC,$00000000,$00001800 dc.l $30000000,$06000000,$03000000,$00060000,$00000000 dc.l $00001800,$00000000,$00000000,$00000000,$00330330 dc.l $40040040,$04004004,$00400400,$40040040,$04004004 dc.l $00400400,$40040040,$04004004,$00400400,$40040040 dc.l $04004004,$004007FE,$00001C00,$00001800,$30000000 dc.l $06000003,$03000000,$00060000,$00003000,$60001800 dc.l $00000000,$31800000,$00000000,$00330330,$78078078 dc.l $07807807,$80780780,$78078078,$07807807,$80780780 dc.l $78078078,$07807807,$80780780,$78078078,$07807807 dc.l $807804F2,$1FE3F066,$63FC1807,$FE3FC7FC,$7FC03C01 dc.l $83FC7FE1,$E07FE7FC,$3F806000,$63FC7FE3,$F03FC3FC dc.l $31833030,$03F87FE7,$800001E0,$40040040,$04004004 dc.l $00400400,$40040040,$04004004,$00400400,$40040040 dc.l $04004004,$00400400,$40" 040040,$04004004,$004004E6 dc.l $30603033,$60001F80,$30000006,$01800C18,$C3000063 dc.l $30060006,$0040C030,$C0C01860,$18006000,$31833030 dc.l $060C6060,$0C000000,$7C07C07C,$07C07C07,$C07C07C0 dc.l $7C07C07C,$07C07C07,$C07C07C0,$40040040,$04004004 dc.l $00400400,$40040040,$04004004,$004004CE,$6067FE00 dc.l $67FE18E0,$30000306,$06000C18,$C3000066,$1806000C dc.l $1F01800D,$87FE18C0,$180067FE,$01833030,$C60C6060 dc.l $0C000000,$01C00801,$C03C0240,$3C01C03E,$01C01C01 dc.l $C03C01E0,$3C03E03E,$01C00801,$C03C0240,$3C01C03E dc.l $01C01C01,$C03C01E0,$3C03E41E,$06C03000,$60301800 dc.l $300000CC,$1F801818,$630000C0,$0C36C018,$00830003 dc.l $00C01800,$301FE006,$01833630,$C60C0060,$0C000000 dc.l $02201802,$20020240,$20020002,$02202202,$20220200 dc.l $22020020,$02201802,$20020240,$20020002,$02202202 dc.l $20220200,$220204CE,$01803000,$C0301800,$30000030 dc.l $66603030,$63000180,$0C36C3B0,$00060C06,$C0C01800 dc.l $3000600C,$01833631,$860C00C0,$18000000,$02A00800 dc.l $C00C03E0,$3C03C004,$01C01E03,$E03C0200,$2203C03C dc.l $02A00800,$C00C03E0,$3C03C004,$01C01E03,$E03C0200 dc.l $2203C4E6,$06606001,$80601800,$600000CC,$0600C030 dc.l $630C0600,$0636C060,$7FC60618,$60C61800,$60006018 dc.l $03033633,$060C0186,$30000000,$02200801,$00220040 dc.l $02022008,$02200202,$20220200,$22020020,$02200801 dc.l $00220040,$02022008,$02200202,$20220200,$220204F2 dc.l $3803800E,$03801803,$807FE306,$06070060,$61F83800 dc.l $06666018,$0023FC60,$007C1807,$FE7FE0E0,$1C063C3C dc.l $07FC0E07,$C0000000,$01C01C03,$E01C0040,$3C01C010 dc.l $01C01C02,$203C01E0,$3C03E020,$01C01C03,$E01C0040 dc.l $3C01C010,$01C01C02,$203C01E0,$3C03E7FE,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$000003FC,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 dc.l $00000000,$00000000,$00000000,$00000000,$00000000 * * * waitforready: wait till window mover done * * waitforready equ * move d0,-(sp) save a register movea.l controladdr(a5),a0 get control address base wait1 move.b wmove(a0),d0 and.b planemask(a5),d0 mask out unused planes beq.s waitdone if clear then we're done move.l #50,-(sp) else wait 50 us jsr delay_timer bra wait1 and look again waitdone move (sp)+,d0 restore d0 rts * * * savestate: preserve window mover state * * Uses a0,a2 * a0 set to controladdr(a5) * savestate equ * jsr waitforready movea.l (sp)+,a2 save return addr move ww(a0),-(sp) move wh(a0),-(sp) move sox(a0),-(sp) move soy(a0),-(sp) move dox(a0),-(sp) move doy(a0),-(sp) move wrr(a0),-(sp) jmp (a2) * * restorestate: restores window mover control regs * * Uses: a0,a2 * restorestate equ * jsr waitforready movea.l (sp)+,a2 save ret addr move (sp)+,wrr(a0) move (sp)+,doy(a0) move (sp)+,dox(a0) move (sp)+,soy(a0) move (sp)+" ,sox(a0) move (sp)+,wh(a0) move (sp)+,ww(a0) jmp (a2) * * * procedure cclearall: clears all of visible area * cclearall jsr savestate bsr cursoroff {SFB 9/29/86} moveq #0,d0 move d0,sox(a0) setup x,y move d0,soy(a0) move d0,dox(a0) move d0,doy(a0) move #width,ww(a0) set width movep dispht(a0),d1 and height move d1,wh(a0) move d0,wrr(a0) set repl rule move.b planemask(a5),wmove(a0) do the move jsr restorestate bsr cursoron {SFB 9/29/86} rts * * * procedure cchar(ord(char),x,y:shortint); * cchar movea.l (sp)+,a4 move (sp)+,d0 d0 = dest y char offset mulu fontht(a5),d0 d0 = pixel row offset move (sp)+,d5 d5 = x char offset mulu fontwidth(a5),d5 d5 = pixel column offset tst.b lowres(a5) check if low res display beq.s cchar2 if not then no offset add #32,d5 else need offset to center add #10,d0 also adjust y offset cchar2 moveq #0,d1 d1 will have src y movea.l controladdr(a5),a0 movep.w dispht(a0),d1 move (sp)+,d2 d2 = character moveq #0,d3 moveq #0,d4 tst.b lowres(a5)  beq.s cchres moveq #6,d7 low res shift count moveq #$3F,d6 low res mask bra.s cchfindxy go find the char in font space cchres moveq #7,d7 hi res shift count moveq #$7F,d6 hi res mask cchfindxy equ * move d2,d3 copy the character move d2,d4 to d3 and d4 lsr d7,d3 d3 = src y row number and d6,d4 d4 = src x offset in chars mulu fontht(a5),d3 d3 = y pixel location mulu fontwidth(a5),d4 d4 = x pixel location add d1,d3 add in y offset jsr savestate preserve window mover state move d3,soy(a0) move d4,sox(a0) set up src location move d0,doy(a0) and dest location move d5,dox(a0) move fontht(a5),wh(a0) set up window size move fontwidth(a5),ww(a0) move #0,wrr(a0) first clear the destination moveq #0,d3 move.b highlight(a5),d3 get highlight byte lsr #4,d3 shift to get color mask and #7,d3 addq #1,d3 get actual pen number not d3 set all unused planes to 0 move.b d3,wmove(a0) trigger the move jsr waitforready move #3,wrr(a0) setup rule to replace btst #0,highlight(a5) inverse video? beq.s ccharb if not, skip next instruction move #12,wrr(a0) else set repl rule to invert ccharb not d3 get actual pen number move.b d3,wmove(a0)  make this the frames to move btst #2,highlight(a5) underline? beq.s cchar1 no, skip next part jsr waitforready add fontht(a5),d0 subq #1,d0 get y pos for underline mulu #width,d0 convert to address add.l d5,d0 add in x offset movea.l screen(a5),a1 get frame buffer start adda.l d0,a1 point a1 to underline row * bsr cursoroff move fontwidth(a5),d1 setup count for underline subq #1,d1 move prr(a0),-(sp) save the prr move #$600,prr(a0) set up xor repl rule cchrul move.b d3,(a1)+ place a pixel dbra d1,cchrul loop till done move (sp)+,prr(a0) restore prr * bsr cursoron cchar1 bsr restorestate restore window state jmp (a4) * * * cscrollup; * * scrolls the screen up one line of alpha text * cscrollup jsr savestate save window mover state bsr cursoroff  turn off 98549A soft cursor SFB 9/24/86 movea.l controladdr(a5),a0 move #0,dox(a0) set up dest. loc move #0,doy(a0) move #0,sox(a0) set up src loc move fontht(a5),soy(a0) start one line width down move maxy(a5),d# 2 get lines in screen to move mulu fontht(a5),d2 get # pixel lines to move move d2,wh(a0) set up window size move #width,ww(a0) move #3,wrr(a0) repl rule to replace tst.b lowres(a5) check for low res display  beq.s cscroll2 if not then skip addi #10,soy(a0) else adjust y offset addi #10,doy(a0) cscroll2 move.b planemask(a5),wmove(a0) move all planes * * Clear bottom line on screen * jsr waitforready move maxy(a5),d2 mulu fontht(a5),d2 d2 = y offset of bottom line move d2,doy(a0) move fontht(a5),wh(a0) clear one char line ht move #0,wrr(a0) repl rule to clear tst.b lowres(a5) check for low res beq.s cscroll3 if not then skip addi #10,doy(a0) else adjust y offset cscroll3 move.b planemask(a5),wmove(a0) clear all planes jsr restorestate bra cursoron turn on 98549A soft cursor SFB 9/24/86 * rts * * cscrolldown * * scrolls the screen down one text line * cscrolldown jsr savestate bsr cursoroff turn off 98549A soft cursor SFB 9/24/86 moveq #0,d0 movea.l controladdr(a5),a0 move d0,sox(a0) set up src origin move d0,soy(a0) move d0,dox(a0) setup dest. origin move fontht(a5),doy(a0) move #width,ww(a0) setup window size move maxy(a5),d2 mulu fontht(a5),d2 move d2,wh(a0) move #3,wrr(a0) setup repl rule tst.b lowres(a5) is this low-res display? beq.s cscroll4 if not then skip addi #10,doy(a0) else adjust y offsets addi #10,soy(a0) cscroll4 move.b planemask(a5),wmove(a0) move all planes jsr waitforready  move soy(a0),doy(a0) move fontht(a5),wh(a0) move d0,wrr(a0) move.b planemask(a5),wmove(a0) jsr restorestate bra cursoron turn on 98549A soft cursor SFB 9/24/86 * rts * * cupdatecursor(x,y:shortint); * cupdatecursor equ * movea.l (sp)+,a4 a4 = return addr move (sp)+,d5 d5 = y in chars move (sp)+,d4 d4 = x in chars movea.l controladdr(a5),a0 mulu fontht(a5),d5 d5 = y in pixels add fontht(a5),d5 subq #1,d5 d5 is last line of char mulu fontwidth(a5),d4 d4 = x in pixels tst.b lowres(a5) check if low res beq.s cupdate2 if not then skip add #32,d4 else offset x add #10,d5 and y cupdate2 move d5,cay(a0) do the cursor move move d4,cax(a0) bsr cursoroff turn off 98549A soft cursor SFB 9/24/86 subq #1,d5 d5 is second last line of char  mulu #width,d5 compute memory address add d4,d5 add.l screen(a5),d5 move.l d5,cursoraddr(a5) bsr cursoron turn on 98549A soft cursor SFB 9/24/86 jmp (a4) * * cclear(xpos,ypos,nchars:shortint); * -- clears nchars starting at xpos, ypos * -- nchars + xpos must not exceed 128 * no range checking is done * cclear equ * bsr cursoroff turn off 98549A soft cursor SFB 9/24/86 movea.l (sp)+,a4 a4 = return address move (sp)+,d1 d4 = number of characters to clear move (sp)+,d3 d3 = y to begin at move (sp)+,d5 d5 = x move.l a4,-(sp) stack return address jsr savestate save window mover state mulu fontht(a5),d3 d3 = y in pixels move d3,doy(a0) mulu fontwidth(a5),d5 d5 = x in pixels tst.b lowres(a5) check for low res beq.s cclear2 if not then skip add #32,d5 else offset x addi #10,doy(a0) and y cclear2 move d5,dox(a0) setup dest. x reg move fontht(a5),wh(a0) setup window size mulu fontwidth(a5),d1 move d1,ww(a0) moveq #0,d0 move d0,wrr(a0) # repl rule to clear move d0,sox(a0) move d0,soy(a0) move.b planemask(a5),wmove(a0) use all planes jsr restorestate * bra cursoron turn on 98549A soft cursor SFB 9/24/86 * rts cursoron equ * enable cursor tst.b softcursor(a5) bne.s softon movea.l controladdr(a5),a0 move.b planemask(a5),curon(a0) rts softon equ * movea.l cursoraddr(a5),a0 movem.l (a0),d0-d1 movem.l d0-d1,holdcursor(a5) movem.l width(a0),d0-d1 movem.l d0-d1,holdcursor+8(a5) moveq #-1,d0 move.l d0,d1 movem.l d0-d1,(a0) movem.l d0-d1,width(a0) rts cursoroff equ *  disable cursor tst.b softcursor(a5) bne.s softoff movea.l controladdr(a5),a0 move.b #0,curon(a0) rts softoff equ * movea.l cursoraddr(a5),a0 movem.l holdcursor(a5),d0-d1 movem.l d0-d1,(a0) movem.l holdcursor+8(a5),d0-d1 movem.l d0-d1,width(a0) rts cshiftleft equ * jsr savestate save window mover state moveq #0,d1 d1 = dest x location move fontwidth(a5),d2 d2 = src x location cshift1 moveq #1,d0 get pointer to last line of screen add maxy(a5),d0 mulu fontht(a5),d0 d0 = y origin of typeahead tst.b lowres(a5) check if lowres beq.s cshlhres  if not then skip add #32,d1 else offset x add #32,d2 locations add #10,d0 and y locations cshlhres move d1,dox(a0) move d2,sox(a0) move d0,doy(a0) setup destination and src loc move d0,soy(a0) moveq #-8,d1 get # chars in length to move add maxx(a5),d1 d1 now has # chars to move mulu fontwidth(a5),d1 d1 now has width in pixels move d1,ww(a0) move fontht(a5),wh(a0) height is one char row move #3,wrr(a0) setup replacement rule move.b planemask(a5),wmove(a0) do all planes bsr restorestate fix replacement rule reg and return rts cshiftright equ * jsr savestate moveq #0,d2 src x location move fontwidth(a5),d1 dest x location bra cshift1 now do same stuff as shift left * procedure cexchange(savearea: windowp; ymin, ymax, xmin, width: shortint); cexchange movea.l (sp)+,a4 a4 = return addr move (sp)+,d0 width of window in pixels in d0 lsr #2,d0 d0=window width in long integers subq #1,d0 setup for later looping move (sp)+,d4 d4 = x offset in chars mulu fontwidth(a5),d4 d4 = x offset in pixels move (sp)+,d5 d5 = ymax move (sp)+,d1 d1 = ymin movea.l (sp)+,a1 a1 = ptr to save area sub d1,d5 addq #1,d5 d5 has # of char rows to move mulu fontht(a5),d5 now has # of pixel rows to move subq #1,d5 setup for outer loop mulu fontht(a5),d1 d1 = y offset in pixels mulu #width,d1 d1 = y address offset bsr savestate * bsr cursoroff move prr(a0),-(sp) move #$300,prr(a0) setup pixel repl rule movea.l screen(a5),a0 a0 points to frame buffer start adda.l d1,a0 now points to correct row adda d4,a0 do x offset into row tst.b lowres(a5) is this low res? beq.s cexchg2 if not then skip adda #32,a0 else adjust x offset adda #10240,a0 and y offset cexchg2 movea.l a0,a2 make a working copy move d0,d7 initialize inner loop cexchg3 move.l (a2),d6 screen to temp move.l (a1),(a2)+ save area to screen move.l d6,(a1)+ temp to save area dbra d7,c$ exchg3 inner loop (pixel row move) adda.l #width,a0 bump row pointer dbra d5,cexchg2 outer loop (row count) movea.l controladdr(a5),a0 move (sp)+,prr(a0) * bsr cursoron bsr restorestate restore control regs jmp (a4) done * procedure cscrollwindow( ymin, ymax, xmin, width: shortint); cscrollwindow equ * bsr cursoroff turn off 98549A soft cursor SFB 9/24/86 moveq #0,d6 set upscroll flag in d6 cscrollwindc movea.l (sp)+,a4 a4 = return addr move (sp)+,d1 d1 = width in chars mulu fontwidth(a5),d1 d1 = width in pixels move (sp)+,d0 d0 = x offset of window in chars mulu fontwidth(a5),d0 d0 = x offset in pixels (bytes) move (sp)+,d2 d2 = ymax move (sp)+,d3 d3 = ymin sub d3,d2 d2 has # of char rows to move mulu fontht(a5),d2 now d2 has height to move mulu fontht(a5),d3 d3 = y offset in bytes of origin jsr savestate tst d6 check up/down flag bne.s cscrollwindb and branch if dn move d3,doy(a0) set ymin to dest y origin add fontht(a5),d3 move d3,soy(a0) one row down is src y origin cscrollwin1 tst.b lowres(a5) is this low res? beq.s cscrollwin2 if not then skip add #32,d0 else adjust x offset addi #10,soy(a0) and y offsets addi #10,doy(a0) cscrollwin2 move d1,ww(a0) setup width reg move d2,wh(a0) setup height reg move d0,sox(a0) setup x coordinates move d0,dox(a0) move #3,wrr(a0) move.b planemask(a5),wmove(a0) all planes bsr restorestate bsr cursoron turn on 98549A soft cursor SFB 9/24/86 jmp (a4) cscrollwindb move d3,soy(a0) ymin = src y origin add fontht(a5),d3 move d3,doy(a0) one row down is dest y bra cscrollwin1 cscrollwinddn equ * bsr cursoroff turn off 98549A soft cursor SFB 9/24/86 moveq #1,d6 set down scroll flag bra cscrollwindc go to common code cdbscrolll equ * bsr cursoroff turn off 98549A soft cursor SFB 9/24/86 moveq #0,d6 set left scroll flag cdbscrollb movea.l (sp)+,a4 pickup return addr move (sp)+,d1 width in chars  subq #1,d1 actual width to move is 1 less mulu fontwidth(a5),d1 width in pixels in d1 move (sp)+,d0 x offset in chars mulu fontwidth(a5),d0 d0 = x offset in pixels move (sp)+,d5 d5 = ymax move (sp)+,d3 d3 = ymin sub d3,d5 addq #1,d5 d5 = # char rows to move mulu fontht(a5),d5 d5 = # pixel rows to move mulu fontht(a5),d3 d3 = y window start offset tst.b lowres(a5)  is this low res? beq.s cdbscrolld if not then skip add #32,d0 else offset x add #10,d3 and y origins cdbscrolld jsr savestate save window mover state tst d6 check left/right flag bne.s cdbscroll2 if right, skip move d0,dox(a0) if left xmin= dest x add fontwidth(a5),d0 move d0,sox(a0) and src is 1 char to rt cdbscrollc move d1,ww(a0) setup width reg move d5,wh(a0) setup height reg move d3,soy(a0) y is same for src and dest move d3,doy(a0) move #3,wrr(a0) setup repl rule move planemask(a5),wmove(a0) all planes bsr restorestate bsr cursoron turn on 98549A soft cursor SFB 9/24/86 move.l a4,-(sp) rts finished! cdbscroll2 move d0,sox(a0) xmin is src x for rt move add fontwidth(a5),d0 move d0,dox(a0) dest is$  1 char to rt bra cdbscrollc goto common code cdbscrollr equ * bsr cursoroff turn off 98549A soft cursor SFB 9/24/86 moveq #1,d6 set right shift flag bra cdbscrollb go to common code end CONST IDREG = hex('0000'); {xxxxxxxx00111001} INTREG = hex('0002'); {unused} WMSTAT = hex('4044'); {do not use. Slows RUG, as it's on GLAD bus} STARTMOVE = hex('409C'); {use TWMxxxx instead} RUGCMD = hex('4206'); {b07..b06=00:solid vect/circle 01:linetype vect/circle 10:blit mode 11:fill mode) b05=circle (NOT vect) b04=framebufwrite ON } RUGSTAT = hex('4206'); {b09=not ready for data b08=busy b03=unclipped pixels drawn } WMWIDTH = hex('4208'); {fill width/fill anchorx} WMHEIGHT = hex('420A'); {fill height/fill anchory/circle radius} LINEPATT = hex('420C'); {16 bit pattern in b15..b00} LINETYPE = hex('420E'); {b11..b08=repeat length b07..b04=current pattern bit b03..b00=current repeat count } WMSOURCEX = hex('4210'); {sourcex/circle centerx/line startx/fill pt 1x} WMSOURCEY = hex('4212'); {sourcey/circle centery/line starty/fill pt 1y} WMDESTX = hex('4214'); {destx/line endx/fill pt 2x} WMDESTY = hex('4216'); {desty/line endy/fill pt 2y} WMCLIPLEFT = hex('4218'); {RUG clip leftx} WMCLIPRIGHT = hex('421A'); {RUG clip rightx} WMCLIPTOP = hex('421C'); {RUG clip topy} WMCLIPBOTTOM = hex('421E'); {RUG clip bottomy} TWMWIDTH = hex('4308'); {triggering WMWIDTH} TWMHEIGHT = hex('430A'); {triggering WMHEIGHT} TWMSOURCEX = hex('4310'); {triggering WMSOURCEX} TWMSOURCEY = hex('4312');  {triggering WMSOURCEy} TWMDESTX = hex('4314'); {triggering WMDESTX} TWMDESTY = hex('4316'); {triggering WMDESTY} PATTERNS = hex('4400'); {nplanes X 16 16-bit regs, bit per pixel} {$4400=plane0row0, $4402=plane0row1, etc} FBEN1 = hex('4500'); {b15..b08, 1 enables} PRR = hex('4502'); {b11..b08} TCREN1 = hex('4504'); {b15..b08, 1 enables} WRR = hex('4506'); {b03..b00} TCWEN1 = hex('4508'); {b15..b08, 1 enables} TRR  = hex('450C'); {b15..b08 are Three Operand Repl Rule} COLOR1 = hex('450E'); {b15..b08, only used if VB=256} VB = hex('4510'); {only b08. 0=bitblt, 1=vector(circle, etc)} TRRCTL = hex('4512'); {only b08. 0=two operand, 1=three operand} ACNTRL = hex('4514'); {only b08. 0=byte per pixel, 1=bit per pixel} PLANEMODE = hex('4516'); {b12..b08 00000=within planes 10000+p=plane p is source phantom plane: HRM=p1,LCC=p5,HRC=p10 } FBEN2  = hex('4700'); {b15..b08, 1 enables} PRR2 = hex('4702'); {b11..b08} TCREN2 = hex('4704'); {not used} WRR2 = hex('4706'); {b03..b00} TCWEN2 = hex('4708'); {not used} TRR2 = hex('470C'); {b15..b08 are 8-bit Three Operand Repl Rule} COLOR2 = hex('470E'); {b15..b08, only used if VB=256} CATSTAT = hex('4800'); {LSBs b00=move or pixel generation currently active b01=RUG ready for data (registers) b02=RUG generated unclipped pixels b03=no daughter board b04=in vertical blank b05=in horizontal sync b06=1 for phantom reads, 0 for framebuf (LCC) b07=1 for phantom writes, 0 for framebuf (LCC) } CMSTAT = hex('6002'); {LSBs b00=vertical sync pulse active b01=currently blanking b02=color map busy b03=horizontal sync pulse active b04=in vertical blanking } VBSTAT = hex('6040'); {LSBs: $FF=currently in vertical blanking} {don't use. Use CATSTAT b04 % instead} BLANKALL = hex('605C'); {set b01 to blank completely} OVERLAYCTL = hex('60A2'); {set to 0 to disable overlay planes} CMINDEX = hex('60B0'); {LSBs 8 bits} CMRED = hex('60B2'); {LSBs 8 bits} CMGREEN = hex('60B4'); {LSBs 8 bits} CMBLUE = hex('60B6'); {LSBs 8 bits} PLANEMASK = hex('60BA'); {LSBs up to 8 planes, 1 enables} CMAPWRITE = hex('60F0'); {address triggered} CMAPREAD = hex('60F8'); {address triggered}  page * * GATORBOX bit-mapped alpha driver * * Pascal 3.1 version by J. Schmidt * def cscrollup,cscrolldown,cupdatecursor,cchar,cclear def cbuildtable,cshiftleft,cshiftright def cexchange,cscrollwindow,cursoron,cursoroff def  cscrollwinddn,cdbscrolll,cdbscrollr rorg.l 0 refa crtgb,sysdevs nosyms clearl equ $CC000 blank pixel row offset maxx equ crtgb-10 maxy equ crtgb-12 cursoraddr equ crtgb-4 highlight equ crtgb-18 cursorhold equ  crtgb-34 content of current cursor location controladdr equ sysdevs-86 screen equ sysdevs-90 writecopy equ sysdevs-96 replreg equ $5006 widthreg equ $5000 htreg equ $5002 writereg equ $6008 write protect reg status  equ $0002 secondary interrup reg has blockmover status blinkrega equ $6001 blink/enable reg A blinkregb equ $6005 blink/enable reg B cmapbusy equ $6803 color map busy cmapptr equ $68B8 color map ptr reg (word) cmapred equ $69B2 color map red (word) cmapgrn equ $69B4 color map green (word) cmapblu equ $69B6 color map blue (word) cmapwrt equ $68F0 color map write trigger (word) width equ 1024 initoffset equ $23 offset to initialization offset fontoffset equ $3B offset to font info offset frameoffset equ $5D offset to frame buffer reg. offset cmapidoff equ $57 offset to color map id offset cmapinitoff equ $3F offset to cmap 0 init region offset framecnt equ $5B offset of number of frames * * cbuildtablei * cbuildtable movea.l controladdr(a5),a0 get pointer to ROM start movep initoffset(a0),d1 form pointer to init block movea.l a0,a1 make copy of ROM start addr adda d1,a1 a1 points to init info now jsr ginitblock call the initializatiion routine moveq #0,d1  movep cmapidoff(a0),d0 get ptr to color map id reg tst d0 if ptr=0, then use init region 0 beq.s cinitclr move.b 0(a0,d0),d1 get cmap id into d1 cinitclr and #3,d1  look at least sig bits lsl #2,d1 move.b cmapinitoff(a0,d1.w),d2 form cmap init block addr lsl #8,d2 move.b cmapinitoff+2(a0,d1.w),d2 movea.l a0,a1 adda d2,a1 a1 points to cmap init block  jsr ginitblock clr.l screen(a5) clear space for frame buffer addr movep.w frameoffset(a0),d0 get offset of frame buffer loc. move.b 0(a0,d0),screen+1(a5) form frame buffer addr clr writereg(a0)  enable all planes for write clr writecopy(a5) moveq #0,d0 setup blink enable regs moveq #0,d1 move.b framecnt(a0),d0 get number of frames beq.s creadfb if zero we can use fb to find out move #$FFFF,d1 d1 will hold bit mask moveq #16,d2 sub d0,d2 d2 = shift count for d1 lsr d2,d1 d1 = blink/enable mask bra.s cinitblink creadfb movea.l screen(a5),a1 use fb to get mask move.b #-1,(a1) move.b (a1),d1 cinitblink move.b d1,blinkrega(a0) setup blink/enable regs move.b d1,blinkregb(a0) movea.l screen(a5),a1 move.w #128+64,replreg(a0) set % repl rule to clear,down/rt move.w #0,widthreg(a0) move.w #1,htreg(a0) clear all but last 4 pixel lines move.b #00,(a1) clear the whole frame buffer zcheck btst #4,status(a0) bne zcheck move #3,replreg(a0) movep fontoffset(a0),d1 get font info offset lea 2(a0,d1.w),a1 point to font id code moveq #2,d7 count number of font found with d7 fontidchk movep 2(a1),d2 get offset of font info lea 10(a0,d2.w),a3 a3 points to first char of font cmpi.b #1,(a1) is font = roman8 ? bne.s notroman bsr unpkroman if so go unpack it notroman cmpi.b #2,(a1) is font = kana8 upper half? bne.s nextfont bsr.s unpkkana if so go unpack it nextfont addq #6,a1 point to next font id tst d7 have we found both fonts? bne fontidchk if not look at this one lea cmaptable,a1 initialize the color map moveq #0,d1 clear some registers move.l d1,d2 move.l d1,d3 move.l d1,d4 cmaploop1 move.b (a1)+,d2 get rgb values in d2-d4 move.b (a1)+,d3 move.b (a1)+,d4 bsr cmapenter stuff the color map entry addq #1,d1 bump cmap pointer value cmp #16,d1 have we done 16 yet? bne cmaploop1  if not then continue moveq #-1,d2 set entries 16-255 to white move.l d2,d3 move.l d2,d4 cmaploop2 bsr cmapenter addq #1,d1 cmp #256,d1 done with cmap init? bne cmaploop2 cmaploop3 btst #2,cmapbusy(a0) wait for color map not busy bne cmaploop3 moveq #0,d1 CHECK FOR NEREID COLOR MAP 6/85 movep cmapidoff(a0),d0 get ptr to color map id reg tst d0  if ptr=0, then use init region 0 beq.s cinitclr2 move.b 0(a0,d0),d1 get cmap id into d1 cinitclr2 and #3,d1 look at least sig bits bne.s notnereid if result<>0 then skip  moveq #0,d0 else set rgb regs to 0 move d0,cmapred(a0) move 0,d7 delay for nereid SFB move d0,cmapgrn(a0) move 0,d7 delay for nereid SFB move d0,cmapblu(a0) notnereid move.l screen(a5),cursoraddr(a5) initialize cursor location bsr cursoron turn it on rts * * misc utilities for initialization * * unpkkana moveq #127,d3 kana8 upper half has 128 chars movea.l #$C8000,a2 store at font storage + 256*128 subq #1,d7 count a found font bra unpackit unpkroman moveq #127,d3 #chars to unpack-1 subq #1,d7 count a found font  movea.l #$C0000,a2 start at beginning of font storage bsr.s unpackit moveq #127,d3 now unpack second half of font movea.l #$C4000,a2 unpackit adda.l screen(a5),a2 movea.l a2,a4 a4 points to font char start addr subq #8,a4 unpackchar moveq #15,d5 unpack 16 rows/char addq #8,a4 point to char storage start movea.l a4,a2 make the working copy unpackrow moveq #7,d4  we need to look at 8 bits/byte unpackrow2 btst d4,(a3) is bit set in font? sne (a2)+ set frame buffer byte accordingly dbra d4,unpackrow2 loop till all 8 bits done addq #2,a3  look at next font byte adda #width-8,a2 adjust storage pointer dbra d5,unpackrow and loop till rows in char done dbra d3,unpackchar loop till all chars done rts &  go look at next font cmapenter nop btst #2,cmapbusy(a0) check for color map busy bne cmapenter loop till bit is clear move 0,d7 delay for nereid SFB move d1,cmapptr(a0) set pointer register move 0,d7 delay for nereid SFB move.w d2,cmapred(a0) stuff the rgb regs move 0,d7 delay for nereid SFB move.w d3,cmapgrn(a0) move 0,d7 delay for nereid SFB move.w d4,cmapblu(a0) move 0,d7 delay for nereid SFB move d1,cmapwrt(a0) hit the write trigger * nop removed SFB rts done with cmap entry write ginitblock moveq #0,d1 clear some regs moveq #0,d0 move.b 2(a1),d0 get word count to initialize movep 4(a1),d1 form destination offset add.l a0,d1 d1 points to dest addr lea 8(a1),a2 a2 points to first data byte movea.l d1,a3 a3 points to destination btst #0,(a1) is this a bit test block? bne.s ginitbtst if so go handle it ginitloop movep 0(a2),d1 form a data word in d1 move.w d1,(a3)+ move data to the destination addr btst #6,(a1) increment data pointer bne.s ginit1 based on control byte addq #4,a2 ginit1 dbra d0,ginitloop loop till word count exhausted btst #7,(a1) was this last block? bne.s ginitdone yes -- go return btst #6,(a1)  adjust data pointer beq.s ginit2 to point to next init block ginit3 addq #4,a2 ginit2 movea.l a2,a1 a1 points to new init block bra ginitblock do the initialize ginitdone rts ginitbtst moveq #0,d2 handle bit test blocks here move.b 2(a2),d2 d2 = bit # to test ginittst2 move (a3),d3 d3 = data word to test btst #0,(a2) check for sense of test bne.s ginittst3 comp if waiting for 0 not d3 ginittst3 btst d2,d3 check the bit beq ginittst2 if not 1 then loop btst #7,(a1) was this last block?  bne ginitdone if so then return bra ginit3 else do next block * * cmaptable equ * initial color map contents (r,g,b) dc.b 0,0,0 0 dc.b 255,255,255  1 dc.b 255,0,0 2 dc.b 255,255,0 3 dc.b 0,255,0 4 dc.b 0,255,255 5 dc.b 0,0,255 6 dc.b 255,0,255 7 dc.b  0,0,0 8 dc.b 204,187,51 9 dc.b 51,170,119 10 dc.b 136,102,170 11 dc.b 204,68,102 12 dc.b 255,102,51 13 dc.b 255,119,0  14 dc.b 221,136,68 15 * * * savecrtstate: preserve tile mover state * Entry: d0= replacement rule * d1= window width in tiles * d2= window height in tiles *  d3= write protect * Uses: a2,a3 * savecrtstate equ * movea.l controladdr(a5),a3 savestate1 btst #4,status(a3) wait for not busy bne savestate1 movea.l (sp)+,a2 save ret addr move replreg(a3),-(sp) move widthreg(a3),-(sp) move htreg(a3),-(sp) move writecopy(a5),-(sp) move d0,replreg(a3) move d1,widthreg(a3) move d2,htreg(a3) move d3,writecopy(a5) move d3,writereg(a3) jmp (a2) & * * restcrtstate: restores tile mover control regs * * Uses: a3 * restcrtstate equ * movea.l controladdr(a5),a3 restcrt1 btst #4,status(a3) wait for not busy bne restcrt1 move 4(sp),writecopy(a5) restore copy variables move writecopy(a5),writereg(a3) restore the registers move 6(sp),htreg(a3) move 8(sp),widthreg(a3) move 10(sp),replreg(a3) move.l (sp),8(sp) move up return addr addq #8,sp rts  and return * procedure cchar(ord(char),x,y:shortint); cchar movea.l (sp)+,a4 move (sp)+,d0 d0 = y mulu #16384,d0 movea.l d0,a0 adda.l screen(a5),a0 move (sp)+,d5 d5 = x (this will be used later also) lsl #3,d5 adda d5,a0 a0 = address of byte to begin at movea.l screen(a5),a1 setup font addr in a1 adda.l #$C0000,a1 fonts are just past visible space move (sp)+,d0 d0 = character cmpi #127,d0 check if in roman8 set ble.s notroman8 adda #$4000,a1 notroman8 cmpi #255,d0 see if char is in kana8 set ble notkana adda #$4000,a1 if so then adjust font base addr notkana lsl #3,d0 get offset from font base addr lea 0(a1,d0.w),a1 a1 = address of char in font storage move #64+128,d0 set repl rule to clear,down/rt moveq #-2,d1 we will move 2 tiles wide moveq #-4,d2 and 4 tiles high moveq #0,d3 move.b highlight(a5),d3 get highlight byte lsr #4,d3 shift to get color mask and #7,d3 addq #1,d3 protect planes we will move bsr savecrtstate move.b #0,(a0) cclrb btst #4,status(a3) bne cclrb wait for mover done move #3+64+128,replreg(a3) set repl rule to replace,down/rt btst #0,highlight(a5) inverse video? beq.s ccharb if not, skip next instruction move #12+64+128,replreg(a3) else set repl rule to invert ccharb not d3  complement to get disabled planes move d3,writecopy(a5) make this the write prot reg move d3,writereg(a3) move.b (a1),(a0) write the character btst #2,highlight(a5) underline? beq.s cchar1 if not then skip next part ccharc btst #4,status(a3) wait for move done bne ccharc adda #15360,a0 point to last line of cell not d3 get actual pen number in d3 move #6,replreg(a3) set repl reg to xor moveq #7,d1 we want to underline 8 bytes cchard move.b d3,(a0)+ do the underline dbra d1,cchard cchar1 bsr restcrtstate jmp (a4) * * * cscrollup; * * scrolls the screen up one line of alpha text (16 graphics lines) * cscrollup bsr cursoroff movea.l screen(a5),a0 movea.l a0,a1 adda #16384,a0 move.w #131+64,d0 set block mover for dn/rt moving moveq #0,d1 width=256 tiles move maxy(a5),d2 get lines in screen to move lsl #2,d2 convert to #tiles neg d2 moveq #0,d3 use all planes bsr savecrtstate move.b (a0),(a1) sucheck btst #4,status(a3) a3 setup by savecrtstate bne sucheck * * Clear bottom line on screen * move maxy(a5),d2 mulu #16384,d2 adda.l d2,a1 a1 now points to last line move #128+64+3,replreg(a3) move #0,widthreg(a3) move #-4,htreg(a3) movea.l #clearl,a0 adda.l screen(a5),a0 move.b (a0),(a1) bcheck  btst #4,status(a3) bne bcheck bsr restcrtstate bra cursoron * * cscrolldown * * scrolls the screen down one text line * cscrolldown bsr cursoroff movea.l screen(a5),a0 move maxy(a5),d0 mulu #16384,d0 subq.l #1,d0 bottom/rt corner of src adda.l d0,a0 movea.l a0,a1 pointed to by a1 adda #16384,a0 point to 1 char row past a1 move.w #131,d0 set repl rule, up/left move moveq ' #0,d1 assume 256 tile width move maxy(a5),d2 use maxy to get height lsl #2,d2 convert to #tiles neg d2 moveq #0,d3 use all planes bsr savecrtstate move.b (a1),(a0) sdcheck btst #4,status(a3) a3 setup by savecrtstate bne sdcheck movea.l screen(a5),a0 movea.l #clearl,a1 adda.l a0,a1 move #128+64+3,replreg(a3) setup blank line move move #0,widthreg(a3) setup widthreg  move #-4,htreg(a3) setup heightreg move.b (a1),(a0) topcheck btst #4,status(a3) a3 setup by savecrtstate bne topcheck bsr restcrtstate bra cursoron * * cupdatecursor(x,y:shortint); * cupdatecursor movea.l cursoraddr(a5),a1 movea.l (sp)+,a4 a4 = return addr moveq #0,d5 move (sp)+,d5 d5 = y move (sp)+,d4 d4 = x moveq #3,d0 moveq #0,d3 bsr savecrtstate lea cursorhold(a5),a2 point to current contents move.l (a2)+,(a1)+ put current content back move.l (a2)+,(a1) adda #width-4,a1 adjust for next line move.l (a2)+,(a1)+ move.l (a2),(a1) current loc now restored mulu #16384,d5 add.l #14336,d5 spaces you to line 15 of character for cursor lsl #3,d4 movea.l screen(a5),a0 adda d4,a0 adda.l d5,a0 move.l a0,cursoraddr(a5) a0 has new cursor address lea cursorhold(a5),a1 save location contents moveq #-1,d0 and put 1's in cursor loc move.l (a0),(a1)+ move.l d0,(a0)+ move.l (a0),(a1)+ move.l d0,(a0) adda #width-4,a0 move.l (a0),(a1)+ move.l d0,(a0)+ move.l (a0),(a1) move.l d0,(a0) bsr restcrtstate jmp (a4) * * cclear(xpos,ypos,nchars:shortint); * -- clears nchars starting at xpos, ypos * -- nchars + xpos must not exceed 128 * no range checking is done * cclear bsr cursoroff movea.l (sp)+,a4 a4 = return address move (sp)+,d1 d4 = number of characters to clear move (sp)+,d3 d3 = y to begin at mulu #16384,d3 d3.l = offset to y move (sp)+,d5 d5 = x move.l a4,-(sp) stack return address lsl #3,d5 d5 = byte offset to begin at movea.l screen(a5),a0 movea.l #clearl,a1 adda.l a0,a1 blank line addr in a1 adda.l d3,a0 a0 = where to begin it all adda d5,a0 after adding x offset lsl #1,d1 convert #chars to #tiles neg d1 complement move.w #131+64,d0 move down/rt  moveq #-4,d2 a row is 4 tiles high moveq #0,d3 use all planes bsr savecrtstate setup control regs move.b (a1),(a0) do the clear bsr restcrtstate cursoron equ * moveq #3,d0  use replace rule moveq #0,d3 enable all planes bsr savecrtstate movea.l cursoraddr(a5),a0 a0 has cursor address lea cursorhold(a5),a1 save location contents moveq #-1,d0 and put 1's in cursor loc move.l (a0),(a1)+ move.l d0,(a0)+ move.l (a0),(a1)+ move.l d0,(a0) adda #width-4,a0 move.l (a0),(a1)+ move.l d0,(a0)+ move.l (a0),(a1) move.l d0,(a0) bsr restcrtstate rts cursoroff equ * movea.l cursoraddr(a5),a1 moveq #3,d0 moveq #0,d3 bsr savecrtstate lea cursorhold(a5),a2 point to current contents move.l (a2)+,(a1)+ put current cursor back move.l (a2)+,(a1) adda #width-4,a1 adjust for next line move.l (a2)+,(a1)+ move.l (a2),(a1) current loc now restored bsr restcrtstate rts cshiftleft moveq #64,d3 '  set flag for down/rt move moveq #1,d0 get pointer to last line of screen add maxy(a5),d0 mulu #16384,d0 movea.l screen(a5),a0 adda.l d0,a0 pointer to last char line now in a0 movea.l a0,a1 addq #8,a1 a1 will be source cshift1 moveq #-8,d1 get # chars in length to move add maxx(a5),d1 d1 now has # chars to move tst d3 check shift direction bne.s cshift2 if up/left must adjust pointers move d1,d2 lsl #3,d2 d2 had #pixels to move subq #1,d2 adda d2,a1 point to lower rt corners adda d2,a0 adda #15360,a0 adda #15360,a1 cshift2 lsl #1,d1 d1 has # tiles in keybuffer length neg d1 move #131,d0 set replacement rule add d3,d0 set direction flag in repl rule moveq #-4,d2 height is 4 tiles moveq #0,d3 use all planes bsr savecrtstate move.b (a1),(a0) and go for it bsr restcrtstate fix replacement rule reg and return rts cshiftright moveq #1,d0 get pointer to last row add maxy(a5),d0 mulu #16384,d0 movea.l screen(a5),a0 adda.l d0,a0 a0 points to last char row movea.l a0,a1 make a copy addq #8,a0 dest in a0 -- 1 char to right moveq #0,d3 set flag for up/left bra cshift1 now do same stuff as shift left * procedure cexchange(savearea: windowp; ymin, ymax, xmin, width: shortint); cexchange movea.l (sp)+,a4 a4 = return addr move (sp)+,d0 width of window in pixels in d0 lsr  #2,d0 d0=window width in long integers subq #1,d0 setup for later looping move (sp)+,d4 d4 = x offset in chars lsl #3,d4 d4 = x offset in pixels move (sp)+,d5 d5 = ymax move  (sp)+,d1 d1 = ymin movea.l (sp)+,a1 a1 = ptr to save area sub d1,d5 addq #1,d5 d5 has # of char rows to move lsl #4,d5 now has # of pixel rows to move subq #1,d5 setup for outer loop mulu #16384,d1 d1 = y offset into frame buffer move d0,d7 save d0 temporarily moveq #3,d0 setup replacement rule moveq #0,d3 enable all planes bsr savecrtstate move d7,d0 restore d0 movea.l screen(a5),a0 a0 points to frame buffer start adda.l d1,a0 now points to correct row adda d4,a0 do x offset into row cexchg2 movea.l a0,a2 make a working copy move  d0,d7 initialize inner loop cexchg3 move.l (a2),d6 screen to temp move.l (a1),(a2)+ save area to screen move.l d6,(a1)+ temp to save area dbra d7,cexchg3 inner loop (pixel row move) adda.l  #width,a0 bump row pointer dbra d5,cexchg2 outer loop (row count) bsr restcrtstate restore control regs jmp (a4) done * procedure cscrollwindow( ymin, ymax, xmin, width: shortint); cscrollwindow bsr cursoroff moveq #0,d6 set upscroll flag in d6 cscrollwindc movea.l (sp)+,a4 a4 = return addr move (sp)+,d1 d1 = width in chars lsl #1,d1 d1 = width in tiles move (sp)+,d0 d0 = x offset of window in chars lsl #3,d0 d0 = x offset in pixels (bytes) move (sp)+,d2 d2 = ymax move (sp)+,d3 d3 = ymin sub d3,d2 d2 has # of char rows to move lsl #2,d2  now d2 has # of tile rows to move movea.l screen(a5),a0 frame buffer addr in a0 mulu #16384,d3 d3 = y offset in bytes adda.l d3,a0 a0 points to first row of window adda d0,a0 now add in x offset (  tst d6 check up/down flag bne.s cscrollwindb and branch if dn movea.l a0,a1 make a copy for source pointer adda.l #16384,a1 which starts 1 char row down move #131+64,d0 set up repl rule, dn/rt moving cscrollwin1 neg d1 setup width reg neg d2 setup height reg moveq #0,d3 enable all planes bsr savecrtstate move.b (a1),(a0) move the window cscrollwin2 btst #4,status(a3) a3 setup by savecrtstate bne cscrollwin2 bsr restcrtstate move.l a4,-(sp) restack return addr bra cursoron and fixup cursor cscrollwindb moveq #0,d4 calculate first source row loc. move d2,d4 d4 = # tile rows to move moveq #12,d3 lsl.l d3,d4 mpy by 4096 to get offset in FB adda.l d4,a0 add to prev. calculated pointer suba #width,a0 point to bottom row to move move d1,d5 d5 = # tiles in row lsl #2,d5 d5 = # pixels in row adda d5,a0 suba #1,a0 a0 points to bot/rt pixel movea.l a0,a1 a1 is source pointer  adda #16384,a0 a0 points to destination move #131,d0 setup repl rule, up/left move bra cscrollwin1 cscrollwinddn bsr cursoroff moveq #1,d6 set down scroll flag bra cscrollwindc  go to common code cdbscrolll bsr cursoroff moveq #0,d6 set left scroll flag cdbscrollb movea.l (sp)+,a4 pickup return addr move (sp)+,d1 width in chars subq #1,d1 actual width to move is 1 less lsl #1,d1 width in tiles in d1 move (sp)+,d0 x offset in chars lsl #3,d0 d0 = x offset in pixels move (sp)+,d5 d5 = ymax moveq #0,d3 move (sp)+,d3 d3 = ymin sub d3,d5 addq #1,d5 d5 = # char rows to move lsl #2,d5 d5 = # tile rows to move movea.l screen(a5),a0 moveq #14,d4 lsl.l d4,d3 d3 = d3*16384 ( y window start offset) adda.l d3,a0 adda d0,a0 add in x offset movea.l a0,a1 copy to a1 tst d6 check left/right flag bne.s cdbscroll2 if right, skip adda #8,a0 else src is to right of dest move #131+64,d0 setup replacement rule, dn/rt move cdbscrollc neg d1 setup width reg move d5,d2 neg d2 setup height reg moveq #0,d3 enable all planes bsr  savecrtstate move.b (a0),(a1) move a pixel row cdbscroll5 btst #4,status(a3) check status bne cdbscroll5 bsr restcrtstate move.l a4,-(sp) bra cursoron finished! cdbscroll2 move d5,d4 d4 = #tiles of y direction mulu #4096,d4 offset to just past window adda.l d4,a0 a0 points to just past window suba #width,a0 point a0 to last pixel row move d1,d4 d4 = width in tiles lsl #2,d4 d4 = width in pixels adda d4,a0 suba #1,a0 a0 points to bot/rt pixel of window movea.l a0,a1 dest. will be a1 adda #8,a1 one char row to rt move #131,d0 setup for up/left move bra cdbscrollc goto common code cdbscrollr bsr cursoroff moveq #1,d6 set right shift flag bra cdbscrollb go to common code end  (* (c) Copyright Hewlett-Packard Company, 1984. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett( -Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $UCSD$ $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ $stackcheck off$ { $search 'INITLOAD', 'ASM','INIT','SYSDEVS'$ } $ALLOW_PACKED ON$ { JWS 4/10/85} program initcrt; module crt; import sysglobals, asm, misc, sysdevs; export function alphacrt: boolean; implement const minkana = 161; maxkana = 223; yenromlocation = 128; { location of Yen symbol in old CRT rom } type kanatocrtlookuptype = packed array [minkana..maxkana] of 128..255; romtokanatype = packed array[#128..#238] of 0..255; crtregtype = 0..15; crtcmdwrd = packed record case integer of 0: (topbyte, botbyte: byte); 1: (longword: shortint);  2: (p1,p2, textfield, softfield: boolean); end; crtscreen = array[0..maxint] of crtword; scrptr = ^crtscreen; const kanatocrtlookup = kanatocrtlookuptype [ { code 161 } 129,130,131,132,133,134,135, { code 168 } 136,137,138,139,140,141,142,143, { code 176 } 144,145,146,147,148,149,150,151, { code 184 } 152,153,154,155,156,157,158,159, { code 192 } 160,161,162,163,164,165,166,167, { code 200 } 173,174,177,178,180,188,190,191, { code 208 } 224,225,226,227,228,229,230,231, { code 216 } 232,233,234,235,236,237,238,179 ]; romtokanamap = romtokanatype [ 92, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 168, 169, 170, 171, 172, 200, 201, 175, 176, 202, 203, 223, 204, 181, 182, 183, 184, 185, 186, 187, 205, 189, 206, 207, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 208, 209, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222]; b9826info=crtirec[  width :80,height:24, crtmemaddr:5316608 { + 416}, crtcontroladdr:5341185, keybufferaddr: 5320448 { + 416}, progstateinfoaddr: 5320592 { + 416}, keybuffersize: 72,  crtcon: crtconsttype [114,80,76,7,26,10,25,25,0,14,76,13], right{FS}:chr(28), left{BS}:chr(8), down{LF}:chr(10), up{US}:chr(31), badch{?}:chr(63), chardel{BS}:chr(8),stop{DC3} :chr(19), break{DLE}:chr(16), flush{ACK}:chr(6), eof{ETX}:chr(3), altmode{ESC}:chr(27), linedel{DEL}:chr(127), backspace{BS}:chr(8), etx:chr(3),prefix:chr(0), prefixed:b14[14 of false], cursormask : 0, spare : 0]; environc=environ[miscinfo:crtfrec[ nobreak:false, stupid :false, slowterm:false,  hasxycrt:true, haslccrt:true, {?} hasclock:true, canupscroll:true, candownscroll:true],  crttype:0, crtctrl:crtcrec[ rlf:chr(31), ndfs:chr(28), eraseeol:chr(9), eraseeos:chr(11), home:chr(1), escape:chr(0), backspace:chr(8), fillcount:10, c) learscreen:chr(0), clearline:chr(0), prefixed:b9[9 of false]], crtinfo:crtirec[ width :50,height:24,  crtmemaddr:5316608, crtcontroladdr:5308417, keybufferaddr: 5319008, progstateinfoaddr: 5319092, keybuffersize: 42, crtcon: crtconsttype [64,50,49,10,25,9,25, 25,0,11,74,11], right{FS}:chr(28), left{BS}:chr(8), down{LF}:chr(10), up{US}:chr(31), badch{?}:chr(63), chardel{BS}:chr(8),stop{DC3} :chr(19), break{DLE}:chr(16), flush{ACK}:chr(6), eof{ETX}:chr(3), altmode{ESC}:chr(27), linedel{DEL}:chr(127), backspace{BS}:chr(8), etx:chr(3),prefix:chr(0), prefixed:b14[14 of false], cursormask : 0, spare : 0]]; var lptr: scrptr; screenwidth: integer; screenheight: integer; maxx,maxy,screensize:shortint; screen:scrptr; defaulthighlight: shortint; highlight: shortint; hascolor: boolean; pm6845addrreg:^char; pm6845comdreg:^char; nomap: boolean; { 3.0 bug fix jws 3/20/84 } crtidreg[hex('51FFFE')]: packed record b15,b14,b13: boolean; colorinfo: (cinfo0, cinfo1, cinfo2, cinfo3); b10,b9,b8,b7,b6,b5,b4,b3,b2,b1,b0: boolean; end; procedure dumpa; label 1; var row, column:integer; c: char; line: string[100]; begin with syscom^.crtinfo do begin setstrlen(line, width); for row := 0 to height-1 do begin for column := 0 to width-1 do begin c := screen^[row*width+column].character; if (c >= #128) and (c <= #238) then c := chr(romtokanamap[c]); line[column+1] := c; end; column := width; while (column > 1) and (line[column]= ' ') do column := column - 1; writeln(gfiles[4]^, line:column); if ioresult <> ord(inoerror) then goto 1; end; end; 1: end; procedure toggleg; var gon [5439488{530000 HEX}]:shortint; goff[5472256{538000 HEX}]:shortint; gbase['GRAPHICSBASE']: ^shortint; begin graphicstate:=not graphicstate; if graphicstate then gbase:=addr(gon) else gbase:=addr(goff); gbase^ := gbase^; end; procedure dumpg; label 1; const gheight = 300; gheightb = 390; gwidth = 50; gwidthb = 64; gbuffersize=gwidthb+6; type gword=packed record dummy,growbyte:char; end; gdotrow=packed array[1..gwidth] of gword; type gmemtype = packed array [1..gheight] of gdotrow; gmembtype = packed array [1..gheightb, 1..gwidthb] of char; gmem = ^gmemtype; gmemb = ^gmembtype; var graphicsbase['GRAPHICSBASE']: anyptr; gbuffer:packed array[1..gbuffersize] of char; i,j,rows,buffersize,pindex:integer; busy:boolean; begin gbuffer[1]:=chr(esc) {escape sequence for graphics}; gbuffer[2]:='*'; gbuffer[3]:='b'; gbuffer[6]:='W'; if sysflag.biggraphics then  begin gbuffer[4]:='6'; gbuffer[5]:='4'; rows := gheightb; buffersize := gwidthb+6; end else begin gbuffer[4]:='5'; gbuffer[5]:='0'; rows := gheight; buffersize := gwidth+6; end; for i:= 1 to rows do begin if sysflag.biggraphics then for j:=1 to gwidthb do gbuffer[j+6]:=gmemb(graphicsbase)^[i,j] else for j:=1 to gwidth do gbuffer[j+6]:=gmem(graphicsbase)^[i,j].growbyte; write(gfiles[4]^, gbuffer:buffersize);)  if ioresult <> ord(inoerror) then goto 1; end; write(gfiles[4]^, #27'*rB'); {terminate graphics sequence}; 1: end; procedure crtcommand(reg: crtregtype; data: byte); begin pm6845addrreg^ := chr(reg); pm6845comdreg^ := chr(data); end; procedure doupdatecursor; var cursaddr: crtcmdwrd; begin cursaddr.longword:=integer(screen) mod 8192 div 2 + ypos*screenwidth+xpos; cursaddr.textfield := alphastate; cursaddr.softfield:=alphastate; crtcommand(14, cursaddr.topbyte); crtcommand(15, cursaddr.botbyte); end; procedure togglea; var lcursaddr:crtcmdwrd; begin alphastate:=not(alphastate); lcursaddr.longword:=integer(screen) mod 8192 div 2; lcursaddr.textfield:=alphastate; lcursaddr.softfield:=alphastate; crtcommand(12, lcursaddr.topbyte); crtcommand(13, lcursaddr.botbyte); doupdatecursor; end; procedure getxy(var x,y: integer); begin x := xpos; y := ypos; end; procedure setxy(x, y: shortint); begin if x>=screenwidth then xpos:=maxx else if x<0 then xpos:=0 else xpos := x; if y>=screenheight then ypos:=maxy else if y<0 then ypos:=0 else ypos := y; end; procedure gotoxy(x,y: integer); begin setxy(x,y); doupdatecursor; end; procedure clear(number: shortint); var x,y: shortint; begin x:=xpos; y:=ypos; while number>0 do begin screen^[y*screenwidth+x].wholeword:= ord(' '); number:=number-1; if x maxkana) then maptocrt := illegalchar else maptocrt := chr(kanatocrtlookup[ord(c)]); end; end; end; { mapkanatocrt } begin if kbdlang = katakana_kbd then mapkanatocrt else mapromextocrt; end; procedure docrtio(fp: fibp; request: amrequesttype; anyvar buffer: window; length, position: integer); var c: char; s: string[1]; buf: charptr; begin ioresult := ord(inoerror); buf := addr(buffer); case request of {uwait: ; } setcursor: gotoxy(fp^.fxpos, fp^.fypos); getcursor: getxy (fp^.fxpos, fp^.fypos); flush: {do nothing}; unitstatus: kbdio(fp, request, buffer, length, position); clearunit: highlight := defaulthighlight; readtoeol: begin buf := addr(buf^, 1); buffer[0] := chr(0); while length>0 do begin kbdio(* fp, readtoeol, s, 1, 0); if strlen(s)=0 then length := 0 { else if s[1] = chr(etx) then length := 0 } else begin length := length - 1; crtio(fp, writebytes, s[1], 1, 0); buf := addr(buf^, 1);  buffer[0] := chr(ord(buffer[0])+1); end; end; end; startread, readbytes: begin while length>0 do begin kbdio(fp, readbytes, buf^, 1, 0); if buf^ = chr(etx) then length := 0  else length := length - 1; if buf^ = eol then crtio(fp, writeeol, buf^, 1, 0) else crtio(fp, writebytes, buf^, 1, 0); buf := addr(buf^, 1); end; if request = startread then call(fp^.feot, fp); end; writeeol: begin if ypos=maxy then scrollup; gotoxy(0, ypos+1); end; startwrite, writebytes: begin while length>0 do begin c:=buf^; buf:=addr(buf^,1); length:=length-1; case c of  homechar: setxy(0,0); leftchar: if (xpos = 0) and (ypos>0) then setxy(maxx, ypos-1) else setxy(xpos-1, ypos); rightchar: if (xpos = maxx) and (ypos0 then setxy(xpos, ypos-1); end; downchar: if ypos=maxy then scrollup else setxy(xpos, ypos+1); bellchar: beep; cteos: clear(screensize-(ypos*screenwidth+xpos)); cteol: clear(screenwidth-xpos); clearscr: begin setxy(0,0); clear(screensize); end; eol: setxy(0, ypos); chr(etx): length:=0; otherwise  if (ord(c)>=128) and (ord(c)< 144) then if hascolor then if ord(c) >= 136 then highlight := highlight mod 2048 + (ord(c)-136)*4096 else highlight := (highlight div 2048 * 8 + (ord(c)-128))*256 else highlight := (ord(c)-128)*256 else with screen^[ypos*screenwidth+xpos] do begin wholeword:=highlight+ ord(maptocrt(c)); if xpos = maxx then begin if ypos = maxy then scrollup; setxy(0, ypos+1); end  else setxy(xpos+1, ypos); end; end; doupdatecursor; end; {while} if request = startwrite then call(fp^.feot, fp); end; otherwise ioresult := ord(ibadrequest); end; {case} end; procedure lineops(op: crtllops; anyvar position: integer; c:char); var i: integer; sptr: ^string255; begin case op of cllput: lptr^[position].wholeword:=ord(maptocrt(c)); cllshiftl: begin for i:=0 to (maxx-8) do lptr^[i]:=lptr^[i+1]; lptr^[maxx-8].wholeword:=ord(' '); end; cllshiftr: begin for i:=0 to (maxx-9) do lptr^[maxx-8-i]:=lptr^[maxx-9-i]; lptr^[0].wholeword:=ord(' '); end; cllclear: for i:=0 to (maxx-8) do lptr^[i].wholeword:=ord(' '); clldisplay: begin sptr:=addr(position); for i:=1 to length(sptr^) do lptr^[i-1].wholeword:=ord(maptocrt(sptr^[i])); for i:=length(sptr^) to (maxx-8) do lptr^[i].wholeword:=ord(' '); end; putstatus: begin { position should be in range 0..7 } lptr^[maxx-7+position].wholeword:=ord(c); end; end; { case} end; { lineops } procedure crtdebug(op: dbcrtops; var dbrec: dbcinfo ); type iptr = ^iarray; iarray = array[0..maxint] of shortint; var xtemp, ytemp: shortint; i,j,k: shortint; len: shortint; inc: shortint; temp: array[0..79] of shortint; begin with dbrec do begin case op of dbinfo: savesize:=(xmax-xmin+1)*(ymax-ymin+1)*2; dbgotoxy: begin xtemp:=xpos; ytemp:=ypos; *  xpos:=cursx; ypos:=cursy; doupdatecursor; xpos:=xtemp; ypos:=ytemp; end; dbscrollup,dbscrolldn: begin len:=(xmax-xmin+1)*2; if op=dbscrollup then begin j:=ymin; inc:=screenwidth;  end else begin j:=ymax; inc:=-screenwidth; end; j:=j*screenwidth+xmin; for i:=(ymin+1) to ymax do begin k:=j; j:=j+inc; moveleft(screen^[j], screen^[k], len); end; for i:=0 to (xmax-xmin) do screen^[j+i].wholeword:=ord(' '); end; dbscrolll,dbscrollr: begin len:=(xmax-xmin+1)*2-2; { fixed 4/13/84 } j:=(ymin-1)*screenwidth+xmin; if op=dbscrolll then begin  j:=j+1; k:=xmax-xmin-1; end else begin k:=0; end; for i:=ymin to ymax do begin j:=j+screenwidth; if op=dbscrolll then moveleft(screen^[j],screen^[j-1], len) else  moveright(screen^[j],screen^[j+1], len); screen^[j+k].wholeword:=ord(' '); end; end; dbhighl: begin i:=cursy*screenwidth+cursx; screen^[i].wholeword:=ord(screen^[i].character)+(ord(c)-128)*256;  end; dbput: if charismapped then screen^[cursy*screenwidth+cursx].wholeword:= ord(maptocrt(c))+debughighlight else screen^[cursy*screenwidth+cursx].wholeword:=ord(c)+  debughighlight; dbclear: for i:=ymin to ymax do for j:=xmin to xmax do screen^[i*screenwidth+j].wholeword:=ord(' '); dbcline: for i:=cursx to xmax do screen^[cursy*screenwidth+i].wholeword:=ord(' '); dbinit: begin for i:=0 to (savesize div 2)-1 do iptr(savearea)^[i]:=ord(' '); cursx:=xmin; cursy:=ymin; areaisdbcrt:=true; charismapped:=false; debughighlight:=0; end; dbexcg: begin k:=xmax-xmin+1; for i:=ymin to ymax do begin moveleft(screen^[i*screenwidth+xmin], temp, k*2); moveleft(iptr(savearea)^[(i-ymin)*k], screen^[i*screenwidth+xmin], k*2); moveleft(temp, iptr(savearea)^[(i-ymin)*k], k*2); end; if areaisdbcrt then begin xtemp:=xpos; ytemp:=ypos; xpos:=cursx; ypos:=cursy; doupdatecursor; xpos:=xtemp; ypos:=ytemp;  end else doupdatecursor; areaisdbcrt:=not areaisdbcrt; end; end; { of case } end; { of with } end; { procedure crtdebug } procedure alphacrtinit; var cursaddr: crtcmdwrd; i,k: integer; begin with syscom^.crtinfo do  begin screen:=anyptr(crtmemaddr); screenwidth:=width; screenheight:=height; maxx:=width-1; maxy:=height-1; screensize:=width*height; for i:=0 to screensize-1 do screen^[i].wholeword:=ord(' '); {clear screen} pm6845addrreg:=anyptr(crtcontroladdr); pm6845comdreg:=anyptr(crtcontroladdr+2); cursaddr.longword:=integer(screen) mod 8192 div 2; cursaddr.textfield:=alphastate; cursaddr.softfield:=alphastate; crtcommand(12, cursaddr.topbyte); crtcommand(13, cursaddr.botbyte); defaulthighlight := 0; highlight := 0; idle:=250; nomap:=false; if sysflag.crtconfigreg then begin if crtidreg.b13 then begin { 3.0 bug jws 3/20/84 } nomap:=true; { 3.0 bug jws 3/20/84 } idle:=245; { 3.0 bug jws 3/20/84 } end; { 3.0 bug jws 3/20/84 } hascolor := crtidreg.colorinfo > cinfo0; end else hascolor := false; gotoxy(0,0); dumpalphahook := dumpa; dumpgraphicshook := dumpg; togglealphahook := togglea; togglegraphicshook := toggleg; updatecursorhook:=doupdatecursor; crtiohook:=docrtio; crtllhook:=lineops; dbcrthook:=crtdebug; c+ rtinithook:=alphacrtinit; lptr:=anyptr(keybufferaddr); keybuffer^.maxsize:=maxx-8; currentcrt:=alphatype; end; end; function alphacrt:boolean; var i[hex('512000')]:shortint; j: shortint; begin alphacrt:=true; { assume we have alpha screen } try j:=i; { attempt read from alpha screen ram } syscom^:=environc; { setup for my kind of environment } if not sysflag.alpha50 then syscom^.crtinfo:=b9826info; alphacrtinit; recover if escapecode=-12 then alphacrt:=false { bus error -- no alpha screen } else escape(escapecode); end; end; { of module } import crt, loader; begin if alphacrt then markuser; end. ************************************************* * BUILD THE VARIOUS CRT DRIVERS PIECES ********** ************************************************* cC_HOOK n cCRT n cGCRT n aGASSM n cBCCRT n aBCASSM n cGBCRT n aGBASSM n cCATCRT n aCATASM n cFCRT n aFASSM n *************************************************************** * NOW LINKEM ************************************************** *************************************************************** loCRT. lnCRT dx Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iCRT alkq loCRTB. lnCRTB dx Copyright Hewlett-Packard Co.,1984,1991 All rights reserved. iGASSM aiGCRT alkq loCRTC. lnCRTC dx Copyright Hewlett-Packard Co.,1985,1991 All rights reserved. iBCASSM aiBCCRT alkq loCRTE. lnCRTE dx Copyright Hewlett-Packard Co.,1985,1991 All rights reserved. iCATASM aiCATCRT alkq loCRTF. lnCRTF dx Copyright Hewlett-Packard Co.,1985,1991 All rights reserved. iFASSM aiFCRT alkq loCRTD. lnCRTD dx Copyright Hewlett-Packard Co.,1985,1991 All rights reserved. iGBASSM aiGBCRT alkq loCHOOK. lnCHOOK x Copyright Hewlett-Packard Co.,1983,1991 All rights reserved. diC_HOOK alkq ******************************************************************* * DONE WITH CRT DRIVER BUILD AND LINK ***************************** *******************************************************************  This floppy contains the source for various Pascal Workstation CRT drivers (CHOOK, CRT, CRTB, CRTC, CRTD, CRTE, CRTF). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_CRTS.TEXT) which shows how to build and link the drivers is also included.  This floppy contains the source for various Pascal Workstation CRT drivers (CHOOK, CRT, CRTB, CRTC, CRTD, CRTE, CRTF). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_CRTS.TEXT) which shows how to build and link the drivers is also included. **************************************************************** Copyright Hewlett-Packard Company, 1994. All rights are reserved. Copying or other reproduction of this product except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado @+ @@@@@@@@@@@@@@@@, @@@@@@@@@@@@@@@@, @@@@@@@@@@@@@@@@- @@@@@@@@@@@@@@@@- @@@@@@@@@@@@@@@@. @@@@@@@@@@@@@@@@. @@@@@@@@@@@@@@@@/ @@@@@@@@@@@@@@@@/ @@@@@@@@@@@@@@@@0 @@@@@@@@@@@@@@@@0 @@@@@@@@@@@@@@@@1 @@@@@@@@@@@@@@@@1 @@@@@@@@@@@@@@@@2 @@@@@@@@@@@@@@@@2 @@@@@@@@@@@@@@@@3 @@@@@@@@@@@@@@@@3 @@@@@@@@@@@@@@@@4 @@@@@@@@@@@@@@@@4 @@@@@@@@@@@@@@@@5 @@@@@@@@@@@@@@@@5 @@@@@@@@@@@@@@@@6 @@@@@@@@@@@@@@@@6 @@@@@@@@@@@@@@@@7 @@@@@@@@@@@@@@@@7 @@@@@@@@@@@@@@@@8 @@@@@@@@@@@@@@@@8 @@@@@@@@@@@@@@@@9 @@@@@@@@@@@@@@@@9 @@@@@@@@@@@@@@@@: @@@@@@@@@@@@@@@@: @@@@@@@@@@@@@@@@; @@@@@@@@@@@@@@@@; @@@@@@@@@@@@@@@@< @@@@@@@@@@@@@@@@< @@@@@@@@@@@@@@@@= @@@@@@@@@@@@@@@@= @@@@@@@@@@@@@@@@> @@@@@@@@@@@@@@@@> @@@@@@@@@@@@@@@@? @@@@@@@@@@@@@@@@? @@@@@@@@@@@@@@@@@ @@@@@@@@@@@@@@@@@ @@@@@@@@@@@@@@@@A @@@@@@@@@@@@@@@@A @@@@@@@@@@@@@@@@B @@@@@@@@@@@@@@@@B @@@@@@@@@@@@@@@@C @@@@@@@@@@@@@@@@C @@@@@@@@@@@@@@@@D @@@@@@@@@@@@@@@@D @@@@@@@@@@@@@@@@E @@@@@@@@@@@@@@@@E @@@@@@@@@@@@@@@@F @@@@@@@@@@@@@@@@F @@@@@@@@@@@@@@@@G @@@@@@@@@@@@@@@@G @@@@@@@@@@@@@@@@H @@@@@@@@@@@@@@@@H @@@@@@@@@@@@@@@@I @@@@@@@@@@@@@@@@I @@@@@@@@@@@@@@@@J @@@@@@@@@@@@@@@@J @@@@@@@@@@@@@@@@K @@@@@@@@@@@@@@@@K @@@@@@@@@@@@@@@@L @@@@@@@@@@@@@@@@L @@@@@@@@@@@@@@@@