Source

compiler-libs-hack / ocaml / otherlibs / labltk / compiler / tables.ml

Full commit
  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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
(***********************************************************************)
(*                                                                     *)
(*                 MLTk, Tcl/Tk interface of OCaml                     *)
(*                                                                     *)
(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
(*               projet Cristal, INRIA Rocquencourt                    *)
(*            Jacques Garrigue, Kyoto University RIMS                  *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique and Kyoto University.  All rights reserved.         *)
(*  This file is distributed under the terms of the GNU Library        *)
(*  General Public License, with the special exception on linking      *)
(*  described in file LICENSE found in the OCaml source tree.          *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

open StdLabels

(* Internal compiler errors *)

exception Compiler_Error of string
let fatal_error s = raise (Compiler_Error s)


(* Types of the description language *)
type mltype =
   Unit
 | Int
 | Float
 | Bool
 | Char
 | String
 | List of mltype
 | Product of mltype list
 | Record of (string * mltype) list
 | UserDefined of string
 | Subtype of string * string
 | Function of mltype                   (* arg type only *)
 | As of mltype * string

type template =
   StringArg of string
 | TypeArg of string * mltype
 | ListArg of template list
 | OptionalArgs of string * template list * template list

(* Sorts of components *)
type component_type =
   Constructor
 | Command
 | External

(* Full definition of a component *)
type fullcomponent = {
  component : component_type;
  ml_name : string; (* used for camltk *)
  var_name : string; (* used just for labltk *)
  template : template;
  result   : mltype;
  safe : bool
  }

let sort_components =
  List.sort ~cmp:(fun c1 c2 ->  compare c1.ml_name c2.ml_name)


(* components are given either in full or abbreviated *)
type component =
   Full of fullcomponent
 | Abbrev of string

(* A type definition *)
(*
 requires_widget_context: the converter of the type MUST be passed
   an additional argument of type Widget.
*)

type parser_arity =
  OneToken
| MultipleToken

type type_def = {
  parser_arity : parser_arity;
  mutable constructors : fullcomponent list;
  mutable subtypes : (string * fullcomponent list) list;
  mutable requires_widget_context : bool;
  mutable variant : bool
}

type module_type =
    Widget
  | Family

type module_def = {
  module_type : module_type;
  commands : fullcomponent list;
  externals : fullcomponent list
}

(******************** The tables ********************)

(* the table of all explicitly defined types *)
let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t)
(* "builtin" types *)
let types_external = ref ([] : (string * parser_arity) list)
(* dependancy order *)
let types_order = (Tsort.create () : string Tsort.porder)
(* Types of atomic values returned by Tk functions *)
let types_returned = ref ([] : string list)
(* Function table *)
let function_table = ref ([] : fullcomponent list)
(* Widget/Module table *)
let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t)


(* variant name *)
let rec getvarname ml_name temp =
  let offhypben s =
    let s = String.copy s in
    if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then
      String.sub s ~pos:1 ~len:(String.length s - 1)
    else s
  and makecapital s =
    begin
      try
        let cd = s.[0] in
          if cd >= 'a' && cd <= 'z' then
            s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a'))
      with
        _ -> ()
    end;
    s
  in
    let head =  makecapital (offhypben begin
                  match temp with
                    StringArg s -> s
                  | TypeArg (s,t) -> s
                  | ListArg (h::_) -> getvarname ml_name h
                  | OptionalArgs (s,_,_) -> s
                  | ListArg [] -> ""
                end)
    in
    let varname = if head = "" then ml_name
                  else if head.[0] >= 'A' && head.[0] <= 'Z' then head
                       else ml_name
    in varname

(***** Some utilities on the various tables *****)
(* Enter a new empty type *)
let new_type typname arity =
  Tsort.add_element types_order typname;
  let typdef = {parser_arity = arity;
                constructors = [];
                subtypes = [];
                requires_widget_context = false;
                variant = false} in
    Hashtbl.add types_table typname typdef;
    typdef


