common.ml 39 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005
  1. (*
  2. * Copyright (C)2005-2013 Haxe Foundation
  3. *
  4. * Permission is hereby granted, free of charge, to any person obtaining a
  5. * copy of this software and associated documentation files (the "Software"),
  6. * to deal in the Software without restriction, including without limitation
  7. * the rights to use, copy, modify, merge, publish, distribute, sublicense,
  8. * and/or sell copies of the Software, and to permit persons to whom the
  9. * Software is furnished to do so, subject to the following conditions:
  10. *
  11. * The above copyright notice and this permission notice shall be included in
  12. * all copies or substantial portions of the Software.
  13. *
  14. * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  15. * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  16. * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  17. * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  18. * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  19. * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  20. * DEALINGS IN THE SOFTWARE.
  21. *)
  22. open Ast
  23. open Type
  24. type package_rule =
  25. | Forbidden
  26. | Directory of string
  27. | Remap of string
  28. type pos = Ast.pos
  29. type basic_types = {
  30. mutable tvoid : t;
  31. mutable tint : t;
  32. mutable tfloat : t;
  33. mutable tbool : t;
  34. mutable tnull : t -> t;
  35. mutable tstring : t;
  36. mutable tarray : t -> t;
  37. }
  38. type stats = {
  39. s_files_parsed : int ref;
  40. s_classes_built : int ref;
  41. s_methods_typed : int ref;
  42. s_macros_called : int ref;
  43. }
  44. type platform =
  45. | Cross
  46. | Flash8
  47. | Js
  48. | Neko
  49. | Flash
  50. | Php
  51. | Cpp
  52. | Cs
  53. | Java
  54. (**
  55. The capture policy tells which handling we make of captured locals
  56. (the locals which are referenced in local functions)
  57. See details/implementation in Codegen.captured_vars
  58. *)
  59. type capture_policy =
  60. (** do nothing, let the platform handle it *)
  61. | CPNone
  62. (** wrap all captured variables into a single-element array to allow modifications *)
  63. | CPWrapRef
  64. (** similar to wrap ref, but will only apply to the locals that are declared in loops *)
  65. | CPLoopVars
  66. type platform_config = {
  67. (** has a static type system, with not-nullable basic types (Int/Float/Bool) *)
  68. pf_static : bool;
  69. (** has access to the "sys" package *)
  70. pf_sys : bool;
  71. (** local variables are block-scoped *)
  72. pf_locals_scope : bool;
  73. (** captured local variables are scoped *)
  74. pf_captured_scope : bool;
  75. (** generated locals must be absolutely unique wrt the current function *)
  76. pf_unique_locals : bool;
  77. (** captured variables handling (see before) *)
  78. pf_capture_policy : capture_policy;
  79. (** when calling a method with optional args, do we replace the missing args with "null" constants *)
  80. pf_pad_nulls : bool;
  81. (** add a final return to methods not having one already - prevent some compiler warnings *)
  82. pf_add_final_return : bool;
  83. (** does the platform natively support overloaded functions *)
  84. pf_overload : bool;
  85. (** does the platform generator handle pattern matching *)
  86. pf_pattern_matching : bool;
  87. (** can the platform use default values for non-nullable arguments *)
  88. pf_can_skip_non_nullable_argument : bool;
  89. (** generator ignores TCast(_,None) *)
  90. pf_ignore_unsafe_cast : bool;
  91. }
  92. type display_mode =
  93. | DMNone
  94. | DMDefault
  95. | DMUsage
  96. | DMMetadata
  97. | DMPosition
  98. type context = {
  99. (* config *)
  100. version : int;
  101. args : string list;
  102. mutable sys_args : string list;
  103. mutable display : display_mode;
  104. mutable debug : bool;
  105. mutable verbose : bool;
  106. mutable foptimize : bool;
  107. mutable platform : platform;
  108. mutable config : platform_config;
  109. mutable std_path : string list;
  110. mutable class_path : string list;
  111. mutable main_class : Type.path option;
  112. mutable defines : (string,string) PMap.t;
  113. mutable package_rules : (string,package_rule) PMap.t;
  114. mutable error : string -> pos -> unit;
  115. mutable warning : string -> pos -> unit;
  116. mutable load_extern_type : (path -> pos -> (string * Ast.package) option) list; (* allow finding types which are not in sources *)
  117. mutable filters : (unit -> unit) list;
  118. mutable final_filters : (unit -> unit) list;
  119. mutable defines_signature : string option;
  120. mutable print : string -> unit;
  121. mutable get_macros : unit -> context option;
  122. mutable run_command : string -> int;
  123. file_lookup_cache : (string,string option) Hashtbl.t;
  124. (* output *)
  125. mutable file : string;
  126. mutable flash_version : float;
  127. mutable features : (string,bool) Hashtbl.t;
  128. mutable modules : Type.module_def list;
  129. mutable main : Type.texpr option;
  130. mutable types : Type.module_type list;
  131. mutable resources : (string,string) Hashtbl.t;
  132. mutable neko_libs : string list;
  133. mutable php_front : string option;
  134. mutable php_lib : string option;
  135. mutable php_prefix : string option;
  136. mutable swf_libs : (string * (unit -> Swf.swf) * (unit -> ((string list * string),As3hl.hl_class) Hashtbl.t)) list;
  137. mutable java_libs : (string * bool * (unit -> unit) * (unit -> (path list)) * (path -> ((JData.jclass * string * string) option))) list; (* (path,std,close,all_files,lookup) *)
  138. mutable net_libs : (string * bool * (unit -> path list) * (path -> IlData.ilclass option)) list; (* (path,std,all_files,lookup) *)
  139. mutable net_std : string list;
  140. net_path_map : (path,string list * string list * string) Hashtbl.t;
  141. mutable js_gen : (unit -> unit) option;
  142. (* typing *)
  143. mutable basic : basic_types;
  144. memory_marker : float array;
  145. }
  146. exception Abort of string * Ast.pos
  147. let display_default = ref DMNone
  148. module Define = struct
  149. type strict_defined =
  150. | AbsolutePath
  151. | AdvancedTelemetry
  152. | As3
  153. | CheckXmlProxy
  154. | CoreApi
  155. | Cppia
  156. | Dce
  157. | DceDebug
  158. | Debug
  159. | Display
  160. | DllExport
  161. | DllImport
  162. | DocGen
  163. | Dump
  164. | DumpDependencies
  165. | Fdb
  166. | FlashStrict
  167. | FlashUseStage
  168. | FormatWarning
  169. | GencommonDebug
  170. | HaxeBoot
  171. | HaxeVer
  172. | HxcppApiLevel
  173. | IncludePrefix
  174. | Interp
  175. | JavaVer
  176. | JsClassic
  177. | JsEs5
  178. | JsFlatten
  179. | Macro
  180. | MacroTimes
  181. | NekoSource
  182. | NekoV1
  183. | NetworkSandbox
  184. | NetVer
  185. | NetTarget
  186. | NoCompilation
  187. | NoCOpt
  188. | NoDeprecationWarnings
  189. | NoFlashOverride
  190. | NoDebug
  191. | NoInline
  192. | NoOpt
  193. | NoPatternMatching
  194. | NoRoot
  195. | NoSwfCompress
  196. | NoTraces
  197. | PhpPrefix
  198. | RealPosition
  199. | ReplaceFiles
  200. | Scriptable
  201. | ShallowExpose
  202. | SourceMapContent
  203. | Swc
  204. | SwfCompressLevel
  205. | SwfDebugPassword
  206. | SwfDirectBlit
  207. | SwfGpu
  208. | SwfMark
  209. | SwfMetadata
  210. | SwfPreloaderFrame
  211. | SwfProtected
  212. | SwfScriptTimeout
  213. | SwfUseDoAbc
  214. | Sys
  215. | Unsafe
  216. | UseNekoc
  217. | UseRttiDoc
  218. | Vcproj
  219. | NoMacroCache
  220. | Last (* must be last *)
  221. let infos = function
  222. | AbsolutePath -> ("absolute_path","Print absolute file path in trace output")
  223. | AdvancedTelemetry -> ("advanced-telemetry","Allow the SWF to be measured with Monocle tool")
  224. | As3 -> ("as3","Defined when outputing flash9 as3 source code")
  225. | CheckXmlProxy -> ("check_xml_proxy","Check the used fields of the xml proxy")
  226. | CoreApi -> ("core_api","Defined in the core api context")
  227. | Cppia -> ("cppia", "Generate experimental cpp instruction assembly")
  228. | Dce -> ("dce","The current DCE mode")
  229. | DceDebug -> ("dce_debug","Show DCE log")
  230. | Debug -> ("debug","Activated when compiling with -debug")
  231. | Display -> ("display","Activated during completion")
  232. | DllExport -> ("dll_export", "GenCPP experimental linking")
  233. | DllImport -> ("dll_import", "GenCPP experimental linking")
  234. | DocGen -> ("doc_gen","Do not perform any removal/change in order to correctly generate documentation")
  235. | Dump -> ("dump","Dump the complete typed AST for internal debugging")
  236. | DumpDependencies -> ("dump_dependencies","Dump the classes dependencies")
  237. | Fdb -> ("fdb","Enable full flash debug infos for FDB interactive debugging")
  238. | FlashStrict -> ("flash_strict","More strict typing for flash target")
  239. | FlashUseStage -> ("flash_use_stage","Keep the SWF library initial stage")
  240. | FormatWarning -> ("format_warning","Print a warning for each formated string, for 2.x compatibility")
  241. | GencommonDebug -> ("gencommon_debug","GenCommon internal")
  242. | HaxeBoot -> ("haxe_boot","Given the name 'haxe' to the flash boot class instead of a generated name")
  243. | HaxeVer -> ("haxe_ver","The current Haxe version value")
  244. | HxcppApiLevel -> ("hxcpp_api_level","Provided to allow compatibility between hxcpp versions")
  245. | IncludePrefix -> ("include_prefix","prepend path to generated include files")
  246. | Interp -> ("interp","The code is compiled to be run with --interp")
  247. | JavaVer -> ("java_ver", "<version:5-7> Sets the Java version to be targeted")
  248. | JsClassic -> ("js_classic","Don't use a function wrapper and strict mode in JS output")
  249. | JsEs5 -> ("js_es5","Generate JS for ES5-compliant runtimes")
  250. | JsFlatten -> ("js_flatten","Generate classes to use fewer object property lookups")
  251. | Macro -> ("macro","Defined when we compile code in the macro context")
  252. | MacroTimes -> ("macro_times","Display per-macro timing when used with --times")
  253. | NetVer -> ("net_ver", "<version:20-45> Sets the .NET version to be targeted")
  254. | NetTarget -> ("net_target", "<name> Sets the .NET target. Defaults to \"net\". xbox, micro (Micro Framework), compact (Compact Framework) are some valid values")
  255. | NekoSource -> ("neko_source","Output neko source instead of bytecode")
  256. | NekoV1 -> ("neko_v1","Keep Neko 1.x compatibility")
  257. | NetworkSandbox -> ("network-sandbox","Use local network sandbox instead of local file access one")
  258. | NoCompilation -> ("no-compilation","Disable CPP final compilation")
  259. | NoCOpt -> ("no_copt","Disable completion optimization (for debug purposes)")
  260. | NoDebug -> ("no_debug","Remove all debug macros from cpp output")
  261. | NoDeprecationWarnings -> ("no-deprecation-warnings","Do not warn if fields annotated with @:deprecated are used")
  262. | NoFlashOverride -> ("no-flash-override", "Change overrides on some basic classes into HX suffixed methods, flash only")
  263. | NoOpt -> ("no_opt","Disable optimizations")
  264. | NoPatternMatching -> ("no_pattern_matching","Disable pattern matching")
  265. | NoInline -> ("no_inline","Disable inlining")
  266. | NoRoot -> ("no_root","GenCS internal")
  267. | NoMacroCache -> ("no_macro_cache","Disable macro context caching")
  268. | NoSwfCompress -> ("no_swf_compress","Disable SWF output compression")
  269. | NoTraces -> ("no_traces","Disable all trace calls")
  270. | PhpPrefix -> ("php_prefix","Compiled with --php-prefix")
  271. | RealPosition -> ("real_position","Disables haxe source mapping when targetting C#")
  272. | ReplaceFiles -> ("replace_files","GenCommon internal")
  273. | Scriptable -> ("scriptable","GenCPP internal")
  274. | ShallowExpose -> ("shallow-expose","Expose types to surrounding scope of Haxe generated closure without writing to window object")
  275. | SourceMapContent -> ("source-map-content","Include the hx sources as part of the JS source map")
  276. | Swc -> ("swc","Output a SWC instead of a SWF")
  277. | SwfCompressLevel -> ("swf_compress_level","<level:1-9> Set the amount of compression for the SWF output")
  278. | SwfDebugPassword -> ("swf_debug_password", "Set a password for debugging.")
  279. | SwfDirectBlit -> ("swf_direct_blit", "Use hardware acceleration to blit graphics")
  280. | SwfGpu -> ("swf_gpu", "Use GPU compositing features when drawing graphics")
  281. | SwfMark -> ("swf_mark","GenSWF8 internal")
  282. | SwfMetadata -> ("swf_metadata", "=<file> Include contents of <file> as metadata in the swf.")
  283. | SwfPreloaderFrame -> ("swf_preloader_frame", "Insert empty first frame in swf")
  284. | SwfProtected -> ("swf_protected","Compile Haxe private as protected in the SWF instead of public")
  285. | SwfScriptTimeout -> ("swf_script_timeout", "Maximum ActionScript processing time before script stuck dialog box displays (in seconds)")
  286. | SwfUseDoAbc -> ("swf_use_doabc", "Use DoAbc swf-tag instead of DoAbcDefine")
  287. | Sys -> ("sys","Defined for all system platforms")
  288. | Unsafe -> ("unsafe","Allow unsafe code when targeting C#")
  289. | UseNekoc -> ("use_nekoc","Use nekoc compiler instead of internal one")
  290. | UseRttiDoc -> ("use_rtti_doc","Allows access to documentation during compilation")
  291. | Vcproj -> ("vcproj","GenCPP internal")
  292. | Last -> assert false
  293. end
  294. module MetaInfo = struct
  295. open Meta
  296. type meta_usage =
  297. | TClass
  298. | TClassField
  299. | TAbstract
  300. | TAbstractField
  301. | TEnum
  302. | TTypedef
  303. | TAnyField
  304. | TExpr
  305. type meta_parameter =
  306. | HasParam of string
  307. | Platform of platform
  308. | Platforms of platform list
  309. | UsedOn of meta_usage
  310. | UsedOnEither of meta_usage list
  311. | Internal
  312. let to_string = function
  313. | Abstract -> ":abstract",("Sets the underlying class implementation as 'abstract'",[Platforms [Java;Cs]])
  314. | Access -> ":access",("Forces private access to package, type or field",[HasParam "Target path";UsedOnEither [TClass;TClassField]])
  315. | Accessor -> ":accessor",("Used internally by DCE to mark property accessors",[UsedOn TClassField;Internal])
  316. | Allow -> ":allow",("Allows private access from package, type or field",[HasParam "Target path";UsedOnEither [TClass;TClassField]])
  317. | Annotation -> ":annotation",("Annotation (@interface) definitions on -java-lib imports will be annotated with this metadata. Has no effect on types compiled by Haxe",[Platform Java; UsedOn TClass])
  318. | ArrayAccess -> ":arrayAccess",("Allows [] access on an abstract",[UsedOnEither [TAbstract;TAbstractField]])
  319. | Ast -> ":ast",("Internally used to pass the AST source into the typed AST",[Internal])
  320. | AutoBuild -> ":autoBuild",("Extends @:build metadata to all extending and implementing classes",[HasParam "Build macro call";UsedOn TClass])
  321. | Bind -> ":bind",("Override Swf class declaration",[Platform Flash;UsedOn TClass])
  322. | Bitmap -> ":bitmap",("Embeds given bitmap data into the class (must extend flash.display.BitmapData)",[HasParam "Bitmap file path";UsedOn TClass;Platform Flash])
  323. | Build -> ":build",("Builds a class or enum from a macro",[HasParam "Build macro call";UsedOnEither [TClass;TEnum]])
  324. | BuildXml -> ":buildXml",("",[Platform Cpp])
  325. | Class -> ":class",("Used internally to annotate an enum that will be generated as a class",[Platforms [Java;Cs]; UsedOn TEnum; Internal])
  326. | ClassCode -> ":classCode",("Used to inject platform-native code into a class",[Platforms [Java;Cs]; UsedOn TClass])
  327. | Commutative -> ":commutative",("Declares an abstract operator as commutative",[UsedOn TAbstractField])
  328. | CompilerGenerated -> ":compilerGenerated",("Marks a field as generated by the compiler. Shouldn't be used by the end user",[Platforms [Java;Cs]])
  329. | CoreApi -> ":coreApi",("Identifies this class as a core api class (forces Api check)",[UsedOnEither [TClass;TEnum;TTypedef;TAbstract]])
  330. | CoreType -> ":coreType",("Identifies an abstract as core type so that it requires no implementation",[UsedOn TAbstract])
  331. | CppFileCode -> ":cppFileCode",("",[Platform Cpp])
  332. | CppNamespaceCode -> ":cppNamespaceCode",("",[Platform Cpp])
  333. | CsNative -> ":csNative",("Automatically added by -net-lib on classes generated from .NET DLL files",[Platform Cs; UsedOnEither[TClass;TEnum]; Internal])
  334. | Dce -> ":dce",("Forces dead code elimination even when not -dce full is specified",[UsedOnEither [TClass;TEnum]])
  335. | Debug -> ":debug",("Forces debug information to be generated into the Swf even without -debug",[UsedOnEither [TClass;TClassField]; Platform Flash])
  336. | Decl -> ":decl",("",[Platform Cpp])
  337. | DefParam -> ":defParam",("?",[])
  338. | Delegate -> ":delegate",("Automatically added by -net-lib on delegates",[Platform Cs; UsedOn TAbstract])
  339. | Depend -> ":depend",("",[Platform Cpp])
  340. | Deprecated -> ":deprecated",("Automatically added by -java-lib on class fields annotated with @Deprecated annotation. Has no effect on types compiled by Haxe.",[Platform Java; UsedOnEither [TClass;TEnum;TClassField]])
  341. | DynamicObject -> ":dynamicObject",("Used internally to identify the Dynamic Object implementation",[Platforms [Java;Cs]; UsedOn TClass; Internal])
  342. | Enum -> ":enum",("Used internally to annotate a class that was generated from an enum",[Platforms [Java;Cs]; UsedOn TClass; Internal])
  343. | EnumConstructorParam -> ":enumConstructorParam",("Used internally to annotate GADT type parameters",[UsedOn TClass; Internal])
  344. | Event -> ":event",("Automatically added by -net-lib on events. Has no effect on types compiled by Haxe.",[Platform Cs; UsedOn TClassField])
  345. | Exhaustive -> ":exhaustive",("",[Internal])
  346. | Expose -> ":expose",("Makes the class available on the window object",[HasParam "?Name=Class path";UsedOn TClass;Platform Js])
  347. | Extern -> ":extern",("Marks the field as extern so it is not generated",[UsedOn TClassField])
  348. | FakeEnum -> ":fakeEnum",("Treat enum as collection of values of the specified type",[HasParam "Type name";UsedOn TEnum])
  349. | File -> ":file",("Includes a given binary file into the target Swf and associates it with the class (must extend flash.utils.ByteArray)",[HasParam "File path";UsedOn TClass;Platform Flash])
  350. | Final -> ":final",("Prevents a class from being extended",[UsedOn TClass])
  351. | FlatEnum -> ":flatEnum",("Internally used to mark an enum as being flat, i.e. having no function constructors",[UsedOn TEnum; Internal])
  352. | Font -> ":font",("Embeds the given TrueType font into the class (must extend flash.text.Font)",[HasParam "TTF path";HasParam "Range String";UsedOn TClass])
  353. | Forward -> ":forward",("Forwards field access to underlying type",[HasParam "List of field names";UsedOn TAbstract])
  354. | From -> ":from",("Specifies that the field of the abstract is a cast operation from the type identified in the function",[UsedOn TAbstractField])
  355. | FunctionCode -> ":functionCode",("",[Platform Cpp])
  356. | FunctionTailCode -> ":functionTailCode",("",[Platform Cpp])
  357. | Generic -> ":generic",("Marks a class or class field as generic so each type parameter combination generates its own type/field",[UsedOnEither [TClass;TClassField]])
  358. | GenericBuild -> ":genericBuild",("Builds instances of a type using the specified macro",[UsedOn TClass])
  359. | Getter -> ":getter",("Generates a native getter function on the given field",[HasParam "Class field name";UsedOn TClassField;Platform Flash])
  360. | Hack -> ":hack",("Allows extending classes marked as @:final",[UsedOn TClass])
  361. | HaxeGeneric -> ":haxeGeneric",("Used internally to annotate non-native generic classes",[Platform Cs; UsedOnEither[TClass;TEnum]; Internal])
  362. | HeaderClassCode -> ":headerClassCode",("",[Platform Cpp])
  363. | HeaderCode -> ":headerCode",("",[Platform Cpp])
  364. | HeaderNamespaceCode -> ":headerNamespaceCode",("",[Platform Cpp])
  365. | HxGen -> ":hxGen",("Annotates that an extern class was generated by Haxe",[Platforms [Java;Cs]; UsedOnEither [TClass;TEnum]])
  366. | IfFeature -> ":ifFeature",("Causes a field to be kept by DCE if the given feature is part of the compilation",[HasParam "Feature name";UsedOn TClassField])
  367. | Impl -> ":impl",("Used internally to mark abstract implementation fields",[UsedOn TAbstractField; Internal])
  368. | Include -> ":include",("",[Platform Cpp])
  369. | InitPackage -> ":initPackage",("?",[])
  370. | Meta.Internal -> ":internal",("Generates the annotated field/class with 'internal' access",[Platforms [Java;Cs]; UsedOnEither[TClass;TEnum;TClassField]])
  371. | IsVar -> ":isVar",("Forces a physical field to be generated for properties that otherwise would not require one",[UsedOn TClassField])
  372. | JavaNative -> ":javaNative",("Automatically added by -java-lib on classes generated from JAR/class files",[Platform Java; UsedOnEither[TClass;TEnum]; Internal])
  373. | Keep -> ":keep",("Causes a field or type to be kept by DCE",[])
  374. | KeepInit -> ":keepInit",("Causes a class to be kept by DCE even if all its field are removed",[UsedOn TClass])
  375. | KeepSub -> ":keepSub",("Extends @:keep metadata to all implementing and extending classes",[UsedOn TClass])
  376. | Meta -> ":meta",("Internally used to mark a class field as being the metadata field",[])
  377. | Macro -> ":macro",("(deprecated)",[])
  378. | MaybeUsed -> ":maybeUsed",("Internally used by DCE to mark fields that might be kept",[Internal])
  379. | MergeBlock -> ":mergeBlock",("Internally used by typer to mark block that should be merged into the outer scope",[Internal])
  380. | MultiType -> ":multiType",("Specifies that an abstract chooses its this-type from its @:to functions",[UsedOn TAbstract; HasParam "Relevant type parameters"])
  381. | Native -> ":native",("Rewrites the path of a class or enum during generation",[HasParam "Output type path";UsedOnEither [TClass;TEnum]])
  382. | NativeGen -> ":nativeGen",("Annotates that a type should be treated as if it were an extern definition - platform native",[Platforms [Java;Cs]; UsedOnEither[TClass;TEnum]])
  383. | NativeGeneric -> ":nativeGeneric",("Used internally to annotate native generic classes",[Platform Cs; UsedOnEither[TClass;TEnum]; Internal])
  384. | NoCompletion -> ":noCompletion",("Prevents the compiler from suggesting completion on this field",[UsedOn TClassField])
  385. | NoDebug -> ":noDebug",("Does not generate debug information into the Swf even if -debug is set",[UsedOnEither [TClass;TClassField];Platform Flash])
  386. | NoDoc -> ":noDoc",("Prevents a type from being included in documentation generation",[])
  387. | NoImportGlobal -> ":noImportGlobal",("Prevents a static field from being imported with import Class.*",[UsedOn TAnyField])
  388. | NoPackageRestrict -> ":noPackageRestrict",("?",[])
  389. | NoStack -> ":noStack",("",[Platform Cpp])
  390. | NotNull -> ":notNull",("Declares an abstract type as not accepting null values",[UsedOn TAbstract])
  391. | NoUsing -> ":noUsing",("Prevents a field from being used with 'using'",[UsedOn TClassField])
  392. | Ns -> ":ns",("Internally used by the Swf generator to handle namespaces",[Platform Flash])
  393. | Op -> ":op",("Declares an abstract field as being an operator overload",[HasParam "The operation";UsedOn TAbstractField])
  394. | Optional -> ":optional",("Marks the field of a structure as optional",[UsedOn TClassField])
  395. | Overload -> ":overload",("Allows the field to be called with different argument types",[HasParam "Function specification (no expression)";UsedOn TClassField])
  396. | Public -> ":public",("Marks a class field as being public",[UsedOn TClassField])
  397. | PublicFields -> ":publicFields",("Forces all class fields of inheriting classes to be public",[UsedOn TClass])
  398. | PrivateAccess -> ":privateAccess",("Allow private access to anything for the annotated expression",[UsedOn TExpr])
  399. | Protected -> ":protected",("Marks a class field as being protected",[UsedOn TClassField])
  400. | Property -> ":property",("Marks a property field to be compiled as a native C# property",[UsedOn TClassField;Platform Cs])
  401. | ReadOnly -> ":readOnly",("Generates a field with the 'readonly' native keyword",[Platform Cs; UsedOn TClassField])
  402. | RealPath -> ":realPath",("Internally used on @:native types to retain original path information",[Internal])
  403. | Remove -> ":remove",("Causes an interface to be removed from all implementing classes before generation",[UsedOn TClass])
  404. | Require -> ":require",("Allows access to a field only if the specified compiler flag is set",[HasParam "Compiler flag to check";UsedOn TClassField])
  405. | RequiresAssign -> ":requiresAssign",("Used internally to mark certain abstract operator overloads",[Internal])
  406. | ReplaceReflection -> ":replaceReflection",("Used internally to specify a function that should replace its internal __hx_functionName counterpart",[Platforms [Java;Cs]; UsedOnEither[TClass;TEnum]; Internal])
  407. | Rtti -> ":rtti",("Adds runtime type informations",[UsedOn TClass])
  408. | Runtime -> ":runtime",("?",[])
  409. | RuntimeValue -> ":runtimeValue",("Marks an abstract as being a runtime value",[UsedOn TAbstract])
  410. | Setter -> ":setter",("Generates a native getter function on the given field",[HasParam "Class field name";UsedOn TClassField;Platform Flash])
  411. | SkipCtor -> ":skipCtor",("Used internally to generate a constructor as if it were a native type (no __hx_ctor)",[Platforms [Java;Cs]; Internal])
  412. | SkipReflection -> ":skipReflection",("Used internally to annotate a field that shouldn't have its reflection data generated",[Platforms [Java;Cs]; UsedOn TClassField; Internal])
  413. | Sound -> ":sound",( "Includes a given .wav or .mp3 file into the target Swf and associates it with the class (must extend flash.media.Sound)",[HasParam "File path";UsedOn TClass;Platform Flash])
  414. | Struct -> ":struct",("Marks a class definition as a struct.",[Platform Cs; UsedOn TClass])
  415. | SuppressWarnings -> ":suppressWarnings",("Adds a SuppressWarnings annotation for the generated Java class",[Platform Java; UsedOn TClass])
  416. | Throws -> ":throws",("Adds a 'throws' declaration to the generated function.",[HasParam "Type as String"; Platform Java; UsedOn TClassField])
  417. | This -> ":this",("Internally used to pass a 'this' expression to macros",[Internal; UsedOn TExpr])
  418. | To -> ":to",("Specifies that the field of the abstract is a cast operation to the type identified in the function",[UsedOn TAbstractField])
  419. | ToString -> ":toString",("Internally used",[Internal])
  420. | Transient -> ":transient",("Adds the 'transient' flag to the class field",[Platform Java; UsedOn TClassField])
  421. | ValueUsed -> ":valueUsed",("Internally used by DCE to mark an abstract value as used",[Internal])
  422. | Volatile -> ":volatile",("",[Platforms [Java;Cs]])
  423. | Unbound -> ":unbound", ("Compiler internal to denote unbounded global variable",[])
  424. | UnifyMinDynamic -> ":unifyMinDynamic",("Allows a collection of types to unify to Dynamic",[UsedOn TClassField])
  425. | Unreflective -> ":unreflective",("",[Platform Cpp])
  426. | Unsafe -> ":unsafe",("Declares a class, or a method with the C#'s 'unsafe' flag",[Platform Cs; UsedOnEither [TClass;TClassField]])
  427. | Usage -> ":usage",("?",[])
  428. | Used -> ":used",("Internally used by DCE to mark a class or field as used",[Internal])
  429. | Last -> assert false
  430. (* do not put any custom metadata after Last *)
  431. | Dollar s -> "$" ^ s,("",[])
  432. | Custom s -> s,("",[])
  433. let hmeta =
  434. let h = Hashtbl.create 0 in
  435. let rec loop i =
  436. let m = Obj.magic i in
  437. if m <> Last then begin
  438. Hashtbl.add h (fst (to_string m)) m;
  439. loop (i + 1);
  440. end;
  441. in
  442. loop 0;
  443. h
  444. let parse s = try Hashtbl.find hmeta (":" ^ s) with Not_found -> Custom (":" ^ s)
  445. let from_string s =
  446. if s = "" then Custom "" else match s.[0] with
  447. | ':' -> (try Hashtbl.find hmeta s with Not_found -> Custom s)
  448. | '$' -> Dollar (String.sub s 1 (String.length s - 1))
  449. | _ -> Custom s
  450. end
  451. let stats =
  452. {
  453. s_files_parsed = ref 0;
  454. s_classes_built = ref 0;
  455. s_methods_typed = ref 0;
  456. s_macros_called = ref 0;
  457. }
  458. let default_config =
  459. {
  460. pf_static = true;
  461. pf_sys = true;
  462. pf_locals_scope = true;
  463. pf_captured_scope = true;
  464. pf_unique_locals = false;
  465. pf_capture_policy = CPNone;
  466. pf_pad_nulls = false;
  467. pf_add_final_return = false;
  468. pf_overload = false;
  469. pf_pattern_matching = false;
  470. pf_can_skip_non_nullable_argument = true;
  471. pf_ignore_unsafe_cast = false;
  472. }
  473. let get_config com =
  474. let defined f = PMap.mem (fst (Define.infos f)) com.defines in
  475. match com.platform with
  476. | Cross ->
  477. default_config
  478. | Flash8 ->
  479. {
  480. pf_static = false;
  481. pf_sys = false;
  482. pf_locals_scope = com.flash_version > 6.;
  483. pf_captured_scope = false;
  484. pf_unique_locals = false;
  485. pf_capture_policy = CPLoopVars;
  486. pf_pad_nulls = false;
  487. pf_add_final_return = false;
  488. pf_overload = false;
  489. pf_pattern_matching = false;
  490. pf_can_skip_non_nullable_argument = true;
  491. pf_ignore_unsafe_cast = false;
  492. }
  493. | Js ->
  494. {
  495. pf_static = false;
  496. pf_sys = false;
  497. pf_locals_scope = false;
  498. pf_captured_scope = false;
  499. pf_unique_locals = false;
  500. pf_capture_policy = CPLoopVars;
  501. pf_pad_nulls = false;
  502. pf_add_final_return = false;
  503. pf_overload = false;
  504. pf_pattern_matching = false;
  505. pf_can_skip_non_nullable_argument = true;
  506. pf_ignore_unsafe_cast = true;
  507. }
  508. | Neko ->
  509. {
  510. pf_static = false;
  511. pf_sys = true;
  512. pf_locals_scope = true;
  513. pf_captured_scope = true;
  514. pf_unique_locals = false;
  515. pf_capture_policy = CPNone;
  516. pf_pad_nulls = true;
  517. pf_add_final_return = false;
  518. pf_overload = false;
  519. pf_pattern_matching = false;
  520. pf_can_skip_non_nullable_argument = true;
  521. pf_ignore_unsafe_cast = true;
  522. }
  523. | Flash when defined Define.As3 ->
  524. {
  525. pf_static = true;
  526. pf_sys = false;
  527. pf_locals_scope = false;
  528. pf_captured_scope = true;
  529. pf_unique_locals = true;
  530. pf_capture_policy = CPLoopVars;
  531. pf_pad_nulls = false;
  532. pf_add_final_return = true;
  533. pf_overload = false;
  534. pf_pattern_matching = false;
  535. pf_can_skip_non_nullable_argument = false;
  536. pf_ignore_unsafe_cast = false;
  537. }
  538. | Flash ->
  539. {
  540. pf_static = true;
  541. pf_sys = false;
  542. pf_locals_scope = true;
  543. pf_captured_scope = true; (* handled by genSwf9 *)
  544. pf_unique_locals = false;
  545. pf_capture_policy = CPLoopVars;
  546. pf_pad_nulls = false;
  547. pf_add_final_return = false;
  548. pf_overload = false;
  549. pf_pattern_matching = false;
  550. pf_can_skip_non_nullable_argument = false;
  551. pf_ignore_unsafe_cast = false;
  552. }
  553. | Php ->
  554. {
  555. pf_static = false;
  556. pf_sys = true;
  557. pf_locals_scope = false; (* some duplicate work is done in genPhp *)
  558. pf_captured_scope = false;
  559. pf_unique_locals = false;
  560. pf_capture_policy = CPNone;
  561. pf_pad_nulls = true;
  562. pf_add_final_return = false;
  563. pf_overload = false;
  564. pf_pattern_matching = false;
  565. pf_can_skip_non_nullable_argument = true;
  566. pf_ignore_unsafe_cast = false;
  567. }
  568. | Cpp ->
  569. {
  570. pf_static = true;
  571. pf_sys = true;
  572. pf_locals_scope = true;
  573. pf_captured_scope = true;
  574. pf_unique_locals = false;
  575. pf_capture_policy = CPWrapRef;
  576. pf_pad_nulls = true;
  577. pf_add_final_return = true;
  578. pf_overload = false;
  579. pf_pattern_matching = false;
  580. pf_can_skip_non_nullable_argument = true;
  581. pf_ignore_unsafe_cast = false;
  582. }
  583. | Cs ->
  584. {
  585. pf_static = true;
  586. pf_sys = true;
  587. pf_locals_scope = false;
  588. pf_captured_scope = true;
  589. pf_unique_locals = true;
  590. pf_capture_policy = CPWrapRef;
  591. pf_pad_nulls = true;
  592. pf_add_final_return = false;
  593. pf_overload = true;
  594. pf_pattern_matching = false;
  595. pf_can_skip_non_nullable_argument = true;
  596. pf_ignore_unsafe_cast = false;
  597. }
  598. | Java ->
  599. {
  600. pf_static = true;
  601. pf_sys = true;
  602. pf_locals_scope = false;
  603. pf_captured_scope = true;
  604. pf_unique_locals = false;
  605. pf_capture_policy = CPWrapRef;
  606. pf_pad_nulls = true;
  607. pf_add_final_return = false;
  608. pf_overload = true;
  609. pf_pattern_matching = false;
  610. pf_can_skip_non_nullable_argument = true;
  611. pf_ignore_unsafe_cast = false;
  612. }
  613. let memory_marker = [|Unix.time()|]
  614. let create v args =
  615. let m = Type.mk_mono() in
  616. {
  617. version = v;
  618. args = args;
  619. sys_args = args;
  620. debug = false;
  621. display = !display_default;
  622. verbose = false;
  623. foptimize = true;
  624. features = Hashtbl.create 0;
  625. platform = Cross;
  626. config = default_config;
  627. print = (fun s -> print_string s; flush stdout);
  628. run_command = Sys.command;
  629. std_path = [];
  630. class_path = [];
  631. main_class = None;
  632. defines = PMap.add "true" "1" (if !display_default <> DMNone then PMap.add "display" "1" PMap.empty else PMap.empty);
  633. package_rules = PMap.empty;
  634. file = "";
  635. types = [];
  636. filters = [];
  637. final_filters = [];
  638. modules = [];
  639. main = None;
  640. flash_version = 10.;
  641. resources = Hashtbl.create 0;
  642. php_front = None;
  643. php_lib = None;
  644. swf_libs = [];
  645. java_libs = [];
  646. net_libs = [];
  647. net_std = [];
  648. net_path_map = Hashtbl.create 0;
  649. neko_libs = [];
  650. php_prefix = None;
  651. js_gen = None;
  652. load_extern_type = [];
  653. defines_signature = None;
  654. get_macros = (fun() -> None);
  655. warning = (fun _ _ -> assert false);
  656. error = (fun _ _ -> assert false);
  657. basic = {
  658. tvoid = m;
  659. tint = m;
  660. tfloat = m;
  661. tbool = m;
  662. tnull = (fun _ -> assert false);
  663. tstring = m;
  664. tarray = (fun _ -> assert false);
  665. };
  666. file_lookup_cache = Hashtbl.create 0;
  667. memory_marker = memory_marker;
  668. }
  669. let log com str =
  670. if com.verbose then com.print (str ^ "\n")
  671. let clone com =
  672. let t = com.basic in
  673. { com with
  674. basic = { t with tvoid = t.tvoid };
  675. main_class = None;
  676. features = Hashtbl.create 0;
  677. file_lookup_cache = Hashtbl.create 0;
  678. }
  679. let file_time file =
  680. try (Unix.stat file).Unix.st_mtime with _ -> 0.
  681. let get_signature com =
  682. match com.defines_signature with
  683. | Some s -> s
  684. | None ->
  685. let str = String.concat "@" (PMap.foldi (fun k v acc ->
  686. (* don't make much difference between these special compilation flags *)
  687. match k with
  688. | "display" | "use_rtti_doc" | "macrotimes" -> acc
  689. | _ -> k :: v :: acc
  690. ) com.defines []) in
  691. let s = Digest.string str in
  692. com.defines_signature <- Some s;
  693. s
  694. let file_extension file =
  695. match List.rev (ExtString.String.nsplit file ".") with
  696. | e :: _ -> String.lowercase e
  697. | [] -> ""
  698. let platforms = [
  699. Flash8;
  700. Js;
  701. Neko;
  702. Flash;
  703. Php;
  704. Cpp;
  705. Cs;
  706. Java;
  707. ]
  708. let platform_name = function
  709. | Cross -> "cross"
  710. | Flash8 -> "flash8"
  711. | Js -> "js"
  712. | Neko -> "neko"
  713. | Flash -> "flash"
  714. | Php -> "php"
  715. | Cpp -> "cpp"
  716. | Cs -> "cs"
  717. | Java -> "java"
  718. let flash_versions = List.map (fun v ->
  719. let maj = int_of_float v in
  720. let min = int_of_float (mod_float (v *. 10.) 10.) in
  721. v, string_of_int maj ^ (if min = 0 then "" else "_" ^ string_of_int min)
  722. ) [9.;10.;10.1;10.2;10.3;11.;11.1;11.2;11.3;11.4;11.5;11.6;11.7;11.8;11.9;12.0;12.1;12.2;12.3;12.4;12.5]
  723. let flash_version_tag = function
  724. | 6. -> 6
  725. | 7. -> 7
  726. | 8. -> 8
  727. | 9. -> 9
  728. | 10. | 10.1 -> 10
  729. | 10.2 -> 11
  730. | 10.3 -> 12
  731. | 11. -> 13
  732. | 11.1 -> 14
  733. | 11.2 -> 15
  734. | 11.3 -> 16
  735. | 11.4 -> 17
  736. | 11.5 -> 18
  737. | 11.6 -> 19
  738. | 11.7 -> 20
  739. | 11.8 -> 21
  740. | 11.9 -> 22
  741. | 12.0 -> 23
  742. | 12.1 -> 24
  743. | 12.2 -> 25
  744. | 12.3 -> 26
  745. | 12.4 -> 27
  746. | 12.5 -> 28
  747. | v -> failwith ("Invalid SWF version " ^ string_of_float v)
  748. let raw_defined ctx v =
  749. PMap.mem v ctx.defines
  750. let defined ctx v =
  751. raw_defined ctx (fst (Define.infos v))
  752. let raw_defined_value ctx k =
  753. PMap.find k ctx.defines
  754. let defined_value ctx v =
  755. raw_defined_value ctx (fst (Define.infos v))
  756. let defined_value_safe ctx v =
  757. try defined_value ctx v
  758. with Not_found -> ""
  759. let raw_define ctx v =
  760. let k,v = try ExtString.String.split v "=" with _ -> v,"1" in
  761. ctx.defines <- PMap.add k v ctx.defines;
  762. let k = String.concat "_" (ExtString.String.nsplit k "-") in
  763. ctx.defines <- PMap.add k v ctx.defines;
  764. ctx.defines_signature <- None
  765. let define_value ctx k v =
  766. raw_define ctx (fst (Define.infos k) ^ "=" ^ v)
  767. let define ctx v =
  768. raw_define ctx (fst (Define.infos v))
  769. let init_platform com pf =
  770. com.platform <- pf;
  771. let name = platform_name pf in
  772. let forbid acc p = if p = name || PMap.mem p acc then acc else PMap.add p Forbidden acc in
  773. com.package_rules <- List.fold_left forbid com.package_rules (List.map platform_name platforms);
  774. com.config <- get_config com;
  775. (* if com.config.pf_static then define com "static"; *)
  776. if com.config.pf_sys then define com Define.Sys else com.package_rules <- PMap.add "sys" Forbidden com.package_rules;
  777. raw_define com name
  778. let add_feature com f =
  779. Hashtbl.replace com.features f true
  780. let has_dce com =
  781. (try defined_value com Define.Dce <> "no" with Not_found -> false)
  782. let rec has_feature com f =
  783. try
  784. Hashtbl.find com.features f
  785. with Not_found ->
  786. if com.types = [] then not (has_dce com) else
  787. match List.rev (ExtString.String.nsplit f ".") with
  788. | [] -> assert false
  789. | [cl] -> has_feature com (cl ^ ".*")
  790. | meth :: cl :: pack ->
  791. let r = (try
  792. let path = List.rev pack, cl in
  793. (match List.find (fun t -> t_path t = path && not (Ast.Meta.has Ast.Meta.RealPath (t_infos t).mt_meta)) com.types with
  794. | t when meth = "*" -> (match t with TAbstractDecl a -> Ast.Meta.has Ast.Meta.ValueUsed a.a_meta | _ ->
  795. Ast.Meta.has Ast.Meta.Used (t_infos t).mt_meta)
  796. | TClassDecl ({cl_extern = true} as c) when com.platform <> Js || cl <> "Array" && cl <> "Math" ->
  797. Meta.has Meta.Used (try PMap.find meth c.cl_statics with Not_found -> PMap.find meth c.cl_fields).cf_meta
  798. | TClassDecl c ->
  799. PMap.exists meth c.cl_statics || PMap.exists meth c.cl_fields
  800. | _ ->
  801. false)
  802. with Not_found ->
  803. false
  804. ) in
  805. let r = r || not (has_dce com) in
  806. Hashtbl.add com.features f r;
  807. r
  808. let allow_package ctx s =
  809. try
  810. if (PMap.find s ctx.package_rules) = Forbidden then ctx.package_rules <- PMap.remove s ctx.package_rules
  811. with Not_found ->
  812. ()
  813. let error msg p = raise (Abort (msg,p))
  814. let platform ctx p = ctx.platform = p
  815. let add_filter ctx f =
  816. ctx.filters <- f :: ctx.filters
  817. let add_final_filter ctx f =
  818. ctx.final_filters <- f :: ctx.final_filters
  819. let find_file ctx f =
  820. try
  821. (match Hashtbl.find ctx.file_lookup_cache f with
  822. | None -> raise Exit
  823. | Some f -> f)
  824. with Exit ->
  825. raise Not_found
  826. | Not_found ->
  827. let rec loop = function
  828. | [] -> raise Not_found
  829. | p :: l ->
  830. let file = p ^ f in
  831. if Sys.file_exists file then
  832. file
  833. else
  834. loop l
  835. in
  836. let r = (try Some (loop ctx.class_path) with Not_found -> None) in
  837. Hashtbl.add ctx.file_lookup_cache f r;
  838. (match r with
  839. | None -> raise Not_found
  840. | Some f -> f)
  841. let get_full_path f = try Extc.get_full_path f with _ -> f
  842. let unique_full_path = if Sys.os_type = "Win32" || Sys.os_type = "Cygwin" then (fun f -> String.lowercase (get_full_path f)) else get_full_path
  843. let normalize_path p =
  844. let l = String.length p in
  845. if l = 0 then
  846. "./"
  847. else match p.[l-1] with
  848. | '\\' | '/' -> p
  849. | _ -> p ^ "/"
  850. let rec mkdir_recursive base dir_list =
  851. match dir_list with
  852. | [] -> ()
  853. | dir :: remaining ->
  854. let path = match base with
  855. | "" -> dir
  856. | "/" -> "/" ^ dir
  857. | _ -> base ^ "/" ^ dir
  858. in
  859. if not ( (path = "") || ( ((String.length path) = 2) && ((String.sub path 1 1) = ":") ) ) then
  860. if not (Sys.file_exists path) then
  861. Unix.mkdir path 0o755;
  862. mkdir_recursive (if (path = "") then "/" else path) remaining
  863. let mem_size v =
  864. Objsize.size_with_headers (Objsize.objsize v [] [])
  865. (* ------------------------- TIMERS ----------------------------- *)
  866. type timer_infos = {
  867. name : string;
  868. mutable start : float list;
  869. mutable total : float;
  870. }
  871. let get_time = Extc.time
  872. let htimers = Hashtbl.create 0
  873. let new_timer name =
  874. try
  875. let t = Hashtbl.find htimers name in
  876. t.start <- get_time() :: t.start;
  877. t
  878. with Not_found ->
  879. let t = { name = name; start = [get_time()]; total = 0.; } in
  880. Hashtbl.add htimers name t;
  881. t
  882. let curtime = ref []
  883. let close t =
  884. let start = (match t.start with
  885. | [] -> assert false
  886. | s :: l -> t.start <- l; s
  887. ) in
  888. let now = get_time() in
  889. let dt = now -. start in
  890. t.total <- t.total +. dt;
  891. let rec loop() =
  892. match !curtime with
  893. | [] -> failwith ("Timer " ^ t.name ^ " closed while not active")
  894. | tt :: l -> curtime := l; if t != tt then loop()
  895. in
  896. loop();
  897. (* because of rounding errors while adding small times, we need to make sure that we don't have start > now *)
  898. List.iter (fun ct -> ct.start <- List.map (fun t -> let s = t +. dt in if s > now then now else s) ct.start) !curtime
  899. let timer name =
  900. let t = new_timer name in
  901. curtime := t :: !curtime;
  902. (function() -> close t)
  903. let rec close_times() =
  904. match !curtime with
  905. | [] -> ()
  906. | t :: _ -> close t; close_times()
  907. ;;
  908. Ast.Meta.to_string_ref := fun m -> fst (MetaInfo.to_string m)
  909. (* Taken from OCaml source typing/oprint.ml
  910. This is a better version of string_of_float which prints without loss of precision
  911. so that float_of_string (float_repres x) = x for all floats x
  912. *)
  913. let valid_float_lexeme s =
  914. let l = String.length s in
  915. let rec loop i =
  916. if i >= l then s ^ "." else
  917. match s.[i] with
  918. | '0' .. '9' | '-' -> loop (i+1)
  919. | _ -> s
  920. in loop 0
  921. let float_repres f =
  922. match classify_float f with
  923. | FP_nan -> "nan"
  924. | FP_infinite ->
  925. if f < 0.0 then "neg_infinity" else "infinity"
  926. | _ ->
  927. let float_val =
  928. let s1 = Printf.sprintf "%.12g" f in
  929. if f = float_of_string s1 then s1 else
  930. let s2 = Printf.sprintf "%.15g" f in
  931. if f = float_of_string s2 then s2 else
  932. Printf.sprintf "%.18g" f
  933. in valid_float_lexeme float_val