\ 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 \ 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] \ 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 : >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 ! 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 ghost :dodefer ghost :dofield 2drop drop ghost over ghost = ghost drop 2drop drop ghost call ghost useraddr ghost execute 2drop drop ghost + ghost - ghost @ 2drop 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 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 [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 >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 : 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 ; : is-resolved ( ghost -- ) >link @ colon, ; \ compile-call : 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 ! r@ >comp @ ['] is-forward = IF ['] is-resolved r@ >comp ! THEN \ loop through forward referencies r> -rot comp-state @ >r Resolving comp-state ! resolve-loop r> comp-state ! ['] noop IS resolve-warning ; \ gexecute ghost, 01nov92py : gexecute ( ghost -- ) dup >comp @ execute ; : addr, ( ghost -- ) dup forward? 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 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 immediate-mask flag! ^imm @ @ dup = IF drop EXIT THEN <> ABORT" CROSS: Cannot immediate a unresolved word" ^imm @ ! ; : restrict restrict-mask 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 alias-mask 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 alias-mask 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 targets with char = 8 bit Cond: MAXU restrict? compile lit tcell 0 ?DO FF T c, H LOOP ;Cond Cond: MINI restrict? 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? 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 ( 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 ! , ; : 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 @ 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 @ create-forward-warn IF ['] reswarn-forward IS resolve-warning THEN \ make Alias (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, \ 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] ] ; : g>body ( ghost -- body ) >link @ T >body H ; : gdoes> ( ghost -- addr flag ) executed-ghost @ state @ IF gexecute true EXIT THEN g>body false ; \ DO: ;DO 11may93jaw \ changed to ?EXIT 10may93jaw : DO: ( -- ghost [xt] [colon-sys] ) here ghostheader :noname postpone gdoes> postpone ?EXIT ; : by: ( -- ghost [xt] [colon-sys] ) \ name ghost :noname postpone gdoes> postpone ?EXIT ; : ;DO ( ghost [xt] [colon-sys] -- ghost ) postpone ; ( S addr xt ) over >exec ! ; immediate : compile: ( ghost -- ghost [xt] [colon-sys] ) :noname postpone g>body ; : ;compile ( ghost [xt] [colon-sys] -- ghost ) postpone ; over >comp ! ; : by ( -- ghost ) \ Name ghost >end @ ; >TARGET \ Variables and Constants 05dec92py Build: ( n -- ) ; by: :docon ( ghost -- n ) T @ H ;DO \ compile: alit, compile @ ;compile 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 \ compile: alit, ;compile 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 \ compile: compile useraddr @ , ;compile 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 \ compile: alit, compile @ compile execute ;compile 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 \ compile: T @ H lit, compile + ;compile 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 \ 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 ; : | ; \ : | 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