gforth/cross.fs - view

File: [gforth] / gforth / cross.fs
Revision 1.29: download - view: text, annotated - select for diffs
Sat Oct 7 17:38:11 1995 UTC (27 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD

added code.fs (code, ;code, end-code, assembler)
renamed dostruc to dofield
made index and doc-entries nicer
Only words containing 'e' or 'E' are converted to FP numbers.
added many wordset comments
added flush-icache primitive and FLUSH_ICACHE macro
added +DO, U+DO, -DO, U-DO and -LOOP
added code address labels (`docol:' etc.)
fixed sparc cache_flush

1: \ CROSS.FS The Cross-Compiler 06oct92py 2: \ $Id: cross.fs,v 1.29 1995/10/07 17:38:11 anton Exp $ 3: \ Idea and implementation: Bernd Paysan (py) 4: \ Copyright 1992-94 by the GNU Forth Development Group 5: 6: \ Log: 7: \ changed in ; [ to state off 12may93jaw 8: \ included place +place 12may93jaw 9: \ for a created word (variable, constant...) 10: \ is now an alias in the target voabulary. 11: \ this means it is no longer necessary to 12: \ switch between vocabularies for variable 13: \ initialization 12may93jaw 14: \ discovered error in DOES> 15: \ replaced !does with (;code) 16may93jaw 16: \ made complete redesign and 17: \ introduced two vocs method 18: \ to be asure that the right words 19: \ are found 08jun93jaw 20: \ btw: ! works not with 16 bit 21: \ targets 09jun93jaw 22: \ added: 2user and value 11jun93jaw 23: 24: \ include other.fs \ ansforth extentions for cross 25: 26: : string, ( c-addr u -- ) 27: \ puts down string as cstring 28: dup c, here swap chars dup allot move ; 29: ' falign Alias cfalign 30: : comment? ( c-addr u -- c-addr u ) 31: 2dup s" (" compare 0= 32: IF postpone ( 33: ELSE 2dup s" \" compare 0= IF postpone \ THEN 34: THEN ; 35: 36: decimal 37: 38: \ Begin CROSS COMPILER: 39: 40: \ GhostNames 9may93jaw 41: \ second name source to search trough list 42: 43: VARIABLE GhostNames 44: 0 GhostNames ! 45: : GhostName ( -- addr ) 46: here GhostNames @ , GhostNames ! here 0 , 47: bl word count 48: \ 2dup type space 49: string, cfalign ; 50: 51: hex 52: 53: 54: Vocabulary Cross 55: Vocabulary Target 56: Vocabulary Ghosts 57: VOCABULARY Minimal 58: only Forth also Target also also 59: definitions Forth 60: 61: : T previous Cross also Target ; immediate 62: : G Ghosts ; immediate 63: : H previous Forth also Cross ; immediate 64: 65: forth definitions 66: 67: : T previous Cross also Target ; immediate 68: : G Ghosts ; immediate 69: 70: : >cross also Cross definitions previous ; 71: : >target also Target definitions previous ; 72: : >minimal also Minimal definitions previous ; 73: 74: H 75: 76: >CROSS 77: 78: \ Variables 06oct92py 79: 80: -1 Constant NIL 81: Variable image 82: Variable tlast NIL tlast ! \ Last name field 83: Variable tlastcfa \ Last code field 84: Variable tdoes \ Resolve does> calls 85: Variable bit$ 86: Variable tdp 87: : there tdp @ ; 88: 89: \ Parameter for target systems 06oct92py 90: 91: included 92: 93: \ Create additional parameters 19jan95py 94: 95: T 96: cell Constant tcell 97: cell<< Constant tcell<< 98: cell>bit Constant tcell>bit 99: bits/byte Constant tbits/byte 100: float Constant tfloat 101: 1 bits/byte lshift Constant maxbyte 102: H 103: 104: >TARGET 105: 106: \ Byte ordering and cell size 06oct92py 107: 108: : cell+ tcell + ; 109: : cells tcell<< lshift ; 110: : chars ; 111: : floats tfloat * ; 112: 113: >CROSS 114: : cell/ tcell<< rshift ; 115: >TARGET 116: 20 CONSTANT bl 117: -1 Constant NIL 118: -2 Constant :docol 119: -3 Constant :docon 120: -4 Constant :dovar 121: -5 Constant :douser 122: -6 Constant :dodefer 123: -7 Constant :dofield 124: -8 Constant :dodoes 125: -9 Constant :doesjump 126: 127: >CROSS 128: 129: bigendian 130: [IF] 131: : T! ( n addr -- ) >r s>d r> tcell bounds swap 1- 132: DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ; 133: : T@ ( addr -- n ) >r 0 0 r> tcell bounds 134: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ; 135: [ELSE] 136: : T! ( n addr -- ) >r s>d r> tcell bounds 137: DO maxbyte ud/mod rot I c! LOOP 2drop ; 138: : T@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1- 139: DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; 140: [THEN] 141: 142: \ Memory initialisation 05dec92py 143: \ Fixed bug in else part 11may93jaw 144: 145: [IFDEF] Memory \ Memory is a bigFORTH feature 146: also Memory 147: : initmem ( var len -- ) 148: 2dup swap handle! >r @ r> erase ; 149: toss 150: [ELSE] 151: : initmem ( var len -- ) 152: tuck allocate abort" CROSS: No memory for target" 153: ( len var adr ) dup rot ! 154: ( len adr ) swap erase ; 155: [THEN] 156: 157: \ MakeKernal 12dec92py 158: 159: >MINIMAL 160: : makekernal ( targetsize -- targetsize ) 161: bit$ over 1- cell>bit rshift 1+ initmem 162: image over initmem tdp off ; 163: 164: >CROSS 165: \ Bit string manipulation 06oct92py 166: \ 9may93jaw 167: CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, 168: : bits ( n -- n ) chars Bittable + c@ ; 169: 170: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; 171: : +bit ( addr n -- ) >bit over c@ or swap c! ; 172: : -bit ( addr n -- ) >bit invert over c@ and swap c! ; 173: : relon ( taddr -- ) bit$ @ swap cell/ +bit ; 174: : reloff ( taddr -- ) bit$ @ swap cell/ -bit ; 175: 176: \ Target memory access 06oct92py 177: 178: : align+ ( taddr -- rest ) 179: cell tuck 1- and - [ cell 1- ] Literal and ; 180: : cfalign+ ( taddr -- rest ) 181: \ see kernal.fs:cfaligned 182: float tuck 1- and - [ float 1- ] Literal and ; 183: 184: >TARGET 185: : aligned ( taddr -- ta-addr ) dup align+ + ; 186: \ assumes cell alignment granularity (as GNU C) 187: 188: : cfaligned ( taddr1 -- taddr2 ) 189: \ see kernal.fs 190: dup cfalign+ + ; 191: 192: >CROSS 193: : >image ( taddr -- absaddr ) image @ + ; 194: >TARGET 195: : @ ( taddr -- w ) >image t@ ; 196: : ! ( w taddr -- ) >image t! ; 197: : c@ ( taddr -- char ) >image c@ ; 198: : c! ( char taddr -- ) >image c! ; 199: : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; 200: : 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ; 201: 202: \ Target compilation primitives 06oct92py 203: \ included A! 16may93jaw 204: 205: : here ( -- there ) there ; 206: : allot ( n -- ) tdp +! ; 207: : , ( w -- ) T here H cell T allot ! H ; 208: : c, ( char -- ) T here 1 allot c! H ; 209: : align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; 210: : cfalign ( -- ) 211: T here H cfalign+ 0 ?DO bl T c, H LOOP ; 212: 213: : A! dup relon T ! H ; 214: : A, ( w -- ) T here H relon T , H ; 215: 216: >CROSS 217: 218: \ threading modell 13dec92py 219: 220: \ generic threading modell 221: : docol, ( -- ) :docol T A, 0 , H ; 222: 223: >TARGET 224: : >body ( cfa -- pfa ) T cell+ cell+ H ; 225: >CROSS 226: 227: : dodoes, ( -- ) T :doesjump A, 0 , H ; 228: 229: \ Ghost Builder 06oct92py 230: 231: \ <T T> new version with temp variable 10may93jaw 232: 233: VARIABLE VocTemp 234: 235: : <T get-current VocTemp ! also Ghosts definitions ; 236: : T> previous VocTemp @ set-current ; 237: 238: 4711 Constant <fwd> 4712 Constant <res> 239: 4713 Constant <imm> 240: 241: \ iForth makes only immediate directly after create 242: \ make atonce trick! ? 243: 244: Variable atonce atonce off 245: 246: : NoExec true ABORT" CROSS: Don't execute ghost" ; 247: 248: : GhostHeader <fwd> , 0 , ['] NoExec , ; 249: 250: : >magic ; : >link cell+ ; : >exec cell+ cell+ ; 251: : >end 3 cells + ; 252: 253: Variable last-ghost 254: : Make-Ghost ( "name" -- ghost ) 255: >in @ GhostName swap >in ! 256: <T Create atonce @ IF immediate atonce off THEN 257: here tuck swap ! ghostheader T> 258: DOES> dup last-ghost ! >exec @ execute ; 259: 260: \ ghost words 14oct92py 261: \ changed: 10may93py/jaw 262: 263: : gfind ( string -- ghost true/1 / string false ) 264: \ searches for string in word-list ghosts 265: \ !! wouldn't it be simpler to just use search-wordlist ? ae 266: dup count [ ' ghosts >body ] ALiteral search-wordlist 267: dup IF >r >body nip r> THEN ; 268: 269: VARIABLE Already 270: 271: : ghost ( "name" -- ghost ) 272: Already off 273: >in @ bl word gfind IF Already on nip EXIT THEN 274: drop >in ! Make-Ghost ; 275: 276: \ resolve 14oct92py 277: 278: : resolve-loop ( ghost tcfa -- ghost tcfa ) 279: >r dup >link @ 280: BEGIN dup WHILE dup T @ H r@ rot T ! H REPEAT drop r> ; 281: 282: \ exists 9may93jaw 283: 284: : exists ( ghost tcfa -- ) 285: over GhostNames 286: BEGIN @ dup 287: WHILE 2dup cell+ @ = 288: UNTIL 289: 2 cells + count cr ." CROSS: Exists: " type 4 spaces drop 290: swap cell+ ! 291: ELSE true abort" CROSS: Ghostnames inconsistent " 292: THEN ; 293: 294: : resolve ( ghost tcfa -- ) 295: over >magic @ <fwd> <> IF exists EXIT THEN 296: resolve-loop over >link ! <res> swap >magic ! ; 297: 298: \ gexecute ghost, 01nov92py 299: 300: : do-forward ( ghost -- ) 301: >link dup @ there rot ! T A, H ; 302: : do-resolve ( ghost -- ) 303: >link @ T A, H ; 304: 305: : gexecute ( ghost -- ) dup @ 306: <fwd> = IF do-forward ELSE do-resolve THEN ; 307: : ghost, ghost gexecute ; 308: 309: \ .unresolved 11may93jaw 310: 311: variable ResolveFlag 312: 313: \ ?touched 11may93jaw 314: 315: : ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @ 316: 0 <> and ; 317: 318: : ?resolved ( ghostname -- ) 319: dup cell+ @ ?touched 320: IF cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ; 321: 322: >MINIMAL 323: : .unresolved ( -- ) 324: ResolveFlag off cr ." Unresolved: " 325: Ghostnames 326: BEGIN @ dup 327: WHILE dup ?resolved 328: REPEAT drop ResolveFlag @ 329: IF 330: abort" Unresolved words!" 331: ELSE 332: ." Nothing!" 333: THEN 334: cr ; 335: 336: >CROSS 337: \ Header states 12dec92py 338: 339: : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; 340: 341: VARIABLE ^imm 342: 343: >TARGET 344: : immediate 20 flag! 345: ^imm @ @ dup <imm> = IF drop EXIT THEN 346: <res> <> ABORT" CROSS: Cannot immediate a unresolved word" 347: <imm> ^imm @ ! ; 348: : restrict 40 flag! ; 349: >CROSS 350: 351: \ ALIAS2 ansforth conform alias 9may93jaw 352: 353: : ALIAS2 create here 0 , DOES> @ execute ; 354: \ usage: 355: \ ' <name> alias2 bla ! 356: 357: \ Target Header Creation 01nov92py 358: 359: : string, ( addr count -- ) 360: dup T c, H bounds ?DO I c@ T c, H LOOP ; 361: : name, ( "name" -- ) bl word count string, T cfalign H ; 362: : view, ( -- ) ( dummy ) ; 363: 364: \ Target Document Creation (goes to crossdoc.fd) 05jul95py 365: 366: s" crossdoc.fd" r/w create-file throw value doc-file-id 367: \ contains the file-id of the documentation file 368: 369: : \G ( -- ) 370: source >in @ /string doc-file-id write-line throw 371: source >in ! drop ; immediate 372: 373: Variable to-doc 374: 375: : cross-doc-entry ( -- ) 376: to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header 377: IF 378: s" " doc-file-id write-line throw 379: s" make-doc " doc-file-id write-file throw 380: tlast @ >image count $1F and doc-file-id write-file throw 381: >in @ 382: [char] ( parse 2drop 383: [char] ) parse doc-file-id write-file throw 384: s" )" doc-file-id write-file throw 385: [char] \ parse 2drop 386: POSTPONE \g 387: >in ! 388: THEN to-doc on ; 389: 390: \ Target TAGS creation 391: 392: s" TAGS" r/w create-file throw value tag-file-id 393: \ contains the file-id of the tags file 394: 395: Create tag-beg 2 c, 7F c, bl c, 396: Create tag-end 2 c, bl c, 01 c, 397: Create tag-bof 1 c, 0C c, 398: 399: 2variable last-loadfilename 0 0 last-loadfilename 2! 400: 401: : put-load-file-name ( -- ) 402: loadfilename 2@ last-loadfilename 2@ d<> 403: IF 404: tag-bof count tag-file-id write-line throw 405: loadfilename 2@ 2dup 406: tag-file-id write-file throw 407: last-loadfilename 2! 408: s" ,0" tag-file-id write-line throw 409: THEN ; 410: 411: : cross-tag-entry ( -- ) 412: tlast @ 0<> \ not an anonymous (i.e. noname) header 413: IF 414: put-load-file-name 415: source >in @ min tag-file-id write-file throw 416: tag-beg count tag-file-id write-file throw 417: tlast @ >image count $1F and tag-file-id write-file throw 418: tag-end count tag-file-id write-file throw 419: base @ decimal loadline @ 0 <# #s #> tag-file-id write-file throw 420: \ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw 421: s" ,0" tag-file-id write-line throw 422: base ! 423: THEN ; 424: 425: \ Target header creation 426: 427: VARIABLE CreateFlag CreateFlag off 428: 429: : (Theader ( "name" -- ghost ) T align H view, 430: tlast @ dup 0> IF T 1 cells - THEN A, H there tlast ! 431: >in @ name, >in ! T here H tlastcfa ! 432: CreateFlag @ IF 433: >in @ alias2 swap >in ! \ create alias in target 434: >in @ ghost swap >in ! 435: swap also ghosts ' previous swap ! \ tick ghost and store in alias 436: CreateFlag off 437: ELSE ghost THEN 438: dup >magic ^imm ! \ a pointer for immediate 439: Already @ IF dup >end tdoes ! 440: ELSE 0 tdoes ! THEN 441: 80 flag! 442: cross-doc-entry cross-tag-entry ; 443: 444: VARIABLE ;Resolve 1 cells allot 445: 446: : Theader ( "name" -- ghost ) 447: (THeader dup there resolve 0 ;Resolve ! ; 448: 449: >TARGET 450: : Alias ( cfa -- ) \ name 451: dup 0< IF to-doc off THEN 452: (THeader over resolve T A, H 80 flag! ; 453: >CROSS 454: 455: \ Conditionals and Comments 11may93jaw 456: 457: : ;Cond 458: postpone ; 459: swap ! ; immediate 460: 461: : Cond: ( -- ) \ name {code } ; 462: atonce on 463: ghost 464: >exec 465: :NONAME ; 466: 467: : restrict? ( -- ) 468: \ aborts on interprete state - ae 469: state @ 0= ABORT" CROSS: Restricted" ; 470: 471: : Comment ( -- ) 472: >in @ atonce on ghost swap >in ! ' swap >exec ! ; 473: 474: Comment ( Comment \ 475: 476: \ Predefined ghosts 12dec92py 477: 478: ghost 0= drop 479: ghost branch ghost ?branch 2drop 480: ghost (do) ghost (?do) 2drop 481: ghost (for) drop 482: ghost (loop) ghost (+loop) 2drop 483: ghost (next) drop 484: ghost unloop ghost ;S 2drop 485: ghost lit ghost (compile) ghost ! 2drop drop 486: ghost (does>) ghost noop 2drop 487: ghost (.") ghost (S") ghost (ABORT") 2drop drop 488: ghost ' 489: 490: \ compile 10may93jaw 491: 492: : compile ( -- ) \ name 493: restrict? 494: bl word gfind dup 0= ABORT" CROSS: Can't compile " 495: 0> ( immediate? ) 496: IF >exec @ compile, 497: ELSE postpone literal postpone gexecute THEN ; 498: immediate 499: 500: >TARGET 501: : ' ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined " 502: dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ; 503: 504: Cond: ['] compile lit ghost gexecute ;Cond 505: 506: Cond: chars ;Cond 507: 508: >CROSS 509: \ tLiteral 12dec92py 510: 511: : lit, ( n -- ) compile lit T , H ; 512: : alit, ( n -- ) compile lit T A, H ; 513: 514: >TARGET 515: Cond: Literal ( n -- ) restrict? lit, ;Cond 516: Cond: ALiteral ( n -- ) restrict? alit, ;Cond 517: 518: : Char ( "<char>" -- ) bl word char+ c@ ; 519: Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond 520: 521: >CROSS 522: \ Target compiling loop 12dec92py 523: \ ">tib trick thrown out 10may93jaw 524: \ number? defined at the top 11may93jaw 525: 526: \ compiled word might leave items on stack! 527: : tcom ( in name -- ) 528: gfind ?dup IF 0> IF nip >exec @ execute 529: ELSE nip gexecute THEN EXIT THEN 530: number? dup IF 0> IF swap lit, THEN lit, drop 531: ELSE 2drop >in ! 532: ghost gexecute THEN ; 533: 534: >TARGET 535: \ : ; DOES> 13dec92py 536: \ ] 9may93py/jaw 537: 538: : ] state on 539: BEGIN 540: BEGIN >in @ bl word 541: dup c@ 0= WHILE 2drop refill 0= 542: ABORT" CROSS: End of file while target compiling" 543: REPEAT 544: tcom 545: state @ 546: 0= 547: UNTIL ; 548: 549: \ by the way: defining a second interpreter (a compiler-)loop 550: \ is not allowed if a system should be ans conform 551: 552: : : ( -- colon-sys ) \ Name 553: (THeader ;Resolve ! there ;Resolve cell+ ! 554: docol, depth T ] H ; 555: 556: Cond: EXIT ( -- ) restrict? compile ;S ;Cond 557: 558: Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond 559: 560: Cond: ; ( -- ) restrict? 561: depth ?dup IF 1- <> ABORT" CROSS: Stack changed" 562: ELSE true ABORT" CROSS: Stack empty" THEN 563: compile ;S state off 564: ;Resolve @ 565: IF ;Resolve @ ;Resolve cell+ @ resolve THEN 566: ;Cond 567: Cond: [ restrict? state off ;Cond 568: 569: >CROSS 570: : !does :dodoes tlastcfa @ tuck T ! cell+ ! H ; 571: 572: >TARGET 573: Cond: DOES> restrict? 574: compile (does>) dodoes, tdoes @ ?dup IF @ T here H resolve THEN 575: ;Cond 576: : DOES> dodoes, T here H !does depth T ] H ; 577: 578: >CROSS 579: \ Creation 01nov92py 580: 581: \ Builder 11may93jaw 582: 583: : Builder ( Create do: "name" -- ) 584: >in @ alias2 swap dup >in ! >r >r 585: Make-Ghost rot swap >exec ! , 586: r> r> >in ! 587: also ghosts ' previous swap ! ; 588: \ DOES> dup >exec @ execute ; 589: 590: : gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <> 591: IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN 592: :dodoes T A, H gexecute T here H cell - reloff ; 593: 594: : TCreate ( -- ) 595: last-ghost @ 596: CreateFlag on 597: Theader >r dup gdoes, 598: >end @ >exec @ r> >exec ! ; 599: 600: : Build: ( -- [xt] [colon-sys] ) 601: :noname postpone TCreate ; 602: 603: : gdoes> ( ghost -- addr flag ) 604: last-ghost @ 605: state @ IF gexecute true EXIT THEN 606: cell+ @ T >body H false ; 607: 608: \ DO: ;DO 11may93jaw 609: \ changed to ?EXIT 10may93jaw 610: 611: : DO: ( -- addr [xt] [colon-sys] ) 612: here ghostheader 613: :noname postpone gdoes> postpone ?EXIT ; 614: 615: : ;DO ( addr [xt] [colon-sys] -- ) 616: postpone ; ( S addr xt ) 617: over >exec ! ; immediate 618: 619: : by ( -- addr ) \ Name 620: ghost >end @ ; 621: 622: >TARGET 623: \ Variables and Constants 05dec92py 624: 625: Build: ; 626: DO: ( ghost -- addr ) ;DO 627: Builder Create 628: by Create :dovar resolve 629: 630: Build: T 0 , H ; 631: by Create 632: Builder Variable 633: 634: Build: T 0 A, H ; 635: by Create 636: Builder AVariable 637: 638: \ User variables 04may94py 639: 640: >CROSS 641: Variable tup 0 tup ! 642: Variable tudp 0 tudp ! 643: : u, ( n -- udp ) 644: tup @ tudp @ + T ! H 645: tudp @ dup T cell+ H tudp ! ; 646: : au, ( n -- udp ) 647: tup @ tudp @ + T A! H 648: tudp @ dup T cell+ H tudp ! ; 649: >TARGET 650: 651: Build: T 0 u, , H ; 652: DO: ( ghost -- up-addr ) T @ H tup @ + ;DO 653: Builder User 654: by User :douser resolve 655: 656: Build: T 0 u, , 0 u, drop H ; 657: by User 658: Builder 2User 659: 660: Build: T 0 au, , H ; 661: by User 662: Builder AUser 663: 664: Build: ( n -- ) T , H ; 665: DO: ( ghost -- n ) T @ H ;DO 666: Builder Constant 667: by Constant :docon resolve 668: 669: Build: ( n -- ) T A, H ; 670: by Constant 671: Builder AConstant 672: 673: Build: ( d -- ) T , , H ; 674: DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO 675: Builder 2Constant 676: 677: Build: T 0 , H ; 678: by Constant 679: Builder Value 680: 681: Build: ( -- ) compile noop ; 682: DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO 683: Builder Defer 684: by Defer :dodefer resolve 685: 686: \ Sturctures 23feb95py 687: 688: >CROSS 689: : nalign ( addr1 n -- addr2 ) 690: \ addr2 is the aligned version of addr1 wrt the alignment size n 691: 1- tuck + swap invert and ; 692: >TARGET 693: 694: Build: >r rot r@ nalign dup T , H ( align1 size offset ) 695: + swap r> nalign ; 696: DO: T @ H + ;DO 697: Builder Field 698: by Field :dofield resolve 699: 700: : struct T 0 1 chars H ; 701: : end-struct T 2Constant H ; 702: 703: : cells: ( n -- size align ) 704: T cells 1 cells H ; 705: 706: \ ' 2Constant Alias2 end-struct 707: \ 0 1 T Chars H 2Constant struct 708: 709: \ structural conditionals 17dec92py 710: 711: >CROSS 712: : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; 713: : sys? ( sys -- sys ) dup 0= ?struc ; 714: : >mark ( -- sys ) T here 0 , H ; 715: : >resolve ( sys -- ) T here over - swap ! H ; 716: : <resolve ( sys -- ) T here - , H ; 717: >TARGET 718: 719: \ Structural Conditionals 12dec92py 720: 721: Cond: BUT restrict? sys? swap ;Cond 722: Cond: YET restrict? sys? dup ;Cond 723: 724: >CROSS 725: Variable tleavings 726: >TARGET 727: 728: Cond: DONE ( addr -- ) restrict? tleavings @ 729: BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT 730: tleavings ! drop ;Cond 731: 732: >CROSS 733: : (leave T here H tleavings @ T , H tleavings ! ; 734: >TARGET 735: 736: Cond: LEAVE restrict? compile branch (leave ;Cond 737: Cond: ?LEAVE restrict? compile 0= compile ?branch (leave ;Cond 738: 739: \ Structural Conditionals 12dec92py 740: 741: Cond: AHEAD restrict? compile branch >mark ;Cond 742: Cond: IF restrict? compile ?branch >mark ;Cond 743: Cond: THEN restrict? sys? dup T @ H ?struc >resolve ;Cond 744: Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond 745: 746: Cond: BEGIN restrict? T here H ;Cond 747: Cond: WHILE restrict? sys? compile IF swap ;Cond 748: Cond: AGAIN restrict? sys? compile branch <resolve ;Cond 749: Cond: UNTIL restrict? sys? compile ?branch <resolve ;Cond 750: Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond 751: 752: \ Structural Conditionals 12dec92py 753: 754: Cond: DO restrict? compile (do) T here H ;Cond 755: Cond: ?DO restrict? compile (?do) (leave T here H ;Cond 756: Cond: FOR restrict? compile (for) T here H ;Cond 757: 758: >CROSS 759: : loop] dup <resolve cell - compile DONE compile unloop ; 760: >TARGET 761: 762: Cond: LOOP restrict? sys? compile (loop) loop] ;Cond 763: Cond: +LOOP restrict? sys? compile (+loop) loop] ;Cond 764: Cond: NEXT restrict? sys? compile (next) loop] ;Cond 765: 766: \ String words 23feb93py 767: 768: : ," [char] " parse string, T align H ; 769: 770: Cond: ." restrict? compile (.") T ," H ;Cond 771: Cond: S" restrict? compile (S") T ," H ;Cond 772: Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond 773: 774: Cond: IS T ' >body H compile ALiteral compile ! ;Cond 775: : IS T ' >body ! H ; 776: Cond: TO T ' >body H compile ALiteral compile ! ;Cond 777: : TO T ' >body ! H ; 778: 779: \ LINKED ERR" ENV" 2ENV" 18may93jaw 780: 781: \ linked list primitive 782: : linked T here over @ A, swap ! H ; 783: 784: : err" s" ErrLink linked" evaluate T , H 785: [char] " parse string, T align H ; 786: 787: : env" [char] " parse s" EnvLink linked" evaluate 788: string, T align , H ; 789: 790: : 2env" [char] " parse s" EnvLink linked" evaluate 791: here >r string, T align , , H 792: r> dup T c@ H 80 and swap T c! H ; 793: 794: \ compile must be last 22feb93py 795: 796: Cond: compile ( -- ) restrict? \ name 797: bl word gfind dup 0= ABORT" CROSS: Can't compile" 798: 0> IF gexecute 799: ELSE dup >magic @ <imm> = 800: IF gexecute 801: ELSE compile (compile) gexecute THEN THEN ;Cond 802: 803: Cond: postpone ( -- ) restrict? \ name 804: bl word gfind dup 0= ABORT" CROSS: Can't compile" 805: 0> IF gexecute 806: ELSE dup >magic @ <imm> = 807: IF gexecute 808: ELSE compile (compile) gexecute THEN THEN ;Cond 809: 810: >MINIMAL 811: also minimal 812: \ Usefull words 13feb93py 813: 814: : KB 400 * ; 815: 816: \ define new [IFDEF] and [IFUNDEF] 20may93jaw 817: 818: : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ; 819: 820: : [IFDEF] there? postpone [IF] ; 821: : [IFUNDEF] there? 0= postpone [IF] ; 822: 823: \ C: \- \+ Conditional Compiling 09jun93jaw 824: 825: : C: >in @ there? 0= 826: IF >in ! T : H 827: ELSE drop 828: BEGIN bl word dup c@ 829: IF count comment? s" ;" compare 0= ?EXIT 830: ELSE refill 0= ABORT" CROSS: Out of Input while C:" 831: THEN 832: AGAIN 833: THEN ; 834: 835: also minimal 836: 837: : \- there? IF postpone \ THEN ; 838: : \+ there? 0= IF postpone \ THEN ; 839: 840: : [IF] postpone [IF] ; 841: : [THEN] postpone [THEN] ; 842: : [ELSE] postpone [ELSE] ; 843: 844: Cond: [IF] [IF] ;Cond 845: Cond: [IFDEF] [IFDEF] ;Cond 846: Cond: [IFUNDEF] [IFUNDEF] ;Cond 847: Cond: [THEN] [THEN] ;Cond 848: Cond: [ELSE] [ELSE] ;Cond 849: 850: \ save-cross 17mar93py 851: 852: \ i'm not interested in bigforth features this time 10may93jaw 853: \ [IFDEF] file 854: \ also file 855: \ [THEN] 856: \ included throw after create-file 11may93jaw 857: 858: bigendian Constant bigendian 859: 860: Create magic s" gforth00" here over allot swap move 861: 862: [char] 1 bigendian + cell + magic 7 + c! 863: 864: : save-cross ( "name" -- ) 865: bl parse ." Saving to " 2dup type 866: w/o bin create-file throw >r 867: magic 8 r@ write-file throw \ write magic 868: image @ there r@ write-file throw \ write image 869: bit$ @ there 1- cell>bit rshift 1+ 870: r@ write-file throw \ write tags 871: r> close-file throw ; 872: 873: \ words that should be in minimal 874: 875: : + + ; : 1- 1- ; 876: : - - ; : 2* 2* ; 877: : * * ; : / / ; 878: : dup dup ; : over over ; 879: : swap swap ; : rot rot ; 880: : drop drop ; : = = ; 881: : lshift lshift ; : 2/ 2/ ; 882: : . . ; 883: cell constant cell 884: 885: \ include bug5.fs 886: \ only forth also minimal definitions 887: 888: : \ postpone \ ; 889: : \G postpone \G ; 890: : ( postpone ( ; 891: : include bl word count included ; 892: : .( [char] ) parse type ; 893: : cr cr ; 894: 895: : times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation 896: only forth also minimal definitions 897: 898: \ cross-compiler words 899: 900: : decimal decimal ; 901: : hex hex ; 902: 903: : tudp T tudp H ; 904: : tup T tup H ; minimal 905: 906: \ for debugging... 907: : order order ; 908: : words words ; 909: : .s .s ; 910: 911: : bye bye ; 912: 913: \ turnkey direction 914: : H forth ; immediate 915: : T minimal ; immediate 916: : G ghosts ; immediate 917: 918: : turnkey 0 set-order also Target definitions 919: also Minimal also ; 920: 921: \ these ones are pefered: 922: 923: : lock turnkey ; 924: : unlock forth also cross ; 925: 926: unlock definitions also minimal 927: : lock lock ; 928: lock