/red-system/utils/r2-forward.r

http://github.com/dockimbel/Red · R · 104 lines · 98 code · 6 blank · 0 comment · 5 complexity · 5335a50ff298384d218401eca9cbe33d MD5 · raw file

  1. ;; NOTE: This file is based on r2-forward.r 2.100.80.4 but stripped of the
  2. ;; changelog and most functions.
  3. ;;
  4. ;; Red/System's compiler requires REBOL 2.7.6 as baseline. This file hold
  5. ;; functions not part of REBOL 2.7.6 which are used in the implementation of
  6. ;; Red/System.
  7. REBOL [
  8. Title: "REBOL 3 Forward Compatibility Functions"
  9. Name: 'r2-forward
  10. Type: 'module
  11. Version: 2.100.80.4.1
  12. Date: 23-Feb-2011
  13. File: %r2-forward.r
  14. Author: "Brian Hawley" ; BrianH
  15. Purpose: "Make REBOL 2 more compatible with REBOL 3."
  16. Exports: [
  17. map-each
  18. collect
  19. ] ; No Globals to limit any potential damage.
  20. License: {
  21. Copyright (c) 2008-2009 Brian Hawley
  22. Permission is hereby granted, free of charge, to any person obtaining a copy
  23. of this software and associated documentation files (the "Software"), to deal
  24. in the Software without restriction, including without limitation the rights
  25. to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  26. copies of the Software, and to permit persons to whom the Software is
  27. furnished to do so, subject to the following conditions:
  28. The above copyright notice and this permission notice shall be included in
  29. all copies or substantial portions of the Software.
  30. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  31. IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  32. FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  33. AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  34. LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  35. OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
  36. THE SOFTWARE.
  37. } ; MIT
  38. ]
  39. ; MAP-EACH with set-words, best datatype! support and /into (ideal full version)
  40. map-each: func [
  41. "Evaluates a block for each value(s) in a series and returns them as a block."
  42. [throw catch]
  43. 'word [word! block!] "Word or block of words to set each time (local)"
  44. data [block!] "The series to traverse"
  45. body [block!] "Block to evaluate each time"
  46. /into "Collect into a given series, rather than a new block"
  47. output [any-block! any-string!] "The series to output to" ; Not image!
  48. /local init len x
  49. ][
  50. ; Shortcut return for empty data
  51. either empty? data [any [output make block! 0]] [
  52. ; BIND/copy word and body
  53. word: either block? word [
  54. if empty? word [throw make error! [script invalid-arg []]]
  55. copy/deep word ; /deep because word is rebound before errors checked
  56. ] [reduce [word]]
  57. word: use word reduce [word]
  58. body: bind/copy body first word
  59. ; Build init code
  60. init: none
  61. parse word [any [word! | x: set-word! (
  62. unless init [init: make block! 4]
  63. ; Add [x: at data index] to init, and remove from word
  64. insert insert insert tail init first x [at data] index? x
  65. remove x
  66. ) :x | x: skip (
  67. throw make error! reduce ['script 'expect-set [word! set-word!] type? first x]
  68. )]]
  69. len: length? word ; Can be zero now (for advanced code tricks)
  70. ; Create the output series if not specified
  71. unless into [output: make block! divide length? data max 1 len]
  72. ; Process the data (which is not empty at this point)
  73. until [ ; Note: output: insert/only output needed for list! output
  74. set word data do init
  75. unless unset? set/any 'x do body [output: insert/only output :x]
  76. tail? data: skip data len
  77. ]
  78. ; Return the output and clean up memory references
  79. also either into [output] [head output] (
  80. set [word data body output init x] none
  81. )
  82. ]
  83. ]
  84. ; Note: This is pretty fast by R2 mezzanine loop standards, native in R3.
  85. collect: func [
  86. "Evaluates a block, storing values via KEEP function, and returns block of collected values."
  87. body [block!] "Block to evaluate"
  88. /into "Insert into a buffer instead (returns position after insert)"
  89. output [series!] "The buffer series (modified)"
  90. ][ ; Note: Needs new FUNC (defined above)
  91. unless output [output: make block! 16]
  92. do func [keep] body func [value /only] [
  93. output: either only [insert/only output :value] [insert output :value]
  94. :value
  95. ]
  96. either into [output] [head output]
  97. ]
  98. ; R3 version based on a discussion with Gregg and Gabriele in AltME.