/red-system/compiler.r

Large files files are truncated, but you can click here to view the full file

   1REBOL [
   2	Title:   "Red/System compiler"
   3	Author:  "Nenad Rakocevic"
   4	File: 	 %compiler.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
   9do %utils/r2-forward.r
  10do %utils/int-to-bin.r
  11do %utils/virtual-struct.r
  12do %utils/secure-clean-path.r
  13do %linker.r
  14do %emitter.r
  15
  16system-dialect: context [
  17	verbose:  	  0									;-- logs verbosity level
  18	job: 		  none								;-- reference the current job object	
  19	runtime-path: %runtime/
  20	nl: 		  newline
  21	
  22	loader: do bind load %loader.r 'self
  23	
  24	compiler: context [
  25		job:		 none								;-- shortcut for job object
  26		pc:			 none								;-- source code input cursor
  27		script:		 none								;-- source script file name
  28		none-type:	 [#[none]]							;-- marker for "no value returned"
  29		last-type:	 none-type							;-- type of last value from an expression
  30		locals: 	 none								;-- currently compiled function specification block
  31		locals-init: []									;-- currently compiler function locals variable init list
  32		func-name:	 none								;-- currently compiled function name
  33		block-level: 0									;-- nesting level of input source block
  34		verbose:  	 0									;-- logs verbosity level
  35	
  36		imports: 	   make block! 10					;-- list of imported functions
  37		natives:	   make hash!  40					;-- list of functions to compile [name [specs] [body]...]
  38		globals:  	   make hash!  40					;-- list of globally defined symbols from scripts
  39		aliased-types: make hash!  10					;-- list of aliased type definitions
  40		
  41		resolve-alias?: yes								;-- YES: instruct the type resolution function to reduce aliases
  42		
  43		debug-lines: reduce [							;-- runtime source line/file information storage
  44			'records make block!  1000					;-- [address line file] records
  45			'files	 make hash!   20					;-- filenames table
  46		]
  47		
  48		pos:		none								;-- validation rules cursor for error reporting
  49		return-def: to-set-word 'return					;-- return: keyword
  50		fail:		[end skip]							;-- fail rule
  51		rule: value: none								;-- global parsing rules helpers
  52		
  53		not-set!:	  [logic! integer!]								  ;-- reserved for internal use only
  54		number!: 	  [byte! integer!]								  ;-- reserved for internal use only
  55		pointers!:	  [pointer! struct! c-string!] 					  ;-- reserved for internal use only
  56		any-pointer!: union pointers! [function!]		  			  ;-- reserved for internal use only
  57		poly!:		  union number!	pointers!					  	  ;-- reserved for internal use only
  58		any-type!:	  union poly! [logic!]							  ;-- reserved for internal use only
  59		type-sets:	  [not-set! number! poly! any-type! any-pointer!] ;-- reserved for internal use only
  60		
  61		comparison-op: [= <> < > <= >=]
  62		
  63		functions: to-hash [
  64		;--Name--Arity--Type----Cc--Specs--		   Cc = Calling convention
  65			+		[2	op		- [a [poly!]   b [poly!]   return: [poly!]]]
  66			-		[2	op		- [a [poly!]   b [poly!]   return: [poly!]]]
  67			*		[2	op		- [a [number!] b [number!] return: [number!]]]
  68			/		[2	op		- [a [number!] b [number!] return: [number!]]]
  69			and		[2	op		- [a [number!] b [number!] return: [number!]]]
  70			or		[2	op		- [a [number!] b [number!] return: [number!]]]
  71			xor		[2	op		- [a [number!] b [number!] return: [number!]]]
  72			//		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- modulo
  73			///		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- remainder (real syntax: %)
  74			>>		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- shift left signed
  75			<<		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- shift right signed
  76			-**		[2	op		- [a [number!] b [number!] return: [number!]]]		;-- shift right unsigned
  77			=		[2	op		- [a [any-type!] b [any-type!]  return: [logic!]]]
  78			<>		[2	op		- [a [any-type!] b [any-type!]  return: [logic!]]]
  79			>		[2	op		- [a [poly!]   b [poly!]   return: [logic!]]]
  80			<		[2	op		- [a [poly!]   b [poly!]   return: [logic!]]]
  81			>=		[2	op		- [a [poly!]   b [poly!]   return: [logic!]]]
  82			<=		[2	op		- [a [poly!]   b [poly!]   return: [logic!]]]
  83			not		[1	inline	- [a [not-set!] 		   return: [logic!]]]	;@@ return should be not-set!
  84			push	[1	inline	- [a [any-type!]]]
  85			pop		[0	inline	- [						   return: [integer!]]]
  86		]
  87		
  88		user-functions: tail functions					;-- marker for user functions
  89		
  90		action-class: context [action: type: data: none]
  91		
  92		struct-syntax: [
  93			pos: opt [into ['align integer! opt ['big | 'little]]]	;-- struct's attributes
  94			pos: some [word! into type-spec]						;-- struct's members
  95		]
  96		
  97		pointer-syntax: ['integer! | 'byte!]
  98		
  99		func-pointer: ['function! set value block! (check-specs '- value)]
 100		
 101		type-syntax: [
 102			'logic! | 'int32! | 'integer! | 'uint8! | 'byte! | 'int16!
 103			| 'c-string!
 104			| 'pointer! into [pointer-syntax]
 105			| 'struct!  into [struct-syntax]
 106		]
 107
 108		type-spec: [
 109			pos: some type-syntax | set value word! (			;-- multiple types allowed for internal usage			
 110				unless find aliased-types value [throw false]	;-- stop parsing if unresolved type
 111			)
 112		]		
 113		
 114		keywords: [
 115			;&			 [throw-error "reserved for future use"]
 116			as			 [comp-as]
 117			assert		 [comp-assert]
 118			size? 		 [comp-size?]
 119			if			 [comp-if]
 120			either		 [comp-either]
 121			case		 [comp-case]
 122			switch		 [comp-switch]
 123			until		 [comp-until]
 124			while		 [comp-while]
 125			any			 [comp-expression-list]
 126			all			 [comp-expression-list/_all]
 127			exit		 [comp-exit]
 128			return		 [comp-exit/value]
 129			declare		 [comp-declare]
 130			null		 [comp-null]
 131			
 132			true		 [also true pc: next pc]		  ;-- converts word! to logic!
 133			false		 [also false pc: next pc]		  ;-- converts word! to logic!
 134			
 135			func 		 [raise-level-error "a function"] ;-- func declaration not allowed at this level
 136			function 	 [raise-level-error "a function"] ;-- func declaration not allowed at this level
 137			alias 		 [raise-level-error "an alias"]	  ;-- alias declaration not allowed at this level
 138		]
 139		
 140		calc-line: has [idx head-end prev p header][
 141			header: head pc
 142			idx: (index? pc) - header/1  				;-- calculate real pc position (not counting hidden header)
 143			prev: 1
 144
 145			parse header [								;-- search for closest line marker
 146				skip									;-- skip over header length
 147				some [
 148					set p pair! (
 149						if p/2 = idx [return p/1]		;-- exact value position match
 150						if p/2 > idx [return prev]		;-- closest value position match 
 151						prev: p/1
 152					)
 153				]
 154			]
 155			return p/1									;-- return last marker
 156		]
 157		
 158		store-dbg-lines: has [dbg pos][
 159			dbg: debug-lines
 160			unless pos: find dbg/files script [
 161				pos: tail dbg/files
 162				append dbg/files script
 163			]
 164			repend dbg/records [
 165				emitter/tail-ptr calc-line index? pos
 166			]
 167		]
 168		
 169		quit-on-error: does [
 170			clean-up
 171			if system/options/args [quit/return 1]
 172			halt
 173		]
 174		
 175		throw-error: func [err [word! string! block!]][
 176			print [
 177				"*** Compilation Error:"
 178				either word? err [
 179					join uppercase/part mold err 1 " error"
 180				][reform err]
 181				"^/*** in file:" mold script
 182				either locals [join "^/*** in function: " func-name][""]
 183			]
 184			if pc [
 185				print [
 186					"*** at line:" calc-line lf
 187					"*** near:" mold copy/part pc 8
 188				]
 189			]
 190			quit-on-error
 191		]
 192		
 193		throw-warning: func [msg [string! block!] /near][
 194			print [
 195				"*** Warning:" 	reform msg
 196				"^/*** in:" 	mold script
 197				"^/*** at:" 	mold copy/part any [all [near back pc] pc] 8
 198			]
 199		]
 200		
 201		raise-level-error: func [kind [string!]][
 202			pc: back pc
 203			throw-error reform ["declaring" kind "at this level is not allowed"]
 204		]
 205		
 206		raise-casting-error: does [
 207			backtrack 'as
 208			throw-error "multiple type casting not allowed"
 209		]
 210		
 211		raise-paren-error: does [
 212			pc: back pc
 213			throw-error "parens are only allowed nested in an expression"
 214		]
 215		
 216		raise-runtime-error: func [error [integer!]][
 217			emitter/target/emit-get-pc				;-- get current CPU program counter address
 218			last-type: [integer!]					;-- emit-get-pc returns an integer! (required for next line)
 219			compiler/comp-call '***-on-quit reduce [error <last>] ;-- raise a runtime error
 220		]
 221		
 222		backtrack: func [value /local res][
 223			pc: any [res: find/only/reverse pc value pc]
 224			to logic! res
 225		]
 226		
 227		blockify: func [value][either block? value [value][reduce [value]]]
 228
 229		literal?: func [value][
 230			not any [word? value path? value block? value value = <last>]
 231		]
 232		
 233		not-initialized?: func [name [word!] /local pos][
 234			all [
 235				locals
 236				pos: find locals /local
 237				pos: find next pos name
 238				not find locals-init name
 239			]
 240		]
 241		
 242		get-alias-id: func [pos [hash!]][
 243			1000 + divide 1 + index? pos 2
 244		]
 245		
 246		get-type-id: func [value /local type alias][
 247			with-alias-resolution off [type: resolve-expr-type value]
 248			
 249			either alias: find aliased-types type/1 [
 250				get-alias-id alias
 251			][
 252				type: resolve-aliased type
 253				type: either type/1 = 'pointer! [
 254					pick [int-ptr! byte-ptr!] type/2/1 = 'integer!
 255				][
 256					type/1
 257				]
 258				select emitter/datatype-ID type
 259			]
 260		]
 261		
 262		system-reflexion?: func [path [path!] /local def][	
 263			if path/1 = 'system [
 264				switch path/2 [
 265					alias [
 266						unless path/3 [
 267							backtrack path
 268							throw-error "invalid system/alias path access"
 269						]
 270						unless def: find aliased-types path/3 [
 271							backtrack path
 272							throw-error ["undefined alias name:" path/3]
 273						]
 274						last-type: [integer!]
 275						return get-alias-id def			;-- special encoding for aliases
 276					]
 277					; add new special reflective system path here
 278				]
 279			]
 280			none
 281		]
 282		
 283		base-type?: func [value][
 284			if block? value [value: value/1]
 285			to logic! find/skip emitter/datatypes value 3
 286		]
 287		
 288		unbox: func [value][
 289			either object? value [value/data][value]
 290		]
 291		
 292		get-return-type: func [name [word!] /local type][
 293			type: select functions/:name/4 return-def
 294			unless type [
 295				backtrack name
 296				throw-error ["return type missing in function:" name]
 297			]
 298			any [type none-type]
 299		]
 300		
 301		set-last-type: func [spec [block!]][
 302			if spec: select spec return-def [last-type: spec]
 303		]
 304		
 305		exists-variable?: func [name [word! set-word!]][
 306			name: to word! name
 307			to logic! any [
 308				all [locals find locals name]
 309				find globals name
 310			]
 311		]
 312		
 313		get-variable-spec: func [name [word!]][
 314			any [
 315				all [locals select locals name]
 316				select globals name
 317			]
 318		]
 319		
 320		get-arity: func [spec [block!] /local count][
 321			count: 0
 322			parse spec [opt block! any [word! block! (count: count + 1)]]
 323			count
 324		]
 325		
 326		any-pointer?: func [type [block!]][
 327			type: first resolve-aliased type
 328			
 329			either find type-sets type [
 330				not empty? intersect get type any-pointer!
 331			][
 332				to logic! find any-pointer! type
 333			]
 334		]
 335
 336		equal-types?: func [type1 [word!] type2 [word!]][
 337			type1: either find type-sets type1 [get type1][reduce [type1]]
 338			type2: either find type-sets type2 [get type2][reduce [type2]]
 339			not empty? intersect type1 type2
 340		]
 341		
 342		equal-types-list?: func [types [block!]][
 343			forall types [							;-- check if all last expressions are of same type
 344				unless types/1/1 [return none-type]	;-- test if type is defined
 345				types/1: resolve-aliased types/1	;-- reduce aliases and pseudo-types
 346				if all [
 347					not head? types
 348					not equal-types? types/-1/1 types/1/1
 349				][
 350					return none-type
 351				]
 352			]
 353			first head types						;-- all types equal, return the first one
 354		]
 355						
 356		with-alias-resolution: func [mode [logic!] body [block!] /local saved][
 357			saved: resolve-alias?
 358			resolve-alias?: mode	
 359			do body
 360			resolve-alias?: saved
 361		]
 362		
 363		resolve-aliased: func [type [block!] /local name][
 364			name: type/1
 365			all [
 366				not base-type? name
 367				not find type-sets name
 368				not type: select aliased-types name
 369				throw-error ["unknown type:" type]
 370			]
 371			type
 372		]
 373		
 374		resolve-type: func [name [word!] /with parent [block! none!] /local type][
 375			type: any [
 376				all [parent select parent name]
 377				get-variable-spec name
 378			]
 379			if all [not type find functions name][
 380				return reduce ['function! functions/:name/4]
 381			]
 382			unless any [not resolve-alias? base-type? type/1][
 383				type: select aliased-types type/1
 384			]
 385			type
 386		]
 387		
 388		resolve-struct-member-type: func [spec [block!] name [word!] /local type][
 389			unless type: select spec name [
 390				pc: skip pc -2
 391				throw-error [
 392					"invalid struct member" name "in:" mold to path! pc/1
 393				]
 394			]
 395			either resolve-alias? [resolve-aliased type][type]
 396		]
 397		
 398		resolve-path-type: func [path [path! set-path!] /parent prev /local type path-error saved][
 399			path-error: [
 400				pc: skip pc -2
 401				throw-error "invalid path value"
 402			]
 403			either word? path/1 [
 404				either parent [
 405					resolve-struct-member-type prev path/1	;-- just check for correct member name
 406					with-alias-resolution on [
 407						type: resolve-type/with path/1 prev
 408					]
 409				][
 410					with-alias-resolution on [
 411						type: resolve-type path/1
 412					]
 413				]
 414			][reduce [type?/word path/1]]
 415			
 416			unless type path-error
 417			
 418			either tail? skip path 2 [
 419				switch/default type/1 [
 420					c-string! [
 421						check-path-index path 'string
 422						[byte!]
 423					]
 424					pointer!  [
 425						check-path-index path 'pointer
 426						reduce [type/2/1]				;-- return pointed value type
 427					]
 428					struct!   [
 429						unless word? path/2 [
 430							backtrack path
 431							throw-error ["invalid struct member" path/2]
 432						]
 433						resolve-struct-member-type type/2 path/2
 434					]
 435				] path-error
 436			][
 437				resolve-path-type/parent next path second type
 438			]
 439		]
 440		
 441		get-type: func [value][
 442			switch/default type?/word value [
 443				none!	 [none-type]				;-- no type case (func with no return value)
 444				tag!	 [either value = <last> [last-type][ [logic!] ]]
 445				logic!	 [[logic!]]
 446				word! 	 [resolve-type value]
 447				char!	 [[byte!]]
 448				integer! [[integer!]]
 449				string!	 [[c-string!]]
 450				path!	 [resolve-path-type value]
 451				object!  [value/type]
 452				block!	 [			
 453					either 'op = second select functions value/1 [
 454						either base-type? type: get-return-type value/1 [
 455							type				;-- unique returned type, stop here
 456						][
 457							get-type value/2	;-- recursively search for left operand base type
 458						]
 459					][
 460						get-return-type value/1
 461					]
 462				]
 463				paren!	 [
 464					reduce either all [value/1 = 'struct! word? value/2][
 465						[value/2]
 466					][
 467						[value/1 value/2]
 468					]
 469				]
 470				get-word! [resolve-type to word! value]
 471			][
 472				throw-error ["not accepted datatype:" type? value]
 473			]
 474		]
 475
 476		resolve-expr-type: func [expr /quiet /local type func? spec][
 477			if block? expr [
 478				switch type?/word expr/1 [
 479					set-word! [expr: expr/2]			;-- resolve assigned value type
 480					set-path! [expr: to path! expr/1]	;-- resolve path type
 481				]
 482			]			
 483			func?: all [
 484				block? expr word? expr/1
 485				not find comparison-op expr/1
 486				spec: select functions expr/1 		 ;-- works for unary & binary functions only!
 487			]
 488			type: case [
 489				object? expr [
 490					expr/type						 ;-- type casting case
 491				]
 492				all [func? find [op inline] spec/2][ ;-- works for unary & binary functions only!
 493					any [
 494						all [
 495							expr/1 <> 'not			;-- @@ issue with 'not return type
 496							spec: select spec/4 return-def
 497							base-type? spec/1		;-- determined return type
 498							spec
 499						]
 500						get-type expr/2				;-- recursively search for return type
 501					]
 502				]
 503				all [func? quiet][
 504					any [
 505						select spec/4 return-def	;-- workaround error throwing in get-return-value
 506						none-type
 507					]
 508				]
 509				'else [get-type expr]
 510			]
 511			type
 512		]
 513		
 514		cast: func [obj [object!] /local value ctype type][
 515			value: obj/data
 516			ctype: obj/type
 517			type: get-type value
 518
 519			if type = ctype [
 520				throw-warning/near [
 521					"type casting from" type/1 
 522					"to" ctype/1 "is not necessary"
 523				] 'as
 524			]
 525			if any [
 526				all [type/1 = 'function! ctype/1 <> 'integer!]
 527				all [ctype/1 = 'byte! find [c-string! pointer! struct!] type/1]
 528				all [
 529					find [c-string! pointer! struct!] ctype/1
 530					find [byte! logic!] type/1
 531				]
 532			][
 533				backtrack value
 534				throw-error [
 535					"type casting from" type/1
 536					"to" ctype/1 "is not allowed"
 537				]
 538			]	
 539			unless literal? value [return value]	;-- shield the following literal conversions
 540			
 541			switch ctype/1 [
 542				byte! [
 543					switch type/1 [
 544						integer! [value: value and 255]
 545						logic! 	 [value: pick [#"^(01)" #"^(00)"] value]
 546					]
 547				]
 548				integer! [
 549					if find [byte! logic!] type/1 [
 550						value: to integer! value
 551					]
 552				]
 553				logic! [
 554					switch type/1 [
 555						byte! 	 [value: value <> null]
 556						integer! [value: value <> 0]
 557					]
 558				]
 559			]
 560			value
 561		]
 562		
 563		init-local: func [name [word!] expr casted [block! none!] /local pos type][
 564			append locals-init name					;-- mark as initialized
 565			pos: find locals name
 566			unless block? pos/2 [					;-- if not typed, infer type
 567				insert/only at pos 2 type: any [
 568					casted
 569					resolve-expr-type expr
 570				]
 571				if verbose > 2 [print ["inferred type" mold type "for variable:" pos/1]]
 572			]
 573		]
 574		
 575		add-symbol: func [name [word!] value type][
 576			unless type [type: get-type value]
 577			append globals reduce [name type: compose [(type)]]
 578			type
 579		]
 580		
 581		add-function: func [type [word!] spec [block!] cc [word!]][
 582			repend functions [
 583				to word! spec/1 reduce [get-arity spec/3 type cc new-line/all spec/3 off]
 584			]		
 585		]
 586		
 587		compare-func-specs: func [
 588			fun [word!] cb [get-word!] f-type [block!] c-type [block!] /local spec pos idx
 589		][
 590			cb: to word! cb
 591			if functions/:cb/3 <> functions/:fun/3 [
 592				throw-error [
 593					"incompatible calling conventions between"
 594					fun "and" cb
 595				]
 596			]
 597			if pos: find f-type /local [f-type: head clear copy pos] ;-- remove locals
 598			if block? f-type/1 [f-type: next f-type]	;-- skip optional attributes block
 599			if block? c-type/1 [c-type: next c-type]	;-- skip optional attributes block
 600			idx: 2
 601			foreach [name type] f-type [
 602				if type <> c-type/:idx [return false]
 603				idx: idx + 2
 604			]
 605			true
 606		]
 607		
 608		check-keywords: func [name [word!]][
 609			if any [
 610				find keywords name
 611				name = 'comment
 612			][
 613				throw-error ["attempt to redefined a protected keyword:" name]
 614			]
 615		]
 616		
 617		check-path-index: func [path [path! set-path!] type [word!] /local ending][
 618			ending: path/2
 619			case [
 620				all [type = 'pointer ending = 'value][]	;-- pass thru case
 621				word? ending [
 622					unless get-variable-spec ending [
 623						backtrack path
 624						throw-error ["undefined" type "index variable"]
 625					]
 626					if 'integer! <> first resolve-type ending [
 627						backtrack path
 628						throw-error [
 629							"attempt to use" type
 630							"indexing with a non-integer! variable"
 631						]
 632					]
 633				]
 634				not integer? ending [
 635					backtrack path
 636					throw-error [
 637						"attempt to use" type
 638						"indexing with a non-integer! value"
 639					]
 640				]
 641			]
 642		]
 643		
 644		check-func-name: func [name [word!] /only][
 645			if find functions name [
 646				pc: back pc
 647				throw-error ["attempt to redefine existing function name:" name]
 648			]
 649			if all [not only find any [locals globals] name][
 650				pc: back pc
 651				throw-error ["a variable is already using the same name:" name]
 652			]
 653		]
 654		
 655		check-duplicates: func [
 656			name [word!] args [block! none!] locs [block! none!]
 657			/local dups
 658		][
 659			if args [remove-each item args: copy args [not word? item]]
 660			if locs [remove-each item locs: copy locs [not word? item]]
 661			
 662			if any [
 663				all [args (length? unique args) <> length? args]
 664				all [locs (length? unique locs) <> length? locs]
 665				all [args locs not empty? dups: intersect args locs]
 666			][
 667				throw-error [
 668					"duplicate variable definition in function" name
 669					either dups [reform ["for:" mold/only new-line/all dups no]][""]
 670				]
 671			]
 672		]
 673		
 674		check-specs: func [
 675			name specs /extend
 676			/local type type-def spec-type attribs value args locs cconv
 677		][
 678			unless block? specs [
 679				throw-error "function definition requires a specification block"
 680			]
 681			cconv: ['cdecl | 'stdcall]
 682			attribs: [
 683				'infix | 'variadic | 'typed | cconv
 684				| [cconv ['variadic | 'typed]]
 685				| [['variadic | 'typed] cconv]
 686			]
 687			type-def: pick [[func-pointer | type-spec] [type-spec]] to logic! extend
 688
 689			unless catch [
 690				parse specs [
 691					pos: opt [into attribs]				;-- functions attributes
 692					pos: copy args any [pos: word! into type-def]	;-- arguments definition
 693					pos: opt [							;-- return type definition				
 694						set value set-word! (					
 695							rule: pick reduce [[into type-spec] fail] value = return-def
 696						) rule
 697					]
 698					pos: opt [/local copy locs some [pos: word! opt [into type-spec]]] ;-- local variables definition
 699				]
 700			][
 701				throw-error rejoin ["invalid definition for function " name ": " mold pos]
 702			]
 703			check-duplicates name args locs
 704		]
 705		
 706		check-conditional: func [name [word!] expr][
 707			if last-type/1 <> 'logic! [check-expected-type/key name expr [logic!]]
 708		]
 709		
 710		check-expected-type: func [name [word!] expr expected [block!] /ret /key /local type alias][
 711			unless any [not none? expr key][return none]   ;-- expr == none for special keywords
 712			if all [
 713				not all [object? expr expr/action = 'null] ;-- avoid null type resolution here
 714				not none? expr							;-- expr can be false, so explicit check for none is required
 715				first type: resolve-expr-type expr		;-- first => deep check that it's not [none]
 716			][											;-- check if a type is returned or none
 717				type: resolve-aliased type
 718				if alias: select aliased-types expected/1 [expected: alias]
 719			]
 720			unless any [
 721				all [
 722					object? expr
 723					expr/action = 'null
 724					type: either expected/1 = 'any-type! [expr/type][expected]	;-- morph null type to expected
 725					any-pointer? expected
 726				]
 727				all [
 728					type
 729					any [
 730						find type-sets expected/1
 731						find type-sets type/1
 732					]
 733					equal-types? type/1 expected/1		;-- internal polymorphic case
 734				]
 735				all [
 736					type
 737					type/1 = 'function!
 738					expected/1 = 'function!
 739					compare-func-specs name expr type/2 expected/2	 ;-- callback case
 740				]
 741				expected = type 						 ;-- normal single-type case
 742			][
 743				if expected = type [type: 'null]		 ;-- make null error msg explicit
 744				any [
 745					backtrack any [all [block? expr expr/1] expr]
 746					backtrack name
 747				]
 748				throw-error [
 749					reform case [
 750						ret   [["wrong return type in function:" name]]
 751						key   [[
 752							uppercase form name "requires a conditional expression"
 753							either find [while until] name ["as last expression"][""]						
 754						]]
 755						'else [["argument type mismatch on calling:" name]]
 756					]
 757					"^/*** expected:" join mold expected #","
 758					"found:" mold new-line/all any [type [none]] no
 759				]
 760			]
 761			type
 762		]
 763		
 764		check-arguments-type: func [name args /local entry spec list][
 765			if find [set-word! set-path!] type?/word name [exit]
 766			
 767			entry: find functions name
 768			if all [
 769				not empty? spec: entry/2/4 
 770				block? spec/1
 771			][
 772				spec: next spec						;-- jump over attributes block
 773			]
 774			list: []
 775			foreach arg args [
 776				append/only list check-expected-type name arg spec/2
 777				spec: skip spec	2
 778			]
 779			if all [
 780				any [
 781					find emitter/target/comparison-op name
 782					find emitter/target/bitwise-op name
 783				]
 784				not equal-types? list/1/1 list/2/1	;-- allow implicit casting for math ops only
 785			][
 786				backtrack name
 787				throw-error [
 788					"left and right argument must be of same type for:" name
 789					"^/*** left:" join list/1/1 #"," "right:" list/2/1
 790				]
 791			]
 792			if all [
 793				find emitter/target/math-op name				
 794				any [
 795					all [list/1/1 = 'byte! any-pointer? list/2]
 796					all [list/2/1 = 'byte! any-pointer? list/1]
 797				]
 798			][
 799				backtrack name
 800				throw-error [
 801					"arguments must be of same size for:" name
 802					"^/*** left:" join list/1/1 #"," "right:" list/2/1
 803				]
 804			]
 805			clear list
 806		]
 807		
 808		check-variable-arity?: func [spec [block!]][
 809			all [
 810				block? spec/1
 811				any [
 812					all [find spec/1 'variadic 'variadic]
 813					all [find spec/1 'typed 'typed]
 814				]
 815			]
 816		]
 817		
 818		check-body: func [body][
 819			case/all [
 820				not block? :body [throw-error "expected a block of code"]
 821				empty? body  	 [throw-error "expected a non-empty block of code"]
 822			]
 823		]
 824		
 825		fetch-into: func [code [block! paren!] body [block!] /local save-pc][		;-- compile sub-block
 826			save-pc: pc
 827			pc: code
 828			do body
 829			next pc: save-pc
 830		]
 831		
 832		fetch-func: func [name /local specs type cc][
 833			name: to word! name
 834			check-func-name name
 835			check-specs name specs: pc/2
 836			type: 'native
 837			cc:   'stdcall								;-- default calling convention
 838			
 839			if all [
 840				not empty? specs
 841				block? specs/1
 842			][
 843				case [
 844					find specs/1 'infix [
 845						if 2 <> get-arity specs [
 846							throw-error [
 847								"infix function requires 2 arguments, found"
 848								get-arity specs "for" name
 849							]
 850						]
 851						type: 'infix
 852					]
 853					find specs/1 'cdecl   [cc: 'cdecl]
 854					find specs/1 'stdcall [cc: 'stdcall]	;-- get ready when fastcall will be the default cc
 855				]
 856			]
 857			add-function type reduce [name none specs] cc
 858			emitter/add-native name
 859			repend natives [name specs pc/3 script]
 860			pc: skip pc 3
 861		]
 862		
 863		reduce-logic-tests: func [expr /local test value][
 864			test: [logic? expr/2 logic? expr/3]
 865			
 866			if all [
 867				block? expr
 868				find [= <>] expr/1
 869				any test
 870			][
 871				expr: either all test [
 872					do expr								;-- let REBOL reduce the expression
 873				][
 874					expr: copy expr
 875					if any [
 876						all [expr/1 = '= not all [expr/2 expr/3]]
 877						all [expr/1 = first [<>] any [expr/2 = true expr/3 = true]]
 878					][
 879						insert expr 'not
 880					]
 881					remove-each v expr [any [find [= <>] v logic? v]]
 882					if any [
 883						all [word? expr/1 get-variable-spec expr/1]
 884						paren? expr/1
 885						block? expr/1
 886						object? expr/1
 887					][
 888						expr: expr/1					;-- remove outer brackets if variable
 889					]
 890					expr
 891				]
 892			]
 893			expr
 894		]
 895		
 896		process-import: func [defs [block!] /local lib list cc name specs spec id reloc][
 897			unless block? defs [throw-error "#import expects a block! as argument"]
 898			unless parse defs [
 899				some [
 900					pos: set lib string! (
 901						unless list: select imports lib [
 902							repend imports [lib list: make block! 10]
 903						]
 904					)
 905					pos: set cc ['cdecl | 'stdcall]		;-- calling convention	
 906					pos: into [
 907						some [
 908							specs:						;-- new function mapping marker
 909							pos: set name set-word! (check-func-name name: to word! name)
 910							pos: set id   string!   (repend list [id reloc: make block! 1])
 911							pos: set spec block!    (
 912								check-specs/extend name spec
 913								add-function 'import specs cc
 914								emitter/import-function name reloc
 915							)
 916						]
 917					]
 918				]
 919			][
 920				throw-error ["invalid import specification at:" pos]
 921			]		
 922		]
 923		
 924		process-syscall: func [defs [block!] /local name id spec][
 925			unless block? defs [throw-error "#syscall expects a block! as argument"]
 926			unless parse defs [
 927				some [
 928					pos: set name set-word! (check-func-name name: to word! name)
 929					pos: set id   integer!
 930					pos: set spec block!    (
 931						check-specs/extend name spec
 932						add-function 'syscall reduce [name none spec] 'syscall
 933						append last functions id		;-- extend definition with syscode
 934					)
 935				]
 936			][
 937				throw-error ["invalid syscall specification at:" pos]
 938			]
 939		]
 940		
 941		comp-chunked: func [body [block!]][
 942			emitter/chunks/start
 943			do body
 944			emitter/chunks/stop
 945		]
 946
 947		comp-directive: has [body][
 948			switch/default pc/1 [
 949				#import  [process-import  pc/2  pc: skip pc 2]
 950				#syscall [process-syscall pc/2	pc: skip pc 2]
 951				#script	 [								;-- internal compiler directive
 952					compiler/script: secure-clean-path pc/2	;-- set the origin of following code
 953					pc: skip pc 2
 954				]
 955			][
 956				throw-error ["unknown directive" pc/1]
 957			]
 958		]
 959		
 960		comp-declare: has [rule value pos offset][
 961			unless find [set-word! set-path!] type?/word pc/-1 [
 962				throw-error "assignment expected before literal declaration"
 963			]
 964			value: to paren! reduce either find [pointer! struct!] pc/2 [
 965				rule: get pick [struct-syntax pointer-syntax] pc/2 = 'struct!
 966				unless catch [parse pos: pc/3 rule][
 967					throw-error ["invalid literal syntax:" mold pos]
 968				]
 969				offset: 3
 970				[pc/2 pc/3]
 971			][
 972				unless all [word? pc/2 resolve-aliased reduce [pc/2]][
 973					throw-error [
 974						"declaring literal for type" pc/2 "not supported"
 975					]
 976				]
 977				offset: 2
 978				['struct! pc/2]
 979			]
 980			pc: skip pc offset
 981			value
 982		]
 983		
 984		comp-null: does [
 985			pc: next pc
 986			make action-class [action: 'null type: [any-pointer!] data: 0]
 987		]
 988		
 989		comp-as: has [ctype ptr? expr][
 990			ctype: pc/2
 991			if ptr?: find [pointer! struct!] ctype [ctype: reduce [pc/2 pc/3]]
 992			
 993			unless any [
 994				parse blockify ctype type-syntax
 995				find aliased-types ctype
 996			][
 997				throw-error ["invalid target type casting:" ctype]
 998			]
 999			pc: skip pc pick [3 2] to logic! ptr?
1000			expr: fetch-expression
1001
1002			if all [object? expr expr/action = 'null][
1003				pc: back pc
1004				throw-error "type casting on null value is not allowed"
1005			]
1006			make action-class [
1007				action: 'type-cast
1008				type: blockify ctype
1009				data: expr
1010			]
1011		]
1012		
1013		comp-assert: has [expr line][
1014			either job/debug? [
1015				line: calc-line
1016				pc: next pc
1017				expr: fetch-expression/final
1018				check-conditional 'assert expr			;-- verify conditional expression
1019				expr: process-logic-encoding expr yes
1020
1021				insert/only pc next next compose [
1022					2 (to pair! reduce [line 1])			;-- hidden line offset header
1023					***-on-quit 98 as integer! system/pc
1024				]
1025				set [unused chunk] comp-block-chunked		;-- compile TRUE block
1026				emitter/set-signed-state expr				;-- properly set signed/unsigned state
1027				emitter/branch/over/on chunk reduce [expr/1] ;-- branch over if expr is true
1028				emitter/merge chunk
1029				last-type: none-type
1030				<last>
1031			][
1032				pc: next pc
1033				fetch-expression							;-- consume next expression
1034				none
1035			]
1036		]
1037		
1038		comp-alias: has [name][
1039			unless set-word? pc/-1 [
1040				throw-error "assignment expected for ALIAS"
1041			]
1042			unless pc/2 = 'struct! [
1043				throw-error "ALIAS only works on struct! type"
1044			]
1045			if find aliased-types name: to word! pc/-1 [
1046				pc: back pc
1047				throw-error reform [
1048					"alias name already defined as:"
1049					mold aliased-types/:name
1050				]
1051			]
1052			if base-type? name [
1053				pc: back pc
1054				throw-error "a base type name cannot be defined as an alias name"
1055			]
1056			repend aliased-types [name reduce [pc/2 pc/3]]
1057			unless catch [parse pos: pc/3 struct-syntax][
1058				throw-error ["invalid struct syntax:" mold pos]
1059			]
1060			pc: skip pc 3
1061			none
1062		]
1063		
1064		comp-size?: has [type expr][
1065			pc: next pc
1066			unless all [
1067				word? expr: pc/1
1068				type: any [
1069					all [base-type? expr expr]
1070					select aliased-types expr
1071				]
1072				pc: next pc
1073			][
1074				expr: fetch-expression/final	
1075				type: resolve-expr-type expr
1076			]
1077			emitter/get-size type expr
1078		]
1079		
1080		comp-exit: func [/value /local expr type ret][
1081			unless locals [
1082				throw-error [pc/1 "is not allowed outside of a function"]
1083			]
1084			pc: next pc
1085			ret: select locals return-def
1086			
1087			either value [				
1088				unless ret [							;-- check if return: declared
1089					throw-error [
1090						"RETURN keyword used without return: declaration in"
1091						func-name
1092					]
1093				]
1094				expr: fetch-expression/final/keep		;-- compile expression to return
1095				type: check-expected-type/ret func-name expr ret
1096				ret: either type [last-type: type <last>][none]
1097			][
1098				if ret [
1099					throw-error [
1100						"EXIT keyword is not compatible with declaring a return value"
1101					]
1102				]
1103			]
1104			emitter/target/emit-exit
1105			ret
1106		]
1107
1108		comp-block-chunked: func [/only /test name [word!] /local expr][
1109			emitter/chunks/start
1110			expr: either only [
1111				fetch-expression/final					;-- returns first expression
1112			][
1113				comp-block/final						;-- returns last expression
1114			]
1115			if test [
1116				check-conditional name expr				;-- verify conditional expression
1117				expr: process-logic-encoding expr no
1118			]
1119			reduce [
1120				expr 
1121				emitter/chunks/stop						;-- returns a chunk block!
1122			]
1123		]
1124		
1125		process-logic-encoding: func [expr invert? [logic!]][	;-- preprocess logic values
1126			case [
1127				logic? expr [ [#[true]] ]
1128				find [word! path!] type?/word expr  [
1129					emitter/target/emit-operation '= [<last> 0]
1130					reduce [not invert?]
1131				]
1132				object? expr [
1133					expr: cast expr
1134					unless find [word! path!] type?/word any [
1135						all [block? expr expr/1] expr 
1136					][
1137						emitter/target/emit-operation '= [<last> 0]
1138					]
1139					process-logic-encoding expr invert?
1140				]
1141				block? expr [
1142					case [
1143						find comparison-op expr/1 [expr]
1144						'else [process-logic-encoding expr/1 invert?]
1145					]
1146				]
1147				tag? expr [
1148					either last-type/1 = 'logic! [
1149						emitter/target/emit-operation '= [<last> 0]
1150						reduce [not invert?]
1151					][expr] 
1152				]
1153				'else [expr]
1154			]
1155		]
1156		
1157		comp-if: has [expr unused chunk][		
1158			pc: next pc
1159			expr: fetch-expression/final				;-- compile expression
1160			check-conditional 'if expr					;-- verify conditional expression
1161			expr: process-logic-encoding expr no
1162			check-body pc/1								;-- check TRUE block
1163	
1164			set [unused chunk] comp-block-chunked		;-- compile TRUE block
1165			emitter/set-signed-state expr				;-- properly set signed/unsigned state
1166			emitter/branch/over/on chunk expr/1			;-- insert IF branching			
1167			emitter/merge chunk
1168			last-type: none-type
1169			<last>
1170		]
1171		
1172		comp-either: has [expr e-true e-false c-true c-false offset t-true t-false][
1173			pc: next pc
1174			expr: fetch-expression/final				;-- compile expression
1175			check-conditional 'either expr				;-- verify conditional expression
1176			expr: process-logic-encoding expr no
1177			check-body pc/1								;-- check TRUE block
1178			check-body pc/2								;-- check FALSE block
1179			
1180			set [e-true c-true]   comp-block-chunked	;-- compile TRUE block		
1181			set [e-false c-false] comp-block-chunked	;-- compile FALSE block
1182		
1183			offset: emitter/branch/over c-false
1184			emitter/set-signed-state expr				;-- properly set signed/unsigned state	
1185			emitter/branch/over/adjust/on c-true negate offset expr/1	;-- skip over JMP-exit
1186			emitter/merge emitter/chunks/join c-true c-false
1187
1188			t-true:  resolve-expr-type/quiet e-true
1189			t-false: resolve-expr-type/quiet e-false
1190
1191			last-type: either all [
1192				t-true/1 t-false/1
1193				t-true:  resolve-aliased t-true			;-- alias resolution is safe here
1194				t-false: resolve-aliased t-false
1195				equal-types? t-true/1 t-false/1
1196			][t-true][none-type]						;-- allow nesting if both blocks return same type		
1197			<last>
1198		]
1199		
1200		comp-case: has [cases list test body op bodies offset types][
1201			pc: next pc
1202			check-body cases: pc/1
1203			list:  make block! 8
1204			types: make block! 8
1205			
1206			until [										;-- collect and pre-compile all cases
1207				fetch-into cases [						;-- compile case test
1208					append/only list comp-block-chunked/only/test 'case
1209					cases: pc							;-- set cursor after the expression
1210				]
1211				check-body cases/1
1212				fetch-into cases [						;-- compile case body
1213					append/only list body: comp-block-chunked
1214					append/only types resolve-expr-type/quiet body/1
1215				]
1216				tail? cases: next cases
1217			]
1218			
1219			bodies: comp-chunked [raise-runtime-error 100] ;-- raise a runtime error if unmatched value
1220			
1221			list: tail list								;-- point to last case test
1222			until [										;-- left join all cases in reverse order			
1223				list: skip list -2
1224				set [test body] list					;-- retrieve case-test and case-body chunks
1225
1226				emitter/set-signed-state test/1			;-- properly set signed/unsigned state
1227				offset: negate emitter/branch/over bodies		;-- insert case exit branching
1228				emitter/branch/over/on/adjust body/2 test/1/1 offset	;-- insert case test branching
1229				
1230				body: emitter/chunks/join test/2 body/2	;-- join case test with case body
1231				bodies: emitter/chunks/join body bodies	;-- left join case with other cases
1232				head? list		
1233			]	
1234			emitter/merge bodies						;-- commit all to main code buffer
1235			pc: next pc
1236			last-type: equal-types-list? types			;-- test if usage in expression allowed
1237			<last>
1238		]
1239		
1240		comp-switch: has [expr save-type spec value values body bodies list types default][
1241			pc: next pc
1242			expr: fetch-expression/final				;-- compile argument
1243			if any [none? expr last-type = none-type][
1244				throw-error "SWITCH argument has no return value"
1245			]
1246			save-type: last-type			
1247			check-body spec: pc/1
1248			foreach w [values list types][set w make block! 8]
1249			
1250			;-- check syntax and store parts in different lists
1251			unless parse spec [
1252				some [
1253					pos: copy value some [integer! | char!] 
1254					(repend values [value none])		;-- [value body-offset ...]
1255					pos: block! (
1256						fetch-into pos [				;-- compile action body
1257							body: comp-block-chunked
1258							append/only list body/2		
1259							append/only types resolve-expr-type/quiet body/1
1260						]
1261					)
1262				]
1263				opt [
1264					'default pos: block! (
1265						fetch-into pos [				;-- compile default body
1266							default: comp-block-chunked
1267							append/only types resolve-expr-type/quiet default/1
1268						]
1269					)
1270				]
1271			][
1272				throw-error ["wrong syntax in SWITCH block at:" copy/part pos 4]
1273			]
1274
1275			;-- assemble all actions together, with exit at end for each one
1276			bodies: emitter/chunks/empty
1277			list: tail list								;-- point to last action
1278			until [										;-- left join all actions in reverse order		
1279				body: first list: back list
1280				unless empty? bodies/1 [
1281					emitter/branch/over bodies			;-- insert case exit branching
1282				]
1283				bodies: emitter/chunks/join body bodies	;-- left join action with other actions		
1284				change at values 2 * index? list length? bodies/1
1285				head? list		
1286			]
1287			
1288			;-- insert default clause or jump to runtime error
1289			either default [
1290				emitter/branch/over bodies          	;-- insert default exit branching
1291				bodies: emitter/chunks/join default/2 bodies ;-- insert default action
1292			][
1293				body: comp-chunked [raise-runtime-error 101] ;-- raise a runtime error if unmatched value
1294				bodies: emitter/chunks/join body bodies
1295			]
1296
1297			;-- construct tests + branching and insert them at head
1298			last-type: save-type
1299			emitter/set-signed-state expr				;-- properly set signed/unsigned state
1300			values: tail values
1301			until [
1302				values: skip values -2
1303				foreach v values/1 [					;-- process multiple values per action
1304					body: comp-chunked [
1305						emitter/target/emit-operation '= reduce [<last> v]
1306					]
1307					emitter/branch/over/on/adjust bodies [=] values/2	;-- insert action branching			
1308					bodies: emitter/chunks/join body bodies
1309				]
1310				head? values
1311			]
1312			emitter/merge bodies						;-- commit all to main code buffer	
1313			
1314			pc: next pc
1315			last-type: equal-types-list? types			;-- test if usage in expression allowed
1316			<last>
1317		]
1318		
1319		comp-until: has [expr chunk][
1320			pc: next pc
1321			check-body pc/1
1322			set [expr chunk] comp-block-chunked/test 'until
1323			emitter/branch/back/on chunk expr/1	
1324			emitter/merge chunk	
1325			last-type: none-type
1326			<last>
1327		]
1328		
1329		comp-while: has [expr unused cond body offset bodies][
1330			pc: next pc
1331			check-body pc/1								;-- check condition block
1332			check-body pc/2								;-- check body block
1333			
1334			set [expr cond]   comp-block-chunked/test 'while	;-- Condition block
1335			set [unused body] comp-block-chunked		;-- Body block
1336			
1337			if logic? expr/1 [expr: [<>]]				;-- re-encode test op
1338			offset: emitter/branch/over body			;-- Jump to condition
1339			bodies: emitter/chunks/join body cond
1340			emitter/set-signed-state expr				;-- properly set signed/unsigned state
1341			emitter/branch/back/on/adjust bodies reduce [expr/1] offset ;-- Test condition, exit if FALSE
1342			emitter/merge bodies
1343			last-type: none-type
1344			<last>
1345		]
1346		
1347		comp-expression-list: func [/_all /local list offset bodies op][
1348			pc: next pc
1349			check-body pc/1								;-- check body block
1350			
1351			list: make block! 8
1352			pc: fetch-into pc/1 [
1353				while [not tail? pc][					;-- comp all expressions in chunks
1354					append/only list comp-block-chunked/only/test pick [all any] to logic! _all
1355				]
1356			]
1357			list: back tail list
1358			set [offset bodies] emitter/chunks/make-boolean			;-- emit ending FALSE/TRUE block
1359			if _all [emitter/branch/over/adjust bodies offset/1]	;-- conclude by a branch on TRUE
1360			offset: pick offset not _all				;-- branch to TRUE or FALSE 
1361			
1362			until [										;-- left join all expr in reverse order			
1363				op: either logic? list/1/1/1 [first [<>]][list/1/1/1]
1364				unless _all [op: reduce [op]]			;-- do not invert the test if ANY
1365				emitter/set-signed-state list/1/1		;-- properly set signed/unsigned state
1366				emitter/branch/over/on/adjust bodies op offset		;-- first emit branch				
1367				bodies: emitter/chunks/join list/1/2 bodies			;-- then left join expr
1368				also head? list	list: back list
1369			]	
1370			emitter/merge bodies
1371			last-type: [logic!]
1372			<last>
1373		]
1374		
1375		comp-assignment: has [name value n][
1376			name: pc/1
1377			pc: next pc
1378			if set-word? name [
1379				check-keywords n: to word! name			;-- forbid keywords redefinition
1380				if get-word? pc/1 [
1381					throw-error "storing a function! requires a type casting"
1382				]
1383				unless all [locals find locals n][
1384					check-func-name/only n				;-- avoid clashing with an existing function name
1385				]
1386			]
1387			either none? value: fetch-expression [		;-- explicitly test for none!
1388				none
1389			][				
1390				new-line/all reduce [name value] no
1391			]
1392		]
1393		
1394		comp-path: has [path value][
1395			path: pc/1
1396			comp-word/path path/1						;-- check if root word is defined
1397			unless value: system-reflexion? path [
1398				last-type: resolve-path-type path
1399			]
1400			any [value path]
1401		]
1402		
1403		comp-get-word: has [spec][
1404			unless spec: select functions to word! pc/1 [
1405				throw-error ["function" to word! pc/1 "not defined"] 
1406			]
1407			unless spec/2 = 'native [
1408				throw-error "get-word syntax only reserved for native functions for now"
1409			]
1410			unless spec/5 = 'callback [append spec 'callback]
1411			also pc/1 pc: next pc
1412		]
1413	
1414		comp-word: func [/path symbol [word!] /local entry args n name expr attribute fetch][
1415			name: any [symbol pc/1]
1416			case [
1417				entry: select keywords name [do entry]	;-- it's a reserved word
1418				
1419				any [
1420					all [locals find locals name]
1421					find globals name
1422				][										;-- it's a variable			
1423					if not-initialized? name [
1424						throw-error ["local variable" name "used before being initialized!"]
1425					]
1426					last-type: resolve-type name				
1427					also name pc: next pc
1428				]
1429				all [
1430					not path
1431					entry: find functions name 
1432				][
1433					pc: next pc							;-- it's a function
1434					either attribute: check-variable-arity? entry/2/4 [
1435						fetch: [
1436							append/only args fetch-expression
1437							if attribute = 'typed [
1438								append args get-type-id last args
1439							]							
1440						]
1441						args: make block! 1
1442						either block? pc/1 [
1443							fetch-into pc/1 [until [do fetch tail? pc]]
1444							pc: next pc					;-- jump over arguments block
1445						][
1446							do fetch
1447						]
1448						reduce [name to-issue attribute args]
1449					][									;-- fixed arity case
1450						args: make block! n: entry/2/1
1451						loop n [append/only args fetch-expression]	;-- fetch n arguments
1452						head insert args name
1453					]
1454				]
1455				'else [throw-error ["undefined symbol:" mold name]]
1456			]
1457		]
1458		
1459		cast-null: func [variable [set-word! set-path!] /local casting][
1460			unless all [
1461				attempt [
1462					casting: get-type any [
1463						all [set-word? variable to word! variable]
1464						to path! variable
1465					]
1466				]
1467				any-pointer? casting
1468			][
1469				backtrack variable
1470				throw-error "Invalid null assignment"
1471			]			
1472			casting
1473		]
1474		
1475		order-args: func [name [word!] args [block!]][
1476			if any [
1477				all [
1478					find [import native infix] functions/:name/2
1479					find [stdcall cdecl] functions/:name/3
1480				]
1481				all [
1482					functions/:name/2 = 'syscall
1483					job/syscall = 'BSD
1484				]
1485				all [
1486					functions/:name/2 = 'syscall		
1487					job/target = 'ARM					;-- odd, but required for Linux/ARM syscalls
1488					job/syscall = 'Linux
1489				]
1490			][		
1491				reverse args
1492			]
1493		]
1494
1495		comp-call: func [
1496			name [word!] args [block!] /sub
1497			/local list type res import? left right dup var-arity? saved? arg
1498		][
1499			list: either issue? args/1 [				;-- bypass type-checking for variable arity calls
1500				args/2
1501			][
1502				check-arguments-type name args
1503				args
1504			]
1505			order-args name list						;-- reorder argument according to cconv
1506
1507			import?: functions/:name/2 = 'import		;@@ syscalls don't seem to need special alignment??
1508			if import? [emitter/target/emit-stack-align-prolog length? args]
1509
1510			type: functions/:name/2
1511			either type <> 'op [					
1512				forall list [							;-- push function's arguments on stack
1513					if block? unbox list/1 [comp-expression list/1 yes]	;-- nested call
1514					if type <> 'inline [
1515						emitter/target/emit-argument list/1 type ;-- let target define how arguments are passed
1516					]
1517				]
1518			][											;-- nested calls as op argument require special handling
1519				if block? unbox list/1 [comp-expression list/1 yes]	;-- nested call
1520				left:  unbox list/1
1521				right: unbox list/2
1522				if saved?: all [block? left any [block? right path? right]][
1523					emitter/target/emit-save-last		;-- optionally save left argument result
1524				]
1525				if block? unbox list/2 [comp-expression list/2 yes]	;-- nested call
1526				if saved? [emitter/target/emit-restore-last]			
1527			]
1528			res: emitter/target/emit-call name args to logic! sub
1529
1530			either res [
1531				last-type: res
1532			][
1533				set-last-type functions/:name/4			;-- catch nested calls return type
1534			]
1535			if import? [emitter/target/emit-stack-align-epilog length? args]
1536			res
1537		]
1538				
1539		comp-path-assign: func [
1540			set-path [set-path!] expr casted [block! none!]
1541			/local type new value
1542		][
1543			unless get-variable-spec set-path/1 [
1544				backtrack set-path
1545				throw-error ["unknown path root variable:" set-path/1]
1546			]
1547			type: resolve-path-type set-path			;-- check path validity
1548			new: resolve-aliased get-type expr		
1549
1550			if type <> any [casted new][
1551				backtrack set-path
1552				throw-error [
1553					"type mismatch on setting path:" to path! set-path
1554					"^/*** expected:" mold type
1555					"^/*** found:" mold any [casted new]
1556				]
1557			]
1558			value: unbox expr
1559			if any [block? value path? value][value: <last>]
1560
1561			emitter/access-path set-path value
1562		]
1563		
1564		comp-variable-assign: func [
1565			set-word [set-word!] expr casted [block! none!]
1566			/local name type new value
1567		][
1568			name: to word! set-word		
1569			if find aliased-types name [
1570				backtrack set-word
1571				throw-error "name already used for as an alias definition"
1572			]
1573			if not-initialized? name [
1574				init-local name expr casted				;-- mark as initialized and infer type if required
1575			]		
1576			either type: get-variable-spec name [ 		;-- test if known variable (local or global)		
1577				type: resolve-aliased type		
1578				new: resolve-aliased get-type expr			
1579				
1580				if type <> any [casted new][
1581					backtrack set-word
1582					throw-error [
1583						"attempt to change type of variable:" name
1584						"^/*** from:" mold type
1585						"^/***   to:" mold any [casted new]
1586					]
1587				]
1588			][
1589				unless zero? block-level [
1590					backtrack set-word
1591					throw-error "variable has to be initialized at root level"
1592				]
1593				type: add-symbol name unbox expr casted  ;-- if unknown add it to global context
1594			]
1595			if none? type/1 [
1596				backtrack set-word
1597				throw-error ["unable to determine a type for:" name]
1598			]
1599			value: unbox expr
1600			if any [block? value path? value][value: <last>]
1601			
1602			emitter/store name value type
1603		]
1604		
1605		comp-expression: func [expr keep? [logic!] /local variable boxed casting new? type][	
1606			;-- preprocessing expression
1607			if all [block? expr find [set-word! set-path!] type?/word expr/1][
1608				variable: expr/1
1609				expr: expr/2							;-- switch to assigned expression
1610				if set-word? variable [
1611					new?: not exists-variable? variable
1612				]
1613			]			
1614			if object? expr [							;-- unbox type-casting object
1615				if all [variable expr/action = 'null][
1616					casting: cast-null variable
1617				]
1618				boxed: expr
1619				expr: cast expr
1620			]
1621
1622			;-- emitting expression code
1623			either block? expr [
1624				type: comp-call expr/1 next expr 		;-- function call case (recursive)
1625				if type [last-type: type]				;-- set last-type if not already set
1626			][
1627				unless any [
1628					all [new? literal? unbox expr]		;-- if new variable, value will be store in data segment
1629					all [set-path? variable literal? unbox expr] ;-- value loaded at lower level
1630					tag? unbox expr
1631				][
1632					emitter/target/emit-load expr		;-- emit code for single value
1633				]
1634				last-type: resolve-expr-type expr
1635			]
1636			
1637			;-- postprocessing result
1638			if boxed [
1639				emitter/target/emit-casting boxed no 	;-- insert runtime type casting if required
1640				last-type: boxed/type
1641			]
1642			if all [
1643				any [keep? variable]					;-- if result needs to be stored
1644				block? expr								;-- and if expr is a function call
1645				last-type/1 = 'logic!					;-- which return type is logic!
1646			][
1647				emitter/logic-to-integer expr/1			;-- runtime logic! conversion before storing
1648			]
1649			
1650			;-- storing result if assignement required
1651			if variable [
1652				if all [boxed not casting][
1653					casting: resolve-aliased boxed/type
1654				]
1655				switch type?/word variable [
1656					set-word! [comp-variable-assign variable expr casting]
1657					set-path! [comp-path-assign		variable expr casting]
1658				]
1659			]
1660		]
1661		
1662		infix?: func [pos [block! paren!] /local specs][
1663			all [
1664				not tail? pos
1665				word? pos/1
1666				specs: select functions pos/1
1667				find [op infix] specs/2
1668			]
1669		]
1670		
1671		check-infix-operators: has [pos][
1672			if infix? pc [exit]							;-- infix op already processed,
1673														;-- or used in prefix mode.
1674			if infix? next pc [
1675				either find [set-word! set-path! struct!] type?/word pc/1 [
1676					throw-error "can't use infix operator here"
1677				][
1678					pos: 0								;-- relative index of next infix op
1679					until [								;-- search for all dependent infix op
1680						pos: pos + 2					;-- target next infix possible position
1681						insert pc pc/:pos				;-- transform to prefix notation
1682						remove at pc pos + 1
1683						not infix? at pc pos + 2		;-- exit when no more infix op found
1684					]
1685				]
1686			]
1687		]
1688		
1689		fetch-expression: func [/final /keep /local expr pass][
1690			check-infix-operators
1691			if verbose >= 4 [print ["<<<" mold pc/1]]
1692			pass: [also pc/1 pc: next pc]
1693			
1694			if tail? pc [
1695				pc: back pc
1696				throw-error "missing argument"
1697			]
1698			if job/debug? [store-dbg-lines]
1699			
1700			expr: switch/default type?/word pc/1 […