(* Assume that types not yet defined are not subtyped *)
(* Widget is builtin and implicitly subtyped *)
let is_subtyped s =
  s = "widget" ||
  try
    let typdef = Hashtbl.find types_table s in
      typdef.subtypes <> []
  with
    Not_found -> false

let requires_widget_context s =
  try
    (Hashtbl.find types_table s).requires_widget_context
  with
    Not_found -> false

let declared_type_parser_arity s =
  try
    (Hashtbl.find types_table s).parser_arity
  with
    Not_found ->
      try List.assoc s !types_external
      with
        Not_found ->
           prerr_string "Type "; prerr_string s;
           prerr_string " is undeclared external or undefined\n";
           prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n");
           OneToken

let rec type_parser_arity = function
   Unit -> OneToken
 | Int -> OneToken
 | Float -> OneToken
 | Bool -> OneToken
 | Char -> OneToken
 | String -> OneToken
 | List _ -> MultipleToken
 | Product _ -> MultipleToken
 | Record _ -> MultipleToken
 | UserDefined s -> declared_type_parser_arity s
 | Subtype (s,_) -> declared_type_parser_arity s
 | Function _ -> OneToken
 | As (ty, _) -> type_parser_arity ty

let enter_external_type s v =
  types_external := (s,v)::!types_external

(*** Stuff for topological Sort.list of types ***)
(* Make sure all types used in commands and functions are in *)
(* the table *)
let rec enter_argtype = function
    Unit | Int | Float | Bool | Char | String -> ()
  | List ty -> enter_argtype ty
  | Product tyl -> List.iter ~f:enter_argtype tyl
  | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t)
  | UserDefined s -> Tsort.add_element types_order s
  | Subtype (s,_) -> Tsort.add_element types_order s
  | Function ty -> enter_argtype ty
  | As (ty, _) -> enter_argtype ty

let rec enter_template_types = function
     StringArg _ -> ()
   | TypeArg (l,t) -> enter_argtype t
   | ListArg l -> List.iter ~f:enter_template_types l
   | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl

(* Find type dependancies on s *)
let rec add_dependancies s =
  function
    List ty -> add_dependancies s ty
  | Product tyl -> List.iter ~f:(add_dependancies s) tyl
  | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s)
  | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s)
  | Function ty -> add_dependancies s ty
  | As (ty, _) -> add_dependancies s ty
  | _ -> ()

let rec add_template_dependancies s = function
     StringArg _ -> ()
   | TypeArg (l,t) -> add_dependancies s t
   | ListArg l -> List.iter ~f:(add_template_dependancies s) l
   | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl

(* Assumes functions are not nested in products, which is reasonable due to syntax*)
let rec has_callback = function
     StringArg _ -> false
   | TypeArg (l,Function _ ) -> true
   | TypeArg _ -> false
   | ListArg l -> List.exists ~f:has_callback l
   | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl

(*** Returned types ***)
let really_add ty =
  if List.mem ty !types_returned then ()
  else types_returned := ty :: !types_returned

let rec add_return_type = function
    Unit -> ()
  | Int -> ()
  | Float -> ()
  | Bool -> ()
  | Char -> ()
  | String -> ()
  | List ty -> add_return_type ty
  | Product tyl -> List.iter ~f:add_return_type tyl
  | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t)
  | UserDefined s -> really_add s
  | Subtype (s,_) -> really_add s
  | Function _ -> fatal_error "unexpected return type (function)" (* whoah *)
  | As (ty, _) -> add_return_type ty

(*** Update tables for a component ***)
let enter_component_types {template = t; result = r} =
  add_return_type r;
  enter_argtype r;
  enter_template_types t


(******************** Types and subtypes ********************)
exception Duplicate_Definition of string * string
exception Invalid_implicit_constructor of string

(* Checking duplicate definition of constructor in subtypes *)
let rec check_duplicate_constr allowed c =
  function
    [] -> false         (* not defined *)
  | c'::rest ->
    if c.ml_name = c'.ml_name then  (* defined *)
      if allowed then
        if c.template = c'.template then true (* same arg *)
        else raise (Duplicate_Definition ("constructor",c.ml_name))
      else raise (Duplicate_Definition ("constructor", c.ml_name))
    else check_duplicate_constr allowed c rest

