cross.fs 24.4 KB
Newer Older
anton's avatar
anton committed
1
\ CROSS.FS     The Cross-Compiler                      06oct92py
2
\ $Id: cross.fs,v 1.29 1995-10-07 17:38:11 anton Exp $
anton's avatar
anton committed
3
\ Idea and implementation: Bernd Paysan (py)
4
\ Copyright 1992-94 by the GNU Forth Development Group
anton's avatar
anton committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23

\ Log:
\       changed in ; [ to state off           12may93jaw
\       included place +place                 12may93jaw
\       for a created word (variable, constant...)
\       is now an alias in the target voabulary.
\       this means it is no longer necessary to
\       switch between vocabularies for variable
\       initialization                        12may93jaw
\       discovered error in DOES>
\       replaced !does with (;code)           16may93jaw
\       made complete redesign and
\       introduced two vocs method
\       to be asure that the right words
\       are found                             08jun93jaw
\       btw:  ! works not with 16 bit
\             targets                         09jun93jaw
\       added: 2user and value                11jun93jaw

pazsan's avatar
pazsan committed
24
\ include other.fs       \ ansforth extentions for cross
anton's avatar
anton committed
25

pazsan's avatar
pazsan committed
26 27 28 29
: string, ( c-addr u -- )
    \ puts down string as cstring
    dup c, here swap chars dup allot move ;
' falign Alias cfalign
30 31 32 33 34 35
: comment? ( c-addr u -- c-addr u )
        2dup s" (" compare 0=
        IF    postpone (
        ELSE  2dup s" \" compare 0= IF postpone \ THEN
        THEN ;

anton's avatar
anton committed
36 37 38 39 40 41 42 43 44 45
decimal

\ Begin CROSS COMPILER:

\ GhostNames                                            9may93jaw
\ second name source to search trough list

VARIABLE GhostNames
0 GhostNames !
: GhostName ( -- addr )
46 47 48 49
    here GhostNames @ , GhostNames ! here 0 ,
    bl word count
    \ 2dup type space
    string, cfalign ;
anton's avatar
anton committed
50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90

hex


Vocabulary Cross
Vocabulary Target
Vocabulary Ghosts
VOCABULARY Minimal
only Forth also Target also also
definitions Forth

: T  previous Cross also Target ; immediate
: G  Ghosts ; immediate
: H  previous Forth also Cross ; immediate

forth definitions

: T  previous Cross also Target ; immediate
: G  Ghosts ; immediate

: >cross  also Cross definitions previous ;
: >target also Target definitions previous ;
: >minimal also Minimal definitions previous ;

H

>CROSS

\ Variables                                            06oct92py

-1 Constant NIL
Variable image
Variable tlast    NIL tlast !  \ Last name field
Variable tlastcfa \ Last code field
Variable tdoes    \ Resolve does> calls
Variable bit$
Variable tdp
: there  tdp @ ;

\ Parameter for target systems                         06oct92py

pazsan's avatar
pazsan committed
91
included
anton's avatar
anton committed
92

pazsan's avatar
pazsan committed
93 94 95 96 97 98 99 100 101 102 103
\ Create additional parameters                         19jan95py

T
cell               Constant tcell
cell<<             Constant tcell<<
cell>bit           Constant tcell>bit
bits/byte          Constant tbits/byte
float              Constant tfloat
1 bits/byte lshift Constant maxbyte
H

anton's avatar
anton committed
104 105 106 107
>TARGET

\ Byte ordering and cell size                          06oct92py

pazsan's avatar
pazsan committed
108 109
: cell+         tcell + ;
: cells         tcell<< lshift ;
anton's avatar
anton committed
110
: chars         ;
pazsan's avatar
pazsan committed
111
: floats	tfloat * ;
112
    
anton's avatar
anton committed
113
>CROSS
pazsan's avatar
pazsan committed
114
: cell/         tcell<< rshift ;
anton's avatar
anton committed
115 116 117 118 119 120
>TARGET
20 CONSTANT bl
-1 Constant NIL
-2 Constant :docol
-3 Constant :docon
-4 Constant :dovar
121
-5 Constant :douser
anton's avatar
anton committed
122
-6 Constant :dodefer
123
-7 Constant :dofield
pazsan's avatar
pazsan committed
124 125
-8 Constant :dodoes
-9 Constant :doesjump
anton's avatar
anton committed
126 127 128

>CROSS

129 130 131 132 133 134
bigendian
[IF]
   : T!  ( n addr -- )  >r s>d r> tcell bounds swap 1-
     DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
   : T@  ( addr -- n )  >r 0 0 r> tcell bounds
     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
pazsan's avatar
pazsan committed
135
[ELSE]
136 137 138 139
   : T!  ( n addr -- )  >r s>d r> tcell bounds
     DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
   : T@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
anton's avatar
anton committed
140 141 142 143 144 145
[THEN]

\ Memory initialisation                                05dec92py
\ Fixed bug in else part                               11may93jaw

[IFDEF] Memory \ Memory is a bigFORTH feature
146
   also Memory
anton's avatar
anton committed
147 148
   : initmem ( var len -- )
     2dup swap handle! >r @ r> erase ;
149
   toss
anton's avatar
anton committed
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171
[ELSE]
   : initmem ( var len -- )
     tuck allocate abort" CROSS: No memory for target"
     ( len var adr ) dup rot !
     ( len adr ) swap erase ;
[THEN]

\ MakeKernal                                           12dec92py

>MINIMAL
: makekernal ( targetsize -- targetsize )
  bit$  over 1- cell>bit rshift 1+ initmem
  image over initmem tdp off ;

>CROSS
\ Bit string manipulation                               06oct92py
\                                                       9may93jaw
CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
: bits ( n -- n ) chars Bittable + c@ ;

: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
: +bit ( addr n -- )  >bit over c@ or swap c! ;
pazsan's avatar
pazsan committed
172
: -bit ( addr n -- )  >bit invert over c@ and swap c! ;
anton's avatar
anton committed
173
: relon ( taddr -- )  bit$ @ swap cell/ +bit ;
pazsan's avatar
pazsan committed
174
: reloff ( taddr -- )  bit$ @ swap cell/ -bit ;
anton's avatar
anton committed
175 176 177 178 179

\ Target memory access                                 06oct92py

: align+  ( taddr -- rest )
    cell tuck 1- and - [ cell 1- ] Literal and ;
180 181 182
: cfalign+  ( taddr -- rest )
    \ see kernal.fs:cfaligned
    float tuck 1- and - [ float 1- ] Literal and ;
anton's avatar
anton committed
183 184 185 186 187

>TARGET
: aligned ( taddr -- ta-addr )  dup align+ + ;
\ assumes cell alignment granularity (as GNU C)

188 189 190 191
: cfaligned ( taddr1 -- taddr2 )
    \ see kernal.fs
    dup cfalign+ + ;

anton's avatar
anton committed
192 193 194
>CROSS
: >image ( taddr -- absaddr )  image @ + ;
>TARGET
pazsan's avatar
pazsan committed
195 196
: @  ( taddr -- w )     >image t@ ;
: !  ( w taddr -- )     >image t! ;
anton's avatar
anton committed
197 198
: c@ ( taddr -- char )  >image c@ ;
: c! ( char taddr -- )  >image c! ;
199 200
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
anton's avatar
anton committed
201 202 203 204 205 206 207 208 209

\ Target compilation primitives                        06oct92py
\ included A!                                          16may93jaw

: here  ( -- there )    there ;
: allot ( n -- )        tdp +! ;
: ,     ( w -- )        T here H cell T allot  ! H ;
: c,    ( char -- )     T here    1 allot c! H ;
: align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;
210 211
: cfalign ( -- )
    T here H cfalign+ 0 ?DO  bl T c, H LOOP ;
anton's avatar
anton committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226

: A!                    dup relon T ! H ;
: A,    ( w -- )        T here H relon T , H ;

>CROSS

\ threading modell                                     13dec92py

\ generic threading modell
: docol,  ( -- ) :docol T A, 0 , H ;

>TARGET
: >body   ( cfa -- pfa ) T cell+ cell+ H ;
>CROSS

227
: dodoes, ( -- ) T :doesjump A, 0 , H ;
anton's avatar
anton committed
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252

\ Ghost Builder                                        06oct92py

\ <T T> new version with temp variable                 10may93jaw

VARIABLE VocTemp

: <T  get-current VocTemp ! also Ghosts definitions ;
: T>  previous VocTemp @ set-current ;

4711 Constant <fwd>             4712 Constant <res>
4713 Constant <imm>

\ iForth makes only immediate directly after create
\ make atonce trick! ?

Variable atonce atonce off

: NoExec true ABORT" CROSS: Don't execute ghost" ;

: GhostHeader <fwd> , 0 , ['] NoExec , ;

: >magic ; : >link cell+ ; : >exec cell+ cell+ ;
: >end 3 cells + ;

253
Variable last-ghost
anton's avatar
anton committed
254 255 256 257
: Make-Ghost ( "name" -- ghost )
  >in @ GhostName swap >in !
  <T Create atonce @ IF immediate atonce off THEN
  here tuck swap ! ghostheader T>
258
  DOES> dup last-ghost ! >exec @ execute ;
anton's avatar
anton committed
259 260 261 262 263 264 265

\ ghost words                                          14oct92py
\                                          changed:    10may93py/jaw

: gfind   ( string -- ghost true/1 / string false )
\ searches for string in word-list ghosts
\ !! wouldn't it be simpler to just use search-wordlist ? ae
266
  dup count [ ' ghosts >body ] ALiteral search-wordlist
pazsan's avatar
pazsan committed
267
  dup IF  >r >body nip r>  THEN ;
anton's avatar
anton committed
268 269 270 271 272

VARIABLE Already

: ghost   ( "name" -- ghost )
  Already off
pazsan's avatar
pazsan committed
273
  >in @  bl word gfind   IF  Already on nip EXIT  THEN
anton's avatar
anton committed
274 275 276 277 278 279 280 281 282 283 284 285 286 287 288
  drop  >in !  Make-Ghost ;

\ resolve                                              14oct92py

: resolve-loop ( ghost tcfa -- ghost tcfa )
  >r dup >link @
  BEGIN  dup  WHILE  dup T @ H r@ rot T ! H REPEAT  drop r> ;

\ exists                                                9may93jaw

: exists ( ghost tcfa -- )
  over GhostNames
  BEGIN @ dup
  WHILE 2dup cell+ @ =
  UNTIL
289
        2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
anton's avatar
anton committed
290
        swap cell+ !
pazsan's avatar
pazsan committed
291
  ELSE  true abort" CROSS: Ghostnames inconsistent "
anton's avatar
anton committed
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327
  THEN ;

: resolve  ( ghost tcfa -- )
  over >magic @ <fwd> <>  IF  exists EXIT THEN
  resolve-loop  over >link ! <res> swap >magic ! ;

\ gexecute ghost,                                      01nov92py

: do-forward   ( ghost -- )
  >link dup @  there rot !  T  A,  H ;
: do-resolve   ( ghost -- )
  >link @                   T  A,  H ;

: gexecute   ( ghost -- )   dup @
             <fwd> = IF  do-forward  ELSE  do-resolve  THEN ;
: ghost,     ghost  gexecute ;

\ .unresolved                                          11may93jaw

variable ResolveFlag

\ ?touched                                             11may93jaw

: ?touched ( ghost -- flag ) dup >magic @ <fwd> = swap >link @
                               0 <> and ;

: ?resolved  ( ghostname -- )
  dup cell+ @ ?touched
  IF  cell+ cell+ count cr type ResolveFlag on ELSE drop THEN ;

>MINIMAL
: .unresolved  ( -- )
  ResolveFlag off cr ." Unresolved: "
  Ghostnames
  BEGIN @ dup
  WHILE dup ?resolved
anton's avatar
anton committed
328 329
  REPEAT drop ResolveFlag @
  IF
330
      abort" Unresolved words!"
anton's avatar
anton committed
331 332 333 334
  ELSE
      ." Nothing!"
  THEN
  cr ;
anton's avatar
anton committed
335 336 337 338 339 340 341 342 343 344

>CROSS
\ Header states                                        12dec92py

: flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;

VARIABLE ^imm

>TARGET
: immediate     20 flag!
345
                ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
anton's avatar
anton committed
346 347
                <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                <imm> ^imm @ ! ;
348
: restrict      40 flag! ;
anton's avatar
anton committed
349 350 351 352 353 354
>CROSS

\ ALIAS2 ansforth conform alias                          9may93jaw

: ALIAS2 create here 0 , DOES> @ execute ;
\ usage:
355
\ ' <name> alias2 bla !
anton's avatar
anton committed
356 357 358 359

\ Target Header Creation                               01nov92py

: string,  ( addr count -- )
pazsan's avatar
pazsan committed
360
  dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 
361
: name,  ( "name" -- )  bl word count string, T cfalign H ;
anton's avatar
anton committed
362 363
: view,   ( -- ) ( dummy ) ;

364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389
\ Target Document Creation (goes to crossdoc.fd)       05jul95py

s" crossdoc.fd" r/w create-file throw value doc-file-id
\ contains the file-id of the documentation file

: \G ( -- )
    source >in @ /string doc-file-id write-line throw
    source >in ! drop ; immediate

Variable to-doc

: cross-doc-entry  ( -- )
    to-doc @ tlast @ 0<> and	\ not an anonymous (i.e. noname) header
    IF
	s" " doc-file-id write-line throw
	s" make-doc " doc-file-id write-file throw
	tlast @ >image count $1F and doc-file-id write-file throw
	>in @
	[char] ( parse 2drop
	[char] ) parse doc-file-id write-file throw
	s"  )" doc-file-id write-file throw
	[char] \ parse 2drop					
	POSTPONE \g
	>in !
    THEN  to-doc on ;

pazsan's avatar
pazsan committed
390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426
\ Target TAGS creation

s" TAGS" r/w create-file throw value tag-file-id
\ contains the file-id of the tags file

Create tag-beg 2 c,  7F c, bl c,
Create tag-end 2 c,  bl c, 01 c,
Create tag-bof 1 c,  0C c,

2variable last-loadfilename 0 0 last-loadfilename 2!
	    
: put-load-file-name ( -- )
    loadfilename 2@ last-loadfilename 2@ d<>
    IF
	tag-bof count tag-file-id write-line throw
	loadfilename 2@ 2dup
	tag-file-id write-file throw
	last-loadfilename 2!
	s" ,0" tag-file-id write-line throw
    THEN ;

: cross-tag-entry  ( -- )
    tlast @ 0<>	\ not an anonymous (i.e. noname) header
    IF
	put-load-file-name
	source >in @ min tag-file-id write-file throw
	tag-beg count tag-file-id write-file throw
	tlast @ >image count $1F and tag-file-id write-file throw
	tag-end count tag-file-id write-file throw
	base @ decimal loadline @ 0 <# #s #> tag-file-id write-file throw
\	>in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
	s" ,0" tag-file-id write-line throw
	base !
    THEN ;

\ Target header creation

anton's avatar
anton committed
427 428 429 430 431 432
VARIABLE CreateFlag CreateFlag off

: (Theader ( "name" -- ghost ) T align H view,
  tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !
  >in @ name, >in ! T here H tlastcfa !
  CreateFlag @ IF
433 434 435 436
       >in @ alias2 swap >in !         \ create alias in target
       >in @ ghost swap >in !
       swap also ghosts ' previous swap !     \ tick ghost and store in alias
       CreateFlag off
anton's avatar
anton committed
437 438 439 440
  ELSE ghost THEN
  dup >magic ^imm !     \ a pointer for immediate
  Already @ IF  dup >end tdoes !
  ELSE 0 tdoes ! THEN
441
  80 flag!
pazsan's avatar
pazsan committed
442
  cross-doc-entry cross-tag-entry ;
anton's avatar
anton committed
443 444 445

VARIABLE ;Resolve 1 cells allot

446 447
: Theader  ( "name" -- ghost )
  (THeader dup there resolve 0 ;Resolve ! ;
anton's avatar
anton committed
448 449 450

>TARGET
: Alias    ( cfa -- ) \ name
451
  dup 0< IF  to-doc off  THEN
anton's avatar
anton committed
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483
  (THeader over resolve T A, H 80 flag! ;
>CROSS

\ Conditionals and Comments                            11may93jaw

: ;Cond
  postpone ;
  swap ! ;  immediate

: Cond: ( -- ) \ name {code } ;
  atonce on
  ghost
  >exec
  :NONAME ;

: restrict? ( -- )
\ aborts on interprete state - ae
  state @ 0= ABORT" CROSS: Restricted" ;

: Comment ( -- )
  >in @ atonce on ghost swap >in ! ' swap >exec ! ;

Comment (       Comment \

\ Predefined ghosts                                    12dec92py

ghost 0=                                        drop
ghost branch    ghost ?branch                   2drop
ghost (do)      ghost (?do)                     2drop
ghost (for)                                     drop
ghost (loop)    ghost (+loop)                   2drop
ghost (next)                                    drop
pazsan's avatar
pazsan committed
484
ghost unloop    ghost ;S                        2drop
anton's avatar
anton committed
485
ghost lit       ghost (compile) ghost !         2drop drop
486
ghost (does>)   ghost noop                      2drop
anton's avatar
anton committed
487
ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
pazsan's avatar
pazsan committed
488
ghost '
anton's avatar
anton committed
489 490 491 492 493

\ compile                                              10may93jaw

: compile  ( -- ) \ name
  restrict?
pazsan's avatar
pazsan committed
494
  bl word gfind dup 0= ABORT" CROSS: Can't compile "
anton's avatar
anton committed
495 496 497 498 499 500
  0> ( immediate? )
  IF    >exec @ compile,
  ELSE  postpone literal postpone gexecute  THEN ;
                                        immediate

>TARGET
pazsan's avatar
pazsan committed
501
: '  ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
anton's avatar
anton committed
502 503 504 505
  dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;

Cond: [']  compile lit ghost gexecute ;Cond

506 507
Cond: chars ;Cond

anton's avatar
anton committed
508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539
>CROSS
\ tLiteral                                             12dec92py

: lit, ( n -- )   compile lit T  ,  H ;
: alit, ( n -- )  compile lit T A,  H ;

>TARGET
Cond:  Literal ( n -- )   restrict? lit, ;Cond
Cond: ALiteral ( n -- )   restrict? alit, ;Cond

: Char ( "<char>" -- )  bl word char+ c@ ;
Cond: [Char]   ( "<char>" -- )  restrict? Char  lit, ;Cond

>CROSS
\ Target compiling loop                                12dec92py
\ ">tib trick thrown out                               10may93jaw
\ number? defined at the top                           11may93jaw

\ compiled word might leave items on stack!
: tcom ( in name -- )
  gfind  ?dup  IF    0> IF    nip >exec @ execute
                        ELSE  nip gexecute  THEN EXIT THEN
  number? dup  IF    0> IF swap lit,  THEN  lit,  drop
               ELSE  2drop >in !
               ghost gexecute THEN  ;

>TARGET
\ : ; DOES>                                            13dec92py
\ ]                                                     9may93py/jaw

: ] state on
    BEGIN
pazsan's avatar
pazsan committed
540
        BEGIN >in @ bl word
anton's avatar
anton committed
541 542 543 544 545 546 547 548 549 550 551 552 553 554 555
              dup c@ 0= WHILE 2drop refill 0=
              ABORT" CROSS: End of file while target compiling"
        REPEAT
        tcom
        state @
        0=
    UNTIL ;

\ by the way: defining a second interpreter (a compiler-)loop
\             is not allowed if a system should be ans conform

: : ( -- colon-sys ) \ Name
  (THeader ;Resolve ! there ;Resolve cell+ !
  docol, depth T ] H ;

pazsan's avatar
pazsan committed
556 557
Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond

558 559
Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond

anton's avatar
anton committed
560 561 562
Cond: ; ( -- ) restrict?
               depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
                          ELSE true ABORT" CROSS: Stack empty" THEN
pazsan's avatar
pazsan committed
563
               compile ;S state off
anton's avatar
anton committed
564 565 566 567 568 569 570 571 572 573
               ;Resolve @
               IF ;Resolve @ ;Resolve cell+ @ resolve THEN
               ;Cond
Cond: [  restrict? state off ;Cond

>CROSS
: !does  :dodoes tlastcfa @ tuck T ! cell+ ! H ;

>TARGET
Cond: DOES> restrict?
574
        compile (does>) dodoes, tdoes @ ?dup IF  @ T here H resolve THEN
anton's avatar
anton committed
575 576 577 578 579 580 581 582 583 584 585 586
        ;Cond
: DOES> dodoes, T here H !does depth T ] H ;

>CROSS
\ Creation                                             01nov92py

\ Builder                                               11may93jaw

: Builder    ( Create do: "name" -- )
  >in @ alias2 swap dup >in ! >r >r
  Make-Ghost rot swap >exec ! ,
  r> r> >in !
587 588
  also ghosts ' previous swap ! ;
\  DOES>  dup >exec @ execute ;
anton's avatar
anton committed
589 590 591

: gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>
  IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
pazsan's avatar
pazsan committed
592
  :dodoes T A, H gexecute T here H cell - reloff ;
anton's avatar
anton committed
593

594 595
: TCreate ( -- )
  last-ghost @
anton's avatar
anton committed
596
  CreateFlag on
597 598
  Theader >r dup gdoes,
  >end @ >exec @ r> >exec ! ;
anton's avatar
anton committed
599 600 601 602 603

: Build:  ( -- [xt] [colon-sys] )
  :noname  postpone TCreate ;

: gdoes>  ( ghost -- addr flag )
604
  last-ghost @
anton's avatar
anton committed
605 606 607 608 609 610 611 612
  state @ IF  gexecute true EXIT  THEN
  cell+ @ T >body H false ;

\ DO: ;DO                                               11may93jaw
\ changed to ?EXIT                                      10may93jaw

: DO:     ( -- addr [xt] [colon-sys] )
  here ghostheader
613
  :noname postpone gdoes> postpone ?EXIT ;
anton's avatar
anton committed
614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637

: ;DO ( addr [xt] [colon-sys] -- )
  postpone ;    ( S addr xt )
  over >exec ! ; immediate

: by      ( -- addr ) \ Name
  ghost >end @ ;

>TARGET
\ Variables and Constants                              05dec92py

Build:  ;
DO: ( ghost -- addr ) ;DO
Builder Create
by Create :dovar resolve

Build: T 0 , H ;
by Create
Builder Variable

Build: T 0 A, H ;
by Create
Builder AVariable

638 639 640 641 642 643 644
\ User variables                                       04may94py

>CROSS
Variable tup  0 tup !
Variable tudp 0 tudp !
: u,  ( n -- udp )
  tup @ tudp @ + T  ! H
pazsan's avatar
pazsan committed
645
  tudp @ dup T cell+ H tudp ! ;
646 647
: au, ( n -- udp )
  tup @ tudp @ + T A! H
pazsan's avatar
pazsan committed
648
  tudp @ dup T cell+ H tudp ! ;
649 650 651 652
>TARGET

Build: T 0 u, , H ;
DO: ( ghost -- up-addr )  T @ H tup @ + ;DO
anton's avatar
anton committed
653
Builder User
654
by User :douser resolve
anton's avatar
anton committed
655

656 657
Build: T 0 u, , 0 u, drop H ;
by User
anton's avatar
anton committed
658 659
Builder 2User

660 661
Build: T 0 au, , H ;
by User
anton's avatar
anton committed
662 663 664 665 666 667 668 669 670 671 672
Builder AUser

Build:  ( n -- ) T , H ;
DO: ( ghost -- n ) T @ H ;DO
Builder Constant
by Constant :docon resolve

Build:  ( n -- ) T A, H ;
by Constant
Builder AConstant

pazsan's avatar
pazsan committed
673 674 675 676
Build:  ( d -- ) T , , H ;
DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
Builder 2Constant

anton's avatar
anton committed
677 678 679 680 681 682 683
Build: T 0 , H ;
by Constant
Builder Value

Build:  ( -- ) compile noop ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder Defer
anton's avatar
anton committed
684
by Defer :dodefer resolve
anton's avatar
anton committed
685

pazsan's avatar
pazsan committed
686 687 688 689 690 691 692 693 694 695 696 697
\ Sturctures                                           23feb95py

>CROSS
: nalign ( addr1 n -- addr2 )
\ addr2 is the aligned version of addr1 wrt the alignment size n
 1- tuck +  swap invert and ;
>TARGET

Build: 	>r rot r@ nalign  dup T , H  ( align1 size offset )
	+ swap r> nalign ;
DO: T @ H + ;DO
Builder Field
698
by Field :dofield resolve
pazsan's avatar
pazsan committed
699 700 701 702 703 704 705 706 707 708

: struct  T 0 1 chars H ;
: end-struct  T 2Constant H ;

: cells: ( n -- size align )
    T cells 1 cells H ;

\ ' 2Constant Alias2 end-struct
\ 0 1 T Chars H 2Constant struct

anton's avatar
anton committed
709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775
\ structural conditionals                              17dec92py

>CROSS
: ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
: sys?        ( sys -- sys )    dup 0= ?struc ;
: >mark       ( -- sys )        T here  0 , H ;
: >resolve    ( sys -- )        T here over - swap ! H ;
: <resolve    ( sys -- )        T here - , H ;
>TARGET

\ Structural Conditionals                              12dec92py

Cond: BUT       restrict? sys? swap ;Cond
Cond: YET       restrict? sys? dup ;Cond

>CROSS
Variable tleavings
>TARGET

Cond: DONE   ( addr -- )  restrict? tleavings @
      BEGIN  2dup u> 0=  WHILE  dup T @ H swap >resolve REPEAT
      tleavings ! drop ;Cond

>CROSS
: (leave  T here H tleavings @ T , H  tleavings ! ;
>TARGET

Cond: LEAVE     restrict? compile branch (leave ;Cond
Cond: ?LEAVE    restrict? compile 0=  compile ?branch (leave  ;Cond

\ Structural Conditionals                              12dec92py

Cond: AHEAD     restrict? compile branch >mark ;Cond
Cond: IF        restrict? compile ?branch >mark ;Cond
Cond: THEN      restrict? sys? dup T @ H ?struc >resolve ;Cond
Cond: ELSE      restrict? sys? compile AHEAD swap compile THEN ;Cond

Cond: BEGIN     restrict? T here H ;Cond
Cond: WHILE     restrict? sys? compile IF swap ;Cond
Cond: AGAIN     restrict? sys? compile branch <resolve ;Cond
Cond: UNTIL     restrict? sys? compile ?branch <resolve ;Cond
Cond: REPEAT    restrict? over 0= ?struc compile AGAIN compile THEN ;Cond

\ Structural Conditionals                              12dec92py

Cond: DO        restrict? compile (do)   T here H ;Cond
Cond: ?DO       restrict? compile (?do)  (leave T here H ;Cond
Cond: FOR       restrict? compile (for)  T here H ;Cond

>CROSS
: loop]   dup <resolve cell - compile DONE compile unloop ;
>TARGET

Cond: LOOP      restrict? sys? compile (loop)  loop] ;Cond
Cond: +LOOP     restrict? sys? compile (+loop) loop] ;Cond
Cond: NEXT      restrict? sys? compile (next)  loop] ;Cond

\ String words                                         23feb93py

: ,"            [char] " parse string, T align H ;

Cond: ."        restrict? compile (.")     T ," H ;Cond
Cond: S"        restrict? compile (S")     T ," H ;Cond
Cond: ABORT"    restrict? compile (ABORT") T ," H ;Cond

Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
: IS            T ' >body ! H ;
pazsan's avatar
pazsan committed
776 777
Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
: TO            T ' >body ! H ;
anton's avatar
anton committed
778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796

\ LINKED ERR" ENV" 2ENV"                                18may93jaw

\ linked list primitive
: linked        T here over @ A, swap ! H ;

: err"   s" ErrLink linked" evaluate T , H
         [char] " parse string, T align H ;

: env"  [char] " parse s" EnvLink linked" evaluate
        string, T align , H ;

: 2env" [char] " parse s" EnvLink linked" evaluate
        here >r string, T align , , H
        r> dup T c@ H 80 and swap T c! H ;

\ compile must be last                                 22feb93py

Cond: compile ( -- ) restrict? \ name
pazsan's avatar
pazsan committed
797
      bl word gfind dup 0= ABORT" CROSS: Can't compile"
anton's avatar
anton committed
798 799 800 801 802 803
      0> IF    gexecute
         ELSE  dup >magic @ <imm> =
               IF   gexecute
               ELSE compile (compile) gexecute THEN THEN ;Cond

Cond: postpone ( -- ) restrict? \ name
pazsan's avatar
pazsan committed
804
      bl word gfind dup 0= ABORT" CROSS: Can't compile"
anton's avatar
anton committed
805 806 807 808 809 810 811 812 813 814 815 816 817
      0> IF    gexecute
         ELSE  dup >magic @ <imm> =
               IF   gexecute
               ELSE compile (compile) gexecute THEN THEN ;Cond

>MINIMAL
also minimal
\ Usefull words                                        13feb93py

: KB  400 * ;

\ define new [IFDEF] and [IFUNDEF]                      20may93jaw

pazsan's avatar
pazsan committed
818
: there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;
anton's avatar
anton committed
819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857

: [IFDEF] there? postpone [IF] ;
: [IFUNDEF] there? 0= postpone [IF] ;

\ C: \- \+ Conditional Compiling                         09jun93jaw

: C: >in @ there? 0=
     IF    >in ! T : H
     ELSE drop
        BEGIN bl word dup c@
              IF   count comment? s" ;" compare 0= ?EXIT
              ELSE refill 0= ABORT" CROSS: Out of Input while C:"
              THEN
        AGAIN
     THEN ;

also minimal

: \- there? IF postpone \ THEN ;
: \+ there? 0= IF postpone \ THEN ;

: [IF]   postpone [IF] ;
: [THEN] postpone [THEN] ;
: [ELSE] postpone [ELSE] ;

Cond: [IF]      [IF] ;Cond
Cond: [IFDEF]   [IFDEF] ;Cond
Cond: [IFUNDEF] [IFUNDEF] ;Cond
Cond: [THEN]    [THEN] ;Cond
Cond: [ELSE]    [ELSE] ;Cond

\ save-cross                                           17mar93py

\ i'm not interested in bigforth features this time    10may93jaw
\ [IFDEF] file
\ also file
\ [THEN]
\ included throw after create-file                     11may93jaw

858
bigendian Constant bigendian
anton's avatar
anton committed
859

860 861 862 863
Create magic  s" gforth00" here over allot swap move

[char] 1 bigendian + cell + magic 7 + c!

anton's avatar
anton committed
864 865 866
: save-cross ( "name" -- )
  bl parse ." Saving to " 2dup type
  w/o bin create-file throw >r
867
  magic 8       r@ write-file throw \ write magic
pazsan's avatar
pazsan committed
868 869 870
  image @ there r@ write-file throw \ write image
  bit$  @ there 1- cell>bit rshift 1+
                r@ write-file throw \ write tags
anton's avatar
anton committed
871 872 873 874 875 876
  r> close-file throw ;

\ words that should be in minimal

: + + ;         : 1- 1- ;
: - - ;         : 2* 2* ;
877
: * * ;         : / / ;
anton's avatar
anton committed
878 879
: dup dup ;     : over over ;
: swap swap ;   : rot rot ;
pazsan's avatar
pazsan committed
880
: drop drop ;   : =   = ;
pazsan's avatar
pazsan committed
881
: lshift lshift ; : 2/ 2/ ;
pazsan's avatar
pazsan committed
882
: . . ;
pazsan's avatar
pazsan committed
883
cell constant cell
anton's avatar
anton committed
884 885 886 887

\ include bug5.fs
\ only forth also minimal definitions

888 889 890
: \  postpone \ ;
: \G postpone \G ;
: (  postpone ( ;
anton's avatar
anton committed
891 892 893 894 895 896 897 898 899 900 901 902
: include bl word count included ;
: .( [char] ) parse type ;
: cr cr ;

: times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation
only forth also minimal definitions

\ cross-compiler words

: decimal       decimal ;
: hex           hex ;

903 904
: tudp          T tudp H ;
: tup           T tup H ;  minimal
anton's avatar
anton committed
905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928

\ for debugging...
: order         order ;
: words         words ;
: .s            .s ;

: bye           bye ;

\ turnkey direction
: H forth ; immediate
: T minimal ; immediate
: G ghosts ; immediate

: turnkey  0 set-order also Target definitions
           also Minimal also ;

\ these ones are pefered:

: lock   turnkey ;
: unlock forth also cross ;

unlock definitions also minimal
: lock   lock ;
lock