PageRenderTime 34ms CodeModel.GetById 15ms app.highlight 9ms RepoModel.GetById 1ms app.codeStats 1ms

/red-system/loader.r

http://github.com/dockimbel/Red
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]