--- gforth/cross.fs 1995/07/25 15:28:04 1.26 +++ gforth/cross.fs 2001/09/04 13:07:44 1.104 @@ -1,70 +1,65 @@ \ CROSS.FS The Cross-Compiler 06oct92py -\ $Id: cross.fs,v 1.26 1995/07/25 15:28:04 pazsan Exp $ \ Idea and implementation: Bernd Paysan (py) -\ Copyright 1992-94 by the GNU Forth Development Group -\ Log: -\ changed in ; [ to state off 12may93jaw -\ included place +place 12may93jaw -\ for a created word (variable, constant...) -\ is now an alias in the target voabulary. -\ this means it is no longer necessary to -\ switch between vocabularies for variable -\ initialization 12may93jaw -\ discovered error in DOES> -\ replaced !does with (;code) 16may93jaw -\ made complete redesign and -\ introduced two vocs method -\ to be asure that the right words -\ are found 08jun93jaw -\ btw: ! works not with 16 bit -\ targets 09jun93jaw -\ added: 2user and value 11jun93jaw +\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. -\ include other.fs \ ansforth extentions for cross +\ This file is part of Gforth. -: string, ( c-addr u -- ) - \ puts down string as cstring - dup c, here swap chars dup allot move ; -' falign Alias cfalign -: comment? ( c-addr u -- c-addr u ) - 2dup s" (" compare 0= - IF postpone ( - ELSE 2dup s" \" compare 0= IF postpone \ THEN - THEN ; +\ 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. -decimal +\ 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. -\ Begin CROSS COMPILER: +\ 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. -\ GhostNames 9may93jaw -\ second name source to search trough list +0 +[IF] -VARIABLE GhostNames -0 GhostNames ! -: GhostName ( -- addr ) - here GhostNames @ , GhostNames ! here 0 , - bl word count - \ 2dup type space - string, cfalign ; +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 +Vocabulary Minimal only Forth also Target also also definitions Forth -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : H previous Forth also Cross ; immediate forth definitions -: T previous Cross also Target ; immediate +: T previous Ghosts also Target ; immediate : G Ghosts ; immediate : >cross also Cross definitions previous ; @@ -75,93 +70,1281 @@ 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] + +\ Ghost Builder 06oct92py + +hex +4711 Constant 4712 Constant +4713 Constant 4714 Constant +4715 Constant + +1 Constant + +Struct + + \ link to next ghost (always the first element) + cell% field >next-ghost + + \ type of ghost + cell% field >magic + + \ pointer where ghost is in target, or if unresolved + \ points to the where we have to resolve (linked-list) + cell% field >link + + \ execution symantics (while target compiling) of ghost + cell% field >exec + + cell% field >exec-compile + + cell% field >exec2 + + cell% field >created + + \ the xt of the created ghost word itself + cell% field >ghost-xt + + \ pointer to the counted string of the assiciated + \ assembler label + cell% field >asm-name + + \ mapped primitives have a special address, so + \ we are able to detect them + cell% field >asm-dummyaddr + + \ for builder (create, variable...) words + \ the execution symantics of words built are placed here + \ this is a doer ghost or a dummy ghost + cell% field >do:ghost + + cell% field >ghost-flags + + cell% field >ghost-name + +End-Struct ghost-struct + +Variable ghost-list +0 ghost-list ! + +Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes> +\ Variable last-ghost \ last ghost that is created +Variable last-header-ghost \ last ghost definitions with header + +\ space for ghosts resolve structure +\ we create ghosts in a sepearte space +\ and not to the current host dp, because this +\ gives trouble with instant while compiling and creating +\ a ghost for a forward reference +\ BTW: we cannot allocate another memory region +\ because allot will check the overflow!! +Variable cross-space-dp +Create cross-space 250000 allot here 100 allot align +Constant cross-space-end +cross-space cross-space-dp ! +Variable cross-space-dp-orig + +: cross-space-used cross-space-dp @ cross-space - ; + +: >space ( -- ) + dp @ cross-space-dp-orig ! + cross-space-dp @ dp ! ; + +: space> ( -- ) + dp @ dup cross-space-dp ! + cross-space-end u> ABORT" CROSS: cross-space overflow" + cross-space-dp-orig @ dp ! ; + +: execute-exec execute ; +: execute-exec2 execute ; +: execute-exec-compile execute ; + +: NoExec + executed-ghost @ >exec2 @ + ?dup + IF execute-exec2 + ELSE true ABORT" CROSS: Don't execute ghost, or immediate target word" + THEN ; + +: (ghostheader) ( -- ) + ghost-list linked , 0 , ['] NoExec , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ; + +: ghostheader ( -- ) (ghostheader) 0 , ; + +' Ghosts >wordlist Constant ghosts-wordlist + +\ the current wordlist for ghost definitions in the host +ghosts-wordlist Value current-ghosts + +: Make-Ghost ( "name" -- ghost ) + >space + \ save current and create in ghost vocabulary + get-current >r current-ghosts set-current + >in @ Create >in ! + \ some forth systems like iForth need the immediate directly + \ after the word is created + \ restore current + r> set-current + here (ghostheader) + bl word count string, align + space> + \ set ghost-xt field by doing a search + dup >ghost-name count + current-ghosts search-wordlist + 0= ABORT" CROSS: Just created, must be there!" + over >ghost-xt ! + DOES> + dup executed-ghost ! + >exec @ execute-exec ; + +\ ghost words 14oct92py +\ changed: 10may93py/jaw + +Defer search-ghosts + +: (search-ghosts) ( adr len -- cfa true | 0 ) + current-ghosts search-wordlist ; + + ' (search-ghosts) IS search-ghosts + +: gsearch ( addr len -- ghost true | 0 ) + search-ghosts + dup IF swap >body swap THEN ; + +: gfind ( string -- ghost true / string false ) +\ searches for string in word-list ghosts + \ dup count type space + dup >r count gsearch + dup IF rdrop ELSE r> swap THEN ; + +: gdiscover ( xt -- ghost true | xt false ) + >r ghost-list + BEGIN @ dup + WHILE dup >magic @ <> + IF dup >link @ r@ = + IF rdrop true EXIT THEN + THEN + REPEAT + drop r> false ; + +: Ghost ( "name" -- ghost ) + >in @ bl word gfind IF nip EXIT THEN + drop >in ! Make-Ghost ; + +: >ghostname ( ghost -- adr len ) + >ghost-name count ; + +: forward? ( ghost -- flag ) + >magic @ = ; + +: undefined? ( ghost -- flag ) + >magic @ dup = swap = or ; + +: immediate? ( ghost -- flag ) + >magic @ = ; + +Variable TWarnings +TWarnings on +Variable Exists-Warnings +Exists-Warnings on + +: exists-warning ( ghost -- ghost ) + TWarnings @ Exists-Warnings @ and + IF dup >ghostname warnhead type ." exists " THEN ; + +\ : HeaderGhost Ghost ; + +Variable reuse-ghosts reuse-ghosts off + +1 [IF] \ FIXME: define when vocs are ready +: HeaderGhost ( "name" -- ghost ) + >in @ + bl word count +\ 2dup type space + current-ghosts search-wordlist + IF >body dup undefined? reuse-ghosts @ or + IF nip EXIT + ELSE exists-warning + THEN + drop >in ! + ELSE >in ! + THEN + \ we keep the execution semantics of the prviously + \ defined words, this is a workaround + \ for the redefined \ until vocs work + Make-Ghost ; +[THEN] + + +: .ghost ( ghost -- ) >ghostname type ; + +\ ' >ghostname ALIAS @name + +: [G'] ( -- ghost : name ) +\G ticks a ghost and returns its address +\ bl word gfind 0= ABORT" CROSS: Ghost don't exists" + ghost state @ IF postpone literal THEN ; immediate + +: ghost>cfa ( ghost -- cfa ) + dup undefined? ABORT" CROSS: forward " >link @ ; + +1 Constant