cross.fs 28.7 KB
Newer Older
anton's avatar
anton committed
1 2
\ CROSS.FS     The Cross-Compiler                      06oct92py
\ Idea and implementation: Bernd Paysan (py)
anton's avatar
anton committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20

\ Copyright (C) 1995 Free Software Foundation, Inc.

\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
anton's avatar
anton committed
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39

\ 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

anton's avatar
anton committed
40 41 42 43 44
\ 	needed? works better now!!!		01mar97jaw
\	mach file is only loaded into target
\	cell corrected


pazsan's avatar
pazsan committed
45
\ include other.fs       \ ansforth extentions for cross
anton's avatar
anton committed
46

pazsan's avatar
pazsan committed
47 48 49 50
: string, ( c-addr u -- )
    \ puts down string as cstring
    dup c, here swap chars dup allot move ;
' falign Alias cfalign
51 52 53 54 55 56
: 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
57 58 59 60 61 62 63 64 65 66
decimal

\ Begin CROSS COMPILER:

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

VARIABLE GhostNames
0 GhostNames !
: GhostName ( -- addr )
67 68 69 70
    here GhostNames @ , GhostNames ! here 0 ,
    bl word count
    \ 2dup type space
    string, cfalign ;
anton's avatar
anton committed
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98

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

pazsan's avatar
pazsan committed
99 100
\ Parameter for target systems                         06oct92py

anton's avatar
anton committed
101
>TARGET
pazsan's avatar
pazsan committed
102 103
mach-file count included

anton's avatar
anton committed
104 105
[IFUNDEF] has-interpreter true CONSTANT has-interpreter [THEN]

pazsan's avatar
pazsan committed
106 107 108 109 110
also Forth definitions

[IFDEF] asm-include asm-include [THEN]

previous
pazsan's avatar
pazsan committed
111
hex
pazsan's avatar
pazsan committed
112 113 114

>CROSS

pazsan's avatar
pazsan committed
115 116 117
\ Create additional parameters                         19jan95py

T
anton's avatar
anton committed
118
NIL		   Constant TNIL
pazsan's avatar
pazsan committed
119 120 121 122 123 124 125 126
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
127 128 129 130 131 132 133 134 135 136 137
\ Variables                                            06oct92py

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


anton's avatar
anton committed
138 139 140 141
>TARGET

\ Byte ordering and cell size                          06oct92py

pazsan's avatar
pazsan committed
142 143
: cell+         tcell + ;
: cells         tcell<< lshift ;
anton's avatar
anton committed
144
: chars         ;
anton's avatar
anton committed
145
: char+		1 + ;
pazsan's avatar
pazsan committed
146
: floats	tfloat * ;
147
    
anton's avatar
anton committed
148
>CROSS
pazsan's avatar
pazsan committed
149
: cell/         tcell<< rshift ;
anton's avatar
anton committed
150 151
>TARGET
20 CONSTANT bl
anton's avatar
anton committed
152
TNIL Constant NIL
anton's avatar
anton committed
153 154 155

>CROSS

156 157 158 159 160 161
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
162
[ELSE]
163 164 165 166
   : 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
167 168 169 170 171 172
[THEN]

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

[IFDEF] Memory \ Memory is a bigFORTH feature
173
   also Memory
anton's avatar
anton committed
174 175
   : initmem ( var len -- )
     2dup swap handle! >r @ r> erase ;
176
   toss
