TESTS: added 5 more tests for APPEND with refinements.

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

;; counters
qt-run-tests: 0
qt-run-asserts: 0
qt-run-passes: 0
qt-run-failures: 0
qt-file-tests: 0
qt-file-asserts: 0
qt-file-passes: 0
qt-file-failures: 0

;; group switches
qt-group-name-not-printed: true
qt-group?: false

_qt-init-group: func [] [
  qt-group-name-not-printed: true
  qt-group?: false
  qt-group-name: ""
]

qt-init-run: func [] [
  qt-run-tests: 0
  qt-run-asserts: 0
  qt-run-passes: 0
  qt-run-failures: 0
  _qt-init-group
]

qt-init-file: func [] [
  qt-file-tests: 0
  qt-file-asserts: 0
  qt-file-passes: 0
  qt-file-failures: 0
  _qt-init-group
]

***start-run***: func[
    title [string!]
][
  qt-init-run
  qt-run-name: title
  prin "***Starting*** "
  print title
]

~~~start-file~~~: func [
  title [string!]
][
  qt-init-file
  prin "~~~started test~~~ "
  print title
  qt-file-name: title
  qt-group?: false
]

===start-group===: func [
  title [string!]
][
  qt-group-name: title
  qt-group?: true
]

--test--: func [
  title [string!]
][
  qt-test-name: title
  qt-file-tests: qt-file-tests + 1
]

--assert: func [
  assertion [logic!]
][

  qt-file-asserts: qt-file-asserts + 1

  either assertion [
     qt-file-passes: qt-file-passes + 1
  ][
    qt-file-failures: qt-file-failures + 1
    if qt-group? [
      if qt-group-name-not-printed [
        prin "===group=== "
        print qt-group-name
        qt-group-name-not-printed: false
      ]
    ]
    prin "--test-- "
    prin qt-test-name
    print " FAILED**************"
  ]
]

===end-group===: func [] [
  _qt-init-group
]

qt-print-totals: func [
  tests     [integer!]
  asserts   [integer!]
  passes    [integer!]
  failures  [integer!]
][
  prin  "  Number of Tests Performed:      "
  print tests
  prin  "  Number of Assertions Performed: "
  print asserts
  prin  "  Number of Assertions Passed:    "
  print passes
  prin  "  Number of Assertions Failed:    "
  print failures
  if failures <> 0 [
    print "****************TEST FAILURES****************"
  ]
]

~~~end-file~~~: func [] [
  print ""
  prin "~~~finished test~~~ "
  print qt-file-name
  qt-print-totals qt-file-tests qt-file-asserts qt-file-passes qt-file-failures
  print ""

  ;; update run totals
  qt-run-passes: qt-run-passes + qt-file-passes
  qt-run-asserts: qt-run-asserts + qt-file-asserts
  qt-run-failures: qt-run-failures + qt-file-failures
  qt-run-tests: qt-run-tests + qt-file-tests
]

***end-run***: func [][
  prin "***Finished*** "
  print qt-run-name
  qt-print-totals qt-run-tests
                  qt-run-asserts
                  qt-run-passes
                  qt-run-failures
]

~~~start-file~~~ "series"

===start-group=== "first, second, third, fourth, fifth"

	--test-- "series-fstff-1"
	  sf1-ser:  [1 2 3 4 5]
	--assert 1 = first sf1-ser
	--assert 2 = second sf1-ser
	--assert 3 = third sf1-ser
	--assert 4 = fourth sf1-ser
	--assert 5 = fifth sf1-ser
	--assert 5 = last sf1-ser

	--test-- "series-fstff-2"
	  sf2-ser:  [1 2 3 4 5]
	--assert 2 = first next sf2-ser

	--test-- "series-fstff-3"
	  sf3-ser:  "12345"
	--assert 49 = first sf3-ser
	--assert 53 = last sf3-ser

	--test-- "series-fstff-4"
	  sf4-ser:  [1 2 3 4 5]
	--assert none = fifth next sf4-ser

	--test-- "series-fstff-5"
	  sf5-ser:  "12345"
	--assert 53 = fifth sf5-ser

	--test-- "series-fstff-6"
	  stf6-ser: #{000102}
	;;--assert 0 = first stf6-ser

	--test-- "series-fstff-7"
	--assert 'a = first [a b c d]

	--test-- "series-fstff-8"
	--assert 'a = first first first first first first first first first [[[[[[[[[a]]]]]]]]]

	--test-- "series-fstff-9"
	--assert #"^(00)" = first "^(00)"

	--test-- "series-fstff-10"
	--assert #"^(00)" = first "^(00)a"

	--test-- "series-fstff-11"
	--assert #"^(00)" = second "a^(00)"

	--test-- "series-fstff-12"
	--assert #"^(00)" = second "a^(00)b"

===end-group===

===start-group=== "next"
  --test-- "series-next-1"
  --assert 2 = first next [1 2 3 4 5]
  --test-- "series-next-2"
  --assert 3 = first next next [1 2 3 4 5]
  --test-- "series-next-3"
  --assert 4 = first next next next [1 2 3 4 5]
  --test-- "series-next-4"
  --assert 5 = first next next next next [1 2 3 4 5]
  --test-- "series-next-5"
  --assert none = first next next next next next [1 2 3 4 5]
  --test-- "series-next-6"
  --assert 50 = first next "12345"
  --test-- "series-next-7"
  --assert 51 = first next next "12345"
  --test-- "series-next-8"
  --assert 52 = first next next next "12345"
  --test-- "series-next-9"
  --assert 53 = first next next next next "12345"
  --test-- "series-next-10"
  --assert none = first next next next next next "12345"
  --test-- "series-next-11"
  --assert #"^(00)" = first next "a^(00)"
  --test-- "series-next-12"
  --assert #"^(00)" = first next "a^(00)b"
===end-group===

===start-group=== "back"
  --test-- "series-back-1"
  --assert 1 = first back next [1 2 3 4 5]
  --test-- "series-back-2"
  --assert 1 = first back back next next [1 2 3 4 5]
  --test-- "series-back-3"
  --assert 1 = first back back back next next next [1 2 3 4 5]
  --test-- "series-back-4"
  --assert 1 = first back back back back next next next next [1 2 3 4 5]
  --test-- "series-back-5"
  --assert 1 = first back back back back back next next next next next [1 2 3 4 5]
  --test-- "series-back-6"
  --assert 49 = first back next "12345"
  --test-- "series-back-7"
  --assert 50 = first back next next "12345"
  --test-- "series-back-8"
  --assert 51 = first back next next next "12345"
  --test-- "series-back-9"
  --assert 52 = first back next next next next "12345"
  --test-- "series-back-10"
  --assert 53 = first back next next next next next "12345"
  --test-- "series-back-11"
  --assert 49 = first back "12345"
===end-group===

===start-group=== "tail"
  --test-- "series-tail-1"
  --assert 5 = first back tail [1 2 3 4 5]
  --test-- "seried-tail-2"
  --assert none = pick tail [1 2 3 4 5] 1
===end-group===

===start-group=== "pick"

  --test-- "series-pick-1"
  --assert none = pick "" 1

  --test-- "series-pick-2"
  --assert none = pick "" 0

  --test-- "series-pick-3"
  --assert none = pick "" 2

  --test-- "series-pick-4"
  --assert 49 = pick "12345" 1

  --test-- "series-pick-5"
  --assert 53 = pick "12345" 5

  --test-- "series-pick-6"
  --assert 1 = pick [1 2 3 4 5] 1

  --test-- "series-pick-7"
  --assert 2 = pick [1 2 3 4 5] 2

  --test-- "series-pick-8"
  --assert 4 = pick [1 2 3 4 5] 4

  --test-- "series-pick-9"
  --assert 5 = pick [1 2 3 4 5] 5

  --test-- "series-pick-10"
  --assert 2 = pick next next next [1 2 3 4 5] -2

  --test-- "series-pick-11"
  --assert 3 = pick next next next [1 2 3 4 5] -1

  --test-- "series-pick-12"
  --assert none = pick next next next [1 2 3 4 5] 0

  --test-- "series-pick-13"
  --assert none = pick "12345" -1

  --test-- "series-pick-14"
    sp14-i: 1
  --assert 1 = pick [1 2 3 4 5] sp14-i

  --test-- "series-pick-15"
    sp15-i: 4
  --assert 4 = pick [1 2 3 4 5] sp15-i

  --test-- "series-pick-16"
    sp16-i: -2
  --assert 2 = pick next next next [1 2 3 4 5] sp16-i

  --test-- "series-pick-17"
    sp17-i: 0
  --assert none = pick next next next [1 2 3 4 5] sp17-i

  --test-- "series-pick-18"
    sp18-i: -1
  --assert none = pick "12345" sp18-i

===end-group===

===start-group=== "select"
  --test-- "series-select-1"
  --assert 2 = select [1 2 3 4 5] 1
  --test-- "series-select-2"
  --assert 5 = select [1 2 3 4 5] 4
  --test-- "series-select-1"
  --assert none = select [1 2 3 4 5] 0
  --test-- "series-select-1"
  --assert none = select [1 2 3 4 5] 5
===end-group===

===start-group=== "append"
  --test-- "series-append-1"
  --assert 6 = last append [1 2 3 4 5] 6
  --test-- "series-append-2"
  --assert 6 = last append [1 2 3 4] [5 6]
  --assert 4 = fourth append [1 2 3 4] [5 6]
  --assert 5 = fifth append [1 2 3 4] [5 6]
  --test-- "series-append-3"
  --assert 55 = last append "12345" "67"
  --test-- "series-append-4"
  --assert 233 = last append "abcde" "é" ;; utf-8 C3 A9
  --test-- "series-append-5"
  --assert 49 = last append "abcdeé" "1" ;; utf-8 C3 A9
  --test-- "series-append-6"
  --assert 10000 = last append "abcde" "✐"
  --test-- "series-append-7"
  --assert 48 = last append "abcde^(2710)" "0"
  --test-- "series-append-8"
  --assert 10000 = last append "abcdeé" "^(2710)"
  --test-- "series-append-9"
  --assert 233 = last append "abcde^(2710)" "é"
  --test-- "series-append-10"
  --assert 65536 = last append "abcde" "^(010000)"
  --test-- "series-append-11"
  --assert 48 = last append "abcde^(010000)" "0"
  --test-- "series-append-12"
  --assert 65536 = last append "abcde^(2710)é" "^(010000)"

  --test-- "series-append-13"
	blk: make block! 1
	append blk 'x/y
	append/only blk  'r/s
	--assert "[x y r/s]" = mold blk

  --test-- "series-append-14"
	blk: [1 2]
	append/dup/part blk [4 5 6] 3 2
	--assert "[1 2 4 5 4 5 4 5]" = mold blk

  --test-- "series-append-15"
	blk: [1 2]
	append/dup/part blk [4 5 6] 2 3
	--assert "[1 2 4 5 6 4 5 6]" = mold blk

  --test-- "series-append-16"
	str: "12"
	append/dup/part str "456" 3 2
	--assert str = "12454545"

  --test-- "series-append-17"
	str: "12"
	append/part/dup str "456" 3 2
	--assert str = "12456456"

