TESTS: commented out a non-valid test.

TESTS: commented out a non-valid test.

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
  --test-- "ns13"
    ns13i: 1
    ns13i-nsp: context [
      ns13i: 2
      get-ns13i: func [return: [integer!]] [ns13i]
    ]
  --assert 2 = ns13i-nsp/get-ns13i

===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 using a path
  ;   pi: declare pointer! [integer!]	;-- is not a supported feature. Use a local function to
  ;   nmsp6: context [					;-- get such pointer.
  ;     i: 12345
  ;   ]
  ;   pi: :nmsp6/i
  ; --assert pi/value = 12345
  --test-- "nmp3"
    nmsp6a: context [
      i: 67890
      get-addr-i: func [
        return: [pointer! [integer!]]
      ][
        :i
      ]
    ]
    pinmp3: declare pointer! [integer!]
    pinmp3: nmsp6a/get-addr-i
  --assert 67890 = pinmp3/value

===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 i = 2
          --assert j = 0
          --assert k = 2
		  --assert nmsp7/i = 0
		  --assert nmsp7/nmsp7-1/i = 1
		  --assert nmsp7/nmsp7-1/j = 0
        ]
        --assert i = 1
        --assert j = 0
        --assert nmsp7/i = 0
      ]
      --assert i = 0
    ]
  --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===

===start-group=== "with"
  --test-- "nsw1"
    nsw1-nsp: context [b: 123]
    with nsw1-nsp [
      --assert b = 123
    ]

  --test-- "nsw2"
    nsw2-nsp1: context [b: 123]
    nsw2-nsp2: context [b: 456]
    with [nsw2-nsp1 nsw2-nsp2] [
      --assert b = 123
      --assert nsw2-nsp1/b = 123
      --assert nsw2-nsp2/b = 456
    ]

  --test-- "nsw3"
    nsw3-nsp1: context [z: declare pointer! [integer!] fooo: func [][nsw3-nsp2/e: 123]]
    nsw3-nsp2: context [e: 456]

    with nsw3-nsp1 [
      c: 123
      z: null
    ]
	--assert nsw3-nsp1/z = null

	  e: -1
	  with [nsw3-nsp1 nsw3-nsp2][
	    fooo
	    --assert e = 123
	  ]
	--assert e = -1

	--test-- "nsw4"
    nsw4-nsp1: context [e: 456]
    nsw4-nsp2: context [fooo: func [][e: 123]]
    with [nsw4-nsp1 nsw4-nsp2] [
      fooo
      --assert e = 456
    ]

===end-group===

===start-group=== "System/Words"

  --test-- "nssw1"
    nssw1-a: 1
    nssw1-nmsp: context [
      nssw1-a: 2
      --assert 1 = system/words/nssw1-a
      --assert 2 = nssw1-a
      system/words/nssw1-a: 3
    ]
  --assert nssw1-a = 3

  --test-- "nssw2"
    nssw2-i: 1
    nssw2-nmsp: context [
      nssw2-i: 2
      pi: declare pointer! [integer!]
      pi: :nssw2-i
      --assert pi/value = 2
    ]
  --assert nssw2-i = 1

===end-group===

===start-group=== "context as local variable"
  ;--test-- "nscaslv1"
  ;  nsca1-nsmp1: context [
  ;    context: 1  							;-- this is not allowed as contexts can be nested, so
  ;  ]										;-- you can't redefine 'context word there, but only
  ;--assert nsca1-nsmp1/context 1			;-- in a function's body.
  --test-- "nscasv2"
    nsca2-f: function [
      return: [integer!]
      /local
        context
    ][
      context: 1
      context
    ]
  --assert nsca2-f = 1

===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
  --test-- "ns13"
    ns13i: 1
    ns13i-nsp: context [
      ns13i: 2
      get-ns13i: func [return: [integer!]] [ns13i]
    ]
  --assert 2 = ns13i-nsp/get-ns13i

===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 using a path
  ;   pi: declare pointer! [integer!]	;-- is not a supported feature. Use a local function to
  ;   nmsp6: context [					;-- get such pointer.
  ;     i: 12345
  ;   ]
  ;   pi: :nmsp6/i
  ; --assert pi/value = 12345
  --test-- "nmp3"
    nmsp6a: context [
      i: 67890
      get-addr-i: func [
        return: [pointer! [integer!]]
      ][
        :i
      ]
    ]
    pinmp3: declare pointer! [integer!]
    pinmp3: nmsp6a/get-addr-i
  --assert 67890 = pinmp3/value

===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 i = 2
          --assert j = 0
          --assert k = 2
		  --assert nmsp7/i = 0
		  --assert nmsp7/nmsp7-1/i = 1
		  --assert nmsp7/nmsp7-1/j = 0
        ]
        --assert i = 1
        --assert j = 0
        --assert nmsp7/i = 0
      ]
      --assert i = 0
    ]
  --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===

===start-group=== "with"
  --test-- "nsw1"
    nsw1-nsp: context [b: 123]
    with nsw1-nsp [
      --assert b = 123
    ]

  --test-- "nsw2"
    nsw2-nsp1: context [b: 123]
    nsw2-nsp2: context [b: 456]
    with [nsw2-nsp1 nsw2-nsp2] [
      --assert b = 123
      --assert nsw2-nsp1/b = 123
      --assert nsw2-nsp2/b = 456
    ]

  --test-- "nsw3"
    nsw3-nsp1: context [z: declare pointer! [integer!] fooo: func [][nsw3-nsp2/e: 123]]
    nsw3-nsp2: context [e: 456]

    with nsw3-nsp1 [
      c: 123
      z: null
    ]
	--assert nsw3-nsp1/z = null

	  e: -1
	  with [nsw3-nsp1 nsw3-nsp2][
	    fooo
	    --assert e = 123
	  ]
	--assert e = -1

	--test-- "nsw4"
    nsw4-nsp1: context [e: 456]
    nsw4-nsp2: context [fooo: func [][e: 123]]
    with [nsw4-nsp1 nsw4-nsp2] [
      fooo
      --assert e = 456
    ]

===end-group===

===start-group=== "System/Words"

  --test-- "nssw1"
    nssw1-a: 1
    nssw1-nmsp: context [
      nssw1-a: 2
      --assert 1 = system/words/nssw1-a
      --assert 2 = nssw1-a
      system/words/nssw1-a: 3
    ]
  --assert nssw1-a = 3

  --test-- "nssw2"
    nssw2-i: 1
    nssw2-nmsp: context [
      nssw2-i: 2
      pi: declare pointer! [integer!]
      pi: :nssw2-i
      --assert pi/value = 2
    ]
  --assert nssw2-i = 1

===end-group===

===start-group=== "context as local variable"
  --test-- "nscaslv1"
    nsca1-nsmp1: context [
      context: 1
    ]
  --assert nsca1-nsmp1/context 1
  --test-- "nscasv2"
    nsca2-f: function [
      return: [integer!]
      /local
        context
    ][
      context: 1
      context
    ]
  --assert nsca2-f = 1

===end-group===

~~~end-file~~~


FEAT: reduced verbosity of the preset words/symbols.

