### Diff for /gforth/cross.fs between versions 1.2 and 1.13

version 1.2, 1994/05/03 15:24:11 version 1.13, 1994/09/12 19:00:27
Line 21 Line 21
\             targets                         09jun93jaw  \             targets                         09jun93jaw
\       added: 2user and value                11jun93jaw  \       added: 2user and value                11jun93jaw

include other.fs       \ ansforth extentions for cross  \ include other.fs       \ ansforth extentions for cross

decimal

\ number?                                               11may93jaw

\ checks for +, -, \$, & ...
2dup 1- chars + c@ [char] . =   \ process double
IF dup 1 chars = IF over 1 swap c! false ELSE 1 chars - true THEN
\ only if more than only . ( may be number output! )
\ if only . => store garbage
ELSE false THEN >r      \ numbers
false -rot base @ -rot
BEGIN over c@
dup [char] - =
IF drop >r >r >r
drop true r> r> r> 0 THEN
dup [char] + =
IF drop 0 THEN
dup [char] \$ =
IF drop >r >r drop 16 r> r> 0 THEN
dup [char] & =
IF drop >r >r drop 10 r> r> 0 THEN
0= IF 1 chars - swap char+ swap false ELSE true THEN
over 0= or
UNTIL
rot >r rot r> r> -rot ;

: number? ( c-addr -- n/d flag )
\ return -1 if cell 1 if double 0 if garbage
0 swap 0 swap           \ create double number
base @ >r base !
>r >r
>number IF 2drop false r> r> 2drop
r> base ! EXIT THEN
drop r> r>
IF IF dnegate 1
ELSE drop negate -1 THEN
ELSE IF 1 ELSE drop -1 THEN
THEN r> base ! ;

