gforth/cross.fs - view

File: [gforth] / gforth / cross.fs
Revision 1.166: download - view: text, annotated - select for diffs
Mon Dec 31 18:40:23 2007 UTC (16 years, 3 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD

updated copyright notices for GPL v3

1: \ CROSS.FS The Cross-Compiler 06oct92py 2: \ Idea and implementation: Bernd Paysan (py) 3: 4: \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007 Free Software Foundation, Inc. 5: 6: \ This file is part of Gforth. 7: 8: \ Gforth is free software; you can redistribute it and/or 9: \ modify it under the terms of the GNU General Public License 10: \ as published by the Free Software Foundation, either version 3 11: \ of the License, or (at your option) any later version. 12: 13: \ This program is distributed in the hope that it will be useful, 14: \ but WITHOUT ANY WARRANTY; without even the implied warranty of 15: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16: \ GNU General Public License for more details. 17: 18: \ You should have received a copy of the GNU General Public License 19: \ along with this program. If not, see http://www.gnu.org/licenses/. 20: 21: 0 22: [IF] 23: 24: ToDo: 25: - Crossdoc destination ./doc/crossdoc.fd makes no sense when 26: cross.fs is used seperately. jaw 27: - Do we need this char translation with >address and in branchoffset? 28: (>body also affected) jaw 29: 30: [THEN] 31: 32: s" compat/strcomp.fs" included 33: 34: hex 35: 36: \ debugging for compiling 37: 38: \ print stack at each colon definition 39: \ : : save-input cr bl word count type restore-input throw .s : ; 40: 41: \ print stack at each created word 42: \ : create save-input cr bl word count type restore-input throw .s create ; 43: 44: 45: \ \ ------------- Setup Vocabularies 46: 47: \ Remark: Vocabulary is not ANS, but it should work... 48: 49: Vocabulary Cross 50: Vocabulary Target 51: Vocabulary Ghosts 52: Vocabulary Minimal 53: only Forth also Target also also 54: definitions Forth 55: 56: : T previous Ghosts also Target ; immediate 57: : G Ghosts ; immediate 58: : H previous Forth also Cross ; immediate 59: 60: forth definitions 61: 62: : T previous Ghosts also Target ; immediate 63: : G Ghosts ; immediate 64: 65: 66: : >cross also Cross definitions previous ; 67: : >target also Target definitions previous ; 68: : >minimal also Minimal definitions previous ; 69: 70: H 71: 72: >CROSS 73: 74: \ Test against this definitions to find out whether we are cross-compiling 75: \ may be usefull for assemblers 76: 0 Constant gforth-cross-indicator 77: 78: \ find out whether we are compiling with gforth 79: 80: : defined? bl word find nip ; 81: defined? emit-file defined? toupper and \ drop 0 82: [IF] 83: \ use this in a gforth system 84: : \GFORTH ; immediate 85: : \ANSI postpone \ ; immediate 86: [ELSE] 87: : \GFORTH postpone \ ; immediate 88: : \ANSI ; immediate 89: [THEN] 90: 91: \ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate 92: \ANSI : [IFDEF] defined? postpone [IF] ; immediate 93: 0 \ANSI drop 1 94: [IF] 95: : \G postpone \ ; immediate 96: : rdrop postpone r> postpone drop ; immediate 97: : name bl word count ; 98: : bounds over + swap ; 99: : scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ; 100: : linked here over @ , swap ! ; 101: : alias create , DOES> @ EXECUTE ; 102: : defer ['] noop alias ; 103: : is state @ 104: IF ' >body postpone literal postpone ! 105: ELSE ' >body ! THEN ; immediate 106: : 0>= 0< 0= ; 107: : d<> rot <> -rot <> or ; 108: : toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ; 109: Variable ebuf 110: : emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ; 111: 0a Constant #lf 112: 0d Constant #cr 113: 114: [IFUNDEF] Warnings Variable Warnings [THEN] 115: 116: \ \ Number parsing 23feb93py 117: 118: \ number? number 23feb93py 119: 120: Variable dpl 121: 122: hex 123: Create bases 10 , 2 , A , 100 , 124: \ 16 2 10 character 125: 126: \ !! protect BASE saving wrapper against exceptions 127: : getbase ( addr u -- addr' u' ) 128: over c@ [char] $ - dup 4 u< 129: IF 130: cells bases + @ base ! 1 /string 131: ELSE 132: drop 133: THEN ; 134: 135: : sign? ( addr u -- addr u flag ) 136: over c@ [char] - = dup >r 137: IF 138: 1 /string 139: THEN 140: r> ; 141: 142: : s>unumber? ( addr u -- ud flag ) 143: over [char] ' = 144: IF \ a ' alone is rather unusual :-) 145: drop char+ c@ 0 true EXIT 146: THEN 147: base @ >r dpl on getbase 148: 0. 2swap 149: BEGIN ( d addr len ) 150: dup >r >number dup 151: WHILE \ there are characters left 152: dup r> - 153: WHILE \ the last >number parsed something 154: dup 1- dpl ! over c@ [char] . = 155: WHILE \ the current char is '.' 156: 1 /string 157: REPEAT THEN \ there are unparseable characters left 158: 2drop false 159: ELSE 160: rdrop 2drop true 161: THEN 162: r> base ! ; 163: 164: \ ouch, this is complicated; there must be a simpler way - anton 165: : s>number? ( addr len -- d f ) 166: \ converts string addr len into d, flag indicates success 167: sign? >r 168: s>unumber? 169: 0= IF 170: rdrop false 171: ELSE \ no characters left, all ok 172: r> 173: IF 174: dnegate 175: THEN 176: true 177: THEN ; 178: 179: : s>number ( addr len -- d ) 180: \ don't use this, there is no way to tell success 181: s>number? drop ; 182: 183: : snumber? ( c-addr u -- 0 / n -1 / d 0> ) 184: s>number? 0= 185: IF 186: 2drop false EXIT 187: THEN 188: dpl @ dup 0< IF 189: nip 190: ELSE 191: 1+ 192: THEN ; 193: 194: : number? ( string -- string 0 / n -1 / d 0> ) 195: dup >r count snumber? dup if 196: rdrop 197: else 198: r> swap 199: then ; 200: 201: : number ( string -- d ) 202: number? ?dup 0= abort" ?" 0< 203: IF 204: s>d 205: THEN ; 206: 207: [THEN] 208: 209: \ this provides assert( and struct stuff 210: \GFORTH [IFUNDEF] assert1( 211: \GFORTH also forth definitions require assert.fs previous 212: \GFORTH [THEN] 213: 214: >CROSS 215: 216: hex \ the defualt base for the cross-compiler is hex !! 217: \ Warnings off 218: 219: \ words that are generaly useful 220: 221: : KB 400 * ; 222: : >wordlist ( vocabulary-xt -- wordlist-struct ) 223: also execute get-order swap >r 1- set-order r> ; 224: 225: : umax 2dup u< IF swap THEN drop ; 226: : umin 2dup u> IF swap THEN drop ; 227: 228: : string, ( c-addr u -- ) 229: \ puts down string as cstring 230: dup c, here swap chars dup allot move ; 231: 232: : ," [char] " parse string, ; 233: 234: : SetValue ( n -- <name> ) 235: \G Same behaviour as "Value" if the <name> is not defined 236: \G Same behaviour as "to" if <name> is defined 237: \G SetValue searches in the current vocabulary 238: save-input bl word >r restore-input throw r> count 239: get-current search-wordlist 240: IF drop >r 241: \ we have to set current to be topmost context wordlist 242: get-order get-order get-current swap 1+ set-order 243: r> ['] to execute 244: set-order 245: ELSE Value THEN ; 246: 247: : DefaultValue ( n -- <name> ) 248: \G Same behaviour as "Value" if the <name> is not defined 249: \G DefaultValue searches in the current vocabulary 250: save-input bl word >r restore-input throw r> count 251: get-current search-wordlist 252: IF bl word drop 2drop ELSE Value THEN ; 253: 254: hex 255: 256: \ FIXME delete` 257: \ 1 Constant Cross-Flag \ to check whether assembler compiler plug-ins are 258: \ for cross-compiling 259: \ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!! 260: 261: \ FIXME move down 262: : comment? ( c-addr u -- c-addr u ) 263: 2dup s" (" str= 264: IF postpone ( 265: ELSE 2dup s" \" str= IF postpone \ THEN 266: THEN ; 267: 268: : X ( -- <name> ) 269: \G The next word in the input is a target word. 270: \G Equivalent to T <name> but without permanent 271: \G switch to target dictionary. Used as prefix e.g. for @, !, here etc. 272: bl word count [ ' target >wordlist ] Literal search-wordlist 273: IF state @ IF compile, ELSE execute THEN 274: ELSE -1 ABORT" Cross: access method not supported!" 275: THEN ; immediate 276: 277: \ Begin CROSS COMPILER: 278: 279: \ debugging 280: 281: 0 [IF] 282: 283: This implements debugflags for the cross compiler and the compiled 284: images. It works identical to the has-flags in the environment. 285: The debugflags are defined in a vocabluary. If the word exists and 286: its value is true, the flag is switched on. 287: 288: [THEN] 289: 290: >CROSS 291: 292: Vocabulary debugflags \ debug flags for cross 293: also debugflags get-order over 294: Constant debugflags-wl 295: set-order previous 296: 297: : DebugFlag 298: get-current >r debugflags-wl set-current 299: SetValue 300: r> set-current ; 301: 302: : Debug? ( adr u -- flag ) 303: \G return true if debug flag is defined or switched on 304: debugflags-wl search-wordlist 305: IF EXECUTE 306: ELSE false THEN ; 307: 308: : D? ( <name> -- flag ) 309: \G return true if debug flag is defined or switched on 310: \G while compiling we do not return the current value but 311: bl word count debug? ; 312: 313: : [d?] 314: \G compile the value-xt so the debug flag can be switched 315: \G the flag must exist! 316: bl word count debugflags-wl search-wordlist 317: IF compile, 318: ELSE -1 ABORT" unknown debug flag" 319: \ POSTPONE false 320: THEN ; immediate 321: 322: : symentry ( adr len taddr -- ) 323: \G Produce a symbol table (an optional symbol address 324: \G map) if wanted 325: [ [IFDEF] fd-symbol-table ] 326: base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! 327: s" :" fd-symbol-table write-file throw 328: fd-symbol-table write-line throw 329: [ [ELSE] ] 330: 2drop drop 331: [ [THEN] ] ; 332: 333: 334: \ \ -------------------- source file 335: 336: decimal 337: 338: Variable cross-file-list 339: 0 cross-file-list ! 340: Variable target-file-list 341: 0 target-file-list ! 342: Variable host-file-list 343: 0 host-file-list ! 344: 345: cross-file-list Value file-list 346: 0 Value source-desc 347: 348: \ file loading 349: 350: : >fl-id 1 cells + ; 351: : >fl-name 2 cells + ; 352: 353: Variable filelist 0 filelist ! 354: Create NoFile ," #load-file#" 355: 356: : loadfile ( -- adr ) 357: source-desc ?dup IF >fl-name ELSE NoFile THEN ; 358: 359: : sourcefilename ( -- adr len ) 360: loadfile count ; 361: 362: \ANSI : sourceline# 0 ; 363: 364: \ \ -------------------- path handling from kernel/paths.fs 365: 366: \ paths.fs path file handling 03may97jaw 367: 368: \ -Changing the search-path: 369: \ fpath+ <path> adds a directory to the searchpath 370: \ fpath= <path>|<path> makes complete now searchpath 371: \ seperator is | 372: \ .fpath displays the search path 373: \ remark I: 374: \ a ./ in the beginning of filename is expanded to the directory the 375: \ current file comes from. ./ can also be included in the search-path! 376: \ ~+/ loads from the current working directory 377: 378: \ remark II: 379: \ if there is no sufficient space for the search path increase it! 380: 381: 382: \ -Creating custom paths: 383: 384: \ It is possible to use the search mechanism on yourself. 385: 386: \ Make a buffer for the path: 387: \ create mypath 100 chars , \ maximum length (is checked) 388: \ 0 , \ real len 389: \ 100 chars allot \ space for path 390: \ use the same functions as above with: 391: \ mypath path+ 392: \ mypath path= 393: \ mypath .path 394: 395: \ do a open with the search path: 396: \ open-path-file ( adr len path -- fd adr len ior ) 397: \ the file is opened read-only; if the file is not found an error is generated 398: 399: \ questions to: wilke@jwdt.com 400: 401: [IFUNDEF] +place 402: : +place ( adr len adr ) 403: 2dup >r >r 404: dup c@ char+ + swap move 405: r> r> dup c@ rot + swap c! ; 406: [THEN] 407: 408: [IFUNDEF] place 409: : place ( c-addr1 u c-addr2 ) 410: 2dup c! char+ swap move ; 411: [THEN] 412: 413: \ if we have path handling, use this and the setup of it 414: [IFUNDEF] open-fpath-file 415: 416: create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic 417: sourcepath value fpath 418: 419: : also-path ( adr len path^ -- ) 420: >r 421: \ len check 422: r@ cell+ @ over + r@ @ u> ABORT" path buffer too small!" 423: \ copy into 424: tuck r@ cell+ dup @ cell+ + swap cmove 425: \ make delimiter 426: 0 r@ cell+ dup @ cell+ + 2 pick + c! 1 + r> cell+ +! 427: ; 428: 429: : only-path ( adr len path^ -- ) 430: dup 0 swap cell+ ! also-path ; 431: 432: : path+ ( path-addr "dir" -- ) \ gforth 433: \G Add the directory @var{dir} to the search path @var{path-addr}. 434: name rot also-path ; 435: 436: : fpath+ ( "dir" ) \ gforth 437: \G Add directory @var{dir} to the Forth search path. 438: fpath path+ ; 439: 440: : path= ( path-addr "dir1|dir2|dir3" ) \ gforth 441: \G Make a complete new search path; the path separator is |. 442: name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP 443: rot only-path ; 444: 445: : fpath= ( "dir1|dir2|dir3" ) \ gforth 446: \G Make a complete new Forth search path; the path separator is |. 447: fpath path= ; 448: 449: : path>string cell+ dup cell+ swap @ ; 450: 451: : next-path ( adr len -- adr2 len2 ) 452: 2dup 0 scan 453: dup 0= IF 2drop 0 -rot 0 -rot EXIT THEN 454: >r 1+ -rot r@ 1- -rot 455: r> - ; 456: 457: : previous-path ( path^ -- ) 458: dup path>string 459: BEGIN tuck dup WHILE repeat ; 460: 461: : .path ( path-addr -- ) \ gforth 462: \G Display the contents of the search path @var{path-addr}. 463: path>string 464: BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; 465: 466: : .fpath ( -- ) \ gforth 467: \G Display the contents of the Forth search path. 468: fpath .path ; 469: 470: : absolut-path? ( addr u -- flag ) \ gforth 471: \G A path is absolute if it starts with a / or a ~ (~ expansion), 472: \G or if it is in the form ./*, extended regexp: ^[/~]|./, or if 473: \G it has a colon as second character ("C:..."). Paths simply 474: \G containing a / are not absolute! 475: 2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/.... 476: over c@ [char] / = >r 477: over c@ [char] ~ = >r 478: \ 2dup S" ../" string-prefix? r> or >r \ not catered for in expandtopic 479: S" ./" string-prefix? 480: r> r> r> or or or ; 481: 482: Create ofile 0 c, 255 chars allot 483: Create tfile 0 c, 255 chars allot 484: 485: : pathsep? dup [char] / = swap [char] \ = or ; 486: 487: : need/ ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ; 488: 489: : extractpath ( adr len -- adr len2 ) 490: BEGIN dup WHILE 1- 491: 2dup + c@ pathsep? IF EXIT THEN 492: REPEAT ; 493: 494: : remove~+ ( -- ) 495: ofile count s" ~+/" string-prefix? 496: IF 497: ofile count 3 /string ofile place 498: THEN ; 499: 500: : expandtopic ( -- ) \ stack effect correct? - anton 501: \ expands "./" into an absolute name 502: ofile count s" ./" string-prefix? 503: IF 504: ofile count 1 /string tfile place 505: 0 ofile c! sourcefilename extractpath ofile place 506: ofile c@ IF need/ THEN 507: tfile count over c@ pathsep? IF 1 /string THEN 508: ofile +place 509: THEN ; 510: 511: : compact.. ( adr len -- adr2 len2 ) 512: \ deletes phrases like "xy/.." out of our directory name 2dec97jaw 513: over swap 514: BEGIN dup WHILE 515: dup >r '/ scan 2dup s" /../" string-prefix? 516: IF 517: dup r> - >r 4 /string over r> + 4 - 518: swap 2dup + >r move dup r> over - 519: ELSE 520: rdrop dup 1 min /string 521: THEN 522: REPEAT drop over - ; 523: 524: : reworkdir ( -- ) 525: remove~+ 526: ofile count compact.. 527: nip ofile c! ; 528: 529: : open-ofile ( -- fid ior ) 530: \G opens the file whose name is in ofile 531: expandtopic reworkdir 532: ofile count r/o open-file ; 533: 534: : check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 ) 535: 0 ofile ! >r >r ofile place need/ 536: r> r> ofile +place 537: open-ofile ; 538: 539: : open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth 540: \G Look in path @var{path-addr} for the file specified by @var{addr1 u1}. 541: \G If found, the resulting path and an open file descriptor 542: \G are returned. If the file is not found, @var{ior} is non-zero. 543: >r 544: 2dup absolut-path? 545: IF rdrop 546: ofile place open-ofile 547: dup 0= IF >r ofile count r> THEN EXIT 548: ELSE r> path>string 549: BEGIN next-path dup 550: WHILE 5 pick 5 pick check-path 551: 0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN 552: REPEAT 553: 2drop 2drop 2drop -38 554: THEN ; 555: 556: : open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth 557: \G Look in the Forth search path for the file specified by @var{addr1 u1}. 558: \G If found, the resulting path and an open file descriptor 559: \G are returned. If the file is not found, @var{ior} is non-zero. 560: fpath open-path-file ; 561: 562: fpath= ~+ 563: 564: [THEN] 565: 566: \ \ -------------------- include require 13may99jaw 567: 568: >CROSS 569: 570: : add-included-file ( adr len -- adr ) 571: dup >fl-name char+ allocate throw >r 572: file-list @ r@ ! r@ file-list ! 573: r@ >fl-name place r> ; 574: 575: : included? ( c-addr u -- f ) 576: file-list 577: BEGIN @ dup 578: WHILE >r 2dup r@ >fl-name count str= 579: IF rdrop 2drop true EXIT THEN 580: r> 581: REPEAT 582: 2drop drop false ; 583: 584: false DebugFlag showincludedfiles 585: 586: : included1 ( fd adr u -- ) 587: \ include file adr u / fd 588: \ we don't use fd with include-file, because the forth system 589: \ doesn't know the name of the file to get a nice error report 590: [d?] showincludedfiles 591: IF cr ." Including: " 2dup type ." ..." THEN 592: rot close-file throw 593: source-desc >r 594: add-included-file to source-desc 595: sourcefilename 596: ['] included catch 597: r> to source-desc 598: throw ; 599: 600: : included ( adr len -- ) 601: cross-file-list to file-list 602: open-fpath-file throw 603: included1 ; 604: 605: : required ( adr len -- ) 606: cross-file-list to file-list 607: open-fpath-file throw \ 2dup cr ." R:" type 608: 2dup included? 609: IF 2drop close-file throw 610: ELSE included1 611: THEN ; 612: 613: : include bl word count included ; 614: 615: : require bl word count required ; 616: 617: 0 [IF] 618: 619: also forth definitions previous 620: 621: : included ( adr len -- ) included ; 622: 623: : required ( adr len -- ) required ; 624: 625: : include include ; 626: 627: : require require ; 628: 629: [THEN] 630: 631: >CROSS 632: hex 633: 634: \ \ -------------------- Error Handling 05aug97jaw 635: 636: \ Flags 637: 638: also forth definitions \ these values may be predefined before 639: \ the cross-compiler is loaded 640: 641: false DefaultValue stack-warn \ check on empty stack at any definition 642: false DefaultValue create-forward-warn \ warn on forward declaration of created words 643: 644: previous >CROSS 645: 646: : .dec 647: base @ decimal swap . base ! ; 648: 649: : .sourcepos 650: cr sourcefilename type ." :" 651: sourceline# .dec ; 652: 653: : warnhead 654: \G display error-message head 655: \G perhaps with linenumber and filename 656: .sourcepos ." Warning: " ; 657: 658: : empty? depth IF .sourcepos ." Stack not empty!" THEN ; 659: 660: stack-warn [IF] 661: : defempty? empty? ; 662: [ELSE] 663: : defempty? ; immediate 664: \ : defempty? .sourcepos ; 665: [THEN] 666: 667: \ \ -------------------- Compiler Plug Ins 01aug97jaw 668: 669: >CROSS 670: 671: \ Compiler States 672: 673: Variable comp-state 674: 0 Constant interpreting 675: 1 Constant compiling 676: 2 Constant resolving 677: 3 Constant assembling 678: 679: : compiling? comp-state @ compiling = ; 680: 681: : pi-undefined -1 ABORT" Plugin undefined" ; 682: 683: : Plugin ( -- : pluginname ) 684: Create 685: \ for normal cross-compiling only one action 686: \ exists, this fields are identical. For the instant 687: \ simulation environment we need, two actions for each plugin 688: \ the target one and the one that generates the simulation code 689: ['] pi-undefined , \ action 690: ['] pi-undefined , \ target plugin action 691: 8765 , \ plugin magic 692: DOES> perform ; 693: 694: Plugin DummyPlugin 695: 696: : 'PI ( -- addr : pluginname ) 697: ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ; 698: 699: : plugin-of ( xt -- : pluginname ) 700: dup 'PI 2! ; 701: 702: : action-of ( xt -- : plunginname ) 703: 'PI cell+ ! ; 704: 705: : TPA ( -- : plugin ) 706: \ target plugin action 707: \ executes current target action of plugin 708: 'PI cell+ POSTPONE literal POSTPONE perform ; immediate 709: 710: Variable ppi-temp 0 ppi-temp ! 711: 712: : pa: 713: \g define plugin action 714: ppi-temp @ ABORT" pa: definition not closed" 715: 'PI ppi-temp ! :noname ; 716: 717: : ;pa 718: \g end a definition for plugin action 719: POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate 720: 721: 722: Plugin dlit, ( d -- ) \ compile numerical value the target 723: Plugin lit, ( n -- ) 724: Plugin alit, ( n -- ) 725: 726: Plugin branch, ( target-addr -- ) \ compiles a branch 727: Plugin ?branch, ( target-addr -- ) \ compiles a ?branch 728: Plugin branchmark, ( -- branch-addr ) \ reserves room for a branch 729: Plugin ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch 730: Plugin ?domark, ( -- branch-addr ) \ reserves room for a ?do branch 731: Plugin branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) 732: ' NOOP plugin-of branchto, 733: Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark 734: Plugin branchtomark, ( -- target-addr ) \ marks a branch destination 735: 736: Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position 737: Plugin prim, ( tcfa -- ) \ compiles primitive invocation 738: Plugin colonmark, ( -- addr ) \ marks a colon call 739: Plugin colon-resolve ( tcfa addr -- ) 740: 741: Plugin addr-resolve ( target-addr addr -- ) 742: Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) 743: 744: Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open 745: Plugin if, ( -- if-token ) 746: Plugin else, ( if-token -- if-token ) 747: Plugin then, ( if-token -- ) 748: Plugin ahead, 749: Plugin begin, 750: Plugin while, 751: Plugin until, 752: Plugin again, 753: Plugin repeat, 754: Plugin cs-swap ( x1 x2 -- x2 x1 ) 755: 756: Plugin case, ( -- n ) 757: Plugin of, ( n -- x1 n ) 758: Plugin endof, ( x1 n -- x2 n ) 759: Plugin endcase, ( x1 .. xn n -- ) 760: 761: Plugin do, ( -- do-token ) 762: Plugin ?do, ( -- ?do-token ) 763: Plugin for, ( -- for-token ) 764: Plugin loop, ( do-token / ?do-token -- ) 765: Plugin +loop, ( do-token / ?do-token -- ) 766: Plugin next, ( for-token ) 767: Plugin leave, ( -- ) 768: Plugin ?leave, ( -- ) 769: 770: Plugin ca>native \ Convert a code address to the processors 771: \ native address. This is used in doprim, and 772: \ code/code: primitive definitions word to 773: \ convert the addresses. 774: \ The only target where we need this is the misc 775: \ which is a 16 Bit processor with word addresses 776: \ but the forth system we build has a normal byte 777: \ addressed memory model 778: 779: Plugin doprim, \ compiles start of a primitive 780: Plugin docol, \ compiles start of a colon definition 781: Plugin doer, 782: Plugin fini, \ compiles end of definition ;s 783: Plugin doeshandler, 784: Plugin dodoes, 785: 786: Plugin colon-start 787: ' noop plugin-of colon-start 788: Plugin colon-end 789: ' noop plugin-of colon-end 790: 791: Plugin ]comp \ starts compilation 792: ' noop plugin-of ]comp 793: Plugin comp[ \ ends compilation 794: ' noop plugin-of comp[ 795: 796: Plugin t>body \ we need the system >body 797: \ and the target >body 798: 799: >TARGET 800: : >body t>body ; 801: 802: 803: \ Ghost Builder 06oct92py 804: 805: >CROSS 806: hex 807: \ Values for ghost magic 808: 4711 Constant <fwd> 4712 Constant <res> 809: 4713 Constant <imm> 4714 Constant <do:> 810: 4715 Constant <skip> 811: 812: \ Bitmask for ghost flags 813: 1 Constant <unique> 814: 2 Constant <primitive> 815: 816: \ FXIME: move this to general stuff? 817: : set-flag ( addr flag -- ) 818: over @ or swap ! ; 819: 820: : reset-flag ( addr flag -- ) 821: invert over @ and swap ! ; 822: 823: : get-flag ( addr flag -- f ) 824: swap @ and 0<> ; 825: 826: 827: Struct 828: 829: \ link to next ghost (always the first element) 830: cell% field >next-ghost 831: 832: \ type of ghost 833: cell% field >magic 834: 835: \ pointer where ghost is in target, or if unresolved 836: \ points to the where we have to resolve (linked-list) 837: cell% field >link 838: 839: \ execution semantics (while target compiling) of ghost 840: cell% field >exec 841: 842: \ compilation action of this ghost; this is what is 843: \ done to compile a call (or whatever) to this definition. 844: \ E.g. >comp contains the semantic of postpone s" 845: \ whereas >exec-compile contains the semantic of s" 846: cell% field >comp 847: 848: \ Compilation sematics (while parsing) of this ghost. E.g. 849: \ "\" will skip the rest of line. 850: \ These semantics are defined by Cond: and 851: \ if a word is made immediate in instant, then the >exec2 field 852: \ gets copied to here 853: cell% field >exec-compile 854: 855: \ Additional execution semantics of this ghost. This is used 856: \ for code generated by instant and for the doer-xt of created 857: \ words 858: cell% field >exec2 859: 860: cell% field >created 861: 862: \ the xt of the created ghost word itself 863: cell% field >ghost-xt 864: 865: \ pointer to the counted string of the assiciated 866: \ assembler label 867: cell% field >asm-name 868: 869: \ mapped primitives have a special address, so 870: \ we are able to detect them 871: cell% field >asm-dummyaddr 872: 873: \ for builder (create, variable...) words 874: \ the execution symantics of words built are placed here 875: \ this is a doer ghost or a dummy ghost 876: cell% field >do:ghost 877: 878: cell% field >ghost-flags 879: 880: cell% field >ghost-name 881: 882: End-Struct ghost-struct 883: 884: Variable ghost-list 885: 0 ghost-list ! 886: 887: Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes> 888: \ Variable last-ghost \ last ghost that is created 889: Variable last-header-ghost \ last ghost definitions with header 890: 891: \ space for ghosts resolve structure 892: \ we create ghosts in a sepearte space 893: \ and not to the current host dp, because this 894: \ gives trouble with instant while compiling and creating 895: \ a ghost for a forward reference 896: \ BTW: we cannot allocate another memory region 897: \ because allot will check the overflow!! 898: Variable cross-space-dp 899: Create cross-space 250000 allot here 100 allot align 900: Constant cross-space-end 901: cross-space cross-space-dp ! 902: Variable cross-space-dp-orig 903: 904: : cross-space-used cross-space-dp @ cross-space - ; 905: 906: : >space ( -- ) 907: dp @ cross-space-dp-orig ! 908: cross-space-dp @ dp ! ; 909: 910: : space> ( -- ) 911: dp @ dup cross-space-dp ! 912: cross-space-end u> ABORT" CROSS: cross-space overflow" 913: cross-space-dp-orig @ dp ! ; 914: 915: \ this is just for debugging, to see this in the backtrace 916: : execute-exec execute ; 917: : execute-exec2 execute ; 918: : execute-exec-compile execute ; 919: 920: : NoExec 921: executed-ghost @ >exec2 @ 922: ?dup 923: IF execute-exec2 924: ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word" 925: THEN ; 926: 927: Defer is-forward 928: 929: : (ghostheader) ( -- ) 930: ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward , 931: 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ; 932: 933: : ghostheader ( -- ) (ghostheader) 0 , ; 934: 935: ' Ghosts >wordlist Constant ghosts-wordlist 936: 937: \ the current wordlist for ghost definitions in the host 938: ghosts-wordlist Value current-ghosts 939: 940: : Make-Ghost ( "name" -- ghost ) 941: >space 942: \ save current and create in ghost vocabulary 943: get-current >r current-ghosts set-current 944: >in @ Create >in ! 945: \ some forth systems like iForth need the immediate directly 946: \ after the word is created 947: \ restore current 948: r> set-current 949: here (ghostheader) 950: bl word count string, align 951: space> 952: \ set ghost-xt field by doing a search 953: dup >ghost-name count 954: current-ghosts search-wordlist 955: 0= ABORT" CROSS: Just created, must be there!" 956: over >ghost-xt ! 957: DOES> 958: dup executed-ghost ! 959: >exec @ execute-exec ; 960: 961: \ ghost words 14oct92py 962: \ changed: 10may93py/jaw 963: 964: Defer search-ghosts 965: 966: : (search-ghosts) ( adr len -- cfa true | 0 ) 967: current-ghosts search-wordlist ; 968: 969: ' (search-ghosts) IS search-ghosts 970: 971: : gsearch ( addr len -- ghost true | 0 ) 972: search-ghosts 973: dup IF swap >body swap THEN ; 974: 975: : gfind ( string -- ghost true / string false ) 976: \ searches for string in word-list ghosts 977: \ dup count type space 978: dup >r count gsearch 979: dup IF rdrop ELSE r> swap THEN ; 980: 981: : gdiscover ( xt -- ghost true | xt false ) 982: >r ghost-list 983: BEGIN @ dup 984: WHILE dup >magic @ <fwd> <> 985: IF dup >link @ r@ = 986: IF rdrop true EXIT THEN 987: THEN 988: REPEAT 989: drop r> false ; 990: 991: : xt>ghost ( xt -- ghost ) 992: gdiscover 0= ABORT" CROSS: ghost not found for this xt" ; 993: 994: : Ghost ( "name" -- ghost ) 995: >in @ bl word gfind IF nip EXIT THEN 996: drop >in ! Make-Ghost ; 997: 998: : >ghostname ( ghost -- adr len ) 999: >ghost-name count ; 1000: 1001: : forward? ( ghost -- flag ) 1002: >magic @ <fwd> = ; 1003: 1004: : undefined? ( ghost -- flag ) 1005: >magic @ dup <fwd> = swap <skip> = or ; 1006: 1007: : immediate? ( ghost -- flag ) 1008: >magic @ <imm> = ; 1009: 1010: Variable TWarnings 1011: TWarnings on 1012: Variable Exists-Warnings 1013: Exists-Warnings on 1014: 1015: : exists-warning ( ghost -- ghost ) 1016: TWarnings @ Exists-Warnings @ and 1017: IF dup >ghostname warnhead type ." exists " THEN ; 1018: 1019: \ : HeaderGhost Ghost ; 1020: 1021: Variable reuse-ghosts reuse-ghosts off 1022: 1023: : HeaderGhost ( "name" -- ghost ) 1024: >in @ 1025: bl word count 1026: \ 2dup type space 1027: current-ghosts search-wordlist 1028: IF >body dup undefined? reuse-ghosts @ or 1029: IF nip EXIT 1030: ELSE exists-warning 1031: THEN 1032: drop >in ! 1033: ELSE >in ! 1034: THEN 1035: \ we keep the execution semantics of the prviously 1036: \ defined words, this is a workaround 1037: \ for the redefined \ until vocs work 1038: Make-Ghost ; 1039: 1040: : .ghost ( ghost -- ) >ghostname type ; 1041: 1042: \ ' >ghostname ALIAS @name 1043: 1044: : findghost ( "ghostname" -- ghost ) 1045: bl word gfind 0= ABORT" CROSS: Ghost don't exists" ; 1046: 1047: : [G'] ( -- ghost : name ) 1048: \G ticks a ghost and returns its address 1049: findghost 1050: state @ IF postpone literal THEN ; immediate 1051: 1052: : g>xt ( ghost -- xt ) 1053: \G Returns the xt (cfa) of a ghost. Issues a warning if undefined. 1054: dup undefined? ABORT" CROSS: forward " >link @ ; 1055: 1056: : g>body ( ghost -- body ) 1057: \G Returns the body-address (pfa) of a ghost. 1058: \G Issues a warning if undefined (a forward-reference). 1059: g>xt X >body ; 1060: 1061: 1 Constant <label> 1062: 1063: Struct 1064: \ bitmask of address type (not used for now) 1065: cell% field addr-type 1066: \ if this address is an xt, this field points to the ghost 1067: cell% field addr-xt-ghost 1068: \ a bit mask that tells as what part of the cell 1069: \ is refenced from an address pointer, used for assembler generation 1070: cell% field addr-refs 1071: End-Struct addr-struct 1072: 1073: : %allocerase ( align size -- addr ) 1074: dup >r %alloc dup r> erase ; 1075: 1076: \ returns the addr struct, define it if 0 reference 1077: : define-addr-struct ( addr -- struct-addr ) 1078: dup @ ?dup IF nip EXIT THEN 1079: addr-struct %allocerase tuck swap ! ; 1080: 1081: >cross 1082: 1083: \ Predefined ghosts 12dec92py 1084: 1085: Ghost - drop \ need a ghost otherwise "-" would be treated as a number 1086: 1087: Ghost 0= drop 1088: Ghost branch Ghost ?branch 2drop 1089: Ghost unloop Ghost ;S 2drop 1090: Ghost lit Ghost ! 2drop 1091: Ghost noop drop 1092: Ghost over Ghost = Ghost drop 2drop drop 1093: Ghost 2drop drop 1094: Ghost 2dup drop 1095: Ghost call drop 1096: Ghost @ drop 1097: Ghost useraddr drop 1098: Ghost execute drop 1099: Ghost + drop 1100: Ghost decimal drop 1101: Ghost hex drop 1102: Ghost lit@ drop 1103: Ghost lit-perform drop 1104: Ghost lit+ drop 1105: Ghost does-exec drop 1106: 1107: Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop 1108: Ghost :dovar drop 1109: 1110: \ \ Parameter for target systems 06oct92py 1111: 1112: 1113: \ we define it ans like... 1114: wordlist Constant target-environment 1115: 1116: \ save information of current dictionary to restore with environ> 1117: Variable env-current 1118: 1119: : >ENVIRON get-current env-current ! target-environment set-current ; 1120: : ENVIRON> env-current @ set-current ; 1121: 1122: >TARGET 1123: 1124: : environment? ( addr len -- [ x ] true | false ) 1125: \G returns the content of environment variable and true or 1126: \G false if not present 1127: target-environment search-wordlist 1128: IF EXECUTE true ELSE false THEN ; 1129: 1130: : $has? ( addr len -- x | false ) 1131: \G returns the content of environment variable 1132: \G or false if not present 1133: T environment? H dup IF drop THEN ; 1134: 1135: : e? ( "name" -- x ) 1136: \G returns the content of environment variable. 1137: \G The variable is expected to exist. If not, issue an error. 1138: bl word count T environment? H 1139: 0= ABORT" environment variable not defined!" ; 1140: 1141: : has? ( "name" --- x | false ) 1142: \G returns the content of environment variable 1143: \G or false if not present 1144: bl word count T $has? H ; 1145: 1146: 1147: >ENVIRON get-order get-current swap 1+ set-order 1148: true SetValue compiler 1149: true SetValue cross 1150: true SetValue standard-threading 1151: >TARGET previous 1152: 1153: 0 1154: [IFDEF] mach-file drop mach-file count 1 [THEN] 1155: [IFDEF] machine-file drop machine-file 1 [THEN] 1156: [IF] included hex 1157: [ELSE] cr ." No machine description!" ABORT 1158: [THEN] 1159: 1160: >ENVIRON 1161: 1162: T has? ec H 1163: [IF] 1164: false DefaultValue relocate 1165: false DefaultValue file 1166: false DefaultValue OS 1167: false DefaultValue prims 1168: false DefaultValue floating 1169: false DefaultValue glocals 1170: false DefaultValue dcomps 1171: false DefaultValue hash 1172: false DefaultValue xconds 1173: false DefaultValue header 1174: false DefaultValue backtrace 1175: false DefaultValue new-input 1176: false DefaultValue peephole 1177: false DefaultValue primcentric 1178: false DefaultValue abranch 1179: true DefaultValue f83headerstring 1180: true DefaultValue control-rack 1181: [THEN] 1182: 1183: true DefaultValue gforthcross 1184: true DefaultValue interpreter 1185: true DefaultValue ITC 1186: false DefaultValue rom 1187: false DefaultValue flash 1188: true DefaultValue standardthreading 1189: 1190: \ ANSForth environment stuff 1191: 8 DefaultValue ADDRESS-UNIT-BITS 1192: 255 DefaultValue MAX-CHAR 1193: 255 DefaultValue /COUNTED-STRING 1194: 1195: >TARGET 1196: s" relocate" T environment? H 1197: \ JAW why set NIL to this?! 1198: [IF] drop \ SetValue NIL 1199: [ELSE] >ENVIRON X NIL SetValue relocate 1200: [THEN] 1201: >TARGET 1202: 1203: 0 Constant NIL 1204: 1205: >CROSS 1206: 1207: \ \ Create additional parameters 19jan95py 1208: 1209: \ currently cross only works for host machines with address-unit-bits 1210: \ eual to 8 because of s! and sc! 1211: \ but I start to query the environment just to modularize a little bit 1212: 1213: : check-address-unit-bits ( -- ) 1214: \ s" ADDRESS-UNIT-BITS" environment? 1215: \ IF 8 <> ELSE true THEN 1216: \ ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!" 1217: 1218: \ shit, this doesn't work because environment? is only defined for 1219: \ gforth.fi and not kernl???.fi 1220: ; 1221: 1222: check-address-unit-bits 1223: 8 Constant bits/byte \ we define: byte is address-unit 1224: 1225: 1 bits/byte lshift Constant maxbyte 1226: \ this sets byte size for the target machine, (probably right guess) jaw 1227: 1228: T 1229: NIL Constant TNIL 1230: cell Constant tcell 1231: cell<< Constant tcell<< 1232: cell>bit Constant tcell>bit 1233: bits/char Constant tbits/char 1234: bits/char H bits/byte T / 1235: Constant tchar 1236: float Constant tfloat 1237: 1 bits/char lshift Constant tmaxchar 1238: [IFUNDEF] bits/byte 1239: 8 Constant tbits/byte 1240: [ELSE] 1241: bits/byte Constant tbits/byte 1242: [THEN] 1243: H 1244: tbits/char bits/byte / Constant tbyte 1245: 1246: : >signed ( u -- n ) 1247: 1 tbits/char tcell * 1- lshift 2dup and 1248: IF negate or ELSE drop THEN ; 1249: 1250: \ Variables 06oct92py 1251: 1252: Variable (tlast) 1253: (tlast) Value tlast TNIL tlast ! \ Last name field 1254: Variable tlastcfa \ Last code field 1255: 1256: \ statistics 10jun97jaw 1257: 1258: Variable headers-named 0 headers-named ! 1259: Variable user-vars 0 user-vars ! 1260: 1261: : target>bitmask-size ( u1 -- u2 ) 1262: 1- tcell>bit rshift 1+ ; 1263: 1264: : allocatetarget ( size -- adr ) 1265: dup allocate ABORT" CROSS: No memory for target" 1266: swap over swap erase ; 1267: 1268: \ \ memregion.fs 1269: 1270: 1271: Variable last-defined-region \ pointer to last defined region 1272: Variable region-link \ linked list with all regions 1273: Variable mirrored-link \ linked list for mirrored regions 1274: 0 dup mirrored-link ! region-link ! 1275: 1276: : >rname 9 cells + ; 1277: : >rtouch 8 cells + ; \ executed when region is accessed 1278: : >rbm 4 cells + ; \ bitfield per cell witch indicates relocation 1279: : >rmem 5 cells + ; 1280: : >rtype 6 cells + ; \ field per cell witch points to a type struct 1281: : >rrom 7 cells + ; \ a -1 indicates that this region is rom 1282: : >rlink 3 cells + ; 1283: : >rdp 2 cells + ; 1284: : >rlen cell+ ; 1285: : >rstart ; 1286: 1287: : (region) ( addr len region -- ) 1288: \G change startaddress and length of an existing region 1289: >r r@ last-defined-region ! 1290: r@ >rlen ! dup r@ >rstart ! r> >rdp ! ; 1291: 1292: : uninitialized -1 ABORT" CROSS: Region is uninitialized" ; 1293: 1294: : region ( addr len -- "name" ) 1295: \G create a new region 1296: \ check whether predefined region exists 1297: save-input bl word find >r >r restore-input throw r> r> 0= 1298: IF \ make region 1299: drop 1300: save-input create restore-input throw 1301: here last-defined-region ! 1302: over ( startaddr ) , ( length ) , ( dp ) , 1303: region-link linked 0 , 0 , 0 , 0 , 1304: ['] uninitialized , 1305: bl word count string, 1306: ELSE \ store new parameters in region 1307: bl word drop 1308: >body (region) 1309: THEN ; 1310: 1311: : borders ( region -- startaddr endaddr ) 1312: \G returns lower and upper region border 1313: dup >rstart @ swap >rlen @ over + ; 1314: 1315: : extent ( region -- startaddr len ) 1316: \G returns the really used area 1317: dup >rstart @ swap >rdp @ over - ; 1318: 1319: : area ( region -- startaddr totallen ) 1320: \G returns the total area 1321: dup >rstart @ swap >rlen @ ; 1322: 1323: : dp@ ( region -- dp ) 1324: >rdp @ ; 1325: 1326: : mirrored ( -- ) 1327: \G mark last defined region as mirrored 1328: mirrored-link 1329: align linked last-defined-region @ , ; 1330: 1331: : writeprotected 1332: \G mark a region as write protected 1333: -1 last-defined-region @ >rrom ! ; 1334: 1335: : .addr ( u -- ) 1336: \G prints a 16 or 32 Bit nice hex value 1337: base @ >r hex 1338: tcell 2 u> 1339: IF s>d <# # # # # [char] . hold # # # # #> type 1340: ELSE s>d <# # # # # # #> type 1341: THEN r> base ! space ; 1342: 1343: : .regions \G display region statistic 1344: 1345: \ we want to list the regions in the right order 1346: \ so first collect all regions on stack 1347: 0 region-link @ 1348: BEGIN dup WHILE dup @ REPEAT drop 1349: BEGIN dup 1350: WHILE cr 1351: 0 >rlink - >r 1352: r@ >rname count tuck type 1353: 12 swap - 0 max spaces space 1354: ." Start: " r@ >rstart @ dup .addr space 1355: ." End: " r@ >rlen @ + .addr space 1356: ." DP: " r> >rdp @ .addr 1357: REPEAT drop 1358: s" rom" T $has? H 0= ?EXIT 1359: cr ." Mirrored:" 1360: mirrored-link @ 1361: BEGIN dup 1362: WHILE space dup cell+ @ >rname count type @ 1363: REPEAT drop cr 1364: ; 1365: 1366: \ -------- predefined regions 1367: 1368: 0 0 region address-space 1369: \ total memory addressed and used by the target system 1370: 1371: 0 0 region user-region 1372: \ data for user variables goes here 1373: \ this has to be defined before dictionary or ram-dictionary 1374: 1375: 0 0 region dictionary 1376: \ rom area for the compiler 1377: 1378: T has? rom H 1379: [IF] 1380: 0 0 region ram-dictionary mirrored 1381: \ ram area for the compiler 1382: [ELSE] 1383: ' dictionary ALIAS ram-dictionary 1384: [THEN] 1385: 1386: 0 0 region return-stack 1387: 1388: 0 0 region data-stack 1389: 1390: 0 0 region tib-region 1391: 1392: ' dictionary ALIAS rom-dictionary 1393: 1394: : setup-region ( region -- ) 1395: >r 1396: \ allocate mem 1397: r@ >rlen @ allocatetarget 1398: r@ >rmem ! 1399: 1400: r@ >rlen @ 1401: target>bitmask-size allocatetarget 1402: r@ >rbm ! 1403: 1404: r@ >rlen @ 1405: tcell / 1+ cells allocatetarget r@ >rtype ! 1406: 1407: ['] noop r@ >rtouch ! 1408: rdrop ; 1409: 1410: : setup-target ( -- ) \G initialize target's memory space 1411: s" rom" T $has? H 1412: IF \ check for ram and rom... 1413: \ address-space area nip 0<> 1414: ram-dictionary area nip 0<> 1415: rom-dictionary area nip 0<> 1416: and 0= 1417: ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!" 1418: THEN 1419: address-space area nip 1420: IF 1421: address-space area 1422: ELSE 1423: dictionary area 1424: THEN 1425: nip 0= 1426: ABORT" CROSS: define at least address-space or dictionary!!" 1427: 1428: \ allocate target for each region 1429: region-link 1430: BEGIN @ dup 1431: WHILE dup 1432: 0 >rlink - >r 1433: r@ >rlen @ 1434: IF r@ setup-region 1435: THEN rdrop 1436: REPEAT drop ; 1437: 1438: \ MakeKernel 22feb99jaw 1439: 1440: : makekernel ( start targetsize -- ) 1441: \G convenience word to setup the memory of the target 1442: \G used by main.fs of the c-engine based systems 1443: dictionary (region) setup-target ; 1444: 1445: >MINIMAL 1446: : makekernel makekernel ; 1447: >CROSS 1448: 1449: \ \ switched tdp for rom support 03jun97jaw 1450: 1451: \ second value is here to store some maximal value for statistics 1452: \ tempdp is also embedded here but has nothing to do with rom support 1453: \ (needs switched dp) 1454: 1455: variable tempdp 0 , \ temporary dp for resolving 1456: variable tempdp-save 1457: 1458: 0 [IF] 1459: variable romdp 0 , \ Dictionary-Pointer for ramarea 1460: variable ramdp 0 , \ Dictionary-Pointer for romarea 1461: 1462: \ 1463: variable sramdp \ start of ram-area for forth 1464: variable sromdp \ start of rom-area for forth 1465: 1466: [THEN] 1467: 1468: 0 Value current-region 1469: 0 Value tdp 1470: Variable fixed \ flag: true: no automatic switching 1471: \ false: switching is done automatically 1472: 1473: \ Switch-Policy: 1474: \ 1475: \ a header is always compiled into rom 1476: \ after a created word (create and variable) compilation goes to ram 1477: \ 1478: \ Be careful: If you want to make the data behind create into rom 1479: \ you have to put >rom before create! 1480: 1481: variable constflag constflag off 1482: 1483: : activate ( region -- ) 1484: \G next code goes to this region 1485: dup to current-region >rdp to tdp ; 1486: 1487: : (switchram) 1488: fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT 1489: ram-dictionary activate ; 1490: 1491: : switchram 1492: constflag @ 1493: IF constflag off ELSE (switchram) THEN ; 1494: 1495: : switchrom 1496: fixed @ ?EXIT rom-dictionary activate ; 1497: 1498: : >tempdp ( addr -- ) 1499: tdp tempdp-save ! tempdp to tdp tdp ! ; 1500: : tempdp> ( -- ) 1501: tempdp-save @ to tdp ; 1502: 1503: : >ram fixed off (switchram) fixed on ; 1504: : >rom fixed off switchrom fixed on ; 1505: : >auto fixed off switchrom ; 1506: 1507: 1508: 1509: \ : romstart dup sromdp ! romdp ! ; 1510: \ : ramstart dup sramdp ! ramdp ! ; 1511: 1512: \ default compilation goes to rom 1513: \ when romable support is off, only the rom switch is used (!!) 1514: >auto 1515: 1516: : there tdp @ ; 1517: 1518: >TARGET 1519: 1520: \ \ Target Memory Handling 1521: 1522: \ Byte ordering and cell size 06oct92py 1523: 1524: : cell+ tcell + ; 1525: : cells tcell<< lshift ; 1526: : chars tchar * ; 1527: : char+ tchar + ; 1528: : floats tfloat * ; 1529: 1530: >CROSS 1531: : cell/ tcell<< rshift ; 1532: >TARGET 1533: 20 CONSTANT bl 1534: \ TNIL Constant NIL 1535: 1536: >CROSS 1537: 1538: bigendian 1539: [IF] 1540: : DS! ( d addr -- ) tcell bounds swap 1- 1541: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; 1542: : DS@ ( addr -- d ) >r 0 0 r> tcell bounds 1543: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP ; 1544: : Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1- 1545: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; 1546: : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds 1547: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; 1548: [ELSE] 1549: : DS! ( d addr -- ) tcell bounds 1550: DO maxbyte ud/mod rot I c! LOOP 2drop ; 1551: : DS@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- 1552: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP ; 1553: : Sc! ( n addr -- ) >r s>d r> tchar bounds 1554: DO maxbyte ud/mod rot I c! LOOP 2drop ; 1555: : Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1- 1556: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; 1557: [THEN] 1558: 1559: : S! ( n addr -- ) >r s>d r> DS! ; 1560: : S@ ( addr -- n ) DS@ d>s ; 1561: 1562: : taddr>region ( taddr -- region | 0 ) 1563: \G finds for a target-address the correct region 1564: \G returns 0 if taddr is not in range of a target memory region 1565: region-link 1566: BEGIN @ dup 1567: WHILE dup >r 1568: 0 >rlink - >r 1569: r@ >rlen @ 1570: IF dup r@ borders within 1571: IF r> r> drop nip 1572: dup >rtouch @ EXECUTE EXIT 1573: THEN 1574: THEN 1575: r> drop 1576: r> 1577: REPEAT 1578: 2drop 0 ; 1579: 1580: : taddr>region-abort ( taddr -- region | 0 ) 1581: \G Same as taddr>region but aborts if taddr is not 1582: \G a valid address in the target address space 1583: dup taddr>region dup 0= 1584: IF drop cr ." Wrong address: " .addr 1585: -1 ABORT" Address out of range!" 1586: THEN nip ; 1587: 1588: : (>regionimage) ( taddr -- 'taddr ) 1589: dup 1590: \ find region we want to address 1591: taddr>region-abort 1592: >r 1593: \ calculate offset in region 1594: r@ >rstart @ - 1595: \ add regions real address in our memory 1596: r> >rmem @ + ; 1597: 1598: : (>regionramimage) ( taddr -- 'taddr ) 1599: \G same as (>regionimage) but aborts if the region is rom 1600: dup 1601: \ find region we want to address 1602: taddr>region-abort 1603: >r 1604: r@ >rrom @ ABORT" CROSS: region is write-protected!" 1605: \ calculate offset in region 1606: r@ >rstart @ - 1607: \ add regions real address in our memory 1608: r> >rmem @ + ; 1609: 1610: : (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr ) 1611: dup 1612: \ find region we want to address 1613: taddr>region-abort 1614: >r 1615: \ calculate offset in region 1616: r@ >rstart @ - 1617: \ add regions real address in our memory 1618: r> >rbm @ ; 1619: 1620: : (>regiontype) ( taddr -- 'taddr ) 1621: dup 1622: \ find region we want to address 1623: taddr>region-abort 1624: >r 1625: \ calculate offset in region 1626: r@ >rstart @ - tcell / cells 1627: \ add regions real address in our memory 1628: r> >rtype @ + ; 1629: 1630: \ Bit string manipulation 06oct92py 1631: \ 9may93jaw 1632: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, 1633: : bits ( n -- n ) chars Bittable + c@ ; 1634: 1635: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; 1636: : +bit ( addr n -- ) >bit over c@ or swap c! ; 1637: : -bit ( addr n -- ) >bit invert over c@ and swap c! ; 1638: 1639: : @relbit ( taddr -- f ) (>regionbm) swap cell/ >bit swap c@ and ; 1640: 1641: : (relon) ( taddr -- ) 1642: [ [IFDEF] fd-relocation-table ] 1643: s" +" fd-relocation-table write-file throw 1644: dup s>d <# #s #> fd-relocation-table write-line throw 1645: [ [THEN] ] 1646: (>regionbm) swap cell/ +bit ; 1647: 1648: : (reloff) ( taddr -- ) 1649: [ [IFDEF] fd-relocation-table ] 1650: s" -" fd-relocation-table write-file throw 1651: dup s>d <# #s #> fd-relocation-table write-line throw 1652: [ [THEN] ] 1653: (>regionbm) swap cell/ -bit ; 1654: 1655: DEFER >image 1656: DEFER >ramimage 1657: DEFER relon 1658: DEFER reloff 1659: DEFER correcter 1660: 1661: T has? relocate H 1662: [IF] 1663: ' (relon) IS relon 1664: ' (reloff) IS reloff 1665: ' (>regionimage) IS >image 1666: ' (>regionimage) IS >ramimage 1667: [ELSE] 1668: ' drop IS relon 1669: ' drop IS reloff 1670: ' (>regionimage) IS >image 1671: ' (>regionimage) IS >ramimage 1672: [THEN] 1673: 1674: : enforce-writeprotection ( -- ) 1675: ['] (>regionramimage) IS >ramimage ; 1676: 1677: : relax-writeprotection ( -- ) 1678: ['] (>regionimage) IS >ramimage ; 1679: 1680: : writeprotection-relaxed? ( -- ) 1681: ['] >ramimage >body @ ['] (>regionimage) = ; 1682: 1683: \ Target memory access 06oct92py 1684: 1685: : align+ ( taddr -- rest ) 1686: tcell tuck 1- and - [ tcell 1- ] Literal and ; 1687: : cfalign+ ( taddr -- rest ) 1688: \ see kernel.fs:cfaligned 1689: /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ; 1690: 1691: >TARGET 1692: : aligned ( taddr -- ta-addr ) dup align+ + ; 1693: \ assumes cell alignment granularity (as GNU C) 1694: 1695: : cfaligned ( taddr1 -- taddr2 ) 1696: \ see kernel.fs 1697: dup cfalign+ + ; 1698: 1699: : @ ( taddr -- w ) >image S@ ; 1700: : ! ( w taddr -- ) >ramimage S! ; 1701: : c@ ( taddr -- char ) >image Sc@ ; 1702: : c! ( char taddr -- ) >ramimage Sc! ; 1703: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; 1704: : 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ; 1705: 1706: \ Target compilation primitives 06oct92py 1707: \ included A! 16may93jaw 1708: 1709: : here ( -- there ) there ; 1710: : allot ( n -- ) tdp +! ; 1711: : , ( w -- ) T here H tcell T allot ! H ; 1712: : c, ( char -- ) T here H tchar T allot c! H ; 1713: : align ( -- ) T here H align+ 0 ?DO bl T c, H tchar +LOOP ; 1714: : cfalign ( -- ) 1715: T here H cfalign+ 0 ?DO bl T c, H tchar +LOOP ; 1716: 1717: : >address dup 0>= IF tbyte / THEN ; \ ?? jaw 1718: : A! swap >address swap dup relon T ! H ; 1719: : A, ( w -- ) >address T here H relon T , H ; 1720: 1721: \ high-level ghosts 1722: 1723: >CROSS 1724: 1725: Ghost (do) Ghost (?do) 2drop 1726: Ghost (for) drop 1727: Ghost (loop) Ghost (+loop) 2drop 1728: Ghost (next) drop 1729: Ghost (does>) Ghost (does>1) Ghost (does>2) 2drop drop 1730: Ghost compile, drop 1731: Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop 1732: Ghost (C") Ghost c(abort") Ghost type 2drop drop 1733: Ghost ' drop 1734: 1735: \ user ghosts 1736: 1737: Ghost state drop 1738: 1739: \ \ -------------------- Host/Target copy etc. 29aug01jaw 1740: 1741: 1742: >CROSS 1743: 1744: : TD! >image DS! ; 1745: : TD@ >image DS@ ; 1746: 1747: : th-count ( taddr -- host-addr len ) 1748: \G returns host address of target string 1749: assert1( tbyte 1 = ) 1750: dup X c@ swap X char+ >image swap ; 1751: 1752: : ht-move ( haddr taddr len -- ) 1753: \G moves data from host-addr to destination in target-addr 1754: \G character by character 1755: swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ; 1756: 1757: 2Variable last-string 1758: X has? rom [IF] $60 [ELSE] $00 [THEN] Constant header-masks 1759: 1760: : ht-header, ( addr count -- ) 1761: dup there swap last-string 2! 1762: dup header-masks or T c, H bounds ?DO I c@ T c, H LOOP ; 1763: : ht-string, ( addr count -- ) 1764: dup there swap last-string 2! 1765: dup T c, H bounds ?DO I c@ T c, H LOOP ; 1766: : ht-mem, ( addr count ) 1767: bounds ?DO I c@ T c, H LOOP ; 1768: 1769: >TARGET 1770: 1771: : count dup X c@ swap X char+ swap ; 1772: 1773: : on >r -1 -1 r> TD! ; 1774: : off T 0 swap ! H ; 1775: 1776: : tcmove ( source dest len -- ) 1777: \G cmove in target memory 1778: tchar * bounds 1779: ?DO dup T c@ H I T c! H 1+ 1780: tchar +LOOP drop ; 1781: 1782: : tcallot ( char size -- ) 1783: 0 ?DO dup T c, H tchar +LOOP drop ; 1784: 1785: : td, ( d -- ) 1786: \G Store a host value as one cell into the target 1787: there tcell X allot TD! ; 1788: 1789: \ \ Load Assembler 1790: 1791: >TARGET 1792: H also Forth definitions 1793: 1794: \ FIXME: should we include the assembler really in the forth 1795: \ dictionary?!?!?!? This conflicts with the existing assembler 1796: \ of the host forth system!! 1797: [IFDEF] asm-include asm-include [THEN] hex 1798: 1799: previous 1800: 1801: 1802: >CROSS 1803: 1804: : (cc) T a, H ; ' (cc) plugin-of colon, 1805: : (prim) T a, H ; ' (prim) plugin-of prim, 1806: 1807: : (cr) >tempdp colon, tempdp> ; ' (cr) plugin-of colon-resolve 1808: : (ar) T ! H ; ' (ar) plugin-of addr-resolve 1809: : (dr) ( ghost res-pnt target-addr addr ) 1810: >tempdp drop over 1811: dup >magic @ <do:> = 1812: IF doer, 1813: ELSE dodoes, 1814: THEN 1815: tempdp> ; ' (dr) plugin-of doer-resolve 1816: 1817: : (cm) ( -- addr ) 1818: there -1 colon, ; ' (cm) plugin-of colonmark, 1819: 1820: >TARGET 1821: : compile, ( xt -- ) 1822: dup xt>ghost >comp @ EXECUTE ; 1823: >CROSS 1824: 1825: \ resolve structure 1826: 1827: : >next ; \ link to next field 1828: : >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer 1829: : >taddr cell+ cell+ ; 1830: : >ghost 3 cells + ; 1831: : >file 4 cells + ; 1832: : >line 5 cells + ; 1833: 1834: : (refered) ( ghost addr tag -- ) 1835: \G creates a reference to ghost at address taddr 1836: >space 1837: rot >link linked 1838: ( taddr tag ) , 1839: ( taddr ) , 1840: last-header-ghost @ , 1841: loadfile , 1842: sourceline# , 1843: space> 1844: ; 1845: 1846: : refered ( ghost tag -- ) 1847: \G creates a resolve structure 1848: T here aligned H swap (refered) 1849: ; 1850: 1851: : killref ( addr ghost -- ) 1852: \G kills a forward reference to ghost at position addr 1853: \G this is used to eleminate a :dovar refence after making a DOES> 1854: dup >magic @ <fwd> <> IF 2drop EXIT THEN 1855: swap >r >link 1856: BEGIN dup @ dup ( addr last this ) 1857: WHILE dup >taddr @ r@ = 1858: IF @ over ! 1859: ELSE nip THEN 1860: REPEAT rdrop 2drop 1861: ; 1862: 1863: Defer resolve-warning 1864: 1865: : reswarn-test ( ghost res-struct -- ghost res-struct ) 1866: over cr ." Resolving " .ghost dup ." in " >ghost @ .ghost ; 1867: 1868: : reswarn-forward ( ghost res-struct -- ghost res-struct ) 1869: over warnhead .ghost dup ." is referenced in " 1870: >ghost @ .ghost ; 1871: 1872: \ ' reswarn-test IS resolve-warning 1873: 1874: \ resolve 14oct92py 1875: 1876: : resolve-loop ( ghost resolve-list tcfa -- ) 1877: >r 1878: BEGIN dup WHILE 1879: \ dup >tag @ 2 = IF reswarn-forward THEN 1880: resolve-warning 1881: r@ over >taddr @ 1882: 2 pick >tag @ 1883: CASE 0 OF colon-resolve ENDOF 1884: 1 OF addr-resolve ENDOF 1885: 2 OF doer-resolve ENDOF 1886: ENDCASE 1887: @ \ next list element 1888: REPEAT 2drop rdrop 1889: ; 1890: 1891: \ : resolve-loop ( ghost tcfa -- ghost tcfa ) 1892: \ >r dup >link @ 1893: \ BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ; 1894: 1895: \ exists 9may93jaw 1896: 1897: : exists ( ghost tcfa -- ) 1898: \G print warning and set new target link in ghost 1899: swap exists-warning 1900: >link ! ; 1901: 1902: : colon-resolved ( ghost -- ) 1903: \ compiles a call to a colon definition, 1904: \ compile action for >comp field 1905: >link @ colon, ; 1906: 1907: : prim-resolved ( ghost -- ) 1908: \ compiles a call to a primitive 1909: >link @ prim, ; 1910: 1911: : (is-forward) ( ghost -- ) 1912: colonmark, 0 (refered) ; \ compile space for call 1913: ' (is-forward) IS is-forward 1914: 1915: 0 Value resolved 1916: 1917: : resolve-forward-references ( ghost resolve-list -- ) 1918: \ loop through forward referencies 1919: comp-state @ >r Resolving comp-state ! 1920: over >link @ resolve-loop 1921: r> comp-state ! 1922: 1923: ['] noop IS resolve-warning ; 1924: 1925: 1926: : (resolve) ( ghost tcfa -- ghost resolve-list ) 1927: \ check for a valid address, it is a primitive reference 1928: \ otherwise 1929: dup taddr>region 0<> IF 1930: \ define this address in the region address type table 1931: 2dup (>regiontype) define-addr-struct addr-xt-ghost 1932: \ we define new address only if empty 1933: \ this is for not to take over the alias ghost 1934: \ (different ghost, but identical xt) 1935: \ but the very first that really defines it 1936: dup @ 0= IF ! ELSE 2drop THEN 1937: THEN 1938: swap >r 1939: r@ to resolved 1940: 1941: \ r@ >comp @ ['] is-forward = 1942: \ ABORT" >comp action not set on a resolved ghost" 1943: 1944: \ copmile action defaults to colon-resolved 1945: \ if this is not right something must be set before 1946: \ calling resolve 1947: r@ >comp @ ['] is-forward = IF 1948: ['] colon-resolved r@ >comp ! 1949: THEN 1950: r@ >link @ swap \ ( list tcfa R: ghost ) 1951: \ mark ghost as resolved 1952: r@ >link ! <res> r@ >magic ! 1953: r> swap ; 1954: 1955: : resolve ( ghost tcfa -- ) 1956: \G resolve referencies to ghost with tcfa 1957: \ is ghost resolved?, second resolve means another 1958: \ definition with the same name 1959: over undefined? 0= IF exists EXIT THEN 1960: (resolve) 1961: ( ghost resolve-list ) 1962: resolve-forward-references ; 1963: 1964: : resolve-noforwards ( ghost tcfa -- ) 1965: \G Same as resolve but complain if there are any 1966: \G forward references on this ghost 1967: \ is ghost resolved?, second resolve means another 1968: \ definition with the same name 1969: over undefined? 0= IF exists EXIT THEN 1970: (resolve) 1971: IF cr ." No forward references allowed on: " .ghost cr 1972: -1 ABORT" Illegal forward reference" 1973: THEN 1974: drop ; 1975: 1976: \ gexecute ghost, 01nov92py 1977: 1978: : (gexecute) ( ghost -- ) 1979: dup >comp @ EXECUTE ; 1980: 1981: : gexecute ( ghost -- ) 1982: dup >magic @ <imm> = ABORT" CROSS: gexecute on immediate word" 1983: (gexecute) ; 1984: 1985: : addr, ( ghost -- ) 1986: dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; 1987: 1988: \ .unresolved 11may93jaw 1989: 1990: variable ResolveFlag 1991: 1992: \ ?touched 11may93jaw 1993: 1994: : ?touched ( ghost -- flag ) dup forward? swap >link @ 1995: 0 <> and ; 1996: 1997: : .forwarddefs ( ghost -- ) 1998: ." appeared in:" 1999: >link 2000: BEGIN @ dup 2001: WHILE cr 5 spaces 2002: dup >ghost @ .ghost 2003: ." file " dup >file @ ?dup IF count type ELSE ." CON" THEN 2004: ." line " dup >line @ .dec 2005: REPEAT 2006: drop ; 2007: 2008: : ?resolved ( ghost -- ) 2009: dup ?touched 2010: IF ResolveFlag on 2011: dup cr .ghost .forwarddefs 2012: ELSE drop 2013: THEN ; 2014: 2015: : .unresolved ( -- ) 2016: ResolveFlag off cr ." Unresolved: " 2017: ghost-list 2018: BEGIN @ dup 2019: WHILE dup ?resolved 2020: REPEAT drop ResolveFlag @ 2021: IF 2022: -1 abort" Unresolved words!" 2023: ELSE 2024: ." Nothing!" 2025: THEN 2026: cr ; 2027: 2028: : .stats 2029: base @ >r decimal 2030: cr ." named Headers: " headers-named @ . 2031: r> base ! ; 2032: 2033: >MINIMAL 2034: 2035: : .unresolved .unresolved ; 2036: 2037: >CROSS 2038: \ Header states 12dec92py 2039: 2040: \ : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; 2041: X has? f83headerstring bigendian or [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ 2042: : flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; 2043: 2044: VARIABLE ^imm 2045: 2046: \ !! should be target wordsize specific 2047: $80 constant alias-mask 2048: $40 constant immediate-mask 2049: $20 constant restrict-mask 2050: 2051: >TARGET 2052: : immediate immediate-mask flag! 2053: ^imm @ @ dup <imm> = IF drop EXIT THEN 2054: <res> <> ABORT" CROSS: Cannot immediate a unresolved word" 2055: <imm> ^imm @ ! ; 2056: : restrict restrict-mask flag! ; 2057: 2058: : isdoer 2059: \G define a forth word as doer, this makes obviously only sence on 2060: \G forth processors such as the PSC1000 2061: <do:> last-header-ghost @ >magic ! ; 2062: >CROSS 2063: 2064: \ Target Header Creation 01nov92py 2065: 2066: : ht-lstring, ( addr count -- ) 2067: dup T , H bounds ?DO I c@ T c, H LOOP ; 2068: 2069: >TARGET 2070: X has? f83headerstring [IF] 2071: : name, ( "name" -- ) bl word count ht-header, X cfalign ; 2072: [ELSE] 2073: : name, ( "name" -- ) bl word count ht-lstring, X cfalign ; 2074: [THEN] 2075: : view, ( -- ) ( dummy ) ; 2076: >CROSS 2077: 2078: \ Target Document Creation (goes to crossdoc.fd) 05jul95py 2079: 2080: s" ./doc/crossdoc.fd" r/w create-file throw value doc-file-id 2081: \ contains the file-id of the documentation file 2082: 2083: : T-\G ( -- ) 2084: source >in @ /string doc-file-id write-line throw 2085: postpone \ ; 2086: 2087: Variable to-doc to-doc on 2088: 2089: : cross-doc-entry ( -- ) 2090: to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header 2091: IF 2092: s" " doc-file-id write-line throw 2093: s" make-doc " doc-file-id write-file throw 2094: 2095: Last-Header-Ghost @ >ghostname doc-file-id write-file throw 2096: >in @ 2097: [char] ( parse 2drop 2098: [char] ) parse doc-file-id write-file throw 2099: s" )" doc-file-id write-file throw 2100: [char] \ parse 2drop 2101: T-\G 2102: >in ! 2103: THEN ; 2104: 2105: \ Target TAGS creation 2106: 2107: s" kernel.TAGS" r/w create-file throw value tag-file-id 2108: s" kernel.tags" r/w create-file throw value vi-tag-file-id 2109: \ contains the file-id of the tags file 2110: 2111: Create tag-beg 1 c, 7F c, 2112: Create tag-end 1 c, 01 c, 2113: Create tag-bof 1 c, 0C c, 2114: Create tag-tab 1 c, 09 c, 2115: 2116: 2variable last-loadfilename 0 0 last-loadfilename 2! 2117: 2118: : put-load-file-name ( -- ) 2119: sourcefilename last-loadfilename 2@ d<> 2120: IF 2121: tag-bof count tag-file-id write-line throw 2122: sourcefilename 2dup 2123: tag-file-id write-file throw 2124: last-loadfilename 2! 2125: s" ,0" tag-file-id write-line throw 2126: THEN ; 2127: 2128: : cross-gnu-tag-entry ( -- ) 2129: tlast @ 0<> \ not an anonymous (i.e. noname) header 2130: IF 2131: put-load-file-name 2132: source >in @ min tag-file-id write-file throw 2133: tag-beg count tag-file-id write-file throw 2134: Last-Header-Ghost @ >ghostname tag-file-id write-file throw 2135: tag-end count tag-file-id write-file throw 2136: base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw 2137: \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw 2138: s" ,0" tag-file-id write-line throw 2139: base ! 2140: THEN ; 2141: 2142: : cross-vi-tag-entry ( -- ) 2143: tlast @ 0<> \ not an anonymous (i.e. noname) header 2144: IF 2145: sourcefilename vi-tag-file-id write-file throw 2146: tag-tab count vi-tag-file-id write-file throw 2147: Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw 2148: tag-tab count vi-tag-file-id write-file throw 2149: s" /^" vi-tag-file-id write-file throw 2150: source vi-tag-file-id write-file throw 2151: s" $/" vi-tag-file-id write-line throw 2152: THEN ; 2153: 2154: : cross-tag-entry ( -- ) 2155: cross-gnu-tag-entry 2156: cross-vi-tag-entry ; 2157: 2158: \ Check for words 2159: 2160: Defer skip? ' false IS skip? 2161: 2162: : skipdef ( "name" -- ) 2163: \G skip definition of an undefined word in undef-words and 2164: \G all-words mode 2165: Ghost dup forward? 2166: IF >magic <skip> swap ! 2167: ELSE drop THEN ; 2168: 2169: : tdefined? ( "name" -- flag ) 2170: Ghost undefined? 0= ; 2171: 2172: : defined2? ( "name" -- flag ) 2173: \G return true for anything else than forward, even for <skip> 2174: \G that's what we want 2175: Ghost forward? 0= ; 2176: 2177: : forced? ( "name" -- flag ) 2178: \G return ture if it is a foreced skip with defskip 2179: Ghost >magic @ <skip> = ; 2180: 2181: : needed? ( -- flag ) \ name 2182: \G returns a false flag when 2183: \G a word is not defined 2184: \G a forward reference exists 2185: \G so the definition is not skipped! 2186: bl word gfind 2187: IF dup undefined? 2188: nip 2189: 0= 2190: ELSE drop true THEN ; 2191: 2192: : doer? ( "name" -- 0 | addr ) \ name 2193: Ghost dup >magic @ <do:> = 2194: IF >link @ ELSE drop 0 THEN ; 2195: 2196: : skip-defs ( -- ) 2197: BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ; 2198: 2199: \ Target header creation 2200: 2201: Variable NoHeaderFlag 2202: NoHeaderFlag off 2203: 2204: : 0.r ( n1 n2 -- ) 2205: base @ >r hex 2206: 0 swap <# 0 ?DO # LOOP #> type 2207: r> base ! ; 2208: 2209: : .sym ( adr len -- ) 2210: \G escapes / and \ to produce sed output 2211: bounds 2212: DO I c@ dup 2213: CASE [char] / OF drop ." \/" ENDOF 2214: [char] \ OF drop ." \\" ENDOF 2215: dup OF emit ENDOF 2216: ENDCASE 2217: LOOP ; 2218: 2219: Defer setup-execution-semantics ' noop IS setup-execution-semantics 2220: 0 Value lastghost 2221: 2222: : (THeader ( "name" -- ghost ) 2223: \ >in @ bl word count type 2 spaces >in ! 2224: \ wordheaders will always be compiled to rom 2225: switchrom 2226: \ build header in target 2227: NoHeaderFlag @ 2228: IF NoHeaderFlag off 2229: ELSE 2230: T align H view, 2231: tlast @ dup 0> IF tcell - THEN T A, H there tlast ! 2232: 1 headers-named +! \ Statistic 2233: >in @ T name, H >in ! 2234: THEN 2235: T cfalign here H tlastcfa ! 2236: \ Old Symbol table sed-script 2237: \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! 2238: HeaderGhost 2239: \ output symbol table to extra file 2240: dup >ghostname there symentry 2241: dup Last-Header-Ghost ! dup to lastghost 2242: dup >magic ^imm ! \ a pointer for immediate 2243: alias-mask flag! 2244: cross-doc-entry cross-tag-entry 2245: setup-execution-semantics 2246: ; 2247: 2248: \ this is the resolver information from ":" 2249: \ resolving is done by ";" 2250: Variable ;Resolve 1 cells allot 2251: 2252: : hereresolve ( ghost -- ) 2253: there resolve 0 ;Resolve ! ; 2254: 2255: : Theader ( "name" -- ghost ) 2256: (THeader dup hereresolve ; 2257: 2258: Variable aprim-nr -20 aprim-nr ! 2259: 2260: : copy-execution-semantics ( ghost-from ghost-dest -- ) 2261: >r 2262: dup >exec @ r@ >exec ! 2263: dup >comp @ r@ >comp ! 2264: dup >exec2 @ r@ >exec2 ! 2265: dup >exec-compile @ r@ >exec-compile ! 2266: dup >ghost-xt @ r@ >ghost-xt ! 2267: dup >created @ r@ >created ! 2268: rdrop drop ; 2269: 2270: >TARGET 2271: 2272: : Alias ( cfa -- ) \ name 2273: >in @ skip? IF 2drop EXIT THEN >in ! 2274: (THeader ( S xt ghost ) 2275: 2dup swap xt>ghost swap copy-execution-semantics 2276: over resolve T A, H alias-mask flag! ; 2277: 2278: Variable last-prim-ghost 2279: 0 last-prim-ghost ! 2280: 2281: : asmprimname, ( ghost -- : name ) 2282: dup last-prim-ghost ! 2283: >r 2284: here bl word count string, r@ >asm-name ! 2285: aprim-nr @ r> >asm-dummyaddr ! ; 2286: 2287: Defer setup-prim-semantics 2288: 2289: : mapprim ( "forthname" "asmlabel" -- ) 2290: THeader -1 aprim-nr +! aprim-nr @ T A, H 2291: asmprimname, 2292: setup-prim-semantics ; 2293: 2294: : mapprim: ( "forthname" "asmlabel" -- ) 2295: -1 aprim-nr +! aprim-nr @ 2296: Ghost tuck swap resolve-noforwards <do:> swap tuck >magic ! 2297: asmprimname, ; 2298: 2299: : Doer: ( cfa -- ) \ name 2300: >in @ skip? IF 2drop EXIT THEN >in ! 2301: dup 0< s" prims" T $has? H 0= and 2302: IF 2303: .sourcepos ." needs doer: " >in @ bl word count type >in ! cr 2304: THEN 2305: Ghost 2306: tuck swap resolve-noforwards <do:> swap >magic ! ; 2307: 2308: Variable prim# 2309: : first-primitive ( n -- ) prim# ! ; 2310: : group 0 word drop prim# @ 1- -$200 and prim# ! ; 2311: : groupadd ( n -- ) drop ; 2312: : Primitive ( -- ) \ name 2313: >in @ skip? IF drop EXIT THEN >in ! 2314: s" prims" T $has? H 0= 2315: IF 2316: .sourcepos ." needs prim: " >in @ bl word count type >in ! cr 2317: THEN 2318: prim# @ (THeader ( S xt ghost ) 2319: ['] prim-resolved over >comp ! 2320: dup >ghost-flags <primitive> set-flag 2321: s" EC" T $has? H 0= 2322: IF 2323: over resolve-noforwards T A, H 2324: alias-mask flag! 2325: ELSE 2326: T here H resolve-noforwards T A, H 2327: THEN 2328: -1 prim# +! ; 2329: >CROSS 2330: 2331: \ Conditionals and Comments 11may93jaw 2332: 2333: \G saves the existing cond action, this is used for redefining in 2334: \G instant 2335: Variable cond-xt-old 2336: 2337: : cond-target ( -- ) 2338: \G Compiles semantic of redefined cond into new one 2339: cond-xt-old @ compile, ; immediate restrict 2340: 2341: : ;Cond 2342: postpone ; 2343: swap ! ; immediate 2344: 2345: : Cond: ( "name" -- ) 2346: \g defines a conditional or another word that must 2347: \g be executed directly while compiling 2348: \g these words have no interpretative semantics by default 2349: Ghost 2350: >exec-compile 2351: dup @ cond-xt-old ! 2352: :NONAME ; 2353: 2354: 2355: : Comment ( -- ) 2356: >in @ Ghost swap >in ! ' swap 2357: 2dup >exec-compile ! >exec ! ; 2358: 2359: Comment ( Comment \ 2360: 2361: \ compile 10may93jaw 2362: 2363: : compile ( "name" -- ) \ name 2364: findghost 2365: dup >exec-compile @ ?dup 2366: IF nip compile, 2367: ELSE postpone literal postpone gexecute THEN ; immediate restrict 2368: 2369: >TARGET 2370: 2371: : ' ( -- xt ) 2372: \G returns the target-cfa of a ghost 2373: bl word gfind 0= ABORT" CROSS: Ghost don't exists" 2374: g>xt ; 2375: 2376: \ FIXME: this works for the current use cases, but is not 2377: \ in all cases correct ;-) 2378: : comp' X ' 0 ; 2379: 2380: Cond: ['] T ' H alit, ;Cond 2381: 2382: >CROSS 2383: 2384: : [T'] 2385: \ returns the target-cfa of a ghost, or compiles it as literal 2386: postpone [G'] 2387: state @ IF postpone g>xt ELSE g>xt THEN ; immediate 2388: 2389: \ \ threading modell 13dec92py 2390: \ modularized 14jun97jaw 2391: 2392: T 2 cells H Value xt>body 2393: 2394: : (>body) ( cfa -- pfa ) 2395: xt>body + ; ' (>body) plugin-of t>body 2396: 2397: : fillcfa ( usedcells -- ) 2398: T cells H xt>body swap - 2399: assert1( dup 0 >= ) 2400: 0 ?DO 0 X c, tchar +LOOP ; 2401: 2402: : (doer,) ( ghost -- ) 2403: addr, 1 fillcfa ; ' (doer,) plugin-of doer, 2404: 2405: : (docol,) ( -- ) [G'] :docol (doer,) ; ' (docol,) plugin-of docol, 2406: 2407: ' NOOP plugin-of ca>native 2408: 2409: : (doprim,) ( -- ) 2410: there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, 2411: 2412: : (doeshandler,) ( -- ) 2413: T cfalign H [G'] :doesjump addr, T 0 , H ; ' (doeshandler,) plugin-of doeshandler, 2414: 2415: : (dodoes,) ( does-action-ghost -- ) 2416: ]comp [G'] :dodoes addr, comp[ 2417: addr, 2418: \ the relocator in the c engine, does not like the 2419: \ does-address to marked for relocation 2420: [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ] 2421: 2 fillcfa ; ' (dodoes,) plugin-of dodoes, 2422: 2423: : (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit, 2424: 2425: : (lit,) ( n -- ) s>d dlit, ; ' (lit,) plugin-of lit, 2426: 2427: \ if we dont produce relocatable code alit, defaults to lit, jaw 2428: \ this is just for convenience, so we don't have to define alit, 2429: \ seperately for embedded systems.... 2430: T has? relocate H 2431: [IF] 2432: : (alit,) ( n -- ) compile lit T a, H ; ' (alit,) plugin-of alit, 2433: [ELSE] 2434: : (alit,) ( n -- ) lit, ; ' (alit,) plugin-of alit, 2435: [THEN] 2436: 2437: : (fini,) compile ;s ; ' (fini,) plugin-of fini, 2438: 2439: [IFUNDEF] (code) 2440: Defer (code) 2441: Defer (end-code) 2442: [THEN] 2443: 2444: >TARGET 2445: : Code 2446: defempty? 2447: (THeader ( ghost ) 2448: ['] prim-resolved over >comp ! 2449: there resolve-noforwards 2450: 2451: [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF] 2452: doprim, 2453: [THEN] 2454: depth (code) ; 2455: 2456: \ FIXME : no-compile -1 ABORT" this ghost is not for compilation" ; 2457: 2458: : Code: 2459: defempty? 2460: Ghost >r 2461: r@ >ghostname there symentry 2462: r@ there ca>native resolve-noforwards 2463: <do:> r@ >magic ! 2464: r> drop 2465: depth (code) ; 2466: 2467: : end-code 2468: (end-code) 2469: depth ?dup IF 1- <> ABORT" CROSS: Stack changed" 2470: ELSE true ABORT" CROSS: Stack empty" THEN 2471: ; 2472: 2473: >CROSS 2474: 2475: \ tLiteral 12dec92py 2476: 2477: >TARGET 2478: Cond: \G T-\G ;Cond 2479: 2480: Cond: Literal ( n -- ) lit, ;Cond 2481: Cond: ALiteral ( n -- ) alit, ;Cond 2482: 2483: : Char ( "<char>" -- ) bl word char+ c@ ; 2484: Cond: [Char] ( "<char>" -- ) Char lit, ;Cond 2485: 2486: : (x#) ( adr len base -- ) 2487: base @ >r base ! 0 0 name >number 2drop drop r> base ! ; 2488: 2489: : d# $0a (x#) ; 2490: : h# $010 (x#) ; 2491: 2492: Cond: d# $0a (x#) lit, ;Cond 2493: Cond: h# $010 (x#) lit, ;Cond 2494: 2495: tchar 1 = [IF] 2496: Cond: chars ;Cond 2497: [THEN] 2498: 2499: \ some special literals 27jan97jaw 2500: 2501: Cond: MAXU 2502: -1 s>d dlit, 2503: ;Cond 2504: 2505: tcell 2 = tcell 4 = or tcell 8 = or 0= 2506: [IF] 2507: .( Warning: MINI and MAXI may not work with this host) cr 2508: [THEN] 2509: 2510: Cond: MINI 2511: tcell 2 = IF $8000 ELSE $80000000 THEN 0 2512: tcell 8 = IF swap THEN dlit, 2513: ;Cond 2514: 2515: Cond: MAXI 2516: tcell 2 = IF $7fff ELSE $7fffffff THEN 0 2517: tcell 8 = IF drop -1 swap THEN dlit, 2518: ;Cond 2519: 2520: >CROSS 2521: 2522: \ Target compiling loop 12dec92py 2523: \ ">tib trick thrown out 10may93jaw 2524: \ number? defined at the top 11may93jaw 2525: \ replaced >in by save-input 2526: 2527: : discard 0 ?DO drop LOOP ; 2528: 2529: \ compiled word might leave items on stack! 2530: : tcom ( x1 .. xn n name -- ) 2531: \ dup count type space 2532: gfind 2533: IF >r ( discard saved input state ) discard r> 2534: dup >exec-compile @ ?dup 2535: IF nip execute-exec-compile ELSE gexecute THEN 2536: EXIT 2537: THEN 2538: number? dup 2539: IF 0> IF swap lit, THEN lit, discard 2540: ELSE 2drop restore-input throw Ghost gexecute THEN ; 2541: 2542: \ : ; DOES> 13dec92py 2543: \ ] 9may93py/jaw 2544: 2545: >CROSS 2546: 2547: : compiling-state ( -- ) 2548: \G set states to compililng 2549: Compiling comp-state ! 2550: \ if we have a state in target, change it with the compile state 2551: [G'] state dup undefined? 0= 2552: IF >ghost-xt @ execute X on ELSE drop THEN ; 2553: 2554: : interpreting-state ( -- ) 2555: \G set states to interpreting 2556: \ if target has a state variable, change it according to our state 2557: [G'] state dup undefined? 0= 2558: IF >ghost-xt @ execute X off ELSE drop THEN 2559: Interpreting comp-state ! ; 2560: 2561: >TARGET 2562: 2563: : ] 2564: compiling-state 2565: BEGIN 2566: BEGIN save-input bl word 2567: dup c@ 0= WHILE drop discard refill 0= 2568: ABORT" CROSS: End of file while target compiling" 2569: REPEAT 2570: tcom 2571: compiling? 0= 2572: UNTIL ; 2573: 2574: \ by the way: defining a second interpreter (a compiler-)loop 2575: \ is not allowed if a system should be ans conform 2576: 2577: : (:) ( ghost -- ) 2578: \ common factor of : and :noname. Prepare ;Resolve and start definition 2579: ;Resolve ! there ;Resolve cell+ ! 2580: docol, ]comp colon-start depth T ] H ; 2581: 2582: : : ( -- colon-sys ) \ Name 2583: defempty? 2584: constflag off \ don't let this flag work over colon defs 2585: \ just to go sure nothing unwanted happens 2586: >in @ skip? IF drop skip-defs EXIT THEN >in ! 2587: (THeader (:) ; 2588: 2589: : :noname ( -- colon-sys ) 2590: switchrom X cfalign there 2591: \ define a nameless ghost 2592: here ghostheader dup last-header-ghost ! dup to lastghost 2593: (:) ; 2594: 2595: Cond: EXIT ( -- ) compile ;S ;Cond 2596: 2597: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond 2598: 2599: >CROSS 2600: : LastXT ;Resolve @ 0= abort" CROSS: no definition for LastXT" 2601: ;Resolve cell+ @ ; 2602: 2603: >TARGET 2604: 2605: Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond 2606: 2607: Cond: ; ( -- ) 2608: depth ?dup 2609: IF 1- <> ABORT" CROSS: Stack changed" 2610: ELSE true ABORT" CROSS: Stack empty" 2611: THEN 2612: colon-end 2613: fini, 2614: comp[ 2615: ;Resolve @ 2616: IF ['] colon-resolved ;Resolve @ >comp ! 2617: ;Resolve @ ;Resolve cell+ @ resolve 2618: THEN 2619: interpreting-state 2620: ;Cond 2621: 2622: Cond: [ ( -- ) interpreting-state ;Cond 2623: 2624: >CROSS 2625: 2626: 0 Value created 2627: 2628: : !does ( does-action -- ) 2629: tlastcfa @ [G'] :dovar killref 2630: >space here >r ghostheader space> 2631: ['] colon-resolved r@ >comp ! 2632: r@ created >do:ghost ! r@ swap resolve 2633: r> tlastcfa @ >tempdp dodoes, tempdp> ; 2634: 2635: Defer instant-interpret-does>-hook ' noop IS instant-interpret-does>-hook 2636: 2637: T has? primcentric H [IF] 2638: : does-resolved ( ghost -- ) 2639: compile does-exec g>xt T a, H ; 2640: [ELSE] 2641: : does-resolved ( ghost -- ) 2642: g>xt T a, H ; 2643: [THEN] 2644: 2645: : resolve-does>-part ( -- ) 2646: \ resolve words made by builders 2647: Last-Header-Ghost @ >do:ghost @ ?dup 2648: IF there resolve THEN ; 2649: 2650: >TARGET 2651: Cond: DOES> 2652: T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells 2653: H + alit, compile (does>2) compile ;s 2654: doeshandler, resolve-does>-part 2655: ;Cond 2656: 2657: : DOES> 2658: ['] does-resolved created >comp ! 2659: switchrom doeshandler, T here H !does 2660: instant-interpret-does>-hook 2661: depth T ] H ; 2662: 2663: >CROSS 2664: \ Creation 01nov92py 2665: 2666: \ Builder 11may93jaw 2667: 2668: 0 Value built 2669: 2670: : Builder ( Create-xt do-ghost "name" -- ) 2671: \ builds up a builder in current vocabulary 2672: \ create-xt is executed when word is interpreted 2673: \ do:-xt is executed when the created word from builder is executed 2674: \ for do:-xt an additional entry after the normal ghost-entrys is used 2675: 2676: ghost to built 2677: built >created @ 0= IF 2678: built >created on 2679: THEN ; 2680: 2681: : gdoes, ( ghost -- ) 2682: \ makes the codefield for a word that is built 2683: >do:ghost @ dup undefined? 0= 2684: IF 2685: dup >magic @ <do:> = 2686: IF doer, 2687: ELSE dodoes, 2688: THEN 2689: EXIT 2690: THEN 2691: \ compile :dodoes gexecute 2692: \ T here H tcell - reloff 2693: 2 refered 2694: 0 fillcfa 2695: ; 2696: 2697: : takeover-x-semantics ( S constructor-ghost new-ghost -- ) 2698: \g stores execution semantic and compilation semantic in the built word 2699: swap >do:ghost @ 2dup swap >do:ghost ! 2700: \ we use the >exec2 field for the semantic of a created word, 2701: \ using exec or exec2 makes no difference for normal cross-compilation 2702: \ but is usefull for instant where the exec field is already 2703: \ defined (e.g. Vocabularies) 2704: 2dup >exec @ swap >exec2 ! 2705: >comp @ swap >comp ! ; 2706: 2707: 0 Value createhere 2708: 2709: : create-resolve ( -- ) 2710: created createhere resolve 0 ;Resolve ! ; 2711: : create-resolve-immediate ( -- ) 2712: create-resolve T immediate H ; 2713: 2714: : TCreate ( <name> -- ) 2715: create-forward-warn 2716: IF ['] reswarn-forward IS resolve-warning THEN 2717: executed-ghost @ (Theader 2718: dup >created on dup to created 2719: 2dup takeover-x-semantics 2720: there to createhere drop gdoes, ; 2721: 2722: : RTCreate ( <name> -- ) 2723: \ creates a new word with code-field in ram 2724: create-forward-warn 2725: IF ['] reswarn-forward IS resolve-warning THEN 2726: \ make Alias 2727: executed-ghost @ (THeader 2728: dup >created on dup to created 2729: 2dup takeover-x-semantics 2730: there 0 T a, H alias-mask flag! 2731: \ store poiter to code-field 2732: switchram T cfalign H 2733: there swap T ! H 2734: there tlastcfa ! 2735: there to createhere drop gdoes, ; 2736: 2737: : Build: ( -- [xt] [colon-sys] ) 2738: :noname postpone TCreate ; 2739: 2740: : BuildSmart: ( -- [xt] [colon-sys] ) 2741: :noname 2742: [ T has? rom H [IF] ] 2743: postpone RTCreate 2744: [ [ELSE] ] 2745: postpone TCreate 2746: [ [THEN] ] ; 2747: 2748: : ;Build 2749: postpone create-resolve postpone ; built >exec ! ; immediate 2750: 2751: : ;Build-immediate 2752: postpone create-resolve-immediate 2753: postpone ; built >exec ! ; immediate 2754: 2755: : gdoes> ( ghost -- addr flag ) 2756: executed-ghost @ g>body ; 2757: 2758: \ DO: ;DO 11may93jaw 2759: 2760: : do:ghost! ( ghost -- ) built >do:ghost ! ; 2761: : doexec! ( xt -- ) built >do:ghost @ >exec ! ; 2762: 2763: : DO: ( -- [xt] [colon-sys] ) 2764: here ghostheader do:ghost! 2765: :noname postpone gdoes> ; 2766: 2767: : by: ( -- [xt] [colon-sys] ) \ name 2768: Ghost do:ghost! 2769: :noname postpone gdoes> ; 2770: 2771: : ;DO ( [xt] [colon-sys] -- ) 2772: postpone ; doexec! ; immediate 2773: 2774: : by ( -- ) \ Name 2775: Ghost >do:ghost @ do:ghost! ; 2776: 2777: : compile: ( --[xt] [colon-sys] ) 2778: \G defines a compile time action for created words 2779: \G by this builder 2780: :noname ; 2781: 2782: : ;compile ( [xt] [colon-sys] -- ) 2783: postpone ; built >do:ghost @ >comp ! ; immediate 2784: 2785: \ Variables and Constants 05dec92py 2786: 2787: Builder (Constant) 2788: Build: ( n -- ) ;Build 2789: by: :docon ( target-body-addr -- n ) T @ H ;DO 2790: 2791: Builder Constant 2792: Build: ( n -- ) T , H ;Build 2793: by (Constant) 2794: 2795: Builder AConstant 2796: Build: ( n -- ) T A, H ;Build 2797: by (Constant) 2798: 2799: Builder 2Constant 2800: Build: ( d -- ) T , , H ;Build 2801: DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO 2802: 2803: Builder Create 2804: BuildSmart: ;Build 2805: by: :dovar ( target-body-addr -- addr ) ;DO 2806: 2807: Builder Variable 2808: T has? rom H [IF] 2809: Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;Build 2810: by (Constant) 2811: [ELSE] 2812: Build: T 0 , H ;Build 2813: by Create 2814: [THEN] 2815: 2816: Builder 2Variable 2817: T has? rom H [IF] 2818: Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;Build 2819: by (Constant) 2820: [ELSE] 2821: Build: T 0 , 0 , H ;Build 2822: by Create 2823: [THEN] 2824: 2825: Builder AVariable 2826: T has? rom H [IF] 2827: Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;Build 2828: by (Constant) 2829: [ELSE] 2830: Build: T 0 A, H ;Build 2831: by Create 2832: [THEN] 2833: 2834: \ User variables 04may94py 2835: 2836: : tup@ user-region >rstart @ ; 2837: 2838: \ Variable tup 0 tup ! 2839: \ Variable tudp 0 tudp ! 2840: 2841: : u, ( n -- udp ) 2842: current-region >r user-region activate 2843: X here swap X , tup@ - 2844: r> activate ; 2845: 2846: : au, ( n -- udp ) 2847: current-region >r user-region activate 2848: X here swap X a, tup@ - 2849: r> activate ; 2850: 2851: T has? no-userspace H [IF] 2852: 2853: : buildby 2854: ghost >exec @ built >exec ! ; 2855: 2856: Builder User 2857: buildby Variable 2858: by Variable 2859: 2860: Builder 2User 2861: buildby 2Variable 2862: by 2Variable 2863: 2864: Builder AUser 2865: buildby AVariable 2866: by AVariable 2867: 2868: [ELSE] 2869: 2870: Builder User 2871: Build: 0 u, X , ;Build 2872: by: :douser ( ghost -- up-addr ) X @ tup@ + ;DO 2873: 2874: Builder 2User 2875: Build: 0 u, X , 0 u, drop ;Build 2876: by User 2877: 2878: Builder AUser 2879: Build: 0 au, X , ;Build 2880: by User 2881: 2882: [THEN] 2883: 2884: T has? rom H [IF] 2885: Builder (Value) 2886: Build: ( n -- ) ;Build 2887: by: :dovalue ( target-body-addr -- n ) T @ @ H ;DO 2888: 2889: Builder Value 2890: Build: T here 0 A, H switchram T align here swap ! , H ;Build 2891: by (Value) 2892: 2893: Builder AValue 2894: Build: T here 0 A, H switchram T align here swap ! A, H ;Build 2895: by (Value) 2896: [ELSE] 2897: Builder (Value) 2898: Build: ( n -- ) ;Build 2899: by: :dovalue ( target-body-addr -- n ) T @ H ;DO 2900: 2901: Builder Value 2902: BuildSmart: T , H ;Build 2903: by (Value) 2904: 2905: Builder AValue 2906: BuildSmart: T A, H ;Build 2907: by (Value) 2908: [THEN] 2909: 2910: Defer texecute 2911: 2912: Builder Defer 2913: T has? rom H [IF] 2914: Build: ( -- ) T here 0 A, H switchram T align here swap ! H [T'] noop T A, H ( switchrom ) ;Build 2915: by: :dodefer ( ghost -- ) X @ X @ texecute ;DO 2916: [ELSE] 2917: BuildSmart: ( -- ) [T'] noop T A, H ;Build 2918: by: :dodefer ( ghost -- ) X @ texecute ;DO 2919: [THEN] 2920: 2921: Builder interpret/compile: 2922: Build: ( inter comp -- ) swap T A, A, H ;Build-immediate 2923: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO 2924: 2925: \ Sturctures 23feb95py 2926: 2927: : nalign ( addr1 n -- addr2 ) 2928: \ addr2 is the aligned version of addr1 wrt the alignment size n 2929: 1- tuck + swap invert and ; 2930: 2931: 2932: Builder (Field) 2933: Build: ;Build 2934: by: :dofield T @ H + ;DO 2935: 2936: Builder Field 2937: Build: ( align1 offset1 align size "name" -- align2 offset2 ) 2938: rot dup T , H ( align1 align size offset1 ) 2939: + >r nalign r> ;Build 2940: by (Field) 2941: 2942: >TARGET 2943: : struct T 1 chars 0 H ; 2944: : end-struct T 2Constant H ; 2945: 2946: : cell% ( n -- size align ) 2947: T 1 cells H dup ; 2948: >CROSS 2949: 2950: \ Input-Methods 01py 2951: 2952: Builder input-method 2953: Build: ( m v -- m' v ) dup T , cell+ H ;Build 2954: DO: abort" Not in cross mode" ;DO 2955: 2956: Builder input-var 2957: Build: ( m v size -- m v' ) over T , H + ;Build 2958: DO: abort" Not in cross mode" ;DO 2959: 2960: \ Peephole optimization 05sep01jaw 2961: 2962: \ this section defines different compilation 2963: \ actions for created words 2964: \ this will help the peephole optimizer 2965: \ I (jaw) took this from bernds latest cross-compiler 2966: \ changes but seperated it from the original 2967: \ Builder words. The final plan is to put this 2968: \ into a seperate file, together with the peephole 2969: \ optimizer for cross 2970: 2971: 2972: T has? primcentric H [IF] 2973: 2974: \ .( loading peephole optimization) cr 2975: 2976: >CROSS 2977: 2978: : (callc) compile call T >body a, H ; ' (callc) plugin-of colon, 2979: : (callcm) T here 0 a, 0 a, H ; ' (callcm) plugin-of colonmark, 2980: : (call-res) >tempdp resolved gexecute tempdp> drop ; 2981: ' (call-res) plugin-of colon-resolve 2982: T has? ec H [IF] 2983: : (pprim) T @ H >signed dup 0< IF $4000 - ELSE 2984: cr ." wrong usage of (prim) " 2985: dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN 2986: T a, H ; ' (pprim) plugin-of prim, 2987: [ELSE] 2988: : (pprim) dup 0< IF $4000 - ELSE 2989: cr ." wrong usage of (prim) " 2990: dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN 2991: T a, H ; ' (pprim) plugin-of prim, 2992: [THEN] 2993: 2994: \ if we want this, we have to spilt aconstant 2995: \ and constant!! 2996: \ Builder (Constant) 2997: \ compile: g>body X @ lit, ;compile 2998: 2999: Builder (Constant) 3000: compile: g>body compile lit@ T a, H ;compile 3001: 3002: Builder (Value) 3003: compile: g>body compile lit@ T a, H ;compile 3004: 3005: \ this changes also Variable, AVariable and 2Variable 3006: Builder Create 3007: compile: g>body alit, ;compile 3008: 3009: Builder User 3010: compile: g>body compile useraddr T @ , H ;compile 3011: 3012: Builder Defer 3013: compile: g>body compile lit-perform T A, H ;compile 3014: 3015: Builder (Field) 3016: compile: g>body T @ H compile lit+ T here H reloff T , H ;compile 3017: 3018: Builder interpret/compile: 3019: compile: does-resolved ;compile 3020: 3021: Builder input-method 3022: compile: does-resolved ;compile 3023: 3024: Builder input-var 3025: compile: does-resolved ;compile 3026: 3027: [THEN] 3028: 3029: \ structural conditionals 17dec92py 3030: 3031: >CROSS 3032: : (ncontrols?) ( n -- ) 3033: \g We expect n open control structures 3034: depth over u<= 3035: ABORT" CROSS: unstructured, stack underflow" 3036: 0 ?DO I pick 0= 3037: ABORT" CROSS: unstructured" 3038: LOOP ; ' (ncontrols?) plugin-of ncontrols? 3039: 3040: \ : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; 3041: \ : sys? ( sys -- sys ) dup 0= ?struc ; 3042: 3043: : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; 3044: 3045: X has? abranch [IF] 3046: : branchoffset ( src dest -- ) drop ; 3047: : offset, ( n -- ) X A, ; 3048: [ELSE] 3049: : branchoffset ( src dest -- ) - tchar / ; \ ?? jaw 3050: : offset, ( n -- ) X , ; 3051: [THEN] 3052: 3053: :noname compile branch X here branchoffset offset, ; 3054: IS branch, ( target-addr -- ) 3055: :noname compile ?branch X here branchoffset offset, ; 3056: IS ?branch, ( target-addr -- ) 3057: :noname compile branch T here 0 H offset, ; 3058: IS branchmark, ( -- branchtoken ) 3059: :noname compile ?branch T here 0 H offset, ; 3060: IS ?branchmark, ( -- branchtoken ) 3061: :noname T here 0 H offset, ; 3062: IS ?domark, ( -- branchtoken ) 3063: :noname dup X @ ?struc X here over branchoffset swap X ! ; 3064: IS branchtoresolve, ( branchtoken -- ) 3065: :noname branchto, X here ; 3066: IS branchtomark, ( -- target-addr ) 3067: 3068: >TARGET 3069: 3070: \ Structural Conditionals 12dec92py 3071: 3072: \ CLEANUP Cond: BUT sys? swap ;Cond 3073: \ CLEANUP Cond: YET sys? dup ;Cond 3074: 3075: >CROSS 3076: 3077: Variable tleavings 0 tleavings ! 3078: 3079: : (done) ( do-addr -- ) 3080: \G resolve branches of leave and ?leave and ?do 3081: \G do-addr is the address of the beginning of our 3082: \G loop so we can take care of nested loops 3083: tleavings @ 3084: BEGIN dup 3085: WHILE 3086: >r dup r@ cell+ @ \ address of branch 3087: u> 0= \ lower than DO? 3088: WHILE 3089: r@ 2 cells + @ \ branch token 3090: branchtoresolve, 3091: r@ @ r> free throw 3092: REPEAT r> THEN 3093: tleavings ! drop ; 3094: 3095: >TARGET 3096: 3097: \ What for? ANS? JAW Cond: DONE ( addr -- ) (done) ;Cond 3098: 3099: >CROSS 3100: : (leave) ( branchtoken -- ) 3101: 3 cells allocate throw >r 3102: T here H r@ cell+ ! 3103: r@ 2 cells + ! 3104: tleavings @ r@ ! 3105: r> tleavings ! ; 3106: >TARGET 3107: 3108: : (leave,) ( -- ) 3109: branchmark, (leave) ; ' (leave,) plugin-of leave, 3110: 3111: : (?leave,) ( -- ) 3112: compile 0= ?branchmark, (leave) ; ' (?leave,) plugin-of ?leave, 3113: 3114: Cond: LEAVE leave, ;Cond 3115: Cond: ?LEAVE ?leave, ;Cond 3116: 3117: >CROSS 3118: \ !!JW ToDo : Move to general tools section 3119: 3120: : to1 ( x1 x2 xn n -- addr ) 3121: \G packs n stack elements in am allocated memory region 3122: dup dup 1+ cells allocate throw dup >r swap 1+ 3123: 0 DO tuck ! cell+ LOOP 3124: drop r> ; 3125: 3126: : 1to ( addr -- x1 x2 xn ) 3127: \G unpacks the elements saved by to1 3128: dup @ swap over cells + swap 3129: 0 DO dup @ swap 1 cells - LOOP 3130: free throw ; 3131: 3132: : loop] ( target-addr -- ) 3133: branchto, 3134: dup X here branchoffset offset, 3135: tcell - (done) ; 3136: 3137: : skiploop] ?dup IF branchto, branchtoresolve, THEN ; 3138: 3139: >TARGET 3140: 3141: \ Structural Conditionals 12dec92py 3142: 3143: : (cs-swap) ( x1 x2 -- x2 x1 ) 3144: swap ; ' (cs-swap) plugin-of cs-swap 3145: 3146: : (ahead,) branchmark, ; ' (ahead,) plugin-of ahead, 3147: 3148: : (if,) ?branchmark, ; ' (if,) plugin-of if, 3149: 3150: : (then,) branchto, branchtoresolve, ; ' (then,) plugin-of then, 3151: 3152: : (else,) ( ahead ) branchmark, 3153: swap 3154: ( then ) branchto, branchtoresolve, ; ' (else,) plugin-of else, 3155: 3156: : (begin,) branchtomark, ; ' (begin,) plugin-of begin, 3157: 3158: : (while,) ( if ) ?branchmark, 3159: swap ; ' (while,) plugin-of while, 3160: 3161: : (again,) branch, ; ' (again,) plugin-of again, 3162: 3163: : (until,) ?branch, ; ' (until,) plugin-of until, 3164: 3165: : (repeat,) ( again ) branch, 3166: ( then ) branchto, branchtoresolve, ; ' (repeat,) plugin-of repeat, 3167: 3168: : (case,) ( -- n ) 3169: 0 ; ' (case,) plugin-of case, 3170: 3171: : (of,) ( n -- x1 n ) 3172: 1+ >r 3173: compile over compile = 3174: if, compile drop r> ; ' (of,) plugin-of of, 3175: 3176: : (endof,) ( x1 n -- x2 n ) 3177: >r 1 ncontrols? else, r> ; ' (endof,) plugin-of endof, 3178: 3179: : (endcase,) ( x1 .. xn n -- ) 3180: compile drop 0 ?DO 1 ncontrols? then, LOOP ; ' (endcase,) plugin-of endcase, 3181: 3182: >TARGET 3183: Cond: AHEAD ahead, ;Cond 3184: Cond: IF if, ;Cond 3185: Cond: THEN 1 ncontrols? then, ;Cond 3186: Cond: ENDIF 1 ncontrols? then, ;Cond 3187: Cond: ELSE 1 ncontrols? else, ;Cond 3188: 3189: Cond: BEGIN begin, ;Cond 3190: Cond: WHILE 1 ncontrols? while, ;Cond 3191: Cond: AGAIN 1 ncontrols? again, ;Cond 3192: Cond: UNTIL 1 ncontrols? until, ;Cond 3193: Cond: REPEAT 2 ncontrols? repeat, ;Cond 3194: 3195: Cond: CASE case, ;Cond 3196: Cond: OF of, ;Cond 3197: Cond: ENDOF endof, ;Cond 3198: Cond: ENDCASE endcase, ;Cond 3199: 3200: \ Structural Conditionals 12dec92py 3201: 3202: : (do,) ( -- target-addr ) 3203: \ ?? i think 0 is too much! jaw 3204: 0 compile (do) 3205: branchtomark, 2 to1 ; ' (do,) plugin-of do, 3206: 3207: \ alternative for if no ?do 3208: \ : (do,) 3209: \ compile 2dup compile = compile IF 3210: \ compile 2drop compile ELSE 3211: \ compile (do) branchtomark, 2 to1 ; 3212: 3213: : (?do,) ( -- target-addr ) 3214: 0 compile (?do) ?domark, (leave) 3215: branchtomark, 2 to1 ; ' (?do,) plugin-of ?do, 3216: 3217: : (for,) ( -- target-addr ) 3218: compile (for) branchtomark, ; ' (for,) plugin-of for, 3219: 3220: : (loop,) ( target-addr -- ) 3221: 1to compile (loop) loop] 3222: compile unloop skiploop] ; ' (loop,) plugin-of loop, 3223: 3224: : (+loop,) ( target-addr -- ) 3225: 1to compile (+loop) loop] 3226: compile unloop skiploop] ; ' (+loop,) plugin-of +loop, 3227: 3228: : (next,) 3229: compile (next) loop] compile unloop ; ' (next,) plugin-of next, 3230: 3231: Cond: DO do, ;Cond 3232: Cond: ?DO ?do, ;Cond 3233: Cond: FOR for, ;Cond 3234: 3235: Cond: LOOP 1 ncontrols? loop, ;Cond 3236: Cond: +LOOP 1 ncontrols? +loop, ;Cond 3237: Cond: NEXT 1 ncontrols? next, ;Cond 3238: 3239: \ String words 23feb93py 3240: 3241: : ," [char] " parse ht-string, X align ; 3242: 3243: X has? control-rack [IF] 3244: Cond: ." compile (.") T ," H ;Cond 3245: Cond: S" compile (S") T ," H ;Cond 3246: Cond: C" compile (C") T ," H ;Cond 3247: Cond: ABORT" compile (ABORT") T ," H ;Cond 3248: [ELSE] 3249: Cond: ." '" parse tuck 2>r ahead, there 2r> ht-mem, X align 3250: >r then, r> compile ALiteral compile Literal compile type ;Cond 3251: Cond: S" '" parse tuck 2>r ahead, there 2r> ht-mem, X align 3252: >r then, r> compile ALiteral compile Literal ;Cond 3253: Cond: C" ahead, there [char] " parse ht-string, X align 3254: >r then, r> compile ALiteral ;Cond 3255: Cond: ABORT" if, ahead, there [char] " parse ht-string, X align 3256: >r then, r> compile ALiteral compile c(abort") then, ;Cond 3257: [THEN] 3258: 3259: X has? rom [IF] 3260: Cond: IS T ' >body @ H compile ALiteral compile ! ;Cond 3261: : IS T >address ' >body @ ! H ; 3262: Cond: TO T ' >body @ H compile ALiteral compile ! ;Cond 3263: : TO T ' >body @ ! H ; 3264: Cond: CTO T ' >body H compile ALiteral compile ! ;Cond 3265: : CTO T ' >body ! H ; 3266: [ELSE] 3267: Cond: IS T ' >body H compile ALiteral compile ! ;Cond 3268: : IS T >address ' >body ! H ; 3269: Cond: TO T ' >body H compile ALiteral compile ! ;Cond 3270: : TO T ' >body ! H ; 3271: [THEN] 3272: 3273: Cond: defers T ' >body @ compile, H ;Cond 3274: 3275: \ LINKED ERR" ENV" 2ENV" 18may93jaw 3276: 3277: \ linked list primitive 3278: : linked X here over X @ X A, swap X ! ; 3279: : chained T linked A, H ; 3280: 3281: : err" s" ErrLink linked" evaluate T , H 3282: [char] " parse ht-string, X align ; 3283: 3284: : env" [char] " parse s" EnvLink linked" evaluate 3285: ht-string, X align X , ; 3286: 3287: : 2env" [char] " parse s" EnvLink linked" evaluate 3288: here >r ht-string, X align X , X , 3289: r> dup T c@ H 80 and swap T c! H ; 3290: 3291: \ compile must be last 22feb93py 3292: 3293: Cond: [compile] ( -- ) \ name 3294: \g For immediate words, works even if forward reference 3295: bl word gfind 0= ABORT" CROSS: Can't compile" 3296: (gexecute) ;Cond 3297: 3298: Cond: postpone ( -- ) \ name 3299: bl word gfind 0= ABORT" CROSS: Can't compile" 3300: dup >magic @ <fwd> = 3301: ABORT" CROSS: Can't postpone on forward declaration" 3302: dup >magic @ <imm> = 3303: IF (gexecute) 3304: ELSE >link @ alit, compile compile, THEN ;Cond 3305: 3306: \ save-cross 17mar93py 3307: 3308: hex 3309: 3310: >CROSS 3311: Create magic s" Gforth3x" here over allot swap move 3312: 3313: bigendian 1+ \ strangely, in magic big=0, little=1 3314: tcell 1 = 0 and or 3315: tcell 2 = 2 and or 3316: tcell 4 = 4 and or 3317: tcell 8 = 6 and or 3318: tchar 1 = 00 and or 3319: tchar 2 = 28 and or 3320: tchar 4 = 50 and or 3321: tchar 8 = 78 and or 3322: magic 7 + c! 3323: 3324: : save-cross ( "image-name" "binary-name" -- ) 3325: .regions \ s" ec" X $has? IF .regions THEN 3326: bl parse ." Saving to " 2dup type cr 3327: w/o bin create-file throw >r 3328: s" header" X $has? IF 3329: s" #! " r@ write-file throw 3330: bl parse r@ write-file throw 3331: s" --image-file" r@ write-file throw 3332: #lf r@ emit-file throw 3333: r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) 3334: ?do 3335: bl over emit-file throw 3336: loop 3337: drop 3338: magic 8 r@ write-file throw \ write magic 3339: ELSE 3340: bl parse 2drop 3341: THEN 3342: >rom dictionary >rmem @ there 3343: s" rom" X $has? IF dictionary >rstart @ - THEN 3344: r@ write-file throw \ write image 3345: s" relocate" X $has? IF 3346: dictionary >rbm @ there 1- tcell>bit rshift 1+ 3347: r@ write-file throw \ write tags 3348: THEN 3349: r> close-file throw ; 3350: 3351: : save-region ( addr len -- ) 3352: bl parse w/o bin create-file throw >r 3353: swap >image swap r@ write-file throw 3354: r> close-file throw ; 3355: 3356: \ save-asm-region 29aug01jaw 3357: 3358: Variable name-ptr 3359: Create name-buf 200 chars allot 3360: : init-name-buf name-buf name-ptr ! ; 3361: : nb, name-ptr @ c! 1 chars name-ptr +! ; 3362: : $nb, ( adr len -- ) bounds ?DO I c@ nb, LOOP ; 3363: : @nb name-ptr @ name-buf tuck - ; 3364: 3365: \ stores a usefull string representation of the character 3366: \ in the name buffer 3367: : name-char, ( c -- ) 3368: dup 'a 'z 1+ within IF nb, EXIT THEN 3369: dup 'A 'Z 1+ within IF $20 + nb, EXIT THEN 3370: dup '0 '9 1+ within IF nb, EXIT THEN 3371: CASE '+ OF s" _PLUS" $nb, ENDOF 3372: '- OF s" _MINUS" $nb, ENDOF 3373: '* OF s" _STAR" $nb, ENDOF 3374: '/ OF s" _SLASH" $nb, ENDOF 3375: '' OF s" _TICK" $nb, ENDOF 3376: '( OF s" _OPAREN" $nb, ENDOF 3377: ') OF s" _CPAREN" $nb, ENDOF 3378: '[ OF s" _OBRACKET" $nb, ENDOF 3379: '] OF s" _CBRACKET" $nb, ENDOF 3380: '! OF s" _STORE" $nb, ENDOF 3381: '@ OF s" _FETCH" $nb, ENDOF 3382: '> OF s" _GREATER" $nb, ENDOF 3383: '< OF s" _LESS" $nb, ENDOF 3384: '= OF s" _EQUAL" $nb, ENDOF 3385: '# OF s" _HASH" $nb, ENDOF 3386: '? OF s" _QUEST" $nb, ENDOF 3387: ': OF s" _COL" $nb, ENDOF 3388: '; OF s" _SEMICOL" $nb, ENDOF 3389: ', OF s" _COMMA" $nb, ENDOF 3390: '. OF s" _DOT" $nb, ENDOF 3391: '" OF s" _DQUOT" $nb, ENDOF 3392: dup 3393: base @ >r hex s>d <# #s 'X hold '_ hold #> $nb, r> base ! 3394: ENDCASE ; 3395: 3396: : label-from-ghostname ( ghost -- addr len ) 3397: dup >ghostname init-name-buf 'L nb, bounds 3398: ?DO I c@ name-char, LOOP 3399: \ we add the address to a name to make in unique 3400: \ because one name may appear more then once 3401: \ there are names (e.g. boot) that may be reference from other 3402: \ assembler source files, so we declare them as unique 3403: \ and don't add the address suffix 3404: dup >ghost-flags @ <unique> and 0= 3405: IF s" __" $nb, >link @ base @ >r hex 0 <# #s 'L hold #> r> base ! $nb, 3406: ELSE drop 3407: THEN 3408: @nb ; 3409: 3410: \ FIXME why disabled?! 3411: : label-from-ghostnameXX ( ghost -- addr len ) 3412: \ same as (label-from-ghostname) but caches generated names 3413: dup >asm-name @ ?dup IF nip count EXIT THEN 3414: \ dup >r (label-from-ghostname) 2dup 3415: align here >r string, align 3416: r> r> >asm-name ! ; 3417: 3418: : primghostdiscover ( xt -- ghost true | xt false ) 3419: dup 0= IF false EXIT THEN 3420: >r last-prim-ghost 3421: BEGIN @ dup 3422: WHILE dup >asm-dummyaddr @ r@ = 3423: IF rdrop true EXIT THEN 3424: REPEAT 3425: drop r> false ; 3426: 3427: : gdiscover2 ( xt -- ghost true | xt false ) 3428: dup taddr>region 0= IF false EXIT THEN 3429: dup (>regiontype) @ dup 0= IF drop false EXIT THEN 3430: addr-xt-ghost @ dup 0= IF drop false EXIT THEN 3431: nip true ; 3432: \ dup >ghost-name @ IF nip true ELSE drop false THEN ; 3433: 3434: \ generates a label name for the target address 3435: : generate-label-name ( taddr -- addr len ) 3436: gdiscover2 3437: IF dup >magic @ <do:> = 3438: IF >asm-name @ count EXIT THEN 3439: label-from-ghostname 3440: ELSE 3441: primghostdiscover 3442: IF >asm-name @ count 3443: ELSE base @ >r hex 0 <# #s 'L hold #> r> base ! 3444: THEN 3445: THEN ; 3446: 3447: Variable outfile-fd 3448: 3449: : $out ( adr len -- ) outfile-fd @ write-file throw ; 3450: : nlout newline $out ; 3451: : .ux ( n -- ) 3452: base @ hex swap 0 <# #S #> $out base ! ; 3453: 3454: : save-asm-region-part-aligned ( taddr len -- 'taddr 'len ) 3455: dup cell/ 0 3456: ?DO nlout s" .word " $out over @relbit 3457: IF over X @ generate-label-name $out 3458: ELSE over X @ s" 0x0" $out .ux 3459: THEN 3460: tcell /string 3461: LOOP ; 3462: 3463: : print-bytes ( taddr len n -- taddr' len' ) 3464: over min dup 0> 3465: IF nlout s" .byte " $out 0 3466: ?DO I 0> IF s" , " $out THEN 3467: over X c@ s" 0x0" $out .ux 1 /string 3468: LOOP 3469: THEN ; 3470: 3471: : save-asm-region-part ( addr len -- ) 3472: over dup X aligned swap - ?dup 3473: IF print-bytes THEN 3474: save-asm-region-part-aligned 3475: dup dup X aligned swap - ?dup 3476: IF 2 pick @relbit ABORT" relocated field splitted" 3477: print-bytes 3478: THEN 3479: 2drop ; 3480: 3481: : print-label ( taddr -- ) 3482: nlout generate-label-name $out s" :" $out ; 3483: 3484: : snl-calc ( taddr taddr2 -- ) 3485: tuck over - ; 3486: 3487: : skip-nolables ( taddr -- taddr2 taddr len ) 3488: \G skips memory region where no lables are defined 3489: \G starting from taddr+1 3490: \G Labels will be introduced for each reference mark 3491: \G in addr-refs. 3492: \G This word deals with lables at byte addresses as well. 3493: \G The main idea is to have an intro part which 3494: \G skips until the next cell boundary, the middle part 3495: \G which skips whole cells very efficiently and the third 3496: \G part which skips the bytes to the label in a cell 3497: dup 1+ dup (>regiontype) 3498: ( S taddr taddr-realstart type-addr ) 3499: dup @ dup IF addr-refs @ THEN 3500: swap >r 3501: over align+ tuck tcell swap - rshift swap 0 3502: ?DO dup 1 and 3503: IF drop rdrop snl-calc UNLOOP EXIT THEN 3504: 2/ swap 1+ swap 3505: LOOP 3506: drop r> cell+ 3507: ( S .. taddr2 type-addr ) dup 3508: BEGIN dup @ dup IF addr-refs @ THEN 0= WHILE cell+ REPEAT 3509: dup >r swap - 1 cells / tcell * + r> 3510: ( S .. taddr2+skiplencells type-addr ) 3511: @ addr-refs @ 1 tcell lshift or 3512: BEGIN dup 1 and 0= WHILE swap 1+ swap 2/ REPEAT drop 3513: ( S .. taddr2+skiplencells+skiplenbytes ) 3514: snl-calc ; 3515: 3516: : insert-label ( taddr -- ) 3517: dup 0= IF drop EXIT THEN 3518: \ ignore everything which points outside our memory regions 3519: \ maybe a primitive pointer or whatever 3520: dup taddr>region 0= IF drop EXIT THEN 3521: dup >r (>regiontype) define-addr-struct addr-refs dup @ 3522: r> tcell 1- and 1 swap lshift or swap ! ; 3523: 3524: \ this generates a sorted list of addresses which must be labels 3525: \ it scans therefore a whole region 3526: : generate-label-list-region ( taddr len -- ) 3527: BEGIN over @relbit IF over X @ insert-label THEN 3528: tcell /string dup 0< 3529: UNTIL 2drop ; 3530: 3531: : generate-label-list ( -- ) 3532: region-link 3533: BEGIN @ dup WHILE 3534: dup 0 >rlink - extent 3535: ?dup IF generate-label-list-region ELSE drop THEN 3536: REPEAT drop ; 3537: 3538: : create-outfile ( addr len -- ) 3539: w/o bin create-file throw outfile-fd ! ; 3540: 3541: : close-outfile ( -- ) 3542: outfile-fd @ close-file throw ; 3543: 3544: : (save-asm-region) ( region -- ) 3545: \ ." label list..." 3546: generate-label-list 3547: \ ." ok!" cr 3548: extent ( S taddr len ) 3549: over insert-label 3550: 2dup + dup insert-label >r ( R end-label ) 3551: ( S taddr len ) drop 3552: BEGIN 3553: dup print-label 3554: dup r@ <> WHILE 3555: skip-nolables save-asm-region-part 3556: REPEAT drop rdrop ; 3557: 3558: : lineout ( addr len -- ) 3559: outfile-fd @ write-line throw ; 3560: 3561: : save-asm-region ( region adr len -- ) 3562: create-outfile (save-asm-region) close-outfile ; 3563: 3564: \ \ minimal definitions 3565: 3566: >MINIMAL also minimal 3567: 3568: \ Usefull words 13feb93py 3569: 3570: : KB 400 * ; 3571: 3572: \ \ [IF] [ELSE] [THEN] ... 14sep97jaw 3573: 3574: \ it is useful to define our own structures and not to rely 3575: \ on the words in the host system 3576: \ The words in the host system might be defined with vocabularies 3577: \ this doesn't work with our self-made compile-loop 3578: 3579: Create parsed 20 chars allot \ store word we parsed 3580: 3581: : upcase 3582: parsed count bounds 3583: ?DO I c@ toupper I c! LOOP ; 3584: 3585: : [ELSE] 3586: 1 BEGIN 3587: BEGIN bl word count dup WHILE 3588: comment? 20 umin parsed place upcase parsed count 3589: 2dup s" [IF]" str= >r 3590: 2dup s" [IFUNDEF]" str= >r 3591: 2dup s" [IFDEF]" str= r> or r> or 3592: IF 2drop 1+ 3593: ELSE 2dup s" [ELSE]" str= 3594: IF 2drop 1- dup 3595: IF 1+ 3596: THEN 3597: ELSE 3598: 2dup s" [ENDIF]" str= >r 3599: s" [THEN]" str= r> or 3600: IF 1- THEN 3601: THEN 3602: THEN 3603: ?dup 0= ?EXIT 3604: REPEAT 3605: 2drop refill 0= 3606: UNTIL drop ; immediate 3607: 3608: : [THEN] ( -- ) ; immediate 3609: 3610: : [ENDIF] ( -- ) ; immediate 3611: 3612: : [IF] ( flag -- ) 3613: 0= IF postpone [ELSE] THEN ; immediate 3614: 3615: Cond: [IF] postpone [IF] ;Cond 3616: Cond: [THEN] postpone [THEN] ;Cond 3617: Cond: [ELSE] postpone [ELSE] ;Cond 3618: 3619: \ define new [IFDEF] and [IFUNDEF] 20may93jaw 3620: 3621: : defined? tdefined? ; 3622: : needed? needed? ; 3623: : doer? doer? ; 3624: 3625: \ we want to use IFDEF on compiler directives (e.g. E?) in the source, too 3626: 3627: : directive? 3628: bl word count [ ' target >wordlist ] literal search-wordlist 3629: dup IF nip THEN ; 3630: 3631: : [IFDEF] >in @ directive? swap >in ! 3632: 0= IF tdefined? ELSE name 2drop true THEN 3633: postpone [IF] ; 3634: 3635: : [IFUNDEF] tdefined? 0= postpone [IF] ; 3636: 3637: Cond: [IFDEF] postpone [IFDEF] ;Cond 3638: 3639: Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond 3640: 3641: \ C: \- \+ Conditional Compiling 09jun93jaw 3642: 3643: : C: >in @ tdefined? 0= 3644: IF >in ! X : 3645: ELSE drop 3646: BEGIN bl word dup c@ 3647: IF count comment? s" ;" str= ?EXIT 3648: ELSE refill 0= ABORT" CROSS: Out of Input while C:" 3649: THEN 3650: AGAIN 3651: THEN ; 3652: 3653: : d? d? ; 3654: 3655: : \D ( -- "debugswitch" ) 3656: \G doesn't skip line when debug switch is on 3657: D? 0= IF postpone \ THEN ; 3658: 3659: : \- ( -- "wordname" ) 3660: \G interprets the line if word is not defined 3661: tdefined? IF postpone \ THEN ; 3662: 3663: : \+ ( -- "wordname" ) 3664: \G interprets the line if word is defined 3665: tdefined? 0= IF postpone \ THEN ; 3666: 3667: : \? ( -- "envorinstring" ) 3668: \G Skip line if environmental variable evaluates to false 3669: X has? 0= IF postpone \ THEN ; 3670: 3671: Cond: \- \- ;Cond 3672: Cond: \+ \+ ;Cond 3673: Cond: \D \D ;Cond 3674: Cond: \? \? ;Cond 3675: 3676: : ?? bl word find IF execute ELSE drop 0 THEN ; 3677: 3678: : needed: 3679: \G defines ghost for words that we want to be compiled 3680: BEGIN >in @ bl word c@ WHILE >in ! Ghost drop REPEAT drop ; 3681: 3682: \ words that should be in minimal 3683: 3684: create s-buffer 50 chars allot 3685: 3686: bigendian Constant bigendian 3687: 3688: : here there ; 3689: : equ constant ; 3690: : mark there constant ; 3691: 3692: \ compiler directives 3693: : >ram >ram ; 3694: : >rom >rom ; 3695: : >auto >auto ; 3696: : >tempdp >tempdp ; 3697: : tempdp> tempdp> ; 3698: : const constflag on ; 3699: 3700: : Redefinitions-start 3701: \G Starts a redefinition section. Warnings are disabled and 3702: \G existing ghosts are reused. This is used in the kernel 3703: \G where ( and \ and the like are redefined 3704: twarnings off warnings off reuse-ghosts on ; 3705: 3706: : Redefinitions-end 3707: \G Ends a redefinition section. Warnings are enabled again. 3708: twarnings on warnings on reuse-ghosts off ; 3709: 3710: : warnings name 3 = 3711: IF twarnings off warnings off ELSE twarnings on warnings on THEN drop ; 3712: 3713: : | ; 3714: \ : | NoHeaderFlag on ; \ This is broken (damages the last word) 3715: 3716: : save-cross save-cross ; 3717: : save-region save-region ; 3718: : tdump swap >image swap dump ; 3719: 3720: also forth 3721: [IFDEF] Label : Label defempty? Label ; [THEN] 3722: [IFDEF] start-macros : start-macros defempty? start-macros ; [THEN] 3723: \ [IFDEF] builttag : builttag builttag ; [THEN] 3724: previous 3725: 3726: : s" [char] " parse s-buffer place s-buffer count ; \ for environment? 3727: : + + ; 3728: : 1+ 1 + ; 3729: : 2+ 2 + ; 3730: : 1- 1- ; 3731: : - - ; 3732: : and and ; 3733: : or or ; 3734: : 2* 2* ; 3735: : * * ; 3736: : / / ; 3737: : dup dup ; 3738: : ?dup ?dup ; 3739: : over over ; 3740: : swap swap ; 3741: : rot rot ; 3742: : drop drop ; 3743: : 2drop 2drop ; 3744: : = = ; 3745: : <> <> ; 3746: : 0= 0= ; 3747: : lshift lshift ; 3748: : 2/ 2/ ; 3749: : hex. base @ $10 base ! swap . base ! ; 3750: : invert invert ; 3751: : linkstring ( addr u n addr -- ) 3752: X here over X @ X , swap X ! X , ht-string, X align ; 3753: \ : . . ; 3754: 3755: : all-words ['] forced? IS skip? ; 3756: : needed-words ['] needed? IS skip? ; 3757: : undef-words ['] defined2? IS skip? ; 3758: : skipdef skipdef ; 3759: 3760: : \ postpone \ ; immediate 3761: : \G T-\G ; immediate 3762: : ( postpone ( ; immediate 3763: : include bl word count included ; 3764: : included swap >image swap included ; 3765: : require require ; 3766: : needs require ; 3767: : .( [char] ) parse type ; 3768: : ERROR" [char] " parse 3769: rot 3770: IF cr ." *** " type ." ***" -1 ABORT" CROSS: Target error, see text above" 3771: ELSE 2drop 3772: THEN ; 3773: : ." [char] " parse type ; 3774: : cr cr ; 3775: 3776: : times 0 ?DO dup X c, LOOP drop ; \ used for space table creation 3777: 3778: \ only forth also cross also minimal definitions order 3779: 3780: \ cross-compiler words 3781: 3782: : decimal decimal [g'] decimal >exec2 @ ?dup IF EXECUTE THEN ; 3783: : hex hex [g'] hex >exec2 @ ?dup IF EXECUTE THEN ; 3784: 3785: \ : tudp X tudp ; 3786: \ : tup X tup ; 3787: 3788: : doc-off false to-doc ! ; 3789: : doc-on true to-doc ! ; 3790: 3791: : declareunique ( "name" -- ) 3792: \ Sets the unique flag for a ghost. The assembler output 3793: \ generates labels with the ghostname concatenated with the address 3794: \ while cross-compiling. The address is concatenated 3795: \ because we have double occurences of the same name. 3796: \ If we want to reference the labels from the assembler or C 3797: \ code we declare them unique, so the address is skipped. 3798: Ghost >ghost-flags dup @ <unique> or swap ! ; 3799: 3800: \ [IFDEF] dbg : dbg dbg ; [THEN] 3801: 3802: \ for debugging... 3803: \ : dbg dbg ; 3804: : horder order ; 3805: : hwords words ; 3806: \ : words also ghosts 3807: \ words previous ; 3808: : .s .s ; 3809: : depth depth ; 3810: : bye bye ; 3811: 3812: \ dummy 3813: 3814: \ turnkey direction 3815: : H forth ; immediate 3816: : T minimal ; immediate 3817: : G ghosts ; immediate 3818: 3819: 3820: \ these ones are pefered: 3821: 3822: : unlock previous forth also cross ; 3823: 3824: \ also minimal 3825: >cross 3826: 3827: : turnkey 3828: ghosts-wordlist 1 set-order 3829: also target definitions 3830: also Minimal also ; 3831: 3832: >minimal 3833: 3834: : [[+++ 3835: turnkey unlock ; 3836: 3837: unlock definitions also minimal 3838: 3839: : lock turnkey ; 3840: 3841: Defer +++]]-hook 3842: : +++]] +++]]-hook lock ; 3843: 3844: LOCK 3845: \ load cross compiler extension defined in mach file 3846: 3847: UNLOCK >CROSS 3848: 3849: [IFDEF] extend-cross extend-cross [THEN] 3850: 3851: LOCK