2 \ Fcode payload for QEMU VGA graphics card
4 \ This is the Forth source for an Fcode payload to initialise
5 \ the QEMU VGA graphics card.
7 \ (C) Copyright 2013 Mark Cave-Ayland
13 \ Dictionary lookups for words that don't have an FCode
16 : (find-xt) \ ( str len -- xt | -1 )
24 " openbios-video-width" (find-xt) cell+ value openbios-video-width-xt
25 " openbios-video-height" (find-xt) cell+ value openbios-video-height-xt
26 " depth-bits" (find-xt) cell+ value depth-bits-xt
27 " line-bytes" (find-xt) cell+ value line-bytes-xt
29 : openbios-video-width openbios-video-width-xt @ ;
30 : openbios-video-height openbios-video-height-xt @ ;
31 : depth-bits depth-bits-xt @ ;
32 : line-bytes line-bytes-xt @ ;
34 " fb8-fillrect" (find-xt) value fb8-fillrect-xt
35 : fb8-fillrect fb8-fillrect-xt execute ;
41 " ioc!" (find-xt) value ioc!-xt
42 " iow!" (find-xt) value iow!-xt
44 : ioc! ioc!-xt execute ;
45 : iow! iow!-xt execute ;
51 h# 3c0 constant vga-addr
52 h# 3c8 constant dac-write-addr
53 h# 3c9 constant dac-data-addr
55 : vga-color! ( r g b index -- )
56 \ Set the VGA colour registers
57 dac-write-addr ioc! rot
58 2 >> dac-data-addr ioc! swap
59 2 >> dac-data-addr ioc!
60 2 >> dac-data-addr ioc!
67 h# 0 constant VBE_DISPI_INDEX_ID
68 h# 1 constant VBE_DISPI_INDEX_XRES
69 h# 2 constant VBE_DISPI_INDEX_YRES
70 h# 3 constant VBE_DISPI_INDEX_BPP
71 h# 4 constant VBE_DISPI_INDEX_ENABLE
72 h# 5 constant VBE_DISPI_INDEX_BANK
73 h# 6 constant VBE_DISPI_INDEX_VIRT_WIDTH
74 h# 7 constant VBE_DISPI_INDEX_VIRT_HEIGHT
75 h# 8 constant VBE_DISPI_INDEX_X_OFFSET
76 h# 9 constant VBE_DISPI_INDEX_Y_OFFSET
77 h# a constant VBE_DISPI_INDEX_NB
79 h# 0 constant VBE_DISPI_DISABLED
80 h# 1 constant VBE_DISPI_ENABLED
83 \ Bochs VBE register writes
86 : vbe-iow! ( val addr -- )
92 \ Initialise Bochs VBE mode
96 h# 0 vga-addr ioc! \ Enable blanking
97 VBE_DISPI_DISABLED VBE_DISPI_INDEX_ENABLE vbe-iow!
98 h# 0 VBE_DISPI_INDEX_X_OFFSET vbe-iow!
99 h# 0 VBE_DISPI_INDEX_Y_OFFSET vbe-iow!
100 openbios-video-width VBE_DISPI_INDEX_XRES vbe-iow!
101 openbios-video-height VBE_DISPI_INDEX_YRES vbe-iow!
102 depth-bits VBE_DISPI_INDEX_BPP vbe-iow!
103 VBE_DISPI_ENABLED VBE_DISPI_INDEX_ENABLE vbe-iow!
105 h# 20 vga-addr ioc! \ Disable blanking
112 " pci-bar>pci-region" (find-xt) value pci-bar>pci-region-xt
113 : pci-bar>pci-region pci-bar>pci-region-xt execute ;
115 h# 10 constant cfg-bar0 \ Framebuffer BAR
119 cfg-bar0 pci-bar>pci-region \ ( pci-addr.lo pci-addr.hi size )
120 " pci-map-in" $call-parent
125 \ Publically visible words
133 \ Hook for MOL (see packages/molvideo.c)
135 \ Perhaps for neatness this there should be a separate molvga.fs
136 \ but let's leave it here for now.
138 : color! ( r g b index -- )
146 : color! ( r g b index -- )
152 : fill-rectangle ( color_ind x y width height -- )
156 : dimensions ( -- width height )
158 openbios-video-height
161 : set-colors ( table start count -- )
163 over dup \ ( table start table table )
164 c@ swap 1+ \ ( table start r table-g )
165 dup c@ swap 1+ \ ( table start r g table-b )
166 c@ 3 pick \ ( table start r g b index )
167 color! \ ( table start )
169 swap 3 + swap \ ( table+3 start+1 )
179 : qemu-vga-driver-install ( -- )
181 map-fb fb-addr to frame-buffer-adr
182 default-font set-font
184 frame-buffer-adr encode-int " address" property
186 openbios-video-width openbios-video-height over char-width / over char-height /
191 : qemu-vga-driver-init
194 openbios-video-width encode-int " width" property
195 openbios-video-height encode-int " height" property
196 depth-bits encode-int " depth" property
197 line-bytes encode-int " linebytes" property
199 ['] qemu-vga-driver-install is-install