gforth/cross.fs - view

File: [gforth] / gforth / cross.fs
Revision 1.175: download - view: text, annotated - select for diffs
Fri Dec 31 18:09:02 2010 UTC (13 years, 3 months ago) by anton
Branches: MAIN
CVS tags: HEAD

updated copyright years

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