Red/System [
	Title:   "Common datatypes utility functions"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

names!: alias struct! [
	buffer	[c-string!]								;-- datatype name string
	size	[integer!]								;-- buffer size - 1 (not counting terminal `!`)
	word	[red-word!]								;-- datatype name as word! value
]

name-table:   declare names! 						;-- datatype names table
action-table: declare int-ptr!						;-- actions jump table

set-type: func [										;@@ convert to macro?
	cell [cell!]
	type [integer!]
][
	cell/header: cell/header and type-mask or type
]

alloc-at-tail: func [
	blk		[red-block!]
	return: [cell!]
][
	alloc-tail as series! blk/node/value
]

alloc-tail: func [
	s		 [series!]
	return:  [cell!]
	/local
		cell [red-value!]
][
	if (as byte-ptr! s/tail + 1) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	cell: s/tail
	;-- ensure that cell is within series upper boundary
	assert (as byte-ptr! cell) < ((as byte-ptr! s + 1) + s/size)

	s/tail: cell + 1									;-- move tail to next cell
	cell
]

alloc-tail-unit: func [
	s		 [series!]
	unit 	 [integer!]
	return:  [byte-ptr!]
	/local
		p	 [byte-ptr!]
][
	if ((as byte-ptr! s/tail) + unit) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	p: as byte-ptr! s/tail
	;-- ensure that cell is within series upper boundary
	assert p < ((as byte-ptr! s + 1) + s/size)

	s/tail: as cell! p + unit							;-- move tail to next unit slot
	p
]

copy-cell: func [
	src		[cell!]
	dst		[cell!]
	return: [red-value!]
][
	copy-memory											;@@ optimize for 16 bytes copying
		as byte-ptr! dst
		as byte-ptr! src
		size? cell!
	dst
]

words: context [
	spec:			-1
	body:			-1
	words:			-1
	logic!:			-1
	integer!:		-1
	repeat:			-1
	foreach:		-1
	map-each:		-1
	remove-each:	-1
	exit*:			-1
	return*:		-1

	any*:			-1
	break*:			-1
	copy:			-1
	end:			-1
	fail:			-1
	into:			-1
	opt:			-1
	not*:			-1
	quote:			-1
	reject:			-1
	set:			-1
	skip:			-1
	some:			-1
	thru:			-1
	to:				-1
	none:			-1
	pipe:			-1
	dash:			-1
	then:			-1
	if*:			-1
	remove:			-1
	while*:			-1

	_body:			as red-word! 0
	_windows:		as red-word! 0
	_syllable:		as red-word! 0
	_macosx:		as red-word! 0
	_linux:			as red-word! 0

	build: does [
		spec:			symbol/make "spec"
		body:			symbol/make "body"
		words:			symbol/make "words"
		logic!:			symbol/make "logic!"
		integer!:		symbol/make "integer!"
		exit*:			symbol/make "exit"
		return*:		symbol/make "return"

		windows:		symbol/make "Windows"
		syllable:		symbol/make "Syllable"
		macosx:			symbol/make "MacOSX"
		linux:			symbol/make "Linux"

		repeat:			symbol/make "repeat"
		foreach:		symbol/make "foreach"
		map-each:		symbol/make "map-each"
		remove-each:	symbol/make "remove-each"

		any*:			symbol/make "any"
		break*:			symbol/make "break"
		copy:			symbol/make "copy"
		end:			symbol/make "end"
		fail:			symbol/make "fail"
		into:			symbol/make "into"
		opt:			symbol/make "opt"
		not*:			symbol/make "not"
		quote:			symbol/make "quote"
		reject:			symbol/make "reject"
		set:			symbol/make "set"
		skip:			symbol/make "skip"
		some:			symbol/make "some"
		thru:			symbol/make "thru"
		to:				symbol/make "to"
		none:			symbol/make "none"
		pipe:			symbol/make "|"
		dash:			symbol/make "-"
		then:			symbol/make "then"
		if*:			symbol/make "if"
		remove:			symbol/make "remove"
		while*:			symbol/make "while"

		_body:			_context/add-global body
		_windows:		_context/add-global windows
		_syllable:		_context/add-global syllable
		_macosx:		_context/add-global macosx
		_linux:			_context/add-global linux
	]
]

refinements: context [
	local: 		as red-refinement! 0
	extern: 	as red-refinement! 0

	build: does [
		local:	refinement/load "local"
		extern:	refinement/load "extern"
	]
]

Red/System [
	Title:   "Common datatypes utility functions"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

names!: alias struct! [
	buffer	[c-string!]								;-- datatype name string
	size	[integer!]								;-- buffer size - 1 (not counting terminal `!`)
	word	[red-word!]								;-- datatype name as word! value
]

name-table:   declare names! 						;-- datatype names table
action-table: declare int-ptr!						;-- actions jump table

set-type: func [										;@@ convert to macro?
	cell [cell!]
	type [integer!]
][
	cell/header: cell/header and type-mask or type
]

alloc-at-tail: func [
	blk		[red-block!]
	return: [cell!]
][
	alloc-tail as series! blk/node/value
]

alloc-tail: func [
	s		 [series!]
	return:  [cell!]
	/local
		cell [red-value!]
][
	if (as byte-ptr! s/tail + 1) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	cell: s/tail
	;-- ensure that cell is within series upper boundary
	assert (as byte-ptr! cell) < ((as byte-ptr! s + 1) + s/size)

	s/tail: cell + 1									;-- move tail to next cell
	cell
]

alloc-tail-unit: func [
	s		 [series!]
	unit 	 [integer!]
	return:  [byte-ptr!]
	/local
		p	 [byte-ptr!]
][
	if ((as byte-ptr! s/tail) + unit) > ((as byte-ptr! s + 1) + s/size) [
		s: expand-series s 0
	]

	p: as byte-ptr! s/tail
	;-- ensure that cell is within series upper boundary
	assert p < ((as byte-ptr! s + 1) + s/size)

	s/tail: as cell! p + unit							;-- move tail to next unit slot
	p
]

copy-cell: func [
	src		[cell!]
	dst		[cell!]
	return: [red-value!]
][
	copy-memory											;@@ optimize for 16 bytes copying
		as byte-ptr! dst
		as byte-ptr! src
		size? cell!
	dst
]

words: context [
	_spec:			as red-word! 0
	_body:			as red-word! 0
	_words:			as red-word! 0
	_logic!:		as red-word! 0
	_integer!:		as red-word! 0
	_windows:		as red-word! 0
	_syllable:		as red-word! 0
	_macosx:		as red-word! 0
	_linux:			as red-word! 0
	_repeat:		as red-word! 0
	_foreach:		as red-word! 0
	_map-each:		as red-word! 0
	_remove-each:	as red-word! 0
	_exit:			as red-word! 0
	_return:		as red-word! 0

	_any:			as red-word! 0
	_copy:			as red-word! 0
	_end:			as red-word! 0
	_fail:			as red-word! 0
	_into:			as red-word! 0
	_opt:			as red-word! 0
	_not:			as red-word! 0
	_quote:			as red-word! 0
	_reject:		as red-word! 0
	_set:			as red-word! 0
	_skip:			as red-word! 0
	_some:			as red-word! 0
	_thru:			as red-word! 0
	_to:			as red-word! 0
	_none:			as red-word! 0
	_pipe:			as red-word! 0
	_dash:			as red-word! 0
	_then:			as red-word! 0
	_if:			as red-word! 0
	_remove:		as red-word! 0
	_while:			as red-word! 0

	spec:			-1
	body:			-1
	words:			-1
	logic!:			-1
	integer!:		-1
	repeat:			-1
	foreach:		-1
	map-each:		-1
	remove-each:	-1
	exit*:			-1
	return*:		-1

	any*:			-1
	break*:			-1
	copy:			-1
	end:			-1
	fail:			-1
	into:			-1
	opt:			-1
	not*:			-1
	quote:			-1
	reject:			-1
	set:			-1
	skip:			-1
	some:			-1
	thru:			-1
	to:				-1
	none:			-1
	pipe:			-1
	dash:			-1
	then:			-1
	if*:			-1
	remove:			-1
	while*:			-1

	build: does [
		_spec:			word/load "spec"
		_body:			word/load "body"
		_words:			word/load "words"
		_logic!:		word/load "logic!"
		_integer!:		word/load "integer!"
		_exit:			word/load "exit"
		_return:		word/load "return"

		_windows:		word/load "Windows"
		_syllable:		word/load "Syllable"
		_macosx:		word/load "MacOSX"
		_linux:			word/load "Linux"

		_repeat:		word/load "repeat"
		_foreach:		word/load "foreach"
		_map-each:		word/load "map-each"
		_remove-each:	word/load "remove-each"

		_any:			word/load "any"
		_break:			word/load "break"
		_copy:			word/load "copy"
		_end:			word/load "end"
		_fail:			word/load "fail"
		_into:			word/load "into"
		_opt:			word/load "opt"
		_not:			word/load "not"
		_quote:			word/load "quote"
		_reject:		word/load "reject"
		_set:			word/load "set"
		_skip:			word/load "skip"
		_some:			word/load "some"
		_thru:			word/load "thru"
		_to:			word/load "to"
		_none:			word/load "none"
		_pipe:			word/load "|"
		_dash:			word/load "-"
		_then:			word/load "then"
		_if:			word/load "if"
		_remove:		word/load "remove"
		_while:			word/load "while"

		spec:			_spec/symbol
		body:			_body/symbol
		words:			_words/symbol
		logic!:			_logic!/symbol
		integer!:		_integer!/symbol
		repeat:			_repeat/symbol
		foreach:		_foreach/symbol
		map-each:		_map-each/symbol
		remove-each:	_remove-each/symbol
		exit*:			_exit/symbol
		return*:		_return/symbol

		any*:			_any/symbol
		break*:			_break/symbol
		copy:			_copy/symbol
		end:			_end/symbol
		fail:			_fail/symbol
		into:			_into/symbol
		opt:			_opt/symbol
		not*:			_not/symbol
		quote:			_quote/symbol
		reject:			_reject/symbol
		set:			_set/symbol
		skip:			_skip/symbol
		some:			_some/symbol
		thru:			_thru/symbol
		to:				_to/symbol
		none:			_none/symbol
		pipe:			_pipe/symbol
		dash:			_dash/symbol
		then:			_then/symbol
		if*:			_if/symbol
		remove:			_remove/symbol
		while*:			_while/symbol
	]
]

refinements: context [
	local: 		as red-refinement! 0
	extern: 	as red-refinement! 0

	build: does [
		local:	refinement/load "local"
		extern:	refinement/load "extern"
	]
]


FIX: issue #497 (DO doesn't evaluate path!)

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

#define RETURN_NONE [
	stack/reset
	none/push-last
	exit
]

#define RETURN_UNSET [
	stack/reset
	unset/push-last
]

