Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/Semant/types/cproto.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Semant/types/cproto.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1173, Sat Mar 23 04:18:51 2002 UTC revision 1174, Sat Mar 23 21:14:40 2002 UTC
# Line 28  Line 28 
28   * [long long]          = Int32.int list   * [long long]          = Int32.int list
29   * [unsigned long long] = Word32.word list   * [unsigned long long] = Word32.word list
30   * [T*]                 = string   * [T*]                 = string
31     * ml object            = bool
32   * [struct {}]          = exn   * [struct {}]          = exn
33   * [struct{t1,...tn}]   = unit * [t1] * ... * [tn]   * [struct{t1,...tn}]   = unit * [t1] * ... * [tn]
34   * [void]               = unit   * [void]               = unit
# Line 54  Line 55 
55   *)   *)
56  structure CProto : sig  structure CProto : sig
57      exception BadEncoding      exception BadEncoding
58      (* decode the encoding described above *)      (* Decode the encoding described above.
59      val decode : string -> Types.ty -> CTypes.c_proto       * Construct an indicator list for the _actual_ ML arguments of
60         * a raw C call and the result type of a raw C call.
61      (* Construct an indicator list for the _actual_ ML arguments of       * Each indicator specifies whether the arguments/result is
62       * a raw C call; the element is true if the corresponding argument       * a float pointer value, an 32-bit integer, or an ML pointer.
63       * is a floating-point argument. *)       *)
64      val flt_args : Types.ty -> bool list      val decode : string ->
65                     { encoding : Types.ty,
66      (* Figure out whether the result of a raw C call is floating-point. *)                     arg_ty   : Types.ty,
67      val flt_res : Types.ty -> bool option                     res_ty   : Types.ty
68                     }  ->
69                     { c_proto   : CTypes.c_proto,
70                       arg_types : PrimOp.ccall_type list,
71                       res_type  : PrimOp.ccall_type option
72                     }
73    
74      (* formatting of C type info (for debugging purposes) *)      (* formatting of C type info (for debugging purposes) *)
75      val tshow : CTypes.c_type -> string      val tshow : CTypes.c_type -> string
# Line 84  Line 90 
90              if BT.isArrowType t then get t else NONE              if BT.isArrowType t then get t else NONE
91          end          end
92          fun bad () = raise BadEncoding          fun bad () = raise BadEncoding
93            fun listTy t = T.CONty (BT.listTycon, [t])
94      in      in
95          fun decode conv t = let          fun decode conv {encoding=t,arg_ty,res_ty} = let
96              (* The type-mapping table: *)              (* The type-mapping table: *)
             fun listTy t = T.CONty (BT.listTycon, [t])  
97              val m = [(BT.intTy,           CT.C_signed   CT.I_int),              val m = [(BT.intTy,           CT.C_signed   CT.I_int),
98                       (BT.wordTy,          CT.C_unsigned CT.I_int),                       (BT.wordTy,          CT.C_unsigned CT.I_int),
99                       (BT.stringTy,        CT.C_PTR),                       (BT.stringTy,        CT.C_PTR),
100                         (BT.boolTy,          CT.C_PTR),
101                       (BT.realTy,          CT.C_double),                       (BT.realTy,          CT.C_double),
102                       (listTy BT.realTy,   CT.C_float),                       (listTy BT.realTy,   CT.C_float),
103                       (BT.charTy,          CT.C_signed   CT.I_char),                       (BT.charTy,          CT.C_signed   CT.I_char),
# Line 114  Line 121 
121                  else (t0, i)                  else (t0, i)
122                | unlist (t, i) = (t, i)                | unlist (t, i) = (t, i)
123    
124                fun isMLTy t = TU.equalType (t, BT.boolTy)
125    
126              (* Given [T] (see above), produce the CTypes.c_type value              (* Given [T] (see above), produce the CTypes.c_type value
127               * corresponding to T. *)               * corresponding to T. *)
128              fun dt t =              fun dt t =
129                  case look t of                  case look t of
130                      SOME ct => ct                      SOME ct => (ct, isMLTy t)
131                    | NONE =>                    | NONE =>
132                      (case BT.getFields t of                      (case BT.getFields t of
133                           SOME (_ :: fl) => CT.C_STRUCT (map dt fl)                        SOME (_ :: fl) => (CT.C_STRUCT (map (#1 o dt) fl), false)
134                         | _ => bad ())                      | _ => bad ()
135                        )
136    
137              val (fty, _) = unlist (t, 0)              val (fty, _) = unlist (t, 0)
138    
139                fun getTy(t, true) = PrimOp.CCALL_ML_PTR
140                  | getTy(t, false) =
141                    if TU.equalType (t, BT.realTy) then PrimOp.CCALL_REAL64
142                    else PrimOp.CCALL_INT32
143    
144                fun res_type(t, ml) =
145                    if TU.equalType (t, BT.unitTy) then NONE
146                    else SOME (getTy(t, ml))
147    
148                fun getTys(t::tys, ml::mls) = getTy(t,ml) :: getTys(tys,mls)
149                  | getTys(tys, []) = map (fn t => getTy(t,false)) tys
150                  | getTys _ = []
151    
152                fun arg_types(t, ml) =
153                    if TU.equalType (t, BT.unitTy) then [] (* no arg case *)
154                    else case BT.getFields t of
155                             SOME fl => getTys (fl,ml) (* >1 arg case *)
156                           | NONE => getTys([t], ml)   (* 1 arg case *)
157          in          in
158              (* Get argument types and result type; decode them.              (* Get argument types and result type; decode them.
159               * Construct the corresponding CTypes.c_proto value. *)               * Construct the corresponding CTypes.c_proto value. *)
160              case getDomainRange fty of              case getDomainRange fty of
161                  NONE => bad ()                  NONE => bad ()
162                | SOME (d, r) =>                | SOME (d, r) =>
163                  { conv = conv,                  let val (retTy, retML) = dt r
164                    retTy = dt r,                      val (argTys, argsML) =
165                    paramTys = if TU.equalType (d, BT.unitTy) then []                          if TU.equalType (d, BT.unitTy) then ([], [])
166                               else case BT.getFields d of                               else case BT.getFields d of
167                                        SOME (_ :: fl) => map dt fl                                 SOME (_ :: fl) =>
168                                      | _ => bad () }                                 let val args = map dt fl
169                                   in  (map #1 args, map #2 args)
170                                   end
171                                 | _ => bad ()
172                    in  {c_proto={ conv = conv,
173                                   retTy = retTy,
174                                   paramTys = argTys
175                                 },
176                         arg_types=arg_types(arg_ty, argsML),
177                         res_type =res_type(res_ty, retML)
178                        }
179          end          end
   
         local  
             fun isFlt t = TU.equalType (t, BT.realTy)  
         in  
             fun flt_res t =  
                 if TU.equalType (t, BT.unitTy) then NONE  
                 else SOME (isFlt t)  
             fun flt_args t =  
                 if TU.equalType (t, BT.unitTy) then [] (* no arg case *)  
                 else case BT.getFields t of  
                          SOME fl => map isFlt fl       (* >1 arg case *)  
                        | NONE => [isFlt t]             (* 1 arg case *)  
180          end          end
181    
182          local          local

Legend:
Removed from v.1173  
changed lines
  Added in v.1174

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0