diff --git a/src/boot/errors.r b/src/boot/errors.r index 04b3b82878..2a1b269ea7 100644 --- a/src/boot/errors.r +++ b/src/boot/errors.r @@ -152,6 +152,9 @@ Script: [ phase-expect-arg: [:arg1 {internal phase expects} :arg2 {for its} :arg3 {argument}] + no-logic-typecheck: [:arg1 {must return LOGIC? to use in typechecking}] + no-arg-typecheck: [:arg1 {must take an argument to use in typechecking}] + invalid-type: [:arg1 {type is not allowed here}] invalid-op: [{invalid operator:} :arg1] no-op-arg: [:arg1 {operator is missing an argument}] diff --git a/src/core/c-error.c b/src/core/c-error.c index cb6261d577..09d513632f 100644 --- a/src/core/c-error.c +++ b/src/core/c-error.c @@ -1174,6 +1174,35 @@ Context(*) Error_Phase_Arg_Type( } +// +// Error_No_Logic_Typecheck: C +// +Context(*) Error_No_Logic_Typecheck(option(Symbol(const*)) label) +{ + DECLARE_LOCAL (name); + if (label) + Init_Word(name, unwrap(label)); + else + Init_Nulled(name); + + return Error_No_Logic_Typecheck_Raw(name); +} + + +// +// Error_No_Arg_Typecheck: C +// +Context(*) Error_No_Arg_Typecheck(option(Symbol(const*)) label) +{ + DECLARE_LOCAL (name); + if (label) + Init_Word(name, unwrap(label)); + else + Init_Nulled(name); + + return Error_No_Arg_Typecheck_Raw(name); +} + // // Error_Bad_Argless_Refine: C // diff --git a/src/core/evaluator/c-eval.c b/src/core/evaluator/c-eval.c index d7f86ed449..98f2d1e1c3 100644 --- a/src/core/evaluator/c-eval.c +++ b/src/core/evaluator/c-eval.c @@ -354,6 +354,22 @@ Bounce Evaluator_Executor(Frame(*) f) f_current_gotten = nullptr; // !!! allow/require to be passe in? goto evaluate; } + intrinsic_in_scratch_arg_in_spare: + case ST_EVALUATOR_CALCULATING_INTRINSIC_ARG : { + Action(*) action = VAL_ACTION(SCRATCH); + Intrinsic* intrinsic = Extract_Intrinsic(action); + REBPAR* param = ACT_PARAM(action, 2); + + if (VAL_PARAM_CLASS(param) == PARAM_CLASS_META) + Meta_Quotify(SPARE); + if (not Typecheck_Coerce_Argument(param, SPARE)) { + option(Symbol(const*)) label = VAL_ACTION_LABEL(SCRATCH); + const REBKEY* key = ACT_KEY(action, 2); + fail (Error_Arg_Type(label, key, param, SPARE)); + } + (*intrinsic)(OUT, SPARE); + goto finished; } + case REB_GROUP : case REB_GET_GROUP : case REB_META_GROUP : @@ -719,6 +735,28 @@ Bounce Evaluator_Executor(Frame(*) f) else enfixed = Get_Action_Flag(action, ENFIXED); + if ( + not enfixed // too rare a case for intrinsic optimization + and ACT_DISPATCHER(action) == &Intrinsic_Dispatcher + and Not_Frame_At_End(f) // can't do , fallthru to error + and not SPORADICALLY(10) // debug build bypass every 10th call + ){ + Copy_Cell(SCRATCH, unwrap(f_current_gotten)); + INIT_VAL_ACTION_LABEL(SCRATCH, label); // use the word + REBPAR* param = ACT_PARAM(action, 2); + Flags flags = 0; + if (VAL_PARAM_CLASS(param) == PARAM_CLASS_META) + flags |= FRAME_FLAG_FAILURE_RESULT_OK; + + if (Did_Init_Inert_Optimize_Complete(SPARE, f->feed, &flags)) + goto intrinsic_in_scratch_arg_in_spare; + + Frame(*) subframe = Make_Frame(f->feed, flags); + Push_Frame(SPARE, subframe); + STATE = ST_EVALUATOR_CALCULATING_INTRINSIC_ARG; + return CATCH_CONTINUE_SUBFRAME(subframe); + } + Frame(*) subframe = Make_Action_Subframe(f); Push_Frame(OUT, subframe); Push_Action(subframe, action, binding); diff --git a/src/core/evaluator/c-trampoline.c b/src/core/evaluator/c-trampoline.c index f44591dcc7..e3eb30900a 100644 --- a/src/core/evaluator/c-trampoline.c +++ b/src/core/evaluator/c-trampoline.c @@ -477,6 +477,19 @@ bool Trampoline_With_Top_As_Root_Throws(void) return false; #if DEBUG_FANCY_PANIC + if (r == BOUNCE_CONTINUE) + printf("R is BOUNCE_CONTINUE\n"); + else if (r == BOUNCE_DELEGATE) + printf("R is BOUNCE_DELEGATE\n"); + else if (r == BOUNCE_REDO_CHECKED) + printf("R is BOUNCE_REDO_CHECKED\n"); + else if (r == BOUNCE_REDO_UNCHECKED) + printf("R is BOUNCE_REDO_UNCHECKED\n"); + else if (r == BOUNCE_SUSPEND) + printf("R is BOUNCE_SUSPEND\n"); + else + printf("R is something unknown\n"); + Dump_Stack(root); #endif diff --git a/src/core/functionals/c-typechecker.c b/src/core/functionals/c-typechecker.c index a9f72d21cf..90d25446a6 100644 --- a/src/core/functionals/c-typechecker.c +++ b/src/core/functionals/c-typechecker.c @@ -187,13 +187,14 @@ bool Typecheck_Value( } for (; item != tail; ++item) { - // + option(Symbol(const*)) label = nullptr; // so goto doesn't cross + // !!! Ultimately, we'll enable literal comparison for quoted/quasi // items. For the moment just try quasi-words for isotopes. // if (IS_QUASI(item)) { if (HEART_BYTE(item) == REB_VOID) { - if (Is_Quasi_Void(item)) + if (Is_None(v)) goto test_succeeded; goto test_failed; } @@ -211,6 +212,7 @@ bool Typecheck_Value( enum Reb_Kind kind; Cell(const*) test; if (IS_WORD(item)) { + label = VAL_WORD_SYMBOL(item); test = Lookup_Word_May_Fail(item, tests_specifier); kind = VAL_TYPE(test); // e.g. TYPE-BLOCK! <> BLOCK! } @@ -232,28 +234,6 @@ bool Typecheck_Value( case REB_ACTION: { Action(*) action = VAL_ACTION(test); - // NULL? and VOID? do not have type specs on their argument, - // because if they did they would have to mention and - // and this would lead to an infinite recursion if called here. - // - // But we still speedup the checking to avoid needing a function - // call. This could be generalized, where typecheckers are - // associated with internal function pointers for testing...so - // no actual frame needed to be built for any arity-1 and - // logic-returning native. - - if (action == VAL_ACTION(Lib(NULL_Q))) { - if (Is_Nulled(v)) - goto test_succeeded; - goto test_failed; - } - - if (action == VAL_ACTION(Lib(VOID_Q))) { - if (Is_Void(v)) - goto test_succeeded; - goto test_failed; - } - // Here we speedup the typeset checking. It may be that the // acceleration could be unified with a function pointer method // if we are willing to make functions for checking each typeset @@ -289,6 +269,26 @@ bool Typecheck_Value( goto test_failed; } + if (ACT_DISPATCHER(action) == &Intrinsic_Dispatcher) { + Intrinsic* intrinsic = Extract_Intrinsic(action); + + REBPAR* param = ACT_PARAM(action, 2); + DECLARE_LOCAL (arg); + Derelativize(arg, v, v_specifier); + if (VAL_PARAM_CLASS(param) == PARAM_CLASS_META) + Meta_Quotify(arg); + if (not Typecheck_Coerce_Argument(param, arg)) + goto test_failed; + + DECLARE_LOCAL (out); + (*intrinsic)(out, arg); + if (not IS_LOGIC(out)) + fail (Error_No_Logic_Typecheck(label)); + if (VAL_LOGIC(out)) + goto test_succeeded; + goto test_failed; + } + Flags flags = 0; Frame(*) f = Make_End_Frame( FLAG_STATE_BYTE(ST_ACTION_TYPECHECKING) | flags @@ -309,7 +309,7 @@ bool Typecheck_Value( arg = First_Unspecialized_Arg(¶m, f); if (not arg) - fail ("Type predicate doesn't take an argument"); + fail (Error_No_Arg_Typecheck(label)); // must take argument Derelativize(arg, v, v_specifier); // do not decay, see [4] @@ -331,7 +331,7 @@ bool Typecheck_Value( Drop_Frame(f); if (not IS_LOGIC(spare)) - fail ("Type Predicates Must Return LOGIC!"); + fail (Error_No_Logic_Typecheck(label)); if (not VAL_LOGIC(spare)) goto test_failed; @@ -471,8 +471,8 @@ bool Typecheck_Coerce_Argument( if (Is_Raised(arg)) goto return_false; - if (Is_Nihil(arg)) - goto return_false; // can't decay + if (Is_Pack(arg) and Is_Pack_Undecayable(arg)) + goto return_false; // nihil or unstable isotope in first slot if (Is_Isotope(arg) and Is_Isotope_Unstable(arg)) { Decay_If_Unstable(arg); diff --git a/src/include/sys-eval.h b/src/include/sys-eval.h index 4265494916..fd3dde25b9 100644 --- a/src/include/sys-eval.h +++ b/src/include/sys-eval.h @@ -119,7 +119,8 @@ enum { // easy use in the "hot" frame header location. ST_EVALUATOR_LOOKING_AHEAD = 100, - ST_EVALUATOR_REEVALUATING + ST_EVALUATOR_REEVALUATING, + ST_EVALUATOR_CALCULATING_INTRINSIC_ARG }; // Some array executions wish to vaporize if all contents vaporize diff --git a/src/include/sys-throw.h b/src/include/sys-throw.h index 09b7cf5341..7d0d55e1d3 100644 --- a/src/include/sys-throw.h +++ b/src/include/sys-throw.h @@ -128,7 +128,11 @@ inline static Value(*) Decay_If_Unstable(Value(*) v) { if (Trampoline_With_Top_As_Root_Throws()) fail (Error_No_Catch_For_Throw(TOP_FRAME)); Drop_Frame(TOP_FRAME); - return v; + + // fall through in case result is pack or raised + // (should this iterate?) + + assert(not Is_Lazy(v)); } if (Is_Pack(v)) { // iterate until result is not multi-return, see [1] @@ -151,3 +155,22 @@ inline static Value(*) Decay_If_Unstable(Value(*) v) { return v; } + +// Packs with unstable isotopes in their first cell (or nihil) are not able +// to be decayed. Type checking has to be aware of this, and know that such +// packs shouldn't raise errors. +// +inline static bool Is_Pack_Undecayable(Value(*) pack) +{ + assert(Is_Pack(pack)); + if (Is_Nihil(pack)) + return true; + Cell(const*) at = VAL_ARRAY_AT(nullptr, pack); + if (Is_Meta_Of_Raised(at)) + return true; + if (Is_Meta_Of_Pack(at)) + return true; + if (Is_Meta_Of_Lazy(at)) + return true; + return false; +}