123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645(**************************************************************************)(* *)(* OCaml *)(* *)(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)(* *)(* Copyright 1996 Institut National de Recherche en Informatique et *)(* en Automatique. *)(* *)(* All rights reserved. This file is distributed under the terms of *)(* the GNU Lesser General Public License version 2.1, with the *)(* special exception on linking described in the file LICENSE. *)(* *)(**************************************************************************)(* Exceptions *)externalregister_named_value:string->'a->unit="caml_register_named_value"let()=(* for runtime/fail_nat.c *)register_named_value"Pervasives.array_bound_error"(Invalid_argument"index out of bounds")externalraise:exn->'a="%raise"externalraise_notrace :exn->'a="%raise_notrace"letfailwiths=raise(Failures)letinvalid_args=raise(Invalid_argument s)exceptionExitexceptionMatch_failure=Match_failureexceptionAssert_failure=Assert_failureexceptionInvalid_argument=Invalid_argumentexceptionFailure=FailureexceptionNot_found=Not_foundexceptionOut_of_memory=Out_of_memoryexceptionStack_overflow=Stack_overflowexceptionSys_error=Sys_errorexceptionEnd_of_file=End_of_fileexceptionDivision_by_zero=Division_by_zeroexceptionSys_blocked_io=Sys_blocked_ioexceptionUndefined_recursive_module=Undefined_recursive_module(* Composition operators *)external(|>):'a->('a->'b)->'b="%revapply"external(@@):('a->'b)->'a->'b="%apply"(* Debugging *)external__LOC__:string="%loc_LOC"external__FILE__ :string="%loc_FILE"external__LINE__ :int="%loc_LINE"external__MODULE__ :string="%loc_MODULE"external__POS__:string*int*int*int="%loc_POS"external __FUNCTION__ :string="%loc_FUNCTION"external__LOC_OF__ :'a->string*'a="%loc_LOC"external__LINE_OF__ :'a->int*'a="%loc_LINE"external__POS_OF__ :'a->(string*int*int*int)*'a="%loc_POS"(* Comparisons *)external(=):'a->'a->bool="%equal"external(<>):'a->'a->bool="%notequal"external(<):'a->'a->bool="%lessthan"external(>):'a->'a->bool="%greaterthan"external(<=):'a->'a->bool="%lessequal"external(>=):'a->'a->bool="%greaterequal"externalcompare:'a->'a->int="%compare"let minxy=ifx<=ythenxelseyletmaxxy=ifx>=ythenxelseyexternal(==):'a->'a->bool="%eq"external(!=):'a->'a->bool="%noteq"(* Boolean operations *)externalnot:bool->bool="%boolnot"external(&&):bool->bool->bool="%sequand"external(||):bool->bool->bool="%sequor"(* Integer operations *)external(~-):int->int="%negint"external(~+):int->int="%identity"externalsucc:int->int="%succint"external pred:int->int="%predint"external (+):int->int->int="%addint"external(-):int->int->int="%subint"external(*):int->int->int="%mulint"external(/):int->int->int="%divint"external(mod):int->int->int="%modint"let absx=ifx>=0then xelse-xexternal(land):int->int->int="%andint"external(lor):int->int->int="%orint"external(lxor):int->int->int="%xorint"let lnotx=xlxor(-1)external(lsl):int->int->int="%lslint"external(lsr):int->int->int="%lsrint"external(asr):int->int->int="%asrint"let max_int=(-1)lsr1letmin_int=max_int+1(* Floating-point operations *)external(~-.):float->float="%negfloat"external (~+.):float->float="%identity"external (+.):float->float->float="%addfloat"external (-.):float->float->float="%subfloat"external (*.):float->float->float="%mulfloat"external (/.):float->float->float="%divfloat"external (**):float->float->float="caml_power_float" "pow"[@@unboxed][@@noalloc]externalexp:float->float="caml_exp_float" "exp"[@@unboxed][@@noalloc]externalexpm1:float->float="caml_expm1_float" "caml_expm1"[@@unboxed][@@noalloc]externalacos:float->float="caml_acos_float" "acos"[@@unboxed][@@noalloc]externalasin:float->float="caml_asin_float" "asin"[@@unboxed][@@noalloc]externalatan:float->float="caml_atan_float" "atan"[@@unboxed][@@noalloc]externalatan2:float->float->float="caml_atan2_float" "atan2"[@@unboxed][@@noalloc]externalhypot:float->float->float="caml_hypot_float""caml_hypot"[@@unboxed][@@noalloc]externalcos:float->float="caml_cos_float" "cos"[@@unboxed][@@noalloc]externalcosh:float->float="caml_cosh_float" "cosh"[@@unboxed][@@noalloc]externalacosh:float->float="caml_acosh_float" "caml_acosh"[@@unboxed][@@noalloc]externallog:float->float="caml_log_float" "log"[@@unboxed][@@noalloc]externallog10:float->float="caml_log10_float" "log10"[@@unboxed][@@noalloc]externallog1p:float->float="caml_log1p_float" "caml_log1p"[@@unboxed][@@noalloc]externalsin:float->float="caml_sin_float" "sin"[@@unboxed][@@noalloc]externalsinh:float->float="caml_sinh_float" "sinh"[@@unboxed][@@noalloc]externalasinh:float->float="caml_asinh_float" "caml_asinh"[@@unboxed][@@noalloc]externalsqrt:float->float="caml_sqrt_float" "sqrt"[@@unboxed][@@noalloc]externaltan:float->float="caml_tan_float" "tan"[@@unboxed][@@noalloc]externaltanh:float->float="caml_tanh_float" "tanh"[@@unboxed][@@noalloc]externalatanh:float->float="caml_atanh_float" "caml_atanh"[@@unboxed][@@noalloc]externalceil:float->float="caml_ceil_float" "ceil"[@@unboxed][@@noalloc]externalfloor:float->float="caml_floor_float" "floor"[@@unboxed][@@noalloc]externalabs_float :float->float="%absfloat"external copysign :float->float->float="caml_copysign_float""caml_copysign"[@@unboxed][@@noalloc]externalmod_float :float->float->float="caml_fmod_float" "fmod"[@@unboxed][@@noalloc]externalfrexp:float->float*int="caml_frexp_float"externalldexp:(float[@unboxed])->(int[@untagged])->(float[@unboxed])="caml_ldexp_float""caml_ldexp_float_unboxed"[@@noalloc]externalmodf:float->float*float ="caml_modf_float"externalfloat:int->float="%floatofint"externalfloat_of_int :int->float="%floatofint"externaltruncate :float->int="%intoffloat"externalint_of_float :float->int="%intoffloat"externalfloat_of_bits :int64->float="caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"[@@unboxed][@@noalloc]letinfinity=float_of_bits0x7F_F0_00_00_00_00_00_00Lletneg_infinity=float_of_bits 0xFF_F0_00_00_00_00_00_00Lletnan=float_of_bits0x7F_F8_00_00_00_00_00_01Lletmax_float=float_of_bits0x7F_EF_FF_FF_FF_FF_FF_FFLletmin_float=float_of_bits0x00_10_00_00_00_00_00_00Lletepsilon_float=float_of_bits 0x3C_B0_00_00_00_00_00_00Ltypefpclass=FP_normal|FP_subnormal|FP_zero|FP_infinite|FP_nanexternal classify_float :(float[@unboxed])->fpclass="caml_classify_float""caml_classify_float_unboxed"[@@noalloc](* String and byte sequence operations -- more in modules String and Bytes *)externalstring_length:string->int="%string_length"externalbytes_length:bytes->int="%bytes_length"externalbytes_create:int->bytes="caml_create_bytes"externalstring_blit:string->int->bytes->int->int-> unit="caml_blit_string"[@@noalloc]externalbytes_blit:bytes->int->bytes->int->int-> unit="caml_blit_bytes"[@@noalloc]externalbytes_unsafe_to_string:bytes->string="%bytes_to_string"let(^)s1s2=letl1=string_lengths1andl2=string_lengths2inlets=bytes_create(l1+l2)instring_blits10s0l1;string_blits20sl1l2;bytes_unsafe_to_strings(* Character operations -- more in module Char *)externalint_of_char:char->int="%identity"externalunsafe_char_of_int:int->char="%identity"letchar_of_intn=ifn<0||n>255theninvalid_arg"char_of_int"elseunsafe_char_of_intn(* Unit operations *)externalignore:'a->unit="%ignore"(* Pair operations *)externalfst:'a*'b->'a="%field0"externalsnd:'a*'b->'b="%field1"(* References *)type'aref={mutablecontents:'a}externalref:'a->'aref="%makemutable"external(!):'aref->'a="%field0"external(:=):'aref->'a->unit="%setfield0"externalincr:intref->unit="%incr"externaldecr:intref->unit="%decr"(* Result type *)type('a,'b)result=Okof'a|Errorof'b(* String conversion functions *)externalformat_int:string->int->string ="caml_format_int"externalformat_float:string->float->string ="caml_format_float"letstring_of_boolb=ifbthen"true"else"false"letbool_of_string=function|"true"->true|"false"->false|_->invalid_arg"bool_of_string"letbool_of_string_opt=function|"true"->Sometrue|"false"->Somefalse|_->Noneletstring_of_intn=format_int"%d"nexternalint_of_string:string->int="caml_int_of_string"letint_of_string_opts=(* TODO: provide this directly as a non-raising primitive. *)trySome(int_of_strings)withFailure_->Noneexternalstring_get:string->int->char="%string_safe_get"letvalid_float_lexems=letl=string_lengthsinletrecloopi=ifi>=lthens^"."elsematchstring_getsiwith|'0'..'9'|'-'->loop(i+1)|_->sinloop0letstring_of_floatf=valid_float_lexem (format_float"%.12g"f)externalfloat_of_string:string->float="caml_float_of_string"letfloat_of_string_opts=(* TODO: provide this directly as a non-raising primitive. *)trySome(float_of_strings)withFailure_->None(* List operations -- more in module List *)let[@tail_mod_cons]rec(@)l1l2=matchl1with|[]->l2|h1::[]->h1::l2|h1::h2::[]->h1::h2::l2|h1::h2::h3::tl->h1::h2::h3::(tl@l2)(* I/O operations *)typein_channeltypeout_channelexternalopen_descriptor_out :int->out_channel="caml_ml_open_descriptor_out"externalopen_descriptor_in :int->in_channel="caml_ml_open_descriptor_in"letstdin=open_descriptor_in 0letstdout=open_descriptor_out1letstderr=open_descriptor_out2(* General output functions *)typeopen_flag=Open_rdonly|Open_wronly|Open_append|Open_creat|Open_trunc|Open_excl|Open_binary|Open_text|Open_nonblockexternalopen_desc :string->open_flaglist->int->int="caml_sys_open"externalset_out_channel_name:out_channel->string->unit="caml_ml_set_channel_name"letopen_out_gen modepermname=let c=open_descriptor_out(open_descnamemodeperm)inset_out_channel_namecname;cletopen_outname=open_out_gen [Open_wronly;Open_creat;Open_trunc;Open_text]0o666nameletopen_out_binname=open_out_gen[Open_wronly;Open_creat;Open_trunc;Open_binary]0o666nameexternalflush:out_channel->unit="caml_ml_flush"externalout_channels_list :unit->out_channellist="caml_ml_out_channels_list"letflush_all()=letreciter=function[]->()|a::l->begintryflushawithSys_error_->()(* ignore channels closed during a preceding flush. *)end;iterliniter(out_channels_list ())externalunsafe_output:out_channel->bytes->int->int-> unit="caml_ml_output_bytes"externalunsafe_output_string:out_channel->string->int->int-> unit="caml_ml_output"externaloutput_char:out_channel->char->unit="caml_ml_output_char"letoutput_bytesocs=unsafe_output ocs0(bytes_lengths)letoutput_stringocs=unsafe_output_string ocs0(string_lengths)letoutputocsofslen=ifofs<0||len<0||ofs>bytes_length s-lentheninvalid_arg"output"elseunsafe_outputocsofslenletoutput_substringocsofslen=ifofs<0||len<0||ofs>string_lengths-lentheninvalid_arg"output_substring"elseunsafe_output_stringocsofslenexternaloutput_byte:out_channel->int->unit="caml_ml_output_char"externaloutput_binary_int:out_channel->int->unit="caml_ml_output_int"externalmarshal_to_channel:out_channel->'a->unitlist ->unit="caml_output_value"letoutput_valuechanv=marshal_to_channelchanv[]externalseek_out:out_channel->int->unit="caml_ml_seek_out"externalpos_out:out_channel->int="caml_ml_pos_out"externalout_channel_length :out_channel->int="caml_ml_channel_size"externalclose_out_channel :out_channel->unit="caml_ml_close_channel"letclose_outoc =flushoc;close_out_channelocletclose_out_noerroc=(tryflush ocwith_->());(tryclose_out_channelocwith_->())external set_binary_mode_out:out_channel->bool->unit="caml_ml_set_binary_mode"(* General input functions *)externalset_in_channel_name:in_channel->string->unit="caml_ml_set_channel_name"letopen_in_genmodepermname=let c=open_descriptor_in(open_descnamemodeperm)inset_in_channel_namecname;cletopen_inname=open_in_gen[Open_rdonly;Open_text]0nameletopen_in_binname=open_in_gen[Open_rdonly;Open_binary]0nameexternalinput_char:in_channel->char="caml_ml_input_char"externalunsafe_input:in_channel->bytes->int->int-> int="caml_ml_input"letinputicsofslen=ifofs<0||len<0||ofs>bytes_length s-lentheninvalid_arg"input"elseunsafe_inputicsofslenletrecunsafe_really_input icsofslen=iflen<=0then()else beginletr=unsafe_inputicsofsleninifr=0thenraiseEnd_of_fileelseunsafe_really_inputics(ofs+r)(len-r)endletreally_inputicsofslen=ifofs<0||len<0||ofs>bytes_length s-lentheninvalid_arg"really_input"elseunsafe_really_inputicsofslenletreally_input_stringiclen=lets=bytes_createleninreally_inputics0len;bytes_unsafe_to_stringsexternalinput_scan_line:in_channel->int="caml_ml_input_scan_line"letinput_linechan=letrecbuild_result bufpos=function[]->buf|hd::tl->letlen=bytes_lengthhdinbytes_blithd0buf(pos-len)len;build_resultbuf(pos-len)tlinletrec scanacculen=letn=input_scan_line chaninifn=0thenbegin(* n = 0: we are at EOF *)matchaccuwith[]->raiseEnd_of_file|_->build_result(bytes_createlen)lenaccuendelse ifn>0thenbegin(* n > 0: newline found in buffer *)letres=bytes_create(n-1)inignore(unsafe_inputchanres0(n-1));ignore(input_charchan);(* skip the newline *)matchaccuwith[]->res|_->letlen=len+n-1inbuild_result(bytes_createlen)len(res::accu)end elsebegin(* n < 0: newline not found *)letbeg=bytes_create(-n)inignore(unsafe_inputchanbeg0(-n));scan(beg::accu)(len-n)endinbytes_unsafe_to_string(scan[]0)externalinput_byte:in_channel->int="caml_ml_input_char"externalinput_binary_int:in_channel->int="caml_ml_input_int"externalinput_value:in_channel->'a="caml_input_value"externalseek_in:in_channel->int->unit="caml_ml_seek_in"externalpos_in:in_channel->int="caml_ml_pos_in"externalin_channel_length :in_channel->int="caml_ml_channel_size"externalclose_in :in_channel->unit="caml_ml_close_channel"letclose_in_noerr ic=(tryclose_inicwith_->())external set_binary_mode_in:in_channel->bool->unit="caml_ml_set_binary_mode"(* Output functions on standard output *)letprint_charc=output_charstdoutcletprint_strings=output_stringstdoutsletprint_bytess=output_bytesstdoutsletprint_inti=output_stringstdout(string_of_inti)letprint_floatf=output_stringstdout(string_of_floatf)letprint_endlines=output_string stdouts;output_charstdout'\n';flushstdoutletprint_newline()=output_char stdout'\n';flushstdout(* Output functions on standard error *)letprerr_charc=output_charstderrcletprerr_strings=output_stringstderrsletprerr_bytess=output_bytesstderrsletprerr_inti=output_stringstderr(string_of_inti)letprerr_floatf=output_stringstderr(string_of_floatf)letprerr_endlines=output_string stderrs;output_charstderr'\n';flushstderrletprerr_newline()=output_char stderr'\n';flushstderr(* Input functions on standard input *)letread_line()=flushstdout;input_linestdinletread_int()=int_of_string(read_line())letread_int_opt()=int_of_string_opt(read_line())letread_float()=float_of_string(read_line())letread_float_opt()=float_of_string_opt(read_line())(* Operations on large files *)moduleLargeFile=structexternalseek_out:out_channel->int64->unit="caml_ml_seek_out_64"externalpos_out:out_channel->int64="caml_ml_pos_out_64"externalout_channel_length :out_channel->int64="caml_ml_channel_size_64"externalseek_in:in_channel->int64->unit="caml_ml_seek_in_64"externalpos_in :in_channel->int64="caml_ml_pos_in_64"externalin_channel_length :in_channel->int64="caml_ml_channel_size_64"end(* Formats *)type('a,'b,'c,'d,'e,'f)format6=('a,'b,'c,'d,'e,'f)CamlinternalFormatBasics.format6=Formatof('a,'b,'c,'d,'e,'f)CamlinternalFormatBasics.fmt*stringtype('a,'b,'c,'d)format4=('a,'b,'c,'c,'c,'d)format6type('a,'b,'c)format=('a,'b,'c,'c)format4letstring_of_format(Format(_fmt,str))=strexternalformat_of_string:('a,'b,'c,'d,'e,'f)format6->('a,'b,'c,'d,'e,'f)format6="%identity"let(^^)(Format(fmt1,str1))(Format(fmt2,str2))=Format (CamlinternalFormatBasics.concat_fmtfmt1fmt2,str1^"%,"^str2)(* Miscellaneous *)externalsys_exit:int->'a="caml_sys_exit"(* for at_exit *)type'aatomic_texternalatomic_make :'a->'aatomic_t="%makemutable"externalatomic_get :'aatomic_t->'a="%atomic_load"externalatomic_compare_and_set :'aatomic_t->'a->'a->bool="%atomic_cas"letexit_function =atomic_makeflush_allletrecat_exitf=(* MPR#7253, MPR#7796: make sure "f" is executed only once *)letf_yet_to_run=atomic_maketrueinletold_exit=atomic_getexit_functioninletnew_exit()=ifatomic_compare_and_set f_yet_to_runtruefalsethenf();old_exit()inletsuccess =atomic_compare_and_setexit_functionold_exitnew_exitinifnotsuccess thenat_exitfletdo_domain_local_at_exit=ref(fun()->())letdo_at_exit()=(!do_domain_local_at_exit)();(atomic_getexit_function)()letexitretcode=do_at_exit ();sys_exitretcodelet_=register_named_value "Pervasives.do_at_exit"do_at_exit(*MODULE_ALIASES*)moduleArg=ArgmoduleArray=ArraymoduleArrayLabels=ArrayLabelsmoduleAtomic=AtomicmoduleBigarray=BigarraymoduleBool=Boolmodule Buffer=BuffermoduleBytes=BytesmoduleBytesLabels=BytesLabelsmoduleCallback=CallbackmoduleChar =CharmoduleComplex=ComplexmoduleCondition=ConditionmoduleDigest=Digestmodule Domain=DomainmoduleDynarray=Dynarraymodule Effect=EffectmoduleEither=EithermoduleEphemeron=EphemeronmoduleFilename=FilenamemoduleFloat=FloatmoduleFormat=FormatmoduleFun=FunmoduleGc=GcmoduleHashtbl=HashtblmoduleIn_channel=In_channelmoduleInt=IntmoduleInt32 =Int32moduleInt64=Int64moduleLazy=LazymoduleLexing=LexingmoduleList=ListmoduleListLabels=ListLabelsmoduleMap=MapmoduleMarshal=MarshalmoduleMoreLabels=MoreLabelsmoduleMutex=MutexmoduleNativeint=NativeintmoduleObj=ObjmoduleOo=OomoduleOption =OptionmoduleOut_channel=Out_channelmoduleParsing=ParsingmodulePrintexc=PrintexcmodulePrintf=PrintfmoduleQueue=QueuemoduleRandom=RandommoduleResult=Resultmodule Scanf=ScanfmoduleSemaphore=SemaphoremoduleSeq=SeqmoduleSet=Setmodule Stack=StackmoduleStdLabels=StdLabelsmoduleString=StringmoduleStringLabels=StringLabelsmoduleSys=SysmoduleType=TypemoduleUchar=UcharmoduleUnit=UnitmoduleWeak =Weak