2dup s" (" compare 0=
IF    postpone (
ELSE  2dup s" \" compare 0= IF postpone \ THEN
THEN ;

decimal

\ Begin CROSS COMPILER:  \ Begin CROSS COMPILER:

Line 75  VARIABLE GhostNames Line 40  VARIABLE GhostNames
0 GhostNames !  0 GhostNames !
: GhostName ( -- addr )  : GhostName ( -- addr )
here GhostNames @ , GhostNames ! here 0 ,          here GhostNames @ , GhostNames ! here 0 ,
name count          bl word count
\        2dup type space  \        2dup type space
dup c, here over chars allot swap move align ;          dup c, here over chars allot swap move align ;

Line 117  Variable bit\$ Line 82  Variable bit\$
Variable tdp  Variable tdp
: there  tdp @ ;  : there  tdp @ ;

\ Constants                                            06apr93py

-2 Constant :docol
-3 Constant :docon
-4 Constant :dovar
-5 Constant :dodoes

\ Parameter for target systems                         06oct92py  \ Parameter for target systems                         06oct92py

include machine.fs  included

>TARGET  >TARGET

Line 135  include machine.fs Line 93  include machine.fs
: cell+         cell + ;  : cell+         cell + ;
: cells         cell<< lshift ;  : cells         cell<< lshift ;
: chars         ;  : chars         ;
: floats        float * ;

>CROSS  >CROSS
: cell/         cell<< rshift ;  : cell/         cell<< rshift ;
>TARGET  >TARGET
Line 144  include machine.fs Line 103  include machine.fs
-2 Constant :docol  -2 Constant :docol
-3 Constant :docon  -3 Constant :docon
-4 Constant :dovar  -4 Constant :dovar
-5 Constant :dodoes  -5 Constant :douser
-6 Constant :dodefer
-7 Constant :dodoes
-8 Constant :doesjump

>CROSS  >CROSS

= [IF]   : bswap ; immediate   = [IF]   : bswap ; immediate
[ELSE]   : bswap ( big / little -- little / big )  0  [ELSE]   : bswap ( big / little -- little / big )  0
cell 1- FOR  bits/byte lshift over             cell 1- FOR  bits/byte lshift over
\ Fixed bug in else part                               11may93jaw  \ Fixed bug in else part                               11may93jaw

[IFDEF] Memory \ Memory is a bigFORTH feature  [IFDEF] Memory \ Memory is a bigFORTH feature
Memory     also Memory
: initmem ( var len -- )     : initmem ( var len -- )
2dup swap handle! >r @ r> erase ;       2dup swap handle! >r @ r> erase ;
Target     toss
[ELSE]  [ELSE]
: initmem ( var len -- )     : initmem ( var len -- )
tuck allocate abort" CROSS: No memory for target"       tuck allocate abort" CROSS: No memory for target"
Line 186  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 148  CREATE Bittable 80 c, 40 c, 20 c, 10 c,

: +bit ( addr n -- )  >bit over c@ or swap c! ;  : +bit ( addr n -- )  >bit over c@ or swap c! ;
: -bit ( addr n -- )  >bit invert over c@ and swap c! ;
: relon ( taddr -- )  bit\$ @ swap cell/ +bit ;  : relon ( taddr -- )  bit\$ @ swap cell/ +bit ;
: reloff ( taddr -- )  bit\$ @ swap cell/ -bit ;

\ Target memory access                                 06oct92py  \ Target memory access                                 06oct92py

Line 204  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 168  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
: !  ( w taddr -- )     >r bswap r> >image ! ;  : !  ( w taddr -- )     >r bswap r> >image ! ;
: c@ ( taddr -- char )  >image c@ ;  : c@ ( taddr -- char )  >image c@ ;
: c! ( char taddr -- )  >image c! ;  : c! ( char taddr -- )  >image c! ;
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;

\ Target compilation primitives                        06oct92py  \ Target compilation primitives                        06oct92py
\ included A!                                          16may93jaw  \ included A!                                          16may93jaw
Line 228  CREATE Bittable 80 c, 40 c, 20 c, 10 c, Line 194  CREATE Bittable 80 c, 40 c, 20 c, 10 c,
: >body   ( cfa -- pfa ) T cell+ cell+ H ;  : >body   ( cfa -- pfa ) T cell+ cell+ H ;
>CROSS  >CROSS

: dodoes, ( -- ) T 0 , 0 , H ;  : dodoes, ( -- ) T :doesjump A, 0 , H ;

\ Ghost Builder                                        06oct92py  \ Ghost Builder                                        06oct92py

Line 254  Variable atonce atonce off Line 220  Variable atonce atonce off
: >magic ; : >link cell+ ; : >exec cell+ cell+ ;  : >magic ; : >link cell+ ; : >exec cell+ cell+ ;
: >end 3 cells + ;  : >end 3 cells + ;

Variable last-ghost
: Make-Ghost ( "name" -- ghost )  : Make-Ghost ( "name" -- ghost )
>in @ GhostName swap >in !    >in @ GhostName swap >in !
<T Create atonce @ IF immediate atonce off THEN    <T Create atonce @ IF immediate atonce off THEN
here tuck swap ! ghostheader T>    here tuck swap ! ghostheader T>
DOES>  >exec @ execute ;    DOES> dup last-ghost ! >exec @ execute ;

\ ghost words                                          14oct92py  \ ghost words                                          14oct92py
\                                          changed:    10may93py/jaw  \                                          changed:    10may93py/jaw
Line 266  Variable atonce atonce off Line 233  Variable atonce atonce off
: gfind   ( string -- ghost true/1 / string false )  : gfind   ( string -- ghost true/1 / string false )
\ searches for string in word-list ghosts  \ searches for string in word-list ghosts
\ !! wouldn't it be simpler to just use search-wordlist ? ae  \ !! wouldn't it be simpler to just use search-wordlist ? ae
>r get-order  0 set-order also ghosts  r> find >r >r    dup count [ ' ghosts >body ] ALiteral search-wordlist
set-order  r> r@  IF  >body  THEN  r> ;    dup IF  >r >body nip r>  THEN ;

: ghost   ( "name" -- ghost )  : ghost   ( "name" -- ghost )
>in @  name gfind   IF  Already on nip EXIT  THEN    >in @  bl word gfind   IF  Already on nip EXIT  THEN
drop  >in !  Make-Ghost ;    drop  >in !  Make-Ghost ;

\ resolve                                              14oct92py  \ resolve                                              14oct92py
Line 328  variable ResolveFlag Line 295  variable ResolveFlag
Ghostnames    Ghostnames
BEGIN @ dup    BEGIN @ dup
WHILE dup ?resolved    WHILE dup ?resolved
REPEAT drop ResolveFlag @ 0= IF ." Nothing!" THEN cr ;    REPEAT drop ResolveFlag @
IF
abort" Unresolved words!"
ELSE
." Nothing!"
THEN
cr ;

>CROSS  >CROSS
Line 342  VARIABLE ^imm Line 315  VARIABLE ^imm
^imm @ @ dup <imm> = ?EXIT                  ^imm @ @ dup <imm> = ?EXIT
<res> <> ABORT" CROSS: Cannot immediate a unresolved word"                  <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
<imm> ^imm @ ! ;                  <imm> ^imm @ ! ;
: restrict      ;  : restrict      40 flag! ;
>CROSS  >CROSS

\ ALIAS2 ansforth conform alias                          9may93jaw  \ ALIAS2 ansforth conform alias                          9may93jaw
Line 355  VARIABLE ^imm Line 328  VARIABLE ^imm

: string,  ( addr count -- )  : string,  ( addr count -- )
dup T c, H bounds  DO  I c@ T c, H  LOOP ;     dup T c, H bounds  DO  I c@ T c, H  LOOP ;
: name,  ( "name" -- )  name count string, T align H ;  : name,  ( "name" -- )  bl word count string, T align H ;
: view,   ( -- ) ( dummy ) ;  : view,   ( -- ) ( dummy ) ;

VARIABLE CreateFlag CreateFlag off  VARIABLE CreateFlag CreateFlag off
Line 376  VARIABLE CreateFlag CreateFlag off Line 349  VARIABLE CreateFlag CreateFlag off

VARIABLE ;Resolve 1 cells allot  VARIABLE ;Resolve 1 cells allot

: Theader  ( "name" -- )     (THeader there resolve 0 ;Resolve ! ;  : Theader  ( "name" -- ghost )
(THeader dup there resolve 0 ;Resolve ! ;

>TARGET  >TARGET
: Alias    ( cfa -- ) \ name  : Alias    ( cfa -- ) \ name
Line 416  ghost unloop    ghost ;S Line 390  ghost unloop    ghost ;S
ghost lit       ghost (compile) ghost !         2drop drop  ghost lit       ghost (compile) ghost !         2drop drop
ghost (;code)   ghost noop                      2drop  ghost (;code)   ghost noop                      2drop
ghost (.")      ghost (S")      ghost (ABORT")  2drop drop  ghost (.")      ghost (S")      ghost (ABORT")  2drop drop
ghost '

\ compile                                              10may93jaw  \ compile                                              10may93jaw

: compile  ( -- ) \ name  : compile  ( -- ) \ name
restrict?    restrict?
name gfind dup 0= ABORT" CROSS: Can't compile "    bl word gfind dup 0= ABORT" CROSS: Can't compile "
0> ( immediate? )    0> ( immediate? )
IF    >exec @ compile,    IF    >exec @ compile,
ELSE  postpone literal postpone gexecute  THEN ;    ELSE  postpone literal postpone gexecute  THEN ;
immediate                                          immediate

>TARGET  >TARGET
: '  ( -- cfa ) name gfind 0= ABORT" CROSS: undefined "  : '  ( -- cfa ) bl word gfind 0= ABORT" CROSS: undefined "
dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;    dup >magic @ <fwd> = ABORT" CROSS: forward " >link @ ;

Cond: [']  compile lit ghost gexecute ;Cond  Cond: [']  compile lit ghost gexecute ;Cond
Line 465  Cond: [Char]   ( "<char>" -- )  restrict Line 440  Cond: [Char]   ( "<char>" -- )  restrict

: ] state on  : ] state on
BEGIN      BEGIN
BEGIN >in @ name          BEGIN >in @ bl word
dup c@ 0= WHILE 2drop refill 0=                dup c@ 0= WHILE 2drop refill 0=
ABORT" CROSS: End of file while target compiling"                ABORT" CROSS: End of file while target compiling"
REPEAT          REPEAT
Line 483  Cond: [Char]   ( "<char>" -- )  restrict Line 458  Cond: [Char]   ( "<char>" -- )  restrict

Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond  Cond: EXIT ( -- )  restrict?  compile ;S  ;Cond

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

Cond: ; ( -- ) restrict?  Cond: ; ( -- ) restrict?
depth ?dup IF   1- <> ABORT" CROSS: Stack changed"                 depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
ELSE true ABORT" CROSS: Stack empty" THEN                            ELSE true ABORT" CROSS: Stack empty" THEN
Line 510  Cond: DOES> restrict? Line 487  Cond: DOES> restrict?
>in @ alias2 swap dup >in ! >r >r    >in @ alias2 swap dup >in ! >r >r
Make-Ghost rot swap >exec ! ,    Make-Ghost rot swap >exec ! ,
r> r> >in !    r> r> >in !
also ghosts ' previous swap !    also ghosts ' previous swap ! ;
DOES> dup >exec @ execute ;  \  DOES>  dup >exec @ execute ;

: gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>  : gdoes,  ( ghost -- )  >end @ dup >magic @ <fwd> <>
IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN    IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
:dodoes T A, H gexecute ;    :dodoes T A, H gexecute T here H cell - reloff ;

: TCreate ( ghost -- )  : TCreate ( -- )
last-ghost @
CreateFlag on    CreateFlag on
>end @ >exec @ execute ;    >end @ >exec @ r> >exec ! ;

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

: gdoes>  ( ghost -- addr flag )  : gdoes>  ( ghost -- addr flag )
last-ghost @
state @ IF  gexecute true EXIT  THEN    state @ IF  gexecute true EXIT  THEN
cell+ @ T >body H false ;    cell+ @ T >body H false ;

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

: (does>)        postpone does> ; immediate \ second level does>

: DO:     ( -- addr [xt] [colon-sys] )  : DO:     ( -- addr [xt] [colon-sys] )
:noname    :noname postpone gdoes> postpone ?EXIT ;
postpone (does>) postpone gdoes> postpone ?EXIT ;

: ;DO ( addr [xt] [colon-sys] -- )  : ;DO ( addr [xt] [colon-sys] -- )
postpone ;    ( S addr xt )    postpone ;    ( S addr xt )
Line 562  Build: T 0 A, H ; Line 538  Build: T 0 A, H ;
by Create  by Create
Builder AVariable  Builder AVariable

Build: T 0 , H ;  \ User variables                                       04may94py
by Create
>CROSS
Variable tup  0 tup !
Variable tudp 0 tudp !
: u,  ( n -- udp )
tup @ tudp @ + T  ! H
tudp @ dup cell+ tudp ! ;
: au, ( n -- udp )
tup @ tudp @ + T A! H
tudp @ dup cell+ tudp ! ;
>TARGET

Build: T 0 u, , H ;
DO: ( ghost -- up-addr )  T @ H tup @ + ;DO
Builder User  Builder User
by User :douser resolve

Build: T 0 , 0 , H ;  Build: T 0 u, , 0 u, drop H ;
by Create  by User
Builder 2User  Builder 2User

Build: T 0 A, H ;  Build: T 0 au, , H ;
by Create  by User
Builder AUser  Builder AUser

Build:  ( n -- ) T , H ;  Build:  ( n -- ) T , H ;
Line 590  Builder Value Line 580  Builder Value
Build:  ( -- ) compile noop ;  Build:  ( -- ) compile noop ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO  DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder Defer  Builder Defer
by Defer :dodefer resolve

\ structural conditionals                              17dec92py  \ structural conditionals                              17dec92py

Line 658  Cond: ABORT"    restrict? compile (ABORT Line 649  Cond: ABORT"    restrict? compile (ABORT

Cond: IS        T ' >body H compile ALiteral compile ! ;Cond  Cond: IS        T ' >body H compile ALiteral compile ! ;Cond
: IS            T ' >body ! H ;  : IS            T ' >body ! H ;
Cond: TO        T ' >body H compile ALiteral compile ! ;Cond
: TO            T ' >body ! H ;

\ LINKED ERR" ENV" 2ENV"                                18may93jaw  \ LINKED ERR" ENV" 2ENV"                                18may93jaw

Line 677  Cond: IS        T ' >body H compile ALit Line 670  Cond: IS        T ' >body H compile ALit
\ compile must be last                                 22feb93py  \ compile must be last                                 22feb93py

Cond: compile ( -- ) restrict? \ name  Cond: compile ( -- ) restrict? \ name
name gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
0> IF    gexecute        0> IF    gexecute
ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
IF   gexecute                 IF   gexecute
ELSE compile (compile) gexecute THEN THEN ;Cond                 ELSE compile (compile) gexecute THEN THEN ;Cond

Cond: postpone ( -- ) restrict? \ name  Cond: postpone ( -- ) restrict? \ name
name gfind dup 0= ABORT" CROSS: Can't compile"        bl word gfind dup 0= ABORT" CROSS: Can't compile"
0> IF    gexecute        0> IF    gexecute
ELSE  dup >magic @ <imm> =           ELSE  dup >magic @ <imm> =
IF   gexecute                 IF   gexecute
Line 698  also minimal Line 691  also minimal

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

: there? name gfind IF >magic @ <fwd> <> ELSE drop false THEN ;  : there? bl word gfind IF >magic @ <fwd> <> ELSE drop false THEN ;

: [IFDEF] there? postpone [IF] ;  : [IFDEF] there? postpone [IF] ;
: [IFUNDEF] there? 0= postpone [IF] ;  : [IFUNDEF] there? 0= postpone [IF] ;
Line 738  Cond: [ELSE]    [ELSE] ;Cond Line 731  Cond: [ELSE]    [ELSE] ;Cond
\ [THEN]  \ [THEN]
\ included throw after create-file                     11may93jaw  \ included throw after create-file                     11may93jaw

endian Constant endian  bigendian Constant bigendian

: save-cross ( "name" -- )  : save-cross ( "name" -- )
bl parse ." Saving to " 2dup type    bl parse ." Saving to " 2dup type
Line 751  endian Constant endian Line 744  endian Constant endian

: + + ;         : 1- 1- ;  : + + ;         : 1- 1- ;
: - - ;         : 2* 2* ;  : - - ;         : 2* 2* ;
: * * ;         : / / ;
: dup dup ;     : over over ;  : dup dup ;     : over over ;
: swap swap ;   : rot rot ;  : swap swap ;   : rot rot ;
: drop drop ;
: lshift lshift ; : 2/ 2/ ;
cell constant cell

\ include bug5.fs  \ include bug5.fs
\ only forth also minimal definitions  \ only forth also minimal definitions
Line 771  only forth also minimal definitions Line 768  only forth also minimal definitions
: decimal       decimal ;  : decimal       decimal ;
: hex           hex ;  : hex           hex ;

: tudp          T tudp H ;
: tup           T tup H ;  minimal

\ for debugging...  \ for debugging...
: order         order ;  : order         order ;

 Removed from v.1.2 changed lines Added in v.1.13

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>