===end-group===

===start-group=== "series-equal"

  --test-- "series-equal-1"
  --assert [] = []

  --test-- "series-equal-2"
    se2-b: []
  --assert [] = se2-b

  --test-- "series-equal-3"
    se3-b: []
  --assert se3-b = []

  --test-- "series-equal-4"
    se4-b: [1]
  --assert se4-b = [1]

  --test-- "series-equal-5"
    se5-b: ["abcde"]
  --assert se5-b = ["abcde"]

===end-group===

===start-group=== "series-find"

  --test-- "series-find-1"
  --assert 3 = first find [1 2 3 4 5] 3

  --test-- "series-find-2"
  --assert 'a = first find [a b c d e] 'a

  --test-- "series-find-3"
  --assert 'e = first find [a b c d e] 'e

  --test-- "series-find-4"
  --assert none = find [] 'a

  --test-- "series-find-5"
  --assert none = find [1 2 3 4] 'a

  --test-- "series-find-6"
  --assert none = find next [a b c d e] 'a

  --test-- "series-find-7"
  --assert 51 = first find "12345" "3"

  --test-- "series-find-8"
  --assert 51 = first find "12345" "^(33)"

  --test-- "series-find-9"
  --assert 51 = first find "12345" first "^(33)"

  --test-- "series-find-10"
  --assert 51 = first find "12345" #"3"

  --test-- "series-find-11"
  --assert 51 = first find "12345" #"^(33)"

  --test-- "series-find-12"
  --assert #"3" = first find "12345" #"3"

  --test-- "series-find-13"
  --assert #"a" = first find "abcdefghijklmno" #"a"

  --test-- "series-find-14"
  --assert "ghijklmno" = find "abcdefghijklmno" "ghij"

  --test-- "series-find-15"
  --assert #"o" = first find "abcdefghijklmno" #"o"

  --test-- "series-find-16"
  --assert "o" = find "abcdefghijklmno" #"o"

  --test-- "series-find-17"
  --assert #"o" = first find "abcdefghijklmno" "o"

  --test-- "series-find-18"
  --assert "o" = find "abcdefghijklmno" "o"

  --test-- "series-find-19"
  --assert none = find "" #"a"

  --test-- "series-find-20"
  --assert none = find "" #"^(00)"

  --test-- "series-find-21"
  --assert none = find "" ""

  --test-- "series-find-22"
  --assert "^(00)" = find "^(00)" "^(00)"

  --test-- "series-find-23"
  --assert "a^(00)" = find "a^(00)" "a^(00)"

  --test-- "series-find-24"
  --assert "^(00)a" = find "^(00)a" "^(00)a"

  --test-- "series-find-25"
  --assert "^(00)" = find "^(00)" #"^(00)"

  --test-- "series-find-26"
  --assert #"^(00)" = first find "^(00)" #"^(00)"

  --test-- "series-find-27"
  --assert #"é" = first find "abcdeé" #"é"

  --test-- "series-find-28"
  --assert "é" = find "abcdeé" "é"

  --test-- "series-find-29"
  --assert "é" = find append "abcde" "é" "é"

  --test-- "series-find-30"
  --assert 10000 = first find "abcde✐" "✐"

  --test-- "series-find-31"
  --assert none = find "012345" 48

  --test-- "series-find-32"
  --assert "^(010000)" = find "abcde^(2710)é^(010000)" "^(010000)"

  --test-- "series-find-33"
  --assert "^(010000)cde^(2710)é" = find "ab^(010000)cde^(2710)é" #"^(010000)"

  --test-- "series-find-34"
  --assert "^(010000)cde^(2710)é" = find "ab^(010000)cde^(2710)é" "^(010000)"

===end-group===

~~~end-file~~~

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

;; counters
qt-run-tests: 0
qt-run-asserts: 0
qt-run-passes: 0
qt-run-failures: 0
qt-file-tests: 0
qt-file-asserts: 0
qt-file-passes: 0
qt-file-failures: 0

;; group switches
qt-group-name-not-printed: true
qt-group?: false

_qt-init-group: func [] [
  qt-group-name-not-printed: true
  qt-group?: false
  qt-group-name: ""
]

qt-init-run: func [] [
  qt-run-tests: 0
  qt-run-asserts: 0
  qt-run-passes: 0
  qt-run-failures: 0
  _qt-init-group
]

qt-init-file: func [] [
  qt-file-tests: 0
  qt-file-asserts: 0
  qt-file-passes: 0
  qt-file-failures: 0
  _qt-init-group
]

***start-run***: func[
    title [string!]
][
  qt-init-run
  qt-run-name: title
  prin "***Starting*** "
  print title
]

~~~start-file~~~: func [
  title [string!]
][
  qt-init-file
  prin "~~~started test~~~ "
  print title
  qt-file-name: title
  qt-group?: false
]

===start-group===: func [
  title [string!]
][
  qt-group-name: title
  qt-group?: true
]

--test--: func [
  title [string!]
][
  qt-test-name: title
  qt-file-tests: qt-file-tests + 1
]

--assert: func [
  assertion [logic!]
][

  qt-file-asserts: qt-file-asserts + 1

  either assertion [
     qt-file-passes: qt-file-passes + 1
  ][
    qt-file-failures: qt-file-failures + 1
    if qt-group? [
      if qt-group-name-not-printed [
        prin "===group=== "
        print qt-group-name
        qt-group-name-not-printed: false
      ]
    ]
    prin "--test-- "
    prin qt-test-name
    print " FAILED**************"
  ]
]

===end-group===: func [] [
  _qt-init-group
]

qt-print-totals: func [
  tests     [integer!]
  asserts   [integer!]
  passes    [integer!]
  failures  [integer!]
][
  prin  "  Number of Tests Performed:      "
  print tests
  prin  "  Number of Assertions Performed: "
  print asserts
  prin  "  Number of Assertions Passed:    "
  print passes
  prin  "  Number of Assertions Failed:    "
  print failures
  if failures <> 0 [
    print "****************TEST FAILURES****************"
  ]
]

~~~end-file~~~: func [] [
  print ""
  prin "~~~finished test~~~ "
  print qt-file-name
  qt-print-totals qt-file-tests qt-file-asserts qt-file-passes qt-file-failures
  print ""

  ;; update run totals
  qt-run-passes: qt-run-passes + qt-file-passes
  qt-run-asserts: qt-run-asserts + qt-file-asserts
  qt-run-failures: qt-run-failures + qt-file-failures
  qt-run-tests: qt-run-tests + qt-file-tests
]

***end-run***: func [][
  prin "***Finished*** "
  print qt-run-name
  qt-print-totals qt-run-tests
                  qt-run-asserts
                  qt-run-passes
                  qt-run-failures
]

~~~start-file~~~ "series"

===start-group=== "first, second, third, fourth, fifth"

	--test-- "series-fstff-1"
	  sf1-ser:  [1 2 3 4 5]
	--assert 1 = first sf1-ser
	--assert 2 = second sf1-ser
	--assert 3 = third sf1-ser
	--assert 4 = fourth sf1-ser
	--assert 5 = fifth sf1-ser
	--assert 5 = last sf1-ser

	--test-- "series-fstff-2"
	  sf2-ser:  [1 2 3 4 5]
	--assert 2 = first next sf2-ser

	--test-- "series-fstff-3"
	  sf3-ser:  "12345"
	--assert 49 = first sf3-ser
	--assert 53 = last sf3-ser

	--test-- "series-fstff-4"
	  sf4-ser:  [1 2 3 4 5]
	--assert none = fifth next sf4-ser

	--test-- "series-fstff-5"
	  sf5-ser:  "12345"
	--assert 53 = fifth sf5-ser

	--test-- "series-fstff-6"
	  stf6-ser: #{000102}
	;;--assert 0 = first stf6-ser

	--test-- "series-fstff-7"
	--assert 'a = first [a b c d]

	--test-- "series-fstff-8"
	--assert 'a = first first first first first first first first first [[[[[[[[[a]]]]]]]]]

	--test-- "series-fstff-9"
	--assert #"^(00)" = first "^(00)"

	--test-- "series-fstff-10"
	--assert #"^(00)" = first "^(00)a"

	--test-- "series-fstff-11"
	--assert #"^(00)" = second "a^(00)"

	--test-- "series-fstff-12"
	--assert #"^(00)" = second "a^(00)b"

===end-group===

===start-group=== "next"
  --test-- "series-next-1"
  --assert 2 = first next [1 2 3 4 5]
  --test-- "series-next-2"
  --assert 3 = first next next [1 2 3 4 5]
  --test-- "series-next-3"
  --assert 4 = first next next next [1 2 3 4 5]
  --test-- "series-next-4"
  --assert 5 = first next next next next [1 2 3 4 5]
  --test-- "series-next-5"
  --assert none = first next next next next next [1 2 3 4 5]
  --test-- "series-next-6"
  --assert 50 = first next "12345"
  --test-- "series-next-7"
  --assert 51 = first next next "12345"
  --test-- "series-next-8"
  --assert 52 = first next next next "12345"
  --test-- "series-next-9"
  --assert 53 = first next next next next "12345"
  --test-- "series-next-10"
  --assert none = first next next next next next "12345"
  --test-- "series-next-11"
  --assert #"^(00)" = first next "a^(00)"
  --test-- "series-next-12"
  --assert #"^(00)" = first next "a^(00)b"
===end-group===

===start-group=== "back"
  --test-- "series-back-1"
  --assert 1 = first back next [1 2 3 4 5]
  --test-- "series-back-2"
  --assert 1 = first back back next next [1 2 3 4 5]
  --test-- "series-back-3"
  --assert 1 = first back back back next next next [1 2 3 4 5]
  --test-- "series-back-4"
  --assert 1 = first back back back back next next next next [1 2 3 4 5]
  --test-- "series-back-5"
  --assert 1 = first back back back back back next next next next next [1 2 3 4 5]
  --test-- "series-back-6"
  --assert 49 = first back next "12345"
  --test-- "series-back-7"
  --assert 50 = first back next next "12345"
  --test-- "series-back-8"
  --assert 51 = first back next next next "12345"
  --test-- "series-back-9"
  --assert 52 = first back next next next next "12345"
  --test-- "series-back-10"
  --assert 53 = first back next next next next next "12345"
  --test-- "series-back-11"
  --assert 49 = first back "12345"
===end-group===

