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

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