File:  [gforth] / gforth / cross.fs
Revision 1.103: download - view: text, annotated - select for diffs
Tue Sep 4 13:06:06 2001 UTC (18 years, 2 months ago) by jwilke
Branches: MAIN
CVS tags: HEAD
lots of changes from the G&D project
- relocatable assembler output
- vocabularies support prepared
- lots of cleanup
- hooks for instant (target execution while cross-compilation)
- peephole changes from bernd missing
- genereation of kernl32l.fi works correctly

\ CROSS.FS     The Cross-Compiler                      06oct92py
\ Idea and implementation: Bernd Paysan (py)

\ Copyright (C) 1995,1996,1997,1998,1999,2000 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.

0 
[IF]

ToDo:
Crossdoc destination ./doc/crossdoc.fd makes no sense when
cross.fs is uses seperately. jaw
Do we need this char translation with >address and in branchoffset? 
(>body also affected) jaw
Clean up mark> and >resolve stuff jaw

[THEN]

hex

\ debugging for compiling

\ print stack at each colon definition
\ : : save-input cr bl word count type restore-input throw .s : ;

\ print stack at each created word
\ : create save-input cr bl word count type restore-input throw .s create ;


\ \ -------------  Setup Vocabularies

\ Remark: Vocabulary is not ANS, but it should work...

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

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

forth definitions

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

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

H

>CROSS

\ find out whether we are compiling with gforth

: defined? bl word find nip ;
defined? emit-file defined? toupper and \ drop 0
[IF]
\ use this in a gforth system
: \GFORTH ; immediate
: \ANSI postpone \ ; immediate
[ELSE]
: \GFORTH postpone \ ; immediate
: \ANSI ; immediate
[THEN]