===start-group=== "tail"
  --test-- "series-tail-1"
  --assert 5 = first back tail [1 2 3 4 5]
  --test-- "seried-tail-2"
  --assert none = pick tail [1 2 3 4 5] 1
===end-group===

===start-group=== "pick"

  --test-- "series-pick-1"
  --assert none = pick "" 1

  --test-- "series-pick-2"
  --assert none = pick "" 0

  --test-- "series-pick-3"
  --assert none = pick "" 2

  --test-- "series-pick-4"
  --assert 49 = pick "12345" 1

  --test-- "series-pick-5"
  --assert 53 = pick "12345" 5

  --test-- "series-pick-6"
  --assert 1 = pick [1 2 3 4 5] 1

  --test-- "series-pick-7"
  --assert 2 = pick [1 2 3 4 5] 2

  --test-- "series-pick-8"
  --assert 4 = pick [1 2 3 4 5] 4

  --test-- "series-pick-9"
  --assert 5 = pick [1 2 3 4 5] 5

  --test-- "series-pick-10"
  --assert 2 = pick next next next [1 2 3 4 5] -2

  --test-- "series-pick-11"
  --assert 3 = pick next next next [1 2 3 4 5] -1

  --test-- "series-pick-12"
  --assert none = pick next next next [1 2 3 4 5] 0

  --test-- "series-pick-13"
  --assert none = pick "12345" -1

  --test-- "series-pick-14"
    sp14-i: 1
  --assert 1 = pick [1 2 3 4 5] sp14-i

  --test-- "series-pick-15"
    sp15-i: 4
  --assert 4 = pick [1 2 3 4 5] sp15-i

  --test-- "series-pick-16"
    sp16-i: -2
  --assert 2 = pick next next next [1 2 3 4 5] sp16-i

  --test-- "series-pick-17"
    sp17-i: 0
  --assert none = pick next next next [1 2 3 4 5] sp17-i

  --test-- "series-pick-18"
    sp18-i: -1
  --assert none = pick "12345" sp18-i

===end-group===

===start-group=== "select"
  --test-- "series-select-1"
  --assert 2 = select [1 2 3 4 5] 1
  --test-- "series-select-2"
  --assert 5 = select [1 2 3 4 5] 4
  --test-- "series-select-1"
  --assert none = select [1 2 3 4 5] 0
  --test-- "series-select-1"
  --assert none = select [1 2 3 4 5] 5
===end-group===

===start-group=== "append"
  --test-- "series-append-1"
  --assert 6 = last append [1 2 3 4 5] 6
  --test-- "series-append-2"
  --assert 6 = last append [1 2 3 4] [5 6]
  --assert 4 = fourth append [1 2 3 4] [5 6]
  --assert 5 = fifth append [1 2 3 4] [5 6]
  --test-- "series-append-3"
  --assert 55 = last append "12345" "67"
  --test-- "series-append-4"
  --assert 233 = last append "abcde" "é" ;; utf-8 C3 A9
  --test-- "series-append-5"
  --assert 49 = last append "abcdeé" "1" ;; utf-8 C3 A9
  --test-- "series-append-6"
  --assert 10000 = last append "abcde" "✐"
  --test-- "series-append-7"
  --assert 48 = last append "abcde^(2710)" "0"
  --test-- "series-append-8"
  --assert 10000 = last append "abcdeé" "^(2710)"
  --test-- "series-append-9"
  --assert 233 = last append "abcde^(2710)" "é"
  --test-- "series-append-10"
  --assert 65536 = last append "abcde" "^(010000)"
  --test-- "series-append-11"
  --assert 48 = last append "abcde^(010000)" "0"
  --test-- "series=append-12"
  --assert 65536 = last append "abcde^(2710)é" "^(010000)"

===end-group===

===start-group=== "series-equal"

  --test-- "series-equal-1"
  --assert [] = []

  --test-- "series-equal-2"
    se2-b: []
  --assert [] = se2-b

  --test-- "series-equal-3"
    se3-b: []
  --assert se3-b = []

  --test-- "series-equal-4"
    se4-b: [1]
  --assert se4-b = [1]

  --test-- "series-equal-5"
    se5-b: ["abcde"]
  --assert se5-b = ["abcde"]

===end-group===

===start-group=== "series-find"

  --test-- "series-find-1"
  --assert 3 = first find [1 2 3 4 5] 3

  --test-- "series-find-2"
  --assert 'a = first find [a b c d e] 'a

  --test-- "series-find-3"
  --assert 'e = first find [a b c d e] 'e

  --test-- "series-find-4"
  --assert none = find [] 'a

  --test-- "series-find-5"
  --assert none = find [1 2 3 4] 'a

  --test-- "series-find-6"
  --assert none = find next [a b c d e] 'a

  --test-- "series-find-7"
  --assert 51 = first find "12345" "3"

  --test-- "series-find-8"
  --assert 51 = first find "12345" "^(33)"

  --test-- "series-find-9"
  --assert 51 = first find "12345" first "^(33)"

  --test-- "series-find-10"
  --assert 51 = first find "12345" #"3"

  --test-- "series-find-11"
  --assert 51 = first find "12345" #"^(33)"

  --test-- "series-find-12"
  --assert #"3" = first find "12345" #"3"

  --test-- "series-find-13"
  --assert #"a" = first find "abcdefghijklmno" #"a"

  --test-- "series-find-14"
  --assert "ghijklmno" = find "abcdefghijklmno" "ghij"

  --test-- "series-find-15"
  --assert #"o" = first find "abcdefghijklmno" #"o"

  --test-- "series-find-16"
  --assert "o" = find "abcdefghijklmno" #"o"

  --test-- "series-find-17"
  --assert #"o" = first find "abcdefghijklmno" "o"

  --test-- "series-find-18"
  --assert "o" = find "abcdefghijklmno" "o"

  --test-- "series-find-19"
  --assert none = find "" #"a"

  --test-- "series-find-20"
  --assert none = find "" #"^(00)"

  --test-- "series-find-21"
  --assert none = find "" ""

  --test-- "series-find-22"
  --assert "^(00)" = find "^(00)" "^(00)"

  --test-- "series-find-23"
  --assert "a^(00)" = find "a^(00)" "a^(00)"

  --test-- "series-find-24"
  --assert "^(00)a" = find "^(00)a" "^(00)a"

  --test-- "series-find-25"
  --assert "^(00)" = find "^(00)" #"^(00)"

  --test-- "series-find-26"
  --assert #"^(00)" = first find "^(00)" #"^(00)"

  --test-- "series-find-27"
  --assert #"é" = first find "abcdeé" #"é"

  --test-- "series-find-28"
  --assert "é" = find "abcdeé" "é"

  --test-- "series-find-29"
  --assert "é" = find append "abcde" "é" "é"

  --test-- "series-find-30"
  --assert 10000 = first find "abcde✐" "✐"

  --test-- "series-find-31"
  --assert none = find "012345" 48

  --test-- "series-find-32"
  --assert "^(010000)" = find "abcde^(2710)é^(010000)" "^(010000)"

  --test-- "series-find-33"
  --assert "^(010000)cde^(2710)é" = find "ab^(010000)cde^(2710)é" #"^(010000)"

  --test-- "series-find-34"
  --assert "^(010000)cde^(2710)é" = find "ab^(010000)cde^(2710)é" "^(010000)"

===end-group===

~~~end-file~~~


TESTS: added tests re issue #826 to function-test.red