natives: context [
	verbose: 0
	lf?: 	 no											;-- used to print or not an ending newline

	table: declare int-ptr!
	top: 1

	buffer-blk: as red-block! 0

	register: func [
		[variadic]
		count	   [integer!]
		list	   [int-ptr!]
		/local
			offset [integer!]
	][
		offset: 0

		until [
			table/top: list/value
			top: top + 1
			assert top <= NATIVES_NB
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	;--- Natives ----

	if*: does [
		either logic/false? [
			RETURN_NONE
		][
			interpreter/eval as red-block! stack/arguments + 1
		]
	]

	unless*: does [
		either logic/false? [
			interpreter/eval as red-block! stack/arguments + 1
		][
			RETURN_NONE
		]
	]

	either*: func [
		/local offset [integer!]
	][
		offset: either logic/true? [1][2]
		interpreter/eval as red-block! stack/arguments + offset
	]

	any*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/true? [exit]
		]
		RETURN_NONE
	]

	all*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/false? [RETURN_NONE]
		]
	]

	while*:	func [
		/local
			cond [red-block!]
			body [red-block!]
	][
		cond: as red-block! stack/arguments
		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		while [
			interpreter/eval cond
			logic/true?
		][
			stack/reset
			interpreter/eval body
		]
		stack/unwind
		RETURN_UNSET
	]

	until*: func [
		/local
			body [red-block!]
	][
		body: as red-block! stack/arguments

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			logic/true?
		]
		stack/unwind-last
	]

	loop*: func [
		/local
			body [red-block!]
			i	 [integer!]
	][
		i: integer/get*
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	repeat*: func [
		/local
			w	   [red-word!]
			body   [red-block!]
			count  [red-integer!]
			cnt	   [integer!]
			i	   [integer!]
	][
		w: 	   as red-word!    stack/arguments
		count: as red-integer! stack/arguments + 1
		body:  as red-block!   stack/arguments + 2

		i: integer/get as red-value! count
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		count/value: 1

		stack/mark-native words/_body
		until [
			stack/reset
			_context/set w as red-value! count
			interpreter/eval body
			count/value: count/value + 1
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	foreach*: func [
		/local
			value [red-value!]
			body  [red-block!]
			size  [integer!]
	][
		value: stack/arguments
		body: as red-block! stack/arguments + 2

		stack/push stack/arguments + 1					;-- copy arguments to stack top in reverse order
		stack/push value								;-- (required by foreach-next)

		stack/mark-native words/_body

		either TYPE_OF(value) = TYPE_BLOCK [
			size: block/rs-length? as red-block! value

			while [foreach-next-block size][			;-- foreach [..]
				stack/reset
				interpreter/eval body
			]
		][
			while [foreach-next][						;-- foreach <word!>
				stack/reset
				interpreter/eval body
			]
		]
		stack/unwind-last
	]

	forall*: func [
		/local
			w 	   [red-word!]
			body   [red-block!]
			saved  [red-value!]
			series [red-series!]
	][
		w:    as red-word!  stack/arguments
		body: as red-block! stack/arguments + 1

		saved: word/get w							;-- save series (for resetting on end)
		w: word/push w								;-- word argument

		stack/mark-native words/_body
		while [
			loop? as red-series! _context/get w
		][
			stack/reset
			interpreter/eval body
			series: as red-series! _context/get w
			series/head: series/head + 1
		]
		stack/unwind-last
		_context/set w saved
	]

	func*: does [
		_function/validate as red-block! stack/arguments
		_function/push
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
			null
			0
		stack/set-last stack/top - 1
	]

	function*:	does [
		_function/collect-words
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
		func*
	]

	does*: does [
		copy-cell stack/arguments stack/push*
		block/make-at as red-block! stack/arguments 1
		func*
	]

	has*: does [
		block/insert-value
			as red-block! stack/arguments
			as red-value! refinements/local
		func*
	]

	switch*: func [
		default? [integer!]
		/local
			pos	 [red-value!]
			blk  [red-block!]
			alt  [red-block!]
			end  [red-value!]
			s	 [series!]
	][
		blk: as red-block! stack/arguments + 1
		alt: as red-block! stack/arguments + 2

		pos: actions/find
			as red-series! blk
			stack/arguments
			null
			yes											;-- /only
			no
			no
			null
			null
			no
			no
			yes											;-- /tail
			no

		either TYPE_OF(pos) = TYPE_NONE [
			either negative? default? [
				RETURN_NONE
			][
				interpreter/eval alt
				exit									;-- early exit with last value on stack
			]
		][
			s: GET_BUFFER(blk)
			end: s/tail

			while [pos < end][							;-- find first following block
				if TYPE_OF(pos) = TYPE_BLOCK [
					stack/reset
					pos: block/pick as red-series! pos 1
					interpreter/eval as red-block! pos	;-- do the block
					exit								;-- early exit with last value on stack
				]
				pos: pos + 1
			]
		]
		RETURN_NONE
	]

	case*: func [
		all? 	  [integer!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments
		if value = tail [RETURN_NONE]

		while [value < tail][
			value: interpreter/eval-next value tail no	;-- eval condition
			either logic/true? [
				either TYPE_OF(value) = TYPE_BLOCK [	;-- if true, eval what follows it
					stack/reset
					interpreter/eval as red-block! value
				][
					value: interpreter/eval-next value tail no
				]
				if negative? all? [exit]				;-- early exit with last value on stack (unless /all)
			][
				value: value + 1						;-- single value only allowed for cases bodies
			]
		]
		RETURN_NONE
	]

	do*: func [
		/local
			arg [red-value!]
			str	[red-string!]
			s	[series!]
	][
		arg: stack/arguments
		switch TYPE_OF(arg) [
			TYPE_BLOCK [
				interpreter/eval as red-block! arg
			]
			TYPE_PATH [
				interpreter/eval-path arg arg arg + 1 no
				stack/set-last arg + 1
			]
			TYPE_STRING [
				str: as red-string! arg
				s: GET_BUFFER(str)
				tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
				do*
			]
			default [
				interpreter/eval-expression arg arg + 1 no no
			]
		]
	]

	get*: func [
		any? [integer!]
	][
		stack/set-last _context/get as red-word! stack/arguments
	]

	set*: func [
		any? [integer!]
		/local
			w	  [red-word!]
			value [red-value!]
			blk	  [red-block!]
	][
		w: as red-word! stack/arguments
		value: stack/arguments + 1

		either TYPE_OF(w) = TYPE_BLOCK [
			blk: as red-block! w
			set-many blk value block/rs-length? blk
			stack/set-last value
		][
			stack/set-last _context/set w value
		]
	]

	print*: does [
		lf?: yes											;@@ get rid of this global state
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
			offset	[byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either any [
			TYPE_OF(arg) = TYPE_STRING 						;@@ replace by ANY_STRING?
			TYPE_OF(arg) = TYPE_FILE
		][
			str: as red-string! arg
		][
			block/rs-clear buffer-blk
			stack/push as red-value! buffer-blk
			assert stack/top - 2 = stack/arguments			;-- check for correct stack layout

			if TYPE_OF(arg) = TYPE_BLOCK [reduce* 1]
			actions/form* -1
			str: as red-string! stack/arguments + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)
		offset: (as byte-ptr! series/offset) + (str/head << (GET_UNIT(series) >> 1))

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! offset]
				UCS-2  [platform/print-line-UCS2 				offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! offset]
				UCS-2  [platform/print-UCS2   			   offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		result/value: actions/compare args args + 1 op
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_NOT_EQUAL
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL
	]

	same?*: does []

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifying stack
		bool/header: TYPE_LOGIC
	]

	halt*: does [halt]

	type?*: func [
		word?	 [integer!]
		return:  [red-value!]
		/local
			dt	 [red-datatype!]
			w	 [red-word!]
			name [names!]
	][
		either negative? word? [
			dt: as red-datatype! stack/arguments		;-- overwrite argument
			dt/value: TYPE_OF(dt)						;-- extract type before overriding
			dt/header: TYPE_DATATYPE
			as red-value! dt
		][
			w: as red-word! stack/arguments				;-- overwrite argument
			name: name-table + TYPE_OF(w)				;-- point to the right datatype name record
			stack/set-last as red-value! name/word
		]
	]

	load*: func [
		header? [integer!]
		all?	[integer!]
		type?	[integer!]
		into 	[integer!]
		return: [red-value!]
		/local
			str [red-string!]
			dst [red-block!]
	][
		str: as red-string! stack/arguments
		dst: null

		if into >= 0 [
			dst: as red-block! stack/push stack/arguments + into
		]
		tokenizer/scan as c-string! string/rs-head str dst	;@@ temporary limited to Latin-1
		unless null? dst [stack/set-last as red-value! dst]

		blk: as red-block! stack/arguments
		if TYPE_OF(blk) = TYPE_BLOCK [
			if all [negative? all? 1 = block/rs-length? blk][
				stack/set-last block/pick as red-series! blk 1
			]
		]
		stack/arguments
	]

	reduce*: func [
		into [integer!]
		/local
			value [red-value!]
			tail  [red-value!]
			blk	  [red-block!]
			arg	  [red-value!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [					;-- pass-thru for non block! values
			interpreter/eval-expression arg arg + 1 no no
			exit
		]

		value: block/rs-head as red-block! arg
		tail:  block/rs-tail as red-block! arg

		stack/mark-native words/_body

		blk: either negative? into [
			block/push-only* (as-integer tail - value) >> 4
		][
			as red-block! stack/push arg + into
		]

		while [value < tail][
			value: interpreter/eval-next value tail yes
			block/append*
			stack/keep									;-- preserve the reduced block on stack
		]
		stack/unwind-last
	]

	compose-block: func [
		blk		[red-block!]
		deep?	[logic!]
		only?	[logic!]
		into	[red-block!]
		root?	[logic!]
		return: [red-block!]
		/local
			value  [red-value!]
			tail   [red-value!]
			new	   [red-block!]
			result [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		new: either all [root? OPTION?(into)][
			into
		][
			block/push-only* (as-integer tail - value) >> 4
		]
		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_BLOCK [
					blk: either deep? [
						compose-block as red-block! value deep? only? into no
					][
						as red-block! value
					]
					copy-cell as red-value! blk ALLOC_TAIL(new)
				]
				TYPE_PAREN [
					blk: as red-block! value
					unless zero? block/rs-length? blk [
						interpreter/eval blk
						result: stack/arguments
						blk: as red-block! result

						unless any [
							TYPE_OF(result) = TYPE_UNSET
							all [
								not only?
								TYPE_OF(result) = TYPE_BLOCK
								zero? block/rs-length? blk
							]
						][
							either any [
								only?
								TYPE_OF(result) <> TYPE_BLOCK
							][
								copy-cell result ALLOC_TAIL(new)
							][
								block/rs-append-block new as red-block! result
							]
						]
					]
				]
				default [
					copy-cell value ALLOC_TAIL(new)
				]
			]
			value: value + 1
		]
		new
	]

	compose*: func [
		deep [integer!]
		only [integer!]
		into [integer!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [					;-- pass-thru for non block! values
			interpreter/eval-expression arg arg + 1 no no
			exit
		]
		stack/set-last
			as red-value! compose-block
				as red-block! arg
				as logic! deep + 1
				as logic! only + 1
				as red-block! stack/arguments + into
				yes
	]

	stats*: func [
		show [integer!]
		info [integer!]
		/local
			blk [red-block!]
	][
		case [
			show >= 0 [
				;TBD
				integer/box memory/total
			]
			info >= 0 [
				blk: block/push* 5
				memory-info blk 2
				stack/set-last as red-value! blk
			]
			true [
				integer/box memory/total
			]
		]
	]

	bind*: func [
		copy [integer!]
		/local
			value [red-value!]
			ref	  [red-value!]
			fun	  [red-function!]
			word  [red-word!]
			ctx	  [red-context!]
	][
		value: stack/arguments
		ref: value + 1

		either any [
			TYPE_OF(ref) = TYPE_FUNCTION
			;TYPE_OF(ref) = TYPE_OBJECT
		][
			fun: as red-function! ref
			ctx: fun/ctx
		][
			word: as red-word! ref
			ctx: word/ctx
		]

		either TYPE_OF(value) = TYPE_BLOCK [
			either negative? copy [
				_context/bind as red-block! value ctx
			][
				stack/set-last
					as red-value! _context/bind
						block/clone as red-block! value yes
						ctx
			]
		][
			word: as red-word! value
			word/ctx: ctx
			word/index: _context/find-word ctx word/symbol
		]
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			s/offset + series/head < s/tail
		][
			(as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
	]

	set-many: func [
		words [red-block!]
		value [red-value!]
		size  [integer!]
		/local
			v		[red-value!]
			blk		[red-block!]
			i		[integer!]
			block?	[logic!]
	][
		block?: TYPE_OF(value) = TYPE_BLOCK
		if block? [blk: as red-block! value]
		i: 1

		while [i <= size][
			v: either block? [block/pick blk i][value]
			_context/set
				as red-word! block/pick words i
				v
			i: i + 1
		]
	]

	foreach-next-block: func [
		size	[integer!]								;-- number of words in the block
		return: [logic!]
		/local
			series [red-series!]
			blk    [red-block!]
			result [logic!]
	][
		blk:    as red-block!  stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		result: loop? series
		if result [set-many blk as red-value! series size]
		series/head: series/head + size
		result
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		word:   as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

		result: loop? series
		if result [_context/set word actions/pick series 1]
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 1
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 1
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: 	as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

	repeat-init*: func [
		cell  	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		copy-cell stack/arguments cell
		int: as red-integer! cell
		int/value										;-- overlapping /value field for integer! and char!
	]

	repeat-set: func [
		cell  [red-value!]
		value [integer!]
		/local
			int [red-integer!]
	][
		assert any [
			TYPE_OF(cell) = TYPE_INTEGER
			TYPE_OF(cell) = TYPE_CHAR
		]
		int: as red-integer! cell
		int/value: value								;-- overlapping /value field for integer! and char!
	]

	init: does [
		table: as int-ptr! allocate NATIVES_NB * size? integer!
		buffer-blk: block/make-in red/root 32			;-- block buffer for PRIN's reduce/into

		register [
			:if*
			:unless*
			:either*
			:any*
			:all*
			:while*
			:until*
			:loop*
			:repeat*
			:foreach*
			:forall*
			:func*
			:function*
			:does*
			:has*
			:switch*
			:case*
			:do*
			:get*
			:set*
			:print*
			:prin*
			:equal?*
			:not-equal?*
			:strict-equal?*
			:lesser?*
			:greater?*
			:lesser-or-equal?*
			:greater-or-equal?*
			:same?*
			:not*
			:halt*
			:type?*
			:load*
			:reduce*
			:compose*
			:stats*
			:bind*
		]
	]

]

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

#define RETURN_NONE [
	stack/reset
	none/push-last
	exit
]

#define RETURN_UNSET [
	stack/reset
	unset/push-last
]

natives: context [
	verbose: 0
	lf?: 	 no											;-- used to print or not an ending newline

	table: declare int-ptr!
	top: 1

	buffer-blk: as red-block! 0

	register: func [
		[variadic]
		count	   [integer!]
		list	   [int-ptr!]
		/local
			offset [integer!]
	][
		offset: 0

		until [
			table/top: list/value
			top: top + 1
			assert top <= NATIVES_NB
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	;--- Natives ----

	if*: does [
		either logic/false? [
			RETURN_NONE
		][
			interpreter/eval as red-block! stack/arguments + 1
		]
	]

	unless*: does [
		either logic/false? [
			interpreter/eval as red-block! stack/arguments + 1
		][
			RETURN_NONE
		]
	]

	either*: func [
		/local offset [integer!]
	][
		offset: either logic/true? [1][2]
		interpreter/eval as red-block! stack/arguments + offset
	]

	any*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/true? [exit]
		]
		RETURN_NONE
	]

	all*: func [
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments

		while [value < tail][
			value: interpreter/eval-next value tail no
			if logic/false? [RETURN_NONE]
		]
	]

	while*:	func [
		/local
			cond [red-block!]
			body [red-block!]
	][
		cond: as red-block! stack/arguments
		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		while [
			interpreter/eval cond
			logic/true?
		][
			stack/reset
			interpreter/eval body
		]
		stack/unwind
		RETURN_UNSET
	]

	until*: func [
		/local
			body [red-block!]
	][
		body: as red-block! stack/arguments

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			logic/true?
		]
		stack/unwind-last
	]

	loop*: func [
		/local
			body [red-block!]
			i	 [integer!]
	][
		i: integer/get*
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		body: as red-block! stack/arguments + 1

		stack/mark-native words/_body
		until [
			stack/reset
			interpreter/eval body
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	repeat*: func [
		/local
			w	   [red-word!]
			body   [red-block!]
			count  [red-integer!]
			cnt	   [integer!]
			i	   [integer!]
	][
		w: 	   as red-word!    stack/arguments
		count: as red-integer! stack/arguments + 1
		body:  as red-block!   stack/arguments + 2

		i: integer/get as red-value! count
		unless positive? i [RETURN_NONE]				;-- if counter <= 0, no loops

		count/value: 1

		stack/mark-native words/_body
		until [
			stack/reset
			_context/set w as red-value! count
			interpreter/eval body
			count/value: count/value + 1
			i: i - 1
			zero? i
		]
		stack/unwind-last
	]

	foreach*: func [
		/local
			value [red-value!]
			body  [red-block!]
			size  [integer!]
	][
		value: stack/arguments
		body: as red-block! stack/arguments + 2

		stack/push stack/arguments + 1					;-- copy arguments to stack top in reverse order
		stack/push value								;-- (required by foreach-next)

		stack/mark-native words/_body

		either TYPE_OF(value) = TYPE_BLOCK [
			size: block/rs-length? as red-block! value

			while [foreach-next-block size][			;-- foreach [..]
				stack/reset
				interpreter/eval body
			]
		][
			while [foreach-next][						;-- foreach <word!>
				stack/reset
				interpreter/eval body
			]
		]
		stack/unwind-last
	]

	forall*: func [
		/local
			w 	   [red-word!]
			body   [red-block!]
			saved  [red-value!]
			series [red-series!]
	][
		w:    as red-word!  stack/arguments
		body: as red-block! stack/arguments + 1

		saved: word/get w							;-- save series (for resetting on end)
		w: word/push w								;-- word argument

		stack/mark-native words/_body
		while [
			loop? as red-series! _context/get w
		][
			stack/reset
			interpreter/eval body
			series: as red-series! _context/get w
			series/head: series/head + 1
		]
		stack/unwind-last
		_context/set w saved
	]

	func*: does [
		_function/validate as red-block! stack/arguments
		_function/push
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
			null
			0
		stack/set-last stack/top - 1
	]

	function*:	does [
		_function/collect-words
			as red-block! stack/arguments
			as red-block! stack/arguments + 1
		func*
	]

	does*: does [
		copy-cell stack/arguments stack/push*
		block/make-at as red-block! stack/arguments 1
		func*
	]

	has*: does [
		block/insert-value
			as red-block! stack/arguments
			as red-value! refinements/local
		func*
	]

	switch*: func [
		default? [integer!]
		/local
			pos	 [red-value!]
			blk  [red-block!]
			alt  [red-block!]
			end  [red-value!]
			s	 [series!]
	][
		blk: as red-block! stack/arguments + 1
		alt: as red-block! stack/arguments + 2

		pos: actions/find
			as red-series! blk
			stack/arguments
			null
			yes											;-- /only
			no
			no
			null
			null
			no
			no
			yes											;-- /tail
			no

		either TYPE_OF(pos) = TYPE_NONE [
			either negative? default? [
				RETURN_NONE
			][
				interpreter/eval alt
				exit									;-- early exit with last value on stack
			]
		][
			s: GET_BUFFER(blk)
			end: s/tail

			while [pos < end][							;-- find first following block
				if TYPE_OF(pos) = TYPE_BLOCK [
					stack/reset
					pos: block/pick as red-series! pos 1
					interpreter/eval as red-block! pos	;-- do the block
					exit								;-- early exit with last value on stack
				]
				pos: pos + 1
			]
		]
		RETURN_NONE
	]

	case*: func [
		all? 	  [integer!]
		/local
			value [red-value!]
			tail  [red-value!]
	][
		value: block/rs-head as red-block! stack/arguments
		tail:  block/rs-tail as red-block! stack/arguments
		if value = tail [RETURN_NONE]

		while [value < tail][
			value: interpreter/eval-next value tail no	;-- eval condition
			either logic/true? [
				either TYPE_OF(value) = TYPE_BLOCK [	;-- if true, eval what follows it
					stack/reset
					interpreter/eval as red-block! value
				][
					value: interpreter/eval-next value tail no
				]
				if negative? all? [exit]				;-- early exit with last value on stack (unless /all)
			][
				value: value + 1						;-- single value only allowed for cases bodies
			]
		]
		RETURN_NONE
	]

	do*: func [
		/local
			arg [red-value!]
			str	[red-string!]
			s	[series!]
	][
		arg: stack/arguments
		switch TYPE_OF(arg) [
			TYPE_BLOCK [
				interpreter/eval as red-block! arg
			]
			TYPE_STRING [
				str: as red-string! arg
				s: GET_BUFFER(str)
				tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
				do*
			]
			default [
				interpreter/eval-expression arg arg + 1 no no
			]
		]
	]

	get*: func [
		any? [integer!]
	][
		stack/set-last _context/get as red-word! stack/arguments
	]

	set*: func [
		any? [integer!]
		/local
			w	  [red-word!]
			value [red-value!]
			blk	  [red-block!]
	][
		w: as red-word! stack/arguments
		value: stack/arguments + 1

		either TYPE_OF(w) = TYPE_BLOCK [
			blk: as red-block! w
			set-many blk value block/rs-length? blk
			stack/set-last value
		][
			stack/set-last _context/set w value
		]
	]

	print*: does [
		lf?: yes											;@@ get rid of this global state
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
			offset	[byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either any [
			TYPE_OF(arg) = TYPE_STRING 						;@@ replace by ANY_STRING?
			TYPE_OF(arg) = TYPE_FILE
		][
			str: as red-string! arg
		][
			block/rs-clear buffer-blk
			stack/push as red-value! buffer-blk
			assert stack/top - 2 = stack/arguments			;-- check for correct stack layout

			if TYPE_OF(arg) = TYPE_BLOCK [reduce* 1]
			actions/form* -1
			str: as red-string! stack/arguments + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)
		offset: (as byte-ptr! series/offset) + (str/head << (GET_UNIT(series) >> 1))

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! offset]
				UCS-2  [platform/print-line-UCS2 				offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! offset]
				UCS-2  [platform/print-UCS2   			   offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		result/value: actions/compare args args + 1 op
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_NOT_EQUAL
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL
	]

	same?*: does []

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifying stack
		bool/header: TYPE_LOGIC
	]

	halt*: does [halt]

	type?*: func [
		word?	 [integer!]
		return:  [red-value!]
		/local
			dt	 [red-datatype!]
			w	 [red-word!]
			name [names!]
	][
		either negative? word? [
			dt: as red-datatype! stack/arguments		;-- overwrite argument
			dt/value: TYPE_OF(dt)						;-- extract type before overriding
			dt/header: TYPE_DATATYPE
			as red-value! dt
		][
			w: as red-word! stack/arguments				;-- overwrite argument
			name: name-table + TYPE_OF(w)				;-- point to the right datatype name record
			stack/set-last as red-value! name/word
		]
	]

	load*: func [
		header? [integer!]
		all?	[integer!]
		type?	[integer!]
		into 	[integer!]
		return: [red-value!]
		/local
			str [red-string!]
			dst [red-block!]
	][
		str: as red-string! stack/arguments
		dst: null

		if into >= 0 [
			dst: as red-block! stack/push stack/arguments + into
		]
		tokenizer/scan as c-string! string/rs-head str dst	;@@ temporary limited to Latin-1
		unless null? dst [stack/set-last as red-value! dst]

		blk: as red-block! stack/arguments
		if TYPE_OF(blk) = TYPE_BLOCK [
			if all [negative? all? 1 = block/rs-length? blk][
				stack/set-last block/pick as red-series! blk 1
			]
		]
		stack/arguments
	]

	reduce*: func [
		into [integer!]
		/local
			value [red-value!]
			tail  [red-value!]
			blk	  [red-block!]
			arg	  [red-value!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [					;-- pass-thru for non block! values
			interpreter/eval-expression arg arg + 1 no no
			exit
		]

		value: block/rs-head as red-block! arg
		tail:  block/rs-tail as red-block! arg

		stack/mark-native words/_body

		blk: either negative? into [
			block/push-only* (as-integer tail - value) >> 4
		][
			as red-block! stack/push arg + into
		]

		while [value < tail][
			value: interpreter/eval-next value tail yes
			block/append*
			stack/keep									;-- preserve the reduced block on stack
		]
		stack/unwind-last
	]

	compose-block: func [
		blk		[red-block!]
		deep?	[logic!]
		only?	[logic!]
		into	[red-block!]
		root?	[logic!]
		return: [red-block!]
		/local
			value  [red-value!]
			tail   [red-value!]
			new	   [red-block!]
			result [red-value!]
	][
		value: block/rs-head blk
		tail:  block/rs-tail blk

		new: either all [root? OPTION?(into)][
			into
		][
			block/push-only* (as-integer tail - value) >> 4
		]
		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_BLOCK [
					blk: either deep? [
						compose-block as red-block! value deep? only? into no
					][
						as red-block! value
					]
					copy-cell as red-value! blk ALLOC_TAIL(new)
				]
				TYPE_PAREN [
					blk: as red-block! value
					unless zero? block/rs-length? blk [
						interpreter/eval blk
						result: stack/arguments
						blk: as red-block! result

						unless any [
							TYPE_OF(result) = TYPE_UNSET
							all [
								not only?
								TYPE_OF(result) = TYPE_BLOCK
								zero? block/rs-length? blk
							]
						][
							either any [
								only?
								TYPE_OF(result) <> TYPE_BLOCK
							][
								copy-cell result ALLOC_TAIL(new)
							][
								block/rs-append-block new as red-block! result
							]
						]
					]
				]
				default [
					copy-cell value ALLOC_TAIL(new)
				]
			]
			value: value + 1
		]
		new
	]

	compose*: func [
		deep [integer!]
		only [integer!]
		into [integer!]
	][
		arg: stack/arguments
		if TYPE_OF(arg) <> TYPE_BLOCK [					;-- pass-thru for non block! values
			interpreter/eval-expression arg arg + 1 no no
			exit
		]
		stack/set-last
			as red-value! compose-block
				as red-block! arg
				as logic! deep + 1
				as logic! only + 1
				as red-block! stack/arguments + into
				yes
	]

	stats*: func [
		show [integer!]
		info [integer!]
		/local
			blk [red-block!]
	][
		case [
			show >= 0 [
				;TBD
				integer/box memory/total
			]
			info >= 0 [
				blk: block/push* 5
				memory-info blk 2
				stack/set-last as red-value! blk
			]
			true [
				integer/box memory/total
			]
		]
	]

	bind*: func [
		copy [integer!]
		/local
			value [red-value!]
			ref	  [red-value!]
			fun	  [red-function!]
			word  [red-word!]
			ctx	  [red-context!]
	][
		value: stack/arguments
		ref: value + 1

		either any [
			TYPE_OF(ref) = TYPE_FUNCTION
			;TYPE_OF(ref) = TYPE_OBJECT
		][
			fun: as red-function! ref
			ctx: fun/ctx
		][
			word: as red-word! ref
			ctx: word/ctx
		]

		either TYPE_OF(value) = TYPE_BLOCK [
			either negative? copy [
				_context/bind as red-block! value ctx
			][
				stack/set-last
					as red-value! _context/bind
						block/clone as red-block! value yes
						ctx
			]
		][
			word: as red-word! value
			word/ctx: ctx
			word/index: _context/find-word ctx word/symbol
		]
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			s/offset + series/head < s/tail
		][
			(as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
	]

	set-many: func [
		words [red-block!]
		value [red-value!]
		size  [integer!]
		/local
			v		[red-value!]
			blk		[red-block!]
			i		[integer!]
			block?	[logic!]
	][
		block?: TYPE_OF(value) = TYPE_BLOCK
		if block? [blk: as red-block! value]
		i: 1

		while [i <= size][
			v: either block? [block/pick blk i][value]
			_context/set
				as red-word! block/pick words i
				v
			i: i + 1
		]
	]

	foreach-next-block: func [
		size	[integer!]								;-- number of words in the block
		return: [logic!]
		/local
			series [red-series!]
			blk    [red-block!]
			result [logic!]
	][
		blk:    as red-block!  stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		result: loop? series
		if result [set-many blk as red-value! series size]
		series/head: series/head + size
		result
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		word:   as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

		result: loop? series
		if result [_context/set word actions/pick series 1]
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 1
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 1
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: 	as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
			TYPE_OF(series) = TYPE_FILE
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

	repeat-init*: func [
		cell  	[red-value!]
		return: [integer!]
		/local
			int [red-integer!]
	][
		copy-cell stack/arguments cell
		int: as red-integer! cell
		int/value										;-- overlapping /value field for integer! and char!
	]

	repeat-set: func [
		cell  [red-value!]
		value [integer!]
		/local
			int [red-integer!]
	][
		assert any [
			TYPE_OF(cell) = TYPE_INTEGER
			TYPE_OF(cell) = TYPE_CHAR
		]
		int: as red-integer! cell
		int/value: value								;-- overlapping /value field for integer! and char!
	]

	init: does [
		table: as int-ptr! allocate NATIVES_NB * size? integer!
		buffer-blk: block/make-in red/root 32			;-- block buffer for PRIN's reduce/into

		register [
			:if*
			:unless*
			:either*
			:any*
			:all*
			:while*
			:until*
			:loop*
			:repeat*
			:foreach*
			:forall*
			:func*
			:function*
			:does*
			:has*
			:switch*
			:case*
			:do*
			:get*
			:set*
			:print*
			:prin*
			:equal?*
			:not-equal?*
			:strict-equal?*
			:lesser?*
			:greater?*
			:lesser-or-equal?*
			:greater-or-equal?*
			:same?*
			:not*
			:halt*
			:type?*
			:load*
			:reduce*
			:compose*
			:stats*
			:bind*
		]
	]

]


FEAT: added IF, UNLESS, EITHER natives support to the interpreter.

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

#define RETURN_NONE [
	stack/reset
	none/push-last
]

natives: context [
	verbose: 0
	lf?: 	 no											;-- used to print or not an ending newline

	table: as int-ptr! allocate NATIVES_NB * size? integer!
	top: 0

	register: func [
		[variadic]
		count	   [integer!]
		list	   [int-ptr!]
		/local
			offset [integer!]
	][
		offset: 0

		until [
			table/top: list/value
			top: top + 1
			assert top < NATIVES_NB
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	;--- Natives ----

	if*: does [
		either logic/false? [
			RETURN_NONE
		][
			interpreter/eval as red-block! stack/arguments + 1
		]
	]

	unless*: does [
		either logic/false? [
			interpreter/eval as red-block! stack/arguments + 1
		][
			RETURN_NONE
		]
	]

	either*: func [
		/local
			offset [integer!]
	][
		offset: either logic/true? [1][2]
		interpreter/eval as red-block! stack/arguments + offset
	]

	any*:		does []
	all*:		does []
	while*:		does []
	until*:		does []
	loop*:		does []
	repeat*:	does []
	foreach*:	does []
	forall*:	does []
	func*:		does []
	function*:	does []
	does*:		does []
	has*:		does []
	exit*:		does []
	return*:	does []
	switch*:	does []
	case*:		does []

	do*: does [
		interpreter/eval as red-block! stack/arguments
	]

	get*:		does []
	set*:		does []

	print*: does [
		lf?: yes
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
			offset	[byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either TYPE_OF(arg) = TYPE_STRING [
			str: as red-string! arg
		][
			actions/form* -1
			str: as red-string! stack/arguments + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)
		offset: (as byte-ptr! series/offset) + (str/head << (GET_UNIT(series) >> 1))

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! offset]
				UCS-2  [platform/print-line-UCS2 				offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! offset]
				UCS-2  [platform/print-UCS2   			   offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		result/value: actions/compare args args + 1 op
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_NOT_EQUAL
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL
	]

	same?*: does []

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifying stack
		bool/header: TYPE_LOGIC
	]

	halt*: does [halt]

	type?*: func [
		word?	 [integer!]
		return:  [red-value!]
		/local
			dt	 [red-datatype!]
			w	 [red-word!]
			name [names!]
	][
		either negative? word? [
			dt: as red-datatype! stack/arguments		;-- overwrite argument
			dt/value: TYPE_OF(dt)						;-- extract type before overriding
			dt/header: TYPE_DATATYPE
			as red-value! dt
		][
			w: as red-word! stack/arguments				;-- overwrite argument
			name: name-table + TYPE_OF(w)				;-- point to the right datatype name record
			stack/set-last as red-value! name/word
		]
	]

	load*: func [
		/local
			str [red-string!]
			s	[series!]
	][
		str: as red-string! stack/arguments
		s: GET_BUFFER(str)
		tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			s/offset + series/head < s/tail
		][
			(as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
	]

	set-many-to-many: func [
		words	[red-block!]
		series	[red-series!]
		size	[integer!]
		/local
			i	[integer!]
	][
		i: 1
		while [i <= size][
			_context/set
				as red-word! block/pick words i
				actions/pick series i
			i: i + 1
		]
	]

	foreach-next-block: func [
		size	[integer!]								;-- number of words in the block
		return: [logic!]
		/local
			series [red-series!]
			blk    [red-block!]
			result [logic!]
	][
		blk:    as red-block!  stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		set-many-to-many blk series size
		result: loop? series
		series/head: series/head + size
		result
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		word:   as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word actions/pick series 1
		result: loop? series
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 1
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 1
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: 	as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

	register [
		:if*
		:unless*
		:either*
		:any*
		:all*
		:while*
		:until*
		:loop*
		:repeat*
		:foreach*
		:forall*
		:func*
		:function*
		:does*
		:has*
		:exit*
		:return*
		:switch*
		:case*
		:do*
		:get*
		:set*
		:print*
		:prin*
		:equal?*
		:not-equal?*
		:strict-equal?*
		:lesser?*
		:greater?*
		:lesser-or-equal?*
		:greater-or-equal?*
		:same?*
		:not*
		:halt*
		:type?*
		:load*
	]

]

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

natives: context [
	verbose: 0
	lf?: 	 no											;-- used to print or not an ending newline

	table: as int-ptr! allocate NATIVES_NB * size? integer!
	top: 0

	register: func [
		[variadic]
		count	   [integer!]
		list	   [int-ptr!]
		/local
			offset [integer!]
	][
		offset: 0

		until [
			table/top: list/value
			top: top + 1
			assert top < NATIVES_NB
			list: list + 1
			count: count - 1
			zero? count
		]
	]

	;--- Natives ----

	if*: 		does []
	unless*:	does []
	either*:	does []
	any*:		does []
	all*:		does []
	while*:		does []
	until*:		does []
	loop*:		does []
	repeat*:	does []
	foreach*:	does []
	forall*:	does []
	func*:		does []
	function*:	does []
	does*:		does []
	has*:		does []
	exit*:		does []
	return*:	does []
	switch*:	does []
	case*:		does []

	do*: does [
		interpreter/eval as red-block! stack/arguments
	]

	get*:		does []
	set*:		does []

	print*: does [
		lf?: yes
		prin*
		lf?: no
	]

	prin*: func [
		/local
			arg		[red-value!]
			str		[red-string!]
			series	[series!]
			offset	[byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/prin"]]

		arg: stack/arguments

		either TYPE_OF(arg) = TYPE_STRING [
			str: as red-string! arg
		][
			actions/form* -1
			str: as red-string! stack/arguments + 1
			assert any [
				TYPE_OF(str) = TYPE_STRING
				TYPE_OF(str) = TYPE_SYMBOL					;-- symbol! and string! structs are overlapping
			]
		]
		series: GET_BUFFER(str)
		offset: (as byte-ptr! series/offset) + (str/head << (GET_UNIT(series) >> 1))

		either lf? [
			switch GET_UNIT(series) [
				Latin1 [platform/print-line-Latin1 as c-string! offset]
				UCS-2  [platform/print-line-UCS2 				offset]
				UCS-4  [platform/print-line-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		][
			switch GET_UNIT(series) [
				Latin1 [platform/print-Latin1 as c-string! offset]
				UCS-2  [platform/print-UCS2   			   offset]
				UCS-4  [platform/print-UCS4   as int-ptr!  offset]

				default [									;@@ replace by an assertion
					print-line ["Error: unknown string encoding: " GET_UNIT(series)]
				]
			]
		]
		stack/set-last unset-value
	]

	compare: func [
		op		   [integer!]
		return:    [red-logic!]
		/local
			args   [red-value!]
			result [red-logic!]
	][
		args: stack/arguments
		result: as red-logic! args
		result/value: actions/compare args args + 1 op
		result/header: TYPE_LOGIC
		result
	]

	equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/equal?"]]
		compare COMP_EQUAL
	]

	not-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not-equal?"]]
		compare COMP_NOT_EQUAL
	]

	strict-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/strict-equal?"]]
		compare COMP_STRICT_EQUAL
	]

	lesser?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser?"]]
		compare COMP_LESSER
	]

	greater?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater?"]]
		compare COMP_GREATER
	]

	lesser-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/lesser-or-equal?"]]
		compare COMP_LESSER_EQUAL
	]

	greater-or-equal?*: func [
		return:    [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/greater-or-equal?"]]
		compare COMP_GREATER_EQUAL
	]

	same?*: does []

	not*: func [
		/local bool [red-logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "native/not"]]

		bool: as red-logic! stack/arguments
		bool/value: logic/false?						;-- run test before modifying stack
		bool/header: TYPE_LOGIC
	]

	halt*: does [halt]

	type?*: func [
		word?	 [integer!]
		return:  [red-value!]
		/local
			dt	 [red-datatype!]
			w	 [red-word!]
			name [names!]
	][
		either negative? word? [
			dt: as red-datatype! stack/arguments		;-- overwrite argument
			dt/value: TYPE_OF(dt)						;-- extract type before overriding
			dt/header: TYPE_DATATYPE
			as red-value! dt
		][
			w: as red-word! stack/arguments				;-- overwrite argument
			name: name-table + TYPE_OF(w)				;-- point to the right datatype name record
			stack/set-last as red-value! name/word
		]
	]

	load*: func [
		/local
			str [red-string!]
			s	[series!]
	][
		str: as red-string! stack/arguments
		s: GET_BUFFER(str)
		tokenizer/scan as c-string! s/offset null	;@@ temporary limited to Latin-1
	]

	;--- Natives helper functions ---

	loop?: func [
		series     [red-series!]
		return:    [logic!]
		/local
			s	   [series!]
	][
		s: GET_BUFFER(series)

		either TYPE_OF(series) = TYPE_BLOCK [			;@@ replace with any-block?/any-string? check
			s/offset + series/head < s/tail
		][
			(as byte-ptr! s/offset)
				+ (series/head << (GET_UNIT(s) >> 1))
				< (as byte-ptr! s/tail)
		]
	]

	set-many-to-many: func [
		words	[red-block!]
		series	[red-series!]
		size	[integer!]
		/local
			i	[integer!]
	][
		i: 1
		while [i <= size][
			_context/set
				as red-word! block/pick words i
				actions/pick series i
			i: i + 1
		]
	]

	foreach-next-block: func [
		size	[integer!]								;-- number of words in the block
		return: [logic!]
		/local
			series [red-series!]
			blk    [red-block!]
			result [logic!]
	][
		blk:    as red-block!  stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(blk) = TYPE_BLOCK

		set-many-to-many blk series size
		result: loop? series
		series/head: series/head + size
		result
	]

	foreach-next: func [
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
			result [logic!]
	][
		word:   as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word actions/pick series 1
		result: loop? series
		series/head: series/head + 1
		result
	]

	forall-loop: func [									;@@ inline?
		return: [logic!]
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: as red-word! stack/arguments - 1
		assert TYPE_OF(word) = TYPE_WORD

		series: as red-series! _context/get word
		loop? series
	]

	forall-next: func [									;@@ inline?
		/local
			series [red-series!]
	][
		series: as red-series! _context/get as red-word! stack/arguments - 1
		series/head: series/head + 1
	]

	forall-end: func [									;@@ inline?
		/local
			series [red-series!]
			word   [red-word!]
	][
		word: 	as red-word!   stack/arguments - 1
		series: as red-series! stack/arguments - 2

		assert any [									;@@ replace with any-block?/any-string? check
			TYPE_OF(series) = TYPE_BLOCK
			TYPE_OF(series) = TYPE_STRING
		]
		assert TYPE_OF(word) = TYPE_WORD

		_context/set word as red-value! series			;-- reset series to its initial offset
	]

	register [
		:if*
		:unless*
		:either*
		:any*
		:all*
		:while*
		:until*
		:loop*
		:repeat*
		:foreach*
		:forall*
		:func*
		:function*
		:does*
		:has*
		:exit*
		:return*
		:switch*
		:case*
		:do*
		:get*
		:set*
		:print*
		:prin*
		:equal?*
		:not-equal?*
		:strict-equal?*
		:lesser?*
		:greater?*
		:lesser-or-equal?*
		:greater-or-equal?*
		:same?*
		:not*
		:halt*
		:type?*
		:load*
	]

]


TESTS: additional vector tests

TESTS: additional vector tests

Red [
	Title:   "Red series test script"
	Author:  "Peter W A Wood"
	File: 	 %vector-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 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~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

	--test-- "vector-trunc-6"
		vt5-v: make vector! [float! 32 [0.0 1.0 2.0]]
		append vt5-v 1.23456789012345678901234567
		--assert 1.234567880630493 = vt5-v/4

===end-group===

===start-group=== "vector path notation"

	--test-- "vector-path-1"
		vp1-v: [0 1 2 3 4]
		--assert none = vp1-v/0
		--assert 0 = vp1-v/1
		--assert 1 = vp1-v/2
		--assert 2 = vp1-v/3
		--assert 3 = vp1-v/4
		--assert 4 = vp1-v/5
		--assert none = vp1-v/6
		--assert none = vp1-v/-1

===end-group===

~~~end-file~~~

Red [
	Title:   "Red series test script"
	Author:  "Peter W A Wood"
	File: 	 %vector-test.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 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~~~ "vector"

===start-group=== "make"

	vector-make-test: func [
		name [string!]
		type [datatype!]
		spec [block!]
		len [integer!]
		test-value [char! float! integer!]
		/local
			vm-v
	][
		--test-- name
		vm-v: make vector! spec
		--assert len = length? vm-v
		foreach v vm-v [
			test-value: test-value + 1
			--assert test-value = v
			--assert type = type? v
		]
		--assert none = vm-v/0
		--assert none = vm-v/(len + 1)
	]

	--test-- "vector-make-1"
		vm1-v: make vector! 10
		--assert 10 = length? vm1-v
		foreach v vm1-v [
			--assert v = 0
			--assert integer! = type? v
		]
		--assert none = vm1-v/0
		--assert none = vm1-v/11

	vector-make-test "vector-make-2" integer! [1 2 3 4 5] 5 0

	vector-make-test "vector-make-3" char! [#"b" #"c" #"d" #"e"] 4 #"a"

	vector-make-test "vector-make-4" float! [1.0 2.0 3.0 4.0 5.0] 5 0.0

	vector-make-test "vector-make-5" integer! [integer! 8 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-6" integer! [integer! 16 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-7" integer! [integer! 32 [1 2 3 4 5]] 5 0

	vector-make-test "vector-make-8" float! [float! 64 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

	vector-make-test "vector-make-9" float! [float! 32 [1.0 2.0 3.0 4.0 5.0]] 5 0.0

===end-group===

===start-group=== "vector-truncate"

	--test-- "vector-trunc-1"
		vt1-v: make vector! [char! 8 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt1-v #"^(0100)"
		--assert 4 = length? vt1-v
		--assert #"^(00)" = vt1-v/4
		--assert none = vt1-v/5

	--test-- "vector-trunc-2"
		vt2-v: make vector! [char! 16 [#"^(00)" #"^(01)" #"^(02)"]]
		append vt2-v #"^(100100)"
		--assert 4 = length? vt2-v
		--assert #"^(0100)" = vt2-v/4
		--assert none = vt2-v/5

	--test-- "vector-trunc-3"
		vt3-v: make vector! [integer! 8 [0 1 2]]
		append vt3-v 256
		--assert 4 = length? vt3-v
		--assert 0 = vt3-v/4
		--assert none = vt3-v/5

	--test-- "vector-trunc-4"
		vt4-v: make vector! [integer! 16 [0 1 2]]
		append vt4-v 65536
		--assert 4 = length? vt4-v
		--assert 0 = vt4-v/4
		--assert none = vt4-v/5

===end-group===

~~~end-file~~~