Hi Tomas,
I have done all my work with Free pascal but only one error
which still i am not able to fix is MEM as i tried all the options which you
suggest me (heartly thanks for that) but still i am not Getting exect
solution for it.....Please see below fully compilable source in free pascal
2.6.4 using 'Video' unit on windows 7 and help me please...
UNIT TestMem;
{$O+,F+}
INTERFACE
TYPE
location_pointer = ^location;
location = RECORD
next : location_pointer;
code : WORD;
END;
window_pointer = ^window_object;
window_object = OBJECT
x, y,
x_offset,
y_offset : BYTE;
first_location : location_pointer;
window_has_been_saved : BOOLEAN;
CONSTRUCTOR initialise(top_left_x,
top_left_y,
width,
height : BYTE);
PROCEDURE save;
PROCEDURE appear; VIRTUAL;
DESTRUCTOR destroy_window;
END;
screen_window_pointer = ^screen_window;
screen_window = OBJECT(window_object)
replacement_window : window_pointer;
border_fore_colour,
border_back_colour,
window_fore_colour,
window_back_colour,
window_style : BYTE;
CONSTRUCTOR initialise(top_left_x,
top_left_y,
width,
height,
style,
border_foreground,
border_background,
window_foreground,
window_background : BYTE);
PROCEDURE appear; VIRTUAL;
PROCEDURE appear_at(top_left_x,
top_left_y : BYTE); VIRTUAL;
PROCEDURE disappear; VIRTUAL;
DESTRUCTOR destroy_window;
END;
PROCEDURE draw_window_outline(top_left_x,
top_left_y,
width,
height,
style,
fore,
back : BYTE);
PROCEDURE blank_window(top_left_x,
top_left_y,
width,
height,
colour : BYTE);
PROCEDURE draw_window(top_left_x,
top_left_y,
width,
height,
style,
border_fore,
border_back,
window_fore,
window_back : BYTE);
PROCEDURE clear_last_boxed_message;
PROCEDURE halt_with_message(line_1,
line_2,
line_3,
line_4 : STRING);
PROCEDURE siren(sound_length : BYTE;
delay_length : BYTE);
PROCEDURE write_box_message (str1, str2, str3 : string; exit_required :
BOOLEAN);
PROCEDURE write_boxed_message(line_1,
line_2,
line_3,
line_4,
line_5 : STRING);
FUNCTION upcase_string(st : STRING): STRING;
VAR
write_message_to_screen : BOOLEAN;
halt_with_message_string : STRING;
IMPLEMENTATION
USES
CRT,
video,
mouse;
TYPE
border_code = ARRAY [0..4] OF BYTE;
CONST
top_left_corner : border_code = (32, 218, 201, 214, 213);
top_right_corner : border_code = (32, 191, 187, 183, 184);
bottom_left_corner : border_code = (32, 192, 200, 211, 212);
bottom_right_corner : border_code = (32, 217, 188, 189, 190);
horizontal : border_code = (32, 196, 205, 196, 205);
vertical : border_code = (32, 179, 186, 186, 179);
VAR
error_message : screen_window;
PROCEDURE set_range_of( VAR input : BYTE;
most,
least : BYTE);
BEGIN
IF input>most THEN
input:=most
ELSE IF input<least THEN
input:=least;
END;
CONSTRUCTOR window_object.initialise(top_left_x,
top_left_y,
width,
height : BYTE);
BEGIN
x:=top_left_x;
y:=top_left_y;
x_offset:=width;
y_offset:=height;
set_range_of( x, 80, 1);
set_range_of( y, 25, 1);
set_range_of( x_offset, 81-top_left_x, 1);
set_range_of( y_offset, 26-top_left_y, 1);
first_location:=NIL;
window_has_been_saved:=FALSE;
END;
PROCEDURE window_object.save;
VAR
width_offset,
height_offset : BYTE;
current_location : location_pointer;
P:Integer;
BEGIN
IF NOT window_has_been_saved THEN
BEGIN
NEW(first_location);
first_location^.next:=NIL;
END;
current_location:=first_location;
FOR height_offset:=y TO (y+y_offset-1) DO
BEGIN
FOR width_offset:=x TO (x+x_offset-1) DO
BEGIN
// current_location^.code:=MEMW[$B800:(width_offset-1)*2
// +(height_offset-1)*160];
P:= ((width_offset-1)+(height_offset-1)* ScreenWidth);
current_location^.code:=word(@VideoBuf^[P]);
IF (current_location^.next=NIL) THEN
BEGIN
NEW(current_location^.next);
current_location^.next^.next:=NIL;
END;
current_location:=current_location^.next;
END;
UpdateScreen(false);
END;
window_has_been_saved:=TRUE;
END;
PROCEDURE window_object.appear;
VAR
width_offset,
height_offset : BYTE;
current_location : location_pointer;
BEGIN
current_location:=first_location;
FOR height_offset:=y TO (y+y_offset-1) DO
BEGIN
FOR width_offset:=x TO (x+x_offset-1) DO
BEGIN
// MEMW[$B800:(width_offset-1)*2
// +(height_offset-1)*160]:=current_location^.code;
VideoBuf^[(width_offset-1)
+(height_offset-1)*
ScreenWidth]:=Ord(current_location^.code);
current_location:=current_location^.next;
END;
END;
current_location^.next:=NIL;
UpdateScreen(false);
END;
DESTRUCTOR window_object.destroy_window;
VAR
current_location : location_pointer;
BEGIN
IF window_has_been_saved AND (first_location<> NIL) THEN
BEGIN
current_location:=first_location^.next;
WHILE current_location<>NIL DO
BEGIN
DISPOSE(first_location);
first_location:=current_location;
current_location:=first_location^.next;
END;
DISPOSE(first_location);
END;
window_has_been_saved:= FALSE;
END;
CONSTRUCTOR screen_window.initialise(top_left_x,
top_left_y,
width,
height,
style,
border_foreground,
border_background,
window_foreground,
window_background : BYTE);
BEGIN
window_object.initialise(top_left_x,
top_left_y,
width,
height);
NEW(replacement_window,initialise(top_left_x,
top_left_y,
width,
height));
window_style:=style;
border_fore_colour:=border_foreground;
border_back_colour:=border_background;
window_fore_colour:=window_foreground;
window_back_colour:=window_background;
set_range_of( window_style, 4, 0);
set_range_of( border_fore_colour, 15, 0);
set_range_of( border_back_colour, 7, 0);
set_range_of( window_fore_colour, 15, 0);
set_range_of( window_back_colour, 7, 0);
END;
PROCEDURE screen_window.appear;
BEGIN
replacement_window^.save;
IF NOT window_has_been_saved THEN
draw_window(x,
y,
x_offset,
y_offset,
window_style,
border_fore_colour,
border_back_colour,
window_fore_colour,
window_back_colour)
ELSE window_object.appear;
END;
PROCEDURE screen_window.disappear;
BEGIN
save;
replacement_window^.appear;
END;
PROCEDURE screen_window.appear_at(top_left_x,
top_left_y : BYTE);
BEGIN
x:=top_left_x;
y:=top_left_y;
set_range_of( x, 79, 1);
set_range_of( y, 24, 1);
replacement_window^.x:=x;
replacement_window^.y:=y;
appear;
END;
DESTRUCTOR screen_window.destroy_window;
BEGIN
IF replacement_window<> NIL THEN
DISPOSE(replacement_window,destroy_window);
window_object.destroy_window;
END;
PROCEDURE draw_window_outline(top_left_x,
top_left_y,
width,
height,
style,
fore,
back : BYTE);
VAR
x,y : BYTE;
offset : INTEGER;
{*
BEGIN
IF (style<>255) AND (width>2) AND (height>2) THEN
BEGIN
offset:=(top_left_x-1)*2
+(top_left_y-1)*160;
MEM[$B800:offset]:=top_left_corner[style];
MEM[$B800:offset+1]:=back*16+fore;
FOR x:=1 TO (width-2) DO
BEGIN
MEM[$B800:offset+x*2]:=horizontal[style];
MEM[$B800:offset+x*2+1]:=back*16+fore;
END;
MEM[$B800:offset+(width-1)*2]:=top_right_corner[style];
MEM[$B800:offset+(width-1)*2+1]:=back*16+fore;
FOR y:=1 TO (height-2) DO
BEGIN
MEM[$B800:offset+y*160]:=vertical[style];
MEM[$B800:offset+y*160+1]:=back*16+fore;
MEM[$B800:offset+(width-1)*2+y*160]:=vertical[style];
MEM[$B800:offset+(width-1)*2+y*160+1]:=back*16+fore;
END;
offset:=(top_left_x-1)*2
+(top_left_y+height-2)*160;
MEM[$B800:offset]:=bottom_left_corner[style];
MEM[$B800:offset+1]:=back*16+fore;
FOR x:=1 TO (width-2) DO
BEGIN
MEM[$B800:offset+x*2]:=horizontal[style];
MEM[$B800:offset+x*2+1]:=back*16+fore;
END;
MEMW[$B800:offset+(width-1)*2]:=bottom_right_corner[style];
MEM[$B800:offset+(width-1)*2+1]:=back*16+fore;
END;
END;
*}
BEGIN
IF (style<>255) AND (width>2) AND (height>2) THEN
BEGIN
offset:=(top_left_x-1)+(top_left_y-1)* ScreenWidth;
VideoBuf^[offset]:=top_left_corner[style];
VideoBuf^[offset+1]:=back*16+fore;
FOR x:=1 TO (width-2) DO
BEGIN
VideoBuf^[offset+x]:=horizontal[style];
VideoBuf^[offset+x]:=back*16+fore;
END;
VideoBuf^[offset+(width-1)]:=top_right_corner[style];
VideoBuf^[offset+(width-1)]:=back*16+fore;
FOR y:=1 TO (height-2) DO
BEGIN
VideoBuf^[offset+y* ScreenWidth]:=vertical[style];
VideoBuf^[offset+y*0+1]:=back*16+fore;
VideoBuf^[offset+(width-1)+y*ScreenWidth]:=vertical[style];
VideoBuf^[offset+(width-1)+y*ScreenWidth+1]:=back*16+fore;
END;
offset:=(top_left_x-1)
+(top_left_y+height-2)*160;
VideoBuf^[offset]:=bottom_left_corner[style];
VideoBuf^[offset+1]:=back*16+fore;
FOR x:=1 TO (width-2) DO
BEGIN
VideoBuf^[offset+x]:=horizontal[style];
VideoBuf^[offset+x]:=back*16+fore;
END;
VideoBuf^[offset+(width-1)]:=bottom_right_corner[style];
VideoBuf^[offset+(width-1)]:=back*16+fore;
END;
UpdateScreen(false);
END;
PROCEDURE blank_window(top_left_x,
top_left_y,
width,
height,
colour : BYTE);
VAR
x_offset,
y_offset : BYTE;
code : WORD;
BEGIN
FOR y_offset:=top_left_y TO (top_left_y+height) DO
BEGIN
FOR x_offset:=top_left_x TO (top_left_x+width) DO
BEGIN
{* MEM[$B800:(x_offset-1)*2
+(y_offset-1)*160]:=32;
MEM[$B800:(x_offset-1)*2
+(y_offset-1)*160+1]:=colour*16; *}
// VideoBuf^[(x_offset-1)+(y_offset-1)*160]:=32;
// VideoBuf^[(x_offset-1)+(y_offset-1)*160]:=colour*16 ;
VideoBuf^[(x_offset-1)+(y_offset-1)*ScreenWidth] :=32 + $16 shl
8;
END;
END;
UpdateScreen(false);
END;
PROCEDURE draw_window(top_left_x,
top_left_y,
width,
height,
style,
border_fore,
border_back,
window_fore,
window_back : BYTE);
BEGIN
draw_window_outline(top_left_x,
top_left_y,
width,
height,
style,
border_fore,
border_back);
blank_window(top_left_x+1,
top_left_y+1,
width-3,
height-3,
window_back);
END;
PROCEDURE siren(sound_length : BYTE;
delay_length : BYTE);
VAR
count : INTEGER;
BEGIN
FOR count := 10 DOWNTO 1 DO
BEGIN
sound(sound_length*count);
delay(delay_length);
nosound;
delay(sound_length);
END;
END;{PROCEDURE siren}
PROCEDURE truncate_message(VAR message_string : STRING);
VAR
counter : INTEGER;
temp_string : STRING;
BEGIN
temp_string := '';
FOR counter := 1 to 69 DO
temp_string := temp_string + message_string[counter];
message_string := temp_string;
END;
PROCEDURE write_boxed_message(line_1,
line_2,
line_3,
line_4,
line_5 : STRING);
VAR
message : ARRAY [1..5] OF STRING;
message_window_height : INTEGER;
message_window_width : INTEGER;
message_window_x : INTEGER;
message_window_y : INTEGER;
PROCEDURE work_out_box_dimensions;
VAR
z,
t,
message_length : BYTE;
BEGIN
message[1]:=line_1;
message[2]:=line_2;
message[3]:=line_3;
message[4]:=line_4;
message[5]:=line_5;
message_window_height:=5;
message_window_width:=0;
FOR z:=1 TO 5 DO
BEGIN
message_length:=LENGTH(message[z]);
IF message_length>69 THEN
BEGIN
truncate_message(message[z]);
message_length := 69;
END;
IF (message_length>message_window_width) THEN
message_window_width:=message_length;
IF (message_length=0) AND (z>1) AND (LENGTH(message[z-1])>0) THEN
message_window_height:=(z-1);
IF (message_window_height<5) AND (message_length>0) THEN
message_window_height:=z;
END;
message_window_height:=message_window_height+2;
message_window_width:=message_window_width+4;
message_window_x:=TRUNC((84-message_window_width)/2);
message_window_y:=TRUNC((24-message_window_height)/2);
END;
PROCEDURE write_message_in_box(box : screen_window);
VAR
z : INTEGER;
BEGIN
WITH box DO
BEGIN
textbackground(window_back_colour);
textcolor(window_fore_colour);
FOR z:=1 TO (message_window_height-2) DO
BEGIN
GOTOXY(message_window_x
+TRUNC((message_window_width-LENGTH(message[z]))/2),
message_window_y+z);
WRITE(message[z]);
END;
END
END;
BEGIN
IF error_message.window_has_been_saved THEN
clear_last_boxed_message;
work_out_box_dimensions;
error_message.initialise(message_window_x,
message_window_y,
message_window_width,
message_window_height,
2,
yellow,
red,
yellow,
red);
IF mouse_enabled THEN
hide_mouse;
error_message.replacement_window^.save;
error_message.appear;
write_message_in_box(error_message);
gotoxy(80,25);
error_message.save;
END;
PROCEDURE halt_with_message(line_1,
line_2,
line_3,
line_4 : STRING);
VAR
dummy : CHAR;
line_5 : STRING;
BEGIN
line_5:='Contact Your Product Support Representative';
IF write_message_to_screen THEN
BEGIN
write_boxed_message(line_1,
line_2,
line_3,
line_4,
line_5);
siren(50,35);
dummy := readkey;
error_message.disappear;
error_message.destroy_window;
END
ELSE
halt_with_message_string := line_1+' '+line_2+' '+line_3+'
'+line_4;
halt;
END;
PROCEDURE clear_last_boxed_message;
BEGIN
IF (error_message.window_has_been_saved) THEN
BEGIN
error_message.replacement_window^.appear;
error_message.destroy_window;
END;
IF mouse_enabled THEN
show_mouse;
END;
PROCEDURE write_box_message (str1, str2, str3 : string; exit_required :
BOOLEAN);
var
border : integer;
ch1 : char;
longest : string;
begin
longest := str1;
if length(str2) > length(longest) then
longest := str2;
if length(str3) > length(longest) then
longest := str3;
clrscr;
border := TRUNC((80 - length(longest)) / 2) - 3;
textbackground(1);
window (border,5,80-border,11);
clrscr;
textcolor(11);
writeln;
writeln(' ', str1);
writeln(' ', str2);
writeln(' ', str3);
writeln;
if exit_required then
begin
textcolor(13);
writeln(' Press any key to exit');
ch1 := ReadKey;
textbackground(0);
textcolor(7);
window (1,1,80,25);
clrscr;
halt;
end;
end;
FUNCTION upcase_string(st : STRING): STRING;
VAR
z : INTEGER;
BEGIN
FOR z:=1 TO LENGTH(st) DO
st[z]:=UpCase(st[z]);
upcase_string:=st;
END;
BEGIN
InitVideo;
error_message.initialise( 1, 1, 1, 1,
2,
yellow,
red,
yellow,
red);
write_message_to_screen := TRUE;
halt_with_message_string := '';
DoneVideo;
END.
--
View this message in context:
http://free-pascal-general.1045716.n5.nabble.com/Segmentation-Error-using-VideoBuf-tp5719293p5719692.html
Sent from the Free Pascal - General mailing list archive at Nabble.com.
_______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/cgi-bin/mailman/listinfo/fpc-pascal
