Brexit commit

Brexit commit

% This is not Rubi and Garnet is not as valuable as Ruby... but at least
% both are basically red...

lisp;
on backtrace, echo, comp; % set some useful (I hope) options

% The existing "rubi_red" package provides a way to access all the
% Rubi rules... But in fact I will set up my own short list...

load_package rubi_red;

% fluid '(rubi_rules);

% To start with I will have just ONE rule!

% (a + b*x^n)^p
% where n*(p+1)=-1
% eg let me try n=1, p=-2, so I get
% (a + b*x^1)^(-2)

%rubi_rules := '(

%(!/!;
%   (!:!=
%      (!Int
%         (expt (plus (!_ a) (times (!_!. b) (expt (!_ x) (!_ n)))) (!_ p))
%         (!_ x !Symbol))
%      (quotient (times x (expt (plus a (times b (expt x n))) (plus p 1))) a))
%   (and
%      (!Free!Q (bracelist a b n p) x)
%      (!Zero!Q (plus (times n (plus p 1)) 1))))

%)$

algebraic operator unsimplified_int;

symbolic procedure simpgarnet u;
  begin
    scalar a, x, r;
    if length u neq 2 then rederr "garnet requires two arguments";
    a := car u;
    x := cadr u;
    if posn() neq 0 then terpri();
    princ "Integrate "; prin a; princ " wrt "; print x;
% The arguments arrive here are totally unprocessed, and so for instance
% if you write "w := <something>; var := x; garnet(w, var);" what you
% receive will be "w" and "var" not sensible values. I have special code
% to deal with this!
    a := garnet!-simp a;
    x := garnet!-simp x;
    r := garnet_integrate(a, x);
% I hand back a list of length 2 - the first item is the result that
% garnet generates, the second is what the existing old Reduce integrator
% makes of the example.
    return simp list('list, r, list('int, a, x));
  end;

