diff options
Diffstat (limited to 'otherlibs/labltk/compiler/printer.ml')
| -rw-r--r-- | otherlibs/labltk/compiler/printer.ml | 173 |
1 files changed, 0 insertions, 173 deletions
diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml deleted file mode 100644 index 60362d17fb..0000000000 --- a/otherlibs/labltk/compiler/printer.ml +++ /dev/null @@ -1,173 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* 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 Objective Caml source tree. *) -(* *) -(***********************************************************************) - -open Tables;; - -open Format;; - -let escape_string s = - let more = ref 0 in - for i = 0 to String.length s - 1 do - match s.[i] with - | '\\' | '"' -> incr more - | _ -> () - done; - if !more = 0 then s else - let res = String.create (String.length s + !more) in - let j = ref 0 in - for i = 0 to String.length s - 1 do - let c = s.[i] in - match c with - | '\\' | '"' -> res.[!j] <- '\\'; incr j; res.[!j] <- c; incr j - | _ -> res.[!j] <- c; incr j - done; - res;; - -let escape_char c = if c = '\'' then "\\'" else String.make 1 c;; - -let print_quoted_string s = printf "\"%s\"" (escape_string s);; -let print_quoted_char c = printf "'%s'" (escape_char c);; -let print_quoted_int i = - if i < 0 then printf "(%d)" i else printf "%d" i;; -let print_quoted_float f = - if f <= 0.0 then printf "(%f)" f else printf "%f" f;; - -(* Iterators *) -let print_list f l = - printf "@[<1>["; - let rec pl = function - | [] -> printf "@;<0 -1>]@]" - | [x] -> f x; pl [] - | x :: xs -> f x; printf ";@ "; pl xs in - pl l;; - -let print_array f v = - printf "@[<2>[|"; - let l = Array.length v in - if l >= 1 then f v.(0); - if l >= 2 then - for i = 1 to l - 1 do - printf ";@ "; f v.(i) - done; - printf "@;<0 -1>|]@]";; - -let print_option f = function - | None -> print_string "None" - | Some x -> printf "@[<1>Some@ "; f x; printf "@]";; - -let print_bool = function - | true -> print_string "true" | _ -> print_string "false";; - -let print_poly x = print_string "<poly>";; - -(* Types of the description language *) -let rec print_mltype = function - | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float" - | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String" - | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]" - | Product l_m -> - printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]" - | Record l_t_s_m -> - printf "@[<1>(%s@ " "Record"; - print_list - (function (s, m) -> - printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m; - printf ")@]") - l_t_s_m; - printf ")@]" - | UserDefined s -> - printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]" - | Subtype (s, s0) -> - printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s; - printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]" - | Function m -> - printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]" - | As (m, s) -> - printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ "; - print_quoted_string s; printf ")@]"; printf ")@]";; - -let rec print_template = function - | StringArg s -> - printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]" - | TypeArg (s, m) -> - printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s; - printf ",@ "; print_mltype m; printf ")@]"; printf ")@]" - | ListArg l_t -> - printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t; - printf ")@]" - | OptionalArgs (s, l_t, l_t0) -> - printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>("; - print_quoted_string s; printf ",@ "; print_list print_template l_t; - printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]";; - -(* Sorts of components *) -let rec print_component_type = function - | Constructor -> printf "Constructor" | Command -> printf "Command" - | External -> printf "External";; - -(* Full definition of a component *) -let rec print_fullcomponent = function - {component = c; ml_name = s; var_name = s0; template = t; result = m; - safe = b; - } -> - printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c; - printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s; - printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0; - printf ";@]@ "; printf "@[<1>template =@ "; print_template t; - printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ "; - printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]";; - -(* components are given either in full or abbreviated *) -let rec print_component = function - | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]" - | Abbrev s -> - printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]";; - -(* A type definition *) -(* - requires_widget_context: the converter of the type MUST be passed - an additional argument of type Widget. -*) -let rec print_parser_arity = function - | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken";; - -let rec print_type_def = function - {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f; - requires_widget_context = b; variant = b0; - } -> - printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p; - printf ";@]@ "; printf "@[<1>constructors =@ "; - print_list print_fullcomponent l_f; printf ";@]@ "; - printf "@[<1>subtypes =@ "; - print_list - (function (s, l_f0) -> - printf "@[<1>("; print_quoted_string s; printf ",@ "; - print_list print_fullcomponent l_f0; printf ")@]") - l_t_s_l_f; - printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b; - printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ "; - printf "@,}@]";; - -let rec print_module_type = function - | Widget -> printf "Widget" | Family -> printf "Family";; - -let rec print_module_def = function - {module_type = m; commands = l_f; externals = l_f0; } -> - printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m; - printf ";@]@ "; printf "@[<1>commands =@ "; - print_list print_fullcomponent l_f; printf ";@]@ "; - printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0; - printf ";@]@ "; printf "@,}@]";; |