\ 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 -- ) \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!!! : 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? ( -- 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 \ 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] \ \ GhostNames Ghosts 9may93jaw \ second name source to search trough list VARIABLE GhostNames 0 GhostNames ! : GhostName ( -- addr ) align here GhostNames @ , GhostNames ! here 0 , bl word count \ 2dup type space string, \ !! cfalign ? align ; \ Ghost Builder 06oct92py \ new version with temp variable 10may93jaw VARIABLE VocTemp : previous VocTemp @ set-current ; hex 4711 Constant 4712 Constant 4713 Constant 4714 Constant 4715 Constant \ 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" ; : GhostHeader , 0 , ['] NoExec , ; : >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 \ for builder (create, variable...) words the \ execution symantics of words built are placed here 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 : Make-Ghost ( "name" -- ghost ) >in @ GhostName swap >in ! dup last-ghost ! DOES> dup executed-ghost ! >exec @ execute ; \ ghost words 14oct92py \ changed: 10may93py/jaw : gfind ( string -- ghost true/1 / string false ) \ searches for string in word-list ghosts dup count [ ' ghosts >wordlist ] Literal search-wordlist dup IF >r >body nip r> THEN ; : gdiscover ( xt -- ghost true | xt false ) GhostNames BEGIN @ dup WHILE 2dup cell+ @ dup >magic @ <> >r >link @ = r> and IF cell+ @ nip true EXIT THEN REPEAT drop false ; VARIABLE Already : ghost ( "name" -- ghost ) Already off >in @ bl word gfind IF atonce off Already on nip EXIT THEN drop >in ! Make-Ghost ; : >ghostname ( ghost -- adr len ) GhostNames BEGIN @ dup WHILE 2dup cell+ @ = UNTIL nip 2 cells + count ELSE 2drop \ true abort" CROSS: Ghostnames inconsistent" s" ?!?!?!" THEN ; : .ghost ( ghost -- ) >ghostname type ; \ ' >ghostname ALIAS @name : forward? ( ghost -- flag ) >magic @ = ; : undefined? ( ghost -- flag ) >magic @ dup = swap = or ; \ 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 \ we define it ans like... wordlist Constant target-environment VARIABLE env-current \ save information of current dictionary to restore with environ> : >ENVIRON get-current env-current ! target-environment set-current ; : ENVIRON> env-current @ set-current ; >TARGET : environment? ( adr len -- [ x ] true | false ) target-environment search-wordlist IF execute true ELSE false THEN ; : e? bl word count T environment? H 0= ABORT" environment variable not defined!" ; : has? bl word count T environment? H IF \ environment variable is present, return its value ELSE \ environment variable is not present, return false 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 standard-threading >TARGET previous 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 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 [IF] 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 tdoes \ Resolve does> calls 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 6 cells + ; : >rbm 5 cells + ; : >rmem 4 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 , 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 ! ; : .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 @ 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 \ 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 ; : (>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, : 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! ; : (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 : 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 >CROSS H \ \ -------------------- 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 >CROSS T 2 cells H VALUE xt>body DEFER doprim, \ compiles start of a primitive DEFER docol, \ compiles start of a colon definition DEFER doer, DEFER fini, \ compiles end of definition ;s DEFER doeshandler, DEFER dodoes, DEFER ]comp \ starts compilation DEFER comp[ \ ends compilation : (cc) T a, H ; ' (cc) IS colon, : (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve : (ar) T ! H ; ' (ar) IS addr-resolve : (dr) ( ghost res-pnt target-addr addr ) >tempdp drop over dup >magic @ = IF doer, ELSE dodoes, THEN tempdp> ; ' (dr) IS doer-resolve : (cm) ( -- addr ) T here align H -1 colon, ; ' (cm) IS 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 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) ; : 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 @ <> 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 Variable TWarnings TWarnings on Variable Exists-Warnings Exists-Warnings on : exists ( ghost tcfa -- ) over GhostNames BEGIN @ dup WHILE 2dup cell+ @ = UNTIL 2 cells + count TWarnings @ Exists-Warnings @ and IF warnhead type ." exists" ELSE 2drop THEN drop swap >link ! ELSE true abort" CROSS: Ghostnames inconsistent " THEN ; : resolve ( ghost tcfa -- ) \G resolve referencies to ghost with tcfa \ 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 ! 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 @ = IF is-forward ELSE is-resolved THEN ; : addr, ( ghost -- ) dup @ = 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 ( ghostname -- ) dup cell+ @ ?touched IF dup cell+ cell+ count cr type ResolveFlag on cell+ @ .forwarddefs ELSE drop THEN ; : .unresolved ( -- ) ResolveFlag off cr ." Unresolved: " Ghostnames 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 = IF drop EXIT THEN <> ABORT" CROSS: Cannot immediate a unresolved word" ^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 last-header-ghost @ >magic ! ; >CROSS \ Target Header Creation 01nov92py >TARGET : string, ( addr count -- ) 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 \ 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 ( -- ) \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 undefined? nip 0= ELSE drop true THEN ; : doer? ( -- flag ) \ name ghost >magic @ = ; : 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 ; : (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 ! 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! cross-doc-entry cross-tag-entry ; VARIABLE ;Resolve 1 cells allot \ this is the resolver information from ":" \ resolving is done by ";" : Theader ( "name" -- ghost ) (THeader dup there resolve 0 ;Resolve ! ; >TARGET : Alias ( cfa -- ) \ 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 (THeader over resolve T A, H 80 flag! ; : 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 swap >magic ! ; Variable prim# : first-primitive ( n -- ) prim# ! ; : Primitive ( -- ) \ name prim# @ T Alias H -1 prim# +! ; >CROSS \ Conditionals and Comments 11may93jaw : ;Cond postpone ; swap ! ; immediate : Cond: ( -- ) \ name {code } ; atonce on ghost >exec :NONAME ; : restrict? ( -- ) \ aborts on interprete state - ae state @ 0= ABORT" CROSS: Restricted" ; : Comment ( -- ) >in @ atonce on ghost swap >in ! ' swap >exec ! ; Comment ( Comment \ \ compile 10may93jaw : compile ( -- ) \ name restrict? bl word gfind dup 0= ABORT" CROSS: Can't compile " 0> ( immediate? ) IF >exec @ compile, ELSE postpone literal postpone gexecute THEN ; immediate : [G'] \G ticks a ghost and returns its address bl word gfind 0= ABORT" CROSS: Ghost don't exists" state @ IF postpone literal THEN ; immediate : ghost>cfa dup undefined? ABORT" CROSS: forward " >link @ ; >TARGET : ' ( -- cfa ) \ returns the target-cfa of a ghost bl word gfind 0= ABORT" CROSS: Ghost don't exists" ghost>cfa ; 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) T IS >body H : (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer, : (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol, : (doprim,) ( -- ) there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) IS doprim, : (doeshandler,) ( -- ) T cfalign H compile :doesjump T 0 , H ; ' (doeshandler,) IS doeshandler, : (dodoes,) ( does-action-ghost -- ) ]comp [G'] :dodoes gexecute comp[ addr, T here H tcell - reloff 2 fillcfa ; ' (dodoes,) IS dodoes, : (lit,) ( n -- ) compile lit T , H ; ' (lit,) IS 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,) IS alit, [ELSE] : (alit,) ( n -- ) lit, ; ' (alit,) IS alit, [THEN] : (fini,) compile ;s ; ' (fini,) IS 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 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 -- ) restrict? lit, ;Cond Cond: ALiteral ( n -- ) restrict? alit, ;Cond : Char ( "" -- ) bl word char+ c@ ; Cond: [Char] ( "" -- ) restrict? Char lit, ;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 restrict? tcell 1 cells u> IF compile lit tcell 0 ?DO FF T c, H LOOP ELSE ffffffff lit, THEN ;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 ;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 ;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 ?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 \ ] 9may93py/jaw : ] state on Compiling comp-state ! BEGIN BEGIN save-input bl word dup c@ 0= WHILE drop discard refill 0= ABORT" CROSS: End of file while target compiling" REPEAT tcom state @ 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 depth T ] H ; : :noname ( -- colon-sys ) T cfalign H there docol, 0 ;Resolve ! depth T ] H ; Cond: EXIT ( -- ) restrict? 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-Ghost @ gexecute ;Cond Cond: ; ( -- ) restrict? depth ?dup IF 1- <> ABORT" CROSS: Stack changed" ELSE true ABORT" CROSS: Stack empty" THEN fini, comp[ state off ;Resolve @ IF ;Resolve @ ;Resolve cell+ @ resolve THEN Interpreting comp-state ! ;Cond Cond: [ restrict? state off Interpreting comp-state ! ;Cond >CROSS Create GhostDummy ghostheader 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> ; >TARGET Cond: DOES> restrict? compile (does>) doeshandler, \ resolve words made by builders tdoes @ ?dup IF @ T here H resolve THEN ;Cond : DOES> switchrom doeshandler, T here H !does 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 ) rot swap ( do:-xt Create-xt ghost ) >exec ! , ; \ rot swap >exec dup @ ['] NoExec <> \ IF 2drop ELSE ! THEN , ; : gdoes, ( ghost -- ) \ makes the codefield for a word that is built >end @ dup undefined? 0= IF dup >magic @ = IF doer, ELSE dodoes, THEN EXIT THEN \ compile :dodoes gexecute \ T here H tcell - reloff 2 refered 0 fillcfa ; : TCreate ( -- ) executed-ghost @ create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN Theader >r dup gdoes, \ 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 ; : RTCreate ( -- ) \ creates a new word with code-field in ram executed-ghost @ 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 ) \ store poiter to code-field switchram T cfalign H there swap T ! H there tlastcfa ! dup there resolve 0 ;Resolve ! >r dup gdoes, \ 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 ; : BuildSmart: ( -- [xt] [colon-sys] ) :noname [ T has? rom H [IF] ] postpone RTCreate [ [ELSE] ] postpone TCreate [ [THEN] ] ; : gdoes> ( ghost -- addr flag ) executed-ghost @ state @ IF gexecute true EXIT THEN >link @ T >body H 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 >end @ ; >TARGET \ Variables and Constants 05dec92py Build: ( n -- ) ; by: :docon ( ghost -- 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 ( ghost -- addr ) ;DO Builder Create T has? rom H [IF] Build: ( -- ) T here 0 , 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 , 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 , H switchram T align here swap ! 0 , 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 BuildSmart: ( -- ) [T'] noop T A, H ; by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;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 : ?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 ! ; : TARGET \ Structural Conditionals 12dec92py Cond: BUT restrict? sys? swap ;Cond Cond: YET restrict? 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 Cond: DONE ( addr -- ) restrict? (done) ;Cond >CROSS : (leave) ( branchtoken -- ) 3 cells allocate throw >r T here H r@ cell+ ! r@ 2 cells + ! tleavings @ r@ ! r> tleavings ! ; >TARGET Cond: LEAVE restrict? branchmark, (leave) ;Cond Cond: ?LEAVE restrict? compile 0= ?branchmark, (leave) ;Cond >CROSS \ !!JW ToDo : Move to general tools section : to1 ( x1 x2 xn n -- addr ) \G packs n stack elements in a 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 TARGET \ Structural Conditionals 12dec92py >TARGET Cond: AHEAD restrict? branchmark, ;Cond Cond: IF restrict? ?branchmark, ;Cond Cond: THEN restrict? sys? branchto, branchtoresolve, ;Cond Cond: ELSE restrict? sys? compile AHEAD swap compile THEN ;Cond Cond: BEGIN restrict? branchtomark, ;Cond Cond: WHILE restrict? sys? compile IF swap ;Cond Cond: AGAIN restrict? sys? branch, ;Cond Cond: UNTIL restrict? sys? ?branch, ;Cond Cond: REPEAT restrict? over 0= ?struc compile AGAIN compile THEN ;Cond Cond: CASE restrict? 0 ;Cond Cond: OF restrict? 1+ >r compile over compile = compile IF compile drop r> ;Cond Cond: ENDOF restrict? >r compile ELSE r> ;Cond Cond: ENDCASE restrict? compile drop 0 ?DO compile THEN LOOP ;Cond \ Structural Conditionals 12dec92py :noname \ ?? i think 0 is too much! jaw 0 compile (do) branchtomark, 2 to1 ; IS do, ( -- target-addr ) \ :noname \ compile 2dup compile = compile IF \ compile 2drop compile ELSE \ compile (do) branchtomark, 2 to1 ; \ IS ?do, :noname 0 compile (?do) ?domark, (leave) branchtomark, 2 to1 ; IS ?do, ( -- target-addr ) :noname compile (for) branchtomark, ; IS for, ( -- target-addr ) :noname 1to compile (loop) loop] compile unloop skiploop] ; IS loop, ( target-addr -- ) :noname 1to compile (+loop) loop] compile unloop skiploop] ; IS +loop, ( target-addr -- ) :noname compile (next) loop] compile unloop ; IS next, ( target-addr -- ) Cond: DO restrict? do, ;Cond Cond: ?DO restrict? ?do, ;Cond Cond: FOR restrict? for, ;Cond Cond: LOOP restrict? sys? loop, ;Cond Cond: +LOOP restrict? sys? +loop, ;Cond Cond: NEXT restrict? sys? next, ;Cond \ String words 23feb93py : ," [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: 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 : on T -1 swap ! H ; : off T 0 swap ! H ; \ 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 T string, align H ; : env" [char] " parse s" EnvLink linked" evaluate T string, align , H ; : 2env" [char] " parse s" EnvLink linked" evaluate here >r T string, align , , H r> dup T c@ H 80 and swap T c! H ; \ compile must be last 22feb93py Cond: compile ( -- ) restrict? \ name bl word gfind dup 0= ABORT" CROSS: Can't compile" 0> IF gexecute ELSE dup >magic @ = IF gexecute ELSE compile (compile) addr, THEN THEN ;Cond Cond: postpone ( -- ) restrict? \ name bl word gfind dup 0= ABORT" CROSS: Can't compile" 0> IF gexecute ELSE dup >magic @ = IF gexecute ELSE compile (compile) addr, THEN THEN ;Cond Cond: [compile] ( -- ) restrict? \ name bl word gfind dup 0= ABORT" CROSS: Can't compile" 0> IF gexecute ELSE dup >magic @ = 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 \ 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 ; : warnings name 3 = 0= twarnings ! drop ; : redefinitions-start twarnings off ; : redefinitions-end twarnings on ; : group 0 word 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 ; : require 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 ; : hex hex ; \ : tudp X tudp ; \ : tup X tup ; : doc-off false to-doc ! ; : doc-on true to-doc ! ; [IFDEF] dbg : dbg dbg ; [THEN] \ for debugging... : order order ; : hwords words ; : words also ghosts words previous ; : .s .s ; : bye bye ; \ turnkey direction : H forth ; immediate : T minimal ; immediate : G ghosts ; immediate : 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 previous forth also cross ; \ also minimal : [[ also unlock ; : ]] 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