File: struct.ml

package info (click to toggle)
camlidl 1.12-1
  • links: PTS, VCS
  • area: main
  • in suites: sid, trixie
  • size: 1,592 kB
  • sloc: ml: 5,238; ansic: 945; cpp: 908; makefile: 358; xml: 213; sh: 74
file content (131 lines) | stat: -rw-r--r-- 4,863 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
(***********************************************************************)
(*                                                                     *)
(*                              CamlIDL                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1999 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the GNU Lesser General Public License LGPL v2.1 *)
(*                                                                     *)
(***********************************************************************)

(* $Id: struct.ml,v 1.15 2004-07-08 09:55:09 xleroy Exp $ *)

(* Handling of structures *)

open Printf
open Utils
open Variables
open Idltypes
open Cvttyp

(* Remove dependent fields (fields that are size_is, length_is,
   or switch_is of another field).  Also remove ignored pointers. *)

let is_dependent_field name fields =
  List.exists (fun f -> Lexpr.is_dependent name f.field_typ) fields

let remove_dependent_fields fields =
  list_filter
    (fun f ->
       not (is_dependent_field f.field_name fields || is_ignored f.field_typ))
    fields

(* Determine if all fields of a struct are floats *)

let rec is_float_field f =
  match scrape_type f.field_typ with
    Type_float -> true
  | Type_double -> true
  | _ -> false

let all_float_fields fl =
  List.for_all is_float_field fl

(* Translation from an ML record [v] to a C struct [c] *)
(* [sd] is the IDL declaration for the record type. *)

let struct_ml_to_c ml_to_c oc onstack pref sd v c =
  let pref' = Prefix.enter_struct pref sd c in
  match remove_dependent_fields sd.sd_fields with
    [f] ->
      ml_to_c oc onstack pref' f.field_typ
                 v (sprintf "%s.%s" c f.field_name);
      List.iter
        (fun f ->
          if is_ignored f.field_typ then
            iprintf oc "%s.%s = NULL;\n" c f.field_name)
        sd.sd_fields
  | _ ->
      if all_float_fields sd.sd_fields then begin
        let rec convert_fields pos = function
          [] -> ()
        | f :: rem ->
            iprintf oc "%s.%s = Double_field(%s, %d);\n" c f.field_name v pos;
            convert_fields (pos + 1) rem in
        convert_fields 0 sd.sd_fields
      end else begin
        let rec convert_fields pos = function
          [] -> ()
        | {field_typ = ty; field_name = n} :: rem ->
            if is_ignored ty then begin
              iprintf oc "%s.%s = NULL;\n" c n;
              convert_fields pos rem
            end else if is_dependent_field n sd.sd_fields then
              convert_fields pos rem
            else begin
              let v' = new_ml_variable() in
              iprintf oc "%s = Field(%s, %d);\n" v' v pos;
              ml_to_c oc onstack pref' ty v' (sprintf "%s.%s" c n);
              convert_fields (pos + 1) rem
            end in
        convert_fields 0 sd.sd_fields
      end

(* Translation from a C pointer struct [c] to an ML record [v].
   [sd] is the IDL declaration for the record type. *)

let struct_c_to_ml c_to_ml oc pref sd c v =
  let pref' = Prefix.enter_struct pref sd c in
  match remove_dependent_fields sd.sd_fields with
    [f] ->
      c_to_ml oc pref' f.field_typ
                 (sprintf "%s.%s" c f.field_name) v
  | fields ->
      let nfields = List.length fields in
      if all_float_fields sd.sd_fields then begin
        iprintf oc
           "%s = camlidl_alloc_small(%d * Double_wosize, Double_tag);\n"
           v nfields;
        let rec convert_fields pos = function
          [] -> ()
        | f :: rem ->
            iprintf oc "Store_double_field(%s, %d, %s.%s);\n" 
                    v pos c f.field_name;
            convert_fields (pos + 1) rem in
        convert_fields 0 sd.sd_fields
      end else begin
        let v' = new_ml_variable_block nfields in
        init_value_block oc v' nfields;
        iprintf oc "Begin_roots_block(%s, %d)\n" v' nfields;
        increase_indent();
        let rec convert_fields pos = function
          [] -> ()
        | {field_typ = ty; field_name = n} :: rem ->
            if is_ignored ty then
              convert_fields pos rem
            else if is_dependent_field n sd.sd_fields then
              convert_fields pos rem
            else begin
              c_to_ml oc pref' ty
                         (sprintf "%s.%s" c n) (sprintf "%s[%d]" v' pos);
              convert_fields (pos + 1) rem
            end in
        convert_fields 0 sd.sd_fields;
        iprintf oc "%s = camlidl_alloc_small(%d, 0);\n" v nfields;
        copy_values_to_block oc v' v nfields;
        decrease_indent();
        iprintf oc "End_roots()\n"
      end