Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file funcall.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163open!Core_kernelopen!Importtype_t=|Cons:'aValue.Type.t*'bt->('a->'b)t|Nullary:'bValue.Type.t->(unit->'b)t|Return:'aValue.Type.t->'atletreturntype_=Returntype_letnullary=Value.Type.create[%sexp"funcall-nullary-placeholder-value"][%sexp_of:unit]ignore(constValue.nil);;letnil=Value.Type.ignoredlet(@->)(typeab)(type_:aValue.Type.t)(t:bt)=matchtwith|Cons_->(matchType_equal.Id.same(Value.Type.idtype_)(Value.Type.idnullary)with|true->raise_s[%message"Function already has arguments, cannot be nullary."]|false->Cons(type_,t))|Nullary_->raise_s[%message"Cannot add arguments to nullary function."]|Returnreturn_type->(matchType_equal.Id.same_witness(Value.Type.idtype_)(Value.Type.idnullary)with|SomeType_equal.T->Nullaryreturn_type|None->Cons(type_,t));;letreturn_type_of_valuesymbol(type_:'aValue.Type.t)value=matchValue.Type.of_value_exntype_valuewith|x->x|exceptionexn->raise_s[%message"funcall failed to convert return value."(symbol:Value.t)(type_:_Value.Type.t)(exn:Exn.t)];;letarityt=letrecarity:typea.at->int->int=funti->matchtwith|Return_->i|Nullary_->i|Cons(_,t)->arityt(i+1)inarityt0;;letwrap:typea.at->Value.t->a=funtsymbol->letreccurry:typea.at->Value.t->Value.tarray->int->a=funtsymbolargsi->matchtwith|Cons(type_,t)->funarg->args.(i)<-Value.Type.to_valuetype_arg;currytsymbolargs(i+1)|Nullaryreturn_type->assert(Int.(=)i0);fun_->Value.funcall0symbol|>return_type_of_valuesymbolreturn_type|Returntype_->Value.funcallN_arraysymbolargs|>return_type_of_valuesymboltype_inletargs=Array.create~len:(arityt)Value.nilincurrytsymbolargs0;;(* It's unclear how much this sort of unrolling matters, but the C bindings do it, so we
might as well do it here. *)letwrap_unrolled:typea.at->Value.t->a=funtsymbol->letrettype_value=return_type_of_valuesymboltype_valueinmatchtwith|Returntype_->Value.funcall0symbol|>rettype_|Nullaryreturn_type->fun_->Value.funcall0symbol|>retreturn_type|Cons(type1,Returntype_)->funa1->Value.funcall1symbol(a1|>Value.Type.to_valuetype1)|>rettype_|Cons(type1,Cons(type2,Returntype_))->funa1a2->Value.funcall2symbol(a1|>Value.Type.to_valuetype1)(a2|>Value.Type.to_valuetype2)|>rettype_|Cons(type1,Cons(type2,Cons(type3,Returntype_)))->funa1a2a3->Value.funcall3symbol(a1|>Value.Type.to_valuetype1)(a2|>Value.Type.to_valuetype2)(a3|>Value.Type.to_valuetype3)|>rettype_|Cons(type1,Cons(type2,Cons(type3,Cons(type4,Returntype_))))->funa1a2a3a4->Value.funcall4symbol(a1|>Value.Type.to_valuetype1)(a2|>Value.Type.to_valuetype2)(a3|>Value.Type.to_valuetype3)(a4|>Value.Type.to_valuetype4)|>rettype_|Cons(type1,Cons(type2,Cons(type3,Cons(type4,Cons(type5,Returntype_)))))->funa1a2a3a4a5->Value.funcall5symbol(a1|>Value.Type.to_valuetype1)(a2|>Value.Type.to_valuetype2)(a3|>Value.Type.to_valuetype3)(a4|>Value.Type.to_valuetype4)(a5|>Value.Type.to_valuetype5)|>rettype_|t->wraptsymbol;;let(<:)elisp_function=letv=elisp_function|>Value.interninfunt->wrap_unrolledtv;;letapplytfargs~on_parse_error=letwrong_number_of_argsmessage=raise_s[%messagemessage(arityt:int)(args:Value.tlist)]inletrecapply:typea.at->a->Value.tlist->Value.t=funtfargs->matchtwith|Cons(type_,t)->(matchargswith|arg::args->(matchValue.Type.of_value_exntype_argwith|arg->applyt(farg)args|exceptionexn->on_parse_errorexn)|[]->(* Emacs convention: missing arguments are nil. *)(matchValue.Type.of_value_exntype_Value.nilwith|arg->applyt(farg)args|exceptionexn->on_parse_errorexn))|Returntype_->(matchargswith|[]->Value.Type.to_valuetype_f|_::_->wrong_number_of_args"Extra args.")|Nullarytype_->(matchargswith|[]->Value.Type.to_valuetype_(f())|_::_->wrong_number_of_args"Extra args.")inapplytfargs;;include(Value.Type:Value.Type.S)modulePrivate=structletapply=applyletwrap_unrolled=wrap_unrolledend