/red-system/utils/r2-forward.r
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 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.