------------------------------------------------------------------------------
-- P A R A S A I L --
-- --
-- Copyright (C) 2012-2014, AdaCore --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 distributed with this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
-- --
-- The ParaSail language and implementation were originally developed by --
-- S. Tucker Taft. --
------------------------------------------------------------------------------
with PSC.Interpreter.Builtins; use PSC.Interpreter.Builtins;
with PSC.Interpreter.Param_Signatures; use PSC.Interpreter.Param_Signatures;
with PSC.Interpreter.GTK;
with PSC.Strings;
with Ada.Text_IO;
with Interfaces.C; use Interfaces.C;
--with GTK_C_Interface;
--with Cairo_C_Interface;
with System.Storage_Elements;
with Ada.Unchecked_Conversion;
pragma Elaborate (PSC.Interpreter.Builtins);
pragma Elaborate (PSC.Interpreter.Param_Signatures);
pragma Elaborate (PSC.Strings);
pragma Elaborate (Ada.Text_IO);
package body PSC.Interpreter.Cairo is
-- Package providing support for builtin ParaSail Cairo-related operations
use GTK_C_Interface;
use Cairo_C_Interface;
function To_Widget is new Ada.Unchecked_Conversion (gpointer, GTKWidget);
function To_gpointer is new Ada.Unchecked_Conversion (GTKWidget, gpointer);
function To_GTKWidget is new Ada.Unchecked_Conversion
(System.Storage_Elements.Integer_Address, GTKWidget);
function From_GTKWidget is new Ada.Unchecked_Conversion
(GTKWidget, System.Storage_Elements.Integer_Address);
function To_CairoContext is new Ada.Unchecked_Conversion
(Word_Type, Cairo_C_Interface.CairoContext);
function From_CairoContext is new Ada.Unchecked_Conversion
(Cairo_C_Interface.CairoContext, Word_Type);
-- func Create(var GTK::Widget+) -> Context
-- is import(#cairo_context_create)
function Cairo_Context_Create (Poly_Widget : Word_Type) return Word_Type is
-- NOTE: Polymorphic types are not passed by reference
Drawable_Widget : constant GTK_C_Interface.GtkWidget :=
Interpreter.GTK.Poly_To_GtkWidget (Poly_Widget);
Drawable_Window : constant GTK_C_Interface.GdkWindow :=
GTK_C_Interface.gtk_widget_get_window (Drawable_Widget);
begin
return From_CairoContext
(Cairo_C_Interface.gdk_cairo_create (Drawable_Window));
end Cairo_Context_Create;
package Cairo_Context_Create_Op is new Unary_Builtin
(Name => "#cairo_context_create",
Operand => Word_Param,
Result => Word_Param,
Op => Cairo_Context_Create,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Arc(var Context; XC, YC, Radius, Angle1, Angle2 : Float)
-- is import(#cairo_arc)//*
procedure Arc
(Context : Word_Ptr; XC, YC, Radius, Angle1, Angle2 : Univ_Real) is
begin
Cairo_C_Interface.cairo_arc
(To_CairoContext (Fetch_Word (Context, 0)), double (XC), double (YC),
double (Radius), double (Angle1), double (Angle2));
end Arc;
package Arc_Op is new Six_Input_Builtin
(Name => "#cairo_arc",
First => Word_Ptr_Param, Second => Real_Param,
Third => Real_Param, Fourth => Real_Param,
Fifth => Real_Param, Sixth => Real_Param,
Op => Arc,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Arc_Negative(var Context; XC, YC, Radius, Angle1, Angle2 : Float)
-- is import(#cairo_arc_negative)//*
procedure Arc_Negative
(Context : Word_Ptr; XC, YC, Radius, Angle1, Angle2 : Univ_Real) is
begin
Cairo_C_Interface.cairo_arc_negative
(To_CairoContext (Fetch_Word (Context, 0)), double (XC), double (YC),
double (Radius), double (Angle1), double (Angle2));
end Arc_Negative;
package Arc_Negative_Op is new Six_Input_Builtin
(Name => "#cairo_arc_negative",
First => Word_Ptr_Param, Second => Real_Param,
Third => Real_Param, Fourth => Real_Param,
Fifth => Real_Param, Sixth => Real_Param,
Op => Arc_Negative,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Close_Path(var Context)
-- is import(#cairo_close_path)//*
procedure Close_Path (Context : Word_Ptr) is
begin
cairo_close_path (To_CairoContext (Fetch_Word (Context, 0)));
end Close_Path;
package Close_Path_Op is new One_Input_Builtin
(Name => "#cairo_close_path",
Operand => Word_Ptr_Param,
Op => Close_Path,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Fill(var Context)
-- is import(#cairo_fill)//*
procedure Fill (Context : Word_Ptr) is
begin
cairo_Fill (To_CairoContext (Fetch_Word (Context, 0)));
end Fill;
package Fill_Op is new One_Input_Builtin
(Name => "#cairo_fill",
Operand => Word_Ptr_Param,
Op => Fill,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Fill_Preserve(var Context)
-- is import(#cairo_fill_preserve)//*
procedure Fill_Preserve (Context : Word_Ptr) is
begin
cairo_fill_preserve (To_CairoContext (Fetch_Word (Context, 0)));
end Fill_Preserve;
package Fill_Preserve_Op is new One_Input_Builtin
(Name => "#cairo_fill_preserve",
Operand => Word_Ptr_Param,
Op => Fill_Preserve,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Line_To(var Context; X, Y : Float)
-- is import(#cairo_line_to)//#
procedure Line_To (Context : Word_Ptr; X, Y : Univ_Real) is
begin
cairo_line_to
(To_CairoContext (Fetch_Word (Context, 0)), double (X), double (Y));
end Line_To;
package Line_To_Op is new Three_Input_Builtin
(Name => "#cairo_line_to",
First => Word_Ptr_Param,
Second => Real_Param,
Third => Real_Param,
Op => Line_To,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Move_To(var Context; X, Y : Float)
-- is import(#cairo_move_to)//#
procedure Move_To (Context : Word_Ptr; X, Y : Univ_Real) is
begin
cairo_move_to
(To_CairoContext (Fetch_Word (Context, 0)), double (X), double (Y));
end Move_To;
package Move_To_Op is new Three_Input_Builtin
(Name => "#cairo_move_to",
First => Word_Ptr_Param,
Second => Real_Param,
Third => Real_Param,
Op => Move_To,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Rectangle(var Context; X, Y, Width, Height : Float)
-- is import(#cairo_rectangle)//*
procedure Rectangle (Context : Word_Ptr; X, Y, Width, Height : Univ_Real)
is
begin
cairo_rectangle (To_CairoContext (Fetch_Word (Context, 0)),
double (X), double (Y), double (Width), double (Height));
end Rectangle;
package Rectangle_Op is new Five_Input_Builtin
(Name => "#cairo_rectangle",
First => Word_Ptr_Param, Second => Real_Param,
Third => Real_Param, Fourth => Real_Param,
Fifth => Real_Param,
Op => Rectangle,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Set_Dash(var Context; Basic_Array<Float>)
-- is import(#cairo_set_dash)
procedure Set_Dash (Context : Word_Ptr; Dashes : Word_Type;
Offset : Univ_Real) is
begin
cairo_set_dash (To_CairoContext (Fetch_Word (Context, 0)),
Dashes => Virtual_To_Physical_Address
(Dashes + (Large_Obj_Header_Size + 1)).all'Address,
Num_Dashes => int (Fetch_Word (Dashes + Large_Obj_Header_Size)),
Offset => gdouble (Offset));
end Set_Dash;
package Set_Dash_Op is new Three_Input_Builtin
(Name => "#cairo_set_dash",
First => Word_Ptr_Param, Second => Word_Param, Third => Real_Param,
Op => Set_Dash,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Set_Source_RGB(var Context; Red, Green, Blue : Float)
-- is import(#cairo_set_source_rgb)//*
procedure Set_Source_RGB (Context : Word_Ptr; Red, Green, Blue : Univ_Real)
is
begin
cairo_set_source_rgb (To_CairoContext (Fetch_Word (Context, 0)),
double (Red), double (Green), double (Blue));
end Set_Source_RGB;
package Set_Source_RGB_Op is new Four_Input_Builtin
(Name => "#cairo_set_source_rgb",
First => Word_Ptr_Param, Second => Real_Param,
Third => Real_Param, Fourth => Real_Param,
Op => Set_Source_RGB,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Set_Source_RGB_Alpha(var Context; Red, Green, Blue, Alpha : Float)
-- is import(#cairo_set_source_rgb_alpha)//*
procedure Set_Source_RGB_Alpha
(Context : Word_Ptr; Red, Green, Blue, Alpha : Univ_Real) is
begin
cairo_set_source_rgba (To_CairoContext (Fetch_Word (Context, 0)),
double (Red), double (Green), double (Blue), double (Alpha));
end Set_Source_RGB_Alpha;
package Set_Source_RGB_Alpha_Op is new Five_Input_Builtin
(Name => "#cairo_set_source_rgb_alpha",
First => Word_Ptr_Param, Second => Real_Param,
Third => Real_Param, Fourth => Real_Param,
Fifth => Real_Param,
Op => Set_Source_RGB_Alpha,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Stroke(var Context)
-- is import(#cairo_stroke)//#
procedure Stroke (Context : Word_Ptr) is
begin
cairo_stroke (To_CairoContext (Fetch_Word (Context, 0)));
end Stroke;
package Stroke_Op is new One_Input_Builtin
(Name => "#cairo_stroke",
Operand => Word_Ptr_Param,
Op => Stroke,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Stroke_Preserve(var Context)
-- is import(#cairo_stroke_preserve)//*
procedure Stroke_Preserve (Context : Word_Ptr) is
begin
cairo_stroke_preserve (To_CairoContext (Fetch_Word (Context, 0)));
end Stroke_Preserve;
package Stroke_Preserve_Op is new One_Input_Builtin
(Name => "#cairo_stroke_preserve",
Operand => Word_Ptr_Param,
Op => Stroke_Preserve,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
function To_PangoLayout is new Ada.Unchecked_Conversion
(Word_Type, Cairo_C_Interface.PangoLayout);
function PangoLayout_To_Word is new Ada.Unchecked_Conversion
(Cairo_C_Interface.PangoLayout, Word_Type);
function Pango_Layout_New (Context : Word_Ptr) return Word_Type is
-- func New(var Context) -> Layout
CCtxt : constant CairoContext :=
To_CairoContext (Fetch_Word (Context, 0));
begin
return PangoLayout_To_Word
(Cairo_C_Interface.pango_cairo_create_layout (CCtxt));
end Pango_Layout_New;
package Pango_Layout_New_Op is new Unary_Builtin
(Name => "#pango_layout_new",
Operand => Word_Ptr_Param,
Result => Word_Param,
Op => Pango_Layout_New,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
-- func Show_Layout(var Context; Pango::Layout)
-- is import(#cairo_show_layout)//#
procedure Show_Layout (Context : Word_Ptr; Layout : Word_Type) is
begin
pango_cairo_show_layout (To_CairoContext (Fetch_Word (Context, 0)),
To_PangoLayout (Layout));
end Show_Layout;
package Show_Layout_Op is new Two_Input_Builtin
(Name => "#cairo_show_layout",
First => Word_Ptr_Param, Second => Word_Param,
Op => Show_Layout,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
procedure Pango_Layout_Set_Text (Layout : Word_Ptr; Text : Word_Type) is
-- func Set_Text(var Layout; Univ_String)
begin
pango_layout_set_text (To_PangoLayout (Fetch_Word (Layout, 0)),
Word_To_String (Text));
end Pango_Layout_Set_Text;
package Pango_Layout_Set_Text_Op is new Two_Input_Builtin
(Name => "#pango_layout_set_text",
First => Word_Ptr_Param,
Second => Word_Param,
Op => Pango_Layout_Set_Text,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
function Pango_Layout_Get_Pixel_Height (Layout : Word_Type)
return Word_Type is
-- func Get_Pixel_Height(Layout) -> Univ_Integer
Pixel_Height : aliased int;
begin
pango_layout_get_pixel_size (To_PangoLayout (Layout),
width => null,
height => Pixel_Height'Unchecked_Access);
return Word_Type (Pixel_Height);
end Pango_Layout_Get_Pixel_Height;
package Pango_Layout_Get_Pixel_Height_Op is new Unary_Builtin
(Name => "#pango_layout_get_pixel_height",
Operand => Word_Param,
Result => Word_Param,
Op => Pango_Layout_Get_Pixel_Height,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
function Pango_Layout_Get_Pixel_Width (Layout : Word_Type)
return Word_Type is
-- func Get_Pixel_Width(Layout) -> Univ_Integer
Pixel_Width : aliased int;
begin
pango_layout_get_pixel_size (To_PangoLayout (Layout),
width => Pixel_Width'Unchecked_Access,
height => null);
return Word_Type (Pixel_Width);
end Pango_Layout_Get_Pixel_Width;
package Pango_Layout_Get_Pixel_Width_Op is new Unary_Builtin
(Name => "#pango_layout_get_pixel_width",
Operand => Word_Param,
Result => Word_Param,
Op => Pango_Layout_Get_Pixel_Width,
Invoke_Before_Call => gdk_threads_enter,
Invoke_After_Call => gdk_threads_leave);
end PSC.Interpreter.Cairo;