with system, unchecked_conversion; package body Adobe_Font_Metrics is procedure free (a : system.address); pragma interface (C, free); procedure parse_afm_file (fd : in POSIX_IO.File_Descriptor; read_option_mask : in Read_Options; font_info : out FontInfo) is P_G : constant := 16#01#; -- Global Font Info P_W : constant := 16#02#; -- Character Widths ONLY P_M : constant := 16#06#; -- All Char Metric Info P_P : constant := 16#08#; -- Pair Kerning Info P_T : constant := 16#10#; -- Track Kerning Info P_C : constant := 16#20#; -- Composite Char Info local_mask : integer; read_only_mode : constant string := "r" & ascii.nul; function fdopen (fildes : POSIX_IO.File_Descriptor; mode : system.address) return system.address; pragma interface (C, fdopen); -- FILE *fdopen(int fildes, char *type); type concrete_FontInfo is record gfi : GlobalFontInfo_Ptrs; -- ptr to a GlobalFontInfo record cwi : character_width_vector_ptrs; -- ptr to 256 element array of just char widths numOfChars : integer; -- number of entries in char metrics array cmi : system.address; -- ptr to char metrics array numOfTracks : integer; -- number to entries in track kerning array tkd : system.address; -- ptr to track kerning array numOfPairs : integer; -- number to entries in pair kerning array pkd : system.address; -- ptr to pair kerning array numOfComps : integer; -- number to entries in comp char array ccd : system.address; -- ptr to comp char array end record; type concrete_FontInfo_ptrs is access concrete_FontInfo; local_font_info : concrete_fontinfo_ptrs; function FontInfo_ptrs_To_Address is new unchecked_conversion (concrete_FontInfo_ptrs, system.address); type return_codes is new integer range -3 .. 0; return_code : return_codes; function parseFile (fp : system.address; -- FILE* fi : system.address; -- FontInfo **fi; flags : integer) return return_codes; pragma interface (C, parseFile, "parseFile"); -- extern int parseFile (FILE *fp; FontInfo **fi; FLAGS flags); -- This procedure expects 3 parameters: a vaild file descriptor, a pointer -- to a (FontInfo *) variable (for which space will be allocated and then -- will be filled in with the data requested), and a mask specifying -- which data from the AFM File should be saved in the FontInfo structure. procedure set_font_info (from : in concrete_fontinfo_ptrs; to : out fontinfo) is type Single_CharMetricInfo_Ptrs is access CharMetricInfo; type Single_PairKernData_Ptrs is access PairKernData; type Single_TrackKernData_Ptrs is access TrackKernData; type Single_CompCharData_Ptrs is access CompCharData; char_metric : Single_CharMetricInfo_Ptrs; pair_kern : Single_PairKernData_Ptrs; track_kern : Single_TrackKernData_Ptrs; comp_char : Single_CompCharData_Ptrs; temp_cmi : CharMetricInfo_Ptrs; temp_pkd : PairKernData_Ptrs; temp_tkd : TrackKernData_Ptrs; temp_ccd : CompCharData_Ptrs; function address_to_char_metric is new unchecked_conversion (system.address, Single_CharMetricInfo_Ptrs); function address_to_pair_kern is new unchecked_conversion (system.address, Single_PairKernData_Ptrs); function address_to_track_kern is new unchecked_conversion (system.address, Single_TrackKernData_Ptrs); function address_to_comp_char is new unchecked_conversion (system.address, Single_CompCharData_Ptrs); use system; -- make "+" directly visible for type address begin -- set_font_info to.gfi := from.gfi; to.cwi := from.cwi; to.numOfChars := from.numOfChars; to.numOfTracks := from.numOfTracks; to.numOfPairs := from.numOfPairs; to.numOfComps := from.numOfComps; if from.cmi /= system.address (0) then temp_cmi := new CharMetricInfo_arrays (1 .. from.numOfChars); for j in 1 .. from.numOfChars loop char_metric := address_to_char_metric (from.cmi + (system.address (j) - 1) * (CharMetricInfo'size / system.storage_unit)); temp_cmi (j) := char_metric.all; end loop; to.cmi := temp_cmi; free (from.cmi); end if; if from.pkd /= system.address (0) then temp_pkd := new PairKernData_arrays (1 .. from.numOfPairs); for j in 1 .. from.numOfPairs loop pair_kern := address_to_pair_kern (from.pkd + (system.address (j) - 1) * (PairKernData'size / system.storage_unit)); temp_pkd (j) := pair_kern.all; end loop; to.pkd := temp_pkd; free (from.pkd); end if; if from.tkd /= system.address (0) then temp_tkd := new TrackKernData_arrays (1 .. from.numOfTracks); for j in 1 .. from.numOfTracks loop track_kern := address_to_track_kern (from.tkd + (system.address (j) - 1) * (TrackKernData'size / system.storage_unit)); temp_tkd (j) := track_kern.all; end loop; to.tkd := temp_tkd; free (from.tkd); end if; if from.ccd /= system.address (0) then temp_ccd := new CompCharData_arrays (1 .. from.numOfComps); for j in 1 .. from.numOfComps loop comp_char := address_to_comp_char (from.ccd + (system.address (j) - 1) * (CompCharData'size / system.storage_unit)); temp_ccd (j) := comp_char.all; end loop; to.ccd := temp_ccd; free (from.ccd); end if; end set_font_info; begin -- parse_afm_file if read_option_mask (All_Char_Metric_Info) and read_option_mask (Character_Widths_Only) then raise read_option_error; end if; if read_option_mask (Composite_Char_Info) then raise not_yet_implemented; end if; -- setup local mask local_mask := 0; for i in read_option_mask'range loop if read_option_mask (i) then case i is when Global_Font_Info => local_mask := local_mask + P_G; when Character_Widths_Only => local_mask := local_mask + P_W; when All_Char_Metric_Info => local_mask := local_mask + P_M; when Pair_Kerning_Info => local_mask := local_mask + P_P; when Track_Kerning_Info => local_mask := local_mask + P_T; when Composite_Char_Info => local_mask := local_mask + P_C; end case; end if; end loop; return_code := parseFile (fdopen (fd, read_only_mode (1)'address), local_font_info'address, local_mask); case return_code is when 0 => set_font_info (from => local_font_info, to => font_info); free (FontInfo_ptrs_To_Address (local_font_info)); when -1 => raise parse_error; when -2 => raise early_eof; when -3 => raise storage_error; end case; end parse_afm_file; function to_string (str : C_Strings) return string is len : positive; begin -- to_string if str /= null then len := str'first; while len <= str'last and then str (len) /= ascii.nul loop len := len + 1; end loop; return str (1 .. len - 1); else return ""; end if; end to_string; procedure free (str : in out C_Strings) is function C_Strings_To_Address is new unchecked_conversion (C_Strings, system.address); begin -- free free (C_Strings_To_Address (str)); str := null; end free; end Adobe_Font_Metrics;