Red [
	Title:   "Red function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %function-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 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~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert quote (1 + 2) = res
		--assert non-evaluated (quote (1 + 2)) = res
		--assert non-evaluated quote (1 + 2) = 3

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"

	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

	unless system/interpreted? [			;-- routine creation not supported by interpreter
		--test-- "infix-2"
				*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

===start-group=== "Scope of Varibles"

	--test-- "scope1 issue #825"
		s1-text: "abcde"
		s1-f: function [/external s1-text] [
			s1-text
		]
		--assert s1-f = "abcde"

	--test-- "scope2 issue #825"
		s2-f: function [/external s2-text] [
			s2-text
		]
		s2-text: "abcde"
		--assert s2-f = "abcde"

	--test-- "scope3 issue #825"
		s3-text: "abcde"
		s3-f: func [/local s3-text] [
			s3-text: "12345"
		]

	--test-- "scope4 issue #825"
		s4-text: "abcde"
		s4-f: function [extern s4-text] [
			if extern [s4-text: "12345"]
			s4-text
		]
		--assert "12345" = s4-f true "00000"

	--test-- "scope5 issue #826"
		s5-text: "abcde"
		s5-f: func[/extern s5-text] [
			either extern [
				s5-text
			][
				"00000"
			]
		]
		--assert "12345" s5-f/extern "12345"

	--test-- "scope6 issue #826"
		s6-text: "abcde"
		s6-f: func [local s6-text] [
			s6-text
		]
		--assert "12345" = s6-f "filler" "12345"

	--test-- "scope7 issue #826"
		s7-text: "abcde"
		s7-f: function [local s7-text] [
			s7-text
		]
		--assert "12345" = s7-f "filler" "12345"

===end-group===

~~~end-file~~~

Red [
	Title:   "Red function test script"
	Author:  "Nenad Rakocevic & Peter W A Wood"
	File: 	 %function-test.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 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~~~ "function"

===start-group=== "Basic function tests"

	--test-- "fun-1"
		foo1: func [][1]
		--assert 1 = foo1

	--test-- "fun-2"
		foo2: func [a][a]
		--assert 5 = foo2 5
		--assert "a" = foo2 "a"
		--assert [123] = foo2 [123]

	--test-- "fun-3"
		foo3: func [a /local c][c: 1 a + c]
		--assert 3 = foo3 2

	--test-- "fun-4"
		foo4: func [a /ref][either ref [a][0]]
		--assert 0 = foo4 5
		--assert 5 = foo4/ref 5

	--test-- "fun-5"
		foo5: func [a /ref b][if ref [a: a + b] a * 2]
		--assert 10 = foo5 5
		--assert 16 = foo5/ref 5 3

	--test-- "fun-6"
		z: 10
		foo6: func [a [integer!] b [integer!] /ref d /local c][
			c: 2
			unless ref [d: 0]
			a + b * c + z + d
		]

		--assert 16 = foo6 1 2
		--assert 21 = foo6/ref 1 2 5

	--test-- "fun-7"
		bar:  func [] [foo7]
		foo7: func [] [42]
		--assert 42 = bar

	--test-- "fun-8"
		foo8: func ['a :b][
			--assert a = 'test
			--assert "(1 + 2)" = mold b
		]
		foo8 test (1 + 2)

	--test-- "fun-9"
		foo9: func [/local cnt][
			cnt: [0]
			cnt/1: cnt/1 + 1
		]
		--assert 1 = foo9
		--assert 2 = foo9
		--assert 3 = foo9

	--test-- "fun-10"
		foo10: func [a][a + 0]
		foo10: func [][1]
		--assert 1 = foo10 "dummy"						;-- make it crash if wrong function referenced

	--test-- "fun-11"
		non-evaluated: func ['param] [param]
		res: first [(1 + 2)]
		--assert quote (1 + 2) = res
		--assert non-evaluated (quote (1 + 2)) = res
		--assert non-evaluated quote (1 + 2) = 3

===end-group===

===start-group=== "Alternate constructor tests"

	--test-- "fun-alt-1"
		z: 0
		alt1: function [a][
			z: 2
			a + z
		]
		--assert 10 = alt1 8
		--assert z = 0

	--test-- "fun-alt-2"
		alt2: does [123]
		--assert 123 = alt2

	--test-- "fun-alt-3"
		alt3: has [c][c: 1 c]
		--assert 1 = alt3

===end-group===

===start-group=== "Exit and Return tests"

	--test-- "fun-exit-1"
		ex1: does [123 exit 0]
		--assert unset! = type? ex1

	--test-- "fun-exit-2"
		ex2: does [if true [exit] 0]
		--assert unset! = type? ex2

	--test-- "fun-exit-3"
		ex3: does [until [if true [if true [exit]] true] 0]
		--assert unset! = type? ex3

	--test-- "fun-ret-1"
		ret1: does [return true]
		--assert ret1

	--test-- "fun-ret-2"
		ret2: does [return 123]
		--assert 123 = ret2

	--test-- "fun-ret-3"
		ret3: does [if true [return 3]]
		--assert 3 = ret3

	--test-- "fun-ret-4"
		ret4: does [return 1 + 1]
		--assert 2 = ret4

	--test-- "fun-ret-5"
		ret5: does [return either false [12][34]]
		--assert 34 = ret5

	--test-- "fun-ret-6"								;-- issue #770
		ret6: func [i [integer!]][
			until [
				if true [
					if i = 0 [
						if true [return 0]
						return 1
					]
					return 2
				]
				return 3
				true
			]
		]
		--assert 0 = ret6 0
		--assert 2 = ret6 1

	--test-- "fun-ret-7"
		f: function [][
			blk: [1 2 3 4 5]
			foreach i blk [
				case [
					i > 1 [return i]
				]
			]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-8"
		f: function [][
		    case [
		        2 > 1 [return true]
		    ]
		]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-9"
		f: function [][if true [return true]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		g: function [][if true [return 1]]
		--assert g = 1

	--test-- "fun-ret-10"
		f: function [][true]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-11"
		f: function [][if true [return true]]
		g: function [][if (f) [return 1]]
		--assert g = 1

	--test-- "fun-ret-12"
		f: function [][if true [return true] ]
		g: function [][if not not f [return 1]]
		--assert g = 1

	--test-- "fun-ret-13"
		f: function [][if true [return 'X]]
		g: function [][if f [return 1]]
		--assert g = 1

	--test-- "fun-ret-14"								;-- issue #778
	 	--assert 1 = do load "f: func [][return 1] t: f"

===end-group===

===start-group=== "Reflection"
	clean-strings: func [blk [block!]][
		blk: copy blk
		forall blk [if string? blk/1 [remove blk blk: back blk]]
		blk
	]

	--test-- "fun-ref-1"
		ref1: func [a b][a + b]
		--assert [a b] = spec-of :ref1
		body: body-of :ref1
		--assert any [
			[a + b] = body
			none? body									;-- if option store-bodies = no
		]

	--test-- "fun-ref-2"
		blk: clean-strings spec-of :append
		--assert blk = [
			series [series!] value [any-type!] /part length [number! series!]
			/only /dup count [number!] return: [series!]
		]

	--test-- "fun-ref-3"
		blk: clean-strings spec-of :set
		--assert blk = [word [any-word! block!] value [any-type!] /any return: [any-type!]]

	--test-- "fun-ref-4"
		blk: clean-strings spec-of :<
		--assert blk = [value1 [any-type!] value2 [any-type!]]

===end-group===

===start-group=== "Capturing of iterators counter word(s)"

	--test-- "fun-capt-1"
		f1: function [] [repeat ii 5 [ii]]
		--assert none <> find spec-of :f1 'ii
		f1
		--assert unset? get/any 'ii

	--test-- "fun-capt-2"
		f2: function [] [foreach ii [1 2 3] [ii]]
		--assert none <> find spec-of :f2 'ii
		f2
		--assert unset? get/any 'ii

	--test-- "fun-capt-3"
		f3: function [] [foreach [ii jj] [1 2 3 4] [ii jj]]
		--assert none <> find spec-of :f3 'ii
		--assert none <> find spec-of :f3 'jj
		f3
		--assert unset? get/any 'ii
		--assert unset? get/any 'jj

===end-group===

===start-group=== "Reported issues"
  	--test-- "ri1 issue #415"
    	i415-f: func [] [
    		g: func [] [1]
    		g
    	]
    --assert 1 = i415-f

  	--test-- "ri2 issue #461"
  		ri2-fn: func ['word] [:word]
  	--assert op? ri2-fn :+

  	--test-- "ri3 issue #461"
  		ri3-fn: func ['word] [mold :word]
  	--assert "'+" = ri3-fn '+

  	--test-- "ri4 issue #461"
  		ri4-fn: func ['word] [mold :word]
  	--assert "+" = ri4-fn +

  	;--test-- "ri5 issue #420"
  	;	ri5-fn: function [][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri5-fn

  	;--test-- "ri6 issue #420"
  	;	ri6-fn: func [
  	;		/local
  	;			g
  	;	][
  	;		g: func [] [true]
  	;		g
  	;	]
  	;--assert ri6-fn

  	;--test-- "ri7 issue #420"
  	;	ri7-g: func [][true]
  	;	ri7-f: func [][g]
  	;--assert ri7-f

  	--test-- "ri8 issue #443"
  		ri8-fn: func[
  			/local
  				ri8-b
  				ri8-i
  				ri8-j
  		][
  			ri8-b: copy []
  			foreach [ri8-i ri8-j] [1 2 3 4] [append ri8-b ri8-i * ri8-j]
  			ri8-b
  		]
  		ri8-i: 100
  		ri8-j: 200
  	--assert [2 12] = ri8-fn
  	--assert 100 = ri8-i
  	--assert 200 = ri8-j

  	--test-- "ri9 issue #443"
  		ri9-i: -1
  		ri9-j: -2
  		ri9-fn: function[][
  			ri9-b: copy []
  			foreach [ri9-i ri9-j] [1 2 3 4] [append ri9-b ri9-i * ri9-j]
  			ri9-b
  		]
  	--assert [2 12] = ri9-fn
  	--assert ri9-i = -1
  	--assert ri9-j = -2
  	;--assert unset! = type? get 'ri9-i		;-- temporary disabled to avoid the hardcoded error msg
  	;--assert unset! = type? get 'ri9-j

===end-group===

===start-group=== "Infix operators creation"

	--test-- "infix-1"
		infix: function [a b][a * 10 + b]
		***: make op! :infix
		--assert 7 *** 3 = 73

		infix2: routine [a [integer!] b [integer!]][integer/box a * 20 + b]

	unless system/interpreted? [			;-- routine creation not supported by interpreter
		--test-- "infix-2"
				*+*: make op! :infix2
			--assert 5 *+* 6 = 106

		--test-- "infix-3"
			--assert 5 *+* 6 *** 7 = 1067
	]

===end-group===

~~~end-file~~~


FIX: missing local declaration in interpreter.reds.

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.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 CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			either next = as red-word! pc [
				#if debug? = yes [if verbose > 0 [log "infix detected!"]]
				infix?: yes
			][
				if TYPE_OF(pc) = TYPE_WORD [
					left: _context/get as red-word! pc
				]
				unless all [
					TYPE_OF(pc) = TYPE_WORD
					any [
						TYPE_OF(left) = TYPE_ACTION
						TYPE_OF(left) = TYPE_NATIVE
						TYPE_OF(left) = TYPE_FUNCTION
					]
					literal-first-arg? as red-native! left	;-- a literal argument is expected
				][
					#if debug? = yes [if verbose > 0 [log "infix detected!"]]
					infix?: yes
				]
			]
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [fire [TO_ERROR(script no-arg) fname value]]

	switch TYPE_OF(value) [
		TYPE_WORD [
			#if debug? = yes [if verbose > 0 [log "evaluating argument"]]
			pc: eval-expression pc end no yes
		]
		TYPE_GET_WORD [
			#if debug? = yes [if verbose > 0 [log "fetching argument as-is"]]
			stack/push pc
			pc: pc + 1
		]
		default [
			#if debug? = yes [if verbose > 0 [log "fetching argument"]]
			switch TYPE_OF(pc) [
				TYPE_GET_WORD [
					copy-cell _context/get as red-word! pc stack/push*
				]
				TYPE_PAREN [
					either TYPE_OF(value) = TYPE_LIT_WORD [
						stack/mark-native as red-word! pc	;@@ ~paren
						eval as red-block! pc yes
						stack/unwind
					][
						stack/push pc
					]
				]
				TYPE_GET_PATH [
					eval-path pc pc + 1 end no yes yes
				]
				default [
					stack/push pc
				]
			]
			pc: pc + 1
		]
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls
	in-func?:	 0										;@@ make it thread-safe?

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	literal-first-arg?: func [
		native 	[red-native!]
		return: [logic!]
		/local
			fun	  [red-function!]
			value [red-value!]
			tail  [red-value!]
			s	  [series!]
	][
		s: as series! either TYPE_OF(native) = TYPE_FUNCTION [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 		[return no]
				TYPE_LIT_WORD	[return yes]
				default 		[0]
			]
			value: value + 1
		]
		no
	]

	set-locals: func [
		fun [red-function!]
		/local
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
			set?  [logic!]
	][
		s: as series! fun/spec/value
		value: s/offset
		tail:  s/tail
		set?:  no

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					if set? [none/push]
				]
				TYPE_REFINEMENT [
					unless set? [set?: yes]
					logic/push false
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]
	]

	eval-function: func [
		[catch]
		fun  [red-function!]
		body [red-block!]
		/local
			ctx	  [red-context!]
			saved [node!]
	][
		in-func?: in-func? + 1
		ctx: GET_CTX(fun)
		saved: ctx/values
		ctx/values: as node! stack/arguments

		eval body yes

		ctx/values: saved
		in-func?: in-func? - 1
		if system/thrown = RED_ERROR [throw RED_ERROR]	;-- let exception pass through
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			left   [red-value!]
			fun	   [red-function!]
			infix? [logic!]
			op	   [red-op!]
			s	   [series!]
			node   [node!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value

		either op/header and body-flag <> 0 [
			node: as node! op/code
			s: as series! node/value
			fun: as red-function! s/offset + 3

			either TYPE_OF(fun) = TYPE_ROUTINE [
				exec-routine as red-routine! fun
			][
				set-locals fun
				eval-function fun as red-block! s/offset
			]
		][
			call-op: as function! [] op/code
			call-op
			0											;-- @@ to make compiler happy!
		]

		#if debug? = yes [
			if verbose > 0 [
				value: stack/arguments
				print-line ["eval: op return type: " TYPE_OF(value)]
			]
		]
		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		ref-pos [red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			expected  [red-value!]
			path-end  [red-value!]
			fname	  [red-word!]
			blk		  [red-block!]
			vec		  [red-vector!]
			bool	  [red-logic!]
			arg		  [red-value!]
			s		  [series!]
			required? [logic!]
			args	  [node!]
			p		  [int-ptr!]
			ref-array [int-ptr!]
			index	  [integer!]
			size	  [integer!]
			type	  [integer!]
			pos		  [byte-ptr!]
			bits 	  [byte-ptr!]
			set? 	  [logic!]
			ret-set?  [logic!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]
		fname:	   as red-word! pc - 1
		args:	   null

		either function? [
			fun: as red-function! native
			s: as series! fun/more/value
			blk: as red-block! s/offset + 1
			if TYPE_OF(blk) = TYPE_BLOCK [args: blk/node]
		][
			args: native/args
		]
		if null? args [
			args: _function/preprocess-spec native

			either function? [
				blk/header: TYPE_BLOCK
				blk/head:	0
				blk/node:	args
			][
				native/args: args
			]
		]

		unless null? path [
			path-end: block/rs-tail as red-block! path
			fname: as red-word! ref-pos

			if ref-pos + 1 < path-end [					;-- test if refinement are following the function
				either null? path/args [
					args: _function/preprocess-options native path ref-pos args fname function?
					path/args: args
				][
					args: path/args
				]
			]
		]

		s: as series! args/value
		value:	   s/offset
		tail:	   s/tail
		required?: yes
		index: 	   0

		while [value < tail][
			expected: value + 1

			if TYPE_OF(value) <> TYPE_SET_WORD [
				switch TYPE_OF(expected) [
					TYPE_TYPESET [
						either required? [
							bits: (as byte-ptr! expected) + 4
							BS_TEST_BIT(bits TYPE_UNSET set?)

							either all [set? pc >= end][ ;-- check for unset! spec
								unset/push
							][
								FETCH_ARGUMENT
								arg:  stack/top - 1
								type: TYPE_OF(arg)
								BS_TEST_BIT(bits type set?)
								unless set? [ERR_EXPECT_ARGUMENT(type index)]
								index: index + 1
							]
						][
							none/push
						]
					]
					TYPE_LOGIC [
						stack/push expected
						bool: as red-logic! expected
						required?: bool/value
					]
					TYPE_VECTOR [
						vec: as red-vector! expected
						s: GET_BUFFER(vec)
						p: as int-ptr! s/offset
						size: (as-integer (as int-ptr! s/tail) - p) / 4
						ref-array: system/stack/top - size
						system/stack/top: ref-array			;-- reserve space on native stack for refs array
						copy-memory as byte-ptr! ref-array as byte-ptr! p size * 4
					]
					default [assert false]				;-- trap it, if stack corrupted
				]
			]
			value: value + 2
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		get?	[logic!]
		sub?	[logic!]
		return: [red-value!]
		/local
			path	[red-path!]
			head	[red-value!]
			tail	[red-value!]
			item	[red-value!]
			parent	[red-value!]
			gparent	[red-value!]
			saved	[red-value!]
			arg		[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "eval: path"]]

		path:   as red-path! value
		head:   block/rs-head as red-block! path
		tail:   block/rs-tail as red-block! path
		item:   head + 1
		saved:  stack/top

		if TYPE_OF(head) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		parent: _context/get as red-word! head
		unless get? [
			switch TYPE_OF(parent) [
				TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code parent pc end yes path item - 1 parent
					return pc
				]
				TYPE_UNSET [fire [TO_ERROR(script no-value)	head]]
				default	   [0]
			]
		]

		while [item < tail][
			#if debug? = yes [if verbose > 0 [print-line ["eval: path parent: " TYPE_OF(parent)]]]

			value: either any [
				TYPE_OF(item) = TYPE_GET_WORD
				all [
					parent = head
					TYPE_OF(item) = TYPE_WORD
					TYPE_OF(parent) <> TYPE_OBJECT
				]
			][
				_context/get as red-word! item
			][
				item
			]
			switch TYPE_OF(value) [
				TYPE_UNSET [fire [TO_ERROR(script no-value)	item]]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value yes		;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- compilation pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			gparent: parent								;-- save grand-parent reference
			arg: either all [set? item + 1 = tail][stack/arguments][null]
			parent: actions/eval-path parent value arg

			unless get? [
				switch TYPE_OF(parent) [
					TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code parent pc end yes path item gparent
						return pc
					]
					default [0]
				]
			]
			item: item + 1
		]

		stack/top: saved
		either sub? [stack/push parent][stack/set-last parent]
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		parent	[red-value!]
		return: [red-value!]
		/local
			name [red-word!]
			obj  [red-object!]
			fun	 [red-function!]
			int	 [red-integer!]
			s	 [series!]
			ctx	 [node!]
	][
		either null? slot [
			name: as red-word! pc - 1
			if TYPE_OF(name) <> TYPE_WORD [name: words/_anon]
		][
			name: as red-word! slot
		]
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				#if debug? = yes [if verbose > 0 [log "pushing action/native frame"]]
				stack/mark-native name
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: action/native return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_ROUTINE [
				#if debug? = yes [if verbose > 0 [log "pushing routine frame"]]
				stack/mark-native name
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: routine return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_FUNCTION [
				#if debug? = yes [if verbose > 0 [log "pushing function frame"]]
				obj: as red-object! parent
				ctx: either all [
					parent <> null
					TYPE_OF(parent) = TYPE_OBJECT
				][
					obj/ctx
				][
					fun: as red-function! value
					s: as series! fun/more/value
					int: as red-integer! s/offset + 4
					either TYPE_OF(int) = TYPE_INTEGER [
						ctx: as node! int/value
					][
						name/ctx						;-- get a context from calling name
					]
				]
				stack/mark-func name
				pc: eval-arguments as red-native! value pc end path slot
				_function/call as red-function! value ctx
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: function return type: " TYPE_OF(value)]
					]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			left   [red-value!]
			w	   [red-word!]
			op	   [red-value!]
			sym	   [integer!]
			infix? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc yes
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: set-word return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes no sub?
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				#if debug? = yes [
					if verbose > 0 [
						print "eval: '"
						print-symbol as red-word! pc
						print lf
					]
				]
				value: _context/get as red-word! pc

				if positive? in-func? [
					w: as red-word! pc
					sym: w/symbol
					case [
						sym = words/exit* [
							copy-cell unset-value stack/arguments
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_EXIT
						]
						sym = words/return* [
							pc: pc + 1
							either pc >= end [
								copy-cell unset-value stack/arguments
							][
								pc: eval-expression pc end no yes
							]
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						fire [
							TO_ERROR(script no-value)
							pc - 1
						]
					]
					TYPE_LIT_WORD [
						word/push as red-word! value	;-- push lit-word! on stack
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null value
					]
					default [
						#if debug? = yes [if verbose > 0 [log "getting word value"]]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]
						#if debug? = yes [
							if verbose > 0 [
								value: stack/arguments
								print-line ["eval: word return type: " TYPE_OF(value)]
							]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no no sub?
			]
			TYPE_GET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no yes sub?
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
			TYPE_NATIVE
			TYPE_ROUTINE
			TYPE_FUNCTION [
				value: pc + 1
				if value >= end [value: end]
				pc: eval-code pc value end sub? null null null
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code   [red-block!]
		chain? [logic!]									;-- chain it with previous stack frame
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-eval words/_body					;-- outer stack frame

		while [value < tail][
			#if debug? = yes [if verbose > 0 [log "root loop..."]]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]
		either chain? [stack/unwind-last][stack/unwind]
	]

]

Red/System [
	Title:   "Red interpreter"
	Author:  "Nenad Rakocevic"
	File: 	 %interpreter.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 CHECK_INFIX [
	if all [
		next < end
		TYPE_OF(next) = TYPE_WORD
	][
		value: _context/get next
		if TYPE_OF(value) = TYPE_OP [
			either next = as red-word! pc [
				#if debug? = yes [if verbose > 0 [log "infix detected!"]]
				infix?: yes
			][
				if TYPE_OF(pc) = TYPE_WORD [
					left: _context/get as red-word! pc
				]
				unless all [
					TYPE_OF(pc) = TYPE_WORD
					any [
						TYPE_OF(left) = TYPE_ACTION
						TYPE_OF(left) = TYPE_NATIVE
						TYPE_OF(left) = TYPE_FUNCTION
					]
					literal-first-arg? as red-native! left	;-- a literal argument is expected
				][
					#if debug? = yes [if verbose > 0 [log "infix detected!"]]
					infix?: yes
				]
			]
		]
	]
]

#define FETCH_ARGUMENT [
	if pc >= end [fire [TO_ERROR(script no-arg) fname value]]

	switch TYPE_OF(value) [
		TYPE_WORD [
			#if debug? = yes [if verbose > 0 [log "evaluating argument"]]
			pc: eval-expression pc end no yes
		]
		TYPE_GET_WORD [
			#if debug? = yes [if verbose > 0 [log "fetching argument as-is"]]
			stack/push pc
			pc: pc + 1
		]
		default [
			#if debug? = yes [if verbose > 0 [log "fetching argument"]]
			switch TYPE_OF(pc) [
				TYPE_GET_WORD [
					copy-cell _context/get as red-word! pc stack/push*
				]
				TYPE_PAREN [
					either TYPE_OF(value) = TYPE_LIT_WORD [
						stack/mark-native as red-word! pc	;@@ ~paren
						eval as red-block! pc yes
						stack/unwind
					][
						stack/push pc
					]
				]
				TYPE_GET_PATH [
					eval-path pc pc + 1 end no yes yes
				]
				default [
					stack/push pc
				]
			]
			pc: pc + 1
		]
	]
]

interpreter: context [
	verbose: 0

	return-type: -1										;-- return type for routine calls
	in-func?:	 0										;@@ make it thread-safe?

	log: func [msg [c-string!]][
		print "eval: "
		print-line msg
	]

	literal-first-arg?: func [
		native 	[red-native!]
		return: [logic!]
		/local
			fun	  [red-function!]
			value [red-value!]
			tail  [red-value!]
			s	  [series!]
	][
		s: as series! either TYPE_OF(native) = TYPE_FUNCTION [
			fun: as red-function! native
			fun/spec/value
		][
			native/spec/value
		]
		value: s/offset
		tail:  s/tail

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD 		[return no]
				TYPE_LIT_WORD	[return yes]
				default 		[0]
			]
			value: value + 1
		]
		no
	]

	set-locals: func [
		fun [red-function!]
		/local
			tail  [red-value!]
			value [red-value!]
			s	  [series!]
			set?  [logic!]
	][
		s: as series! fun/spec/value
		value: s/offset
		tail:  s/tail
		set?:  no

		while [value < tail][
			switch TYPE_OF(value) [
				TYPE_WORD
				TYPE_GET_WORD
				TYPE_LIT_WORD [
					if set? [none/push]
				]
				TYPE_REFINEMENT [
					unless set? [set?: yes]
					logic/push false
				]
				default [0]								;-- ignore other values
			]
			value: value + 1
		]
	]

	eval-function: func [
		[catch]
		fun  [red-function!]
		body [red-block!]
		/local
			ctx	  [red-context!]
			saved [node!]
	][
		in-func?: in-func? + 1
		ctx: GET_CTX(fun)
		saved: ctx/values
		ctx/values: as node! stack/arguments

		eval body yes

		ctx/values: saved
		in-func?: in-func? - 1
		if system/thrown = RED_ERROR [throw RED_ERROR]	;-- let exception pass through
	]

	exec-routine: func [
		fun	 [red-routine!]
		/local
			native [red-native!]
			arg	   [red-value!]
			bool   [red-logic!]
			int	   [red-integer!]
			s	   [series!]
			ret	   [integer!]
			count  [integer!]
			call
	][
		s: as series! fun/more/value
		native: as red-native! s/offset + 2
		call: as function! [return: [integer!]] native/code
		count: (routine/get-arity fun) - 1				;-- zero-based stack access

		while [count >= 0][
			arg: stack/arguments + count
			switch TYPE_OF(arg) [
				TYPE_LOGIC	 [push logic/get arg]
				TYPE_INTEGER [push integer/get arg]
				default		 [push arg]
			]
			count: count - 1
		]
		either positive? return-type [
			ret: call
			switch return-type [
				TYPE_LOGIC	[
					bool: as red-logic! stack/arguments
					bool/header: TYPE_LOGIC
					bool/value: ret <> 0
				]
				TYPE_INTEGER [
					int: as red-integer! stack/arguments
					int/header: TYPE_INTEGER
					int/value: ret
				]
				default [assert false]					;-- should never happen
			]
		][
			call
		]
	]

	eval-infix: func [
		value 	  [red-value!]
		pc		  [red-value!]
		end		  [red-value!]
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			left   [red-value!]
			fun	   [red-function!]
			infix? [logic!]
			op	   [red-op!]
			s	   [series!]
			call-op
	][
		stack/keep
		pc: pc + 1										;-- skip operator
		pc: eval-expression pc end yes yes				;-- eval right operand
		op: as red-op! value

		either op/header and body-flag <> 0 [
			node: as node! op/code
			s: as series! node/value
			fun: as red-function! s/offset + 3

			either TYPE_OF(fun) = TYPE_ROUTINE [
				exec-routine as red-routine! fun
			][
				set-locals fun
				eval-function fun as red-block! s/offset
			]
		][
			call-op: as function! [] op/code
			call-op
			0											;-- @@ to make compiler happy!
		]

		#if debug? = yes [
			if verbose > 0 [
				value: stack/arguments
				print-line ["eval: op return type: " TYPE_OF(value)]
			]
		]
		infix?: no
		next: as red-word! pc
		CHECK_INFIX
		if infix? [pc: eval-infix value pc end sub?]
		pc
	]

	eval-arguments: func [
		native 	[red-native!]
		pc		[red-value!]
		end	  	[red-value!]
		path	[red-path!]
		ref-pos [red-value!]
		return: [red-value!]
		/local
			fun	  	  [red-function!]
			function? [logic!]
			routine?  [logic!]
			value	  [red-value!]
			tail	  [red-value!]
			expected  [red-value!]
			path-end  [red-value!]
			fname	  [red-word!]
			blk		  [red-block!]
			vec		  [red-vector!]
			bool	  [red-logic!]
			arg		  [red-value!]
			s		  [series!]
			required? [logic!]
			args	  [node!]
			p		  [int-ptr!]
			ref-array [int-ptr!]
			index	  [integer!]
			size	  [integer!]
			type	  [integer!]
			pos		  [byte-ptr!]
			bits 	  [byte-ptr!]
			set? 	  [logic!]
			ret-set?  [logic!]
			call
	][
		routine?:  TYPE_OF(native) = TYPE_ROUTINE
		function?: any [routine? TYPE_OF(native) = TYPE_FUNCTION]
		fname:	   as red-word! pc - 1
		args:	   null

		either function? [
			fun: as red-function! native
			s: as series! fun/more/value
			blk: as red-block! s/offset + 1
			if TYPE_OF(blk) = TYPE_BLOCK [args: blk/node]
		][
			args: native/args
		]
		if null? args [
			args: _function/preprocess-spec native

			either function? [
				blk/header: TYPE_BLOCK
				blk/head:	0
				blk/node:	args
			][
				native/args: args
			]
		]

		unless null? path [
			path-end: block/rs-tail as red-block! path
			fname: as red-word! ref-pos

			if ref-pos + 1 < path-end [					;-- test if refinement are following the function
				either null? path/args [
					args: _function/preprocess-options native path ref-pos args fname function?
					path/args: args
				][
					args: path/args
				]
			]
		]

		s: as series! args/value
		value:	   s/offset
		tail:	   s/tail
		required?: yes
		index: 	   0

		while [value < tail][
			expected: value + 1

			if TYPE_OF(value) <> TYPE_SET_WORD [
				switch TYPE_OF(expected) [
					TYPE_TYPESET [
						either required? [
							bits: (as byte-ptr! expected) + 4
							BS_TEST_BIT(bits TYPE_UNSET set?)

							either all [set? pc >= end][ ;-- check for unset! spec
								unset/push
							][
								FETCH_ARGUMENT
								arg:  stack/top - 1
								type: TYPE_OF(arg)
								BS_TEST_BIT(bits type set?)
								unless set? [ERR_EXPECT_ARGUMENT(type index)]
								index: index + 1
							]
						][
							none/push
						]
					]
					TYPE_LOGIC [
						stack/push expected
						bool: as red-logic! expected
						required?: bool/value
					]
					TYPE_VECTOR [
						vec: as red-vector! expected
						s: GET_BUFFER(vec)
						p: as int-ptr! s/offset
						size: (as-integer (as int-ptr! s/tail) - p) / 4
						ref-array: system/stack/top - size
						system/stack/top: ref-array			;-- reserve space on native stack for refs array
						copy-memory as byte-ptr! ref-array as byte-ptr! p size * 4
					]
					default [assert false]				;-- trap it, if stack corrupted
				]
			]
			value: value + 2
		]

		unless function? [
			system/stack/top: ref-array					;-- reset native stack to our custom arguments frame
			call: as function! [] native/code			;-- direct call for actions/natives
			call
		]
		pc
	]

	eval-path: func [
		value   [red-value!]
		pc		[red-value!]							;-- path to evaluate
		end		[red-value!]
		set?	[logic!]
		get?	[logic!]
		sub?	[logic!]
		return: [red-value!]
		/local
			path	[red-path!]
			head	[red-value!]
			tail	[red-value!]
			item	[red-value!]
			parent	[red-value!]
			gparent	[red-value!]
			saved	[red-value!]
			arg		[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "eval: path"]]

		path:   as red-path! value
		head:   block/rs-head as red-block! path
		tail:   block/rs-tail as red-block! path
		item:   head + 1
		saved:  stack/top

		if TYPE_OF(head) <> TYPE_WORD [
			print-line "*** Error: path value must start with a word!"
			halt
		]

		parent: _context/get as red-word! head
		unless get? [
			switch TYPE_OF(parent) [
				TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
				TYPE_NATIVE
				TYPE_ROUTINE
				TYPE_FUNCTION [
					pc: eval-code parent pc end yes path item - 1 parent
					return pc
				]
				TYPE_UNSET [fire [TO_ERROR(script no-value)	head]]
				default	   [0]
			]
		]

		while [item < tail][
			#if debug? = yes [if verbose > 0 [print-line ["eval: path parent: " TYPE_OF(parent)]]]

			value: either any [
				TYPE_OF(item) = TYPE_GET_WORD
				all [
					parent = head
					TYPE_OF(item) = TYPE_WORD
					TYPE_OF(parent) <> TYPE_OBJECT
				]
			][
				_context/get as red-word! item
			][
				item
			]
			switch TYPE_OF(value) [
				TYPE_UNSET [fire [TO_ERROR(script no-value)	item]]
				TYPE_PAREN [
					stack/mark-native words/_body		;@@ ~paren
					eval as red-block! value yes		;-- eval paren content
					stack/unwind
					value: stack/top - 1
				]
				default [0]								;-- compilation pass-thru
			]
			#if debug? = yes [if verbose > 0 [print-line ["eval: path item: " TYPE_OF(value)]]]

			gparent: parent								;-- save grand-parent reference
			arg: either all [set? item + 1 = tail][stack/arguments][null]
			parent: actions/eval-path parent value arg

			unless get? [
				switch TYPE_OF(parent) [
					TYPE_ACTION								;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code parent pc end yes path item gparent
						return pc
					]
					default [0]
				]
			]
			item: item + 1
		]

		stack/top: saved
		either sub? [stack/push parent][stack/set-last parent]
		pc
	]

	eval-code: func [
		value	[red-value!]
		pc		[red-value!]
		end		[red-value!]
		sub?	[logic!]
		path	[red-path!]
		slot 	[red-value!]
		parent	[red-value!]
		return: [red-value!]
		/local
			name [red-word!]
			obj  [red-object!]
			fun	 [red-function!]
			int	 [red-integer!]
			s	 [series!]
			ctx	 [node!]
	][
		either null? slot [
			name: as red-word! pc - 1
			if TYPE_OF(name) <> TYPE_WORD [name: words/_anon]
		][
			name: as red-word! slot
		]
		switch TYPE_OF(value) [
			TYPE_ACTION
			TYPE_NATIVE [
				#if debug? = yes [if verbose > 0 [log "pushing action/native frame"]]
				stack/mark-native name
				pc: eval-arguments as red-native! value pc end path slot 	;-- fetch args and exec
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: action/native return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_ROUTINE [
				#if debug? = yes [if verbose > 0 [log "pushing routine frame"]]
				stack/mark-native name
				pc: eval-arguments as red-native! value pc end path slot
				exec-routine as red-routine! value
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: routine return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_FUNCTION [
				#if debug? = yes [if verbose > 0 [log "pushing function frame"]]
				obj: as red-object! parent
				ctx: either all [
					parent <> null
					TYPE_OF(parent) = TYPE_OBJECT
				][
					obj/ctx
				][
					fun: as red-function! value
					s: as series! fun/more/value
					int: as red-integer! s/offset + 4
					either TYPE_OF(int) = TYPE_INTEGER [
						ctx: as node! int/value
					][
						name/ctx						;-- get a context from calling name
					]
				]
				stack/mark-func name
				pc: eval-arguments as red-native! value pc end path slot
				_function/call as red-function! value ctx
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: function return type: " TYPE_OF(value)]
					]
				]
			]
		]
		pc
	]

	eval-expression: func [
		pc		  [red-value!]
		end	  	  [red-value!]
		prefix?	  [logic!]								;-- TRUE => don't check for infix
		sub?	  [logic!]
		return:   [red-value!]
		/local
			next   [red-word!]
			value  [red-value!]
			left   [red-value!]
			w	   [red-word!]
			op	   [red-value!]
			sym	   [integer!]
			infix? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line ["eval: fetching value of type " TYPE_OF(pc)]]]

		infix?: no
		unless prefix? [
			next: as red-word! pc + 1
			CHECK_INFIX
			if infix? [
				stack/mark-native as red-word! pc + 1
				sub?: yes								;-- force sub? for infix expressions
				op: value
			]
		]

		switch TYPE_OF(pc) [
			TYPE_PAREN [
				stack/mark-native as red-word! pc		;@@ ~paren
				eval as red-block! pc yes
				either sub? [stack/unwind][stack/unwind-last]
				pc: pc + 1
			]
			TYPE_SET_WORD [
				stack/mark-native as red-word! pc		;@@ ~set
				word/push as red-word! pc
				pc: pc + 1
				pc: eval-expression pc end no yes
				word/set
				either sub? [stack/unwind][stack/unwind-last]
				#if debug? = yes [
					if verbose > 0 [
						value: stack/arguments
						print-line ["eval: set-word return type: " TYPE_OF(value)]
					]
				]
			]
			TYPE_SET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-expression pc end no yes		;-- yes: push value on top of stack
				pc: eval-path value pc end yes no sub?
			]
			TYPE_GET_WORD [
				copy-cell _context/get as red-word! pc stack/push*
				pc: pc + 1
			]
			TYPE_LIT_WORD [
				either sub? [
					w: word/push as red-word! pc		;-- nested expression: push value
				][
					w: as red-word! stack/set-last pc	;-- root expression: return value
				]
				w/header: TYPE_WORD						;-- coerce it to a word!
				pc: pc + 1
			]
			TYPE_WORD [
				#if debug? = yes [
					if verbose > 0 [
						print "eval: '"
						print-symbol as red-word! pc
						print lf
					]
				]
				value: _context/get as red-word! pc

				if positive? in-func? [
					w: as red-word! pc
					sym: w/symbol
					case [
						sym = words/exit* [
							copy-cell unset-value stack/arguments
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_EXIT
						]
						sym = words/return* [
							pc: pc + 1
							either pc >= end [
								copy-cell unset-value stack/arguments
							][
								pc: eval-expression pc end no yes
							]
							stack/unroll stack/FLAG_FUNCTION
							throw THROWN_RETURN
						]
						true [0]
					]
				]
				pc: pc + 1

				switch TYPE_OF(value) [
					TYPE_UNSET [
						fire [
							TO_ERROR(script no-value)
							pc - 1
						]
					]
					TYPE_LIT_WORD [
						word/push as red-word! value	;-- push lit-word! on stack
					]
					TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
					TYPE_NATIVE
					TYPE_ROUTINE
					TYPE_FUNCTION [
						pc: eval-code value pc end sub? null null value
					]
					default [
						#if debug? = yes [if verbose > 0 [log "getting word value"]]
						either sub? [
							stack/push value			;-- nested expression: push value
						][
							stack/set-last value		;-- root expression: return value
						]
						#if debug? = yes [
							if verbose > 0 [
								value: stack/arguments
								print-line ["eval: word return type: " TYPE_OF(value)]
							]
						]
					]
				]
			]
			TYPE_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no no sub?
			]
			TYPE_GET_PATH [
				value: pc
				pc: pc + 1
				pc: eval-path value pc end no yes sub?
			]
			TYPE_LIT_PATH [
				value: stack/push pc
				value/header: TYPE_PATH
				pc: pc + 1
			]
			TYPE_OP [
				--NOT_IMPLEMENTED--						;-- op used in prefix mode
			]
			TYPE_ACTION							;@@ replace with TYPE_ANY_FUNCTION
			TYPE_NATIVE
			TYPE_ROUTINE
			TYPE_FUNCTION [
				value: pc + 1
				if value >= end [value: end]
				pc: eval-code pc value end sub? null null null
			]
			default [
				either sub? [
					stack/push pc						;-- nested expression: push value
				][
					stack/set-last pc					;-- root expression: return value
				]
				pc: pc + 1
			]
		]

		if infix? [
			pc: eval-infix op pc end sub?
			unless prefix? [
				either sub? [stack/unwind][stack/unwind-last]
			]
		]
		pc
	]

	eval-next: func [
		value	[red-value!]
		tail	[red-value!]
		sub?	[logic!]
		return: [red-value!]							;-- return start of next expression
	][
		stack/mark-native words/_body					;-- outer stack frame
		value: eval-expression value tail no sub?
		either sub? [stack/unwind][stack/unwind-last]
		value
	]

	eval: func [
		code   [red-block!]
		chain? [logic!]									;-- chain it with previous stack frame
		/local
			value [red-value!]
			tail  [red-value!]
			arg	  [red-value!]
	][
		value: block/rs-head code
		tail:  block/rs-tail code
		if value = tail [
			arg: stack/arguments
			arg/header: TYPE_UNSET
			exit
		]

		stack/mark-eval words/_body					;-- outer stack frame

		while [value < tail][
			#if debug? = yes [if verbose > 0 [log "root loop..."]]
			value: eval-expression value tail no no
			if value + 1 < tail [stack/reset]
		]
		either chain? [stack/unwind-last][stack/unwind]
	]

]


FEAT: code refactoring for typeset.reds

FEAT: code refactoring for typeset.reds

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

typeset: context [
	verbose: 0

	#enum typeset-op! [
		OP_MAX											;-- calculate highest value
		OP_SET											;-- set value bits
		OP_TEST											;-- test if value bits are set
		OP_CLEAR										;-- clear value bits
		OP_UNION
		OP_AND
		OP_OR
		OP_XOR
	]

	do-bitwise: func [
		type	[integer!]
		return: [red-typeset!]
		/local
			res   [red-typeset!]
			set1  [red-typeset!]
			set2  [red-typeset!]
	][
		set1: as red-typeset! stack/arguments
		set2: set1 + 1
		res: as red-typeset! stack/push*
		res/header: TYPE_TYPESET
		clear res
		if TYPE_OF(set2) = TYPE_DATATYPE [
			set-type res as red-value! set2
			set2: res
		]
		switch type [
			OP_UNION
			OP_OR	[
				res/array1: set1/array1 or set2/array1
				res/array2: set1/array2 or set2/array2
				res/array3: set1/array3 or set2/array3
			]
			OP_AND	[
				res/array1: set1/array1 and set2/array1
				res/array2: set1/array2 and set2/array2
				res/array3: set1/array3 and set2/array3
			]
			OP_XOR	[
				res/array1: set1/array1 xor set2/array1
				res/array2: set1/array2 xor set2/array2
				res/array3: set1/array3 xor set2/array3
			]
		]
		stack/set-last as red-value! res
		res
	]

	union: func [
		case?	[logic!]
		skip	[red-value!]
		return: [red-typeset!]
	][
		do-bitwise OP_UNION
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/and~"]]
		as red-value! do-bitwise OP_AND
	]

	or~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/or~"]]
		as red-value! do-bitwise OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/xor~"]]
		as red-value! do-bitwise OP_XOR
	]

	push: func [
		sets [red-typeset!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/push"]]

		copy-cell as red-value! sets stack/push*
	]

	set-type: func [
		sets	[red-typeset!]
		value	[red-value!]
		/local
			type [red-datatype!]
			id   [integer!]
			array [byte-ptr!]
	][
		type: as red-datatype! value
		if TYPE_OF(type) = TYPE_WORD [
			type: as red-datatype! word/get as red-word! type
		]
		if TYPE_OF(type) <> TYPE_DATATYPE [
			print-line "** Error: invalid argument" ;TBD throw an error
		]
		id: type/value
		assert id < 96
		array: (as byte-ptr! sets) + 4
		BS_SET_BIT(array id)
	]

	;-- Actions --

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return: [red-typeset!]
		/local
			sets [red-typeset!]
			type [red-value!]
			blk	 [red-block!]
			i	 [integer!]
			end  [red-value!]
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/make"]]

		sets: as red-typeset! stack/push*
		sets/header: TYPE_TYPESET						;-- implicit reset of all header flags
		clear sets

		either TYPE_OF(spec) = TYPE_BLOCK [
			blk: as red-block! spec
			s: GET_BUFFER(blk)
			i: blk/head
			end: s/tail
			type: s/offset + i

			while [type < end][
				set-type sets type
				i: i + 1
				type: s/offset + i
			]
		][
			print-line "** Error: invalid argument" ;TBD throw an error
		]
		sets
	]

	form: func [
		sets	[red-typeset!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			array	[byte-ptr!]
			value	[integer!]
			id		[integer!]
			base	[integer!]
			cnt		[integer!]
			s		[series!]
			part?	[logic!]
			set?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/form"]]

		part?: OPTION?(arg)
		array: (as byte-ptr! sets) + 4
		id: 1
		cnt: 0
		string/concatenate-literal buffer "make typeset! ["
		part: part - 15
		until [
			BS_TEST_BIT(array id set?)
			if set? [
				if all [part? negative? part][return part]
				name: name-table + id
				string/concatenate-literal-part buffer name/buffer name/size + 1
				string/append-char GET_BUFFER(buffer) as-integer space
				part: part - name/size - 2
				cnt: cnt + 1
			]
			id: id + 1
			id > datatype/top-id
		]
		s: GET_BUFFER(buffer)
		either zero? cnt [
			string/append-char s as-integer #"]"
		][
			string/poke-char s (as byte-ptr! s/tail) - 1 as-integer #"]"
		]
		part
	]

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

		form sets buffer arg part
	]

	compare: func [
		set1	[red-typeset!]							;-- first operand
		set2   	[red-typeset!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return: [integer!]
		/local
			type  [integer!]
			res	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/compare"]]

		type: TYPE_OF(set2)
		if type <> TYPE_TYPESET [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: SIGN_COMPARE_RESULT((length? set1) (length? set2))
			]
			default [
				print-line ["Error: cannot use: " op " comparison on typeset! value"]
				res: -2
			]
		]
		res
	]

	complement: func [
		sets	[red-typeset!]
		return:	[red-value!]
		/local
			res [red-typeset!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/complement"]]

		res: as red-typeset! copy-cell as red-value! sets stack/push*
		res/array1: not res/array1
		res/array2: not res/array2
		res/array3: not res/array3
		as red-value! res
	]

	clear: func [
		sets	[red-typeset!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/clear"]]

		sets/array1: 0
		sets/array2: 0
		sets/array3: 0
		as red-value! sets
	]

	find: func [
		sets	 [red-typeset!]
		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!]
			type [red-datatype!]
			set? [logic!]
			array [byte-ptr!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/find"]]

		if TYPE_OF(value) <> TYPE_DATATYPE [
			print-line "Find Error: invalid argument"
			return as red-value! false-value
		]
		array: (as byte-ptr! sets) + 4
		type: as red-datatype! value
		id: type/value
		assert id < 96
		BS_TEST_BIT(array id set?)
		as red-value! either set? [true-value][false-value]
	]

	insert: func [
		sets	 [red-typeset!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		append?	 [logic!]
		return:	 [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/insert"]]

		set-type sets value
		as red-value! sets
	]

	length?: func [
		sets	[red-typeset!]
		return: [integer!]
		/local
			arr [byte-ptr!]
			cnt [integer!]
			id  [integer!]
			set? [logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/length?"]]

		id:  1
		cnt: 0
		arr: (as byte-ptr! sets) + 4
		until [
			BS_TEST_BIT(arr id set?)
			if set? [cnt: cnt + 1]
			id: id + 1
			id > datatype/top-id
		]
		cnt
	]

	init: does [
		datatype/register [
			TYPE_TYPESET
			TYPE_VALUE
			"typeset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;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 --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			:clear
			null			;copy
			:find
			null			;head
			null			;head?
			null			;index?
			:insert
			:length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;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:   "Typeset datatype runtime functions"
	Author:  "Xie Qingtian"
	File: 	 %typeset.reds
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2015 Nenad Rakocevic & Xie Qingtian. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

typeset: context [
	verbose: 0

	#enum typeset-op! [
		OP_MAX											;-- calculate highest value
		OP_SET											;-- set value bits
		OP_TEST											;-- test if value bits are set
		OP_CLEAR										;-- clear value bits
		OP_UNION
		OP_AND
		OP_OR
		OP_XOR
	]

	do-bitwise: func [
		type	[integer!]
		return: [red-typeset!]
		/local
			res   [red-typeset!]
			set1  [red-typeset!]
			set2  [red-typeset!]
	][
		set1: as red-typeset! stack/arguments
		set2: set1 + 1
		res: as red-typeset! stack/push*
		res/header: TYPE_TYPESET
		clear res
		if TYPE_OF(set2) = TYPE_DATATYPE [
			set-type res as red-value! set2
			set2: res
		]
		switch type [
			OP_UNION
			OP_OR	[
				res/array1: set1/array1 or set2/array1
				res/array2: set1/array2 or set2/array2
				res/array3: set1/array3 or set2/array3
			]
			OP_AND	[
				res/array1: set1/array1 and set2/array1
				res/array2: set1/array2 and set2/array2
				res/array3: set1/array3 and set2/array3
			]
			OP_XOR	[
				res/array1: set1/array1 xor set2/array1
				res/array2: set1/array2 xor set2/array2
				res/array3: set1/array3 xor set2/array3
			]
		]
		stack/set-last as red-value! res
		res
	]

	union: func [
		case?	[logic!]
		skip	[red-value!]
		return: [red-typeset!]
	][
		do-bitwise OP_UNION
	]

	and~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/and~"]]
		as red-value! do-bitwise OP_AND
	]

	or~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/or~"]]
		as red-value! do-bitwise OP_OR
	]

	xor~: func [return:	[red-value!]][
		#if debug? = yes [if verbose > 0 [print-line "typeset/xor~"]]
		as red-value! do-bitwise OP_XOR
	]

	push: func [
		sets [red-typeset!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/push"]]

		copy-cell as red-value! sets stack/push*
	]

	set-type: func [
		sets	[red-typeset!]
		value	[red-value!]
		/local
			type [red-datatype!]
			id   [integer!]
	][
		type: as red-datatype! value
		if TYPE_OF(type) = TYPE_WORD [
			type: as red-datatype! word/get as red-word! type
		]
		if TYPE_OF(type) <> TYPE_DATATYPE [
			print-line "** Error: invalid argument" ;TBD throw an error
		]
		id: type/value
		assert id < 96
		case [
			id < 32 [sets/array1: sets/array1 or (1 << id)]
			id < 64 [sets/array2: sets/array2 or (1 << (id - 32))]
			true	[sets/array3: sets/array3 or (1 << (id - 64))]
		]
	]

	;-- Actions --

	make: func [
		proto	[red-value!]
		spec	[red-value!]
		return: [red-typeset!]
		/local
			sets [red-typeset!]
			type [red-value!]
			blk	 [red-block!]
			i	 [integer!]
			end  [red-value!]
			s	 [series!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/make"]]

		sets: as red-typeset! stack/push*
		sets/header: TYPE_TYPESET						;-- implicit reset of all header flags
		clear sets

		either TYPE_OF(spec) = TYPE_BLOCK [
			blk: as red-block! spec
			s: GET_BUFFER(blk)
			i: blk/head
			end: s/tail
			type: s/offset + i

			while [type < end][
				set-type sets type
				i: i + 1
				type: s/offset + i
			]
		][
			print-line "** Error: invalid argument" ;TBD throw an error
		]
		sets
	]

	form: func [
		sets	[red-typeset!]
		buffer	[red-string!]
		arg		[red-value!]
		part	[integer!]
		return: [integer!]
		/local
			array	[int-ptr!]
			end		[int-ptr!]
			value	[integer!]
			id		[integer!]
			base	[integer!]
			cnt		[integer!]
			s		[series!]
			part?	[logic!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/form"]]

		part?: OPTION?(arg)
		array: (as int-ptr! sets) + 1
		end: array + 3
		base: 0
		cnt: 0
		string/concatenate-literal buffer "make typeset! ["
		part: part - 15
		until [
			id: 0
			value: array/value
			until [
				if value and (1 << id) <> 0 [
					if all [part? negative? part][return part]
					name: name-table + base + id
					string/concatenate-literal-part buffer name/buffer name/size + 1
					string/append-char GET_BUFFER(buffer) as-integer space
					part: part - name/size - 2
					cnt: cnt + 1
				]
				id: id + 1
				id = 32
			]
			base: base + 32
			array: array + 1
			array = end
		]
		s: GET_BUFFER(buffer)
		either zero? cnt [
			string/append-char s as-integer #"]"
		][
			string/poke-char s (as byte-ptr! s/tail) - 1 as-integer #"]"
		]
		part
	]

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

		form sets buffer arg part
	]

	compare: func [
		set1	[red-typeset!]							;-- first operand
		set2   	[red-typeset!]							;-- second operand
		op		[integer!]								;-- type of comparison
		return: [integer!]
		/local
			type  [integer!]
			res	  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/compare"]]

		type: TYPE_OF(set2)
		if type <> TYPE_TYPESET [RETURN_COMPARE_OTHER]
		switch op [
			COMP_EQUAL
			COMP_STRICT_EQUAL
			COMP_NOT_EQUAL
			COMP_SORT
			COMP_CASE_SORT [
				res: SIGN_COMPARE_RESULT((length? set1) (length? set2))
			]
			default [
				print-line ["Error: cannot use: " op " comparison on typeset! value"]
				res: -2
			]
		]
		res
	]

	negate: func [
		sets	[red-typeset!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/negate"]]

		as red-value! complement sets
	]

	complement: func [
		sets	[red-typeset!]
		return:	[red-value!]
		/local
			res [red-typeset!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/complement"]]

		res: as red-typeset! copy-cell as red-value! sets stack/push*
		res/array1: not res/array1
		res/array2: not res/array2
		res/array3: not res/array3
		as red-value! res
	]

	clear: func [
		sets	[red-typeset!]
		return:	[red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/clear"]]

		sets/array1: 0
		sets/array2: 0
		sets/array3: 0
		as red-value! sets
	]

	find: func [
		sets	 [red-typeset!]
		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!]
			type [red-datatype!]
			res  [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/find"]]

		if TYPE_OF(value) <> TYPE_DATATYPE [
			print-line "Find Error: invalid argument"
			return as red-value! false-value
		]
		type: as red-datatype! value
		id: type/value
		res: case [
			id < 32 [sets/array1 and (1 << id)]
			id < 64 [sets/array2 and (1 << (id - 32))]
			true	[sets/array3 and (1 << (id - 64))]
		]
		as red-value! either zero? res [false-value][true-value]
	]

	insert: func [
		sets	 [red-typeset!]
		value	 [red-value!]
		part-arg [red-value!]
		only?	 [logic!]
		dup-arg	 [red-value!]
		append?	 [logic!]
		return:	 [red-value!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/insert"]]

		set-type sets value
		as red-value! sets
	]

	length?: func [
		sets	[red-typeset!]
		return: [integer!]
		/local
			v	[integer!]
			c	[integer!]
			arr [int-ptr!]
			end [int-ptr!]
			len [integer!]
	][
		#if debug? = yes [if verbose > 0 [print-line "typeset/length?"]]

		len: 0
		arr: as int-ptr! sets
		end: arr + 3
		until [
			arr: arr + 1
			v: arr/value
			c: 0
			while [v <> 0][
				c: c + 1
				v: v and (v - 1)
			]
			len: len + c
			arr = end
		]
		len
	]

	init: does [
		datatype/register [
			TYPE_TYPESET
			TYPE_VALUE
			"typeset!"
			;-- General actions --
			:make
			null			;random
			null			;reflect
			null			;to
			:form
			:mold
			null			;eval-path
			null			;set-path
			:compare
			;-- Scalar actions --
			null			;absolute
			null			;add
			null			;divide
			null			;multiply
			:negate
			null			;power
			null			;remainder
			null			;round
			null			;subtract
			null			;even?
			null			;odd?
			;-- Bitwise actions --
			:and~
			:complement
			:or~
			:xor~
			;-- Series actions --
			null			;append
			null			;at
			null			;back
			null			;change
			:clear
			null			;copy
			:find
			null			;head
			null			;head?
			null			;index?
			:insert
			:length?
			null			;next
			null			;pick
			null			;poke
			null			;remove
			null			;reverse
			null			;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
		]
	]
]