Diff for /gforth/cross.fs between versions 1.1 and 1.10

version 1.1, 1994/02/11 16:30:45 version 1.10, 1994/08/25 15:25:20
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 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  include-file

>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

\ 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 266  Variable atonce atonce off Line 232  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 328  variable ResolveFlag Line 296  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
1 (bye)
ELSE
." Nothing!"
THEN
cr ;

>CROSS  >CROSS
Line 342  VARIABLE ^imm Line 316  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 412  ghost (do)      ghost (?do) Line 386  ghost (do)      ghost (?do)
ghost (for)                                     drop  ghost (for)                                     drop
ghost (loop)    ghost (+loop)                   2drop  ghost (loop)    ghost (+loop)                   2drop
ghost (next)                                    drop  ghost (next)                                    drop
ghost unloop    ghost EXIT                      2drop  ghost unloop    ghost ;S                        2drop
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 481  Cond: [Char]   ( "<char>" -- )  restrict Line 456  Cond: [Char]   ( "<char>" -- )  restrict
(THeader ;Resolve ! there ;Resolve cell+ !    (THeader ;Resolve ! there ;Resolve cell+ !
docol, depth T ] H ;    docol, depth T ] H ;

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
compile EXIT state off                 compile ;S state off
;Resolve @                 ;Resolve @
IF ;Resolve @ ;Resolve cell+ @ resolve THEN                 IF ;Resolve @ ;Resolve cell+ @ resolve THEN
;Cond                 ;Cond
Line 513  Cond: DOES> restrict? Line 492  Cond: DOES> restrict?

: 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 ( ghost -- )
CreateFlag on    CreateFlag on
Line 560  Build: T 0 A, H ; Line 539  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 588  Builder Value Line 581  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 656  Cond: ABORT"    restrict? compile (ABORT Line 650  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 769  only forth also minimal definitions Line 765  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.1 changed lines Added in v.1.10

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