<commit_before>REBOL [
	Title:   "Red compiler"
	Author:  "<NAME>"
	File: 	 %compiler.r
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 <NAME>. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

do-cache %system/compiler.r

red: context [
	verbose:	   0									;-- logs verbosity level
	job: 		   none									;-- reference the current job object	
	script-name:   none
	script-path:   none
	main-path:	   none
	runtime-path:  %runtime/
	include-stk:   make block! 3
	included-list: make block! 20
	symbols:	   make hash! 1000
	globals:	   make hash! 1000						;-- words defined in global context
	aliases: 	   make hash! 100
	contexts:	   make hash! 100						;-- storage for statically compiled contexts
	ctx-stack:	   make block! 8						;-- contexts access path
	objects:	   make block! 100						;-- [name object! ctx...]
	obj-stack:	   to path! 'objects					;-- current object access path
	container-obj?: none								;-- closest wrapping object
	func-objs:	   none									;-- points to 'objects first in-function object
	rebol-gctx:	   bind? 'rebol
	expr-stack:	   make block! 8
	expr-start-pos: none								;-- mark beginning of a new expression generated code
	
	lexer: 		   do bind load-cache %lexer.r 'self
	extracts:	   do bind load-cache %utils/extractor.r 'self ;-- @@ to be removed once we get redbin loader.
	sys-global:    make block! 1
	lit-vars: 	   reduce [
		'block	   make hash! 1000
		'string	   make hash! 1000
		'context   make hash! 1000
	]
	 
	pc: 		   none
	locals:		   none
	locals-stack:  make block! 32
	output:		   make block! 100
	sym-table:	   make block! 1000
	literals:	   make block! 1000
	declarations:  make block! 1000
	bodies:		   make block! 1000
	ssa-names: 	   make block! 10						;-- unique names lookup table (SSA form)
	last-type:	   none
	return-def:    to-set-word 'return					;-- return: keyword
	s-counter:	   0									;-- series suffix counter
	depth:		   0									;-- expression nesting level counter
	booting?:	   none									;-- YES: compiling boot script
	no-global?:	   no									;-- YES: put global code in a function
	nl: 		   newline
 
	unboxed-set:   [integer! char! float! float32! logic!]
	block-set:	   [block! paren! path! set-path! lit-path!]	;@@ missing get-path!
	string-set:	   [string! binary!]
	series-set:	   union block-set string-set
	
	actions: 	   make block! 100
	op-actions:	   make block! 20
	keywords: 	   make block! 10
	
	actions-prefix: to path! 'actions
	natives-prefix: to path! 'natives
	
	intrinsics:   [
		if unless either any all while until loop repeat
		foreach forall break func function does has
		exit return switch case routine set get reduce
		context object
	]
	
	word-iterators: [repeat foreach forall]				;-- only ones that use word(s) as counter
	
	iterators: [loop until while repeat foreach forall]

	func-constructors: [
		'func | 'function | 'does | 'has | 'routine | 'make 'function!
	]

	functions: make hash! [
	;---name--type--arity----------spec----------------------------refs--
		make [action! 2 [type [datatype! word!] spec [any-type!]] #[none]]	;-- must be pre-defined
	]
	
	make-keywords: does [
		foreach [name spec] functions [
			if spec/1 = 'intrinsic! [
				repend keywords [name reduce [to word! join "comp-" name]]
			]
		]
		bind keywords self
	]

	set-last-none: does [copy [stack/reset none/push-last]]	;-- copy required for R/S line counting injection

	--not-implemented--: does [print "Feature not yet implemented!" halt]
	
	quit-on-error: does [
		clean-up
		if system/options/args [quit/return 1]
		halt
	]

	throw-error: func [err [word! string! block!]][
		print [
			"*** Compilation Error:"
			either word? err [
				join uppercase/part mold err 1 " error"
			][reform err]
			"^/*** in file:" mold script-name
			;either locals [join "^/*** in function: " func-name][""]
		]
		if pc [
			print [
				;"*** at line:" calc-line lf
				"*** near:" mold copy/part pc 8
			]
		]
		quit-on-error
	]
	
	relative-path?: func [file [file!]][
		not find "/~" first file
	]
	
	process-include-paths: func [code [block!] /local rule file][
		parse code rule: [
			some [
				#include file: (
					script-path: any [script-path main-path]
					if all [script-path relative-path? file/1][
						file/1: clean-path join script-path file/1
					]
				)
				| into rule
				| skip
			]
		]
	]
	
	process-calls: func [code [block!] /global /local rule pos mark][
		parse code rule: [
			some [
				#call pos: (
					mark: tail output
					process-call-directive pos/1 to logic! global
					change/part back pos mark 2
					clear mark
				)
				| into rule
				| skip
			]
		]
	]
	
	preprocess-strings: func [code [block!] /local rule s][  ;-- re-encode strings for Red/System
		parse code rule: [
			any [
				s: string! (lexer/decode-UTF8-string s/1)
				into rule
				| skip
			]
		]
	]
	
	convert-to-block: func [mark [block!]][
		change/part/only mark copy/deep mark tail mark	;-- put code between [...]
		clear next mark									;-- remove code at "upper" level
	]
	
	any-function?: func [value [word!]][
		find [native! action! op! function! routine!] value
	]
	
	scalar?: func [expr][
		find [
			unset!
			none!
			logic!
			datatype!
			char!
			integer!
			tuple!
			decimal!
			refinement!
			issue!
			lit-word!
			word! 
			get-word!
			set-word!
		] type?/word :expr
	]
	
	local-word?: func [name [word!]][
		all [not empty? locals-stack find last locals-stack name]
	]
	
	unicode-char?: func [value][
		all [issue? value value/1 = #"'"]
	]
	
	float-special?: func [value][
		all [issue? value value/1 = #"."]
	]
	
	insert-lf: func [pos][
		new-line skip tail output pos yes
	]
	
	emit: func [value][
		either block? value [append output value][append/only output value]
	]
		
	emit-src-comment: func [pos [block! paren! none!] /with cmt [string!]][
		unless cmt [
			cmt: trim/lines mold/only/flat clean-lf-deep copy/deep/part pos offset? pos pc
		]
		if 50 < length? cmt [cmt: append copy/part cmt 50 "..."]
		emit reduce [
			'------------| (cmt)
		]
	]
	
	parent-object?: func [obj [object!]][
		all [not empty? locals-stack (next first obj) = container-obj?]
	]
	
	find-binding: func [original [any-word!] /local ctx idx][
		all [
			ctx: all [
				rebol-gctx <> obj: bind? original
				select objects obj
			]
			attempt [idx: get-word-index/with to word! original ctx]
			reduce [ctx idx]
		]
	]
	
	get-word-index: func [name [word!] /with c [word!] /local ctx pos list][
		if with [
			ctx: select contexts c
			return (index? find ctx name) - 1
		]
		list: tail ctx-stack
		until [											;-- search backward in parent contexts
			list: back list
			ctx: select contexts list/1
			if pos: find ctx name [
				return (index? pos) - 1					;-- 0-based access in context table
			]
			head? list
		]
		throw-error ["Should not happen: not found context for word: " mold name]
	]
	
	emit-push-from: func [
		name [any-word!] original [any-word!] type [word!] actions [block!]
		/local ctx obj idx
	][
		either all [
			ctx: all [
				rebol-gctx <> obj: bind? original
				select objects obj
			]
			attempt [idx: get-word-index/with name ctx]
		][
			emit append to path! type actions/1
			emit either parent-object? obj ['octx][ctx] ;-- optional parametrized context reference (octx)
			emit idx
			insert-lf -3
		][
			emit append to path! type actions/2
			emit decorate-symbol name
			insert-lf -2
		]
	]
	
	emit-push-word: func [name [any-word!] original [any-word!] /local type ctx obj][
		type: to word! form type? name
		name: to word! :name
		
		either local-word? name [
			emit append to path! type 'push-local
			emit last ctx-stack
			emit get-word-index name
			insert-lf -3
		][
			emit-push-from name original type [push-local push]
		]
	]
	
	emit-get-word: func [name [word!] original [any-word!] /any? /literal /local new][
		either local-word? name [
			emit 'stack/push							;-- local word
		][
			if new: select ssa-names name [name: new]	;@@ add a check for function! type
			emit case [									;-- global word
				literal ['get-word/get]
				any?	['word/get-any]
				'else	[
					emit-push-from name name 'word [get-local get]
					exit
				]
			]
		]
		emit decorate-symbol name
		insert-lf -2
	]
	
	emit-load-string: func [buffer [string! file! url!]][
		emit to path! reduce [to word! form type? buffer 'load]
		emit form buffer
		emit 1 + length? buffer							;-- account for terminal zero
		emit 'UTF-8
	]
	
	emit-open-frame: func [name [word!] /local type][
		unless find symbols name [add-symbol name]
		emit case [
			'function! = all [
				type: find functions name
				first first next type
			]['stack/mark-func]
			name = 'try	  ['stack/mark-try]
			name = 'catch ['stack/mark-catch]
			'else		  ['stack/mark-native]
		]
		emit decorate-symbol name
		insert-lf -2
	]
	
	emit-close-frame: func [/last][
		emit pick [stack/unwind-last stack/unwind] to logic! last
		insert-lf -1
	]
	
	emit-stack-reset: does [
		emit 'stack/reset
		insert-lf -1
	]
	
	emit-action: func [name [word!] /with options [block!]][
		emit join actions-prefix to word! join name #"*"
		insert-lf either with [
			emit options
			-1 - length? options
		][
			-1
		]
	]
	
	emit-native: func [name [word!] /with options [block!]][
		emit join natives-prefix to word! join name #"*"
		insert-lf either with [
			emit options
			-1 - length? options
		][
			-1
		]
	]
	
	emit-exit-function: does [
		emit [
			stack/unwind-last
			stack/unroll stack/FLAG_FUNCTION
			ctx/values: as node! pop
			exit
		]
		insert-lf -5
	]
	
	emit-deep-check: func [path [series!] /local list check check2 obj top? parent-ctx][
		check:  [
			'object/unchanged?
				decorate-symbol path/1
				third obj: find objects do obj-stk
		]
		check2: [
			'object/unchanged2?
				parent-ctx
				get-word-index/with path/1 parent-ctx
				third obj: find objects do obj-stk
		]
		obj-stk: copy obj-stack
		
		either 2 = length? path [
			append obj-stk path/1
			reduce check
		][
			list: make block! 3 * length? path
			while [not tail? next path][
				append obj-stk path/1
				repend list get pick [check check2] head? path
				parent-ctx: obj/2
				path: next path
			]
			new-line list on
			new-line skip list 3 on
			new-line/all/skip skip list 3 on 4
			reduce ['all list]
		]
	]
	
	get-counter: does [s-counter: s-counter + 1]
	
	clean-lf-deep: func [blk [block! paren!] /local pos][
		blk: copy/deep blk
		parse blk rule: [
			pos: (new-line/all pos off)
			into rule | skip
		]
		blk
	]

	clean-lf-flag: func [name [word! lit-word! set-word! get-word! refinement!]][
		mold/flat to word! name
	]
	
	prefix-global: func [word [word!]][					;@@ to be removed?
		append to path! 'exec word
	]
	
	prefix-func: func [word [word!] /with path][
		if 1 < length? obj-stack [
			path: any [obj-func-call? word next any [path obj-stack]]
			word: decorate-obj-member word path
		]
		word
	]
	
	decorate-obj-member: func [word [word!] path /local value][
		parse value: mold path [some [p: #"/" (p/1: #"~") | skip]]
		to word! rejoin [value #"~" word]
	]
	
	decorate-type: func [type [word!]][
		to word! join "red-" mold/flat type
	]
	
	decorate-exec-ctx: func [name [word!]][
		append to path! 'exec name
	]
	
	decorate-symbol: func [name [word!] /local pos][
		if pos: find/case/skip aliases name 2 [name: pos/2]
		to word! join "~" clean-lf-flag name
	]
	
	decorate-func: func [name [word!] /strict /local new][
		if all [not strict new: select ssa-names name][name: new]
		to word! join "f_" clean-lf-flag name
	]
	
	decorate-series-var: func [name [word!] /local new list][
		new: to word! join name get-counter
		list: select lit-vars select [blk block str string ctx context] name
		if all [list not find list new][append list new]
		new
	]
	
	declare-variable: func [name [string! word!] /init value /local var set-var][
		set-var: to set-word! var: to word! name

		unless find declarations set-var [
			repend declarations [set-var any [value 0]]	;-- declare variable at root level
			new-line skip tail declarations -2 yes
		]
		reduce [var set-var]
	]
	
	add-symbol: func [name [word!] /local sym id alias][
		unless find/case symbols name [
			if find symbols name [
				if find/case/skip aliases name 2 [exit]
				alias: decorate-series-var name
				repend aliases [name alias]
			]
			sym: decorate-symbol name
			id: 1 + ((length? symbols) / 2)
			repend symbols [name reduce [sym id]]
			repend sym-table [
				to set-word! sym 'word/load mold name
			]
			new-line skip tail sym-table -3 on
		]
	]
	
	get-symbol-id: func [name [word!]][
		second select symbols name
	]
	
	add-global: func [name [word!]][
		unless any [
			local-word? name
			find globals name
		][
			repend globals [name 'unset!]
		]
	]
	
	push-call: func [name [word!]][
		append expr-stack name
	]
	
	pop-call: does [
		remove back tail expr-stack
	]
	
	add-context: func [ctx [block!] /local name][
		append contexts name: decorate-series-var 'ctx
		append/only contexts ctx
		name
	]
	
	push-context: func [ctx [block!] /local name][
		append ctx-stack name: add-context ctx
		name
	]
	
	pop-context: does [
		clear back tail ctx-stack
	]
	
	find-contexts: func [name [word!]][
		ctx: tail ctx-stack
		while [not head? ctx][
			ctx: back ctx
			if find select contexts ctx/1 name [return ctx/1]
		]
		none
	]
	
	iterator-pending?: does [
		not empty? intersect expr-stack iterators
	]
	
	get-obj-base: func [name [any-word!] /list][
		name: either local-word? name ['func-objs]['objects]
		either list [get name][name]
	]
	
	find-proto: func [obj [block!] fun [word!] /local proto o multi?][
		if proto: obj/4 [
			all [
				multi?: 2 = length? proto					;-- multiple inheritance case
				in proto/1 fun
				in proto/2 fun
				return obj/1								;-- method redefined in spec
			]
			if in proto/1 fun [
				return either multi? [obj/1][proto/1]		;-- check <spec> prototype
			]
			if o: find-proto find objects proto/1 fun [return o] ;-- recurse into previous prototypes
			
			unless proto/2 [return none]
			if in proto/2 fun [return proto/2]				;-- check <base> prototype
			if o: find-proto find objects proto/2 fun [return o] ;-- recurse into previous prototypes
		]
		none
	]
	
	object-access?: func [path [series!]][
		attempt [do head insert copy/part to path! path (length? path) - 1 get-obj-base path/1]
	]
	
	is-object?: func [expr][
		if any [
			not find [word! get-word! path!] type?/word expr
			all [any-word? expr local-word? expr]
		][
			return none
		]
		attempt [do join obj-stack expr]
	]
	
	obj-func-call?: func [name [any-word!] /local obj origin word][
		if rebol-gctx = obj: bind? name [return no]
		select objects obj
	]
	
	obj-func-path?: func [path [path!] /local search base fpath symbol found? fun origin name obj][
		search: [
			fpath: head insert copy path base
			until [										;-- evaluate nested paths from longer to shorter
				remove back tail fpath
				any [
					tail? next fpath
					object? found?: attempt [do fpath]	;-- path evaluates to an object: found!
				]
			]
		]
		
		base: get-obj-base path/1
		do search										;-- check if path is an absolute object path
		
		if all [not found? 1 < length? obj-stack][
			base: obj-stack
			do search									;-- check if path is a relative object path
			unless found? [return none]					;-- not an object access path
		]
		
		fun: append copy fpath either base = obj-stack [ ;-- extract function access path without refinements
			pick path 1 + (length? fpath) - (length? obj-stack)
		][
			pick path length? fpath
		]
		unless function! = attempt [do fun][return none] ;-- not a function call
		
		remove fpath									;-- remove 'objects prefix

		obj: 	find objects found?
		origin: find-proto obj last fun
		name:	either origin [select objects origin][obj/2]
		symbol: decorate-obj-member first find/tail fun fpath name

		either find functions symbol [
			fpath: next find path last fpath			;-- point to function name
			reduce [
				either 1 = length? fpath [fpath/1][copy fpath]
				symbol
				obj/2 									;-- object instance ctx name
			]
		][
			none
		]
	]
	
	push-locals: func [symbols [block!]][
		append/only locals-stack symbols
	]

	pop-locals: does [
		also
			last locals-stack
			remove back tail locals-stack
	]
	
	literal-first-arg?: func [spec [block!]][
		parse spec [
			any [
				word! 		(return no)
				| lit-word! (return yes)
				| /local	(return no)
				| skip
			]
		]
		no
	]
	
	infix?: func [pos [block! paren!] /local specs][
		all [
			not tail? pos
			word? pos/1
			specs: select functions pos/1
			'op! = specs/1
			not all [									;-- check if a literal argument is not expected
				word? pos/-1
				specs: select functions pos/-1
				literal-first-arg? specs/3				;-- literal arg needed, disable infix mode
			]
		]
	]
	
	convert-types: func [spec [block!] /local value][
		forall spec [
			if spec/1 = /local [break]					;-- avoid processing local variable
			if all [
				block? value: spec/1
				not find [integer! logic!] value/1 
			][
				value/1: decorate-type either value/1 = 'any-type! ['value!][value/1]
			]
		]
	]
	
	check-invalid-call: func [name [word!]][
		if all [
			find [exit return] name
			empty? locals-stack
		][
			pc: back pc
			throw-error "EXIT or RETURN used outside of a function"
		]
	]
	
	check-redefined: func [name [word!] /local pos][
		if pos: find functions name [
			remove/part pos 2							;-- remove previous function definition
		]
		if pos: find objects name [
			remove/part pos 5							;-- remove previous object definition
		]
	]
	
	check-func-name: func [name [word!] /local new pos][
		if find functions name [
			new: to word! append mold/flat name get-counter
			either pos: find ssa-names name [
				pos/2: new
			][
				repend ssa-names [name new]
			]
			name: new
		]
		name
	]
	
	check-cloned-function: func [new [word!] /local name alter entry pos][
		if all [
			get-word? pc/1
			name: to word! pc/1	
			all [
				alter: get-prefix-func name
				entry: find functions alter
				name: alter
			]
		][
			if alter: select ssa-names name [
				entry: find functions alter
			]
			repend functions [new entry/2]
			
			either pos: find/skip ssa-names new 2 [		;-- add the real function name as alias
				pos/2: name
			][
				repend ssa-names [new name]
			]
		]
	]
	
	check-new-func-name: func [path [path!] symbol [word!] ctx [word!] /local name][
		if any [
			set-word? name: pc/-1
			all [lit-word? name 'set = pc/-2]
		][
			name: to word! name
			repend functions [name append select functions symbol ctx]
			
			either pos: find/skip ssa-names name 2 [	;-- add the real function name as alias
				pos/2: symbol
			][
				repend ssa-names [name symbol]
			]
		]
	]
	
	check-spec: func [spec [block!] /local symbols value pos stop locals return?][
		symbols: make block! length? spec
		locals:  0
		
		unless parse spec [
			opt string!
			any [
				pos: /local (append symbols 'local) some [
					pos: word! (
						append symbols to word! pos/1
						locals: locals + 1
					)
					pos: opt block! pos: opt string!
				]
				| set-word! (
					if any [return? pos/1 <> return-def][stop: [end skip]]
					return?: yes						;-- allow only one return: statement
				) stop pos: block! opt string!
				| [
					[word! | lit-word! | get-word!] opt block! opt string!
					| refinement! opt string!
				] (append symbols to word! pos/1)
			]
		][
			throw-error ["invalid function spec block:" mold pos]
		]
		forall spec [
			if all [
				word? spec/1
				find next spec spec/1
			][
				pc: skip pc -2
				throw-error ["duplicate word definition:" spec/1]
			]
		]
		reduce [symbols locals]
	]
	
	make-refs-table: func [spec [block!] /local mark pos arity arg-rule list ref args][
		arity: 0
		arg-rule: [word! | lit-word! | get-word!]
		parse spec [
			any [
				arg-rule (arity: arity + 1)
				| mark: refinement! (pos: mark) break
				| skip
			]
		]
		if all [pos pos/1 <> /local][
			list: make block! 8
			ref: 0
			parse pos [
				some [
					pos: refinement! opt string! (
						ref: ref + 1
						if pos/1 = /local [return reduce [list arity]]
						repend list [pos/1 ref 0]
						args: 0
					)
					| arg-rule opt block! opt string! (
						change back tail list args: args + 1	;@@ one argument by refinement max!!
					)
					| set-word! break
				]
			]
		]
		reduce [list arity]
	]
	
	get-prefix-func: func [name [word!] /local path word ctx][
		if 1 < length? obj-stack [
			path: copy obj-stack
			while [1 < length? path][
				if all [word: in do path name function! = get word][
					return prefix-func/with name path
				]
				remove back tail path
			]
		]
		if all [										;-- check for method case during function compilation stage
			container-obj?
			ctx: obj-func-call? name
		][
			return decorate-obj-member name ctx
		]
		name
	]
	
	add-function: func [name [word!] spec [block!] /type kind [word!] /local refs arity][
		set [refs arity] make-refs-table spec
		repend functions [name reduce [any [kind 'function!] arity spec refs]]
	]
	
	fetch-functions: func [pos [block!] /local name type spec refs arity][
		name: to word! pos/1
		if find functions name [exit]					;-- mainly intended for 'make (hardcoded)

		switch type: pos/3 [
			native! [if find intrinsics name [type: 'intrinsic!]]
			action! [append actions name]
			op!     [repend op-actions [name to word! pos/4]]
		]
		spec: either pos/3 = 'op! [
			third select functions to word! pos/4
		][
			clean-lf-deep pos/4/1
		]
		set [refs arity] make-refs-table spec
		repend functions [name reduce [type arity spec refs]]
	]
	
	emit-block: func [
		blk [any-block!] /sub level [integer!] /bind ctx [word!]
		/local class name item value word action type binding
	][
		if path? blk [class: 'path]
		
		unless sub [
			emit-open-frame 'append
			emit to set-word! name: decorate-series-var any [class 'blk]
			emit append to path! any [class 'block] 'push*
			emit max 1 length? blk
			insert-lf -3
		]
		level: 0
		
		forall blk [
			item: blk/1
			either any-block? :item [
				type: either all [path? item get-word? item/1][
					item/1: to word! item/1 ;this is workaround of missing get-path! in R2
					'get-path
				][type? :item]
				
				emit-open-frame 'append
				emit to lit-path! reduce [to word! form type 'push*]
				emit max 1 length? item
				insert-lf -2
				
				level: level + 1
				either bind [
					emit-block/sub/bind to block! item level ctx
				][
					emit-block/sub to block! item level
				]
				level: level - 1
				
				emit-close-frame
				emit 'block/append*
				insert-lf -1
				emit 'stack/keep						;-- reset stack, but keep block as last value
				insert-lf -1
			][
				if :item = #get-definition [			;-- temporary directive
					value: select extracts/definitions blk/2
					change/only/part blk value 2
					item: blk/1
				]
				action: 'push
				value: case [
					unicode-char? :item [
						value: item
						item: #"_"						;-- placeholder just to pass the char! type to item
						to integer! next value
					]
					any-word? :item [
						add-symbol word: to word! clean-lf-flag item
						value: decorate-symbol word
						either all [bind local-word? to word! :item][
							action: 'push-local
							reduce [ctx get-word-index/with to word! :item ctx]
						][
							either binding: find-binding :item [
								action: 'push-local
								binding
							][
								value
							]
						]
					]
					issue? :item [
						add-symbol word: to word! form item
						decorate-symbol word
					]
					find [string! file! url!] type?/word :item [
						emit [tmp:]
						insert-lf -1
						emit-load-string item
						new-line back tail output off
						'tmp
					]
					find [logic! unset! datatype!] type?/word :item [
						to word! form :item
					]
					none? :item [
						[]								;-- no argument
					]
					'else [
						item
					]
				]
				either float-special? :item [
					emit 'float/push64
					emit-fp-special item
					insert-lf -3
				][
					either decimal? :item [
						emit 'float/push64
						emit-float item
						insert-lf -3
					][
						emit to path! reduce [to word! form type? :item action]
						emit value
						insert-lf -1 - either block? value [length? value][1]
					]
				]
				
				emit 'block/append*
				insert-lf -1
				unless tail? next blk [
					emit 'stack/keep					;-- reset stack, but keep block as last value
					insert-lf -1
				]
			]
		]
		unless sub [emit-close-frame]
		name
	]
	
	emit-eval-path: func [/set][
		emit 'actions/eval-path*
		emit either set ['true]['false]
		insert-lf -2
	]
	
	emit-path: func [
		path [path! set-path!] set? [logic!] alt? [logic!]
		/local value mark assign original
	][
		value: path/1
		
		assign: [
			either alt? [								;-- object path (fallback case)
				emit [stack/push stack/arguments - 1]	;-- get arguments just below the stack record
				insert-lf -4
			][
				comp-expression							;-- fetch assigned value (normal case)
			]
			emit-eval-path/set
			emit-close-frame
		]
		
		switch type?/word original: value [
			word! [
				add-symbol value: to word! clean-lf-flag value
				case [
					head? path [
						emit-get-word value original
					]
					all [set? tail? next path][
						emit-open-frame 'eval-set-path
						emit-path back path set? alt?
						emit-push-word value value
						do assign
					]
					'else [
						emit-open-frame 'select
						emit-path back path set? alt?
						emit-push-word value value
						insert-lf -2
						emit-action/with 'select [-1 -1 -1 -1 -1 -1 -1 -1]
						emit-close-frame
					]
				]
			]
			get-word! [
				either all [set? tail? next path][
					emit-open-frame 'poke
					emit-path back path set? alt?
					emit-get-word to word! value original
					
					emit copy/deep [unless stack/top-type? = TYPE_INTEGER] ;-- choose action at run-time
					insert-lf -4
					
					mark: tail output					;-- SELECT action
					emit [stack/pop 1]					;-- overwrite the get-word on stack top
					insert-lf -2
					emit-open-frame 'find
					emit-path back path set? alt?
					emit-get-word to word! value original
					emit-action/with 'find [-1 -1 -1 -1 -1 -1 -1 -1 -1 -1]
					emit-action 'index?
					emit [stack/pop 2]
					insert-lf -2
					emit [integer/push 1]
					insert-lf -2
					emit-action 'add
					emit-close-frame
					convert-to-block mark
					do assign
				][
					emit-open-frame 'pick-select
					emit-path back path set? alt?
					emit-get-word to word! value original
					
					emit copy/deep [either stack/top-type? = TYPE_INTEGER] ;-- choose action at run-time
					insert-lf -4
					
					mark: tail output					;-- PICK action
					emit-action 'pick
					convert-to-block mark
					
					mark: tail output					;-- SELECT action
					emit-action/with 'select [-1 -1 -1 -1 -1 -1 -1 -1]
					convert-to-block mark
					
					emit-close-frame
				]
			]
			integer! [
				either all [set? tail? next path][
					emit-open-frame 'eval-set-path
					emit-path back path set? alt?
					emit compose [integer/push (value)]
					insert-lf -2
					do assign
				][
					emit-open-frame 'pick
					emit-path back path set? alt?
					emit compose [integer/push (value)]
					insert-lf -2
					emit-action 'pick
					emit-close-frame
				]
			]
			string!	[
				--not-implemented--
			]
		]
	]
	
	paths-stack: make block! 4
	
	emit-checked-path: func [path [path!] /local pname fun idx mark saved][
		redirect-to literals [pname: emit-block path]
		fun: decorate-func to word! join "~path" s-counter + 1
		
		emit [stack/top: stack/arguments]				;-- inlined stack reset (protected from callbacks)
		insert-lf -2
		emit 'word/get
		emit decorate-symbol path/1
		insert-lf -2
		saved: output
		
		forall path [
			emit [either stack/func?]
			insert-lf -2
			idx: (index? path) - 1
			emit compose/deep [[stack/push-call (pname) (idx) as-integer (to get-word! fun)]]

			either tail? next path [
				emit compose/deep [[
					copy-cell stack/arguments + 1 stack/arguments
					stack/keep
					(fun)
				]]
				new-line back tail last output yes
			][
				mark: tail output
				emit-open-frame 'eval-path
				emit [stack/push stack/arguments - 1]
				insert-lf -4
				emit append to path! to word! form type? path/2 'push
				emit decorate-symbol path/2
				insert-lf -2
				emit-eval-path no
				emit 'stack/unwind-no-cb				;-- avoid triggering dynamic callbacks
				insert-lf -1
				emit [stack/top: stack/arguments + 2]
				insert-lf -4
				change/only/part mark mark: copy mark tail output
				output: mark
			]
		]
		output: saved
	]

	emit-path-func: has [body f-name][
		body: copy expr-start-pos
		clear expr-start-pos
		if all [1 = length? body body/1 = 'stack/reset][clear body]
		
		redirect-to declarations [
			f-name: to word! join "f_~path" get-counter
			emit reduce [to set-word! f-name 'does body]
			insert-lf -3
		]
		emit last paths-stack
		remove back tail paths-stack
	]
	
	emit-opt-call: func [mark [block!]][
		append/only paths-stack copy mark
		clear mark
		if (index? mark) <> index? expr-start-pos [
			emit [stack/push stack/arguments  - 1]
			insert-lf -4
		]
	]
	
	emit-routine: func [name [word!] spec [block!] /local type cnt offset alter][
		declare-variable/init 'r_arg to paren! [as red-value! 0]
		emit [r_arg: stack/arguments]
		insert-lf -2

		offset: 0
		if all [
			type: select spec return-def
			find [integer! logic!] type/1 
		][
			offset: 1
			append/only output append to path! form get type/1 'box
		]
		if alter: select/skip ssa-names name 2 [name: alter]
		emit name
		cnt: 0

		forall spec [
			if string? spec/1 [
				if tail? remove spec [break]
			]
			if any [spec/1 = /local set-word? spec/1][
				spec: head spec
				break									;-- avoid processing local variable	
			]
			unless block? spec/1 [
				unless block? spec/2 [
					insert/only next spec [red-value!]
				]
				either find [integer! logic!] spec/2/1 [
					append/only output append to path! form get spec/2/1 'get
				][
					emit reduce ['as spec/2/1]
				]
				emit 'r_arg
				unless head? spec [emit reduce ['+ cnt]]
				cnt: cnt + 1
			]
		]
		insert-lf negate cnt * 2 + offset + 1
	]
	
	redirect-to: func [out [block!] body [block!] /local saved][
		saved: output
		output: out
		also
			do body
			output: saved
	]

	emit-float: func [value [decimal!] /local bin][
		bin: IEEE-754/to-binary64 value
		emit to integer! copy/part bin 4
		emit to integer! skip bin 4
	]

	emit-fp-special: func [value [issue!]][
		switch next value [
			#INF  [emit to integer! #{7FF00000} emit 0]
			#INF- [emit to integer! #{FFF00000} emit 0]
			#NaN  [emit to integer! #{7FF80000} emit 0]			;-- smallest quiet NaN
			#0-	  [emit to integer! #{80000000} emit 0]
		]
	]
	
	comp-literal: func [/inactive /local value char? special? name w make-block type][
		value: pc/1
		either any [
			char?: unicode-char? value
			special?: float-special? value
			scalar? :value
		][			
			case [
				char? [
					emit 'char/push
					emit to integer! next value
					insert-lf -2
				]
				special? [
					emit 'float/push64
					emit-fp-special value
					insert-lf -3
				]
				decimal? :value [
					emit 'float/push64
					emit-float value
					insert-lf -3
				]
				find [refinement! issue! lit-word!] type?/word :value [
					add-symbol w: to word! form value
					type: to word! form type? :value
					if all [lit-word? :value not inactive][type: 'word]
					
					either all [not issue? :value local-word? w][
						emit append to path! type 'push-local
						emit last ctx-stack
						emit get-word-index w
						insert-lf -3
					][
						emit to path! reduce [type 'push]
						emit to path! reduce ['exec decorate-symbol w]
						insert-lf -2
					]
				]
				none? :value [
					emit 'none/push
					insert-lf -1
				]
				any-word? :value [
					add-symbol to word! :value
					emit-push-word :value :value
				]
				'else [
					emit to path! reduce [to word! form type? :value 'push]
					emit load mold :value
					insert-lf -2
				]
			]
		][
			make-block: [
				redirect-to literals [
					value: to block! value
					either empty? ctx-stack [
						emit-block value
					][
						emit-block/bind value last ctx-stack
					]
				]
			]
			switch/default type?/word value [
				block!	[
					name: do make-block
					emit 'block/push
					emit name
					insert-lf -2
				]
				paren!	[
					name: do make-block
					emit 'paren/push
					emit name
					insert-lf -2
				]
				path! set-path!	[
					name: do make-block
					either lit-path? pc/1 [
						emit 'path/push
					][
						emit to path! reduce [to word! form type? pc/1 'push]
					]
					emit name
					insert-lf -2
				]
				string!	file! url! [
					redirect-to literals [
						emit to set-word! name: decorate-series-var 'str
						insert-lf -1
						emit-load-string value
					]	
					emit to path! reduce [to word! form type? value 'push]
					emit name
					insert-lf -2
				]
				binary!	[]
			][
				throw-error ["comp-literal: unsupported type" mold value]
			]
		]
		pc: next pc
		name
	]
	
	inherit-functions: func [new [object!] extend [object!] /local symbol name][ ;-- multiple inheritance case
		foreach word next first extend [
			if function! = get in extend word [
				symbol: decorate-obj-member word select objects extend
				
				repend functions [
					name: decorate-obj-member word select objects new
					select functions symbol
				]
				
				append bodies name
				append bodies bind/copy copy/part next find bodies symbol 8 new
				add-symbol name
			]
		]
	]
	
	comp-context: func [
		/with word
		/extend proto [object!]
		/locals 
			words ctx spec name id func? obj original body pos entry
			symbol body? ctx2 new blk list
	][
		name:  to word! original: any [word pc/-1]
		words: any [all [proto third proto] make block! 8] ;-- start from existing ctx or fresh
		list:  clear any [list []]
		
		if proto [proto: reduce [proto]]
		
		either body?: block? pc/2 [
			parse body: pc/2 [							;-- collect words from body block
				any [
					(clear list)
					any [pos: set-word! (append list pos/1)]
					(func?: no) [func-constructors (func?: yes) | skip] (
						foreach word list [
							either entry: find words word [
								if func? [entry/2: function!]
							][
								append words word
								append words either func? [function!][none]
							]
						]
					) | skip
				]
			]

			spec: make block! (length? words) / 2
			forskip words 2 [append spec to word! words/1]
		][
			unless extend [
				blk: redirect-to literals [emit-block copy/part pc 2]
				emit-open-frame 'set					;-- defer it to runtime evaluation
				emit-push-word name original
				emit-open-frame 'do
				emit reduce ['block/push blk]
				insert-lf -2
				emit-native 'do
				emit-close-frame
				emit 'word/set
				insert-lf -1
				emit-close-frame
				pc: skip pc 2
				return none
			]
			obj:    find objects proto/1				;-- simple inheritance case
			spec:   next first obj/1
			words:  third obj/1
			
			unless find [context object object!] pc/1 [
				unless new: is-object? pc/2 [
					comp-call 'make select functions 'make ;-- fallback to runtime creation
					exit
				]
				
				ctx2: select objects new				;-- multiple inheritance case
				spec: union spec next first new
				insert proto new
				
				forskip words 2 [
					if word: in new words/1 [words/2: get in new words/1]
				]
				foreach [name value] third new [
					unless find words name [repend words [name value]]
				]
			]
		]

		redirect-to literals [							;-- store spec and body blocks
			ctx: add-context spec
			emit compose [
				(to set-word! ctx) _context/make (blk: emit-block spec) no yes	;-- build context
			]
			insert-lf -4
		]
		
		symbol: get pick [name ctx] to logic! any [		;-- name for global words, else use context name
			rebol-gctx = bind? original 
			local-word? name
		]
		if pos: find get-obj-base/list name name [pos/1: none] ;-- unbind word with previous object
		
		repend objects [								;-- register shadow object	
			symbol										;-- object access word
			obj: make object! words						;-- shadow object
			ctx											;-- object's context name
			id: get-counter								;-- unique object ID
			proto										;-- optional prototype object
		]
		
		unless tail? next obj-stack [
			do reduce [to set-path! join obj-stack name obj] ;-- set object in shadow tree
		]
		if body? [bind body obj]
		
		emit-open-frame 'set							;-- runtime object value creation
		emit-push-word name original
		unless all [empty? locals-stack not iterator-pending?][	;-- in a function or iteration block
			emit compose [
				(to set-word! ctx) _context/make (blk) no yes	;-- rebuild context
			]
			insert-lf -4
		]
		emit reduce ['object/init-push ctx id]
		insert-lf -3
		if proto [
			emit reduce ['object/duplicate select objects last proto ctx]
			insert-lf -3
		]
		unless body? [
			inherit-functions obj new<commit_msg>FIX: issue #933 (Compiled contexts mix up methods)<commit_after>REBOL [
	Title:   "Red compiler"
	Author:  "<NAME>"
	File: 	 %compiler.r
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2012 <NAME>. All rights reserved."
	License: "BSD-3 - https://github.com/dockimbel/Red/blob/master/BSD-3-License.txt"
]

do-cache %system/compiler.r

red: context [
	verbose:	   0									;-- logs verbosity level
	job: 		   none									;-- reference the current job object	
	script-name:   none
	script-path:   none
	main-path:	   none
	runtime-path:  %runtime/
	include-stk:   make block! 3
	included-list: make block! 20
	symbols:	   make hash! 1000
	globals:	   make hash! 1000						;-- words defined in global context
	aliases: 	   make hash! 100
	contexts:	   make hash! 100						;-- storage for statically compiled contexts
	ctx-stack:	   make block! 8						;-- contexts access path
	objects:	   make block! 100						;-- [name object! ctx...]
	obj-stack:	   to path! 'objects					;-- current object access path
	container-obj?: none								;-- closest wrapping object
	func-objs:	   none									;-- points to 'objects first in-function object
	rebol-gctx:	   bind? 'rebol
	expr-stack:	   make block! 8
	expr-start-pos: none								;-- mark beginning of a new expression generated code
	
	lexer: 		   do bind load-cache %lexer.r 'self
	extracts:	   do bind load-cache %utils/extractor.r 'self ;-- @@ to be removed once we get redbin loader.
	sys-global:    make block! 1
	lit-vars: 	   reduce [
		'block	   make hash! 1000
		'string	   make hash! 1000
		'context   make hash! 1000
	]
	 
	pc: 		   none
	locals:		   none
	locals-stack:  make block! 32
	output:		   make block! 100
	sym-table:	   make block! 1000
	literals:	   make block! 1000
	declarations:  make block! 1000
	bodies:		   make block! 1000
	ssa-names: 	   make block! 10						;-- unique names lookup table (SSA form)
	last-type:	   none
	return-def:    to-set-word 'return					;-- return: keyword
	s-counter:	   0									;-- series suffix counter
	depth:		   0									;-- expression nesting level counter
	booting?:	   none									;-- YES: compiling boot script
	no-global?:	   no									;-- YES: put global code in a function
	nl: 		   newline
 
	unboxed-set:   [integer! char! float! float32! logic!]
	block-set:	   [block! paren! path! set-path! lit-path!]	;@@ missing get-path!
	string-set:	   [string! binary!]
	series-set:	   union block-set string-set
	
	actions: 	   make block! 100
	op-actions:	   make block! 20
	keywords: 	   make block! 10
	
	actions-prefix: to path! 'actions
	natives-prefix: to path! 'natives
	
	intrinsics:   [
		if unless either any all while until loop repeat
		foreach forall break func function does has
		exit return switch case routine set get reduce
		context object
	]
	
	word-iterators: [repeat foreach forall]				;-- only ones that use word(s) as counter
	
	iterators: [loop until while repeat foreach forall]

	func-constructors: [
		'func | 'function | 'does | 'has | 'routine | 'make 'function!
	]

	functions: make hash! [
	;---name--type--arity----------spec----------------------------refs--
		make [action! 2 [type [datatype! word!] spec [any-type!]] #[none]]	;-- must be pre-defined
	]
	
	make-keywords: does [
		foreach [name spec] functions [
			if spec/1 = 'intrinsic! [
				repend keywords [name reduce [to word! join "comp-" name]]
			]
		]
		bind keywords self
	]

	set-last-none: does [copy [stack/reset none/push-last]]	;-- copy required for R/S line counting injection

	--not-implemented--: does [print "Feature not yet implemented!" halt]
	
	quit-on-error: does [
		clean-up
		if system/options/args [quit/return 1]
		halt
	]

	throw-error: func [err [word! string! block!]][
		print [
			"*** Compilation Error:"
			either word? err [
				join uppercase/part mold err 1 " error"
			][reform err]
			"^/*** in file:" mold script-name
			;either locals [join "^/*** in function: " func-name][""]
		]
		if pc [
			print [
				;"*** at line:" calc-line lf
				"*** near:" mold copy/part pc 8
			]
		]
		quit-on-error
	]
	
	relative-path?: func [file [file!]][
		not find "/~" first file
	]
	
	process-include-paths: func [code [block!] /local rule file][
		parse code rule: [
			some [
				#include file: (
					script-path: any [script-path main-path]
					if all [script-path relative-path? file/1][
						file/1: clean-path join script-path file/1
					]
				)
				| into rule
				| skip
			]
		]
	]
	
	process-calls: func [code [block!] /global /local rule pos mark][
		parse code rule: [
			some [
				#call pos: (
					mark: tail output
					process-call-directive pos/1 to logic! global
					change/part back pos mark 2
					clear mark
				)
				| into rule
				| skip
			]
		]
	]
	
	preprocess-strings: func [code [block!] /local rule s][  ;-- re-encode strings for Red/System
		parse code rule: [
			any [
				s: string! (lexer/decode-UTF8-string s/1)
				into rule
				| skip
			]
		]
	]
	
	convert-to-block: func [mark [block!]][
		change/part/only mark copy/deep mark tail mark	;-- put code between [...]
		clear next mark									;-- remove code at "upper" level
	]
	
	any-function?: func [value [word!]][
		find [native! action! op! function! routine!] value
	]
	
	scalar?: func [expr][
		find [
			unset!
			none!
			logic!
			datatype!
			char!
			integer!
			tuple!
			decimal!
			refinement!
			issue!
			lit-word!
			word! 
			get-word!
			set-word!
		] type?/word :expr
	]
	
	local-word?: func [name [word!]][
		all [not empty? locals-stack find last locals-stack name]
	]
	
	unicode-char?: func [value][
		all [issue? value value/1 = #"'"]
	]
	
	float-special?: func [value][
		all [issue? value value/1 = #"."]
	]
	
	insert-lf: func [pos][
		new-line skip tail output pos yes
	]
	
	emit: func [value][
		either block? value [append output value][append/only output value]
	]
		
	emit-src-comment: func [pos [block! paren! none!] /with cmt [string!]][
		unless cmt [
			cmt: trim/lines mold/only/flat clean-lf-deep copy/deep/part pos offset? pos pc
		]
		if 50 < length? cmt [cmt: append copy/part cmt 50 "..."]
		emit reduce [
			'------------| (cmt)
		]
	]
	
	parent-object?: func [obj [object!]][
		all [not empty? locals-stack (next first obj) = container-obj?]
	]
	
	find-binding: func [original [any-word!] /local ctx idx][
		all [
			ctx: all [
				rebol-gctx <> obj: bind? original
				select objects obj
			]
			attempt [idx: get-word-index/with to word! original ctx]
			reduce [ctx idx]
		]
	]
	
	get-word-index: func [name [word!] /with c [word!] /local ctx pos list][
		if with [
			ctx: select contexts c
			return (index? find ctx name) - 1
		]
		list: tail ctx-stack
		until [											;-- search backward in parent contexts
			list: back list
			ctx: select contexts list/1
			if pos: find ctx name [
				return (index? pos) - 1					;-- 0-based access in context table
			]
			head? list
		]
		throw-error ["Should not happen: not found context for word: " mold name]
	]
	
	emit-push-from: func [
		name [any-word!] original [any-word!] type [word!] actions [block!]
		/local ctx obj idx
	][
		either all [
			ctx: all [
				rebol-gctx <> obj: bind? original
				select objects obj
			]
			attempt [idx: get-word-index/with name ctx]
		][
			emit append to path! type actions/1
			emit either parent-object? obj ['octx][ctx] ;-- optional parametrized context reference (octx)
			emit idx
			insert-lf -3
		][
			emit append to path! type actions/2
			emit decorate-symbol name
			insert-lf -2
		]
	]
	
	emit-push-word: func [name [any-word!] original [any-word!] /local type ctx obj][
		type: to word! form type? name
		name: to word! :name
		
		either local-word? name [
			emit append to path! type 'push-local
			emit last ctx-stack
			emit get-word-index name
			insert-lf -3
		][
			emit-push-from name original type [push-local push]
		]
	]
	
	emit-get-word: func [name [word!] original [any-word!] /any? /literal /local new][
		either local-word? name [
			emit 'stack/push							;-- local word
		][
			if new: select ssa-names name [name: new]	;@@ add a check for function! type
			emit case [									;-- global word
				literal ['get-word/get]
				any?	['word/get-any]
				'else	[
					emit-push-from name name 'word [get-local get]
					exit
				]
			]
		]
		emit decorate-symbol name
		insert-lf -2
	]
	
	emit-load-string: func [buffer [string! file! url!]][
		emit to path! reduce [to word! form type? buffer 'load]
		emit form buffer
		emit 1 + length? buffer							;-- account for terminal zero
		emit 'UTF-8
	]
	
	emit-open-frame: func [name [word!] /local type][
		unless find symbols name [add-symbol name]
		emit case [
			'function! = all [
				type: find functions name
				first first next type
			]['stack/mark-func]
			name = 'try	  ['stack/mark-try]
			name = 'catch ['stack/mark-catch]
			'else		  ['stack/mark-native]
		]
		emit decorate-symbol name
		insert-lf -2
	]
	
	emit-close-frame: func [/last][
		emit pick [stack/unwind-last stack/unwind] to logic! last
		insert-lf -1
	]
	
	emit-stack-reset: does [
		emit 'stack/reset
		insert-lf -1
	]
	
	emit-action: func [name [word!] /with options [block!]][
		emit join actions-prefix to word! join name #"*"
		insert-lf either with [
			emit options
			-1 - length? options
		][
			-1
		]
	]
	
	emit-native: func [name [word!] /with options [block!]][
		emit join natives-prefix to word! join name #"*"
		insert-lf either with [
			emit options
			-1 - length? options
		][
			-1
		]
	]
	
	emit-exit-function: does [
		emit [
			stack/unwind-last
			stack/unroll stack/FLAG_FUNCTION
			ctx/values: as node! pop
			exit
		]
		insert-lf -5
	]
	
	emit-deep-check: func [path [series!] /local list check check2 obj top? parent-ctx][
		check:  [
			'object/unchanged?
				decorate-symbol path/1
				third obj: find objects do obj-stk
		]
		check2: [
			'object/unchanged2?
				parent-ctx
				get-word-index/with path/1 parent-ctx
				third obj: find objects do obj-stk
		]
		obj-stk: copy obj-stack
		
		either 2 = length? path [
			append obj-stk path/1
			reduce check
		][
			list: make block! 3 * length? path
			while [not tail? next path][
				append obj-stk path/1
				repend list get pick [check check2] head? path
				parent-ctx: obj/2
				path: next path
			]
			new-line list on
			new-line skip list 3 on
			new-line/all/skip skip list 3 on 4
			reduce ['all list]
		]
	]
	
	get-counter: does [s-counter: s-counter + 1]
	
	clean-lf-deep: func [blk [block! paren!] /local pos][
		blk: copy/deep blk
		parse blk rule: [
			pos: (new-line/all pos off)
			into rule | skip
		]
		blk
	]

	clean-lf-flag: func [name [word! lit-word! set-word! get-word! refinement!]][
		mold/flat to word! name
	]
	
	prefix-global: func [word [word!]][					;@@ to be removed?
		append to path! 'exec word
	]
	
	prefix-func: func [word [word!] /with path][
		if 1 < length? obj-stack [
			path: any [obj-func-call? word next any [path obj-stack]]
			word: decorate-obj-member word path
		]
		word
	]
	
	decorate-obj-member: func [word [word!] path /local value][
		parse value: mold path [some [p: #"/" (p/1: #"~") | skip]]
		to word! rejoin [value #"~" word]
	]
	
	decorate-type: func [type [word!]][
		to word! join "red-" mold/flat type
	]
	
	decorate-exec-ctx: func [name [word!]][
		append to path! 'exec name
	]
	
	decorate-symbol: func [name [word!] /local pos][
		if pos: find/case/skip aliases name 2 [name: pos/2]
		to word! join "~" clean-lf-flag name
	]
	
	decorate-func: func [name [word!] /strict /local new][
		if all [not strict new: select ssa-names name][name: new]
		to word! join "f_" clean-lf-flag name
	]
	
	decorate-series-var: func [name [word!] /local new list][
		new: to word! join name get-counter
		list: select lit-vars select [blk block str string ctx context] name
		if all [list not find list new][append list new]
		new
	]
	
	declare-variable: func [name [string! word!] /init value /local var set-var][
		set-var: to set-word! var: to word! name

		unless find declarations set-var [
			repend declarations [set-var any [value 0]]	;-- declare variable at root level
			new-line skip tail declarations -2 yes
		]
		reduce [var set-var]
	]
	
	add-symbol: func [name [word!] /local sym id alias][
		unless find/case symbols name [
			if find symbols name [
				if find/case/skip aliases name 2 [exit]
				alias: decorate-series-var name
				repend aliases [name alias]
			]
			sym: decorate-symbol name
			id: 1 + ((length? symbols) / 2)
			repend symbols [name reduce [sym id]]
			repend sym-table [
				to set-word! sym 'word/load mold name
			]
			new-line skip tail sym-table -3 on
		]
	]
	
	get-symbol-id: func [name [word!]][
		second select symbols name
	]
	
	add-global: func [name [word!]][
		unless any [
			local-word? name
			find globals name
		][
			repend globals [name 'unset!]
		]
	]
	
	push-call: func [name [word!]][
		append expr-stack name
	]
	
	pop-call: does [
		remove back tail expr-stack
	]
	
	add-context: func [ctx [block!] /local name][
		append contexts name: decorate-series-var 'ctx
		append/only contexts ctx
		name
	]
	
	push-context: func [ctx [block!] /local name][
		append ctx-stack name: add-context ctx
		name
	]
	
	pop-context: does [
		clear back tail ctx-stack
	]
	
	find-contexts: func [name [word!]][
		ctx: tail ctx-stack
		while [not head? ctx][
			ctx: back ctx
			if find select contexts ctx/1 name [return ctx/1]
		]
		none
	]
	
	iterator-pending?: does [
		not empty? intersect expr-stack iterators
	]
	
	get-obj-base: func [name [any-word!] /list][
		name: either local-word? name ['func-objs]['objects]
		either list [get name][name]
	]
	
	find-proto: func [obj [block!] fun [word!] /local proto o multi?][
		if proto: obj/4 [
			all [
				multi?: 2 = length? proto				;-- multiple inheritance case
				in proto/1 fun
				in proto/2 fun
				return obj/1							;-- method redefined in spec
			]
			if in proto/1 fun [return obj/1]			;-- check <spec> prototype
			if o: find-proto find objects proto/1 fun [return o] ;-- recurse into previous prototypes
			
			unless proto/2 [return none]				;-- finish if simple inheritance case
			if in proto/2 fun [return proto/2]			;-- check <base> prototype
			if o: find-proto find objects proto/2 fun [return o] ;-- recurse into previous prototypes
		]
		none
	]
	
	object-access?: func [path [series!]][
		attempt [do head insert copy/part to path! path (length? path) - 1 get-obj-base path/1]
	]
	
	is-object?: func [expr][
		if any [
			not find [word! get-word! path!] type?/word expr
			all [any-word? expr local-word? expr]
		][
			return none
		]
		attempt [do join obj-stack expr]
	]
	
	obj-func-call?: func [name [any-word!] /local obj origin word][
		if rebol-gctx = obj: bind? name [return no]
		select objects obj
	]
	
	obj-func-path?: func [path [path!] /local search base fpath symbol found? fun origin name obj][
		search: [
			fpath: head insert copy path base
			until [										;-- evaluate nested paths from longer to shorter
				remove back tail fpath
				any [
					tail? next fpath
					object? found?: attempt [do fpath]	;-- path evaluates to an object: found!
				]
			]
		]
		
		base: get-obj-base path/1
		do search										;-- check if path is an absolute object path
		
		if all [not found? 1 < length? obj-stack][
			base: obj-stack
			do search									;-- check if path is a relative object path
			unless found? [return none]					;-- not an object access path
		]
		
		fun: append copy fpath either base = obj-stack [ ;-- extract function access path without refinements
			pick path 1 + (length? fpath) - (length? obj-stack)
		][
			pick path length? fpath
		]
		unless function! = attempt [do fun][return none] ;-- not a function call
		
		remove fpath									;-- remove 'objects prefix

		obj: 	find objects found?
		origin: find-proto obj last fun
		name:	either origin [select objects origin][obj/2]
		symbol: decorate-obj-member first find/tail fun fpath name

		either find functions symbol [
			fpath: next find path last fpath			;-- point to function name
			reduce [
				either 1 = length? fpath [fpath/1][copy fpath]
				symbol
				obj/2 									;-- object instance ctx name
			]
		][
			none
		]
	]
	
	push-locals: func [symbols [block!]][
		append/only locals-stack symbols
	]

	pop-locals: does [
		also
			last locals-stack
			remove back tail locals-stack
	]
	
	literal-first-arg?: func [spec [block!]][
		parse spec [
			any [
				word! 		(return no)
				| lit-word! (return yes)
				| /local	(return no)
				| skip
			]
		]
		no
	]
	
	infix?: func [pos [block! paren!] /local specs][
		all [
			not tail? pos
			word? pos/1
			specs: select functions pos/1
			'op! = specs/1
			not all [									;-- check if a literal argument is not expected
				word? pos/-1
				specs: select functions pos/-1
				literal-first-arg? specs/3				;-- literal arg needed, disable infix mode
			]
		]
	]
	
	convert-types: func [spec [block!] /local value][
		forall spec [
			if spec/1 = /local [break]					;-- avoid processing local variable
			if all [
				block? value: spec/1
				not find [integer! logic!] value/1 
			][
				value/1: decorate-type either value/1 = 'any-type! ['value!][value/1]
			]
		]
	]
	
	check-invalid-call: func [name [word!]][
		if all [
			find [exit return] name
			empty? locals-stack
		][
			pc: back pc
			throw-error "EXIT or RETURN used outside of a function"
		]
	]
	
	check-redefined: func [name [word!] /local pos][
		if pos: find functions name [
			remove/part pos 2							;-- remove previous function definition
		]
		if pos: find objects name [
			remove/part pos 5							;-- remove previous object definition
		]
	]
	
	check-func-name: func [name [word!] /local new pos][
		if find functions name [
			new: to word! append mold/flat name get-counter
			either pos: find ssa-names name [
				pos/2: new
			][
				repend ssa-names [name new]
			]
			name: new
		]
		name
	]
	
	check-cloned-function: func [new [word!] /local name alter entry pos][
		if all [
			get-word? pc/1
			name: to word! pc/1	
			all [
				alter: get-prefix-func name
				entry: find functions alter
				name: alter
			]
		][
			if alter: select ssa-names name [
				entry: find functions alter
			]
			repend functions [new entry/2]
			
			either pos: find/skip ssa-names new 2 [		;-- add the real function name as alias
				pos/2: name
			][
				repend ssa-names [new name]
			]
		]
	]
	
	check-new-func-name: func [path [path!] symbol [word!] ctx [word!] /local name][
		if any [
			set-word? name: pc/-1
			all [lit-word? name 'set = pc/-2]
		][
			name: to word! name
			repend functions [name append select functions symbol ctx]
			
			either pos: find/skip ssa-names name 2 [	;-- add the real function name as alias
				pos/2: symbol
			][
				repend ssa-names [name symbol]
			]
		]
	]
	
	check-spec: func [spec [block!] /local symbols value pos stop locals return?][
		symbols: make block! length? spec
		locals:  0
		
		unless parse spec [
			opt string!
			any [
				pos: /local (append symbols 'local) some [
					pos: word! (
						append symbols to word! pos/1
						locals: locals + 1
					)
					pos: opt block! pos: opt string!
				]
				| set-word! (
					if any [return? pos/1 <> return-def][stop: [end skip]]
					return?: yes						;-- allow only one return: statement
				) stop pos: block! opt string!
				| [
					[word! | lit-word! | get-word!] opt block! opt string!
					| refinement! opt string!
				] (append symbols to word! pos/1)
			]
		][
			throw-error ["invalid function spec block:" mold pos]
		]
		forall spec [
			if all [
				word? spec/1
				find next spec spec/1
			][
				pc: skip pc -2
				throw-error ["duplicate word definition:" spec/1]
			]
		]
		reduce [symbols locals]
	]
	
	make-refs-table: func [spec [block!] /local mark pos arity arg-rule list ref args][
		arity: 0
		arg-rule: [word! | lit-word! | get-word!]
		parse spec [
			any [
				arg-rule (arity: arity + 1)
				| mark: refinement! (pos: mark) break
				| skip
			]
		]
		if all [pos pos/1 <> /local][
			list: make block! 8
			ref: 0
			parse pos [
				some [
					pos: refinement! opt string! (
						ref: ref + 1
						if pos/1 = /local [return reduce [list arity]]
						repend list [pos/1 ref 0]
						args: 0
					)
					| arg-rule opt block! opt string! (
						change back tail list args: args + 1	;@@ one argument by refinement max!!
					)
					| set-word! break
				]
			]
		]
		reduce [list arity]
	]
	
	get-prefix-func: func [name [word!] /local path word ctx][
		if 1 < length? obj-stack [
			path: copy obj-stack
			while [1 < length? path][
				if all [word: in do path name function! = get word][
					return prefix-func/with name path
				]
				remove back tail path
			]
		]
		if all [										;-- check for method case during function compilation stage
			container-obj?
			ctx: obj-func-call? name
		][
			return decorate-obj-member name ctx
		]
		name
	]
	
	add-function: func [name [word!] spec [block!] /type kind [word!] /local refs arity][
		set [refs arity] make-refs-table spec
		repend functions [name reduce [any [kind 'function!] arity spec refs]]
	]
	
	fetch-functions: func [pos [block!] /local name type spec refs arity][
		name: to word! pos/1
		if find functions name [exit]					;-- mainly intended for 'make (hardcoded)

		switch type: pos/3 [
			native! [if find intrinsics name [type: 'intrinsic!]]
			action! [append actions name]
			op!     [repend op-actions [name to word! pos/4]]
		]
		spec: either pos/3 = 'op! [
			third select functions to word! pos/4
		][
			clean-lf-deep pos/4/1
		]
		set [refs arity] make-refs-table spec
		repend functions [name reduce [type arity spec refs]]
	]
	
	emit-block: func [
		blk [any-block!] /sub level [integer!] /bind ctx [word!]
		/local class name item value word action type binding
	][
		if path? blk [class: 'path]
		
		unless sub [
			emit-open-frame 'append
			emit to set-word! name: decorate-series-var any [class 'blk]
			emit append to path! any [class 'block] 'push*
			emit max 1 length? blk
			insert-lf -3
		]
		level: 0
		
		forall blk [
			item: blk/1
			either any-block? :item [
				type: either all [path? item get-word? item/1][
					item/1: to word! item/1 ;this is workaround of missing get-path! in R2
					'get-path
				][type? :item]
				
				emit-open-frame 'append
				emit to lit-path! reduce [to word! form type 'push*]
				emit max 1 length? item
				insert-lf -2
				
				level: level + 1
				either bind [
					emit-block/sub/bind to block! item level ctx
				][
					emit-block/sub to block! item level
				]
				level: level - 1
				
				emit-close-frame
				emit 'block/append*
				insert-lf -1
				emit 'stack/keep						;-- reset stack, but keep block as last value
				insert-lf -1
			][
				if :item = #get-definition [			;-- temporary directive
					value: select extracts/definitions blk/2
					change/only/part blk value 2
					item: blk/1
				]
				action: 'push
				value: case [
					unicode-char? :item [
						value: item
						item: #"_"						;-- placeholder just to pass the char! type to item
						to integer! next value
					]
					any-word? :item [
						add-symbol word: to word! clean-lf-flag item
						value: decorate-symbol word
						either all [bind local-word? to word! :item][
							action: 'push-local
							reduce [ctx get-word-index/with to word! :item ctx]
						][
							either binding: find-binding :item [
								action: 'push-local
								binding
							][
								value
							]
						]
					]
					issue? :item [
						add-symbol word: to word! form item
						decorate-symbol word
					]
					find [string! file! url!] type?/word :item [
						emit [tmp:]
						insert-lf -1
						emit-load-string item
						new-line back tail output off
						'tmp
					]
					find [logic! unset! datatype!] type?/word :item [
						to word! form :item
					]
					none? :item [
						[]								;-- no argument
					]
					'else [
						item
					]
				]
				either float-special? :item [
					emit 'float/push64
					emit-fp-special item
					insert-lf -3
				][
					either decimal? :item [
						emit 'float/push64
						emit-float item
						insert-lf -3
					][
						emit to path! reduce [to word! form type? :item action]
						emit value
						insert-lf -1 - either block? value [length? value][1]
					]
				]
				
				emit 'block/append*
				insert-lf -1
				unless tail? next blk [
					emit 'stack/keep					;-- reset stack, but keep block as last value
					insert-lf -1
				]
			]
		]
		unless sub [emit-close-frame]
		name
	]
	
	emit-eval-path: func [/set][
		emit 'actions/eval-path*
		emit either set ['true]['false]
		insert-lf -2
	]
	
	emit-path: func [
		path [path! set-path!] set? [logic!] alt? [logic!]
		/local value mark assign original
	][
		value: path/1
		
		assign: [
			either alt? [								;-- object path (fallback case)
				emit [stack/push stack/arguments - 1]	;-- get arguments just below the stack record
				insert-lf -4
			][
				comp-expression							;-- fetch assigned value (normal case)
			]
			emit-eval-path/set
			emit-close-frame
		]
		
		switch type?/word original: value [
			word! [
				add-symbol value: to word! clean-lf-flag value
				case [
					head? path [
						emit-get-word value original
					]
					all [set? tail? next path][
						emit-open-frame 'eval-set-path
						emit-path back path set? alt?
						emit-push-word value value
						do assign
					]
					'else [
						emit-open-frame 'select
						emit-path back path set? alt?
						emit-push-word value value
						insert-lf -2
						emit-action/with 'select [-1 -1 -1 -1 -1 -1 -1 -1]
						emit-close-frame
					]
				]
			]
			get-word! [
				either all [set? tail? next path][
					emit-open-frame 'poke
					emit-path back path set? alt?
					emit-get-word to word! value original
					
					emit copy/deep [unless stack/top-type? = TYPE_INTEGER] ;-- choose action at run-time
					insert-lf -4
					
					mark: tail output					;-- SELECT action
					emit [stack/pop 1]					;-- overwrite the get-word on stack top
					insert-lf -2
					emit-open-frame 'find
					emit-path back path set? alt?
					emit-get-word to word! value original
					emit-action/with 'find [-1 -1 -1 -1 -1 -1 -1 -1 -1 -1]
					emit-action 'index?
					emit [stack/pop 2]
					insert-lf -2
					emit [integer/push 1]
					insert-lf -2
					emit-action 'add
					emit-close-frame
					convert-to-block mark
					do assign
				][
					emit-open-frame 'pick-select
					emit-path back path set? alt?
					emit-get-word to word! value original
					
					emit copy/deep [either stack/top-type? = TYPE_INTEGER] ;-- choose action at run-time
					insert-lf -4
					
					mark: tail output					;-- PICK action
					emit-action 'pick
					convert-to-block mark
					
					mark: tail output					;-- SELECT action
					emit-action/with 'select [-1 -1 -1 -1 -1 -1 -1 -1]
					convert-to-block mark
					
					emit-close-frame
				]
			]
			integer! [
				either all [set? tail? next path][
					emit-open-frame 'eval-set-path
					emit-path back path set? alt?
					emit compose [integer/push (value)]
					insert-lf -2
					do assign
				][
					emit-open-frame 'pick
					emit-path back path set? alt?
					emit compose [integer/push (value)]
					insert-lf -2
					emit-action 'pick
					emit-close-frame
				]
			]
			string!	[
				--not-implemented--
			]
		]
	]
	
	paths-stack: make block! 4
	
	emit-checked-path: func [path [path!] /local pname fun idx mark saved][
		redirect-to literals [pname: emit-block path]
		fun: decorate-func to word! join "~path" s-counter + 1
		
		emit [stack/top: stack/arguments]				;-- inlined stack reset (protected from callbacks)
		insert-lf -2
		emit 'word/get
		emit decorate-symbol path/1
		insert-lf -2
		saved: output
		
		forall path [
			emit [either stack/func?]
			insert-lf -2
			idx: (index? path) - 1
			emit compose/deep [[stack/push-call (pname) (idx) as-integer (to get-word! fun)]]

			either tail? next path [
				emit compose/deep [[
					copy-cell stack/arguments + 1 stack/arguments
					stack/keep
					(fun)
				]]
				new-line back tail last output yes
			][
				mark: tail output
				emit-open-frame 'eval-path
				emit [stack/push stack/arguments - 1]
				insert-lf -4
				emit append to path! to word! form type? path/2 'push
				emit decorate-symbol path/2
				insert-lf -2
				emit-eval-path no
				emit 'stack/unwind-no-cb				;-- avoid triggering dynamic callbacks
				insert-lf -1
				emit [stack/top: stack/arguments + 2]
				insert-lf -4
				change/only/part mark mark: copy mark tail output
				output: mark
			]
		]
		output: saved
	]

	emit-path-func: has [body f-name][
		body: copy expr-start-pos
		clear expr-start-pos
		if all [1 = length? body body/1 = 'stack/reset][clear body]
		
		redirect-to declarations [
			f-name: to word! join "f_~path" get-counter
			emit reduce [to set-word! f-name 'does body]
			insert-lf -3
		]
		emit last paths-stack
		remove back tail paths-stack
	]
	
	emit-opt-call: func [mark [block!]][
		append/only paths-stack copy mark
		clear mark
		if (index? mark) <> index? expr-start-pos [
			emit [stack/push stack/arguments  - 1]
			insert-lf -4
		]
	]
	
	emit-routine: func [name [word!] spec [block!] /local type cnt offset alter][
		declare-variable/init 'r_arg to paren! [as red-value! 0]
		emit [r_arg: stack/arguments]
		insert-lf -2

		offset: 0
		if all [
			type: select spec return-def
			find [integer! logic!] type/1 
		][
			offset: 1
			append/only output append to path! form get type/1 'box
		]
		if alter: select/skip ssa-names name 2 [name: alter]
		emit name
		cnt: 0

		forall spec [
			if string? spec/1 [
				if tail? remove spec [break]
			]
			if any [spec/1 = /local set-word? spec/1][
				spec: head spec
				break									;-- avoid processing local variable	
			]
			unless block? spec/1 [
				unless block? spec/2 [
					insert/only next spec [red-value!]
				]
				either find [integer! logic!] spec/2/1 [
					append/only output append to path! form get spec/2/1 'get
				][
					emit reduce ['as spec/2/1]
				]
				emit 'r_arg
				unless head? spec [emit reduce ['+ cnt]]
				cnt: cnt + 1
			]
		]
		insert-lf negate cnt * 2 + offset + 1
	]
	
	redirect-to: func [out [block!] body [block!] /local saved][
		saved: output
		output: out
		also
			do body
			output: saved
	]

	emit-float: func [value [decimal!] /local bin][
		bin: IEEE-754/to-binary64 value
		emit to integer! copy/part bin 4
		emit to integer! skip bin 4
	]

	emit-fp-special: func [value [issue!]][
		switch next value [
			#INF  [emit to integer! #{7FF00000} emit 0]
			#INF- [emit to integer! #{FFF00000} emit 0]
			#NaN  [emit to integer! #{7FF80000} emit 0]			;-- smallest quiet NaN
			#0-	  [emit to integer! #{80000000} emit 0]
		]
	]
	
	comp-literal: func [/inactive /local value char? special? name w make-block type][
		value: pc/1
		either any [
			char?: unicode-char? value
			special?: float-special? value
			scalar? :value
		][			
			case [
				char? [
					emit 'char/push
					emit to integer! next value
					insert-lf -2
				]
				special? [
					emit 'float/push64
					emit-fp-special value
					insert-lf -3
				]
				decimal? :value [
					emit 'float/push64
					emit-float value
					insert-lf -3
				]
				find [refinement! issue! lit-word!] type?/word :value [
					add-symbol w: to word! form value
					type: to word! form type? :value
					if all [lit-word? :value not inactive][type: 'word]
					
					either all [not issue? :value local-word? w][
						emit append to path! type 'push-local
						emit last ctx-stack
						emit get-word-index w
						insert-lf -3
					][
						emit to path! reduce [type 'push]
						emit to path! reduce ['exec decorate-symbol w]
						insert-lf -2
					]
				]
				none? :value [
					emit 'none/push
					insert-lf -1
				]
				any-word? :value [
					add-symbol to word! :value
					emit-push-word :value :value
				]
				'else [
					emit to path! reduce [to word! form type? :value 'push]
					emit load mold :value
					insert-lf -2
				]
			]
		][
			make-block: [
				redirect-to literals [
					value: to block! value
					either empty? ctx-stack [
						emit-block value
					][
						emit-block/bind value last ctx-stack
					]
				]
			]
			switch/default type?/word value [
				block!	[
					name: do make-block
					emit 'block/push
					emit name
					insert-lf -2
				]
				paren!	[
					name: do make-block
					emit 'paren/push
					emit name
					insert-lf -2
				]
				path! set-path!	[
					name: do make-block
					either lit-path? pc/1 [
						emit 'path/push
					][
						emit to path! reduce [to word! form type? pc/1 'push]
					]
					emit name
					insert-lf -2
				]
				string!	file! url! [
					redirect-to literals [
						emit to set-word! name: decorate-series-var 'str
						insert-lf -1
						emit-load-string value
					]	
					emit to path! reduce [to word! form type? value 'push]
					emit name
					insert-lf -2
				]
				binary!	[]
			][
				throw-error ["comp-literal: unsupported type" mold value]
			]
		]
		pc: next pc
		name
	]
	
	inherit-functions: func [new [object!] extend [object!] /local symbol name][ ;-- multiple inheritance case
		foreach word next first extend [
			if function! = get in extend word [
				symbol: decorate-obj-member word select objects extend
				
				repend functions [
					name: decorate-obj-member word select objects new
					select functions symbol
				]
				
				append bodies name
				append bodies bind/copy copy/part next find bodies symbol 8 new
				add-symbol name
			]
		]
	]
	
	comp-context: func [
		/with word
		/extend proto [object!]
		/locals 
			words ctx spec name id func? obj original body pos entry
			symbol body? ctx2 new blk list
	][
		name:  to word! original: any [word pc/-1]
		words: any [all [proto third proto] make block! 8] ;-- start from existing ctx or fresh
		list:  clear any [list []]
		
		if proto [proto: reduce [proto]]
		
		either body?: block? pc/2 [
			parse body: pc/2 [							;-- collect words from body block
				any [
					(clear list)
					any [pos: set-word! (append list pos/1)]
					(func?: no) [func-constructors (func?: yes) | skip] (
						foreach word list [
							either entry: find words word [
								if func? [entry/2: function!]
							][
								append words word
								append words either func? [function!][none]
							]
						]
					) | skip
				]
			]

			spec: make block! (length? words) / 2
			forskip words 2 [append spec to word! words/1]
		][
			unless extend [
				blk: redirect-to literals [emit-block copy/part pc 2]
				emit-open-frame 'set					;-- defer it to runtime evaluation
				emit-push-word name original
				emit-open-frame 'do
				emit reduce ['block/push blk]
				insert-lf -2
				emit-native 'do
				emit-close-frame
				emit 'word/set
				insert-lf -1
				emit-close-frame
				pc: skip pc 2
				return none
			]
			obj:    find objects proto/1				;-- simple inheritance case
			spec:   next first obj/1
			words:  third obj/1
			
			unless find [context object object!] pc/1 [
				unless new: is-object? pc/2 [
					comp-call 'make select functions 'make ;-- fallback to runtime creation
					exit
				]
				
				ctx2: select objects new				;-- multiple inheritance case
				spec: union spec next first new
				insert proto new
				
				forskip words 2 [
					if word: in new words/1 [words/2: get in new words/1]
				]
				foreach [name value] third new [
					unless find words name [repend words [name value]]
				]
			]
		]

		redirect-to literals [							;-- store spec and body blocks
			ctx: add-context spec
			emit compose [
				(to set-word! ctx) _context/make (blk: emit-block spec) no yes	;-- build context
			]
			insert-lf -4
		]
		
		symbol: get pick [name ctx] to logic! any [		;-- name for global words, else use context name
			rebol-gctx = bind? original 
			local-word? name
		]
		if pos: find get-obj-base/list name name [pos/1: none] ;-- unbind word with previous object
		
		repend objects [								;-- register shadow object	
			symbol										;-- object access word
			obj: make object! words						;-- shadow object
			ctx											;-- object's context name
			id: get-counter								;-- unique object ID
			proto										;-- optional prototype object
		]
		
		unless tail? next obj-stack [
			do reduce [to set-path! join obj-stack name obj] ;-- set object in shadow tree
		]
		if body? [bind body obj]
		
		emit-open-frame 'set							;-- runtime object value creation
		emit-push-word name original
		unless all [empty? locals-stack not iterator-pending?][	;-- in a function or iteration block
			emit compose [
				(to set-word! ctx) _context/make (blk) no yes	;-- rebuild context
			]
			insert-lf -4
		]
		emit reduce ['object/init-push ctx id]
		insert-lf -3
		if proto [
			if body? [inherit-functions obj last proto]
			emit reduce ['object/duplicate select objects last proto ctx]
			insert-lf -3
		]
		unless body? [
			inherit-functions obj new
{'fraction_non_alphanumeric': 0.11927554980595084, 'fraction_numerical': 0.011438687274460407, 'mean_word_length': 2.264257456549762, 'pattern_counts': {'":': 0, '<': 31, '<?xml version=': 0, '>': 21, 'https://': 2, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 2, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '40865', 'n_tokens_mistral': 32195, 'n_tokens_neox': 24826, 'n_words': 8505}