(* Retrieve constructor *)
let rec find_constructor cname = function
   [] -> raise (Invalid_implicit_constructor cname)
 | c::l -> if c.ml_name = cname then c
           else find_constructor cname l

(* Enter a type, must not be previously defined *)
let enter_type typname ?(variant = false) arity constructors =
  if Hashtbl.mem types_table typname then
      raise (Duplicate_Definition ("type", typname)) else
  let typdef = new_type typname arity in
  if variant then typdef.variant <- true;
  List.iter constructors ~f:
    begin fun c ->
      if not (check_duplicate_constr false c typdef.constructors)
      then begin
         typdef.constructors <- c :: typdef.constructors;
         add_template_dependancies typname c.template
      end;
      (* Callbacks require widget context *)
      typdef.requires_widget_context <-
        typdef.requires_widget_context ||
                has_callback c.template
    end

(* Enter a subtype *)
let enter_subtype typ arity subtyp constructors =
  (* Retrieve the type if already defined, else add a new one *)
  let typdef =
    try Hashtbl.find types_table typ
    with Not_found -> new_type typ arity
  in
    if List.mem_assoc subtyp typdef.subtypes
    then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
    else begin
      let real_constructors =
        List.map constructors ~f:
          begin function
            Full c ->
              if not (check_duplicate_constr true c typdef.constructors)
              then begin
                add_template_dependancies typ c.template;
                typdef.constructors <- c :: typdef.constructors
              end;
              typdef.requires_widget_context <-
                typdef.requires_widget_context ||
                has_callback c.template;
              c
          | Abbrev name -> find_constructor name typdef.constructors
          end
      in
       (* TODO: duplicate def in subtype are not checked *)
       typdef.subtypes <-
          (subtyp , List.sort real_constructors
             ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) ::
          typdef.subtypes
    end

(******************** Widgets ********************)
(* used by the parser; when enter_widget is called,
   all components are assumed to be in Full form *)
let retrieve_option optname =
  let optiontyp =
    try Hashtbl.find types_table "options"
    with
      Not_found -> raise (Invalid_implicit_constructor optname)
  in find_constructor optname optiontyp.constructors

(* Sort components by type *)
let rec add_sort l obj =
  match l with
    []  -> [obj.component ,[obj]]
  | (s',l)::rest ->
     if obj.component = s' then
       (s',obj::l)::rest
     else
       (s',l)::(add_sort rest obj)

let separate_components =  List.fold_left ~f:add_sort ~init:[]

let enter_widget name components =
  if Hashtbl.mem module_table name then
    raise (Duplicate_Definition ("widget/module", name)) else
  let sorted_components = separate_components components in
  List.iter sorted_components ~f:
    begin function
      Constructor, l ->
        enter_subtype "options" MultipleToken
          name (List.map ~f:(fun c -> Full c) l)
    | Command, l ->
        List.iter ~f:enter_component_types l
    | External, _ -> ()
    end;
  let commands =
      try List.assoc Command sorted_components
      with Not_found -> []
  and externals =
      try List.assoc External sorted_components
      with Not_found -> []
  in
  Hashtbl.add module_table name
    {module_type = Widget; commands = commands; externals = externals}

(******************** Functions ********************)

let enter_function comp =
  enter_component_types comp;
  function_table := comp :: !function_table


(******************** Modules ********************)
let enter_module name components =
  if Hashtbl.mem module_table name then
    raise (Duplicate_Definition ("widget/module", name)) else
  let sorted_components = separate_components components in
  List.iter sorted_components ~f:
    begin function
      Constructor, l -> fatal_error "unexpected Constructor"
    | Command, l -> List.iter ~f:enter_component_types l
    | External, _ -> ()
    end;
  let commands =
      try List.assoc Command sorted_components
      with Not_found -> []
  and externals =
      try List.assoc External sorted_components
      with Not_found -> []
  in
    Hashtbl.add module_table name
      {module_type = Family; commands = commands; externals = externals}