FEAT: dynamic function refinements

src/core/c-do.c

@@ -668,6 +668,7 @@ x*/ static REBINT Do_Args_Light(REBVAL *func, REBVAL *path, REBSER *block, REBCN
  REBINT dsf = dsp - DSF_BIAS;
  REBVAL *tos;
  REBVAL *func;
+ REBOOL useArgs = TRUE; // can be used by get-word function refinements to ignore values
 
  if ((dsp + 100) > (REBINT)SERIES_REST(DS_Series)) {
  Expand_Stack(STACK_MIN);
@@ -716,7 +717,7 @@ x*/ static REBINT Do_Args_Light(REBVAL *func, REBVAL *path, REBSER *block, REBCN
  index = Do_Next(block, index, IS_OP(func));
  // THROWN is handled after the switch.
  if (index == END_FLAG) Trap2(RE_NO_ARG, Func_Word(dsf), args);
- DS_Base[ds] = *DS_POP;
+ if (useArgs) DS_Base[ds] = *DS_POP; else DS_DROP;
  break;
 
  case REB_LIT_WORD: // 'WORD - Just get next value
@@ -725,34 +726,30 @@ x*/ static REBINT Do_Args_Light(REBVAL *func, REBVAL *path, REBSER *block, REBCN
  if (IS_PAREN(value) || IS_GET_WORD(value) || IS_GET_PATH(value)) {
  index = Do_Next(block, index, IS_OP(func));
  // THROWN is handled after the switch.
- DS_Base[ds] = *DS_POP;
+ if (useArgs) DS_Base[ds] = *DS_POP; else DS_DROP;
  }
  else {
  index++;
- DS_Base[ds] = *value;
+ if (useArgs) DS_Base[ds] = *value;
  }
  } else
  SET_UNSET(&DS_Base[ds]); // allowed to be none
  break;
 
  case REB_GET_WORD: // :WORD - Get value
  if (index < BLK_LEN(block)) {
- DS_Base[ds] = *BLK_SKIP(block, index);
+ if (useArgs) DS_Base[ds] = *BLK_SKIP(block, index);
  index++;
  } else
  SET_UNSET(&DS_Base[ds]); // allowed to be none
  break;
-/*
- value = BLK_SKIP(block, index);
- index++;
- if (IS_WORD(value) && VAL_WORD_FRAME(value)) value = Get_Var(value);
- DS_Base[ds] = *value;
-*/
+
  case REB_REFINEMENT: // /WORD - Function refinement
  if (!path || IS_END(path)) return index;
  if (IS_WORD(path)) {
  // Optimize, if the refinement is the next arg:
  if (SAME_SYM(path, args)) {
+ useArgs = TRUE;
  SET_TRUE(DS_VALUE(ds)); // set refinement stack value true
  path++; // remove processed refinement
  continue;
@@ -763,6 +760,7 @@ x*/ static REBINT Do_Args_Light(REBVAL *func, REBVAL *path, REBSER *block, REBCN
  args = BLK_SKIP(words, 1);
  for (; NOT_END(args); args++, ds++) {
  if (IS_REFINEMENT(args) && VAL_WORD_CANON(args) == VAL_WORD_CANON(path)) {
+ useArgs = TRUE;
  SET_TRUE(DS_VALUE(ds)); // set refinement stack value true
  path++; // remove processed refinement
  break;
@@ -772,6 +770,34 @@ x*/ static REBINT Do_Args_Light(REBVAL *func, REBVAL *path, REBSER *block, REBCN
  if (IS_END(args)) Trap2(RE_NO_REFINE, Func_Word(dsf), path);
  continue;
  }
+ else if (IS_GET_WORD(path)) {
+ // This branch is almost same like the above one, but better to have it
+ // separated not to slow down regular refinements.
+ // Optimize, if the refinement is the next arg:
+ if (SAME_SYM(path, args)) {
+ value = Get_Var(path);
+ useArgs = IS_TRUE(value);
+ SET_LOGIC(DS_VALUE(ds), useArgs);
+ path++; // remove processed refinement
+ continue;
+ }
+ // Refinement out of sequence, resequence arg order:
+more_get_path:
+ ds = dsp;
+ args = BLK_SKIP(words, 1);
+ for (; NOT_END(args); args++, ds++) {
+ if (IS_REFINEMENT(args) && VAL_WORD_CANON(args) == VAL_WORD_CANON(path)) {
+ value = Get_Var(path);
+ useArgs = IS_TRUE(value);
+ SET_LOGIC(DS_VALUE(ds), useArgs);
+ path++; // remove processed refinement
+ break;
+ }
+ }
+ // Was refinement found? If not, error:
+ if (IS_END(args)) Trap2(RE_NO_REFINE, Func_Word(dsf), path);
+ continue;
+ }
  else Trap1(RE_BAD_REFINE, path);
  break;
 
@@ -789,14 +815,15 @@ x*/ static REBINT Do_Args_Light(REBVAL *func, REBVAL *path, REBSER *block, REBCN
  }
 
  // If word is typed, verify correct argument datatype:
- if (!TYPE_CHECK(args, VAL_TYPE(DS_VALUE(ds))))
+ if (!TYPE_CHECK(args, VAL_TYPE(DS_VALUE(ds))) && useArgs)
  Trap3(RE_EXPECT_ARG, Func_Word(dsf), args, Of_Type(DS_VALUE(ds)));
  }
 
  // Hack to process remaining path:
  if (path && NOT_END(path)) {
- if (!IS_WORD(path)) Trap1(RE_BAD_REFINE, path);
- goto more_path;
+ if (IS_WORD(path)) goto more_path; 
+ if (IS_GET_WORD(path)) goto more_get_path;
+ Trap1(RE_BAD_REFINE, path);
  }
 
  return index;

src/tests/units/evaluation-test.r3

@@ -1128,4 +1128,73 @@ Rebol [
 
 ===end-group===
 
+
+===start-group=== "Dynamic refinements"
+ ;@@ https://github.com/red/red/blob/c69d4763173/tests/source/units/evaluation-test.red#L1210
+ dyn-ref-fun: func [i [integer!] b /ref c1 /ref2 /ref3 c3 c4][
+ reduce [i b ref c1 ref2 ref3 c3 c4]
+ ]
+
+ --test-- "dyn-ref-1"
+ only: yes
+ repend/:only s: [] [1 + 2 3 * 4]
+ --assert s == [[3 12]]
+
+ --test-- "dyn-ref-2"
+ only: no
+ repend/:only s: [] [4 + 5 6 * 7]
+ --assert s == [9 42]
+
+ --test-- "dyn-ref-3"
+ part: no length: 10 
+ --assert "def" == find/:part "abcdef" "d" length
+
+ --test-- "dyn-ref-4"
+ part: yes length: 2
+ --assert none? find/:part "abcdef" "d" length
+
+ --test-- "dyn-ref-7"
+ ref: yes
+ --assert (dyn-ref-fun/:ref 10 * 9 "hello" 789)
+ == [90 "hello" #[true] 789 #[none] #[none] #[none] #[none]]
+
+ --test-- "dyn-ref-8"
+ ref: no
+ --assert (dyn-ref-fun/:ref 10 * 9 "hello" 789)
+ == [90 "hello" #[false] #[none] #[none] #[none] #[none] #[none]]
+
+ --test-- "dyn-ref-9"
+ ref: ref2: yes
+ --assert (dyn-ref-fun/:ref/:ref2 10 * 9 "hello" 789)
+ == [90 "hello" #[true] 789 #[true] #[none] #[none] #[none]] 
+
+ --test-- "dyn-ref-10"
+ ref: no ref2: yes
+ --assert (dyn-ref-fun/:ref/:ref2 10 * 9 "hello" 789)
+ == [90 "hello" #[false] #[none] #[true] #[none] #[none] #[none]]
+
+ --test-- "dyn-ref-11"
+ ref: no ref2: ref3: yes
+ --assert (dyn-ref-fun/:ref/:ref2/:ref3 10 * 9 "hello" 789 6 7)
+ == [90 "hello" #[false] #[none] #[true] #[true] 6 7]
+
+ --test-- "dyn-ref-12" 
+ dyn-ref-12-obj: context [
+ foo: func [i [integer!] b /ref c1 /ref2 /ref3 c3 c4][
+ reduce [i b ref c1 ref2 ref3 c3 c4]
+ ]
+ bar: func [/local ref][
+ ref: no
+ --assert (foo/:ref 10 * 9 "hello" 789)
+ == [90 "hello" #[false] #[none] #[none] #[none] #[none] #[none]]
+
+ ref: yes
+ --assert (foo/:ref 10 * 9 "hello" 789)
+ == [90 "hello" #[true] 789 #[none] #[none] #[none] #[none]]
+
+ ]
+ ]
+ dyn-ref-12-obj/bar
+===end-group===
+
 ~~~end-file~~~

src/tests/units/func-test.r3

@@ -8,6 +8,44 @@ Rebol [
 
 ~~~start-file~~~ "Function"
 
+===start-group=== "Function refinements"
+ fce: func[a [string!] /ref1 b [integer!] /ref2 :c 'd][
+ reduce [a ref1 b ref2 c d]
+ ]
+ --test-- "no refinements"
+ --assert all [error? e: try [fce ] e/id = 'no-arg]
+ --assert all [error? e: try [fce 1] e/id = 'expect-arg]
+ --assert (fce "a") == ["a" #[none] #[none] #[none] #[none] #[none]]
+
+ --test-- "simple refinements"
+ --assert all [error? e: try [fce/ref1 "a" ] e/id = 'no-arg]
+ --assert all [error? e: try [fce/ref1 "a" ""] e/id = 'expect-arg]
+ --assert (fce/ref1 "a" 1) == ["a" #[true] 1 #[none] #[none] #[none]]
+ --assert (fce/ref1 "a" 1 + 1) == ["a" #[true] 2 #[none] #[none] #[none]]
+ --assert (fce/ref1/ref2 "a" 1 x y) == ["a" #[true] 1 #[true] x y]
+ --assert (fce/ref2/ref1 "a" x y 1 + 1) == ["a" #[true] 2 #[true] x y]
+
+ --test-- "dynamic refinements"
+ ref1: yes --assert all [error? e: try [fce/:ref1 "a" ] e/id = 'no-arg]
+ ref1: off --assert all [error? e: try [fce/:ref1 "a" ] e/id = 'no-arg]
+ ref1: yes --assert all [error? e: try [fce/:ref1 "a" ""] e/id = 'expect-arg]
+ ref1: off --assert (fce/:ref1 "a" "") == ["a" #[false] #[none] #[none] #[none] #[none]]
+ ref1: yes --assert (fce/:ref1 "a" 1) == ["a" #[true] 1 #[none] #[none] #[none]]
+ ref1: off --assert (fce/:ref1 "a" 1) == ["a" #[false] #[none] #[none] #[none] #[none]]
+ ref1: yes --assert all [(fce/:ref1 "a" x: 1 + 1) == ["a" #[true] 2 #[none] #[none] #[none]] x == 2]
+ ref1: off --assert all [(fce/:ref1 "a" x: 1 + 1) == ["a" #[false] #[none] #[none] #[none] #[none]] x == 2]
+ ref1: yes ref2: yes --assert (fce/:ref1/:ref2 "a" 1 + 1 x y) == ["a" #[true] 2 #[true] x y]
+ ref1: yes ref2: yes --assert (fce/:ref2/:ref1 "a" x y 1 + 1) == ["a" #[true] 2 #[true] x y]
+ ref1: yes ref2: off --assert (fce/:ref1/:ref2 "a" 1 + 1 x y) == ["a" #[true] 2 #[false] #[none] #[none]]
+ ref1: yes ref2: off --assert (fce/:ref2/:ref1 "a" x y 1 + 1) == ["a" #[true] 2 #[false] #[none] #[none]]
+ ref1: off ref2: yes --assert (fce/:ref1/:ref2 "a" 1 + 1 x y) == ["a" #[false] #[none] #[true] x y]
+ ref1: off ref2: yes --assert (fce/:ref2/:ref1 "a" x y 1 + 1) == ["a" #[false] #[none] #[true] x y]
+ ref1: off ref2: off --assert (fce/:ref1/:ref2 "a" 1 + 1 x y) == ["a" #[false] #[none] #[false] #[none] #[none]]
+ ref1: off ref2: off --assert (fce/:ref2/:ref1 "a" x y 1 + 1) == ["a" #[false] #[none] #[false] #[none] #[none]]
+
+===end-group===
+
+
 ===start-group=== "Apply"
 
 --test-- "apply :do [:func]"