DASM
|
00001 #!/usr/bin/perl -w 00002 ## 00003 # Text emulation for the DASM assembler. 00004 # This module provides the video RAM for a text array chip, based on what 00005 # appears to be the video hardware for the assembler. 00006 # 00007 # The chip is 32x12 = 384 bytes for the video array. 00008 # 00009 # The allocation in the window is: 00010 # 00011 # - 0x000-0x17f : Character array 00012 # 00013 # - 0x180-0x27f : Character definitions 00014 # 00015 # - 0x280-0x281 : Background colour 00016 # 00017 # Bit mapping: 00018 # 00019 # `ccccccccbiiiiiii` 00020 # 00021 # - `iiiiiii` @n 00022 # Character index. 00023 # 00024 # - `b` @n 00025 # Blinking. 00026 # 00027 # - `cccccccc` @n 00028 # Colour, in the form `ffffbbbb`, each of which takes the form `hrgb`: 00029 # - `h` @n 00030 # Highlight (increase by 0x55). 00031 # - `r` @n 00032 # Red component (value 0xAA when set) 00033 # - `g` @n 00034 # Green component (value 0xAA when set) 00035 # - `b` @n 00036 # Blue component (value 0xAA when set) 00037 # 00038 # We actually use the highlight only on the foreground colour, as bold 00039 # in the colour attributes. 00040 # 00041 # @file 00042 # @author Justin Fletcher 00043 # 00044 00045 package DExecHW::Video; 00046 00047 use Curses; 00048 00049 00050 ## Disable the Curses interface (for debug) 00051 my $disabled = 0; 00052 00053 00054 ## 00055 # Construct a new hardware device object. 00056 # 00057 # @param[in] $proto This class object, or prototype to add to 00058 # @param[in] $object The object to proxy for 00059 # @param[in] $offset The offset this object is created for 00060 # 00061 # @return Assembler object 00062 sub new 00063 { 00064 my $proto = shift; 00065 my $object = shift; 00066 my $offset = shift || 0; 00067 my $class = ref($proto) || $proto; 00068 my $self = { 00069 'display' => [ 00070 map { 0 } (0..0x17f) 00071 ], 00072 'chars' => [ 00073 map { 0 } (0..0xff) 00074 ], 00075 'background' => [ 00076 map { 0 } (0..0x1) 00077 ], 00078 00079 'width' => 32, 00080 'height' => 12, 00081 }; 00082 00083 bless $self, $class; 00084 00085 00086 return $self; 00087 } 00088 00089 00090 ## 00091 # Start up the hardware. 00092 # 00093 # We perform all output through the Curses library. 00094 # 00095 # @param[in] $self Object 00096 sub start 00097 { 00098 my ($self) = @_; 00099 00100 if (!$disabled) 00101 { 00102 Curses::initscr(); 00103 00104 if (!Curses::has_colors()) 00105 { 00106 Curses::endwin(); 00107 die "No colours available for video driver\n"; 00108 } 00109 00110 Curses::start_color(); 00111 my @colours = ( 00112 Curses::COLOR_BLACK, 00113 Curses::COLOR_BLUE, 00114 Curses::COLOR_GREEN, 00115 Curses::COLOR_CYAN, 00116 Curses::COLOR_RED, 00117 Curses::COLOR_MAGENTA, 00118 Curses::COLOR_YELLOW, 00119 Curses::COLOR_WHITE, 00120 ); 00121 for my $col (0..(8*8-1)) 00122 { 00123 Curses::init_pair(1+$col, $colours[$col>>3], $colours[$col & 7]); 00124 00125 # Debugging 00126 if ($disabled) 00127 { 00128 printf "InitColour %i: fg=%i, bg=%i\n", 00129 $col, $colours[$col>>3], $colours[$col & 7]; 00130 } 00131 } 00132 00133 $self->{'win'} = Curses::newwin($self->{'height'}, 00134 $self->{'width'}, 00135 0, 0); 00136 #Curses::box( $self->{'win'}, 0,0); 00137 00138 Curses::refresh( $self->{'win'} ); 00139 } 00140 } 00141 00142 00143 ## 00144 # Stop the hardware. 00145 # 00146 # @param[in] $self Object 00147 sub stop 00148 { 00149 my ($self) = @_; 00150 00151 if (!$disabled) 00152 { 00153 Curses::endwin(); 00154 } 00155 } 00156 00157 00158 00159 ## 00160 # Return the size of of the implementation. 00161 # 00162 # @param[in] $self Object 00163 # 00164 # @return Size of the hardware implementation in words 00165 sub window 00166 { 00167 my ($self) = @_; 00168 00169 return 0x282; 00170 } 00171 00172 00173 ## 00174 # Read value 00175 # 00176 # @param[in] $self Object 00177 # @param[in] $offset Offset of register within window 00178 # @param[in] $exec DExec object opon which this object is operating 00179 # 00180 # @return value of this register 00181 sub read 00182 { 00183 my ($self, $offset, $exec) = @_; 00184 00185 if ($offset < 0x180) 00186 { 00187 $value = $self->{'display'}->[$offset]; 00188 } 00189 elsif ($offset < 0x180+0x100) 00190 { 00191 $value = $self->{'chars'}->[$offset-0x180]; 00192 } 00193 elsif ($offset < 0x180+0x100+2) 00194 { 00195 $value = $self->{'background'}->[$offset-0x180-0x100]; 00196 } 00197 00198 return $value; 00199 } 00200 00201 00202 ## 00203 # Write value 00204 # 00205 # @param[in] $self Object 00206 # @param[in] $offset Offset of register within window 00207 # @param[in] $exec DExec object upon which this object is operating 00208 # @param[in] $value Value to write 00209 # 00210 # @return ignored 00211 sub write 00212 { 00213 my ($self, $offset, $exec, $value) = @_; 00214 00215 if ($offset < 0x180) 00216 { 00217 $self->{'display'}->[$offset] = $value; 00218 00219 my $bg = ($value >> 8) & 0x7; 00220 my $bgh = $value & (1<<11); 00221 my $fg = ($value >> 12) & 0x7; 00222 my $fgh = $value & (1<<15); 00223 my $blink = ($value & 128); 00224 my $char = ($value & 0x7f); 00225 00226 if (!$disabled) 00227 { 00228 Curses::attron( $self->{'win'}, 00229 Curses::COLOR_PAIR(1+$fg*8 + $bg) | 00230 ($fgh ? Curses::A_BOLD : 0) | 00231 ($blink ? Curses::A_BLINK : 0)); 00232 } 00233 00234 my $y = int($offset / $self->{'width'}); 00235 my $x = int($offset % $self->{'width'}); 00236 00237 if (!$disabled) 00238 { 00239 Curses::addch($self->{'win'}, $y, $x, $char); 00240 00241 Curses::refresh( $self->{'win'} ); 00242 } 00243 else 00244 { 00245 print "Write $value to $x,$y (char=$char, fg=$fg, bg=$bg, blink=$blink)\n"; 00246 } 00247 } 00248 elsif ($offset < 0x180+0x100) 00249 { 00250 $self->{'chars'}->[$offset-0x180] = $value; 00251 } 00252 elsif ($offset < 0x180+0x100+2) 00253 { 00254 $self->{'background'}->[$offset-0x180-0x100] = $value; 00255 } 00256 } 00257 00258 00259 ## 00260 # Get the symbol name for an offset 00261 # 00262 # @param[in] $self Object 00263 # @param[in] $offset Offset of register within window 00264 # 00265 # @return symbol name to use 00266 # @retval undef for a default symbol 00267 # @retval "" for no symbol 00268 sub symbol 00269 { 00270 my ($self, $offset) = @_; 00271 00272 return ""; 00273 } 00274 00275 # Must return 1 00276 1;