/red-system/loader.r
R | 262 lines | 239 code | 20 blank | 3 comment | 20 complexity | 1fa378d2b9f4ae8559e51bdfc519ee0a MD5 | raw file
1REBOL [ 2 Title: "Red/System source program loader" 3 Author: "Nenad Rakocevic" 4 File: %loader.r 5 Rights: "Copyright (C) 2011 Nenad Rakocevic. All rights reserved." 6 License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt" 7] 8 9loader: context [ 10 verbose: 0 11 include-dirs: none 12 include-list: make hash! 20 13 defs: make block! 100 14 15 hex-chars: charset "0123456789ABCDEF" 16 ws-chars: charset " ^M^-" 17 ws-all: union ws-chars charset "^/" 18 hex-delim: charset "[]()/" 19 non-cbracket: complement charset "}^/" 20 21 current-script: none 22 line: none 23 24 throw-error: func [err [string! block!]][ 25 print [ 26 "*** Loading Error:" 27 either word? err [ 28 join uppercase/part mold err 1 " error" 29 ][reform err] 30 "^/*** in file:" mold current-script 31 "^/*** at line:" line 32 ] 33 compiler/quit-on-error 34 ] 35 36 init: does [ 37 include-dirs: reduce [runtime-path] 38 clear include-list 39 clear defs 40 insert defs <no-match> ;-- required to avoid empty rule (causes infinite loop) 41 ] 42 43 included?: func [file [file!]][ 44 file: get-modes file 'full-path 45 either find include-list file [true][ 46 append include-list file 47 false 48 ] 49 ] 50 51 find-path: func [file [file!]][ 52 either slash = first file [ 53 if exists? file [return file] ;-- absolute path check 54 ][ 55 foreach dir include-dirs [ ;-- relative path check using known directories 56 if exists? dir/:file [return dir/:file] 57 ] 58 ] 59 throw-error ["include file access error:" mold file] 60 ] 61 62 check-marker: func [src [string!] /local pos][ 63 unless parse/all src [any ws-all "Red/System" any ws-all #"[" to end][ 64 throw-error "not a Red/System source program" 65 ] 66 ] 67 68 check-condition: func [type [word!] payload [block!]][ 69 if any [ 70 not any [word? payload/1 lit-word? payload/1] 71 not in job payload/1 72 all [type <> 'switch not find [= <> < > <= >=] payload/2] 73 ][ 74 throw-error rejoin ["invalid #" type " condition"] 75 ] 76 either type = 'switch [ 77 any [ 78 select payload/2 job/(payload/1) 79 select payload/2 #default 80 ] 81 ][ 82 do bind copy/part payload 3 job 83 ] 84 ] 85 86 expand-string: func [src [string! binary!] /local value s e c lf-count ws i prev ins?][ 87 if verbose > 0 [print "running string preprocessor..."] 88 89 line: 1 ;-- lines counter 90 lf-count: [lf s: ( 91 if prev <> i: index? s [ ;-- workaround to avoid writing more complex rules 92 prev: i 93 line: line + 1 94 if ins? [s: insert s rejoin [" #L " line " "]] 95 ] 96 )] 97 ws: [ws-chars | (ins?: yes) lf-count] 98 99 parse/all/case src [ ;-- not-LOAD-able syntax support 100 any [ 101 (c: 0) 102 #";" to lf 103 | {"} thru {"} 104 | "{" any [(ins?: no) lf-count | non-cbracket] "}" 105 | ws s: ">>>" e: ws ( 106 e: change/part s "-**" e ;-- convert >>> to -** 107 ) :e 108 | ws s: #"%" e: ws ( 109 e: change/part s "///" e ;-- convert % to /// 110 ) :e 111 | [hex-delim | ws] 112 s: copy value some [hex-chars (c: c + 1)] #"h" ;-- literal hexadecimal support 113 e: [hex-delim | ws-all | #";" to lf | end] ( 114 either find [2 4 8] c [ 115 e: change/part s to integer! to issue! value e 116 ][ 117 throw-error ["invalid hex literal:" copy/part s 40] 118 ] 119 ) :e 120 | (ins?: yes) lf-count 121 | skip 122 ] 123 ] 124 ] 125 126 expand-block: func [ 127 src [block!] 128 /local blk rule name value s e opr then-block else-block cases body 129 saved stack header mark idx prev 130 ][ 131 if verbose > 0 [print "running block preprocessor..."] 132 stack: append/only clear [] make block! 100 133 append stack/1 1 ;-- insert root header starting size 134 line: 1 135 136 store-line: [ 137 header: last stack 138 idx: index? s 139 mark: to pair! reduce [line idx] 140 either all [ 141 prev: pick tail header -1 142 pair? prev 143 prev/2 = idx ;-- test if previous marker is at the same series position 144 ][ 145 change back tail header mark ;-- replace last marker by a more accurate one 146 ][ 147 append header mark ;-- append line marker to header 148 ] 149 ] 150 151 parse/case src blk: [ 152 s: (do store-line) 153 some [ 154 defs ;-- resolve definitions in a single pass 155 | s: #define set name word! set value skip e: ( 156 if verbose > 0 [print [mold name #":" mold value]] 157 if word? value [value: to lit-word! value] 158 either block? value [ 159 saved: reduce [s e] 160 parse/case value rule: [ 161 some [defs | into rule | skip] ;-- resolve macros recursively 162 ] 163 set [s e] saved 164 rule: copy/deep [s: _ e: (e: change/part s copy/deep _ e) :s] 165 rule/4/5: :value 166 ][ 167 rule: copy/deep [s: _ e: (e: change/part s _ e) :s] 168 rule/4/4: :value 169 ] 170 rule/2: to lit-word! name 171 172 either tag? defs/1 [remove defs][append defs '|] 173 append defs rule 174 remove/part s e 175 ) :s 176 | s: #include set name file! e: ( 177 either included? name: find-path name [ 178 s: remove/part s e ;-- already included, drop it 179 ][ 180 if verbose > 0 [print ["...including file:" mold name]] 181 value: skip process/short name 2 ;-- skip Red/System header 182 e: change/part s value e 183 insert e reduce [ ;-- put back the parent origin 184 #script current-script 185 ] 186 insert s reduce [ ;-- mark code origin 187 #script name 188 ] 189 current-script: name 190 ] 191 ) :s 192 | s: #if set name word! set opr skip set value any-type! set then-block block! e: ( 193 either check-condition 'if reduce [name opr get/any 'value][ 194 change/part s then-block e 195 ][ 196 remove/part s e 197 ] 198 ) :s 199 | s: #either set name word! set opr skip set value any-type! set then-block block! set else-block block! e: ( 200 either check-condition 'either reduce [name opr get/any 'value][ 201 change/part s then-block e 202 ][ 203 change/part s else-block e 204 ] 205 ) :s 206 | s: #switch set name word! set cases block! e: ( 207 if body: check-condition 'switch reduce [name cases][ 208 change/part s body e 209 ] 210 ) :s 211 | s: #L set line integer! e: ( 212 s: remove/part s 2 213 new-line s yes 214 do store-line 215 ) :s 216 | path! | set-path! | any-string! ;-- avoid diving into these series 217 | s: (if any [block? s/1 paren? s/1][append/only stack copy [1]]) 218 [into blk | block! | paren!] ;-- black magic... 219 s: ( 220 if any [block? s/-1 paren? s/-1][ 221 header: last stack 222 change header length? header ;-- update header size 223 s/-1: insert s/-1 header ;-- insert hidden header 224 remove back tail stack 225 ] 226 ) 227 | skip 228 ] 229 ] 230 change stack/1 length? stack/1 ;-- update root header size 231 insert src stack/1 ;-- return source with hidden root header 232 ] 233 234 process: func [input [file! string!] /short /local src err path][ 235 if verbose > 0 [print ["processing" mold either file? input [input]['in-memory]]] 236 237 if file? input [ 238 if all [ 239 %./ <> path: first split-path input ;-- is there a path in the filename? 240 not find include-dirs path 241 ][ 242 insert include-dirs path ;-- register source's dir as include dir 243 ] 244 if error? set/any 'err try [src: as-string read/binary input][ ;-- read source file 245 throw-error ["file access error:" mold disarm err] 246 ] 247 ] 248 unless short [ 249 current-script: pick reduce [input 'in-memory] file? input 250 ] 251 src: any [src input] ;-- process string-level compiler directives 252 if file? input [check-marker src] ;-- look for "Red/System" head marker 253 expand-string src 254 255 if error? set/any 'err try [src: load src][ ;-- convert source to blocks 256 throw-error ["syntax error during LOAD phase:" mold disarm err] 257 ] 258 259 unless short [src: expand-block src] ;-- process block-level compiler directives 260 src 261 ] 262]