\ANSI : [IFUNDEF] defined? 0= postpone [IF] ; immediate
\ANSI : [IFDEF] defined? postpone [IF] ; immediate
0 \ANSI drop 1
[IF]
: \G postpone \ ; immediate
: rdrop postpone r> postpone drop ; immediate
: name bl word count ;
: bounds over + swap ;
: scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ;
: linked here over @ , swap ! ;
: alias create , DOES> @ EXECUTE ;
: defer ['] noop alias ;
: is state @ 
  IF ' >body postpone literal postpone ! 
  ELSE ' >body ! THEN ; immediate
: 0>= 0< 0= ;
: d<> rot <> -rot <> or ;
: toupper dup [char] a [char] z 1+ within IF [char] A [char] a - + THEN ;
Variable ebuf
: emit-file ( c fd -- ior ) swap ebuf c! ebuf 1 chars rot write-file ;
0a Constant #lf
0d Constant #cr

[IFUNDEF] Warnings Variable Warnings [THEN]

\ \ Number parsing					23feb93py

\ number? number                                       23feb93py

Variable dpl

hex
Create bases   10 ,   2 ,   A , 100 ,
\              16     2    10   character

\ !! protect BASE saving wrapper against exceptions
: getbase ( addr u -- addr' u' )
    over c@ [char] $ - dup 4 u<
    IF
	cells bases + @ base ! 1 /string
    ELSE
	drop
    THEN ;

: sign? ( addr u -- addr u flag )
    over c@ [char] - =  dup >r
    IF
	1 /string
    THEN
    r> ;

: s>unumber? ( addr u -- ud flag )
    over [char] ' =
    IF 	\ a ' alone is rather unusual :-)
	drop char+ c@ 0 true EXIT 
    THEN
    base @ >r  dpl on  getbase
    0. 2swap
    BEGIN ( d addr len )
	dup >r >number dup
    WHILE \ there are characters left
	dup r> -
    WHILE \ the last >number parsed something
	dup 1- dpl ! over c@ [char] . =
    WHILE \ the current char is '.'
	1 /string
    REPEAT  THEN \ there are unparseable characters left
	2drop false
    ELSE
	rdrop 2drop true
    THEN
    r> base ! ;

\ ouch, this is complicated; there must be a simpler way - anton
: s>number? ( addr len -- d f )
    \ converts string addr len into d, flag indicates success
    sign? >r
    s>unumber?
    0= IF
        rdrop false
    ELSE \ no characters left, all ok
	r>
	IF
	    dnegate
	THEN
	true
    THEN ;

: s>number ( addr len -- d )
    \ don't use this, there is no way to tell success
    s>number? drop ;

: snumber? ( c-addr u -- 0 / n -1 / d 0> )
    s>number? 0=
    IF
	2drop false  EXIT
    THEN
    dpl @ dup 0< IF
	nip
    ELSE
	1+
    THEN ;

: number? ( string -- string 0 / n -1 / d 0> )
    dup >r count snumber? dup if
	rdrop
    else
	r> swap
    then ;

: number ( string -- d )
    number? ?dup 0= abort" ?"  0<
    IF
	s>d
    THEN ;

[THEN]

hex     \ the defualt base for the cross-compiler is hex !!
\ Warnings off

\ words that are generaly useful

: KB  400 * ;
: >wordlist ( vocabulary-xt -- wordlist-struct )
  also execute get-order swap >r 1- set-order r> ;

: umax 2dup u< IF swap THEN drop ;
: umin 2dup u> IF swap THEN drop ;

: string, ( c-addr u -- )
    \ puts down string as cstring
    dup c, here swap chars dup allot move ;

: ," [char] " parse string, ;

: SetValue ( n -- <name> )
\G Same behaviour as "Value" if the <name> is not defined
\G Same behaviour as "to" if <name> is defined
\G SetValue searches in the current vocabulary
  save-input bl word >r restore-input throw r> count
  get-current search-wordlist
  IF	drop >r
	\ we have to set current to be topmost context wordlist
	get-order get-order get-current swap 1+ set-order
	r> ['] to execute
	set-order
  ELSE Value THEN ;

: DefaultValue ( n -- <name> )
\G Same behaviour as "Value" if the <name> is not defined
\G DefaultValue searches in the current vocabulary
 save-input bl word >r restore-input throw r> count
 get-current search-wordlist
 IF bl word drop 2drop ELSE Value THEN ;

hex

\ 1 Constant Cross-Flag	\ to check whether assembler compiler plug-ins are
			\ for cross-compiling
\ No! we use "[IFUNDEF]" there to find out whether we are target compiling!!!

: comment? ( c-addr u -- c-addr u )
        2dup s" (" compare 0=
        IF    postpone (
        ELSE  2dup s" \" compare 0= IF postpone \ THEN
        THEN ;

\ Begin CROSS COMPILER:

\ debugging

0 [IF]

This implements debugflags for the cross compiler and the compiled
images. It works identical to the has-flags in the environment.
The debugflags are defined in a vocabluary. If the word exists and
its value is true, the flag is switched on.

[THEN]

>CROSS

Vocabulary debugflags	\ debug flags for cross
also debugflags get-order over
Constant debugflags-wl
set-order previous

: DebugFlag
  get-current >r debugflags-wl set-current
  SetValue
  r> set-current ;

: Debug? ( adr u -- flag )
\G return true if debug flag is defined or switched on
  debugflags-wl search-wordlist
  IF EXECUTE
  ELSE false THEN ;

: D? ( <name> -- flag )
\G return true if debug flag is defined or switched on
\G while compiling we do not return the current value but
  bl word count debug? ;

: [d?]
\G compile the value-xt so the debug flag can be switched
\G the flag must exist!
  bl word count debugflags-wl search-wordlist
  IF 	compile,
  ELSE  -1 ABORT" unknown debug flag"
	\ POSTPONE false 
  THEN ; immediate

\ \ --------------------	source file

decimal

Variable cross-file-list
0 cross-file-list !
Variable target-file-list
0 target-file-list !
Variable host-file-list
0 host-file-list !

cross-file-list Value file-list
0 Value source-desc

\ file loading

: >fl-id   1 cells + ;
: >fl-name 2 cells + ;

Variable filelist 0 filelist !
Create NoFile ," #load-file#"

: loadfile ( -- adr )
  source-desc ?dup IF >fl-name ELSE NoFile THEN ;

: sourcefilename ( -- adr len ) 
  loadfile count ;

\ANSI : sourceline# 0 ;

\ \ --------------------	path handling from kernel/paths.fs

\ paths.fs path file handling                                    03may97jaw

\ -Changing the search-path:
\ fpath+ <path> 	adds a directory to the searchpath
\ fpath= <path>|<path>	makes complete now searchpath
\ 			seperator is |
\ .fpath		displays the search path
\ remark I: 
\ a ./ in the beginning of filename is expanded to the directory the
\ current file comes from. ./ can also be included in the search-path!
\ ~+/ loads from the current working directory

\ remark II:
\ if there is no sufficient space for the search path increase it!


\ -Creating custom paths:

\ It is possible to use the search mechanism on yourself.

\ Make a buffer for the path:
\ create mypath	100 chars , 	\ maximum length (is checked)
\ 		0 ,		\ real len
\ 		100 chars allot \ space for path
\ use the same functions as above with:
\ mypath path+ 
\ mypath path=
\ mypath .path

\ do a open with the search path:
\ open-path-file ( adr len path -- fd adr len ior )
\ the file is opened read-only; if the file is not found an error is generated

\ questions to: wilke@jwdt.com

[IFUNDEF] +place
: +place ( adr len adr )
        2dup >r >r
        dup c@ char+ + swap move
        r> r> dup c@ rot + swap c! ;
[THEN]

[IFUNDEF] place
: place ( c-addr1 u c-addr2 )
        2dup c! char+ swap move ;
[THEN]

\ if we have path handling, use this and the setup of it
[IFUNDEF] open-fpath-file

create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic
sourcepath value fpath

: also-path ( adr len path^ -- )
  >r
  \ len check
  r@ cell+ @ over + r@ @ u> ABORT" path buffer too small!"
  \ copy into
  tuck r@ cell+ dup @ cell+ + swap cmove
  \ make delimiter
  0 r@ cell+ dup @ cell+ + 2 pick + c! 1 + r> cell+ +!
  ;

: only-path ( adr len path^ -- )
  dup 0 swap cell+ ! also-path ;

: path+ ( path-addr  "dir" -- ) \ gforth
    \G Add the directory @var{dir} to the search path @var{path-addr}.
    name rot also-path ;

: fpath+ ( "dir" ) \ gforth
    \G Add directory @var{dir} to the Forth search path.
    fpath path+ ;

: path= ( path-addr "dir1|dir2|dir3" ) \ gforth
    \G Make a complete new search path; the path separator is |.
    name 2dup bounds ?DO i c@ [char] | = IF 0 i c! THEN LOOP
    rot only-path ;

: fpath= ( "dir1|dir2|dir3" ) \ gforth
    \G Make a complete new Forth search path; the path separator is |.
    fpath path= ;

: path>counted  cell+ dup cell+ swap @ ;

: next-path ( adr len -- adr2 len2 )
  2dup 0 scan
  dup 0= IF     2drop 0 -rot 0 -rot EXIT THEN
  >r 1+ -rot r@ 1- -rot
  r> - ;

: previous-path ( path^ -- )
  dup path>counted
  BEGIN tuck dup WHILE repeat ;

: .path ( path-addr -- ) \ gforth
    \G Display the contents of the search path @var{path-addr}.
    path>counted
    BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ;

: .fpath ( -- ) \ gforth
    \G Display the contents of the Forth search path.
    fpath .path ;

: absolut-path? ( addr u -- flag ) \ gforth
    \G A path is absolute if it starts with a / or a ~ (~ expansion),
    \G or if it is in the form ./*, extended regexp: ^[/~]|./, or if
    \G it has a colon as second character ("C:...").  Paths simply
    \G containing a / are not absolute!
    2dup 2 u> swap 1+ c@ [char] : = and >r \ dos absoulte: c:/....
    over c@ [char] / = >r
    over c@ [char] ~ = >r
    \ 2dup 3 min S" ../" compare 0= r> or >r \ not catered for in expandtopic
    2 min S" ./" compare 0=
    r> r> r> or or or ;

Create ofile 0 c, 255 chars allot
Create tfile 0 c, 255 chars allot

: pathsep? dup [char] / = swap [char] \ = or ;

: need/   ofile dup c@ + c@ pathsep? 0= IF s" /" ofile +place THEN ;

: extractpath ( adr len -- adr len2 )
  BEGIN dup WHILE 1-
        2dup + c@ pathsep? IF EXIT THEN
  REPEAT ;

: remove~+ ( -- )
    ofile count 3 min s" ~+/" compare 0=
    IF
	ofile count 3 /string ofile place
    THEN ;

: expandtopic ( -- ) \ stack effect correct? - anton
    \ expands "./" into an absolute name
    ofile count 2 min s" ./" compare 0=
    IF
	ofile count 1 /string tfile place
	0 ofile c! sourcefilename extractpath ofile place
	ofile c@ IF need/ THEN
	tfile count over c@ pathsep? IF 1 /string THEN
	ofile +place
    THEN ;

: compact.. ( adr len -- adr2 len2 )
    \ deletes phrases like "xy/.." out of our directory name 2dec97jaw
    over swap
    BEGIN  dup  WHILE
        dup >r '/ scan 2dup 4 min s" /../" compare 0=
        IF
            dup r> - >r 4 /string over r> + 4 -
            swap 2dup + >r move dup r> over -
        ELSE
            rdrop dup 1 min /string
        THEN
    REPEAT  drop over - ;

: reworkdir ( -- )
  remove~+
  ofile count compact..
  nip ofile c! ;

: open-ofile ( -- fid ior )
    \G opens the file whose name is in ofile
    expandtopic reworkdir
    ofile count r/o open-file ;

: check-path ( adr1 len1 adr2 len2 -- fd 0 | 0 <>0 )
  0 ofile ! >r >r ofile place need/
  r> r> ofile +place
  open-ofile ;

: open-path-file ( addr1 u1 path-addr -- wfileid addr2 u2 0 | ior ) \ gforth
    \G Look in path @var{path-addr} for the file specified by @var{addr1 u1}.
    \G If found, the resulting path and an open file descriptor
    \G are returned. If the file is not found, @var{ior} is non-zero.
  >r
  2dup absolut-path?
  IF    rdrop
        ofile place open-ofile
	dup 0= IF >r ofile count r> THEN EXIT
  ELSE  r> path>counted
        BEGIN  next-path dup
        WHILE  5 pick 5 pick check-path
        0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN
  REPEAT
        2drop 2drop 2drop -38
  THEN ;

: open-fpath-file ( addr1 u1 -- wfileid addr2 u2 0 | ior ) \ gforth
    \G Look in the Forth search path for the file specified by @var{addr1 u1}.
    \G If found, the resulting path and an open file descriptor
    \G are returned. If the file is not found, @var{ior} is non-zero.
    fpath open-path-file ;

fpath= ~+

[THEN]

\ \ --------------------	include require			13may99jaw

>CROSS

: add-included-file ( adr len -- adr )
  dup >fl-name char+ allocate throw >r
  file-list @ r@ ! r@ file-list !
  r@ >fl-name place r> ;

: included? ( c-addr u -- f )
  file-list
  BEGIN	@ dup
  WHILE	>r 2dup r@ >fl-name count compare 0=
	IF rdrop 2drop true EXIT THEN
	r>
  REPEAT
  2drop drop false ;	

false DebugFlag showincludedfiles

: included1 ( fd adr u -- )
\ include file adr u / fd
\ we don't use fd with include-file, because the forth system
\ doesn't know the name of the file to get a nice error report
  [d?] showincludedfiles
  IF	cr ." Including: " 2dup type ." ..." THEN
  rot close-file throw
  source-desc >r
  add-included-file to source-desc 
  sourcefilename
  ['] included catch
  r> to source-desc 
  throw ;

: included ( adr len -- )
	cross-file-list to file-list
	open-fpath-file throw 
        included1 ;

: required ( adr len -- )
	cross-file-list to file-list
	open-fpath-file throw \ 2dup cr ." R:" type
	2dup included?
	IF 	2drop close-file throw
	ELSE	included1
	THEN ;

: include bl word count included ;

: require bl word count required ;

0 [IF]

also forth definitions previous

: included ( adr len -- ) included ;

: required ( adr len -- ) required ;

: include include ;

: require require ;

[THEN]

>CROSS
hex

\ \ --------------------        Error Handling                  05aug97jaw

\ Flags

also forth definitions  \ these values may be predefined before
                        \ the cross-compiler is loaded

false DefaultValue stack-warn   	 \ check on empty stack at any definition
false DefaultValue create-forward-warn   \ warn on forward declaration of created words

previous >CROSS

: .dec
  base @ decimal swap . base ! ;

: .sourcepos
  cr sourcefilename type ." :"
  sourceline# .dec ;

: warnhead
\G display error-message head
\G perhaps with linenumber and filename
  .sourcepos ." Warning: " ;

: empty? depth IF .sourcepos ." Stack not empty!"  THEN ;

stack-warn [IF]
: defempty? empty? ;
[ELSE]
: defempty? ; immediate
[THEN]

\ Ghost Builder                                        06oct92py

hex
4711 Constant <fwd>             4712 Constant <res>
4713 Constant <imm>             4714 Constant <do:>
4715 Constant <skip>

1 Constant <unique>

Struct

  \ link to next ghost (always the first element)
  cell% field >next-ghost

  \ type of ghost
  cell% field >magic
		
  \ pointer where ghost is in target, or if unresolved
  \ points to the where we have to resolve (linked-list)
  cell% field >link

  \ execution symantics (while target compiling) of ghost
  cell% field >exec

  cell% field >exec-compile

  cell% field >exec2

  cell% field >created

  \ the xt of the created ghost word itself
  cell% field >ghost-xt

  \ pointer to the counted string of the assiciated
  \ assembler label
  cell% field >asm-name

  \ mapped primitives have a special address, so
  \ we are able to detect them
  cell% field >asm-dummyaddr
			
  \ for builder (create, variable...) words
  \ the execution symantics of words built are placed here
  \ this is a doer ghost or a dummy ghost
  cell% field >do:ghost

  cell% field >ghost-flags

  cell% field >ghost-name

End-Struct ghost-struct

Variable ghost-list
0 ghost-list !

Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
\ Variable last-ghost	\ last ghost that is created
Variable last-header-ghost \ last ghost definitions with header

\ space for ghosts resolve structure
\ we create ghosts in a sepearte space
\ and not to the current host dp, because this
\ gives trouble with instant while compiling and creating
\ a ghost for a forward reference
\ BTW: we cannot allocate another memory region
\ because allot will check the overflow!!
Variable cross-space-dp
Create cross-space 250000 allot here 100 allot align 
Constant cross-space-end
cross-space cross-space-dp !
Variable cross-space-dp-orig

: cross-space-used cross-space-dp @ cross-space - ;

: >space ( -- )
  dp @ cross-space-dp-orig !
  cross-space-dp @ dp ! ;

: space> ( -- )
  dp @ dup cross-space-dp !
  cross-space-end u> ABORT" CROSS: cross-space overflow"
  cross-space-dp-orig @ dp ! ;

: execute-exec execute ;
: execute-exec2 execute ;
: execute-exec-compile execute ;

: NoExec
  executed-ghost @ >exec2 @
  ?dup 
  IF   execute-exec2
  ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word"
  THEN ;

: (ghostheader) ( -- )
  ghost-list linked <fwd> , 0 , ['] NoExec , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;

: ghostheader ( -- ) (ghostheader) 0 , ;

' Ghosts >wordlist Constant ghosts-wordlist

\ the current wordlist for ghost definitions in the host
ghosts-wordlist Value current-ghosts

: Make-Ghost ( "name" -- ghost )
  >space
  \ save current and create in ghost vocabulary
  get-current >r current-ghosts set-current
  >in @ Create >in !
  \ some forth systems like iForth need the immediate directly
  \ after the word is created
  \ restore current
  r> set-current
  here (ghostheader)
  bl word count string, align
  space>
  \ set ghost-xt field by doing a search
  dup >ghost-name count 
  current-ghosts search-wordlist
  0= ABORT" CROSS: Just created, must be there!"
  over >ghost-xt !
  DOES> 
      dup executed-ghost !
      >exec @ execute-exec ;

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

Defer search-ghosts

: (search-ghosts) ( adr len -- cfa true | 0 )
  current-ghosts search-wordlist ; 

  ' (search-ghosts) IS search-ghosts

: gsearch ( addr len -- ghost true | 0 )
  search-ghosts
  dup IF swap >body swap THEN ;

: gfind   ( string -- ghost true / string false )
\ searches for string in word-list ghosts
  \ dup count type space
  dup >r count gsearch
  dup IF rdrop ELSE r> swap THEN ;

: gdiscover ( xt -- ghost true | xt false )
  >r ghost-list
  BEGIN @ dup
  WHILE dup >magic @ <fwd> <>
        IF dup >link @ r@ =
           IF rdrop true EXIT THEN
        THEN
  REPEAT
  drop r> false ;

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

: >ghostname ( ghost -- adr len )
  >ghost-name count ;

: forward? ( ghost -- flag )
  >magic @ <fwd> = ;

: undefined? ( ghost -- flag )
  >magic @ dup <fwd> = swap <skip> = or ;

: immediate? ( ghost -- flag )
  >magic @ <imm> = ;

Variable TWarnings
TWarnings on
Variable Exists-Warnings
Exists-Warnings on

: exists-warning ( ghost -- ghost )
  TWarnings @ Exists-Warnings @ and
  IF dup >ghostname warnhead type ."  exists " THEN ;

\ : HeaderGhost Ghost ;

Variable reuse-ghosts reuse-ghosts off

1 [IF] \ FIXME: define when vocs are ready
: HeaderGhost ( "name" -- ghost )
  >in @ 
  bl word count 
\  2dup type space
  current-ghosts search-wordlist
  IF  >body dup undefined? reuse-ghosts @ or
      IF   nip EXIT
      ELSE exists-warning 
      THEN
      drop >in ! 
  ELSE >in ! 
  THEN 
  \ we keep the execution semantics of the prviously
  \ defined words, this is a workaround
  \ for the redefined \ until vocs work
  Make-Ghost ;
[THEN] 

 
: .ghost ( ghost -- ) >ghostname type ;

\ ' >ghostname ALIAS @name

: [G'] ( -- ghost : name )
\G ticks a ghost and returns its address
\  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
  ghost state @ IF postpone literal THEN ; immediate

: ghost>cfa ( ghost -- cfa )
  dup undefined? ABORT" CROSS: forward " >link @ ;
   
1 Constant <label>

Struct
  \ bitmask of address type (not used for now)
  cell% field addr-type
  \ if this address is an xt, this field points to the ghost
  cell% field addr-xt-ghost
  \ a bit mask that tells as what part of the cell
  \ is refenced from an address pointer, used for assembler generation
  cell% field addr-refs
End-Struct addr-struct

: %allocerase ( align size -- addr )
  dup >r %alloc dup r> erase ;

\ returns the addr struct, define it if 0 reference
: define-addr-struct ( addr -- struct-addr )
  dup @ ?dup IF nip EXIT THEN
  addr-struct %allocerase tuck swap ! ;

\ 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
Ghost unloop    Ghost ;S                        2drop
Ghost lit       Ghost (compile) Ghost !         2drop drop
Ghost (does>)   Ghost noop                      2drop
Ghost (.")      Ghost (S")      Ghost (ABORT")  2drop drop
Ghost '                                         drop
Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
Ghost :dovar					drop
Ghost over      Ghost =         Ghost drop      2drop drop
Ghost - drop
Ghost 2drop drop
Ghost 2dup drop



\ \ Parameter for target systems                         06oct92py


>cross
\ we define it ans like...
wordlist Constant target-environment

\ save information of current dictionary to restore with environ>
Variable env-current 

: >ENVIRON get-current env-current ! target-environment set-current ;
: ENVIRON> env-current @ set-current ; 

>TARGET

: environment? ( addr len -- [ x ] true | false )
\G returns the content of environment variable and true or
\G false if not present
   target-environment search-wordlist 
   IF EXECUTE true ELSE false THEN ;

: $has? ( addr len -- x | false )
\G returns the content of environment variable 
\G or false if not present
   T environment? H dup IF drop THEN ;

: e? ( "name" -- x )
\G returns the content of environment variable. 
\G The variable is expected to exist. If not, issue an error.
   bl word count T environment? H 
   0= ABORT" environment variable not defined!" ;

: has? ( "name" --- x | false )
\G returns the content of environment variable 
\G or false if not present
   bl word count T $has? H ;


>ENVIRON get-order get-current swap 1+ set-order
true SetValue compiler
true SetValue cross
true SetValue standard-threading
>TARGET previous

0
[IFDEF] mach-file drop mach-file count 1 [THEN]
[IFDEF] machine-file drop machine-file 1 [THEN]
[IF] 	included hex
[ELSE]  cr ." No machine description!" ABORT 
[THEN]

>ENVIRON

T has? ec H
[IF]
false DefaultValue relocate
false DefaultValue file
false DefaultValue OS
false DefaultValue prims
false DefaultValue floating
false DefaultValue glocals
false DefaultValue dcomps
false DefaultValue hash
false DefaultValue xconds
false DefaultValue header
[THEN]

true DefaultValue interpreter
true DefaultValue ITC
false DefaultValue rom
true DefaultValue standardthreading

>TARGET
s" relocate" T environment? H 
\ JAW why set NIL to this?!
[IF]	drop \ SetValue NIL
[ELSE]	>ENVIRON T NIL H SetValue relocate
[THEN]

>CROSS

\ \ Create additional parameters                         19jan95py

\ currently cross only works for host machines with address-unit-bits
\ eual to 8 because of s! and sc!
\ but I start to query the environment just to modularize a little bit

: check-address-unit-bits ( -- )	
\	s" ADDRESS-UNIT-BITS" environment?
\	IF 8 <> ELSE true THEN
\	ABORT" ADDRESS-UNIT-BITS unknown or not equal to 8!"

\	shit, this doesn't work because environment? is only defined for 
\	gforth.fi and not kernl???.fi
	;

check-address-unit-bits
8 Constant bits/byte	\ we define: byte is address-unit

1 bits/byte lshift Constant maxbyte 
\ this sets byte size for the target machine, (probably right guess) jaw

T
NIL		   	Constant TNIL
cell               	Constant tcell
cell<<             	Constant tcell<<
cell>bit           	Constant tcell>bit
bits/char          	Constant tbits/char
bits/char H bits/byte T /      
			Constant tchar
float             	Constant tfloat
1 bits/char lshift 	Constant tmaxchar
[IFUNDEF] bits/byte
8			Constant tbits/byte
[ELSE]
bits/byte		Constant tbits/byte
[THEN]
H
tbits/char bits/byte /	Constant tbyte


\ Variables                                            06oct92py

Variable image
Variable tlast    TNIL tlast !  \ Last name field
Variable tlastcfa \ Last code field
Variable bit$

\ statistics						10jun97jaw

Variable headers-named 0 headers-named !
Variable user-vars 0 user-vars !

: target>bitmask-size ( u1 -- u2 )
  1- tcell>bit rshift 1+ ;

: allocatetarget ( size --- adr )
  dup allocate ABORT" CROSS: No memory for target"
  swap over swap erase ;

\ \ memregion.fs


Variable last-defined-region    \ pointer to last defined region
Variable region-link            \ linked list with all regions
Variable mirrored-link          \ linked list for mirrored regions
0 dup mirrored-link ! region-link !


: >rname 7 cells + ;
: >rbm   4 cells + ;
: >rmem  5 cells + ;
: >rtype 6 cells + ;
: >rlink 3 cells + ;
: >rdp 2 cells + ;
: >rlen cell+ ;
: >rstart ;


: region ( addr len -- )                
\G create a new region
  \ check whether predefined region exists 
  save-input bl word find >r >r restore-input throw r> r> 0= 
  IF	\ make region
	drop
	save-input create restore-input throw
	here last-defined-region !
	over ( startaddr ) , ( length ) , ( dp ) ,
	region-link linked 0 , 0 , 0 , bl word count string,
  ELSE	\ store new parameters in region
        bl word drop
	>body >r r@ last-defined-region !
	r@ >rlen ! dup r@ >rstart ! r> >rdp !
  THEN ;

: borders ( region -- startaddr endaddr ) 
\G returns lower and upper region border
  dup >rstart @ swap >rlen @ over + ;

: extent  ( region -- startaddr len )   
\G returns the really used area
  dup >rstart @ swap >rdp @ over - ;

: area ( region -- startaddr totallen ) 
\G returns the total area
  dup >rstart @ swap >rlen @ ;

: mirrored                              
\G mark a region as mirrored
  mirrored-link
  align linked last-defined-region @ , ;

: .addr ( u -- )
\G prints a 16 or 32 Bit nice hex value
  base @ >r hex
  tcell 2 u>
  IF s>d <# # # # # [char] . hold # # # # #> type
  ELSE s>d <# # # # # # #> type
  THEN r> base ! space ;

: .regions                      \G display region statistic

  \ we want to list the regions in the right order
  \ so first collect all regions on stack
  0 region-link @
  BEGIN dup WHILE dup @ REPEAT drop
  BEGIN dup
  WHILE cr
        0 >rlink - >r
        r@ >rname count tuck type
        12 swap - 0 max spaces space
        ." Start: " r@ >rstart @ dup .addr space
        ." End: " r@ >rlen @ + .addr space
        ." DP: " r> >rdp @ .addr
  REPEAT drop
  s" rom" T $has? H 0= ?EXIT
  cr ." Mirrored:"
  mirrored-link @
  BEGIN dup
  WHILE space dup cell+ @ >rname count type @
  REPEAT drop cr
  ;

\ -------- predefined regions

0 0 region address-space
\ total memory addressed and used by the target system

0 0 region dictionary
\ rom area for the compiler

T has? rom H
[IF]
0 0 region ram-dictionary mirrored
\ ram area for the compiler
[ELSE]
' dictionary ALIAS ram-dictionary
[THEN]

0 0 region return-stack

0 0 region data-stack

0 0 region tib-region

' dictionary ALIAS rom-dictionary


: setup-target ( -- )   \G initialize targets memory space
  s" rom" T $has? H
  IF  \ check for ram and rom...
      \ address-space area nip 0<>
      ram-dictionary area nip 0<>
      rom-dictionary area nip 0<>
      and 0=
      ABORT" CROSS: define address-space, rom- , ram-dictionary, with rom-support!"
  THEN
  address-space area nip
  IF
      address-space area
  ELSE
      dictionary area
  THEN
  nip 0=
  ABORT" CROSS: define at least address-space or dictionary!!"

  \ allocate target for each region
  region-link
  BEGIN @ dup
  WHILE dup
        0 >rlink - >r
        r@ >rlen @
        IF      \ allocate mem
                r@ >rlen @ allocatetarget dup image !
                r@ >rmem !

                r@ >rlen @
                target>bitmask-size allocatetarget
                dup bit$ !
                r@ >rbm !

		r@ >rlen @
		tcell / 1+ cells allocatetarget r@ >rtype !

		rdrop
        ELSE    r> drop THEN
   REPEAT drop ;

\ MakeKernal                                           		22feb99jaw

: makekernel ( targetsize -- targetsize )
  dup dictionary >rlen ! setup-target ;

>MINIMAL
: makekernel makekernel ;
>CROSS

\ \ switched tdp for rom support				03jun97jaw

\ second value is here to store some maximal value for statistics
\ tempdp is also embedded here but has nothing to do with rom support
\ (needs switched dp)

variable tempdp	0 ,	\ temporary dp for resolving
variable tempdp-save

0 [IF]
variable romdp 0 ,      \ Dictionary-Pointer for ramarea
variable ramdp 0 ,      \ Dictionary-Pointer for romarea

\
variable sramdp		\ start of ram-area for forth
variable sromdp		\ start of rom-area for forth

[THEN]


0 value tdp
variable fixed		\ flag: true: no automatic switching
			\	false: switching is done automatically

\ Switch-Policy:
\
\ a header is always compiled into rom
\ after a created word (create and variable) compilation goes to ram
\
\ Be careful: If you want to make the data behind create into rom
\ you have to put >rom before create!

variable constflag constflag off

: activate ( region -- )
\G next code goes to this region
  >rdp to tdp ;

: (switchram)
  fixed @ ?EXIT s" rom" T $has? H 0= ?EXIT
  ram-dictionary activate ;

: switchram
  constflag @
  IF constflag off ELSE (switchram) THEN ;

: switchrom
  fixed @ ?EXIT rom-dictionary activate ;

: >tempdp ( addr -- ) 
  tdp tempdp-save ! tempdp to tdp tdp ! ;
: tempdp> ( -- )
  tempdp-save @ to tdp ;

: >ram  fixed off (switchram) fixed on ;
: >rom  fixed off switchrom fixed on ;
: >auto fixed off switchrom ;



\ : romstart dup sromdp ! romdp ! ;
\ : ramstart dup sramdp ! ramdp ! ;

\ default compilation goes to rom
\ when romable support is off, only the rom switch is used (!!)
>auto

: there  tdp @ ;

>TARGET

\ \ Target Memory Handling

\ Byte ordering and cell size                          06oct92py

: cell+         tcell + ;
: cells         tcell<< lshift ;
: chars         tchar * ;
: char+		tchar + ;
: floats	tfloat * ;
    
>CROSS
: cell/         tcell<< rshift ;
>TARGET
20 CONSTANT bl
\ TNIL Constant NIL

>CROSS

bigendian
[IF]
   : S!  ( n addr -- )  >r s>d r> tcell bounds swap 1-
     DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
   : S@  ( addr -- n )  >r 0 0 r> tcell bounds
     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
   : Sc!  ( n addr -- )  >r s>d r> tchar bounds swap 1-
     DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
   : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds
     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
[ELSE]
   : S!  ( n addr -- )  >r s>d r> tcell bounds
     DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
   : S@  ( addr -- n )  >r 0 0 r> tcell bounds swap 1-
     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
   : Sc!  ( n addr -- )  >r s>d r> tchar bounds
     DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
   : Sc@  ( addr -- n )  >r 0 0 r> tchar bounds swap 1-
     DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
[THEN]

: taddr>region ( taddr -- region | 0 )
\G finds for a target-address the correct region
\G returns 0 if taddr is not in range of a target memory region
  region-link
  BEGIN @ dup
  WHILE dup >r
        0 >rlink - >r
        r@ >rlen @
        IF      dup r@ borders within
                IF r> r> drop nip EXIT THEN
        THEN
        r> drop
        r>
  REPEAT
  2drop 0 ;

: taddr>region-abort ( taddr -- region | 0 )
  dup taddr>region dup 0= 
  IF    drop cr ." Wrong address: " .addr
        -1 ABORT" Address out of range!"
  THEN nip ;

: (>regionimage) ( taddr -- 'taddr )
  dup
  \ find region we want to address
  taddr>region-abort
  >r
  \ calculate offset in region
  r@ >rstart @ -
  \ add regions real address in our memory
  r> >rmem @ + ;

: (>regionbm) ( taddr -- 'taddr bitmaskbaseaddr )
  dup
  \ find region we want to address
  taddr>region-abort
  >r
  \ calculate offset in region
  r@ >rstart @ -
  \ add regions real address in our memory
  r> >rbm @ ;

: (>regiontype) ( taddr -- 'taddr )
  dup
  \ find region we want to address
  taddr>region-abort
  >r
  \ calculate offset in region
  r@ >rstart @ - tcell / cells
  \ add regions real address in our memory
  r> >rtype @ + ;
  
\ 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! ;
: -bit ( addr n -- )  >bit invert over c@ and swap c! ;

: @relbit ( taddr -- f ) (>regionbm) swap cell/ >bit swap c@ and ;

: (relon) ( taddr -- )  
  [ [IFDEF] fd-relocation-table ]
  s" +" fd-relocation-table write-file throw
  dup s>d <# #s #> fd-relocation-table write-line throw
  [ [THEN] ]
  (>regionbm) swap cell/ +bit ;

: (reloff) ( taddr -- ) 
  [ [IFDEF] fd-relocation-table ]
  s" -" fd-relocation-table write-file throw
  dup s>d <# #s #> fd-relocation-table write-line throw
  [ [THEN] ]
  (>regionbm) swap cell/ -bit ;

: (>image) ( taddr -- absaddr ) image @ + ;

DEFER >image
DEFER relon
DEFER reloff
DEFER correcter

T has? relocate H
[IF]
' (relon) IS relon
' (reloff) IS reloff
' (>regionimage) IS >image
[ELSE]
' drop IS relon
' drop IS reloff
' (>regionimage) IS >image
[THEN]

\ Target memory access                                 06oct92py

: align+  ( taddr -- rest )
    tcell tuck 1- and - [ tcell 1- ] Literal and ;
: cfalign+  ( taddr -- rest )
    \ see kernel.fs:cfaligned
    /maxalign tuck 1- and - [ /maxalign 1- ] Literal and ;

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

: cfaligned ( taddr1 -- taddr2 )
    \ see kernel.fs
    dup cfalign+ + ;

: @  ( taddr -- w )     >image S@ ;
: !  ( w taddr -- )     >image S! ;
: c@ ( taddr -- char )  >image Sc@ ;
: c! ( char taddr -- )  >image Sc! ;
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T tuck ! cell+ ! H ;

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

: here  ( -- there )    there ;
: allot ( n -- )        tdp +! ;
: ,     ( w -- )        T here H tcell T allot  ! H ;
: c,    ( char -- )     T here H tchar T allot c! H ;
: align ( -- )          T here H align+ 0 ?DO  bl T c, H tchar +LOOP ;
: cfalign ( -- )
    T here H cfalign+ 0 ?DO  bl T c, H tchar +LOOP ;

: >address		dup 0>= IF tbyte / THEN ; \ ?? jaw 
: A!                    swap >address swap dup relon T ! H ;
: A,    ( w -- )        >address T here H relon T , H ;


>CROSS

: tcmove ( source dest len -- )
\G cmove in target memory
  tchar * bounds
  ?DO  dup T c@ H I T c! H 1+
  tchar +LOOP  drop ;


\ \ Load Assembler

>TARGET
H also Forth definitions

: X 	bl word count [ ' target >wordlist ] Literal search-wordlist
	IF	state @ IF compile,
		ELSE execute THEN
	ELSE	-1 ABORT" Cross: access method not supported!"
	THEN ; immediate

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

previous

\ \ --------------------        Host/Target copy etc.     	29aug01jaw


>CROSS

: th-count ( taddr -- host-addr len )
\G returns host address of target string
  assert1( tbyte 1 = )
  dup X c@ swap X char+ >image swap ;

: ht-move ( haddr taddr len -- )
\G moves data from host-addr to destination in target-addr
\G character by character
  swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ;

2Variable last-string

: ht-string,  ( addr count -- )
  dup there swap last-string 2!
  dup T c, H bounds  ?DO  I c@ T c, H  LOOP ; 

>TARGET

: count dup X c@ swap X char+ swap ;
\ FIXME -1 on 64 bit machines?!?!
: on		T -1 swap ! H ; 
: off   	T 0 swap ! H ;

\ \ --------------------        Compiler Plug Ins               01aug97jaw

>CROSS

\  Compiler States

Variable comp-state
0 Constant interpreting
1 Constant compiling
2 Constant resolving
3 Constant assembling

: compiling? comp-state @ compiling = ;

: Plugin ( -- : pluginname )
  Create 
  ['] noop , \ action
  ['] noop , \ target plugin action
  8765 ,     \ plugin magic
  DOES> perform ;

Plugin DummyPlugin

: 'PI ( -- addr : pluginname )
  ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ;

: plugin-of ( xt -- : pluginname )
  dup 'PI 2! ;

: action-of ( xt -- : plunginname )
  'PI cell+ ! ;

: TPA ( -- : plugin )
\ target plugin action
\ executes current target action of plugin
  'PI cell+ POSTPONE literal POSTPONE perform ; immediate

Variable ppi-temp 0 ppi-temp !

: pa:
\g define plugin action
  ppi-temp @ ABORT" pa: definition not closed"
  'PI ppi-temp ! :noname ;

: ;pa
\g end a definition for plugin action
  POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate


Plugin lit, ( n -- )
Plugin alit, ( n -- )

Plugin branch, ( target-addr -- )	\ compiles a branch
Plugin ?branch, ( target-addr -- )	\ compiles a ?branch
Plugin branchmark, ( -- branch-addr )	\ reserves room for a branch
Plugin ?branchmark, ( -- branch-addr )	\ reserves room for a ?branch
Plugin ?domark, ( -- branch-addr )	\ reserves room for a ?do branch
Plugin branchto, ( -- )			\ actual program position is target of a branch (do e.g. alignment)
Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
Plugin branchtomark, ( -- target-addr )	\ marks a branch destination

Plugin colon, ( tcfa -- )		\ compiles call to tcfa at current position
Plugin colonmark, ( -- addr )		\ marks a colon call
Plugin colon-resolve ( tcfa addr -- )

Plugin addr-resolve ( target-addr addr -- )
Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )

Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
Plugin if, 	( -- if-token )
Plugin else,	( if-token -- if-token )
Plugin then,	( if-token -- )
Plugin ahead,
Plugin begin,
Plugin while,
Plugin until,
Plugin again,
Plugin repeat,
Plugin cs-swap	( x1 x2 -- x2 x1 )

Plugin case,	( -- n )
Plugin of,	( n -- x1 n )
Plugin endof,	( x1 n -- x2 n )
Plugin endcase,	( x1 .. xn n -- )

Plugin do,	( -- do-token )
Plugin ?do,	( -- ?do-token )
Plugin for,	( -- for-token )
Plugin loop,	( do-token / ?do-token -- )
Plugin +loop,	( do-token / ?do-token -- )
Plugin next,	( for-token )
Plugin leave,	( -- )
Plugin ?leave, 	( -- )

[IFUNDEF] ca>native
Plugin ca>native	
[THEN]

Plugin doprim,	\ compiles start of a primitive
Plugin docol,   	\ compiles start of a colon definition
Plugin doer,		
Plugin fini,      \ compiles end of definition ;s
Plugin doeshandler,
Plugin dodoes,

Plugin colon-start
Plugin colon-end

Plugin ]comp     \ starts compilation
Plugin comp[     \ ends compilation

T 2 cells H Value xt>body

Plugin t>body             \ we need the system >body
			\ and the target >body

>TARGET
: >body t>body ;
>CROSS

: (cc) T a, H ;					' (cc) plugin-of colon,

: (cr) >tempdp ]comp colon, comp[ tempdp> ; 	' (cr) plugin-of colon-resolve
: (ar) T ! H ;					' (ar) plugin-of addr-resolve
: (dr)  ( ghost res-pnt target-addr addr )
	>tempdp drop over 
	dup >magic @ <do:> =
	IF 	doer,
	ELSE	dodoes,
	THEN 
	tempdp> ;				' (dr) plugin-of doer-resolve

: (cm) ( -- addr )
    T here align H
    -1 colon, ;					' (cm) plugin-of colonmark,

>TARGET
: compile, colon, ;
>CROSS

\ resolve structure

: >next ;		\ link to next field
: >tag cell+ ;		\ indecates type of reference: 0: call, 1: address, 2: doer
: >taddr cell+ cell+ ;	
: >ghost 3 cells + ;
: >file 4 cells + ;
: >line 5 cells + ;

: (refered) ( ghost addr tag -- )
\G creates a reference to ghost at address taddr
    >space
    rot >link linked
    ( taddr tag ) ,
    ( taddr ) , 
    last-header-ghost @ , 
    loadfile , 
    sourceline# , 
    space>
  ;

: refered ( ghost tag -- )
\G creates a resolve structure
    T here aligned H swap (refered)
  ;

: killref ( addr ghost -- )
\G kills a forward reference to ghost at position addr
\G this is used to eleminate a :dovar refence after making a DOES>
    dup >magic @ <fwd> <> IF 2drop EXIT THEN
    swap >r >link
    BEGIN dup @ dup  ( addr last this )
    WHILE dup >taddr @ r@ =
 	 IF   @ over !
	 ELSE nip THEN
    REPEAT rdrop 2drop 
  ;

Defer resolve-warning

: reswarn-test ( ghost res-struct -- ghost res-struct )
  over cr ." Resolving " .ghost dup ."  in " >ghost @ .ghost ;

: reswarn-forward ( ghost res-struct -- ghost res-struct )
  over warnhead .ghost dup ."  is referenced in " 
  >ghost @ .ghost ;

\ ' reswarn-test IS resolve-warning
 
\ resolve                                              14oct92py

 : resolve-loop ( ghost resolve-list tcfa -- )
    >r
    BEGIN dup WHILE 
\  	  dup >tag @ 2 = IF reswarn-forward THEN
	  resolve-warning 
	  r@ over >taddr @ 
	  2 pick >tag @
	  CASE	0 OF colon-resolve ENDOF
		1 OF addr-resolve ENDOF
		2 OF doer-resolve ENDOF
	  ENDCASE
	  @ \ next list element
    REPEAT 2drop rdrop 
  ;

\ : 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 -- )
\G print warning and set new target link in ghost
  swap exists-warning
  >link ! ;

Variable rdbg

: resolve  ( ghost tcfa -- )
\G resolve referencies to ghost with tcfa
    rdbg @ IF break: THEN 
    dup taddr>region 0<> IF
      2dup (>regiontype) define-addr-struct addr-xt-ghost 

      \ we define new address only if empty
      \ this is for not to overtake the alias ghost
      \ but the very first that really defines it
\ FIXME: define when HeaderGhost is ready
      dup @ 0= IF ! ELSE 2drop THEN
\    !
    THEN

    \ is ghost resolved?, second resolve means another 
    \ definition with the same name
    over undefined? 0= IF  exists EXIT THEN
    \ get linked-list
    swap >r r@ >link @ swap \ ( list tcfa R: ghost )
    \ mark ghost as resolved
    dup r@ >link ! <res> r@ >magic !
    \ loop through forward referencies
    r> -rot 
    comp-state @ >r Resolving comp-state !
    resolve-loop 
    r> comp-state !

    ['] noop IS resolve-warning 
  ;

\ gexecute ghost,                                      01nov92py

: is-forward   ( ghost -- )
  colonmark, 0 (refered) ; \ compile space for call

: is-resolved   ( ghost -- )
  >link @ colon, ; \ compile-call

: (gexecute)   ( ghost -- )
  dup >magic @ 
  <fwd> = IF  is-forward  ELSE  is-resolved  THEN ;

: gexecute ( ghost -- )
\  dup >magic @ <imm> = IF -1 ABORT" CROSS: gexecute on immediate word" THEN
  (gexecute) ;

: addr,  ( ghost -- )
  dup >magic @ <fwd> = IF  1 refered 0 T a, H ELSE >link @ T a, H THEN ;

\ !! : ghost,     ghost  gexecute ;

\ .unresolved                                          11may93jaw

variable ResolveFlag

\ ?touched                                             11may93jaw

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

: .forwarddefs ( ghost -- )
  ."  appeared in:"
  >link
  BEGIN	@ dup
  WHILE	cr 5 spaces
	dup >ghost @ .ghost
	."  file " dup >file @ ?dup IF count type ELSE ." CON" THEN
	."  line " dup >line @ .dec
  REPEAT 
  drop ;

: ?resolved  ( ghost -- )
  dup ?touched
  IF  	ResolveFlag on 
	dup cr .ghost .forwarddefs
  ELSE 	drop 
  THEN ;

: .unresolved  ( -- )
  ResolveFlag off cr ." Unresolved: "
  ghost-list
  BEGIN @ dup
  WHILE dup ?resolved
  REPEAT drop ResolveFlag @
  IF
      -1 abort" Unresolved words!"
  ELSE
      ." Nothing!"
  THEN
  cr ;

: .stats
  base @ >r decimal
  cr ." named Headers: " headers-named @ . 
  r> base ! ;

>MINIMAL

: .unresolved .unresolved ;

>CROSS
\ Header states                                        12dec92py

\ : flag! ( 8b -- )   tlast @ dup >r T c@ xor r> c! H ;
bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+
: flag! ( w -- )   tlast @ flag+ + dup >r T c@ xor r> c! H ;

VARIABLE ^imm

>TARGET
: immediate     40 flag!
                ^imm @ @ dup <imm> = IF  drop  EXIT  THEN
                <res> <> ABORT" CROSS: Cannot immediate a unresolved word"
                <imm> ^imm @ ! ;
: restrict      20 flag! ;

: isdoer	
\G define a forth word as doer, this makes obviously only sence on
\G forth processors such as the PSC1000
		<do:> last-header-ghost @ >magic ! ;
>CROSS

\ Target Header Creation                               01nov92py

: ht-lstring, ( addr count -- )
  dup T , H bounds  ?DO  I c@ T c, H  LOOP ;

>TARGET
: name,  ( "name" -- )  bl word count ht-lstring, X cfalign ;
: view,   ( -- ) ( dummy ) ;
>CROSS

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

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

: T-\G ( -- )
    source >in @ /string doc-file-id write-line throw
    postpone \ ;

Variable to-doc  to-doc on

: 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					
	T-\G
	>in !
    THEN ;

\ Target TAGS creation

s" kernel.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 ( -- )
    sourcefilename last-loadfilename 2@ d<>
    IF
	tag-bof count tag-file-id write-line throw
	sourcefilename 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 sourceline# 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 ;

\ Check for words

Defer skip? ' false IS skip?

: skipdef ( "name" -- )
\G skip definition of an undefined word in undef-words and
\G all-words mode
    Ghost dup forward?
    IF  >magic <skip> swap !
    ELSE drop THEN ;

: tdefined? ( "name" -- flag ) 
    Ghost undefined? 0= ;

: defined2? ( "name" -- flag ) 
\G return true for anything else than forward, even for <skip>
\G that's what we want
    Ghost forward? 0= ;

: forced? ( "name" -- flag )
\G return ture if it is a foreced skip with defskip
    Ghost >magic @ <skip> = ;

: needed? ( -- flag ) \ name
\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 undefined?
	nip
	0=
    ELSE  drop true  THEN ;

: doer? ( -- flag ) \ name
    Ghost >magic @ <do:> = ;

: skip-defs ( -- )
    BEGIN  refill  WHILE  source -trailing nip 0= UNTIL  THEN ;

\ Target header creation

Variable NoHeaderFlag
NoHeaderFlag off

: 0.r ( n1 n2 -- ) 
    base @ >r hex 
    0 swap <# 0 ?DO # LOOP #> type 
    r> base ! ;

: .sym ( adr len -- )
\G escapes / and \ to produce sed output
  bounds 
  DO I c@ dup
	CASE	[char] / OF drop ." \/" ENDOF
		[char] \ OF drop ." \\" ENDOF
		dup OF emit ENDOF
	ENDCASE
    LOOP ;

Defer setup-execution-semantics
0 Value lastghost

: (THeader ( "name" -- ghost )
    \  >in @ bl word count type 2 spaces >in !
    \ wordheaders will always be compiled to rom
    switchrom
    \ build header in target
    NoHeaderFlag @
    IF  NoHeaderFlag off
    ELSE
	T align H view,
	tlast @ dup 0> IF tcell - THEN T A, H  there tlast !
	1 headers-named +!	\ Statistic
	>in @ T name, H >in !
    THEN
    T cfalign here H tlastcfa !
    \ Old Symbol table sed-script
\    >in @ cr ." sym:s/CFA=" there 4 0.r ." /"  bl word count .sym ." /g" cr >in !
    HeaderGhost
    \ output symbol table to extra file
    [ [IFDEF] fd-symbol-table ]
      base @ hex there s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base !
      s" :" fd-symbol-table write-file throw
      dup >ghostname fd-symbol-table write-line throw
    [ [THEN] ]
    dup Last-Header-Ghost ! dup to lastghost
    dup >magic ^imm !     \ a pointer for immediate
    80 flag!
    cross-doc-entry cross-tag-entry 
    setup-execution-semantics
    ;

\ this is the resolver information from ":"
\ resolving is done by ";"
Variable ;Resolve 1 cells allot

: hereresolve ( ghost -- )
  there resolve 0 ;Resolve ! ;

: Theader  ( "name" -- ghost )
  (THeader dup hereresolve ;

Variable aprim-nr -20 aprim-nr !

: copy-execution-semantics ( ghost-from ghost-dest -- )
  >r
  dup >exec @ r@ >exec !
  dup >exec2 @ r@ >exec2 !
  dup >exec-compile @ r@ >exec-compile !
  dup >ghost-xt @ r@ >ghost-xt !
  dup >created @ r@ >created !
  rdrop drop ;

>TARGET

: Alias    ( cfa -- ) \ name
  >in @ skip? IF  2drop  EXIT  THEN  >in !
  (THeader ( S xt ghost )
  2dup swap gdiscover 0= ABORT" missing" swap copy-execution-semantics
  over resolve T A, H 80 flag! ;

Variable last-prim-ghost
0 last-prim-ghost !

: asmprimname, ( ghost -- : name ) 
  dup last-prim-ghost !
  >r
  here bl word count string, r@ >asm-name !
  aprim-nr @ r> >asm-dummyaddr ! ;

Defer setup-prim-semantics

: aprim   ( -- ) 
  THeader -1 aprim-nr +! aprim-nr @ T A, H
  asmprimname, 
  setup-prim-semantics ;

: aprim:   ( -- ) 
  -1 aprim-nr +! aprim-nr @
  Ghost tuck swap resolve <do:> swap tuck >magic !
  asmprimname, ;

: Alias:   ( cfa -- ) \ name
  >in @ skip? IF  2drop  EXIT  THEN  >in !
  dup 0< s" prims" T $has? H 0= and
  IF
      .sourcepos ." needs doer: " >in @ bl word count type >in ! cr
  THEN
  Ghost tuck swap resolve <do:> swap >magic ! ;

Variable prim#
: first-primitive ( n -- )  prim# ! ;
: Primitive  ( -- ) \ name
  >in @ skip? IF  2drop  EXIT  THEN  >in !
  dup 0< s" prims" T $has? H 0= and
  IF
     .sourcepos ." needs prim: " >in @ bl word count type >in ! cr
  THEN
  prim# @ (THeader ( S xt ghost )
  over resolve T A, H 80 flag!
  -1 prim# +! ;
>CROSS

\ Conditionals and Comments                            11may93jaw

\G saves the existing cond action, this is used for redefining in
\G instant
Variable cond-xt-old

: cond-target ( -- )
\G Compiles semantic of redefined cond into new one
  cond-xt-old @ compile, ; immediate restrict

: ;Cond
  postpone ;
  swap ! ;  immediate

: Cond: ( "name" -- ) 
\g defines a conditional or another word that must
\g be executed directly while compiling
\g these words have no interpretative semantics by default
  Ghost
  >exec-compile
  dup @ cond-xt-old !
  :NONAME ;


: Comment ( -- )
  >in @ Ghost swap >in ! ' swap 
  2dup >exec-compile ! >exec ! ;

Comment (       Comment \

\ compile                                              10may93jaw

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

: '  ( -- cfa ) 
\ returns the target-cfa of a ghost
  bl word gfind 0= ABORT" CROSS: Ghost don't exists"
  ghost>cfa ;

\ FIXME: this works for the current use cases, but is not
\ in all cases correct ;-) 
: comp' X ' 0 ;

Cond: [']  T ' H alit, ;Cond

>CROSS

: [T']
\ returns the target-cfa of a ghost, or compiles it as literal
  postpone [G'] state @ IF postpone ghost>cfa ELSE ghost>cfa THEN ; immediate

\ \ threading modell					13dec92py
\ modularized						14jun97jaw

: fillcfa   ( usedcells -- )
  T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ;

: (>body)   ( cfa -- pfa ) 
  xt>body + ;					' (>body) plugin-of t>body

: (doer,)   ( ghost -- ) 
  addr, 1 fillcfa ;   				' (doer,) plugin-of doer,

: (docol,)  ( -- ) [G'] :docol (doer,) ;	' (docol,) plugin-of docol,

: (doprim,) ( -- )
  there xt>body + ca>native T a, H 1 fillcfa ;	' (doprim,) plugin-of doprim,

: (doeshandler,) ( -- ) 
  T cfalign H compile :doesjump T 0 , H ; 	' (doeshandler,) plugin-of doeshandler,

: (dodoes,) ( does-action-ghost -- )
  ]comp [G'] :dodoes gexecute comp[
  addr,
  \ the relocator in the c engine, does not like the
  \ does-address to marked for relocation
  [ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ]
  2 fillcfa ;		' (dodoes,) plugin-of dodoes,

: (lit,) ( n -- )   compile lit T  ,  H ;	' (lit,) plugin-of lit,

\ if we dont produce relocatable code alit, defaults to lit, jaw
\ this is just for convenience, so we don't have to define alit,
\ seperately for embedded systems....
T has? relocate H
[IF]
: (alit,) ( n -- )  compile lit T  a, H ;	' (alit,) plugin-of alit,
[ELSE]
: (alit,) ( n -- )  lit, ;			' (alit,) plugin-of alit,
[THEN]

: (fini,)         compile ;s ;			' (fini,) plugin-of fini,

[IFUNDEF] (code) 
Defer (code)
Defer (end-code)
[THEN]

>TARGET
: Code
  defempty?
  (THeader there resolve
  [ T e? prims H 0= [IF] T e? ITC H [ELSE] true [THEN] ] [IF]
  doprim, 
  [THEN]
  depth (code) ;

: Code:
  defempty?
    Ghost dup there ca>native resolve  <do:> swap >magic !
    depth (code) ;

: end-code
    (end-code)
    depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
    ELSE true ABORT" CROSS: Stack empty" THEN
    ;

>CROSS

\ tLiteral                                             12dec92py

>TARGET
Cond: \G  T-\G ;Cond

Cond:  Literal ( n -- )   lit, ;Cond
Cond: ALiteral ( n -- )   alit, ;Cond

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

\ JAW Cond: chars ;Cond 

\ some special literals					27jan97jaw

\ !! Known Bug: Special Literals and plug-ins work only correct
\ on 16 and 32 Bit Targets and 32 Bit Hosts!

Cond: MAXU
  tcell 1 cells u> 
  IF	compile lit tcell 0 ?DO FF T c, H LOOP 
  ELSE	ffffffff lit, THEN
  ;Cond

Cond: MINI
  tcell 1 cells u>
  IF	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
  ELSE	tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
  ;Cond
 
Cond: MAXI
 tcell 1 cells u>
 IF	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
 ELSE	tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
 ;Cond

>CROSS
\ Target compiling loop                                12dec92py
\ ">tib trick thrown out                               10may93jaw
\ number? defined at the top                           11may93jaw
\ replaced >in by save-input				

: discard 0 ?DO drop LOOP ;

\ compiled word might leave items on stack!
: tcom ( x1 .. xn n name -- )
\  dup count type space
  gfind 
  IF    >r ( discard saved input state ) discard r>
	dup >exec-compile @ ?dup
        IF   nip execute-exec-compile ELSE gexecute  THEN 
	EXIT 
  THEN
  number? dup  
  IF	0> IF swap lit,  THEN  lit, discard
  ELSE	2drop restore-input throw Ghost gexecute THEN  ;

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

: ] 
    Compiling comp-state !
    \ if we have a state in target, change it with the compile state
    [G'] state dup undefined? 0= IF >ghost-xt @ execute X on ELSE drop THEN
    BEGIN
        BEGIN save-input bl word
              dup c@ 0= WHILE drop discard refill 0=
              ABORT" CROSS: End of file while target compiling"
        REPEAT
        tcom
        compiling? 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
  defempty?
  constflag off \ don't let this flag work over colon defs
		\ just to go sure nothing unwanted happens
  >in @ skip? IF  drop skip-defs  EXIT  THEN  >in !
  (THeader ;Resolve ! there ;Resolve cell+ !
   docol, ]comp  colon-start depth T ] H ;

: :noname ( -- colon-sys )
  X cfalign
  \ FIXME: cleanup!!!!!!!!
  \ idtentical to : with dummy ghost?!
  here ghostheader dup ;Resolve ! dup last-header-ghost ! to lastghost
  there ;Resolve cell+ !
  there docol, ]comp 
  colon-start depth T ] H ;

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

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

>CROSS
: LastXT ;Resolve @ 0= abort" CROSS: no definition for LastXT"
         ;Resolve cell+ @ ;

>TARGET

Cond: recurse ( -- ) Last-Header-Ghost @ gexecute ;Cond

Cond: ; ( -- ) 
               depth ?dup IF   1- <> ABORT" CROSS: Stack changed"
                          ELSE true ABORT" CROSS: Stack empty" THEN
               colon-end
               fini,
               comp[
               ;Resolve @
               IF ;Resolve @ ;Resolve cell+ @ resolve THEN
    [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN
               Interpreting comp-state !
               ;Cond
Cond: [  
  \ if we have a state in target, change it with the compile state
    [G'] state dup undefined? 0= IF >ghost-xt @ execute X off ELSE drop THEN
\  [G'] state dup undefined? 0= IF ghost>cfa X >body X off ELSE drop THEN
  Interpreting comp-state ! ;Cond

>CROSS

Create GhostDummy ghostheader
<res> GhostDummy >magic !

: !does ( does-action -- )
\ !! zusammenziehen und dodoes, machen!
    tlastcfa @ [G'] :dovar killref
\    tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
\ !! geht so nicht, da dodoes, ghost will!
    GhostDummy >link ! GhostDummy 
    tlastcfa @ >tempdp dodoes, tempdp> ;


Defer instant-compile-does>-hook
Defer instant-interpret-does>-hook

: resolve-does>-part ( -- )
\ resolve words made by builders
  Last-Header-Ghost @ >do:ghost @ ?dup IF there resolve THEN ;

>TARGET
Cond: DOES>
        compile (does>) doeshandler,
        resolve-does>-part
\        instant-compile-does>-hook
        ;Cond

: DOES> switchrom doeshandler, T here H !does 
  instant-interpret-does>-hook
  depth T ] H ;

>CROSS
\ Creation                                             01nov92py

\ Builder                                               11may93jaw

: Builder    ( Create-xt do:-xt "name" -- )
\ builds up a builder in current vocabulary
\ create-xt is executed when word is interpreted
\ do:-xt is executet when the created word from builder is executed
\ for do:-xt an additional entry after the normal ghost-enrys is used

  Make-Ghost 		( Create-xt do:-xt ghost )
  dup >created on
  rot swap		( do:-xt Create-xt ghost )
  tuck >exec ! >do:ghost ! ;
\  rot swap >exec dup @ ['] NoExec <>
\  IF 2drop ELSE ! THEN , ;

: gdoes,  ( ghost -- )
\ makes the codefield for a word that is built
  >do:ghost @ dup undefined? 0=
  IF
	dup >magic @ <do:> =
	IF 	 doer, 
	ELSE	dodoes,
	THEN
	EXIT
  THEN
\  compile :dodoes gexecute
\  T here H tcell - reloff 
  2 refered 
  0 fillcfa
  ;

: takeover-x-semantics ( S constructor-ghost new-ghost -- )
\g stores execution semantic in the built word
\g if the word already has a semantic (concerns S", IS, .", DOES>)
\g then keep it
   swap >do:ghost @ >exec @ swap >exec2 ! ;
\  >exec dup @ ['] NoExec = 
\  IF swap >do:ghost @ >exec @ swap ! ELSE 2drop THEN ;

: TCreate ( <name> -- )
  create-forward-warn
  IF ['] reswarn-forward IS resolve-warning THEN
  executed-ghost @ (Theader
  dup >created on
  2dup takeover-x-semantics hereresolve gdoes, ;

: RTCreate ( <name> -- )
\ creates a new word with code-field in ram
  create-forward-warn
  IF ['] reswarn-forward IS resolve-warning THEN
  \ make Alias
  executed-ghost @ (THeader 
  dup >created on
  2dup takeover-x-semantics
  there 0 T a, H 80 flag!
  \ store poiter to code-field
  switchram T cfalign H
  there swap T ! H
  there tlastcfa ! 
  hereresolve gdoes, ;

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

: BuildSmart:  ( -- [xt] [colon-sys] )
  :noname
  [ T has? rom H [IF] ]
  postpone RTCreate
  [ [ELSE] ]
  postpone TCreate 
  [ [THEN] ] ;

: gdoes>  ( ghost -- addr flag )
  executed-ghost @
\  compiling? ABORT" CROSS: Executing gdoes> while compiling"
\ ?! compiling? IF  gexecute true EXIT  THEN
  >link @ X >body ( false ) ;

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

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

: by:     ( -- addr [xt] [colon-sys] ) \ name
  Ghost
  :noname postpone gdoes> ( postpone ?EXIT ) ;

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

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

>TARGET
\ Variables and Constants                              05dec92py

Build:  ( n -- ) ;
by: :docon ( target-body-addr -- n ) T @ H ;DO
Builder (Constant)

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

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

Build:  ( d -- ) T , , H ;
DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
Builder 2Constant

BuildSmart: ;
by: :dovar ( target-body-addr -- addr ) ;DO
Builder Create

T has? rom H [IF]
Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , H ( switchrom ) ;
by (Constant)
Builder Variable
[ELSE]
Build: T 0 , H ;
by Create
Builder Variable
[THEN]

T has? rom H [IF]
Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 , 0 , H ( switchrom ) ;
by (Constant)
Builder 2Variable
[ELSE]
Build: T 0 , 0 , H ;
by Create
Builder 2Variable
[THEN]

T has? rom H [IF]
Build: ( -- ) T here 0 A, H switchram T align here swap ! 0 A, H ( switchrom ) ;
by (Constant)
Builder AVariable
[ELSE]
Build: T 0 A, H ;
by Create
Builder AVariable
[THEN]

\ User variables                                       04may94py

>CROSS

Variable tup  0 tup !
Variable tudp 0 tudp !

: u,  ( n -- udp )
  tup @ tudp @ + T  ! H
  tudp @ dup T cell+ H tudp ! ;

: au, ( n -- udp )
  tup @ tudp @ + T A! H
  tudp @ dup T cell+ H tudp ! ;

>TARGET

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

Build: 0 u, X , 0 u, drop ;
by User
Builder 2User

Build: 0 au, X , ;
by User
Builder AUser

BuildSmart: T , H ;
by (Constant)
Builder Value

BuildSmart: T A, H ;
by (Constant)
Builder AValue

Defer texecute

BuildSmart:  ( -- ) [T'] noop T A, H ;
by: :dodefer ( ghost -- ) X @ texecute ;DO
Builder Defer

Build: ( inter comp -- ) swap T immediate A, A, H ;
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
Builder interpret/compile:

\ 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: ;
by: :dofield T @ H + ;DO
Builder (Field)

Build: ( align1 offset1 align size "name" --  align2 offset2 )
    rot dup T , H ( align1 align size offset1 )
    + >r nalign r> ;
by (Field)
Builder Field

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

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



Build: ( m v -- m' v )  dup T , cell+ H ;
DO:  abort" Not in cross mode" ;DO
Builder input-method

Build: ( m v size -- m v' )  over T , H + ;
DO:  abort" Not in cross mode" ;DO
Builder input-var




\ structural conditionals                              17dec92py

>CROSS
: (ncontrols?) ( n -- ) 
\g We expect n open control structures
  depth over u<= 
  ABORT" CROSS: unstructured, stack underflow"
  0 ?DO I pick 0= 
        ABORT" CROSS: unstructured" 
  LOOP ;					' (ncontrols?) plugin-of ncontrols?

\ : ?struc      ( flag -- )       ABORT" CROSS: unstructured " ;
\ : sys?        ( sys -- sys )    dup 0= ?struc ;

: >mark       ( -- sys )        T here  ( dup ." M" hex. ) 0 , H ;

: branchoffset ( src dest -- )  - tchar / ; \ ?? jaw

: >resolve    ( sys -- )        
	X here ( dup ." >" hex. ) over branchoffset swap X ! ;

: <resolve    ( sys -- )
	X here ( dup ." <" hex. ) branchoffset X , ;

:noname compile branch X here branchoffset X , ;
  IS branch, ( target-addr -- )
:noname compile ?branch X here branchoffset X , ;
  IS ?branch, ( target-addr -- )
:noname compile branch T here 0 , H ;
  IS branchmark, ( -- branchtoken )
:noname compile ?branch T here 0 , H ;
  IS ?branchmark, ( -- branchtoken )
:noname T here 0 , H ;
  IS ?domark, ( -- branchtoken )
:noname dup X @ ?struc X here over branchoffset swap X ! ;
  IS branchtoresolve, ( branchtoken -- )
:noname branchto, X here ;
  IS branchtomark, ( -- target-addr )

>TARGET

\ Structural Conditionals                              12dec92py

\ CLEANUP Cond: BUT       sys? swap ;Cond
\ CLEANUP Cond: YET       sys? dup ;Cond

>CROSS

Variable tleavings 0 tleavings !

: (done) ( addr -- )
    tleavings @
    BEGIN  dup
    WHILE
	>r dup r@ cell+ @ \ address of branch
	u> 0=	   \ lower than DO?	
    WHILE
	r@ 2 cells + @ \ branch token
	branchtoresolve,
	r@ @ r> free throw
    REPEAT  r>  THEN
    tleavings ! drop ;

>TARGET

\ What for? ANS? JAW Cond: DONE   ( addr -- )  (done) ;Cond

>CROSS
: (leave) ( branchtoken -- )
    3 cells allocate throw >r
    T here H r@ cell+ !
    r@ 2 cells + !
    tleavings @ r@ !
    r> tleavings ! ;
>TARGET

: (leave,) ( -- ) 
  branchmark, (leave) ; 			' (leave,) plugin-of leave,

: (?leave,) ( -- )
  compile 0= ?branchmark, (leave) ; 		' (?leave,) plugin-of ?leave,

Cond: LEAVE     leave, ;Cond
Cond: ?LEAVE    ?leave, ;Cond

>CROSS
\ !!JW ToDo : Move to general tools section

: to1 ( x1 x2 xn n -- addr )
\G packs n stack elements in am allocated memory region
   dup dup 1+ cells allocate throw dup >r swap 1+
   0 DO tuck ! cell+ LOOP
   drop r> ;

: 1to ( addr -- x1 x2 xn )
\G unpacks the elements saved by to1
    dup @ swap over cells + swap
    0 DO  dup @ swap 1 cells -  LOOP
    free throw ;

: loop]     branchto, dup <resolve tcell - (done) ;

: skiploop] ?dup IF branchto, branchtoresolve, THEN ;

>TARGET

\ Structural Conditionals                              12dec92py

: (cs-swap) ( x1 x2 -- x2 x1 )
  swap ;					' (cs-swap) plugin-of cs-swap

: (ahead,) branchmark, ; 			' (ahead,) plugin-of ahead,

: (if,) ?branchmark, ; 				' (if,) plugin-of if,

: (then,) branchto, branchtoresolve, ; 		' (then,) plugin-of then,

: (else,) ( ahead ) branchmark, 
          swap 
          ( then ) branchto, branchtoresolve, ;	' (else,) plugin-of else,

: (begin,) branchtomark, ; 			' (begin,) plugin-of begin,

: (while,) ( if ) ?branchmark,
           swap ; 				' (while,) plugin-of while,

: (again,) branch, ;				' (again,) plugin-of again,

: (until,) ?branch, ;				' (until,) plugin-of until,

: (repeat,) ( again ) branch,
            ( then ) branchto, branchtoresolve, ; ' (repeat,) plugin-of repeat,

: (case,)   ( -- n )
  0 ;						' (case,) plugin-of case,

: (of,) ( n -- x1 n )
  1+ >r 
  compile over compile = 
  if, compile drop r> ;				' (of,) plugin-of of,

: (endof,) ( x1 n -- x2 n )
  >r 1 ncontrols? else, r> ;			' (endof,) plugin-of endof,

: (endcase,) ( x1 .. xn n -- )
  compile drop 0 ?DO 1 ncontrols? then, LOOP ;	' (endcase,) plugin-of endcase,

>TARGET
Cond: AHEAD     ahead, ;Cond
Cond: IF        if,  ;Cond
Cond: THEN      1 ncontrols? then, ;Cond
Cond: ENDIF     1 ncontrols? then, ;Cond
Cond: ELSE      1 ncontrols? else, ;Cond

Cond: BEGIN     begin, ;Cond
Cond: WHILE     1 ncontrols? while, ;Cond
Cond: AGAIN     1 ncontrols? again, ;Cond
Cond: UNTIL     1 ncontrols? until, ;Cond
Cond: REPEAT    2 ncontrols? repeat, ;Cond

Cond: CASE      case, ;Cond
Cond: OF        of, ;Cond
Cond: ENDOF     endof, ;Cond
Cond: ENDCASE   endcase, ;Cond

\ Structural Conditionals                              12dec92py

: (do,) ( -- target-addr )
  \ ?? i think 0 is too much! jaw
    0 compile (do)
    branchtomark,  2 to1 ;			' (do,) plugin-of do,

\ alternative for if no ?do
\ : (do,)
\     compile 2dup compile = compile IF
\     compile 2drop compile ELSE
\     compile (do) branchtomark, 2 to1 ;
    
: (?do,) ( -- target-addr )
    0 compile (?do)  ?domark, (leave)
    branchtomark,  2 to1 ;			' (?do,) plugin-of ?do,

: (for,) ( -- target-addr )
  compile (for) branchtomark, ;			' (for,) plugin-of for,

: (loop,) ( target-addr -- )
  1to compile (loop)  loop] 
  compile unloop skiploop] ;			' (loop,) plugin-of loop,

: (+loop,) ( target-addr -- )
  1to compile (+loop)  loop] 
  compile unloop skiploop] ;			' (+loop,) plugin-of +loop,

: (next,) 
  compile (next)  loop] compile unloop ;	' (next,) plugin-of next,

Cond: DO      	do, ;Cond
Cond: ?DO     	?do, ;Cond
Cond: FOR	for, ;Cond

Cond: LOOP	1 ncontrols? loop, ;Cond
Cond: +LOOP	1 ncontrols? +loop, ;Cond
Cond: NEXT	1 ncontrols? next, ;Cond

\ String words                                         23feb93py

: ,"            [char] " parse ht-string, X align ;

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

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

Cond: defers	T ' >body @ compile, H ;Cond

\ LINKED ERR" ENV" 2ENV"                                18may93jaw

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

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

: env"  [char] " parse s" EnvLink linked" evaluate
        ht-string, X align X , ;

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

\ compile must be last                                 22feb93py

Cond: [compile] ( -- ) \ name
\g For immediate words, works even if forward reference
      bl word gfind 0= ABORT" CROSS: Can't compile"
      (gexecute) ;Cond
	   
Cond: postpone ( -- ) \ name
      bl word gfind 0= ABORT" CROSS: Can't compile"
      dup >magic @ <fwd> =
      ABORT" CROSS: Can't postpone on forward declaration"
      dup >magic @ <imm> =
      IF   (gexecute)
      ELSE compile (compile) addr, THEN ;Cond
	   
\ save-cross                                           17mar93py

hex

>CROSS
Create magic  s" Gforth2x" here over allot swap move

bigendian 1+ \ strangely, in magic big=0, little=1
tcell 1 = 0 and or
tcell 2 = 2 and or
tcell 4 = 4 and or
tcell 8 = 6 and or
tchar 1 = 00 and or
tchar 2 = 28 and or
tchar 4 = 50 and or
tchar 8 = 78 and or
magic 7 + c!

: save-cross ( "image-name" "binary-name" -- )
  bl parse ." Saving to " 2dup type cr
  w/o bin create-file throw >r
  TNIL IF
      s" #! "           r@ write-file throw
      bl parse          r@ write-file throw
      s"  --image-file" 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
  image @ there 
  r@ write-file throw \ write image
  TNIL IF
      bit$  @ there 1- tcell>bit rshift 1+
                r@ write-file throw \ write tags
  THEN
  r> close-file throw ;

: save-region ( addr len -- )
  bl parse w/o bin create-file throw >r
  swap >image swap r@ write-file throw
  r> close-file throw ;

1 [IF]

Variable name-ptr
Create name-buf 200 chars allot
: init-name-buf name-buf name-ptr ! ;
: nb, name-ptr @ c! 1 chars name-ptr +! ;
: $nb, ( adr len -- ) bounds ?DO I c@ nb, LOOP ;
: @nb name-ptr @ name-buf tuck - ;

\ stores a usefull string representation of the character
\ in the name buffer
: name-char, ( c -- )
  dup 'a 'z 1+ within IF nb, EXIT THEN
  dup 'A 'Z 1+ within IF $20 + nb, EXIT THEN
  dup '0 '9 1+ within IF nb, EXIT THEN
  CASE '+ OF s" _PLUS" $nb, ENDOF
       '- OF s" _MINUS" $nb, ENDOF
       '* OF s" _STAR" $nb, ENDOF
       '/ OF s" _SLASH" $nb, ENDOF
       '' OF s" _TICK" $nb, ENDOF
       '( OF s" _OPAREN" $nb, ENDOF
       ') OF s" _CPAREN" $nb, ENDOF
       '[ OF s" _OBRACKET" $nb, ENDOF
       '] OF s" _CBRACKET" $nb, ENDOF
       '! OF s" _STORE" $nb, ENDOF
       '@ OF s" _FETCH" $nb, ENDOF
       '> OF s" _GREATER" $nb, ENDOF
       '< OF s" _LESS" $nb, ENDOF
       '= OF s" _EQUAL" $nb, ENDOF
       '# OF s" _HASH" $nb, ENDOF
       '? OF s" _QUEST" $nb, ENDOF
       ': OF s" _COL" $nb, ENDOF
       '; OF s" _SEMICOL" $nb, ENDOF
       ', OF s" _COMMA" $nb, ENDOF
       '. OF s" _DOT" $nb, ENDOF
       '" OF s" _DQUOT" $nb, ENDOF
       dup 
       base @ >r hex s>d <# #s 'X hold '_ hold #> $nb, r> base !
  ENDCASE ;
 
: label-from-ghostname ( ghost -- addr len )
  dup >ghostname init-name-buf 'L nb, bounds 
  ?DO I c@ name-char, LOOP 
  \ we add the address to a name to make in unique
  \ because one name may appear more then once
  \ there are names (e.g. boot) that may be reference from other
  \ assembler source files, so we declare them as unique
  \ and don't add the address suffix
  dup >ghost-flags @ <unique> and 0= 
  IF   s" __" $nb, >link @ base @ >r hex 0 <# #s 'L hold #> r> base ! $nb, 
  ELSE drop 
  THEN
  @nb ;

: label-from-ghostnameXX ( ghost -- addr len )
\ same as (label-from-ghostname) but caches generated names
  dup >asm-name @ ?dup IF nip count EXIT THEN
 \ dup >r (label-from-ghostname) 2dup
  align here >r string, align
  r> r> >asm-name ! ;

: primghostdiscover ( xt -- ghost true | xt false )
  dup 0= IF false EXIT THEN
  >r last-prim-ghost
  BEGIN @ dup
  WHILE dup >asm-dummyaddr @ r@ =
        IF rdrop true EXIT THEN
  REPEAT
  drop r> false ;

: gdiscover2 ( xt -- ghost true | xt false ) 
  dup taddr>region 0= IF false EXIT THEN
  dup (>regiontype) @ dup 0= IF drop false EXIT THEN
  addr-xt-ghost @ dup 0= IF drop false EXIT THEN
  nip true ;
\  dup >ghost-name @ IF nip true ELSE drop false THEN ;

\ generates a label name for the target address
: generate-label-name ( taddr -- addr len )
  gdiscover2
  IF dup >magic @ <do:> =
     IF >asm-name @ count EXIT THEN
     label-from-ghostname
  ELSE
     primghostdiscover
     IF   >asm-name @ count 
     ELSE base @ >r hex 0 <# #s 'L hold #> r> base !
     THEN
  THEN ;

Variable outfile-fd

: $out ( adr len -- ) outfile-fd @ write-file throw  ;
: nlout newline $out ;
: .ux ( n -- ) 
  base @ hex swap 0 <# #S #> $out base ! ;

: save-asm-region-part-aligned ( taddr len -- 'taddr 'len )
  dup cell/ 0 
  ?DO nlout s"    .word " $out over @relbit 
      IF   over X @ generate-label-name $out
      ELSE over X @ s" 0x0" $out .ux
      THEN
      tcell /string
  LOOP ;

: print-bytes ( taddr len n -- taddr' len' )
  over min dup 0> 
  IF   nlout s"    .byte " $out 0 
       ?DO  I 0> IF s" , " $out THEN
            over X c@ s" 0x0" $out .ux 1 /string 
       LOOP 
  THEN ;

: save-asm-region-part ( addr len -- )
  over dup X aligned swap - ?dup
  IF   print-bytes THEN
  save-asm-region-part-aligned
  dup dup X aligned swap - ?dup
  IF   2 pick @relbit ABORT" relocated field splitted"
       print-bytes
  THEN
  2drop ;

: print-label ( taddr -- )
  nlout generate-label-name $out s" :" $out ;

: snl-calc ( taddr taddr2 -- )
  tuck over - ;

: skip-nolables ( taddr -- taddr2 taddr len )
\G skips memory region where no lables are defined
\G starting from taddr+1
\G Labels will be introduced for each reference mark
\G in addr-refs.
\G This word deals with lables at byte addresses as well.
\G The main idea is to have an intro part which
\G skips until the next cell boundary, the middle part
\G which skips whole cells very efficiently and the third
\G part which skips the bytes to the label in a cell
  dup 1+ dup (>regiontype) 
  ( S taddr taddr-realstart type-addr )
  dup @ dup IF addr-refs @ THEN
  swap >r
  over align+ tuck tcell swap - rshift swap 0
  DO dup 1 and 
     IF drop rdrop snl-calc UNLOOP EXIT THEN 
     2/ swap 1+ swap 
  LOOP
  drop r> cell+
  ( S .. taddr2 type-addr ) dup
  BEGIN dup @ dup IF addr-refs @ THEN 0= WHILE cell+ REPEAT
  dup >r swap - 1 cells / tcell * + r>
  ( S .. taddr2+skiplencells type-addr )
  @ addr-refs @ 1 tcell lshift or
  BEGIN dup 1 and 0= WHILE swap 1+ swap 2/ REPEAT drop
  ( S .. taddr2+skiplencells+skiplenbytes )
  snl-calc ;

: insert-label ( taddr -- )
  dup 0= IF drop EXIT THEN
  \ ignore everything which points outside our memory regions
  \ maybe a primitive pointer or whatever
  dup taddr>region 0= IF drop EXIT THEN
  dup >r (>regiontype) define-addr-struct addr-refs dup @ 
  r> tcell 1- and 1 swap lshift or swap ! ;

\ this generates a sorted list of addresses which must be labels
\ it scans therefore a whole region
: generate-label-list-region ( taddr len -- )
  BEGIN over @relbit IF over X @ insert-label THEN
        tcell /string dup 0< 
  UNTIL 2drop ;

: generate-label-list ( -- )
  region-link
  BEGIN @ dup WHILE 
        dup 0 >rlink - extent 
        ?dup IF generate-label-list-region ELSE drop THEN
  REPEAT drop ;

: create-outfile ( addr len -- )
  w/o bin create-file throw outfile-fd ! ;

: close-outfile ( -- )
  outfile-fd @ close-file throw ;

: (save-asm-region) ( region -- )
  \ ." label list..."
  generate-label-list
  \ ." ok!" cr
  extent ( S taddr len )
  over insert-label
  2dup + dup insert-label >r ( R end-label )
  ( S taddr len ) drop
  BEGIN
     dup print-label
     dup r@ <> WHILE
     skip-nolables save-asm-region-part
  REPEAT drop rdrop ;

: lineout ( addr len -- )
  outfile-fd @ write-line throw ;  

: save-asm-region ( region adr len -- )
  create-outfile (save-asm-region) close-outfile ;

[THEN]

\ \ minimal definitions
	   
>MINIMAL also minimal

\ Usefull words                                        13feb93py

: KB  400 * ;

\ \ [IF] [ELSE] [THEN] ...				14sep97jaw

\ it is useful to define our own structures and not to rely
\ on the words in the compiler
\ The words in the compiler might be defined with vocabularies
\ this doesn't work with our self-made compile-loop

Create parsed 20 chars allot	\ store word we parsed

: upcase
    parsed count bounds
    ?DO I c@ toupper I c! LOOP ;

: [ELSE]
    1 BEGIN
	BEGIN bl word count dup WHILE
	    comment? 20 umin parsed place upcase parsed count
	    2dup s" [IF]" compare 0= >r 
	    2dup s" [IFUNDEF]" compare 0= >r
	    2dup s" [IFDEF]" compare 0= r> or r> or
	    IF   2drop 1+
	    ELSE 2dup s" [ELSE]" compare 0=
		IF   2drop 1- dup
		    IF 1+
		    THEN
		ELSE
		    2dup s" [ENDIF]" compare 0= >r
		    s" [THEN]" compare 0= r> or
		    IF 1- THEN
		THEN
	    THEN
	    ?dup 0= ?EXIT
	REPEAT
	2drop refill 0=
    UNTIL drop ; immediate
  
: [THEN] ( -- ) ; immediate

: [ENDIF] ( -- ) ; immediate

: [IF] ( flag -- )
    0= IF postpone [ELSE] THEN ; immediate 

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

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

: defined? tdefined? ;
: needed? needed? ;
: doer? doer? ;

\ we want to use IFDEF on compiler directives (e.g. E?) in the source, too

: directive? 
  bl word count [ ' target >wordlist ] literal search-wordlist 
  dup IF nip THEN ;

: [IFDEF]  >in @ directive? swap >in !
	   0= IF tdefined? ELSE name 2drop true THEN
	   postpone [IF] ;

: [IFUNDEF] tdefined? 0= postpone [IF] ;

Cond: [IFDEF]   postpone [IFDEF] ;Cond

Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond

\ C: \- \+ Conditional Compiling                         09jun93jaw

: C: >in @ tdefined? 0=
     IF    >in ! X :
     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 ;

: d? d? ;

\G doesn't skip line when debug switch is on
: \D D? 0= IF postpone \ THEN ;

\G interprets the line if word is not defined
: \- tdefined? IF postpone \ THEN ;

\G interprets the line if word is defined
: \+ tdefined? 0= IF postpone \ THEN ;

Cond: \- \- ;Cond
Cond: \+ \+ ;Cond
Cond: \D \D ;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 ;

\ words that should be in minimal

create s-buffer 50 chars allot

bigendian Constant bigendian

: here there ;
: equ constant ;
: mark there constant ;

\ compiler directives
: >ram >ram ;
: >rom >rom ;
: >auto >auto ;
: >tempdp >tempdp ;
: tempdp> tempdp> ;
: const constflag on ;

: Redefinitions-start
\G Starts a redefinition section. Warnings are disabled and
\G existing ghosts are reused. This is used in the kernel
\G where ( and \ and the like are redefined
  twarnings off warnings off reuse-ghosts on ;

: Redefinitions-end
\G Ends a redefinition section. Warnings are enabled again.
  twarnings on warnings on reuse-ghosts off ;

: warnings name 3 = 
  IF twarnings off warnings off ELSE twarnings on warnings on THEN drop ;

: | ;
\ : | NoHeaderFlag on ; \ This is broken (damages the last word)

: save-cross save-cross ;
: save-region save-region ;
: tdump swap >image swap dump ;

also forth 
[IFDEF] Label           : Label defempty? Label ; [THEN] 
[IFDEF] start-macros    : start-macros defempty? start-macros ; [THEN]
\ [IFDEF] builttag	: builttag builttag ;	[THEN]
previous

: s" [char] " parse s-buffer place s-buffer count ; \ for environment?
: + + ;
: 1+ 1 + ;
: 2+ 2 + ;
: 1- 1- ;
: - - ;
: and and ;
: or or ;
: 2* 2* ;
: * * ;
: / / ;
: dup dup ;
: over over ;
: swap swap ;
: rot rot ;
: drop drop ;
: =   = ;
: 0=   0= ;
: lshift lshift ;
: 2/ 2/ ;
\ : . . ;

: all-words    ['] forced?    IS skip? ;
: needed-words ['] needed?  IS skip? ;
: undef-words  ['] defined2? IS skip? ;
: skipdef skipdef ;

: \  postpone \ ;  immediate
: \G T-\G ; immediate
: (  postpone ( ;  immediate
: include bl word count included ;
: included swap >image swap included ;
: require require ;
: needs require ;
: .( [char] ) parse type ;
: ." [char] " parse type ;
: cr cr ;

: times 0 ?DO dup X c, LOOP drop ; \ used for space table creation

\ only forth also cross also minimal definitions order

\ cross-compiler words

: decimal       decimal [g'] decimal >exec2 @ ?dup IF EXECUTE THEN ;
: hex           hex [g'] hex >exec2 @ ?dup IF EXECUTE THEN ;

\ : tudp          X tudp ;
\ : tup           X tup ;

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

: declareunique ( "name" -- )
\G Sets the unique flag for a ghost. The assembler output
\G generates labels with the ghostname concatenated with the address
\G while cross-compiling. The address is concatenated
\G because we have double occurences of the same name.
\G If we want to reference the labels from the assembler or C
\G code we declare them unique, so the address is skipped.
  Ghost >ghost-flags dup @ <unique> or swap ! ;

\ [IFDEF] dbg : dbg dbg ; [THEN]

\ for debugging...
\ : dbg dbg ;
: horder         order ;
: hwords        words ;
\ : words 	also ghosts 
\                words previous ;
\ : .s            .s ;
: bye           bye ;

\ dummy
: group 0 word drop ;

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


\ these ones are pefered:

: unlock previous forth also cross ;

\ also minimal
>cross

: turnkey 
   ghosts-wordlist 1 set-order
   also target definitions
   also Minimal also ;

>minimal

: [[+++
  turnkey unlock ;

unlock definitions also minimal

: lock   turnkey ;

Defer +++]]-hook
: +++]] +++]]-hook lock ;

LOCK
\ load cross compiler extension defined in mach file

UNLOCK >CROSS

[IFDEF] extend-cross extend-cross [THEN]

LOCK




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