### Diff for /gforth/cross.fs between versions 1.3 and 1.11

version 1.3, 1994/05/05 15:46:38 version 1.11, 1994/09/02 15:23:33
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 119  Variable tdp Line 84  Variable tdp

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

include machine.fs  include-file

>TARGET  >TARGET

Line 128  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 138  include machine.fs Line 104  include machine.fs
-3 Constant :docon  -3 Constant :docon
-4 Constant :dovar  -4 Constant :dovar
-5 Constant :douser  -5 Constant :douser
-6 Constant :dodoes  -6 Constant :dodefer
-7 Constant :doesjump  -7 Constant :dodoes
-8 Constant :doesjump

>CROSS  >CROSS

\ 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 181  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 199  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 249  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 261  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> ;  \ >r get-order  0 set-order also ghosts  r> find >r >r
>r r@ IF  >body nip  THEN  r> ;
\ set-order  r> r@  IF  >body  THEN  r> ;

Line 323  variable ResolveFlag Line 297  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 337  VARIABLE ^imm Line 317  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 371  VARIABLE CreateFlag CreateFlag off Line 351  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 411  ghost unloop    ghost ;S Line 392  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

Line 478  Cond: [Char]   ( "<char>" -- )  restrict Line 460  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 505  Cond: DOES> restrict? Line 489  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 599  Builder Value Line 582  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 667  Cond: ABORT"    restrict? compile (ABORT Line 651  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 760  endian Constant endian Line 746  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 ;

 Removed from v.1.3 changed lines Added in v.1.11

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