← Back to branch summary

~ubuntu-branches/ubuntu/oneiric/haxe/oneiric

« back to all changes in this revision

Viewing changes to haxe/typecore.ml

  • Committer: Bazaar Package Importer
  • Author(s): Jens Peter Secher
  • Date: 2009-03-18 23:09:50 UTC
  • mfrom: (3.1.1 experimental)
  • Revision ID: james.westby@ubuntu.com-20090318230950-pgfuxg2ucolps74t
Tags: 1:2.2-2
http://bugs.debian.org/519630
http://bugs.debian.org/519627
* Use ocamlfind to locate and use the libraries xml-light and extlib
  which already exist in Debian as separate packages.
  (Closes: #519630)
* Fixed compile error with camlp4 3.11, thanks to Stéphane Glondu.
  (Closes: #519627)
* Use quilt instead of dpatch for patches, and describe how to use
  quilt in Debian.source (thanks to Russ Allbery).
* Added a Vcs-Hg control filed to indicate the location of the public
  repository.
* Bumped Standards-Version to 3.8.1.

Show diffs side-by-side

added added

removed removed

Lines of Context:
haxe/typecore.ml
 
1
(*
 
2
 *  Haxe Compiler
 
3
 *  Copyright (c)2005-2008 Nicolas Cannasse
 
4
 *
 
5
 *  This program is free software; you can redistribute it and/or modify
 
6
 *  it under the terms of the GNU General Public License as published by
 
7
 *  the Free Software Foundation; either version 2 of the License, or
 
8
 *  (at your option) any later version.
 
9
 *
 
10
 *  This program is distributed in the hope that it will be useful,
 
11
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
 *  GNU General Public License for more details.
 
14
 *
 
15
 *  You should have received a copy of the GNU General Public License
 
16
 *  along with this program; if not, write to the Free Software
 
17
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
18
 *)
 
19
open Common
 
20
open Type
 
21
 
 
22
type typer = {
 
23
        (* shared *)
 
24
        com : context;
 
25
        mutable api : context_type_api;
 
26
        types_module : (path, path) Hashtbl.t;
 
27
        modules : (path , module_def) Hashtbl.t;
 
28
        delays : (unit -> unit) list list ref;
 
29
        constructs : (path , Ast.access list * Ast.type_param list * Ast.func) Hashtbl.t;
 
30
        doinline : bool;
 
31
        mutable std : module_def;
 
32
        mutable untyped : bool;
 
33
        mutable super_call : bool;
 
34
        (* per-module *)
 
35
        current : module_def;
 
36
        mutable local_types : module_type list;
 
37
        (* per-class *)
 
38
        mutable curclass : tclass;
 
39
        mutable tthis : t;
 
40
        mutable type_params : (string * t) list;
 
41
        (* per-function *)
 
42
        mutable curmethod : string;
 
43
        mutable in_constructor : bool;
 
44
        mutable in_static : bool;
 
45
        mutable in_loop : bool;
 
46
        mutable in_display : bool;
 
47
        mutable ret : t;
 
48
        mutable locals : (string, t) PMap.t;
 
49
        mutable locals_map : (string, string) PMap.t;
 
50
        mutable locals_map_inv : (string, string) PMap.t;
 
51
        mutable opened : anon_status ref list;
 
52
        mutable param_type : t option;
 
53
}
 
54
 
 
55
type error_msg =
 
56
        | Module_not_found of path
 
57
        | Unify of unify_error list
 
58
        | Custom of string
 
59
        | Protect of error_msg
 
60
        | Unknown_ident of string
 
61
        | Invalid_enum_matching
 
62
        | Stack of error_msg * error_msg
 
63
 
 
64
exception Error of error_msg * pos
 
65
 
 
66
let type_expr_ref : (typer -> Ast.expr -> bool -> texpr) ref = ref (fun _ _ _ -> assert false)
 
67
let build_inheritance : (typer -> Type.tclass -> Ast.pos -> Ast.class_flag -> bool) ref = ref (fun _ _ _ _ -> true)
 
68
 
 
69
let unify_error_msg ctx = function
 
70
        | Cannot_unify (t1,t2) ->
 
71
                s_type ctx t1 ^ " should be " ^ s_type ctx t2
 
72
        | Invalid_field_type s ->
 
73
                "Invalid type for field " ^ s ^ " :"
 
74
        | Has_no_field (t,n) ->
 
75
                s_type ctx t ^ " has no field " ^ n
 
76
        | Has_extra_field (t,n) ->
 
77
                s_type ctx t ^ " has extra field " ^ n
 
78
        | Invalid_access (f,get,a,b) ->
 
79
                "Inconsistent " ^ (if get then "getter" else "setter") ^ " for field " ^ f ^ " : " ^ s_access a ^ " should be " ^ s_access b
 
80
        | Invalid_visibility n ->
 
81
                "The field " ^ n ^ " is not public"
 
82
        | Not_matching_optional n ->
 
83
                "Optional attribute of parameter " ^ n ^ " differs"
 
84
        | Cant_force_optional ->
 
85
                "Optional parameters can't be forced"
 
86
 
 
87
let rec error_msg = function
 
88
        | Module_not_found m -> "Class not found : " ^ Ast.s_type_path m
 
89
        | Unify l ->
 
90
                let ctx = print_context() in
 
91
                String.concat "\n" (List.map (unify_error_msg ctx) l)
 
92
        | Unknown_ident s -> "Unknown identifier : " ^ s
 
93
        | Invalid_enum_matching -> "Invalid enum matching case"
 
94
        | Custom s -> s
 
95
        | Stack (m1,m2) -> error_msg m1 ^ "\n" ^ error_msg m2
 
96
        | Protect m -> error_msg m
 
97
 
 
98
let display_error ctx msg p = ctx.com.error msg p
 
99
 
 
100
let error msg p = raise (Error (Custom msg,p))
 
101
 
 
102
let type_expr ctx e need_val = (!type_expr_ref) ctx e need_val
 
103
 
 
104
let unify ctx t1 t2 p =
 
105
        try
 
106
                Type.unify t1 t2
 
107
        with
 
108
                Unify_error l ->
 
109
                        if not ctx.untyped then display_error ctx (error_msg (Unify l)) p
 
110
 
 
111
let unify_raise ctx t1 t2 p =
 
112
        try
 
113
                Type.unify t1 t2
 
114
        with
 
115
                Unify_error l ->
 
116
                        (* no untyped check *)
 
117
                        raise (Error (Unify l,p))
 
118
 
 
119
let save_locals ctx =
 
120
        let locals = ctx.locals in
 
121
        let map = ctx.locals_map in
 
122
        let inv = ctx.locals_map_inv in
 
123
        (fun() ->
 
124
                ctx.locals <- locals;
 
125
                ctx.locals_map <- map;
 
126
                ctx.locals_map_inv <- inv;
 
127
        )
 
128
 
 
129
let add_local ctx v t =
 
130
        let rec loop n =
 
131
                let nv = (if n = 0 then v else v ^ string_of_int n) in
 
132
                if PMap.mem nv ctx.locals || PMap.mem nv ctx.locals_map_inv then
 
133
                        loop (n+1)
 
134
                else begin
 
135
                        ctx.locals <- PMap.add v t ctx.locals;
 
136
                        if n <> 0 then begin
 
137
                                ctx.locals_map <- PMap.add v nv ctx.locals_map;
 
138
                                ctx.locals_map_inv <- PMap.add nv v ctx.locals_map_inv;
 
139
                        end;
 
140
                        nv
 
141
                end
 
142
        in
 
143
        loop 0
 
144
 
 
145
let gen_local ctx t =
 
146
        let rec loop n =
 
147
                let nv = (if n = 0 then "_g" else "_g" ^ string_of_int n) in
 
148
                if PMap.mem nv ctx.locals || PMap.mem nv ctx.locals_map_inv then
 
149
                        loop (n+1)
 
150
                else
 
151
                        nv
 
152
        in
 
153
        add_local ctx (loop 0) t
 
154
 
 
155
let rec is_nullable = function
 
156
        | TMono r ->
 
157
                (match !r with None -> true | Some t -> is_nullable t)
 
158
        | TType ({ t_path = ([],"Null") },[_]) ->
 
159
                false
 
160
        | TLazy f ->
 
161
                is_nullable (!f())
 
162
        | TType (t,tl) ->
 
163
                is_nullable (apply_params t.t_types tl t.t_type)
 
164
        | TFun _ ->
 
165
                true
 
166
        | TInst ({ cl_path = (["haxe"],"Int32") },[])
 
167
        | TInst ({ cl_path = ([],"Int") },[])
 
168
        | TInst ({ cl_path = ([],"Float") },[])
 
169
        | TEnum ({ e_path = ([],"Bool") },[]) -> true
 
170
        | _ ->
 
171
                false
 
172
 
 
173
let rec is_null = function
 
174
        | TMono r ->
 
175
                (match !r with None -> false | Some t -> is_null t)
 
176
        | TType ({ t_path = ([],"Null") },[t]) ->
 
177
                is_nullable t
 
178
        | TLazy f ->
 
179
                is_null (!f())
 
180
        | TType (t,tl) ->
 
181
                is_null (apply_params t.t_types tl t.t_type)
 
182
        | _ ->
 
183
                false
 
184
 
 
185
let not_opened = ref Closed
 
186
let mk_anon fl = TAnon { a_fields = fl; a_status = not_opened; }
 
187
 
 
188
let mk_field name t = {
 
189
        cf_name = name;
 
190
        cf_type = t;
 
191
        cf_doc = None;
 
192
        cf_public = true;
 
193
        cf_get = NormalAccess;
 
194
        cf_set = NormalAccess;
 
195
        cf_expr = None;
 
196
        cf_params = [];
 
197
}