--- gforth/cross.fs 1999/01/10 22:00:22 1.65 +++ gforth/cross.fs 2001/03/11 22:50:49 1.94 @@ -1,7 +1,7 @@ \ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) -\ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -17,83 +17,49 @@ \ You should have received a copy of the GNU General Public License \ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. -\ Log: -\ changed in ; [ to state off 12may93jaw -\ included place +place 12may93jaw -\ for a created word (variable, constant...) -\ is now an alias in the target voabulary. -\ this means it is no longer necessary to -\ switch between vocabularies for variable -\ initialization 12may93jaw -\ discovered error in DOES> -\ replaced !does with (;code) 16may93jaw -\ made complete redesign and -\ introduced two vocs method -\ to be asure that the right words -\ are found 08jun93jaw -\ btw: ! works not with 16 bit -\ targets 09jun93jaw -\ added: 2user and value 11jun93jaw - -\ needed? works better now!!! 01mar97jaw -\ mach file is only loaded into target -\ cell corrected -\ romable extansions 27apr97-5jun97jaw -\ environmental query support 01sep97jaw -\ added own [IF] ... [ELSE] ... [THEN] 14sep97jaw -\ extra resolver for doers 20sep97jaw -\ added killref for DOES> 20sep97jaw +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 -hex \ the defualt base for the cross-compiler is hex !! -Warnings off +[THEN] -\ words that are generaly useful +hex -: KB 400 * ; -: >wordlist ( vocabulary-xt -- wordlist-struct ) - also execute get-order swap >r 1- set-order r> ; +\ debugging for compiling -: umax 2dup u< IF swap THEN drop ; -: umin 2dup u> IF swap THEN drop ; +\ print stack at each colon definition +\ : : save-input cr bl word count type restore-input throw .s : ; -: string, ( c-addr u -- ) - \ puts down string as cstring - dup c, here swap chars dup allot move ; +\ print stack at each created word +\ : create save-input cr bl word count type restore-input throw .s create ; -: SetValue ( n -- ) -\G Same behaviour as "Value" if the is not defined -\G Same behaviour as "to" if is defined -\G SetValue searches in the current vocabulary - save-input bl word >r restore-input throw r> count - get-current search-wordlist - IF ['] to execute ELSE Value THEN ; -: DefaultValue ( n -- ) -\G Same behaviour as "Value" if the 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 ; +\ \ ------------- Setup Vocabularies -hex +\ Remark: Vocabulary is not ANS, but it should work... Vocabulary Cross Vocabulary Target Vocabulary Ghosts -VOCABULARY Minimal +Vocabulary Minimal only Forth also Target also also definitions Forth -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : H previous Forth also Cross ; immediate forth definitions -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : >cross also Cross definitions previous ; @@ -104,6 +70,177 @@ 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 -- ) +\G Same behaviour as "Value" if the is not defined +\G Same behaviour as "to" if 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 -- ) +\G Same behaviour as "Value" if the 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!!! @@ -116,7 +253,348 @@ H \ 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? ( -- 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+ adds a directory to the searchpath +\ fpath= | 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 @@ -128,9 +606,6 @@ also forth definitions \ these values m false DefaultValue stack-warn \ check on empty stack at any definition false DefaultValue create-forward-warn \ warn on forward declaration of created words -[IFUNDEF] DebugMaskSrouce Variable DebugMaskSource 0 DebugMaskSource ! [THEN] -[IFUNDEF] DebugMaskCross Variable DebugMaskCross 0 DebugMaskCross ! [THEN] - previous >CROSS : .dec @@ -153,8 +628,6 @@ stack-warn [IF] : defempty? ; immediate [THEN] - - \ \ GhostNames Ghosts 9may93jaw \ second name source to search trough list @@ -163,7 +636,7 @@ VARIABLE GhostNames 0 GhostNames ! : GhostName ( -- addr ) - here GhostNames @ , GhostNames ! here 0 , + align here GhostNames @ , GhostNames ! here 0 , bl word count \ 2dup type space string, \ !! cfalign ? @@ -181,28 +654,97 @@ VARIABLE VocTemp hex 4711 Constant 4712 Constant 4713 Constant 4714 Constant +4715 Constant -\ iForth makes only immediate directly after create -\ make atonce trick! ? +\ Compiler States -Variable atonce atonce off +Variable comp-state +0 Constant interpreting +1 Constant compiling +2 Constant resolving +3 Constant assembling + +Defer lit, ( n -- ) +Defer alit, ( n -- ) + +Defer branch, ( target-addr -- ) \ compiles a branch +Defer ?branch, ( target-addr -- ) \ compiles a ?branch +Defer branchmark, ( -- branch-addr ) \ reserves room for a branch +Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch +Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch +Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) +Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark +Defer branchfrom, ( -- ) \ ?! +Defer branchtomark, ( -- target-addr ) \ marks a branch destination -: NoExec true ABORT" CROSS: Don't execute ghost" ; +Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position +Defer prim, ( tcfa -- ) \ compiles a primitive invocation + \ at current position +Defer colonmark, ( -- addr ) \ marks a colon call +Defer colon-resolve ( tcfa addr -- ) -: GhostHeader , 0 , ['] NoExec , ; +Defer addr-resolve ( target-addr addr -- ) +Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) + +Defer do, ( -- do-token ) +Defer ?do, ( -- ?do-token ) +Defer for, ( -- for-token ) +Defer loop, ( do-token / ?do-token -- ) +Defer +loop, ( do-token / ?do-token -- ) +Defer next, ( for-token ) + +[IFUNDEF] ca>native +defer ca>native +[THEN] + +\ ghost structure : >magic ; \ type of ghost : >link cell+ ; \ pointer where ghost is in target, or if unresolved \ points to the where we have to resolve (linked-list) : >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost -: >end 3 cells + ; \ room for additional tags +: >comp 3 cells + ; \ compilation semantics +: >end 4 cells + ; \ room for additional tags \ for builder (create, variable...) words the \ execution symantics of words built are placed here +\ 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 + ; + +\ refer variables + 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 +: (refered) ( ghost addr tag -- ) +\G creates a reference to ghost at address taddr + rot >r here r@ >link @ , r> >link ! + ( taddr tag ) , + ( taddr ) , + last-header-ghost @ , + loadfile , + sourceline# , + ; + +\ iForth makes only immediate directly after create +\ make atonce trick! ? + +Variable atonce atonce off + +: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ; + +: is-forward ( ghost -- ) + colonmark, 0 (refered) ; \ compile space for call + +: GhostHeader , 0 , ['] NoExec , ['] is-forward , ; + : Make-Ghost ( "name" -- ghost ) >in @ GhostName swap >in ! wordlist ] ALiteral search-wordlist + dup count [ ' ghosts >wordlist ] Literal search-wordlist dup IF >r >body nip r> THEN ; : gdiscover ( xt -- ghost true | xt false ) @@ -232,7 +774,7 @@ VARIABLE Already : ghost ( "name" -- ghost ) Already off - >in @ bl word gfind IF Already on nip EXIT THEN + >in @ bl word gfind IF atonce off Already on nip EXIT THEN drop >in ! Make-Ghost ; : >ghostname ( ghost -- adr len ) @@ -245,11 +787,16 @@ VARIABLE Already s" ?!?!?!" THEN ; -' >ghostname ALIAS @name +: .ghost ( ghost -- ) >ghostname type ; + +\ ' >ghostname ALIAS @name : forward? ( ghost -- flag ) >magic @ = ; +: undefined? ( ghost -- flag ) + >magic @ dup = swap = or ; + \ Predefined ghosts 12dec92py ghost 0= drop @@ -261,12 +808,13 @@ ghost (next) 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 (.") ghost (S") ghost (ABORT") 2drop drop ( " ) ghost ' drop ghost :docol ghost :doesjump ghost :dodoes 2drop drop -ghost :dovar drop +ghost :dovar ghost :dodefer ghost :dofield 2drop drop ghost over ghost = ghost drop 2drop drop -ghost - drop +ghost call ghost useraddr ghost execute 2drop drop +ghost + ghost - ghost @ 2drop drop ghost 2drop drop ghost 2dup drop @@ -282,29 +830,32 @@ VARIABLE env-current \ save information >TARGET -: environment? +: environment? ( adr len -- [ x ] true | false ) target-environment search-wordlist IF execute true ELSE false THEN ; -: e? name T environment? H 0= ABORT" environment variable not defined!" ; +: e? bl word count T environment? H 0= ABORT" environment variable not defined!" ; -: has? name T environment? H +: has? bl word count T environment? H IF \ environment variable is present, return its value ELSE \ environment variable is not present, return false - \ !! JAW abort is just for testing - false true ABORT" arg" + false \ debug true ABORT" arg" THEN ; : $has? T environment? H IF ELSE false THEN ; >ENVIRON get-order get-current swap 1+ set-order true SetValue compiler -true SetValue cross +true SetValue cross true SetValue standard-threading >TARGET previous - -mach-file count included hex +0 +[IFDEF] mach-file mach-file count 1 [THEN] +[IFDEF] machine-file machine-file 1 [THEN] +[IF] included hex drop +[ELSE] cr ." No machine description!" ABORT +[THEN] >ENVIRON @@ -320,11 +871,14 @@ false DefaultValue dcomps false DefaultValue hash false DefaultValue xconds false DefaultValue header +false DefaultValue backtrace +false DefaultValue new-input [THEN] true DefaultValue interpreter true DefaultValue ITC false DefaultValue rom +true DefaultValue standardthreading >TARGET s" relocate" T environment? H @@ -334,19 +888,45 @@ s" relocate" T environment? H >CROSS -\ \ Create additional parameters 19jan95py +\ \ 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 -1 8 lshift Constant maxbyte T -NIL Constant TNIL -cell Constant tcell -cell<< Constant tcell<< -cell>bit Constant tcell>bit -bits/byte Constant tbits/byte -bits/byte 8 / Constant tchar -float Constant tfloat -1 bits/byte lshift Constant tmaxbyte +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 @@ -361,31 +941,12 @@ Variable bit$ Variable headers-named 0 headers-named ! Variable user-vars 0 user-vars ! -\ Memory initialisation 05dec92py - -[IFDEF] Memory \ Memory is a bigFORTH feature - also Memory - : initmem ( var len -- ) - 2dup swap handle! >r @ r> erase ; - toss -[ELSE] - : initmem ( var len -- ) - tuck allocate abort" CROSS: No memory for target" - ( len var adr ) dup rot ! - ( len adr ) swap erase ; -[THEN] - -\ MakeKernal 12dec92py +: target>bitmask-size ( u1 -- u2 ) + 1- tcell>bit rshift 1+ ; -: makekernel ( targetsize -- targetsize ) - bit$ over 1- tcell>bit rshift 1+ initmem - image over initmem ; - ->MINIMAL -: makekernel makekernel ; - - ->CROSS +: allocatetarget ( size --- adr ) + dup allocate ABORT" CROSS: No memory for target" + swap over swap erase ; \ \ memregion.fs @@ -396,6 +957,10 @@ Variable mirrored-link \ linked 0 dup mirrored-link ! region-link ! +: >rname 6 cells + ; +: >rbm 5 cells + ; +: >rmem 4 cells + ; +: >rlink 3 cells + ; : >rdp 2 cells + ; : >rlen cell+ ; : >rstart ; @@ -409,30 +974,31 @@ Variable mirrored-link \ linked save-input create restore-input throw here last-defined-region ! over ( startaddr ) , ( length ) , ( dp ) , - region-link linked name string, + region-link linked 0 , 0 , bl word count string, ELSE \ store new parameters in region bl word drop >body >r r@ last-defined-region ! - r@ cell+ ! dup r@ ! r> 2 cells + ! + r@ >rlen ! dup r@ >rstart ! r> >rdp ! THEN ; : borders ( region -- startaddr endaddr ) \G returns lower and upper region border - dup @ swap cell+ @ over + ; + dup >rstart @ swap >rlen @ over + ; : extent ( region -- startaddr len ) \G returns the really used area - dup @ swap 2 cells + @ over - ; + dup >rstart @ swap >rdp @ over - ; : area ( region -- startaddr totallen ) \G returns the total area - dup @ swap cell+ @ ; + dup >rstart @ swap >rlen @ ; : mirrored \G mark a region as mirrored mirrored-link - linked last-defined-region @ , ; + align linked last-defined-region @ , ; -: .addr +: .addr ( u -- ) +\G prints a 16 or 32 Bit nice hex value base @ >r hex tcell 2 u> - IF s>d <# # # # # '. hold # # # # #> type + IF s>d <# # # # # [char] . hold # # # # #> type ELSE s>d <# # # # # # #> type THEN r> base ! ; @@ -443,18 +1009,19 @@ Variable mirrored-link \ linked 0 region-link @ BEGIN dup WHILE dup @ REPEAT drop BEGIN dup - WHILE cr 3 cells - >r - r@ 4 cells + count tuck type + WHILE cr + 0 >rlink - >r + r@ >rname count tuck type 12 swap - 0 max spaces space - ." Start: " r@ @ dup .addr space - ." End: " r@ 1 cells + @ + .addr space - ." DP: " r> 2 cells + @ .addr + ." 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+ @ 4 cells + count type @ + WHILE space dup cell+ @ >rname count type @ REPEAT drop cr ; @@ -486,10 +1053,10 @@ T has? rom H : setup-target ( -- ) \G initialize targets memory space s" rom" T $has? H IF \ check for ram and rom... - address-space area nip - ram-dictionary area nip - rom-dictionary area nip - and and 0= + \ 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 @@ -498,9 +1065,36 @@ T has? rom H ELSE dictionary area THEN - dup 0= + nip 0= ABORT" CROSS: define at least address-space or dictionary!!" - + makekernel drop ; + + \ allocate target for each region + region-link + BEGIN @ dup + WHILE dup + 0 >rlink - >r + r@ >rlen @ + IF \ allocate mem + r@ >rlen @ dup + + allocatetarget dup image ! + r@ >rmem ! + + target>bitmask-size allocatetarget + dup bit$ ! + r> >rbm ! + + 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 @@ -536,16 +1130,20 @@ variable fixed \ flag: true: no automat 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 >rdp to tdp ; + ram-dictionary activate ; : switchram constflag @ IF constflag off ELSE (switchram) THEN ; : switchrom - fixed @ ?EXIT rom-dictionary >rdp to tdp ; + fixed @ ?EXIT rom-dictionary activate ; : >tempdp ( addr -- ) tdp tempdp-save ! tempdp to tdp tdp ! ; @@ -561,7 +1159,7 @@ variable constflag constflag off \ : romstart dup sromdp ! romdp ! ; \ : ramstart dup sramdp ! ramdp ! ; -\ default compilation goed to rom +\ default compilation goes to rom \ when romable support is off, only the rom switch is used (!!) >auto @@ -575,8 +1173,8 @@ variable constflag constflag off : cell+ tcell + ; : cells tcell<< lshift ; -: chars ; -: char+ 1 + ; +: chars tchar * ; +: char+ tchar + ; : floats tfloat * ; >CROSS @@ -608,7 +1206,32 @@ bigendian DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ; [THEN] ->CROSS +: 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 ; + +: (>regionimage) ( taddr -- 'taddr ) + dup + \ find region we want to address + taddr>region dup 0= ABORT" Address out of range!" + >r + \ calculate offset in region + r@ >rstart @ - + \ add regions real address in our memory + r> >rmem @ + ; + \ Bit string manipulation 06oct92py \ 9may93jaw CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, @@ -617,8 +1240,38 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 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! ; -: relon ( taddr -- ) bit$ @ swap cell/ +bit ; -: reloff ( taddr -- ) bit$ @ swap cell/ -bit ; + +: (relon) ( taddr -- ) + [ [IFDEF] fd-relocation-table ] + s" +" fd-relocation-table write-file throw + dup s>d <# #s #> fd-relocation-table write-line throw + [ [THEN] ] + bit$ @ 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] ] + bit$ @ 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 +' (>image) IS >image +[ELSE] +' drop IS relon +' drop IS reloff +' (>regionimage) IS >image +[THEN] \ Target memory access 06oct92py @@ -636,28 +1289,25 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, \ see kernel.fs dup cfalign+ + ; ->CROSS -: >image ( taddr -- absaddr ) image @ + ; ->TARGET : @ ( 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 swap over ! cell+ ! 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 T here drop H ; -: c, ( char -- ) T here tchar allot c! H ; -: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ; +: , ( 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, tchar H +LOOP ; + T here H cfalign+ 0 ?DO bl T c, H tchar +LOOP ; -: >address dup 0>= IF tchar / THEN ; +: >address dup 0>= IF tbyte / THEN ; \ ?? jaw : A! swap >address swap dup relon T ! H ; : A, ( w -- ) >address T here H relon T , H ; @@ -669,15 +1319,16 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, ?DO dup T c@ H I T c! H 1+ tchar +LOOP drop ; +\ \ Load Assembler + >TARGET -H also Forth definitions \ ." asm: " order +H also Forth definitions -: X also target bl word find +: X bl word count [ ' target >wordlist ] Literal search-wordlist IF state @ IF compile, ELSE execute THEN - ELSE previous ABORT" Cross: access method not supported!" - THEN - previous ; immediate + ELSE -1 ABORT" Cross: access method not supported!" + THEN ; immediate [IFDEF] asm-include asm-include [THEN] hex @@ -686,45 +1337,6 @@ previous \ \ -------------------- Compiler Plug Ins 01aug97jaw -\ Compiler States - -Variable comp-state -0 Constant interpreting -1 Constant compiling -2 Constant resolving -3 Constant assembling - -Defer lit, ( n -- ) -Defer alit, ( n -- ) - -Defer branch, ( target-addr -- ) \ compiles a branch -Defer ?branch, ( target-addr -- ) \ compiles a ?branch -Defer branchmark, ( -- branch-addr ) \ reserves room for a branch -Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch -Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch -Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) -Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark -Defer branchfrom, ( -- ) \ ?! -Defer branchtomark, ( -- target-addr ) \ marks a branch destination - -Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position -Defer colonmark, ( -- addr ) \ marks a colon call -Defer colon-resolve ( tcfa addr -- ) - -Defer addr-resolve ( target-addr addr -- ) -Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) - -Defer do, ( -- do-token ) -Defer ?do, ( -- ?do-token ) -Defer for, ( -- for-token ) -Defer loop, ( do-token / ?do-token -- ) -Defer +loop, ( do-token / ?do-token -- ) -Defer next, ( for-token ) - -[IFUNDEF] ca>native -defer ca>native -[THEN] - >TARGET DEFER >body \ we need the system >body \ and the target >body @@ -740,9 +1352,9 @@ DEFER dodoes, DEFER ]comp \ starts compilation DEFER comp[ \ ends compilation -: (cc) T a, H ; ' (cc) IS colon, +: (prim) T a, H ; ' (prim) IS prim, -: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve +: (cr) >tempdp ]comp prim, comp[ tempdp> ; ' (cr) IS colon-resolve : (ar) T ! H ; ' (ar) IS addr-resolve : (dr) ( ghost res-pnt target-addr addr ) >tempdp drop over @@ -754,70 +1366,12 @@ DEFER comp[ \ ends compilation : (cm) ( -- addr ) T here align H - -1 colon, ; ' (cm) IS colonmark, + -1 prim, ; ' (cm) IS colonmark, >TARGET -: compile, colon, ; +: compile, prim, ; >CROSS -\ file loading - -: >fl-id 1 cells + ; -: >fl-name 2 cells + ; - -Variable filelist 0 filelist ! -0 Value filemem -: loadfile filemem >fl-name ; - -1 [IF] \ !! JAW WIP - -: add-included-file ( adr len -- ) - dup char+ >fl-name allocate throw >r - r@ >fl-name place - filelist @ r@ ! - r> dup filelist ! to FileMem - ; - -: included? ( c-addr u -- f ) - filelist - BEGIN @ dup - WHILE >r r@ 1 cells + count compare 0= - IF rdrop 2drop true EXIT THEN - r> - REPEAT - 2drop drop false ; - -: included -\ cr ." Including: " 2dup type ." ..." - FileMem >r - 2dup add-included-file included - r> to FileMem ; - -: include bl word count included ; - -: require bl word count included ; - -[THEN] - -\ 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 - rot >r here r@ >link @ , r> >link ! - ( taddr tag ) , - ( taddr ) , - last-header-ghost @ , - loadfile , - sourceline# , - ; - : refered ( ghost tag -- ) \G creates a resolve structure T here aligned H swap (refered) @@ -838,11 +1392,11 @@ Variable filelist 0 filelist ! Defer resolve-warning : reswarn-test ( ghost res-struct -- ghost res-struct ) - over cr ." Resolving " >ghostname type dup ." in " >ghost @ >ghostname type ; + over cr ." Resolving " .ghost dup ." in " >ghost @ .ghost ; : reswarn-forward ( ghost res-struct -- ghost res-struct ) - over warnhead >ghostname type dup ." is referenced in " - >ghost @ >ghostname type ; + over warnhead .ghost dup ." is referenced in " + >ghost @ .ghost ; \ ' reswarn-test IS resolve-warning @@ -887,15 +1441,22 @@ Exists-Warnings on ELSE true abort" CROSS: Ghostnames inconsistent " THEN ; +: colon-resolved ( ghost -- ) + >link @ colon, ; \ compile-call +: prim-resolved ( ghost -- ) + >link @ prim, ; + : resolve ( ghost tcfa -- ) \G resolve referencies to ghost with tcfa \ is ghost resolved?, second resolve means another definition with the \ same name - over forward? 0= IF exists EXIT THEN + 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 ! r@ >magic ! + r@ >comp @ ['] is-forward = IF + ['] prim-resolved r@ >comp ! THEN \ loop through forward referencies r> -rot comp-state @ >r Resolving comp-state ! @@ -907,17 +1468,11 @@ Exists-Warnings on \ gexecute ghost, 01nov92py -: is-forward ( ghost -- ) - colonmark, 0 (refered) ; \ compile space for call - -: is-resolved ( ghost -- ) - >link @ colon, ; \ compile-call - : gexecute ( ghost -- ) - dup @ = IF is-forward ELSE is-resolved THEN ; + dup >comp @ execute ; : addr, ( ghost -- ) - dup @ = IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; + dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ; \ !! : ghost, ghost gexecute ; @@ -935,7 +1490,7 @@ variable ResolveFlag >link BEGIN @ dup WHILE cr 5 spaces - dup >ghost @ >ghostname type + dup >ghost @ .ghost ." file " dup >file @ ?dup IF count type ELSE ." CON" THEN ." line " dup >line @ .dec REPEAT @@ -949,7 +1504,6 @@ variable ResolveFlag ELSE drop THEN ; ->MINIMAL : .unresolved ( -- ) ResolveFlag off cr ." Unresolved: " Ghostnames @@ -968,19 +1522,29 @@ variable ResolveFlag 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 +\ !! should be target wordsize specific +$80 constant alias-mask +$40 constant immediate-mask +$20 constant restrict-mask + >TARGET -: immediate 40 flag! +: immediate immediate-mask flag! ^imm @ @ dup = IF drop EXIT THEN <> ABORT" CROSS: Cannot immediate a unresolved word" ^imm @ ! ; -: restrict 20 flag! ; +: restrict restrict-mask flag! ; : isdoer \G define a forth word as doer, this makes obviously only sence on @@ -988,18 +1552,14 @@ VARIABLE ^imm last-header-ghost @ >magic ! ; >CROSS -\ ALIAS2 ansforth conform alias 9may93jaw - -: ALIAS2 create here 0 , DOES> @ execute ; -\ usage: -\ ' alias2 bla ! - \ Target Header Creation 01nov92py >TARGET : string, ( addr count -- ) - dup T c, H bounds ?DO I c@ T c, H LOOP ; -: name, ( "name" -- ) bl word count T string, cfalign H ; + dup T c, H bounds ?DO I c@ T c, H LOOP ; +: lstring, ( addr count -- ) + dup T , H bounds ?DO I c@ T c, H LOOP ; +: name, ( "name" -- ) bl word count T lstring, cfalign H ; : view, ( -- ) ( dummy ) ; >CROSS @@ -1019,7 +1579,8 @@ Variable to-doc to-doc on 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 + + tlast @ >image count 1F and doc-file-id write-file throw >in @ [char] ( parse 2drop [char] ) parse doc-file-id write-file throw @@ -1041,7 +1602,7 @@ Create tag-bof 1 c, 0C c, 2variable last-loadfilename 0 0 last-loadfilename 2! : put-load-file-name ( -- ) - loadfilename 2@ last-loadfilename 2@ d<> + sourcefilename last-loadfilename 2@ d<> IF tag-bof count tag-file-id write-line throw sourcefilename 2dup @@ -1056,7 +1617,7 @@ Create tag-bof 1 c, 0C c, 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 + 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 @@ -1068,16 +1629,32 @@ Create tag-bof 1 c, 0C c, Defer skip? ' false IS skip? -: defined? ( -- flag ) \ name +: skipdef ( -- ) +\G skip definition of an undefined word in undef-words and +\G all-words mode + ghost dup forward? + IF >magic swap ! + ELSE drop THEN ; + +: tdefined? ( -- flag ) \ name + ghost undefined? 0= ; + +: defined2? ( -- flag ) \ name +\G return true for anything else than forward, even for +\G that's what we want ghost forward? 0= ; +: forced? ( -- flag ) \ name +\G return ture if it is a foreced skip with defskip + ghost >magic @ = ; + : 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 forward? + IF dup undefined? nip 0= ELSE drop true THEN ; @@ -1090,9 +1667,6 @@ Defer skip? ' false IS skip? \ Target header creation -Variable CreateFlag -CreateFlag off - Variable NoHeaderFlag NoHeaderFlag off @@ -1100,11 +1674,13 @@ NoHeaderFlag off base @ >r hex 0 swap <# 0 ?DO # LOOP #> type r> base ! ; -: .sym + +: .sym ( adr len -- ) +\G escapes / and \ to produce sed output bounds DO I c@ dup - CASE '/ OF drop ." \/" ENDOF - '\ OF drop ." \\" ENDOF + CASE [char] / OF drop ." \/" ENDOF + [char] \ OF drop ." \\" ENDOF dup OF emit ENDOF ENDCASE LOOP ; @@ -1118,28 +1694,27 @@ NoHeaderFlag off IF NoHeaderFlag off ELSE T align H view, - tlast @ dup 0> IF T 1 cells - H THEN T A, H there tlast ! + 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 ! - \ Symbol table + \ Old Symbol table sed-script \ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in ! - CreateFlag @ - IF - >in @ alias2 swap >in ! \ create alias in target - >in @ ghost swap >in ! - swap also ghosts ' previous swap ! \ tick ghost and store in alias - CreateFlag off - ELSE ghost - THEN + ghost + \ 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 >magic ^imm ! \ a pointer for immediate Already @ IF dup >end tdoes ! ELSE 0 tdoes ! THEN - 80 flag! + alias-mask flag! cross-doc-entry cross-tag-entry ; VARIABLE ;Resolve 1 cells allot @@ -1156,7 +1731,7 @@ VARIABLE ;Resolve 1 cells allot IF .sourcepos ." needs prim: " >in @ bl word count type >in ! cr THEN - (THeader over resolve T A, H 80 flag! ; + (THeader over resolve T A, H alias-mask flag! ; : Alias: ( cfa -- ) \ name >in @ skip? IF 2drop EXIT THEN >in ! dup 0< s" prims" T $has? H 0= and @@ -1202,6 +1777,8 @@ Comment ( Comment \ ELSE postpone literal postpone gexecute THEN ; immediate +: (cc) compile call T a, H ; ' (cc) IS colon, + : [G'] \G ticks a ghost and returns its address bl word gfind 0= ABORT" CROSS: Ghost don't exists" @@ -1210,7 +1787,7 @@ Comment ( Comment \ THEN ; immediate : ghost>cfa - dup forward? ABORT" CROSS: forward " >link @ ; + dup undefined? ABORT" CROSS: forward " >link @ ; >TARGET @@ -1231,11 +1808,11 @@ Cond: ['] T ' H alit, ;Cond \ modularized 14jun97jaw : fillcfa ( usedcells -- ) - T cells H xt>body swap - 0 ?DO 0 T c, tchar H +LOOP ; + T cells H xt>body swap - 0 ?DO 0 X c, tchar +LOOP ; : (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H -: (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer, +: (doer,) ( ghost -- ) ]comp addr, comp[ 1 fillcfa ; ' (doer,) IS doer, : (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol, @@ -1252,7 +1829,15 @@ Cond: ['] T ' H alit, ;Cond : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS lit, -: (alit,) ( n -- ) lit, T here cell - H relon ; ' (alit,) IS alit, +\ 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,) IS alit, +[ELSE] +: (alit,) ( n -- ) lit, ; ' (alit,) IS alit, +[THEN] : (fini,) compile ;s ; ' (fini,) IS fini, @@ -1281,8 +1866,6 @@ Defer (end-code) ELSE true ABORT" CROSS: Stack empty" THEN ; -( Cond ) : chars tchar * ; ( Cond ) - >CROSS \ tLiteral 12dec92py @@ -1299,47 +1882,49 @@ Cond: [Char] ( "" -- ) restrict \ some special literals 27jan97jaw \ !! Known Bug: Special Literals and plug-ins work only correct -\ on 16 and 32 Bit Targets and 32 Bit Hosts! +\ on targets with char = 8 bit Cond: MAXU restrict? - tcell 1 cells u> - IF compile lit tcell 0 ?DO FF T c, H LOOP - ELSE $ffffffff lit, THEN + compile lit tcell 0 ?DO FF T c, H LOOP ;Cond Cond: MINI restrict? - 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 + compile lit bigendian + IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP + ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H + THEN ;Cond Cond: MAXI restrict? - 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 + compile lit bigendian + IF 7F T c, H tcell 1 ?DO FF T c, H LOOP + ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H + THEN ;Cond >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 ( in name -- ) - gfind ?dup IF 0> IF nip >exec @ execute - ELSE nip gexecute THEN EXIT THEN - number? dup IF 0> IF swap lit, THEN lit, drop - ELSE 2drop >in ! - ghost gexecute THEN ; +: tcom ( x1 .. xn n name -- ) +\ dup count type space + gfind ?dup + IF >r >r discard r> r> + 0> IF >exec @ execute + 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 @@ -1348,8 +1933,8 @@ Cond: MAXI : ] state on Compiling comp-state ! BEGIN - BEGIN >in @ bl word - dup c@ 0= WHILE 2drop refill 0= + BEGIN save-input bl word + dup c@ 0= WHILE drop discard refill 0= ABORT" CROSS: End of file while target compiling" REPEAT tcom @@ -1390,7 +1975,8 @@ Cond: ; ( -- ) restrict? comp[ state off ;Resolve @ - IF ;Resolve @ ;Resolve cell+ @ resolve THEN + IF ;Resolve @ ;Resolve cell+ @ resolve + ['] prim-resolved ;Resolve @ >comp ! THEN Interpreting comp-state ! ;Cond Cond: [ restrict? state off Interpreting comp-state ! ;Cond @@ -1421,24 +2007,19 @@ Cond: DOES> restrict? \ Builder 11may93jaw -: Builder ( Create-xt do:-xt "name" -- ) +: Builder ( Create-xt do-ghost "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 - >in @ alias2 swap dup >in ! >r >r - Make-Ghost - rot swap >exec dup @ ['] NoExec <> - IF 2drop ELSE ! THEN - , - r> r> >in ! - also ghosts ' previous swap ! ; -\ DOES> dup >exec @ execute ; + Make-Ghost ( Create-xt do-ghost ghost ) + rot swap ( do-ghost Create-xt ghost ) + >exec ! , ; : gdoes, ( ghost -- ) \ makes the codefield for a word that is built - >end @ dup forward? 0= + >end @ dup undefined? 0= IF dup >magic @ = IF doer, @@ -1454,28 +2035,34 @@ Cond: DOES> restrict? : TCreate ( -- ) executed-ghost @ - CreateFlag on create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN Theader >r dup gdoes, -\ stores execution symantic in the built word - >end @ >exec @ r> >exec ! ; +\ stores execution semantic in the built word +\ if the word already has a semantic (concerns S", IS, .", DOES>) +\ then keep it + >end @ + dup >exec @ r@ >exec dup @ ['] NoExec = IF ! ELSE 2drop THEN + >comp @ r> >comp ! ; : RTCreate ( -- ) \ creates a new word with code-field in ram executed-ghost @ - CreateFlag on create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN \ make Alias - (THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost ) + (THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost ) \ store poiter to code-field switchram T cfalign H there swap T ! H there tlastcfa ! dup there resolve 0 ;Resolve ! >r dup gdoes, - >end @ >exec @ r> >exec ! ; +\ stores execution semantic in the built word +\ if the word already has a semantic (concerns S", IS, .", DOES>) +\ then keep it + >end @ >exec @ r> >exec dup @ ['] NoExec = + IF ! ELSE 2drop THEN ; : Build: ( -- [xt] [colon-sys] ) :noname postpone TCreate ; @@ -1488,27 +2075,34 @@ Cond: DOES> restrict? postpone TCreate [ [THEN] ] ; +: g>body ( ghost -- body ) + >link @ T >body H ; : gdoes> ( ghost -- addr flag ) executed-ghost @ state @ IF gexecute true EXIT THEN - >link @ T >body H false ; + g>body false ; \ DO: ;DO 11may93jaw \ changed to ?EXIT 10may93jaw -: DO: ( -- addr [xt] [colon-sys] ) +: DO: ( -- ghost [xt] [colon-sys] ) here ghostheader :noname postpone gdoes> postpone ?EXIT ; -: by: ( -- addr [xt] [colon-sys] ) \ name +: by: ( -- ghost [xt] [colon-sys] ) \ name ghost :noname postpone gdoes> postpone ?EXIT ; -: ;DO ( addr [xt] [colon-sys] -- addr ) +: ;DO ( ghost [xt] [colon-sys] -- ghost ) postpone ; ( S addr xt ) over >exec ! ; immediate -: by ( -- addr ) \ Name +: compile: ( ghost -- ghost [xt] [colon-sys] ) + :noname postpone g>body ; +: ;compile ( ghost [xt] [colon-sys] -- ghost ) + postpone ; over >comp ! ; immediate + +: by ( -- ghost ) \ Name ghost >end @ ; >TARGET @@ -1516,6 +2110,7 @@ Cond: DOES> restrict? Build: ( n -- ) ; by: :docon ( ghost -- n ) T @ H ;DO +compile: alit, compile @ ;compile Builder (Constant) Build: ( n -- ) T , H ; @@ -1532,6 +2127,7 @@ Builder 2Constant BuildSmart: ; by: :dovar ( ghost -- addr ) ;DO +compile: alit, ;compile Builder Create T has? rom H [IF] @@ -1567,25 +2163,30 @@ Builder AVariable \ 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: T 0 u, , H ; -by: :douser ( ghost -- up-addr ) T @ H tup @ + ;DO +Build: 0 u, X , ; +by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO +compile: compile useraddr T @ , H ;compile Builder User -Build: T 0 u, , 0 u, drop H ; +Build: 0 u, X , 0 u, drop ; by User Builder 2User -Build: T 0 au, , H ; +Build: 0 au, X , ; by User Builder AUser @@ -1599,9 +2200,10 @@ Builder AValue BuildSmart: ( -- ) [T'] noop T A, H ; by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO +compile: alit, compile @ compile execute ;compile Builder Defer -BuildSmart: ( inter comp -- ) swap T immediate A, A, H ; +Build: ( inter comp -- ) swap T immediate A, A, H ; DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO Builder interpret/compile: @@ -1615,6 +2217,7 @@ Builder interpret/compile: Build: ; by: :dofield T @ H + ;DO +compile: T @ H lit, compile + ;compile Builder (Field) Build: ( align1 offset1 align size "name" -- align2 offset2 ) @@ -1629,8 +2232,13 @@ Builder Field : cell% ( n -- size align ) T 1 cells H dup ; -\ ' 2Constant Alias2 end-struct -\ 0 1 T Chars H 2Constant struct +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 @@ -1639,15 +2247,17 @@ Builder Field : sys? ( sys -- sys ) dup 0= ?struc ; : >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; -: branchoffset ( src dest -- ) - tchar / ; +: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw -: >resolve ( sys -- ) T here ( dup ." >" hex. ) over branchoffset swap ! H ; +: >resolve ( sys -- ) + X here ( dup ." >" hex. ) over branchoffset swap X ! ; -: TARGET @@ -1667,29 +2277,10 @@ Builder Field Cond: BUT restrict? sys? swap ;Cond Cond: YET restrict? sys? dup ;Cond -0 [IF] ->CROSS -Variable tleavings ->TARGET - -Cond: DONE ( addr -- ) restrict? tleavings @ - BEGIN 2dup u> 0= WHILE dup T @ H swap >resolve REPEAT - tleavings ! drop ;Cond - >CROSS -: (leave) T here H tleavings @ T , H tleavings ! ; ->TARGET - -Cond: LEAVE restrict? compile branch (leave) ;Cond -Cond: ?LEAVE restrict? compile 0= compile ?branch (leave) ;Cond -[ELSE] - \ !! This is WIP - \ The problem is (?DO)! - \ perhaps we need a plug-in for (?DO) - ->CROSS Variable tleavings 0 tleavings ! + : (done) ( addr -- ) tleavings @ BEGIN dup @@ -1719,8 +2310,6 @@ Cond: DONE ( addr -- ) restrict? (don Cond: LEAVE restrict? branchmark, (leave) ;Cond Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond -[THEN] - >CROSS \ !!JW ToDo : Move to general tools section @@ -1763,7 +2352,7 @@ Cond: ENDCASE restrict? compile drop 0 \ Structural Conditionals 12dec92py -:noname +:noname \ ?? i think 0 is too much! jaw 0 compile (do) branchtomark, 2 to1 ; IS do, ( -- target-addr ) @@ -1799,12 +2388,12 @@ Cond: NEXT restrict? sys? next, ;Cond : ," [char] " parse T string, align H ; -Cond: ." restrict? compile (.") T ," H ;Cond -Cond: S" restrict? compile (S") T ," H ;Cond -Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond +Cond: ." restrict? compile (.") T ," H ;Cond ( " ) +Cond: S" restrict? compile (S") T ," H ;Cond ( " ) +Cond: ABORT" restrict? compile (ABORT") T ," H ;Cond ( " ) Cond: IS T ' >body H compile ALiteral compile ! ;Cond -: IS T ' >body ! H ; +: IS T >address ' >body ! H ; Cond: TO T ' >body H compile ALiteral compile ! ;Cond : TO T ' >body ! H ; @@ -1815,7 +2404,7 @@ Cond: defers T ' >body @ compile, H ;Con \ LINKED ERR" ENV" 2ENV" 18may93jaw \ linked list primitive -: linked T here over @ A, swap ! H ; +: linked X here over X @ X A, swap X ! ; : chained T linked A, H ; : err" s" ErrLink linked" evaluate T , H @@ -1844,10 +2433,58 @@ Cond: postpone ( -- ) restrict? \ name IF gexecute ELSE compile (compile) addr, THEN 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 ; + \ \ minimal definitions ->MINIMAL -also minimal +>MINIMAL also minimal + \ Usefull words 13feb93py : KB 400 * ; @@ -1868,7 +2505,7 @@ Create parsed 20 chars allot \ store wor : [ELSE] 1 BEGIN BEGIN bl word count dup WHILE - comment? parsed place upcase parsed count + 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 @@ -1901,21 +2538,21 @@ Cond: [ELSE] postpone [ELSE] ;Cond \ define new [IFDEF] and [IFUNDEF] 20may93jaw -: defined? defined? ; +: 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 ] aliteral search-wordlist + bl word count [ ' target >wordlist ] literal search-wordlist dup IF nip THEN ; : [IFDEF] >in @ directive? swap >in ! - 0= IF defined? ELSE name 2drop true THEN + 0= IF tdefined? ELSE name 2drop true THEN postpone [IF] ; -: [IFUNDEF] defined? 0= postpone [IF] ; +: [IFUNDEF] tdefined? 0= postpone [IF] ; Cond: [IFDEF] postpone [IFDEF] ;Cond @@ -1923,8 +2560,8 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond \ C: \- \+ Conditional Compiling 09jun93jaw -: C: >in @ defined? 0= - IF >in ! T : H +: C: >in @ tdefined? 0= + IF >in ! X : ELSE drop BEGIN bl word dup c@ IF count comment? s" ;" compare 0= ?EXIT @@ -1933,16 +2570,16 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond AGAIN THEN ; -also minimal +: d? d? ; -\G doesn't skip line when bit is set in debugmask -: \D name evaluate debugmasksource @ and 0= IF postpone \ THEN ; +\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 -: \- defined? IF postpone \ THEN ; +: \- tdefined? IF postpone \ THEN ; \G interprets the line if word is defined -: \+ defined? 0= IF postpone \ THEN ; +: \+ tdefined? 0= IF postpone \ THEN ; Cond: \- \- ;Cond Cond: \+ \+ ;Cond @@ -1954,63 +2591,15 @@ Cond: \D \D ;Cond \G defines ghost for words that we want to be compiled BEGIN >in @ bl word c@ WHILE >in ! ghost drop REPEAT drop ; -previous - -\ save-cross 17mar93py - ->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" -i" r@ write-file throw - #lf r@ emit-file throw - r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) - ?do - bl over emit-file throw - loop - drop - magic 8 r@ write-file throw \ write magic - ELSE - bl parse 2drop - THEN - 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 ; - \ words that should be in minimal create s-buffer 50 chars allot ->MINIMAL -also minimal - bigendian Constant bigendian + : here there ; +: equ constant ; +: mark there constant ; \ compiler directives : >ram >ram ; @@ -2030,14 +2619,13 @@ bigendian Constant bigendian also forth [IFDEF] Label : Label defempty? Label ; [THEN] [IFDEF] start-macros : start-macros defempty? start-macros ; [THEN] -[IFDEF] builttag : builttag builttag ; [THEN] +\ [IFDEF] builttag : builttag builttag ; [THEN] previous : s" [char] " parse s-buffer place s-buffer count ; \ for environment? : + + ; : 1+ 1 + ; : 2+ 2 + ; -: or or ; : 1- 1- ; : - - ; : and and ; @@ -2056,9 +2644,10 @@ previous : 2/ 2/ ; : . . ; -: all-words ['] false IS skip? ; +: all-words ['] forced? IS skip? ; : needed-words ['] needed? IS skip? ; -: undef-words ['] defined? IS skip? ; +: undef-words ['] defined2? IS skip? ; +: skipdef skipdef ; : \ postpone \ ; immediate : \G T-\G ; immediate @@ -2069,22 +2658,22 @@ previous : ." [char] " parse type ; : cr cr ; -: times 0 ?DO dup T c, H LOOP drop ; \ used for space table creation -only forth also minimal definitions +: 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 ; : hex hex ; -: tudp T tudp H ; -: tup T tup H ; +\ : tudp X tudp ; +\ : tup X tup ; -: doc-off false T to-doc H ! ; -: doc-on true T to-doc H ! ; -[IFDEF] dbg : dbg dbg ; [THEN] +: doc-off false to-doc ! ; +: doc-on true to-doc ! ; -minimal +[IFDEF] dbg : dbg dbg ; [THEN] \ for debugging... : order order ; @@ -2098,17 +2687,29 @@ minimal : T minimal ; immediate : G ghosts ; immediate -: turnkey 0 set-order also Target definitions - also Minimal also ; +: turnkey + \GFORTH 0 set-order also ghosts + \ANSI [ ' ghosts >wordlist ] Literal 1 set-order + also target definitions + also Minimal also ; \ these ones are pefered: : lock turnkey ; -: unlock forth also cross ; +: unlock previous forth also cross ; +\ also minimal : [[ also unlock ; -: ]] previous previous ; +: ]] previous previous also also ; unlock definitions also minimal : lock lock ; lock + +\ load cross compiler extension defined in mach file + +UNLOCK >CROSS + +[IFDEF] extend-cross extend-cross [THEN] + +LOCK