123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382(**************************************************************************)(* *)(* 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. *)(* *)(**************************************************************************)openPrintftypet=exn=..letprinters=Atomic.make[]letlocfmt=format_of_string"File \"%s\", line %d, characters %d-%d: %s"letfieldxi=letf=Obj.fieldxiinifnot(Obj.is_blockf)thensprintf"%d"(Obj.magicf:int)(* can also be a char *)elseifObj.tagf=Obj.string_tagthensprintf"%S"(Obj.magicf:string)elseifObj.tagf=Obj.double_tagthenstring_of_float(Obj.magicf:float)else"_"letrecother_fieldsxi=ifi>=Obj.sizexthen""elsesprintf", %s%s"(fieldxi)(other_fieldsx(i+1))letfieldsx=matchObj.sizexwith|0->""|1->""|2->sprintf"(%s)"(fieldx1)|_->sprintf"(%s%s)"(fieldx1)(other_fieldsx2)letuse_printersx=letrecconv=function|hd::tl->(matchhdxwith|None|exception_->convtl|Somes->Somes)|[]->Noneinconv(Atomic.getprinters)letdestruct_ext_constructorx=ifObj.tagx<>0then((Obj.magic(Obj.fieldx0):string),None)elseletconstructor=(Obj.magic(Obj.field(Obj.fieldx0)0):string)in(constructor,Some(fieldsx))letstring_of_extension_constructort=letconstructor,fields_opt=destruct_ext_constructortinmatchfields_optwith|None->constructor|Somef->constructor^fletto_string_default=function|Out_of_memory->"Out of memory"|Stack_overflow->"Stack overflow"|Match_failure(file,line,char)->sprintflocfmtfilelinechar(char+5)"Pattern matching failed"|Assert_failure(file,line,char)->sprintflocfmtfilelinechar(char+6)"Assertion failed"|Undefined_recursive_module(file,line,char)->sprintflocfmtfilelinechar(char+6)"Undefined recursive module"|x->string_of_extension_constructor(Obj.reprx)letto_stringe=matchuse_printersewith|Somes->s|None->to_string_defaulteletprintfctarg=tryfctargwithx->eprintf"Uncaught exception: %s\n"(to_stringx);flushstderr;raisexletcatchfctarg=tryfctargwithx->flushstdout;eprintf"Uncaught exception: %s\n"(to_stringx);exit2typeraw_backtrace_slottyperaw_backtrace_entry=privateinttyperaw_backtrace=raw_backtrace_entryarrayletraw_backtrace_entriesbt=btexternalget_raw_backtrace:unit->raw_backtrace="caml_get_exception_raw_backtrace"externalraise_with_backtrace:exn->raw_backtrace->'a="%raise_with_backtrace"(* Disable warning 37: values are constructed in the runtime *)type[@warning"-37"]backtrace_slot=|Known_locationof{is_raise:bool;filename:string;start_lnum:int;start_char:int;end_offset:int;(* Relative to beginning of start_lnum *)end_lnum:int;end_char:int;(* Relative to beginning of end_lnum line *)is_inline:bool;defname:string;}|Unknown_locationof{is_raise:bool}externalconvert_raw_backtrace_slot:raw_backtrace_slot->backtrace_slot="caml_convert_raw_backtrace_slot"externalconvert_raw_backtrace:raw_backtrace->backtrace_slotarray="caml_convert_raw_backtrace"letconvert_raw_backtracebt=trySome(convert_raw_backtracebt)withFailure_->Noneletformat_backtrace_slotposslot=letinfois_raise=ifis_raisethenifpos=0then"Raised at"else"Re-raised at"elseifpos=0then"Raised by primitive operation at"else"Called from"inmatchslotwith|Unknown_locationl->ifl.is_raisethen(* compiler-inserted re-raise, skipped *)NoneelseSome(sprintf"%s unknown location"(infofalse))|Known_locationl->letlines=ifl.start_lnum=l.end_lnumthenPrintf.sprintf" %d"l.start_lnumelsePrintf.sprintf"s %d-%d"l.start_lnuml.end_lnuminSome(sprintf"%s %s in file \"%s\"%s, line%s, characters %d-%d"(infol.is_raise)l.defnamel.filename(ifl.is_inlinethen" (inlined)"else"")linesl.start_charl.end_char)letprint_exception_backtraceoutchanbacktrace=matchbacktracewith|None->fprintfoutchan"(Program not linked with -g, cannot print stack backtrace)\n"|Somea->fori=0toArray.lengtha-1domatchformat_backtrace_slotia.(i)with|None->()|Somestr->fprintfoutchan"%s\n"strdoneletprint_raw_backtraceoutchanraw_backtrace=print_exception_backtraceoutchan(convert_raw_backtraceraw_backtrace)(* confusingly named: prints the global current backtrace *)letprint_backtraceoutchan=print_raw_backtraceoutchan(get_raw_backtrace())letbacktrace_to_stringbacktrace=matchbacktracewith|None->"(Program not linked with -g, cannot print stack backtrace)\n"|Somea->letb=Buffer.create1024infori=0toArray.lengtha-1domatchformat_backtrace_slotia.(i)with|None->()|Somestr->bprintfb"%s\n"strdone;Buffer.contentsbletraw_backtrace_to_stringraw_backtrace=backtrace_to_string(convert_raw_backtraceraw_backtrace)letbacktrace_slot_is_raise=function|Known_locationl->l.is_raise|Unknown_locationl->l.is_raiseletbacktrace_slot_is_inline=function|Known_locationl->l.is_inline|Unknown_location_->falsetypelocation={filename:string;line_number:int;start_char:int;end_char:int;end_line:int;end_col:int;}letbacktrace_slot_location=function|Unknown_location_->None|Known_locationl->Some{filename=l.filename;line_number=l.start_lnum;start_char=l.start_char;end_char=l.end_offset;end_line=l.end_lnum;end_col=l.end_char;}letbacktrace_slot_defname=function|Unknown_location_|Known_location{defname=""}->None|Known_locationl->Somel.defnameletbacktrace_slotsraw_backtrace=(* The documentation of this function guarantees that Some is
returned only if a part of the trace is usable. This gives us
a bit more work than just convert_raw_backtrace, but it makes the
API more user-friendly -- otherwise most users would have to
reimplement the "Program not linked with -g, sorry" logic
themselves. *)matchconvert_raw_backtraceraw_backtracewith|None->None|Somebacktrace->letusable_slot=function|Unknown_location_->false|Known_location_->trueinletrecexists_usable=function|(-1)->false|i->usable_slotbacktrace.(i)||exists_usable(i-1)inifexists_usable(Array.lengthbacktrace-1)thenSomebacktraceelseNoneletbacktrace_slots_of_raw_entryentry=backtrace_slots[|entry|]moduleSlot=structtypet=backtrace_slotletformat=format_backtrace_slotletis_raise=backtrace_slot_is_raiseletis_inline=backtrace_slot_is_inlineletlocation=backtrace_slot_locationletname=backtrace_slot_defnameendletraw_backtrace_lengthbt=Array.lengthbtexternalget_raw_backtrace_slot:raw_backtrace->int->raw_backtrace_slot="caml_raw_backtrace_slot"externalget_raw_backtrace_next_slot:raw_backtrace_slot->raw_backtrace_slotoption="caml_raw_backtrace_next_slot"(* confusingly named:
returns the *string* corresponding to the global current backtrace *)letget_backtrace()=raw_backtrace_to_string(get_raw_backtrace())externalrecord_backtrace:bool->unit="caml_record_backtrace"externalbacktrace_status:unit->bool="caml_backtrace_status"letrecregister_printerfn=letold_printers=Atomic.getprintersinletnew_printers=fn::old_printersinletsuccess=Atomic.compare_and_setprintersold_printersnew_printersinifnotsuccessthenregister_printerfnexternalget_callstack:int->raw_backtrace="caml_get_current_callstack"letexn_slotx=letx=Obj.reprxinifObj.tagx=0thenObj.fieldx0elsexletexn_slot_idx=letslot=exn_slotxin(Obj.obj(Obj.fieldslot1):int)letexn_slot_namex=letslot=exn_slotxin(Obj.obj(Obj.fieldslot0):string)externalget_debug_info_status:unit->int="caml_ml_debug_info_status"(* Descriptions for errors in startup.h. See also backtrace.c *)leterrors=[|"";(* FILE_NOT_FOUND *)"(Cannot print locations:\n \
bytecode executable program file not found)";(* BAD_BYTECODE *)"(Cannot print locations:\n \
bytecode executable program file appears to be corrupt)";(* WRONG_MAGIC *)"(Cannot print locations:\n \
bytecode executable program file has wrong magic number)";(* NO_FDS *)"(Cannot print locations:\n \
bytecode executable program file cannot be opened;\n \
-- too many open files. Try running with OCAMLRUNPARAM=b=2)"|]letdefault_uncaught_exception_handlerexnraw_backtrace=eprintf"Fatal error: exception %s\n"(to_stringexn);print_raw_backtracestderrraw_backtrace;letstatus=get_debug_info_status()inifstatus<0thenprerr_endlineerrors.(absstatus);flushstderrletuncaught_exception_handler=refdefault_uncaught_exception_handlerletset_uncaught_exception_handlerfn=uncaught_exception_handler:=fnletempty_backtrace:raw_backtrace=[||]lettry_get_raw_backtrace()=tryget_raw_backtrace()with_(* Out_of_memory? *)->empty_backtracelethandle_uncaught_exception'exndebugger_in_use=try(* Get the backtrace now, in case one of the [at_exit] function
destroys it. *)letraw_backtrace=ifdebugger_in_use(* Same test as in [runtime/printexc.c] *)thenempty_backtraceelsetry_get_raw_backtrace()in(tryStdlib.do_at_exit()with_->());try!uncaught_exception_handlerexnraw_backtracewithexn'->letraw_backtrace'=try_get_raw_backtrace()ineprintf"Fatal error: exception %s\n"(to_stringexn);print_raw_backtracestderrraw_backtrace;eprintf"Fatal error in uncaught exception handler: exception %s\n"(to_stringexn');print_raw_backtracestderrraw_backtrace';flushstderrwith|Out_of_memory->prerr_endline"Fatal error: out of memory in uncaught exception handler"(* This function is called by [caml_fatal_uncaught_exception] in
[runtime/printexc.c] which expects no exception is raised. *)lethandle_uncaught_exceptionexndebugger_in_use=tryhandle_uncaught_exception'exndebugger_in_usewith_->(* There is not much we can do at this point *)()externalregister_named_value:string->'a->unit="caml_register_named_value"let()=register_named_value"Printexc.handle_uncaught_exception"handle_uncaught_exception