put('garnet, 'simpfn, 'simpgarnet);

% This takes a formula and "evaluates" it by evaluating all the variables
% present in it while trying to preserve the structure around the, So if you
% hand it (x-1)^10 where x has some messy value it will return the expression
% (<messy-value> - 1)^10 rather than multiplying things out. Just in case
% the varibles used had previously been simplified in a way that expanded
% them this does some factorization to try to return things to a "neat"
% form. If substituting values for variables would introduce cases of
% (expression + 0) or (expression^1) it does some minor tidying up to
% make things seem nicer.

symbolic procedure garnet!-simp u;
  if numberp u then u
  else if atom u then garnet!-simpatom u
  else begin
    scalar w;
    w := for each v in cdr u collect garnet!-simp v;
    if car u = 'plus then return garnet!-simp!-plus w
    else if car u = 'difference then return garnet!-simp!-difference w
    else if car u = 'times then return garnet!-simp!-times w
    else if car u = 'quotient then return garnet!-simp!-quotient w
    else if car u = 'expt then return garnet!-simp!-expt w
    else if car u = 'minus then return garnet!-simp!-minus w
    else return car u . w
  end;

% Following might be redundant - commented out for the moment

%symbolic procedure garnet!-simp!-plus l;
%  begin
%    scalar r;
%    for each x in l do if not zerop x then r := x . r;
%    if null r then return 0
%    else if nuill cdr r then return car r
%    else return 'plus . reverse r
%  end;

% The next few reconstruct prefix forms performing only the very simplest
% transformations such as (x + 0) => x and (x * 1) => x. They may even
% go as far as (2 + 2) => 4, but do not guarantee even that! Note that
% "simplifications" along the lines illustrated here are naive and not
% in general an effective way to tidy things up.

symbolic procedure garnet!-simp!-plus l;
  begin
    scalar r, n;
    n := 0;
    for each x in l do
       if numberp x then n := n + x
       else r := x . r;
% Puts any numeric constant as first item in result version.
    if not zerop n then r := n . reverse r
    else r := reverse r;
% If only one item left return it, otherwise return a sum.
    if null cdr r then return car r
    else return 'plus . r
  end;

symbolic procedure garnet!-simp!-times l;
  begin
    scalar r, n;
    n := 1;
    for each x in l do
       if numberp x then n := n * x
       else r := x . r;
    if zerop n then return 0
    else if not onep n then r := n . reverse r
    else r := reverse r;
    if null cdr r then return car r
    else return 'times . r
  end;

symbolic procedure garnet!-simp!-difference l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if numberp a and numberp b then return a-b
    else if zerop a then return garnet!-simp!-minus list b
    else if zerop b then return a
    else return list('difference, a, b)
  end;

symbolic procedure garnet!-simp!-quotient l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    if zerop a then return 0
    else if onep b then return a
    else return list('quotient, a, b)
  end;

% Adding garnet!-simp!-expt l
% Sean-To-do: seems that we cannot just simplify expt component
symbolic procedure garnet!-simp!-expt l;
  begin
    scalar a, b;
    a := car l;
    b := cadr l;
    return list('expt, a, b)
%    if zerop b then return 1
%    else if onep b then return a
%    else if zerop a then return 0
%    else if onep a then return a
%    else return list('expt, a, b)
  end;

symbolic procedure garnet!-simp!-minus l;
  begin
    scalar a;
    a := car l;
    if numberp a then return -a
    else if eqcar(a, 'minus) then return cadr a
    else return list('minus, a)
  end;

symbolic procedure garnet!-simpatom x;
  begin
    scalar w, n, d;
% Start by "simplifying" to get a Standard Quotient
    w := simp x;
% Factorize the polynomials in numerator and denominator;
    n := prepfctr fctrf numr w;
    d := prepfctr fctrf denr w;
    if d = 1 then return n
% WARNING: FOLLOWING IS A HACK
% Simple quotient rewrite rule when numberator is one
    else if onep n then <<
      if eqcar(d, 'expt) and (numberp caddr d) then
        return list('expt, cadr d, -(caddr d));
      >>

    else return list('quotient, n, d)
  end;

% fctrf returns a numerical content on the front of a list of
% factors and multiplicities. If it is (c . (f1 . n1) (f2 . n2)) I will
% return (times c (expt f1 n1) (expt f2 n2)). But can omit bits if any
% multiplicity is 1, or if c=1, or if there is only one factor shown at
% all.

symbolic procedure prepfctr u;
  begin
    scalar r;
    r := for each f in cdr u collect
      if cdr f = 1 then prepf car f
      else list('expt, prepf car f, cdr f);
    if null r then return car u
    else if car u = 1 then <<
      if null cdr r then return car r
      else return 'times . r >>
    else return 'times . car u . r
  end;

% tr garnet!-simpatom;
% tr fctrf, prepfctr;

% going through all the rules one by one for pattern matching

symbolic procedure garnet_integrate(a, x);
  begin
    scalar rules, w;
    rules := rubi_rules;
top:
    if null rules then return list('unsimplified_int, a, x);
% apply_rules returns a non-nil answer if it finds an integral, or nil
% if the rules will not apply.
    if w := apply_rule(car rules, a, x) then
       return garnet_check_inside w;
    rules := cdr rules;
    go to top;
  end;

global '(trace_counter);
trace_counter := 0;

% The high-level pattern matcher, match a rule against an expression
% calls trymatch to create bindings
% returns nil if fail to match
%
symbolic procedure apply_rule(rule, a, x);
  begin
    scalar lhs, rhs, conditions, w, bindings, condition;
    if (trace_counter := trace_counter+1) < 5 then <<
        %Sean-To-do: look up posn()
        %Arthur: posn() tells you the current output column, so this
        % forces a new line unless you are already at the start of a line.
       if posn() neq 0 then terpri();
       prin trace_counter; princ ": ";
       princ "looking at "; prin a; princ " wrt "; print x;
       princ "Try rule "; prettyprint rule; terpri() >>;
    if not eqcar(rule, '!/!;) then <<
       % printc "Expecting /; at top of rule, rule is: "; % print rule;
       return nil >>;
    w := cadr rule;
    conditions := caddr rule;
    if not eqcar(w, '!:!=) then <<
       printc "Expecting := at top of rewrite";
       return nil >>;
    lhs := cadr w;
    rhs := caddr w;
% trymatch will return either a list of bindings or the special symbol
% 'fail to indicate that matching was not possible.
    bindings := trymatch(list('!Int, a, x), lhs, nil);

    if bindings = 'fail then return nil;

    % TO-DO: verify if binding is valid
    terpri(); princ "Bindings = "; print bindings;

    % WARNING: FOLLOWING IS A HACK THAT ONLY CHECK BINDING FOR X ONCE
    % There must be a better way of checking if binding occurs twice
    % and if bindings are coherent

    if assoc('x, bindings) and assoc('x, cdr bindings) and
      not (assoc('x, bindings) = assoc('x, cdr bindings)) then return nil;

    princ "Rule is: "; print rule;
    if eqcar(rhs, '!Module) or eqcar(rhs, '!Dist) then return nil;

    % following is a little test for check_fraction_q
    % condition := '(!Fraction!Q (bracelist n p));
    % single_condition_pass(subla(bindings, condition), rhs);

% Here I need to check conditions
% Sean: do subla before checking conditions??
% Sean: doing subla on conditions before checking conditions
% I see no incidence of using the original conditions

    if conditions_pass(subla(bindings, conditions), subla(bindings, rhs))
      then return subla(bindings, rhs) % redundant call to subla
    else return nil;
  end;

% ===================== Conditions Section ======================
symbolic procedure conditions_pass(c, r);
  begin
    scalar first_cond, second_cond;
    if eqcar(c, 'and) then <<
%      printc "AND: checking if both conditions are true";

      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>
      else return nil;
      >>
    else if eqcar(c, 'or) then <<
%      printc "OR: checking if one of the two conditions are true";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else if first_cond then return t
      else  <<
        second_cond := conditions_pass(caddr c, r);
        if second_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car caddr c;
          return nil;
          >>
        else return second_cond;
        >>;
      >>
    else if eqcar(c, '!Not) then <<
%      printc "NOT: reverse logic";
      first_cond := conditions_pass(cadr c, r);
      if first_cond = 'fail then <<
          princ "Condition test not implemented: "; prin car cadr c;
          return nil;
          >>
      else return not first_cond;
      >>
    else <<
      first_cond := single_condition_pass(c, r);
      if first_cond = 'fail then return nil
      else if first_cond then return t
      else <<
        princ "Condition failed: "; print c;
        return nil;
        >>
      >>
  end;

%*****************List of Conditions*************
% Ones without a * are not implemented
% Listed in the order of appearance
% After some inspection, some conditions seem not captured here
% TO-DO: find out why

% *!Free!Q
% *!Fraction!Q
% *lessp -> most imporant one, needs a lot more testing
% *!Positive!Q
% *!Pos!Q
% *!Neg!Q
% !Not - this is bizarre, as it shouldn't appear
% *!Zero!Q
% *greaterp
% *!Nonzero!Q
% !Rational!Q -> incorrectly implemented, see notes later
% *!Integer!Q
% *!Integers!Q
% *leq
% !Match!Q
% *equal
% *!Negative!Q
% *geq
% nil
% !Polynomial!Q
% !Negative!Coefficient!Q
% !Linear!Q
% !If
% *neq
% !Algebraic!Function!Q
% *!Even!Q
% *!Odd!Q
% !Function!Of!Hyperbolic!Q
% !Function!Of!Q
% !Nonsum!Q
% !Try!Pure!Tanh!Subst
% !Independent!Q
% !Half!Integer!Q
% !Inverse!Function!Free!Q
% !False!Q
% !Coprime!Q
% !Expand!Integrand!Q
% !One!Q
% !Recognized!Function!Of!Trig!Q
% !Member!Q
% !Try!Pure!Tan!Subst

%****************************************************

symbolic procedure single_condition_pass(c, r);
  begin
% Passing (cdr c) for now to preserve structural integrity for various cases
% TO-DO: reorder according to the number of occurence
% TO-DO: remove the parenthesis around (cdr c) if necessary
    if eqcar(c, '!Free!Q) then return check_free_q(cdr c, r)
    else if eqcar(c, '!Zero!Q) then return check_zero_q(cdr c)
    else if eqcar(c, '!Nonzero!Q) then return check_non_zero_q(cdr c)
    else if eqcar(c, 'equal) then return check_equal(cdr c)
    else if eqcar(c, 'neq) then return check_not_equal(cdr c)
    else if eqcar(c, '!Odd!Q) then return check_odd_q(cdr c)
    else if eqcar(c, '!Even!Q) then return check_even_q(cdr c)
    else if eqcar(c, '!Positive!Q) then return check_positive_q(cdr c)
    else if eqcar(c, '!Negative!Q) then return check_negative_q(cdr c)
    else if eqcar(c, '!Pos!Q) then return check_pos_q(cdr c)
    else if eqcar(c, '!Neg!Q) then return check_neg_q(cdr c)
    else if eqcar(c, 'lessp) then return check_lessp(cdr c)
    else if eqcar(c, '!greaterp) then return check_greaterp(cdr c)
    else if eqcar(c, 'leq) then return check_less_equal(cdr c)
    else if eqcar(c, 'geq) then return check_greater_equal(cdr c)
    else if eqcar(c, 'nil) then return check_nil(cdr c)
    else if eqcar(c, '!Independent!Q) then return check_independent_q(cdr c, r)
    else if eqcar(c, '!Match!Q) then return check_match_q(cdr c)
    else if eqcar(c, '!Integer!Q) then return check_integer_q(cdr c)
    else if eqcar(c, '!Integers!Q) then return check_integers_q(cdr c)
    else if eqcar(c, '!Rational!Q) then return check_rational_q(cdr c)
    else if eqcar(c, '!Fraction!Q) then return check_fraction_q(cdr c)
    else if eqcar(c, '!Polynomial!Q) then return check_polynomial_q(cdr c)
    else if eqcar(c, '!Linear!Q) then return check_linear_q(cdr c)
    else if eqcar(c, '!Function!Of!Q) then return check_function_of_q(cdr c)

    else if eqcar(c, '!Fraction!Or!Negative!Q) then
      return check_fraction_or_negative_q(cdr c)

    else if eqcar(c, '!Negative!Coefficient!Q) then
      return check_negative_coefficient_q(cdr c)

    else if eqcar(c, '!Algebraic!Function!Q) then
      return check_algebraic_function_q(cdr c)

    else if eqcar(c, '!Function!Of!Hyperbolic!Q) then
      return check_function_of_hyperbolic_q(cdr c)

    else if eqcar(c, '!Inverse!Function!Free!Q) then
      return check_inverse_function_free_q(cdr c)

    else if eqcar(c, '!Recognized!Function!Of!Trig!Q) then
      return check_recognized_function_of_trig_q(cdr c)

    else <<
      princ "Condition not recognised, need to add to current list: ";
      print c;
      return 'fail;
      >>;
    return nil;
  end;

% To-do: test it thoroughly - most frequent condition
% c: condition, in the form of ((bracelist a b c ...) x) or (a x)
% r: right hand side
symbolic procedure check_free_q(c, r);
  begin
    mark_constants(r, car cdr c);
    if eqcar(car c, 'bracelist) then
      return check_free_q_list cdr car c
    else return print gethash(car c, garnet_hash);
  end;

symbolic procedure check_free_q_list l;
  if null l then t
  else if gethash(car l, garnet_hash) then check_free_q_list cdr l
  else nil;

% tr check_free_q_list, check_free_q;

symbolic procedure check_zero_q(c);
  zerop reval(car c);

symbolic procedure check_non_zero_q(c);
  not check_zero_q(c);

% still a little puzzled by different equality test
symbolic procedure check_equal(c);
  reval car c = reval cadr c;

symbolic procedure check_not_equal(c);
  not check_equal(c);

symbolic procedure check_odd_q(c);
  oddp reval car c;

symbolic procedure check_even_q(c);
  evenp reval car c;

symbolic procedure check_positive_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_negative_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_pos_q(c);
  lessp_quotient(0, car c);

symbolic procedure check_neg_q(c);
  lessp_quotient(car c, 0);

symbolic procedure check_lessp(c);
  lessp_quotient(car c, cadr c);

% The (perculiar) behavior of reval:
% w := '(quotient 1 -2);
% reval w; => (quotient (minus 1) 2)
% reval cadr w; => 1;
% reval cadr reval w; => -1;

% lessp than compares quotient as well
% To-do: might not work well with irrational and complex numbers
symbolic procedure lessp_quotient(l, r);
  begin
    l := reval l;
    r := reval r;
    if numberp l and numberp r then return l < r
    else if eqcar(l, 'quotient) and numberp r then <<
      if zerop r then return eqcar(cadr l, 'minus)
      else if r > 0 then <<
        if eqcar(cadr l, 'minus) then return t % neg fraction < positive int
        else return lessp_quotient(list('times, cadr l, r), caddr l);
        >>
      else <<
        if eqcar(cadr l, 'minus) then % make both positive
          return lessp_quotient(list('minus, r), list('minus, l))
        else return nil;
        >>;
      >>
    else if numberp l and eqcar(r, 'quotient) then
      return not lessp_quotient(r, l)
    else if eqcar(l, 'quotient) and eqcar(r, 'quotient) then <<
% This part needs a bit more scrutinisation:
% we assume if we found a number at numerator, then the quotient
% is positive
      if eqcar(cadr l, 'minus) and eqcar(cadr r, 'minus) then
        return lessp_quotient(list('minus, r), list('minus, l))
      else if eqcar(cadr l, 'minus) and numberp cadr r then return t
      else if numberp cadr l and eqcar(cadr r, 'minus) then return nil
      else if numberp cadr l and numberp cadr r then
        return lessp_quotient(list('times,cadr l, caddr r),
          list('times, cadr r, caddr l))
      else
        rederr "Error comparing two quotients";
      >>
    % Sean: not really sure the best error-handling practice here
    else rederr "lessp_quotient cannot recognise the format";
  end;

symbolic procedure check_greaterp(c);
  not check_lessp(c);

symbolic procedure check_less_equal(c);
  check_equal(c) and check_lessp(c);

symbolic procedure check_greater_equal(c);
  check_equal(c) and not check_lessp(c);

symbolic procedure check_nil(c);
  'fail;

% Two cases for !Independent!Q, one followed by !Cancel, the other is not
% !Cancel not implemented
symbolic procedure check_independent_q(c, r);
  if not eqcar(car c, 'Cancel) then check_free_q(c, r);

symbolic procedure check_match_q(c);
  'fail;

symbolic procedure check_integer_q(c);
  fixp reval car c;

symbolic procedure check_integers_q(c);
  if null c then t
  else if check_integer_q(c) then check_integers_q(cdr c)
  else nil;

symbolic procedure check_rational_q(c);
  if eqcar(c, 'bracelist) then check_rational_q_list (cdr car c)
  else check_rational_q_atom (car c);

symbolic procedure check_rational_q_list l;
  if null l then t
  else if check_rational_q_atom car l then check_rational_q_list cdr l
  else nil;

% WARNING: THIS ONE WILL FAIL!!
% It is implemented incorrectly so as to move on with testing
% If we do a reval PI, it gives back a quotient of two integers,
% thus making it a rational number as well. BUT WE KNOW IT IS NOT.
% We need to in some way evaluate c (the expression) first, because
% the goal is to see if any irrational terms cancels out, since many test
% begin with (!Rationa!Q (!Rt ...) ..).
symbolic procedure check_rational_q_atom c;
  if fixp reval c then t
  else if eqcar(reval c, 'quotient) then fixp cadr c and fixp caddr c
  else nil;

reval pi;

symbolic procedure check_fraction_q(c);
% !Fraction!Q can be either called on a single atom or a bracelist
% for eg. (!Fraction!Q n) and (!Fraction!Q (bracelist n p))
  if eqcar(c, 'bracelist) then check_fraction_q_list (cdr car c)
  else check_fraction_q_atom (car c);

symbolic procedure check_fraction_q_atom c;
% do a reval to force 'quotient to come to car of the list
% seems generally work but can't guarantee
  if atom reval c then nil
  else car reval c = 'quotient;

symbolic procedure check_fraction_q_list l;
  begin
    if null l then return t
    else if check_fraction_q_atom (car l) then <<
      l := cdr l;
      return check_fraction_q_list l;
      >>
    else return nil;
  end;

% tr check_fraction_q, check_fraction_q_atom, check_fraction_q_list;

symbolic procedure check_polynomial_q(c);
  'fail;
symbolic procedure check_linear_q(c);
  'fail;
symbolic procedure check_function_of_q(c);
  'fail;
symbolic procedure check_fraction_or_negative_q(c);
  'fail;
symbolic procedure check_negative_coefficient_q(c);
  'fail;
symbolic procedure check_algebraic_function_q(c);
  'fail;
symbolic procedure check_function_of_hyperbolic_q(c);
  'fail;
symbolic procedure check_inverse_function_free_q(c);
  'fail;
symbolic procedure check_recognized_function_of_trig_q(c);
  'fail;

% ===================== Conditions Section End ======================

% the low-level recursive pattern matcher that generates bindings
% returns binding if succeed, 'fail otherwise
% bindings in the following format:
% (( rule_variable_name . expression_variable_name) (...) ...)

% TO-DO: seems there might be double binding, meaning if we do
% garnet((1+z)^(-1/12), z), x is bind to both z and (1+z)
% thus we get 12*z^(11/12)/11 as a result, instead of
% 12*(1+z)^(11/12)/11.

symbolic procedure trymatch(u, pattern, env);
  begin
%    princ "u = "; print u;
%    princ "pattern = "; print pattern;
%    princ "env = "; print env;
% Sean-To-do: what happens when there is '!_ or '!_!.??
    if eqcar(pattern, '!_) then
       return (cadr pattern . u) . env
    else if eqcar(pattern, '!_!.) then
       return (cadr pattern . u) . env
    else if u = pattern then return env
    else if atom pattern or atom u then return 'fail
    else if not (car u = car pattern) then return 'fail
    else return trymatchlist(cdr u, cdr pattern, env)
  end;

symbolic procedure trymatchlist(lu, lpattern, env);
  if null lu and null lpattern then env
  else if null lu or null lpattern then 'fail
  else begin
    scalar w;
    w := trymatch(car lu, car lpattern, env);

    % If using original expression fails to match, try rewriting our
    % expression to match the the pattern
    if w = 'fail then <<
      if eqcar(car lpattern, 'expt) then <<
        w := trymatch_expt(lu, lpattern, env);
        >>
      else if eqcar(car lpattern, 'times) then <<
        w := trymatch_times(lu, lpattern, env);
        >>
      else if eqcar(car lpattern, 'plus) then <<
        w := trymatch_plus(lu, lpattern, env);
        >>
      else return 'fail;
      >>;
    if w = 'fail then return 'fail
    else return trymatchlist(cdr lu, cdr lpattern, w);
    end;

%======================Try Match with Options====================

% To-do: not fully implemented yet
% To-do: some redundant logic, will fix it when I have a clear mind
% To-do: distinguish between !_ and !_!.

symbolic procedure trymatch_expt(lu, lpattern, env);
% princ "Attempting to add exponent 1.";
    if eqcar(caddr car lpattern, '!_ ) or eqcar(caddr car lpattern, '!_!. ) then
      trymatch(list('expt, car lu, 1), car lpattern, env)
    else 'fail;

symbolic procedure trymatch_times(lu, lpattern, env);
% princ "Attempting to add coefficient/times 1.";
  if eqcar(cadr car lpattern, '!_ ) or eqcar(cadr car lpattern, '!_!. ) then
   trymatch(list('times, 1, car lu), car lpattern, env)
  else 'fail;

symbolic procedure trymatch_plus(lu, lpattern, env);
% princ "Attempting to add plus 0.";
  if eqcar(cadr car lpattern, '!_ ) or eqcar(cadr car lpattern, '!_!. ) then
   trymatch(list('plus, 0, car lu), car lpattern, env)
  else 'fail;

%======================Try Match with Options End================

% A rule may transform an integral into something where there is an
% integral sign left within what is generated. Scan to spot such cases and
% call garnet again to process that.

symbolic procedure garnet_check_inside u;
  if atom u then u
  else if eqcar(u, 'int) then garnet_integrate(cadr u, caddr u)
  else car u . for each a in cdr u collect garnet_check_inside a;

% A possibly useful function for noting constants. NOT TESTED AT ALL YET.

%Sean-To-do: will try to incorporate this at later stage

fluid '(garnet_hash);
garnet_hash := mkhash(15, 0, 2.0);

symbolic procedure mark_constants(u, x);
  begin
    clrhash garnet_hash;
    mark_constants_1(u, x)
  end;

% The idea is that this will enter data into the hash table for every
% part of the input that is "constant" in u (with respect to x). So complex
% formulae like sin(pi/sqrt(a^2+b^2)) are constant with respect to x, in that
% the given formula has no x in it. However exactly the same formula would not
% be independent of a or b.
% The functio also returns true it its argument u is independent of x,
% This is to implement the InvolvesQ predicate.

symbolic procedure mark_constants_1(u, x);
  if u = x then nil
  else if atom u then << puthash(u, garnet_hash, t); t >>
  else begin
    scalar overall;
    overall := t;
% overall is going to tell if this whole expression seems constant.
    for each s in cdr u do
       if not mark_constants_1(s, x) then overall := nil;
    if overall then puthash(u, garnet_hash, t);
    return overall
  end;

% check by using "gethash(u, garnet_hash)"

% Small test/demo of above

symbolic procedure test_constants(u, x);
  begin
    mark_constants(u, x);
    testconst u
  end;

symbolic procedure testconst u;
  begin
    prin u;
    if posn() > 49 then terpri();
    ttab 50;
    print gethash(u, garnet_hash);
    if atom u then return nil;
    for each s in cdr u do testconst s
  end;

test_constants('(plus (times 2 x)
                 (sin (quotient pi (sqrt (plus (expt a 2) (expt b 2)))))),
               'x);

algebraic;

% I now have some cases - where SOME of them should match the rule that
% I have got.

% tr trymatch, trymatchlist;

% TO-DO: doesn't seem to work with sin z, log etc.

garnet((u + v*z^1)^(-1/3), z); % doesn't work
garnet((u + z^1)^(-2), z);
garnet((u + v*z)^(-2), z);
garnet((u + z)^(-2), z);

% Now the same four but with a level of indirection...
w := (u + v*z^1)^(-1/3); garnet(w, z); % doesn't work either
w := (u + z^1)^(-2); garnet(w, z); % This one in the test
w := (u + v*z)^(-2); garnet(w, z);
w := (u + z)^(-2); garnet(w, z);

end;

% :/


TESTS: fixed some tests for unset!.

TESTS: fixed some tests for unset!.

Red [
	Title:   "Red type? test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %type-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../../quick-test/quick-test.red

~~~start-file~~~ "type?"

===start-group=== "unevaluated literals"
	--test-- "type?ul-1"
	--assert integer! = type? first [1]
	--test-- "type?ul-2"
	--assert char! = type? first [#"a"]
	--test-- "type?ul-3"
	--assert block! = type? first [[]]
	--test-- "type?ul-4"
	--assert get-word! = type? first [:b]
	--test-- "type?ul-5"
	--assert logic! = type? first [#[true]]
	--test-- "type?ul-6"
	--assert issue! = type? first [#1]
	--test-- "type?ul-7"
	--assert none! = type? first [#[none]]
	--test-- "type?ul-8"
	--assert paren! = type? first [(1)]
	--test-- "type?ul-9"
	--assert set-word! = type? first [b:]
	--test-- "type?ul-10"
	--assert string! = type? first ["1234566789"]
	--test-- "type?ul-11"
	--assert unset! = type? first reduce [prin ""]
	--test-- "type?ul-12"
	--assert word! = type? first [a]
	--test-- "type?ul-13"
	--assert lit-word! = type? first ['a]
===end-group===

===start-group=== "word value"
	--test-- "type?wv-1"
		value: 1
	--assert integer! = type? value
	--test-- "type?wv-2"
		value: #"a"
	--assert char! = type? value
	--test-- "type?wv-3"
		value: [a b c d]
	--assert block! = type? value
	--test-- "type?wv-4"
		value: true
	--assert logic! = type? value
	--test-- "type?wv-5"
		value: #123456789
	--assert issue! = type? value
	--test-- "type?wv-6"
		value: none
	--assert none! = type? value
	--test-- "type?wv-7"
		value: first [("a b c d")]
	--assert paren! = type? value
	--test-- "type?wv-8"
		value: first [a:]
	--assert set-word! = type? value
	--test-- "type?wv-9"
		value: "Hello Nenad"
	--assert string! = type? value
	--test-- "type?wv-10"
		set/any 'value print ""
	--assert unset! = type? get/any 'value
	--test-- "type?wv-11"
		value: 'a
	--assert word! = type? value
	--test-- "type?wv-12"
		value: first ['a]
	--assert word! = type? value
===end-group===

===start-group=== "get word value"
	--test-- "type?gwv-1"
		value: 1
	--assert integer! = type? :value
	--test-- "type?gwv-2"
		value: #"a"
	--assert char! = type? :value
	--test-- "type?gwv-3"
		value: [a b c d]
	--assert block! = type? :value
	--test-- "type?gwv-4"
		value: first [:g]
	--assert get-word! = type? :value
	--test-- "type?gwv-5"
		value: true
	--assert logic! = type? :value
	--test-- "type?gwv-6"
		value: #123456789
	--assert issue! = type? :value
	--test-- "type?gwv-7"
		value: none
	--assert none! = type? :value
	--test-- "type?gwv-8"
		value: first [("abcd")]
	--assert paren! = type? :value
	--test-- "type?gwv-9"
		value: first [a: ]
	--assert set-word! = type? :value
	--test-- "type?gwv-10"
		value: "Hello Nenad"
	--assert string! = type? :value
	--test-- "type?gwv-11"
	  set/any 'value print ""
	--assert unset! = type? :value
	--test-- "type?gwv-12"
		value: 'a
	--assert word! = type? :value
	--test-- "type?gwv-13"
		value: first ['a]
	--assert lit-word! = type? :value
===end-group===

~~~end-file~~~

Red [
	Title:   "Red type? test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %type-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include  %../../../../quick-test/quick-test.red

~~~start-file~~~ "type?"

===start-group=== "unevaluated literals"
	--test-- "type?ul-1"
	--assert integer! = type? first [1]
	--test-- "type?ul-2"
	--assert char! = type? first [#"a"]
	--test-- "type?ul-3"
	--assert block! = type? first [[]]
	--test-- "type?ul-4"
	--assert get-word! = type? first [:b]
	--test-- "type?ul-5"
	--assert logic! = type? first [#[true]]
	--test-- "type?ul-6"
	--assert issue! = type? first [#1]
	--test-- "type?ul-7"
	--assert none! = type? first [#[none]]
	--test-- "type?ul-8"
	--assert paren! = type? first [(1)]
	--test-- "type?ul-9"
	--assert set-word! = type? first [b:]
	--test-- "type?ul-10"
	--assert string! = type? first ["1234566789"]
	;--test-- "type?ul-11"
	;--assert unset! = type? first [prin ""]
	--test-- "type?ul-12"
	--assert word! = type? first [a]
	--test-- "type?ul-13"
	--assert lit-word! = type? first ['a]
===end-group===

===start-group=== "word value"
	--test-- "type?wv-1"
		value: 1
	--assert integer! = type? value
	--test-- "type?wv-2"
		value: #"a"
	--assert char! = type? value
	--test-- "type?wv-3"
		value: [a b c d]
	--assert block! = type? value
	--test-- "type?wv-4"
		value: true
	--assert logic! = type? value
	--test-- "type?wv-5"
		value: #123456789
	--assert issue! = type? value
	--test-- "type?wv-6"
		value: none
	--assert none! = type? value
	--test-- "type?wv-7"
		value: first [("a b c d")]
	--assert paren! = type? value
	--test-- "type?wv-8"
		value: first [a:]
	--assert set-word! = type? value
	--test-- "type?wv-9"
		value: "Hello Nenad"
	--assert string! = type? value
	--test-- "type?wv-10"
		set/any 'value print ""
	--assert unset! = type? get/any 'value
	--test-- "type?wv-11"
		value: 'a
	--assert word! = type? value
	--test-- "type?wv-12"
		value: first ['a]
	--assert word! = type? value
===end-group===

===start-group=== "get word value"
	--test-- "type?gwv-1"
		value: 1
	--assert integer! = type? :value
	--test-- "type?gwv-2"
		value: #"a"
	--assert char! = type? :value
	--test-- "type?gwv-3"
		value: [a b c d]
	--assert block! = type? :value
	--test-- "type?gwv-4"
		value: first [:g]
	--assert get-word! = type? :value
	--test-- "type?gwv-5"
		value: true
	--assert logic! = type? :value
	--test-- "type?gwv-6"
		value: #123456789
	--assert issue! = type? :value
	--test-- "type?gwv-7"
		value: none
	--assert none! = type? :value
	--test-- "type?gwv-8"
		value: first [("abcd")]
	--assert paren! = type? :value
	--test-- "type?gwv-9"
		value: first [a: ]
	--assert set-word! = type? :value
	--test-- "type?gwv-10"
		value: "Hello Nenad"
	--assert string! = type? :value
	--test-- "type?gwv-11"
	  set/any 'value print ""
	--assert unset! = type? get/any 'value
	--test-- "type?gwv-12"
		value: 'a
	--assert word! = type? :value
	--test-- "type?gwv-13"
		value: first ['a]
	--assert lit-word! = type? :value
===end-group===

~~~end-file~~~


FIX: issue #1222 (selecting string! key from object!)

Red/System [
	Title:   "Object! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %object.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

object: context [
	verbose: 0

	class-id: 1'000'000									;-- base ID for dynamically created objects

	get-new-id: func [return: [integer!]][				;@@ protect from concurrent accesses
		class-id: class-id + 1
		class-id
	]

	rs-find: func [
		obj		 [red-object!]
		value	 [red-value!]
		return:	 [integer!]								;-- -1 if not found, else index
		/local
			word [red-word!]
			ctx	 [node!]
	][
		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: obj/ctx
		 _context/find-word TO_CTX(ctx) word/symbol yes
	]

	rs-select: func [
		obj		 [red-object!]
		value	 [red-value!]
		return:	 [red-value!]
		/local
			word   [red-word!]
			ctx	   [red-context!]
			values [series!]
			id	   [integer!]
	][
		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: GET_CTX(obj)
		id: _context/find-word ctx word/symbol yes
		if id = -1 [return as red-value! none-value]

		values: as series! ctx/values/value
		values/offset + id
	]

	get-word: func [
		obj		[node!]
		index	[integer!]
		return: [red-value!]
		/local
			ctx [red-context!]
			s   [series!]
	][
		ctx: TO_CTX(obj)
		s: as series! ctx/symbols/value
		s/offset + index
	]

	get-words: func [
		obj		[red-object!]
		return: [red-value!]
	][
		get-word obj/ctx 0
	]

	get-values: func [
		obj		[red-object!]
		return: [red-value!]
		/local
			ctx [red-context!]
			s   [series!]
	][
		ctx: GET_CTX(obj)
		s: as series! ctx/values/value
		s/offset
	]

	get-size: func [
		obj		[red-object!]
		return: [integer!]
		/local
			ctx [red-context!]
			s   [series!]
	][
		ctx: GET_CTX(obj)
		s: as series! ctx/symbols/value
		(as-integer s/tail - s/offset) >> 4
	]

	save-self-object: func [
		obj		[red-object!]
		return: [node!]
		/local
			int	 [red-integer!]
			node [node!]
			s	 [series!]
	][
		node: alloc-cells 1								;-- hidden object value storage used by SELF
		s: as series! node/value
		copy-cell as red-value! obj s/offset
		node
	]

	make-callback-node: func [
		ctx		[red-context!]
		index   [integer!]
		locals  [integer!]
		return: [node!]
		/local
			node [node!]
			int  [red-integer!]
			s	 [series!]
	][
		node: alloc-cells 2
		s: as series! node/value
		int: as red-integer! s/offset
		int/header: TYPE_INTEGER
		int/value: index

		int: as red-integer! s/offset + 1
		int/header: TYPE_INTEGER
		s: as series! ctx/values/value
		int/value: locals
		node
	]

	on-set-defined?: func [
		ctx		[red-context!]
		return: [node!]
		/local
			head   [red-word!]
			tail   [red-word!]
			word   [red-word!]
			fun	   [red-function!]
			s	   [series!]
			on-set [integer!]
			index  [integer!]
	][
		s:		as series! ctx/symbols/value
		head:	as red-word! s/offset
		tail:	as red-word! s/tail
		word:	head
		on-set:	words/_on-change*/symbol
		index:	-1

		while [all [index < 0 word < tail]][
			if on-set = symbol/resolve word/symbol [
				index: (as-integer word - head) >> 4
			]
			word: word + 1
		]
		if index = -1 [return null]						;-- callback is not found

		s: as series! ctx/values/value
		fun: as red-function! s/offset + index

		make-callback-node
			ctx
			index
			_function/calc-arity null fun 0				;-- passing a null path triggers short code branch
	]

	fire-on-set*: func [								;-- compiled code entry point
		parent [red-word!]
		field  [red-word!]
	][
		fire-on-set
			as red-object! _context/get parent
			field
			stack/top - 1
			stack/top - 2
	]

	fire-on-set: func [
		obj	 [red-object!]
		word [red-word!]
		old	 [red-value!]
		new	 [red-value!]
		/local
			fun	  [red-function!]
			int	  [red-integer!]
			index [integer!]
			count [integer!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/fire-on-set"]]

		assert TYPE_OF(obj) = TYPE_OBJECT
		assert obj/on-set <> null
		s: as series! obj/on-set/value

		int: as red-integer! s/offset
		assert TYPE_OF(int) = TYPE_INTEGER
		index: int/value

		int: as red-integer! s/offset + 1
		assert TYPE_OF(int) = TYPE_INTEGER
		count: int/value

		ctx: GET_CTX(obj)
		s: as series! ctx/values/value
		fun: as red-function! s/offset + index
		assert TYPE_OF(fun) = TYPE_FUNCTION

		stack/mark-func words/_on-change*
		stack/push as red-value! word
		stack/push old
		stack/push new
		if positive? count [_function/init-locals count]
		_function/call fun obj/ctx
		stack/unwind
	]

	unchanged?: func [
		word	[red-word!]
		id		[integer!]
		return: [logic!]
		/local
			obj [red-object!]
	][
		obj: as red-object! _context/get word
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	unchanged2?: func [
		node	[node!]
		index	[integer!]
		id		[integer!]
		return: [logic!]
		/local
			obj	   [red-object!]
			ctx	   [red-context!]
			values [series!]
	][
		ctx: TO_CTX(node)
		values: as series! ctx/values/value
		obj: as red-object! values/offset + index
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
			blank	[byte!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		if sym = s-tail [return part]					;-- exit if empty

		either flat? [
			indent?: no
			blank: space
		][
			if mold? [
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			blank: lf
		]

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			if TYPE_OF(value) = TYPE_VALUE [value/header: TYPE_UNSET] ;-- force uninitialized slot to UNSET
			if TYPE_OF(value) = TYPE_WORD [
				string/append-char GET_BUFFER(buffer) as-integer #"'" ;-- create a literal word
				part: part - 1
			]
			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer blank
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	transfer: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			word   [red-word!]
			symbol [red-value!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			idx	   [integer!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/symbols/value
		symbol: s/offset
		tail: s/tail

		s: as series! from/values/value
		value: s/offset

		s: as series! to/values/value
		target: s/offset

		while [symbol < tail][
			word: as red-word! symbol
			idx: _context/find-word to word/symbol yes

			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target + idx
					null
					yes
					null
			][
				copy-cell value target + idx			;-- just propagate the old value by default
			]
			symbol: symbol + 1
			value: value + 1
		]
	]

	duplicate: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/values/value
		value: s/offset
		tail:  s/tail

		s: as series! to/values/value
		target: s/offset

		while [value < tail][
			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target
					null
					yes
					null
			][
				copy-cell value target					;-- just propagate the old value by default
			]
			value: value + 1
			target: target + 1
		]
	]

	extend: func [
		ctx		[red-context!]
		spec	[red-context!]
		return: [logic!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			base  [red-value!]
			word  [red-word!]
			type  [integer!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		s: as series! ctx/values/value

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			if null? value [
				word: as red-word! syms
				value: s/offset + _context/find-word ctx word/symbol yes
				copy-cell vals value
			]
			type: TYPE_OF(value)
			case [
				ANY_SERIES?(type) [
					actions/copy
						as red-series! value
						value						;-- overwrite the value
						null
						yes
						null
				]
				type = TYPE_FUNCTION [
					rebind as red-function! value ctx
				]
				true [0]
			]
			syms: syms + 1
			vals: vals + 1
		]
		s: as series! ctx/symbols/value					;-- refreshing pointer
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
			blk  [red-block!]
			spec [red-block!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			fire [TO_ERROR(script bad-func-def) fun]
		]
		spec: as red-block! stack/push*
		spec/head: 0
		spec/node: fun/spec

		blk: block/clone as red-block! more yes yes
		_context/bind blk ctx null yes					;-- rebind new body to object
		_function/push spec blk	fun/ctx null null		;-- recreate function
		copy-cell stack/top - 1	as red-value! fun		;-- overwrite function slot in object
		stack/pop 2										;-- remove extra stack slots (block/clone and _function/push)

		s: as series! fun/more/value
		more: s/offset + 2
		more/header: TYPE_UNSET							;-- invalidate compiled body
	]

	init-push: func [
		node	[node!]
		class	[integer!]
		return: [red-object!]
		/local
			ctx [red-context!]
			obj	[red-object!]
	][
		ctx: TO_CTX(node)
		s: as series! ctx/values/value
		if s/offset = s/tail [
			s/tail: s/offset + (s/size >> 4)			;-- (late) setting of 'values right tail pointer
		]

		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	node
		obj/class:	class
		obj/on-set: null								;-- deferred setting, once object's body is evaluated
		obj
	]

	init-on-set: func [
		ctx	   [node!]
		index  [integer!]
		locals [integer!]
		/local
			obj [red-object!]
	][
		obj: as red-object! stack/top - 1
		assert TYPE_OF(obj) = TYPE_OBJECT
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
	]

	push: func [
		ctx		[node!]
		class	[integer!]
		index	[integer!]
		locals	[integer!]
		return: [red-object!]
		/local
			obj	[red-object!]
	][
		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	ctx
		obj/class:	class
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
		obj
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx:	_context/create slots no yes
		obj/class:	0
		obj/on-set: null
		obj
	]

	collect-couples: func [
		ctx	 	[red-context!]
		spec 	[red-block!]
		only?	[logic!]
		return: [logic!]
		/local
			cell   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			values [red-value!]
			base   [red-value!]
			word   [red-word!]
			s	   [series!]
			id	   [integer!]
			sym	   [integer!]
	][
		s: GET_BUFFER(spec)
		cell: s/offset
		tail: s/tail

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		s: as series! ctx/values/value
		values: s/offset

		while [cell < tail][
			if TYPE_OF(cell) = TYPE_SET_WORD [
				id: _context/add ctx as red-word! cell

				value: cell + 1							;-- fetch next value to assign
				while [all [
					TYPE_OF(value) = TYPE_SET_WORD
					value < tail
				]][
					value: value + 1
				]
				if value = tail [value: as red-value! none-value]

				if all [not only? TYPE_OF(value) = TYPE_WORD][ ;-- reduce the value if allowed
					word: as red-word! value
					sym: symbol/resolve word/symbol
					if any [
						sym = words/_true
						sym = words/_yes
						sym = words/_on
					][
						value: as red-value! true-value
					]
					if any [
						sym = words/_false
						sym = words/_no
						sym = words/_off
					][
						value: as red-value! false-value
					]
					if sym = words/none [value: as red-value! none-value]
				]

				copy-cell value values + id
			]
			cell: cell + 1
		]
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	construct: func [
		spec	[red-block!]
		proto	[red-object!]
		only?	[logic!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			ctx	 [red-context!]
	][
		obj: as red-object! stack/push*
		make-at obj 4								;-- arbitrary value
		ctx: GET_CTX(obj)
		unless null? proto [extend ctx GET_CTX(proto)]
		collect-couples ctx spec only?
		obj/class: get-new-id
		obj/on-set: null
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx	 [red-context!]
			blk	 [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				obj/class: either extend ctx GET_CTX(obj2) [get-new-id][proto/class]
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx save-self-object obj yes
				interpreter/eval blk no
				obj/class: get-new-id
				obj/on-set: on-set-defined? ctx
			]
			default [fire [TO_ERROR(syntax malconstruct) spec]]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			word  [red-word!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no no

				word: as red-word! block/rs-head blk
				tail: block/rs-tail blk

				while [word < as red-word! tail][
					word/ctx: obj/ctx
					word: word + 1
				]
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					word: as red-word! block/rs-append blk syms
					word/header: TYPE_SET_WORD
					word/ctx: obj/ctx

					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

	form: func [
		obj		[red-object!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/form"]]

		serialize obj buffer no no no arg part no 0 no
	]

	mold: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/mold"]]

		string/concatenate-literal buffer "make object! ["
		part: serialize obj buffer only? all? flat? arg part - 14 yes indent + 1 yes
		if indent > 0 [part: do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		path	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			word	[red-word!]
			ctx		[red-context!]
			old		[red-value!]
			on-set? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/eval-path"]]

		word: as red-word! element
		if TYPE_OF(word) <> TYPE_WORD [fire [TO_ERROR(script invalid-path) path element]]

		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol yes
			if word/index = -1 [
				fire [TO_ERROR(script invalid-path) path element]
			]
			word/ctx: parent/ctx
		]
		either value <> null [
			on-set?: parent/on-set <> null
			if on-set? [old: stack/push _context/get-in word ctx]
			_context/set-in word value ctx
			if on-set? [fire-on-set parent as red-word! element old value]
			value
		][
			_context/get-in word ctx
		]
	]

	compare: func [
		obj1	[red-object!]							;-- first operand
		obj2	[red-object!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return:	[integer!]
		/local
			ctx1   [red-context!]
			ctx2   [red-context!]
			sym1   [red-word!]
			sym2   [red-word!]
			tail   [red-word!]
			value1 [red-value!]
			value2 [red-value!]
			s	   [series!]
			diff   [integer!]
			s1	   [integer!]
			s2	   [integer!]
			type1  [integer!]
			type2  [integer!]
			res	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/compare"]]

		if TYPE_OF(obj2) <> TYPE_OBJECT [RETURN_COMPARE_OTHER]

		ctx1: GET_CTX(obj1)
		s: as series! ctx1/symbols/value
		sym1: as red-word! s/offset
		tail: as red-word! s/tail

		ctx2: GET_CTX(obj2)
		s: as series! ctx2/symbols/value

		diff: (as-integer s/tail - s/offset) - (as-integer tail - sym1)
		if diff <> 0 [
			return either positive? diff [-1][1]
		]
		if zero? (as-integer tail - sym1) [			;-- empty objects case
			return 0
		]

		sym2: as red-word! s/offset
		s: as series! ctx1/values/value
		value1: s/offset
		s: as series! ctx2/values/value
		value2: s/offset

		until [
			s1: symbol/resolve sym1/symbol
			s2: symbol/resolve sym2/symbol
			if s1 <> s2 [
				return SIGN_COMPARE_RESULT(s1 s2)
			]
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [											;@@ replace by ANY_NUMBER?
					any [type1 = TYPE_INTEGER type1 = TYPE_FLOAT]
					any [type2 = TYPE_INTEGER type2 = TYPE_FLOAT]
				]
			][
				res: actions/compare-value value1 value2 op
				sym1: sym1 + 1
				sym2: sym2 + 1
				value1: value1 + 1
				value2: value2 + 1
			][
				return SIGN_COMPARE_RESULT(type1 type2)
			]
			any [
				res <> 0
				sym1 >= tail
			]
		]
		res
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
			type  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			ERR_INVALID_REFINEMENT_ARG(refinements/_part part-arg)
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		copy-cell as cell! obj as cell! new
		new/ctx: _context/create slots no yes
		new/class: obj/class
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		value: dst/offset
		tail:  dst/tail

		either deep? [
			while [value < tail][
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					true [0]
				]
				value: value + 1
			]
		][
			while [value < tail][
				if TYPE_OF(value) = TYPE_FUNCTION [
					rebind as red-function! value nctx
				]
				value: value + 1
			]
		]
		new
	]

	find: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			id	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/find"]]

		id: rs-find obj value
		as red-value! either id = -1 [none-value][true-value]
	]

	select: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/select"]]

		rs-select obj value
	]

	init: does [
		datatype/register [
			TYPE_OBJECT
			TYPE_VALUE
			"object!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			:find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			:select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]

Red/System [
	Title:   "Object! datatype runtime functions"
	Author:  "Nenad Rakocevic"
	File: 	 %object.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/red/red/blob/master/BSL-License.txt
	}
]

object: context [
	verbose: 0

	class-id: 1'000'000									;-- base ID for dynamically created objects

	get-new-id: func [return: [integer!]][				;@@ protect from concurrent accesses
		class-id: class-id + 1
		class-id
	]

	rs-find: func [
		obj		 [red-object!]
		value	 [red-value!]
		return:	 [integer!]								;-- -1 if not found, else index
		/local
			word [red-word!]
			ctx	 [node!]
	][
		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: obj/ctx
		 _context/find-word TO_CTX(ctx) word/symbol yes
	]

	rs-select: func [
		obj		 [red-object!]
		value	 [red-value!]
		return:	 [red-value!]
		/local
			word   [red-word!]
			ctx	   [red-context!]
			values [series!]
			id	   [integer!]
	][
		assert any [									;@@ replace with ANY_WORD?
			TYPE_OF(value) = TYPE_WORD
			TYPE_OF(value) = TYPE_LIT_WORD
			TYPE_OF(value) = TYPE_GET_WORD
			TYPE_OF(value) = TYPE_SET_WORD
		]
		word: as red-word! value
		ctx: GET_CTX(obj)
		id: _context/find-word ctx word/symbol yes
		if id = -1 [return as red-value! none-value]

		values: as series! ctx/values/value
		values/offset + id
	]

	get-word: func [
		obj		[node!]
		index	[integer!]
		return: [red-value!]
		/local
			ctx [red-context!]
			s   [series!]
	][
		ctx: TO_CTX(obj)
		s: as series! ctx/symbols/value
		s/offset + index
	]

	get-words: func [
		obj		[red-object!]
		return: [red-value!]
	][
		get-word obj/ctx 0
	]

	get-values: func [
		obj		[red-object!]
		return: [red-value!]
		/local
			ctx [red-context!]
			s   [series!]
	][
		ctx: GET_CTX(obj)
		s: as series! ctx/values/value
		s/offset
	]

	get-size: func [
		obj		[red-object!]
		return: [integer!]
		/local
			ctx [red-context!]
			s   [series!]
	][
		ctx: GET_CTX(obj)
		s: as series! ctx/symbols/value
		(as-integer s/tail - s/offset) >> 4
	]

	save-self-object: func [
		obj		[red-object!]
		return: [node!]
		/local
			int	 [red-integer!]
			node [node!]
			s	 [series!]
	][
		node: alloc-cells 1								;-- hidden object value storage used by SELF
		s: as series! node/value
		copy-cell as red-value! obj s/offset
		node
	]

	make-callback-node: func [
		ctx		[red-context!]
		index   [integer!]
		locals  [integer!]
		return: [node!]
		/local
			node [node!]
			int  [red-integer!]
			s	 [series!]
	][
		node: alloc-cells 2
		s: as series! node/value
		int: as red-integer! s/offset
		int/header: TYPE_INTEGER
		int/value: index

		int: as red-integer! s/offset + 1
		int/header: TYPE_INTEGER
		s: as series! ctx/values/value
		int/value: locals
		node
	]

	on-set-defined?: func [
		ctx		[red-context!]
		return: [node!]
		/local
			head   [red-word!]
			tail   [red-word!]
			word   [red-word!]
			fun	   [red-function!]
			s	   [series!]
			on-set [integer!]
			index  [integer!]
	][
		s:		as series! ctx/symbols/value
		head:	as red-word! s/offset
		tail:	as red-word! s/tail
		word:	head
		on-set:	words/_on-change*/symbol
		index:	-1

		while [all [index < 0 word < tail]][
			if on-set = symbol/resolve word/symbol [
				index: (as-integer word - head) >> 4
			]
			word: word + 1
		]
		if index = -1 [return null]						;-- callback is not found

		s: as series! ctx/values/value
		fun: as red-function! s/offset + index

		make-callback-node
			ctx
			index
			_function/calc-arity null fun 0				;-- passing a null path triggers short code branch
	]

	fire-on-set*: func [								;-- compiled code entry point
		parent [red-word!]
		field  [red-word!]
	][
		fire-on-set
			as red-object! _context/get parent
			field
			stack/top - 1
			stack/top - 2
	]

	fire-on-set: func [
		obj	 [red-object!]
		word [red-word!]
		old	 [red-value!]
		new	 [red-value!]
		/local
			fun	  [red-function!]
			int	  [red-integer!]
			index [integer!]
			count [integer!]
			s	  [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/fire-on-set"]]

		assert TYPE_OF(obj) = TYPE_OBJECT
		assert obj/on-set <> null
		s: as series! obj/on-set/value

		int: as red-integer! s/offset
		assert TYPE_OF(int) = TYPE_INTEGER
		index: int/value

		int: as red-integer! s/offset + 1
		assert TYPE_OF(int) = TYPE_INTEGER
		count: int/value

		ctx: GET_CTX(obj)
		s: as series! ctx/values/value
		fun: as red-function! s/offset + index
		assert TYPE_OF(fun) = TYPE_FUNCTION

		stack/mark-func words/_on-change*
		stack/push as red-value! word
		stack/push old
		stack/push new
		if positive? count [_function/init-locals count]
		_function/call fun obj/ctx
		stack/unwind
	]

	unchanged?: func [
		word	[red-word!]
		id		[integer!]
		return: [logic!]
		/local
			obj [red-object!]
	][
		obj: as red-object! _context/get word
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	unchanged2?: func [
		node	[node!]
		index	[integer!]
		id		[integer!]
		return: [logic!]
		/local
			obj	   [red-object!]
			ctx	   [red-context!]
			values [series!]
	][
		ctx: TO_CTX(node)
		values: as series! ctx/values/value
		obj: as red-object! values/offset + index
		all [
			TYPE_OF(obj) = TYPE_OBJECT
			obj/class = id
		]
	]

	do-indent: func [
		buffer	[red-string!]
		tabs	[integer!]
		part	[integer!]
		return:	[integer!]
		/local
			n [integer!]
	][
		n: tabs
		until [
			string/concatenate-literal buffer "    "
			n: n - 1
			zero? n
		]
		part - (4 * tabs)
	]

	serialize: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent?	[logic!]
		tabs	[integer!]
		mold?	[logic!]
		return: [integer!]
		/local
			ctx		[red-context!]
			syms	[series!]
			values	[series!]
			sym		[red-value!]
			s-tail	[red-value!]
			value	[red-value!]
			blank	[byte!]
	][
		ctx: 	GET_CTX(obj)
		syms:   as series! ctx/symbols/value
		values: as series! ctx/values/value

		sym:	syms/offset
		s-tail: syms/tail
		value: 	values/offset

		if sym = s-tail [return part]					;-- exit if empty

		either flat? [
			indent?: no
			blank: space
		][
			if mold? [
				string/append-char GET_BUFFER(buffer) as-integer lf
				part: part - 1
			]
			blank: lf
		]

		while [sym < s-tail][
			if indent? [part: do-indent buffer tabs part]

			part: word/mold as red-word! sym buffer no no flat? arg part tabs
			string/concatenate-literal buffer ": "
			part: part - 2

			if TYPE_OF(value) = TYPE_VALUE [value/header: TYPE_UNSET] ;-- force uninitialized slot to UNSET
			if TYPE_OF(value) = TYPE_WORD [
				string/append-char GET_BUFFER(buffer) as-integer #"'" ;-- create a literal word
				part: part - 1
			]
			part: actions/mold value buffer only? all? flat? arg part tabs

			if any [indent? sym + 1 < s-tail][			;-- no final LF when FORMed
				string/append-char GET_BUFFER(buffer) as-integer blank
				part: part - 1
			]
			sym: sym + 1
			value: value + 1
		]
		part
	]

	transfer: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			word   [red-word!]
			symbol [red-value!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			idx	   [integer!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/symbols/value
		symbol: s/offset
		tail: s/tail

		s: as series! from/values/value
		value: s/offset

		s: as series! to/values/value
		target: s/offset

		while [symbol < tail][
			word: as red-word! symbol
			idx: _context/find-word to word/symbol yes

			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target + idx
					null
					yes
					null
			][
				copy-cell value target + idx			;-- just propagate the old value by default
			]
			symbol: symbol + 1
			value: value + 1
		]
	]

	duplicate: func [
		src    [node!]									;-- src context
		dst	   [node!]									;-- dst context (extension of src)
		/local
			from   [red-context!]
			to	   [red-context!]
			value  [red-value!]
			tail   [red-value!]
			target [red-value!]
			s	   [series!]
			type   [integer!]
	][
		from: TO_CTX(src)
		to:	  TO_CTX(dst)

		s: as series! from/values/value
		value: s/offset
		tail:  s/tail

		s: as series! to/values/value
		target: s/offset

		while [value < tail][
			type: TYPE_OF(value)
			either ANY_SERIES?(type) [					;-- copy series value in extended object
				actions/copy
					as red-series! value
					target
					null
					yes
					null
			][
				copy-cell value target					;-- just propagate the old value by default
			]
			value: value + 1
			target: target + 1
		]
	]

	extend: func [
		ctx		[red-context!]
		spec	[red-context!]
		return: [logic!]
		/local
			syms  [red-value!]
			tail  [red-value!]
			vals  [red-value!]
			value [red-value!]
			base  [red-value!]
			word  [red-word!]
			type  [integer!]
			s	  [series!]
	][
		s: as series! spec/symbols/value
		syms: s/offset
		tail: s/tail

		s: as series! spec/values/value
		vals: s/offset

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		s: as series! ctx/values/value

		while [syms < tail][
			value: _context/add-with ctx as red-word! syms vals

			if null? value [
				word: as red-word! syms
				value: s/offset + _context/find-word ctx word/symbol yes
				copy-cell vals value
			]
			type: TYPE_OF(value)
			case [
				ANY_SERIES?(type) [
					actions/copy
						as red-series! value
						value						;-- overwrite the value
						null
						yes
						null
				]
				type = TYPE_FUNCTION [
					rebind as red-function! value ctx
				]
				true [0]
			]
			syms: syms + 1
			vals: vals + 1
		]
		s: as series! ctx/symbols/value					;-- refreshing pointer
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	rebind: func [
		fun		[red-function!]
		ctx 	[red-context!]
		/local
			s	 [series!]
			more [red-value!]
			blk  [red-block!]
			spec [red-block!]
	][
		s: as series! fun/more/value
		more: s/offset

		if TYPE_OF(more) = TYPE_NONE [
			fire [TO_ERROR(script bad-func-def) fun]
		]
		spec: as red-block! stack/push*
		spec/head: 0
		spec/node: fun/spec

		blk: block/clone as red-block! more yes yes
		_context/bind blk ctx null yes					;-- rebind new body to object
		_function/push spec blk	fun/ctx null null		;-- recreate function
		copy-cell stack/top - 1	as red-value! fun		;-- overwrite function slot in object
		stack/pop 2										;-- remove extra stack slots (block/clone and _function/push)

		s: as series! fun/more/value
		more: s/offset + 2
		more/header: TYPE_UNSET							;-- invalidate compiled body
	]

	init-push: func [
		node	[node!]
		class	[integer!]
		return: [red-object!]
		/local
			ctx [red-context!]
			obj	[red-object!]
	][
		ctx: TO_CTX(node)
		s: as series! ctx/values/value
		if s/offset = s/tail [
			s/tail: s/offset + (s/size >> 4)			;-- (late) setting of 'values right tail pointer
		]

		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	node
		obj/class:	class
		obj/on-set: null								;-- deferred setting, once object's body is evaluated
		obj
	]

	init-on-set: func [
		ctx	   [node!]
		index  [integer!]
		locals [integer!]
		/local
			obj [red-object!]
	][
		obj: as red-object! stack/top - 1
		assert TYPE_OF(obj) = TYPE_OBJECT
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
	]

	push: func [
		ctx		[node!]
		class	[integer!]
		index	[integer!]
		locals	[integer!]
		return: [red-object!]
		/local
			obj	[red-object!]
	][
		obj: as red-object! stack/push*
		obj/header: TYPE_OBJECT
		obj/ctx:	ctx
		obj/class:	class
		obj/on-set: make-callback-node TO_CTX(ctx) index locals
		obj
	]

	make-at: func [
		obj		[red-object!]
		slots	[integer!]
		return: [red-object!]
	][
		obj/header: TYPE_OBJECT
		obj/ctx:	_context/create slots no yes
		obj/class:	0
		obj/on-set: null
		obj
	]

	collect-couples: func [
		ctx	 	[red-context!]
		spec 	[red-block!]
		only?	[logic!]
		return: [logic!]
		/local
			cell   [red-value!]
			tail   [red-value!]
			value  [red-value!]
			values [red-value!]
			base   [red-value!]
			word   [red-word!]
			s	   [series!]
			id	   [integer!]
			sym	   [integer!]
	][
		s: GET_BUFFER(spec)
		cell: s/offset
		tail: s/tail

		s: as series! ctx/symbols/value
		base: s/tail - s/offset

		s: as series! ctx/values/value
		values: s/offset

		while [cell < tail][
			if TYPE_OF(cell) = TYPE_SET_WORD [
				id: _context/add ctx as red-word! cell

				value: cell + 1							;-- fetch next value to assign
				while [all [
					TYPE_OF(value) = TYPE_SET_WORD
					value < tail
				]][
					value: value + 1
				]
				if value = tail [value: as red-value! none-value]

				if all [not only? TYPE_OF(value) = TYPE_WORD][ ;-- reduce the value if allowed
					word: as red-word! value
					sym: symbol/resolve word/symbol
					if any [
						sym = words/_true
						sym = words/_yes
						sym = words/_on
					][
						value: as red-value! true-value
					]
					if any [
						sym = words/_false
						sym = words/_no
						sym = words/_off
					][
						value: as red-value! false-value
					]
					if sym = words/none [value: as red-value! none-value]
				]

				copy-cell value values + id
			]
			cell: cell + 1
		]
		s/tail - s/offset > base						;-- TRUE: new words added
	]

	construct: func [
		spec	[red-block!]
		proto	[red-object!]
		only?	[logic!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			ctx	 [red-context!]
	][
		obj: as red-object! stack/push*
		make-at obj 4								;-- arbitrary value
		ctx: GET_CTX(obj)
		unless null? proto [extend ctx GET_CTX(proto)]
		collect-couples ctx spec only?
		obj/class: get-new-id
		obj/on-set: null
		obj
	]

	;-- Actions --

	make: func [
		proto	[red-object!]
		spec	[red-value!]
		return:	[red-object!]
		/local
			obj	 [red-object!]
			obj2 [red-object!]
			ctx	 [red-context!]
			blk	 [red-block!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/make"]]

		obj: as red-object! stack/push*

		either TYPE_OF(proto) = TYPE_OBJECT [
			copy proto obj null yes null				;-- /deep
		][
			make-at obj 4								;-- arbitrary value
		]
		ctx: GET_CTX(obj)

		switch TYPE_OF(spec) [
			TYPE_OBJECT [
				obj2: as red-object! spec
				obj/class: either extend ctx GET_CTX(obj2) [get-new-id][proto/class]
			]
			TYPE_BLOCK [
				blk: as red-block! spec
				_context/collect-set-words ctx blk
				_context/bind blk ctx save-self-object obj yes
				interpreter/eval blk no
				obj/class: get-new-id
				obj/on-set: on-set-defined? ctx
			]
			default [fire [TO_ERROR(syntax malconstruct) spec]]
		]
		obj
	]

	reflect: func [
		obj		[red-object!]
		field	[integer!]
		return:	[red-block!]
		/local
			ctx	  [red-context!]
			blk   [red-block!]
			syms  [red-value!]
			vals  [red-value!]
			tail  [red-value!]
			value [red-value!]
			word  [red-word!]
			s	  [series!]
	][
		blk: 		as red-block! stack/push*
		blk/header: TYPE_BLOCK
		blk/head: 	0

		ctx: GET_CTX(obj)

		case [
			field = words/words [
				blk/node: ctx/symbols
				blk: block/clone blk no no

				word: as red-word! block/rs-head blk
				tail: block/rs-tail blk

				while [word < as red-word! tail][
					word/ctx: obj/ctx
					word: word + 1
				]
			]
			field = words/values [
				blk/node: ctx/values
				blk: block/clone blk no no
			]
			field = words/body [
				blk/node: ctx/symbols
				blk/node: alloc-cells block/rs-length? blk

				s: as series! ctx/symbols/value
				syms: s/offset
				tail: s/tail

				s: as series! ctx/values/value
				vals: s/offset

				while [syms < tail][
					word: as red-word! block/rs-append blk syms
					word/header: TYPE_SET_WORD
					word/ctx: obj/ctx

					block/rs-append blk vals
					syms: syms + 1
					vals: vals + 1
				]
			]
			true [
				--NOT_IMPLEMENTED--						;@@ raise error
			]
		]
		as red-block! stack/set-last as red-value! blk
	]

	form: func [
		obj		[red-object!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/form"]]

		serialize obj buffer no no no arg part no 0 no
	]

	mold: func [
		obj		[red-object!]
		buffer	[red-string!]
		only?	[logic!]
		all?	[logic!]
		flat?	[logic!]
		arg		[red-value!]
		part	[integer!]
		indent	[integer!]
		return: [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/mold"]]

		string/concatenate-literal buffer "make object! ["
		part: serialize obj buffer only? all? flat? arg part - 14 yes indent + 1 yes
		if indent > 0 [part: do-indent buffer indent part]
		string/append-char GET_BUFFER(buffer) as-integer #"]"
		part - 1
	]

	eval-path: func [
		parent	[red-object!]							;-- implicit type casting
		element	[red-value!]
		value	[red-value!]
		path	[red-value!]
		case?	[logic!]
		return:	[red-value!]
		/local
			word	[red-word!]
			ctx		[red-context!]
			old		[red-value!]
			on-set? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/eval-path"]]

		word: as red-word! element
		assert TYPE_OF(word) = TYPE_WORD
		ctx:  GET_CTX(parent)

		if word/ctx <> parent/ctx [						;-- bind the word to object's context
			word/index: _context/find-word ctx word/symbol yes
			if word/index = -1 [
				fire [TO_ERROR(script invalid-path) path element]
			]
			word/ctx: parent/ctx
		]
		either value <> null [
			on-set?: parent/on-set <> null
			if on-set? [old: stack/push _context/get-in word ctx]
			_context/set-in word value ctx
			if on-set? [fire-on-set parent as red-word! element old value]
			value
		][
			_context/get-in word ctx
		]
	]

	compare: func [
		obj1	[red-object!]							;-- first operand
		obj2	[red-object!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return:	[integer!]
		/local
			ctx1   [red-context!]
			ctx2   [red-context!]
			sym1   [red-word!]
			sym2   [red-word!]
			tail   [red-word!]
			value1 [red-value!]
			value2 [red-value!]
			s	   [series!]
			diff   [integer!]
			s1	   [integer!]
			s2	   [integer!]
			type1  [integer!]
			type2  [integer!]
			res	   [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/compare"]]

		if TYPE_OF(obj2) <> TYPE_OBJECT [RETURN_COMPARE_OTHER]

		ctx1: GET_CTX(obj1)
		s: as series! ctx1/symbols/value
		sym1: as red-word! s/offset
		tail: as red-word! s/tail

		ctx2: GET_CTX(obj2)
		s: as series! ctx2/symbols/value

		diff: (as-integer s/tail - s/offset) - (as-integer tail - sym1)
		if diff <> 0 [
			return either positive? diff [-1][1]
		]
		if zero? (as-integer tail - sym1) [			;-- empty objects case
			return 0
		]

		sym2: as red-word! s/offset
		s: as series! ctx1/values/value
		value1: s/offset
		s: as series! ctx2/values/value
		value2: s/offset

		until [
			s1: symbol/resolve sym1/symbol
			s2: symbol/resolve sym2/symbol
			if s1 <> s2 [
				return SIGN_COMPARE_RESULT(s1 s2)
			]
			type1: TYPE_OF(value1)
			type2: TYPE_OF(value2)
			either any [
				type1 = type2
				all [word/any-word? type1 word/any-word? type2]
				all [											;@@ replace by ANY_NUMBER?
					any [type1 = TYPE_INTEGER type1 = TYPE_FLOAT]
					any [type2 = TYPE_INTEGER type2 = TYPE_FLOAT]
				]
			][
				res: actions/compare-value value1 value2 op
				sym1: sym1 + 1
				sym2: sym2 + 1
				value1: value1 + 1
				value2: value2 + 1
			][
				return SIGN_COMPARE_RESULT(type1 type2)
			]
			any [
				res <> 0
				sym1 >= tail
			]
		]
		res
	]

	copy: func [
		obj      [red-object!]
		new	  	 [red-object!]
		part-arg [red-value!]
		deep?	 [logic!]
		types	 [red-value!]
		return:	 [red-object!]
		/local
			ctx	  [red-context!]
			nctx  [red-context!]
			value [red-value!]
			tail  [red-value!]
			src	  [series!]
			dst	  [series!]
			size  [integer!]
			slots [integer!]
			type  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/copy"]]

		if OPTION?(types) [--NOT_IMPLEMENTED--]

		if OPTION?(part-arg) [
			ERR_INVALID_REFINEMENT_ARG(refinements/_part part-arg)
		]

		ctx:	GET_CTX(obj)
		src:	as series! ctx/symbols/value
		size:   as-integer src/tail - src/offset
		slots:	size >> 4

		copy-cell as cell! obj as cell! new
		new/ctx: _context/create slots no yes
		new/class: obj/class
		nctx: GET_CTX(new)

		;-- process SYMBOLS
		dst: as series! nctx/symbols/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots
		_context/set-context-each dst new/ctx

		;-- process VALUES
		src: as series! ctx/values/value
		dst: as series! nctx/values/value
		copy-memory as byte-ptr! dst/offset as byte-ptr! src/offset size
		dst/size: size
		dst/tail: dst/offset + slots

		value: dst/offset
		tail:  dst/tail

		either deep? [
			while [value < tail][
				type: TYPE_OF(value)
				case [
					ANY_SERIES?(type) [
						actions/copy
							as red-series! value
							value						;-- overwrite the value
							null
							yes
							null
					]
					type = TYPE_FUNCTION [
						rebind as red-function! value nctx
					]
					true [0]
				]
				value: value + 1
			]
		][
			while [value < tail][
				if TYPE_OF(value) = TYPE_FUNCTION [
					rebind as red-function! value nctx
				]
				value: value + 1
			]
		]
		new
	]

	find: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		tail?	 [logic!]
		match?	 [logic!]
		return:	 [red-value!]
		/local
			id	 [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/find"]]

		id: rs-find obj value
		as red-value! either id = -1 [none-value][true-value]
	]

	select: func [
		obj		 [red-object!]
		value	 [red-value!]
		part	 [red-value!]
		only?	 [logic!]
		case?	 [logic!]
		any?	 [logic!]
		with-arg [red-string!]
		skip	 [red-integer!]
		last?	 [logic!]
		reverse? [logic!]
		return:	 [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "object/select"]]

		rs-select obj value
	]

	init: does [
		datatype/register [
			TYPE_OBJECT
			TYPE_VALUE
			"object!"
			;-- General actions --
			:make
			null			;random
			:reflect
			null			;to
			:form
			:mold
			:eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			null			;negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			null			;and~
			null			;complement
			null			;or~
			null			;xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			null			;clear
			:copy
			:find
			null			;head
			null			;head?
			null			;index?
			null			;insert
			null			;length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			:select
			null			;sort
			null			;skip
			null			;swap
			null			;tail
			null			;tail?
			null			;take
			null			;trim
			;-- I/O actions --
			null			;create
			null			;close
			null			;delete
			null			;modify
			null			;open
			null			;open?
			null			;query
			null			;read
			null			;rename
			null			;update
			null			;write
		]
	]
]


TESTS: added few cross-reference tests.

TESTS: added few cross-reference tests.

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-test.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include %../../../../quick-test/quick-test.reds

~~~start-file~~~ "namespace"

    nmsp1: context [
      i: 123
      f: 1.23
      f32: as float32! 2.46
      l: true
      s: "my string"
      fn: func [pi [pointer! [integer!]] return: [integer!]] [pi/value: 789 789]
      fn2: func [
        i [integer!]
        return: [integer!]
      ][ 2 * i]
      st: declare struct! [
        a [integer!]
        b [integer!]
      ]
    ]

    i: 987
	ctx: context [
		i: 123
		j: "test"
		foo: func [return: [integer!]][
			i: i + 1
			i
		]
		--test-- "in-ns1"
		--assert 124 = foo
	]

===start-group=== "basic"

  --test-- "ns1"
  --assert 123 = nmsp1/i
  --test-- "ns2"
  --assert 1.23 = nmsp1/f
  --test-- "ns3"
  --assert (as float32! 2.46) = nmsp1/f32
  --test-- "ns4"
  --assert nmsp1/l
  --test-- "ns5"
  --assert nmsp1/s/1 = #"m"
  --assert nmsp1/s/2 = #"y"
  --assert nmsp1/s/3 = #" "
  --assert nmsp1/s/4 = #"s"
  --assert nmsp1/s/5 = #"t"
  --assert nmsp1/s/6 = #"r"
  --assert nmsp1/s/7 = #"i"
  --assert nmsp1/s/8 = #"n"
  --assert nmsp1/s/9 = #"g"
  --test-- "ns6"
    nmsp1/s: "hello"
  --assert 5 = length? nmsp1/s
  --test-- "ns7"
    ns1-b-i: 0
  --assert 789 = nmsp1/fn :ns1-b-i
  --test-- "ns8"
    ns1-b-i: 4
  --assert 8 = nmsp1/fn2 ns1-b-i
  --test-- "ns9"
    nmsp1/st/a: 1
  --assert nmsp1/st/a = 1
  --test-- "ns10"
  --assert ctx/j/1 = #"t"
  --test-- "ns11"
  --assert ctx/foo = 125
  --test-- "ns12"
    ctx/i: ctx/i + 1
  --assert ctx/i = 126
  --assert i = 987

===end-group===

===start-group=== "hiding"
    i: 321
    f: 3.21
    f32: as float32! 6.42
    l: false
    s: "not my string"
    fn: func [pi [pointer! [integer!]]] [pi/value: 987]
    fn2: func[
        i [integer!]
        return: [integer!]
      ][ 3 * i]
    st: declare struct! [
        a [integer!]
        b [integer!]
    ]

  --test-- "nmh1"
    nmsp1/i: 789
  --assert i = 321
  --test-- "nmh2"
    nmsp1/f: 7.89
  --assert f = 3.21
  --test-- "nmh3"
    nmsp1/f32: as float32! 7.89
  --assert nmsp1/f32 = as float32! 7.89
  --test-- "nmh4"
    nmsp1/s: "str"
  --assert 13 = length? s
  --test-- "nmh5"
    nmh5-i: 1
    nmsp1/fn :nmh5-i
  --assert 789 = nmh5-i
  --test-- "nmh6"
    nmh6-i: 1
    fn :nmh6-i
  --assert 987 = nmh6-i
  --test-- "nmh7"
    nmh7-i: 2
  --assert 4 = nmsp1/fn2 nmh7-i
  --assert 6 = fn2 nmh7-i
  --test-- "nmh8"
    st/a: 1
    st/b: 2
    nmsp1/st/a: 100
    nmsp1/st/b: 200
  --assert 1 = st/a
  --assert 2 = st/b

===end-group===

===start-group=== "initialisation"
    nmsp2: context [
      i: 2
      j: 3
      k: 0
      s: "12345"
      st: declare struct! [
        a [integer!]
        b [c-string!]
        c [float!]
        d [integer!]
      ]

      k: i * j
      s/1: #"h"
      s/2: #"e"
      s/3: #"l"
      s/4: #"l"
      s/5: #"o"
      st/a: 1
      st/b: "hello"
      st/c: 12345.678
      st/d: 1
      until [
        i: i * j
        j: j - 1
        j < 1
      ]
    ]
  --test-- "nmi1"
  --assert nmsp2/i = 12
  --test-- "nmi2"
  --assert nmsp2/j = 0
  --test-- "nmi3"
  --assert nmsp2/k = 6
  --test-- "nmi4"
  --assert nmsp2/s/1 = #"h"
  --assert nmsp2/s/2 = #"e"
  --assert nmsp2/s/3 = #"l"
  --assert nmsp2/s/4 = #"l"
  --assert nmsp2/s/5 = #"o"
  --test-- "nmi5"
  --assert nmsp2/st/a = 1
  --test-- "nmi6"
  --assert nmsp2/st/b/1 = #"h"
  --assert nmsp2/st/b/2 = #"e"
  --assert nmsp2/st/b/3 = #"l"
  --assert nmsp2/st/b/4 = #"l"
  --assert nmsp2/st/b/5 = #"o"
  --test-- "nmi7"
  --assert nmsp2/st/c = 12345.678
  --test-- "nmi8"
  --assert nmsp2/st/d = 1

===end-group===

===start-group=== "multiple"
    nmspa: context [
      i: 1
    ]
    nmspb: context [
      i: 2
    ]
    nmspc: context [
      i: 3
    ]
    nmspd: context [
      i: 4
    ]
    nmspe: context [
      i: 5
    ]
    nmspf: context [
      i: 6
    ]
    nmspg: context [
      i: 7
    ]
    nmsph: context [
      i: 8
    ]
    nmspi: context [
      i: 9
    ]
    nmspj: context [
      i: 10
    ]
    nmspk: context [
      i: 11
    ]
  --test-- "nmm1"
  --assert nmspa/i = 1
  --assert nmspb/i = 2
  --assert nmspc/i = 3
  --assert nmspd/i = 4
  --assert nmspe/i = 5
  --assert nmspf/i = 6
  --assert nmspg/i = 7
  --assert nmsph/i = 8
  --assert nmspi/i = 9
  --assert nmspj/i = 10
  --assert nmspk/i = 11

===end-group===

===start-group=== "global access"
  --test-- "nmga1"
    i2: 0
    j: 3
    nmsp3: context [
      i: 2
      k: i * j
      i2: 4
    ]
  --assert nmsp3/k = 6
  --assert nmsp3/i2 = 4
  --assert i2 = 0
  --test-- "nmga2"
      j3: 1
    nmsp4: context [
      i3: 2
      k3: i3 * j3
      i4: 4
    ]
    i4: 0
    j3: 3
  --assert nmsp4/k3 = 2
  --assert i4 = 0
===end-group===

===start-group=== "pointers"
  --test-- "nmp1"
    i: 12345
    nmsp5: context [
      pi: declare pointer! [integer!]
    ]
    nmsp5/pi: :i
  --assert nmsp5/pi/value = 12345
 ; --test-- "nmp2"						;-- getting a pointer on a variable in a context is not
 ;   pi: declare pointer! [integer!]	;-- a supported feature. Use a local function to get such
 ;   nmsp6: context [					;-- pointer.
 ;     i: 12345
 ;   ]
 ;   pi: :nmsp6/i
 ; --assert pi/value = 12345
===end-group===

===start-group=== "nesting"
  --test-- "nmm1"
    nmsp7: context [
      i: 0
      nmsp7-1: context [
        i: 1
        j: i * nmsp7/i
        nmsp7-2: context [
          i: 2
          j: i * nmsp7/i
          k: i * nmsp7/nmsp7-1/i
          nmsp7-3: context [
            i: 3
            j: i * nmsp7/i
            k: i * nmsp7/nmsp7-1/i
            l: i * nmsp7/nmsp7-1/nmsp7-2/i
          ]
        ]
      ]
    ]
  --assert nmsp7/i = 0
  --assert nmsp7/nmsp7-1/i = 1
  --assert nmsp7/nmsp7-1/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/i = 2
  --assert nmsp7/nmsp7-1/nmsp7-2/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/k = 2
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/i = 3
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/k = 3
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/l = 6
===end-group===

===start-group=== "include"
  --test-- "nminc1"
    nmsp8: context [
      #include %namespace-test-include.reds
    ]
  --assert 54321 = nmsp8/i

===end-group===

===start-group=== "libs"
    nmsp-lib: context [
      #import [
        LIBM-file cdecl [
          abs-int: "abs" [
            i       [integer!]
            return: [integer!]
          ]
        ]
      ]
      #import [
        LIBC-file cdecl [
          strnlen: "strnlen" [
            str     [c-string!]
            maxlen  [integer!]
            return: [integer!]
          ]
        ]
      ]
    ]
  --test-- "nmlibs1"
  --assert 1 = nmsp-lib/abs-int -1
  --test-- "nmlibs2"
  --assert 11 = nmsp-lib/strnlen "hello world" 20

===end-group===

===start-group=== "cross-reference"

	nmxr1: context [c: 789 fooo: func [][nmxr2/e: 123]]
	nmxr2: context [e: 456 f: nmxr1/c]

	--test-- "ns-cross-1"
	--assert nmxr2/e = 456
	nmxr1/fooo
	--assert nmxr2/e = 123

	--test-- "ns-cross-2"
	--assert nmxr2/f = 789

===end-group===

~~~end-file~~~

Red/System [
	Title:   "Red/System null test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %namespace-test.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic & Peter W A Wood. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/origin/BSD-3-License.txt"
]

#include %../../../../quick-test/quick-test.reds

~~~start-file~~~ "namespace"

    nmsp1: context [
      i: 123
      f: 1.23
      f32: as float32! 2.46
      l: true
      s: "my string"
      fn: func [pi [pointer! [integer!]] return: [integer!]] [pi/value: 789 789]
      fn2: func [
        i [integer!]
        return: [integer!]
      ][ 2 * i]
      st: declare struct! [
        a [integer!]
        b [integer!]
      ]
    ]

    i: 987
	ctx: context [
		i: 123
		j: "test"
		foo: func [return: [integer!]][
			i: i + 1
			i
		]
		--test-- "in-ns1"
		--assert 124 = foo
	]

===start-group=== "basic"

  --test-- "ns1"
  --assert 123 = nmsp1/i
  --test-- "ns2"
  --assert 1.23 = nmsp1/f
  --test-- "ns3"
  --assert (as float32! 2.46) = nmsp1/f32
  --test-- "ns4"
  --assert nmsp1/l
  --test-- "ns5"
  --assert nmsp1/s/1 = #"m"
  --assert nmsp1/s/2 = #"y"
  --assert nmsp1/s/3 = #" "
  --assert nmsp1/s/4 = #"s"
  --assert nmsp1/s/5 = #"t"
  --assert nmsp1/s/6 = #"r"
  --assert nmsp1/s/7 = #"i"
  --assert nmsp1/s/8 = #"n"
  --assert nmsp1/s/9 = #"g"
  --test-- "ns6"
    nmsp1/s: "hello"
  --assert 5 = length? nmsp1/s
  --test-- "ns7"
    ns1-b-i: 0
  --assert 789 = nmsp1/fn :ns1-b-i
  --test-- "ns8"
    ns1-b-i: 4
  --assert 8 = nmsp1/fn2 ns1-b-i
  --test-- "ns9"
    nmsp1/st/a: 1
  --assert nmsp1/st/a = 1
  --test-- "ns10"
  --assert ctx/j/1 = #"t"
  --test-- "ns11"
  --assert ctx/foo = 125
  --test-- "ns12"
    ctx/i: ctx/i + 1
  --assert ctx/i = 126
  --assert i = 987

===end-group===

===start-group=== "hiding"
    i: 321
    f: 3.21
    f32: as float32! 6.42
    l: false
    s: "not my string"
    fn: func [pi [pointer! [integer!]]] [pi/value: 987]
    fn2: func[
        i [integer!]
        return: [integer!]
      ][ 3 * i]
    st: declare struct! [
        a [integer!]
        b [integer!]
    ]

  --test-- "nmh1"
    nmsp1/i: 789
  --assert i = 321
  --test-- "nmh2"
    nmsp1/f: 7.89
  --assert f = 3.21
  --test-- "nmh3"
    nmsp1/f32: as float32! 7.89
  --assert nmsp1/f32 = as float32! 7.89
  --test-- "nmh4"
    nmsp1/s: "str"
  --assert 13 = length? s
  --test-- "nmh5"
    nmh5-i: 1
    nmsp1/fn :nmh5-i
  --assert 789 = nmh5-i
  --test-- "nmh6"
    nmh6-i: 1
    fn :nmh6-i
  --assert 987 = nmh6-i
  --test-- "nmh7"
    nmh7-i: 2
  --assert 4 = nmsp1/fn2 nmh7-i
  --assert 6 = fn2 nmh7-i
  --test-- "nmh8"
    st/a: 1
    st/b: 2
    nmsp1/st/a: 100
    nmsp1/st/b: 200
  --assert 1 = st/a
  --assert 2 = st/b

===end-group===

===start-group=== "initialisation"
    nmsp2: context [
      i: 2
      j: 3
      k: 0
      s: "12345"
      st: declare struct! [
        a [integer!]
        b [c-string!]
        c [float!]
        d [integer!]
      ]

      k: i * j
      s/1: #"h"
      s/2: #"e"
      s/3: #"l"
      s/4: #"l"
      s/5: #"o"
      st/a: 1
      st/b: "hello"
      st/c: 12345.678
      st/d: 1
      until [
        i: i * j
        j: j - 1
        j < 1
      ]
    ]
  --test-- "nmi1"
  --assert nmsp2/i = 12
  --test-- "nmi2"
  --assert nmsp2/j = 0
  --test-- "nmi3"
  --assert nmsp2/k = 6
  --test-- "nmi4"
  --assert nmsp2/s/1 = #"h"
  --assert nmsp2/s/2 = #"e"
  --assert nmsp2/s/3 = #"l"
  --assert nmsp2/s/4 = #"l"
  --assert nmsp2/s/5 = #"o"
  --test-- "nmi5"
  --assert nmsp2/st/a = 1
  --test-- "nmi6"
  --assert nmsp2/st/b/1 = #"h"
  --assert nmsp2/st/b/2 = #"e"
  --assert nmsp2/st/b/3 = #"l"
  --assert nmsp2/st/b/4 = #"l"
  --assert nmsp2/st/b/5 = #"o"
  --test-- "nmi7"
  --assert nmsp2/st/c = 12345.678
  --test-- "nmi8"
  --assert nmsp2/st/d = 1

===end-group===

===start-group=== "multiple"
    nmspa: context [
      i: 1
    ]
    nmspb: context [
      i: 2
    ]
    nmspc: context [
      i: 3
    ]
    nmspd: context [
      i: 4
    ]
    nmspe: context [
      i: 5
    ]
    nmspf: context [
      i: 6
    ]
    nmspg: context [
      i: 7
    ]
    nmsph: context [
      i: 8
    ]
    nmspi: context [
      i: 9
    ]
    nmspj: context [
      i: 10
    ]
    nmspk: context [
      i: 11
    ]
  --test-- "nmm1"
  --assert nmspa/i = 1
  --assert nmspb/i = 2
  --assert nmspc/i = 3
  --assert nmspd/i = 4
  --assert nmspe/i = 5
  --assert nmspf/i = 6
  --assert nmspg/i = 7
  --assert nmsph/i = 8
  --assert nmspi/i = 9
  --assert nmspj/i = 10
  --assert nmspk/i = 11

===end-group===

===start-group=== "global access"
  --test-- "nmga1"
    i2: 0
    j: 3
    nmsp3: context [
      i: 2
      k: i * j
      i2: 4
    ]
  --assert nmsp3/k = 6
  --assert nmsp3/i2 = 4
  --assert i2 = 0
  --test-- "nmga2"
      j3: 1
    nmsp4: context [
      i3: 2
      k3: i3 * j3
      i4: 4
    ]
    i4: 0
    j3: 3
  --assert nmsp4/k3 = 2
  --assert i4 = 0
===end-group===

===start-group=== "pointers"
  --test-- "nmp1"
    i: 12345
    nmsp5: context [
      pi: declare pointer! [integer!]
    ]
    nmsp5/pi: :i
  --assert nmsp5/pi/value = 12345
 ; --test-- "nmp2"						;-- getting a pointer on a variable in a context is not
 ;   pi: declare pointer! [integer!]	;-- a supported feature. Use a local function to get such
 ;   nmsp6: context [					;-- pointer.
 ;     i: 12345
 ;   ]
 ;   pi: :nmsp6/i
 ; --assert pi/value = 12345
===end-group===

===start-group=== "nesting"
  --test-- "nmm1"
    nmsp7: context [
      i: 0
      nmsp7-1: context [
        i: 1
        j: i * nmsp7/i
        nmsp7-2: context [
          i: 2
          j: i * nmsp7/i
          k: i * nmsp7/nmsp7-1/i
          nmsp7-3: context [
            i: 3
            j: i * nmsp7/i
            k: i * nmsp7/nmsp7-1/i
            l: i * nmsp7/nmsp7-1/nmsp7-2/i
          ]
        ]
      ]
    ]
  --assert nmsp7/i = 0
  --assert nmsp7/nmsp7-1/i = 1
  --assert nmsp7/nmsp7-1/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/i = 2
  --assert nmsp7/nmsp7-1/nmsp7-2/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/k = 2
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/i = 3
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/j = 0
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/k = 3
  --assert nmsp7/nmsp7-1/nmsp7-2/nmsp7-3/l = 6
===end-group===

===start-group=== "include"
  --test-- "nminc1"
    nmsp8: context [
      #include %namespace-test-include.reds
    ]
  --assert 54321 = nmsp8/i

===end-group===

===start-group=== "libs"
    nmsp-lib: context [
      #import [
        LIBM-file cdecl [
          abs-int: "abs" [
            i       [integer!]
            return: [integer!]
          ]
        ]
      ]
      #import [
        LIBC-file cdecl [
          strnlen: "strnlen" [
            str     [c-string!]
            maxlen  [integer!]
            return: [integer!]
          ]
        ]
      ]
    ]
  --test-- "nmlibs1"
  --assert 1 = nmsp-lib/abs-int -1
  --test-- "nmlibs2"
  --assert 11 = nmsp-lib/strnlen "hello world" 20

~~~end-file~~~