/red-system/compiler.r
R | 2016 lines | 1833 code | 180 blank | 3 comment | 172 complexity | a2ec5dfbd4d730d87b0fd2e6b135bfd4 MD5 | raw file
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 […
Large files files are truncated, but you can click here to view the full file