anton's avatar
anton committed
177 178 179 180 181 182 183 184 185 186
[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
pazsan's avatar
pazsan committed
187
: makekernel ( targetsize -- targetsize )
anton's avatar
anton committed
188
  bit$  over 1- tcell>bit rshift 1+ initmem
anton's avatar
anton committed
189 190 191 192 193 194 195 196 197 198
  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
199
: -bit ( addr n -- )  >bit invert over c@ and swap c! ;
anton's avatar
anton committed
200
: relon ( taddr -- )  bit$ @ swap cell/ +bit ;
pazsan's avatar
pazsan committed
201
: reloff ( taddr -- )  bit$ @ swap cell/ -bit ;
anton's avatar
anton committed
202 203 204 205

\ Target memory access                                 06oct92py

: align+  ( taddr -- rest )
anton's avatar
anton committed
206
    tcell tuck 1- and - [ tcell 1- ] Literal and ;
207
: cfalign+  ( taddr -- rest )
pazsan's avatar
pazsan committed
208
    \ see kernel.fs:cfaligned
pazsan's avatar
pazsan committed
209
    /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;
anton's avatar
anton committed
210 211 212 213 214

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

215
: cfaligned ( taddr1 -- taddr2 )
pazsan's avatar
pazsan committed
216
    \ see kernel.fs
217 218
    dup cfalign+ + ;

anton's avatar
anton committed
219 220 221
>CROSS
: >image ( taddr -- absaddr )  image @ + ;
>TARGET
pazsan's avatar
pazsan committed
222 223
: @  ( taddr -- w )     >image t@ ;
: !  ( w taddr -- )     >image t! ;
anton's avatar
anton committed
224 225
: c@ ( taddr -- char )  >image c@ ;
: c! ( char taddr -- )  >image c! ;
226 227
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
anton's avatar
anton committed
228 229 230 231 232 233

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

: here  ( -- there )    there ;
: allot ( n -- )        tdp +! ;
anton's avatar
anton committed
234
: ,     ( w -- )        T here H tcell T allot  ! H ;
anton's avatar
anton committed
235 236
: c,    ( char -- )     T here    1 allot c! H ;
: align ( -- )          T here H align+ 0 ?DO  bl T c, H LOOP ;
237 238
: cfalign ( -- )
    T here H cfalign+ 0 ?DO  bl T c, H LOOP ;
anton's avatar
anton committed
239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259

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

>CROSS

\ threading modell                                     13dec92py

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

\ 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 ;

pazsan's avatar
pazsan committed
260
hex
anton's avatar
anton committed
261
4711 Constant <fwd>             4712 Constant <res>
262
4713 Constant <imm>             4714 Constant <do:>
anton's avatar
anton committed
263 264 265 266 267 268 269 270 271 272

\ 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 , ;

pazsan's avatar
pazsan committed
273 274 275
: >magic ;
: >link cell+ ;
: >exec cell+ cell+ ;
anton's avatar
anton committed
276 277
: >end 3 cells + ;

278
Variable last-ghost
anton's avatar
anton committed
279 280 281 282
: Make-Ghost ( "name" -- ghost )
  >in @ GhostName swap >in !
  <T Create atonce @ IF immediate atonce off THEN
  here tuck swap ! ghostheader T>
283
  DOES> dup last-ghost ! >exec @ execute ;
anton's avatar
anton committed
284

anton's avatar
anton committed
285 286 287 288 289
variable cfalist 0 cfalist !

: markcfa
  cfalist here over @ , swap ! , ;

anton's avatar
anton committed
290 291 292 293 294
\ ghost words                                          14oct92py
\                                          changed:    10may93py/jaw

: gfind   ( string -- ghost true/1 / string false )
\ searches for string in word-list ghosts
295
  dup count [ ' ghosts >body ] ALiteral search-wordlist
anton's avatar
anton committed
296
  dup IF >r >body nip r>  THEN ;
anton's avatar
anton committed
297 298 299 300 301

VARIABLE Already

: ghost   ( "name" -- ghost )
  Already off
pazsan's avatar
pazsan committed
302
  >in @  bl word gfind   IF  Already on nip EXIT  THEN
anton's avatar
anton committed
303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
  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
318
        2 cells + count cr ." CROSS: Exists: " type 4 spaces drop
anton's avatar
anton committed
319
        swap cell+ !
pazsan's avatar
pazsan committed
320
  ELSE  true abort" CROSS: Ghostnames inconsistent "
anton's avatar
anton committed
321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
  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
357 358
  REPEAT drop ResolveFlag @
  IF
anton's avatar
anton committed
359
      -1 abort" Unresolved words!"
anton's avatar
anton committed
360 361 362 363
  ELSE
      ." Nothing!"
  THEN
  cr ;
anton's avatar
anton committed
364 365 366 367 368 369 370 371 372

>CROSS
\ Header states                                        12dec92py

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

VARIABLE ^imm

>TARGET
373
: immediate     40 flag!
374
                ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
anton's avatar
anton committed
375 376
                <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                <imm> ^imm @ ! ;
377
: restrict      20 flag! ;
anton's avatar
anton committed
378 379 380 381 382 383
>CROSS

\ ALIAS2 ansforth conform alias                          9may93jaw

: ALIAS2 create here 0 , DOES> @ execute ;
\ usage:
384
\ ' <name> alias2 bla !
anton's avatar
anton committed
385 386 387 388

\ Target Header Creation                               01nov92py

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

393 394
\ Target Document Creation (goes to crossdoc.fd)       05jul95py

anton's avatar
anton committed
395
s" doc/crossdoc.fd" r/w create-file throw value doc-file-id
396 397
\ contains the file-id of the documentation file

pazsan's avatar
pazsan committed
398
: T-\G ( -- )
399
    source >in @ /string doc-file-id write-line throw
pazsan's avatar
pazsan committed
400
    postpone \ ;
401

pazsan's avatar
pazsan committed
402
Variable to-doc  to-doc on
403 404 405 406 407 408 409 410 411 412 413 414

: 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					
pazsan's avatar
pazsan committed
415
	T-\G
416
	>in !
pazsan's avatar
pazsan committed
417
    THEN ;
418

pazsan's avatar
pazsan committed
419 420
\ Target TAGS creation

pazsan's avatar
pazsan committed
421
s" kernel.TAGS" r/w create-file throw value tag-file-id
pazsan's avatar
pazsan committed
422 423 424 425 426 427 428 429 430 431 432 433
\ 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
434
	sourcefilename 2dup
pazsan's avatar
pazsan committed
435 436 437 438 439 440 441 442 443 444 445 446 447
	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
448
	base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw
pazsan's avatar
pazsan committed
449 450 451 452 453
\	>in @ 0 <# #s [char] , hold #> tag-file-id write-line throw
	s" ,0" tag-file-id write-line throw
	base !
    THEN ;

pazsan's avatar
pazsan committed
454 455 456 457 458 459 460 461
\ Check for words

Defer skip? ' false IS skip?

: defined? ( -- flag ) \ name
    ghost >magic @ <fwd> <> ;

: needed? ( -- flag ) \ name
anton's avatar
anton committed
462 463 464 465 466 467 468 469 470 471
\G returns a false flag when
\G a word is not defined
\G a forward reference exists
\G so the definition is not skipped!
    bl word gfind
    IF dup >magic @ <fwd> = 
	\ swap >link @ 0<> and 
	nip
	0=
    ELSE  drop true  THEN ;
pazsan's avatar
pazsan committed
472

473 474 475
: doer? ( -- flag ) \ name
    ghost >magic @ <do:> = ;

pazsan's avatar
pazsan committed
476 477 478
: skip-defs ( -- )
    BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;

pazsan's avatar
pazsan committed
479 480
\ Target header creation

anton's avatar
anton committed
481 482
VARIABLE CreateFlag CreateFlag off

pazsan's avatar
pazsan committed
483 484 485
: (Theader ( "name" -- ghost )
\  >in @ bl word count type 2 spaces >in !
  T align H view,
anton's avatar
anton committed
486 487 488
  tlast @ dup 0> IF  T 1 cells - THEN  A, H  there tlast !
  >in @ name, >in ! T here H tlastcfa !
  CreateFlag @ IF
489 490 491 492
       >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
493 494 495 496
  ELSE ghost THEN
  dup >magic ^imm !     \ a pointer for immediate
  Already @ IF  dup >end tdoes !
  ELSE 0 tdoes ! THEN
497
  80 flag!
pazsan's avatar
pazsan committed
498
  cross-doc-entry cross-tag-entry ;
anton's avatar
anton committed
499 500 501

VARIABLE ;Resolve 1 cells allot

502 503
: Theader  ( "name" -- ghost )
  (THeader dup there resolve 0 ;Resolve ! ;
anton's avatar
anton committed
504 505 506

>TARGET
: Alias    ( cfa -- ) \ name
pazsan's avatar
pazsan committed
507 508 509 510 511 512
    >in @ skip? IF  2drop  EXIT  THEN  >in !
    dup 0< has-prims 0= and
    IF
	." needs prim: " >in @ bl word count type >in ! cr
    THEN
    (THeader over resolve T A, H 80 flag! ;
513
: Alias:   ( cfa -- ) \ name
pazsan's avatar
pazsan committed
514 515 516 517 518 519
    >in @ skip? IF  2drop  EXIT  THEN  >in !
    dup 0< has-prims 0= and
    IF
	." needs doer: " >in @ bl word count type >in ! cr
    THEN
    ghost tuck swap resolve <do:> swap >magic ! ;
anton's avatar
anton committed
520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550
>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
551
ghost unloop    ghost ;S                        2drop
anton's avatar
anton committed
552
ghost lit       ghost (compile) ghost !         2drop drop
553
ghost (does>)   ghost noop                      2drop
anton's avatar
anton committed
554
ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
555
ghost '                                         drop
556
ghost :docol    ghost :doesjump ghost :dodoes   2drop drop
pazsan's avatar
pazsan committed
557
ghost over      ghost =         ghost drop      2drop drop
anton's avatar
anton committed
558 559 560 561 562

\ compile                                              10may93jaw

: compile  ( -- ) \ name
  restrict?
pazsan's avatar
pazsan committed
563
  bl word gfind dup 0= ABORT" CROSS: Can't compile "
anton's avatar
anton committed
564 565 566 567 568
  0> ( immediate? )
  IF    >exec @ compile,
  ELSE  postpone literal postpone gexecute  THEN ;
                                        immediate

569 570 571
\ generic threading modell
: docol,  ( -- ) compile :docol T 0 , H ;

pazsan's avatar
pazsan committed
572
: dodoes, ( -- ) T cfalign H compile :doesjump T 0 , H ;
573

pazsan's avatar
pazsan committed
574 575 576 577 578
[IFUNDEF] (code) 
Defer (code)
Defer (end-code)
[THEN]

anton's avatar
anton committed
579 580 581 582
[IFUNDEF] ca>native
defer ca>native
[THEN]

anton's avatar
anton committed
583
>TARGET
pazsan's avatar
pazsan committed
584
: Code
anton's avatar
anton committed
585 586 587 588 589
  (THeader there resolve
  [ has-prims 0= [IF] ITC [ELSE] true [THEN] ] [IF]
  there 2 T cells H + ca>native T a, 0 , H
  [THEN]
  depth (code) ;
pazsan's avatar
pazsan committed
590 591

: Code:
anton's avatar
anton committed
592
    ghost dup there ca>native resolve  <do:> swap >magic !
pazsan's avatar
pazsan committed
593 594 595 596 597 598 599
    depth (code) ;

: end-code
    depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
    ELSE true ABORT" CROSS: Stack empty" THEN
    (end-code) ;
               
pazsan's avatar
pazsan committed
600
: '  ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
anton's avatar
anton committed
601 602 603 604
  dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;

Cond: [']  compile lit ghost gexecute ;Cond

605 606
Cond: chars ;Cond

anton's avatar
anton committed
607 608 609 610 611 612 613
>CROSS
\ tLiteral                                             12dec92py

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

>TARGET
pazsan's avatar
pazsan committed
614 615
Cond: \G  T-\G ;Cond

anton's avatar
anton committed
616 617 618 619 620 621
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

pazsan's avatar
pazsan committed
622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645
\ some special literals					27jan97jaw

Cond: MAXU
 restrict? compile lit 
 tcell 0 ?DO FF T c, H LOOP ;Cond

Cond: MINI
 restrict? compile lit
 bigendian IF
 80 T c, H tcell 1 ?DO 0 T c, H LOOP 
 ELSE
 tcell 1 ?DO 0 T c, H LOOP 80 T c, H
 THEN
 ;Cond
 
Cond: MAXI
 restrict? compile lit
 bigendian IF
 7F T c, H tcell 1 ?DO FF T c, H LOOP 
 ELSE
 tcell 1 ?DO FF T c, H LOOP 7F T c, H
 THEN
 ;Cond

anton's avatar
anton committed
646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664
>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
665
        BEGIN >in @ bl word
anton's avatar
anton committed
666 667 668 669 670 671 672 673 674 675 676 677
              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
pazsan's avatar
pazsan committed
678
  >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
anton's avatar
anton committed
679 680 681
  (THeader ;Resolve ! there ;Resolve cell+ !
  docol, depth T ] H ;

682
: :noname ( -- colon-sys )
pazsan's avatar
pazsan committed
683
  T cfalign H there docol, depth T ] H ;
684

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

687 688
Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond

anton's avatar
anton committed
689 690 691
Cond: ; ( -- ) restrict?
               depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
                          ELSE true ABORT" CROSS: Stack empty" THEN
pazsan's avatar
pazsan committed
692
               compile ;S state off
anton's avatar
anton committed
693 694 695 696 697 698
               ;Resolve @
               IF ;Resolve @ ;Resolve cell+ @ resolve THEN
               ;Cond
Cond: [  restrict? state off ;Cond

>CROSS
699 700
: !does
    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
anton's avatar
anton committed
701 702 703

>TARGET
Cond: DOES> restrict?
anton's avatar
anton committed
704
        compile (does>) dodoes, tdoes @ ?dup IF  @ T here H resolve THEN
anton's avatar
anton committed
705 706 707 708 709 710 711 712 713 714 715 716
        ;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 !
717 718
  also ghosts ' previous swap ! ;
\  DOES>  dup >exec @ execute ;
anton's avatar
anton committed
719 720

: gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>
721 722 723 724
    IF
	dup >magic @ <do:> =
	IF  gexecute T 0 , H  EXIT THEN
    THEN
jwilke's avatar
jwilke committed
725
    compile :dodoes gexecute T here H tcell - reloff ;
anton's avatar
anton committed
726

727 728
: TCreate ( -- )
  last-ghost @
anton's avatar
anton committed
729
  CreateFlag on
730 731
  Theader >r dup gdoes,
  >end @ >exec @ r> >exec ! ;
anton's avatar
anton committed
732 733 734 735 736

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

: gdoes>  ( ghost -- addr flag )
737
  last-ghost @
anton's avatar
anton committed
738 739 740 741 742 743 744 745
  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
746
  :noname postpone gdoes> postpone ?EXIT ;
anton's avatar
anton committed
747

748 749 750 751
: by:     ( -- addr [xt] [colon-sys] ) \ name
  ghost
  :noname postpone gdoes> postpone ?EXIT ;

anton's avatar
anton committed
752 753 754 755 756 757 758 759 760 761 762
: ;DO ( addr [xt] [colon-sys] -- )
  postpone ;    ( S addr xt )
  over >exec ! ; immediate

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

>TARGET
\ Variables and Constants                              05dec92py

Build:  ;
763
by: :dovar ( ghost -- addr ) ;DO
anton's avatar
anton committed
764 765 766 767 768 769 770 771 772 773
Builder Create

Build: T 0 , H ;
by Create
Builder Variable

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

774 775 776 777 778 779 780
\ User variables                                       04may94py

>CROSS
Variable tup  0 tup !
Variable tudp 0 tudp !
: u,  ( n -- udp )
  tup @ tudp @ + T  ! H
pazsan's avatar
pazsan committed
781
  tudp @ dup T cell+ H tudp ! ;
782 783
: au, ( n -- udp )
  tup @ tudp @ + T A! H
pazsan's avatar
pazsan committed
784
  tudp @ dup T cell+ H tudp ! ;
785 786 787
>TARGET

Build: T 0 u, , H ;
788
by: :douser ( ghost -- up-addr )  T @ H tup @ + ;DO
anton's avatar
anton committed
789 790
Builder User

791 792
Build: T 0 u, , 0 u, drop H ;
by User
anton's avatar
anton committed
793 794
Builder 2User

795 796
Build: T 0 au, , H ;
by User
anton's avatar
anton committed
797 798
Builder AUser

799
Build:  ( n -- ) ;
800
by: :docon ( ghost -- n ) T @ H ;DO
801 802 803 804
Builder (Constant)

Build:  ( n -- ) T , H ;
by (Constant)
anton's avatar
anton committed
805 806 807
Builder Constant

Build:  ( n -- ) T A, H ;
808
by (Constant)
anton's avatar
anton committed
809 810
Builder AConstant

pazsan's avatar
pazsan committed
811 812 813 814
Build:  ( d -- ) T , , H ;
DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
Builder 2Constant

pazsan's avatar
pazsan committed
815
Build: T , H ;
816
by (Constant)
anton's avatar
anton committed
817 818
Builder Value

pazsan's avatar
pazsan committed
819
Build: T A, H ;
820
by (Constant)
pazsan's avatar
pazsan committed
821 822
Builder AValue

anton's avatar
anton committed
823
Build:  ( -- ) compile noop ;
824
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
anton's avatar
anton committed
825 826
Builder Defer

827 828
Build:  ( inter comp -- ) swap T immediate A, A, H ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
anton's avatar
anton committed
829
Builder interpret/compile:
830

pazsan's avatar
pazsan committed
831 832 833 834 835 836 837 838
\ 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

839 840 841 842
Build: ;
by: :dofield T @ H + ;DO
Builder (Field)

pazsan's avatar
pazsan committed
843 844
Build: 	>r rot r@ nalign  dup T , H  ( align1 size offset )
	+ swap r> nalign ;
845
by (Field)
pazsan's avatar
pazsan committed
846 847 848 849 850 851 852 853 854 855 856
Builder Field

: 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
857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899
\ 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

pazsan's avatar
pazsan committed
900 901 902 903 904 905
Cond: CASE      restrict? 0 ;Cond
Cond: OF        restrict? 1+ >r compile over compile = compile IF compile drop
                r> ;Cond
Cond: ENDOF     restrict? >r compile ELSE r> ;Cond
Cond: ENDCASE   restrict? compile drop 0 ?DO  compile THEN  LOOP ;Cond

anton's avatar
anton committed
906 907 908
\ Structural Conditionals                              12dec92py

Cond: DO        restrict? compile (do)   T here H ;Cond
anton's avatar
anton committed
909
Cond: ?DO       restrict? compile (?do)  T (leave here H ;Cond
anton's avatar
anton committed
910 911 912
Cond: FOR       restrict? compile (for)  T here H ;Cond

>CROSS
anton's avatar
anton committed
913
: loop]   dup <resolve tcell - compile DONE compile unloop ;
anton's avatar
anton committed
914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929
>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
930 931
Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
: TO            T ' >body ! H ;
anton's avatar
anton committed
932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950

\ 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
951
      bl word gfind dup 0= ABORT" CROSS: Can't compile"
anton's avatar
anton committed
952 953 954 955 956 957
      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
958
      bl word gfind dup 0= ABORT" CROSS: Can't compile"
anton's avatar
anton committed
959 960 961 962 963 964 965 966 967 968 969 970 971
      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
972
: defined? defined? ;
973 974
: needed? needed? ;
: doer? doer? ;
anton's avatar
anton committed
975

pazsan's avatar
pazsan committed
976 977
: [IFDEF] defined? postpone [IF] ;
: [IFUNDEF] defined? 0= postpone [IF] ;
anton's avatar
anton committed
978 979 980

\ C: \- \+ Conditional Compiling                         09jun93jaw

pazsan's avatar
pazsan committed
981
: C: >in @ defined? 0=
anton's avatar
anton committed
982 983 984 985 986 987 988 989 990 991 992
     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

anton's avatar
anton committed
993
\G interprets the line if word is not defined
pazsan's avatar
pazsan committed
994
: \- defined? IF postpone \ THEN ;
anton's avatar
anton committed
995 996

\G interprets the line if word is defined
pazsan's avatar
pazsan committed
997
: \+ defined? 0= IF postpone \ THEN ;
anton's avatar
anton committed
998

anton's avatar
anton committed
999 1000 1001 1002 1003 1004 1005 1006 1007
Cond: \- \- ;Cond
Cond: \+ \+ ;Cond

: ?? bl word find IF execute ELSE drop 0 THEN ;

: needed:
\G defines ghost for words that we want to be compiled
  BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ;

anton's avatar
anton committed
1008 1009 1010 1011 1012 1013 1014 1015 1016 1017
: [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

anton's avatar
anton committed
1018
previous
anton's avatar
anton committed
1019

anton's avatar
anton committed
1020
\ save-cross                                           17mar93py
anton's avatar
anton committed
1021

anton's avatar
anton committed
1022
>CROSS
anton's avatar
anton committed
1023
Create magic  s" Gforth10" here over allot swap move
1024

anton's avatar
anton committed
1025
char 1 bigendian + tcell + magic 7 + c!
1026

anton's avatar
anton committed
1027 1028
: save-cross ( "image-name" "binary-name" -- )
  bl parse ." Saving to " 2dup type cr
anton's avatar
anton committed
1029
  w/o bin create-file throw >r
anton's avatar
anton committed
1030
  TNIL IF
pazsan's avatar
pazsan committed
1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043
      s" #! "   r@ write-file throw
      bl parse  r@ write-file throw
      s"  -i"   r@ write-file throw
      #lf       r@ emit-file throw
      r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index )
      ?do
	  bl over emit-file throw
      loop
      drop
      magic 8       r@ write-file throw \ write magic
  ELSE
      bl parse 2drop
  THEN
pazsan's avatar
pazsan committed
1044
  image @ there r@ write-file throw \ write image
anton's avatar
anton committed
1045 1046
  TNIL IF
      bit$  @ there 1- tcell>bit rshift 1+
pazsan's avatar
pazsan committed
1047
                r@ write-file throw \ write tags
pazsan's avatar
pazsan committed
1048
  THEN
anton's avatar
anton committed
1049 1050 1051
  r> close-file throw ;

\ words that should be in minimal
anton's avatar
anton committed
1052 1053
>MINIMAL
also minimal
anton's avatar
anton committed
1054

anton's avatar
anton committed
1055 1056
bigendian Constant bigendian
: save-cross save-cross ;
pazsan's avatar
pazsan committed
1057
: here there ;
anton's avatar
anton committed
1058 1059 1060 1061 1062
also forth 
[IFDEF] Label : Label Label ; [THEN] 
[IFDEF] start-macros : start-macros start-macros ; [THEN]
previous

pazsan's avatar
pazsan committed
1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078
: + + ;
: or or ;
: 1- 1- ;
: - - ;
: 2* 2* ;
: * * ;
: / / ;
: dup dup ;
: over over ;
: swap swap ;
: rot rot ;
: drop drop ;
: =   = ;
: 0=   0= ;
: lshift lshift ;
: 2/ 2/ ;
pazsan's avatar
pazsan committed
1079
: . . ;
1080
: const ;
1081

anton's avatar
anton committed
1082
\ mach-file count included
anton's avatar
anton committed
1083

pazsan's avatar
pazsan committed
1084 1085 1086
: all-words    ['] false    IS skip? ;
: needed-words ['] needed?  IS skip? ;
: undef-words  ['] defined? IS skip? ;
anton's avatar
anton committed
1087

pazsan's avatar
pazsan committed
1088
: \  postpone \ ;  immediate
1089
: \G T-\G ; immediate
pazsan's avatar
pazsan committed
1090
: (  postpone ( ;  immediate
anton's avatar
anton committed
1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102
: 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 ;

1103
: tudp          T tudp H ;
pazsan's avatar
pazsan committed
1104 1105 1106 1107 1108 1109
: tup           T tup H ;

: doc-off       false T to-doc H ! ;
: doc-on        true  T to-doc H ! ;

minimal
anton's avatar
anton committed
1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133

\ 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