-- ----------------------------------------------------------------- --
-- AdaSDL_Framebuffer --
-- Copyright (C) 2001 A.M.F.Vargas --
-- Antonio M. F. Vargas --
-- Ponta Delgada - Azores - Portugal --
-- http://www.adapower.net/~avargas --
-- E-mail: avargas@adapower.net --
-- ----------------------------------------------------------------- --
-- --
-- This library is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from --
-- this unit, or you link this unit with other files to produce an --
-- executable, this unit does not by itself cause the resulting --
-- executable to be covered by the GNU General Public License. This --
-- exception does not however invalidate any other reasons why the --
-- executable file might be covered by the GNU Public License. --
-- ----------------------------------------------------------------- --
-- ##########################################################################
-- ### These are new extensions to the SDL API in order to improve the
-- ### Ada code and to isolate the pointer arithmetic inside the library.
-- ##########################################################################
with Lib_C;
package body SDL_Framebuffer_Generics is
-- ===========================================================
-- Go_XY_Generic
-- ===========================================================
function Go_XY_Generic (
Surface : Vd.Surface_ptr;
X : Natural;
Y : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
use Uint_Ptrs;
begin
if X < Natural (Surface.h) and Y < Natural (Surface.w) then
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels))
+ C.ptrdiff_t (
Y * Natural (Surface.pitch) / Natural (Surface.format.BytesPerPixel)
+ X));
else
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels)));
end if;
end Go_XY_Generic;
-- ===========================================================
-- Go_XY_Unchecked_Generic
-- ===========================================================
function Go_XY_Unchecked_Generic (
Surface : Vd.Surface_ptr;
X : Natural;
Y : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
use Uint_Ptrs;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels))
+ C.ptrdiff_t (
Y * Natural (Surface.pitch) / Natural (Surface.format.BytesPerPixel)
+ X));
end Go_XY_Unchecked_Generic;
-- ===========================================================
-- Get_Framebuffer_Generic
-- ===========================================================
function Get_Framebuffer_Generic (
Surface : Vd.Surface_ptr) return Uint_Ptrs.Object_Pointer
is
begin
return Uint_Ptrs.To_Pointer (Surface.pixels);
end Get_Framebuffer_Generic;
-- ===========================================================
-- Goto_Line_Generic
-- ===========================================================
function Goto_Line_Generic (
Surface : Vd.Surface_ptr;
Line_Num : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
use type C.int;
begin
if Line_Num > Natural (Surface.h - 1) then
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels))
+ C.ptrdiff_t (Line_Num * Natural (Surface.pitch)));
else
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels)));
end if;
end Goto_Line_Generic;
-- ===================================================================
-- Goto_Line_Unchecked_Generic
-- ===================================================================
function Goto_Line_Unchecked_Generic (
Surface : Vd.Surface_ptr;
Line_Num : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels))
+ C.ptrdiff_t (Line_Num * Natural (Surface.pitch)));
end Goto_Line_Unchecked_Generic;
-- ===========================================================
-- Goto_Line_End_Unchecked_Generic
-- ===========================================================
function Goto_Line_End_Unchecked_Generic (
Surface : Vd.Surface_ptr;
Line_Num : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
use type C.int;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels))
+ C.ptrdiff_t (Line_Num * Natural (Surface.pitch)
+ Natural (Surface.w - 1)));
end Goto_Line_End_Unchecked_Generic;
-- ===========================================================
-- Goto_Line_End_Generic
-- ===========================================================
function Goto_Line_End_Generic (
Surface : Vd.Surface_ptr;
Line_Num : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
use type C.int;
begin
if Line_Num < Natural (Surface.h - 1) then
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels))
+ C.ptrdiff_t (Line_Num * Natural (Surface.pitch)
+ Natural (Surface.w - 1)));
else
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Uint_Ptrs.To_Pointer (Surface.pixels))
+ C.ptrdiff_t (Natural (Surface.w - 1)));
end if;
end Goto_Line_End_Generic;
-- ===========================================================
-- Next_Line_Unchecked_Generic
-- ===========================================================
function Next_Line_Unchecked_Generic (
Surface : Vd.Surface_ptr;
Actual : Uint_Ptrs.Object_Pointer) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Actual)
+ C.ptrdiff_t (Surface.pitch));
end Next_Line_Unchecked_Generic;
-- ===========================================================
-- Prev_Line_Unchecked_Generic
-- ===========================================================
function Prev_Line_Unchecked_Generic (
Surface : Vd.Surface_ptr;
Actual : Uint_Ptrs.Object_Pointer) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Actual)
- C.ptrdiff_t (Surface.pitch));
end Prev_Line_Unchecked_Generic;
-- ===========================================================
-- Go_Right_Unchecked_Generic
-- ===========================================================
function Go_Right_Unchecked_Generic (
Actual : Uint_Ptrs.Object_Pointer;
Displacement : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Actual)
+ C.ptrdiff_t (Displacement));
end Go_Right_Unchecked_Generic;
-- ===========================================================
-- Go_Left_Unchecked_Generic
-- ===========================================================
function Go_Left_Unchecked_Generic (
Actual : Uint_Ptrs.Object_Pointer;
Displacement : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Actual)
- C.ptrdiff_t (Displacement));
end Go_Left_Unchecked_Generic;
-- ===========================================================
-- Go_Up_Unchecked_Generic
-- ===========================================================
function Go_Up_Unchecked_Generic (
Surface : Vd.Surface_ptr;
Actual : Uint_Ptrs.Object_Pointer;
Displacement : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Actual)
- C.ptrdiff_t (Uint16 (Displacement) * Surface.pitch));
end Go_Up_Unchecked_Generic;
-- ===========================================================
-- Go_Down_Unchecked_Generic
-- ===========================================================
function Go_Down_Unchecked_Generic (
Surface : Vd.Surface_ptr;
Actual : Uint_Ptrs.Object_Pointer;
Displacement : Natural) return Uint_Ptrs.Object_Pointer
is
use Uint_PtrOps;
begin
return Uint_Ptrs.Object_Pointer (
Uint_PtrOps.Pointer (Actual)
+ C.ptrdiff_t (Uint16 (Displacement) * Surface.pitch));
end Go_Down_Unchecked_Generic;
-- ===========================================================
-- Paint_Line_Generic
-- ===========================================================
procedure Paint_Line_Generic (
Surface : Vd.Surface_ptr;
Line_Num : Natural;
Color : C.int)
is
Line_Begin : Uint_Ptrs.Object_Pointer;
begin
Line_Begin := Goto_Line (Surface, Line_Num);
Lib_C.memset (
Uint_Ptrs.To_Address (Line_Begin),
Color,
-- Surface.w * Surface.format.BytesPerPixel);
C.size_t (Surface.pitch));
end Paint_Line_Generic;
-- ===========================================================
-- Paint_Line_Unchecked_Generic
-- ===========================================================
procedure Paint_Line_Unchecked_Generic (
Surface : Vd.Surface_ptr;
Line_Begin : Uint_Ptrs.Object_Pointer;
Color : C.int) is
begin
Lib_C.memset (
Uint_Ptrs.To_Address (Line_Begin),
Color,
-- Surface.w * Surface.format.BytesPerPixel);
C.size_t (Surface.pitch));
end Paint_Line_Unchecked_Generic;
-- ===========================================================
function MapRGB_Generic (
format : Vd.PixelFormat_ptr;
r : Uint8;
g : Uint8;
b : Uint8)
return Element_Type is
begin
return Element_Type (Vd.MapRGB (format, r, g, b));
end MapRGB_Generic;
-- ===========================================================
end SDL_Framebuffer_Generics;
syntax highlighted by Code2HTML, v. 0.9.1