--- gforth/cross.fs 1995/09/06 21:00:11 1.28 +++ gforth/cross.fs 2004/08/26 15:50:44 1.146 @@ -1,72 +1,69 @@ \ CROSS.FS The Cross-Compiler 06oct92py -\ $Id: cross.fs,v 1.28 1995/09/06 21:00:11 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,2003 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. + +0 +[IF] + +ToDo: +- Crossdoc destination ./doc/crossdoc.fd makes no sense when + cross.fs is used seperately. jaw +- Do we need this char translation with >address and in branchoffset? + (>body also affected) jaw -\ GhostNames 9may93jaw -\ second name source to search trough list +[THEN] -VARIABLE GhostNames -0 GhostNames ! -: GhostName ( -- addr ) - here GhostNames @ , GhostNames ! here 0 , - bl word count - \ 2dup type space - string, cfalign ; +s" compat/strcomp.fs" included 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 ; : >target also Target definitions previous ; : >minimal also Minimal definitions previous ; @@ -75,93 +72,1557 @@ H >CROSS -\ Variables 06oct92py +\ Test against this definitions to find out whether we are cross-compiling +\ may be usefull for assemblers +0 Constant gforth-cross-indicator --1 Constant NIL -Variable image -Variable tlast NIL tlast ! \ Last name field -Variable tlastcfa \ Last code field -Variable tdoes \ Resolve does> calls -Variable bit$ -Variable tdp -: there tdp @ ; +\ 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] + +\ this provides assert( and struct stuff +\GFORTH [IFUNDEF] assert1( +\GFORTH also forth definitions require assert.fs previous +\GFORTH [THEN] + +>CROSS + +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 + +\ FIXME delete` +\ 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!!! + +\ FIXME move down +: comment? ( c-addr u -- c-addr u ) + 2dup s" (" str= + IF postpone ( + ELSE 2dup s" \" str= IF postpone \ THEN + THEN ; + +: X ( -- ) +\G The next word in the input is a target word. +\G Equivalent to T but without permanent +\G switch to target dictionary. Used as prefix e.g. for @, !, here etc. + 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 + +\ 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 + +: symentry ( adr len taddr -- ) +\G Produce a symbol table (an optional symbol address +\G map) if wanted + [ [IFDEF] fd-symbol-table ] + base @ swap hex s>d <# 8 0 DO # LOOP #> fd-symbol-table write-file throw base ! + s" :" fd-symbol-table write-file throw + fd-symbol-table write-line throw + [ [ELSE] ] + 2drop drop + [ [THEN] ] ; + + +\ \ -------------------- 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 ! -\ Parameter for target systems 06oct92py +cross-file-list Value file-list +0 Value source-desc -included +\ file loading -\ Create additional parameters 19jan95py +: >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>string 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>string + BEGIN tuck dup WHILE repeat ; + +: .path ( path-addr -- ) \ gforth + \G Display the contents of the search path @var{path-addr}. + path>string + 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 S" ../" string-prefix? r> or >r \ not catered for in expandtopic + S" ./" string-prefix? + 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 s" ~+/" string-prefix? + IF + ofile count 3 /string ofile place + THEN ; + +: expandtopic ( -- ) \ stack effect correct? - anton + \ expands "./" into an absolute name + ofile count s" ./" string-prefix? + 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 s" /../" string-prefix? + 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>string + 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 str= + 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 +\ : defempty? .sourcepos ; +[THEN] + +\ \ -------------------- Compiler Plug Ins 01aug97jaw + +>CROSS + +\ Compiler States + +Variable comp-state +0 Constant interpreting +1 Constant compiling +2 Constant resolving +3 Constant assembling + +: compiling? comp-state @ compiling = ; + +: pi-undefined -1 ABORT" Plugin undefined" ; + +: Plugin ( -- : pluginname ) + Create + \ for normal cross-compiling only one action + \ exists, this fields are identical. For the instant + \ simulation environment we need, two actions for each plugin + \ the target one and the one that generates the simulation code + ['] pi-undefined , \ action + ['] pi-undefined , \ target plugin action + 8765 , \ plugin magic + DOES> perform ; + +Plugin DummyPlugin + +: 'PI ( -- addr : pluginname ) + ' >body dup 2 cells + @ 8765 <> ABORT" not a plugin" ; + +: plugin-of ( xt -- : pluginname ) + dup 'PI 2! ; + +: action-of ( xt -- : plunginname ) + 'PI cell+ ! ; + +: TPA ( -- : plugin ) +\ target plugin action +\ executes current target action of plugin + 'PI cell+ POSTPONE literal POSTPONE perform ; immediate + +Variable ppi-temp 0 ppi-temp ! + +: pa: +\g define plugin action + ppi-temp @ ABORT" pa: definition not closed" + 'PI ppi-temp ! :noname ; + +: ;pa +\g end a definition for plugin action + POSTPONE ; ppi-temp @ ! 0 ppi-temp ! ; immediate + + +Plugin dlit, ( d -- ) \ compile numerical value the target +Plugin lit, ( n -- ) +Plugin alit, ( n -- ) + +Plugin branch, ( target-addr -- ) \ compiles a branch +Plugin ?branch, ( target-addr -- ) \ compiles a ?branch +Plugin branchmark, ( -- branch-addr ) \ reserves room for a branch +Plugin ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch +Plugin ?domark, ( -- branch-addr ) \ reserves room for a ?do branch +Plugin branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment) +' NOOP plugin-of branchto, +Plugin branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark +Plugin branchtomark, ( -- target-addr ) \ marks a branch destination + +Plugin colon, ( tcfa -- ) \ compiles call to tcfa at current position +Plugin prim, ( tcfa -- ) \ compiles primitive invocation +Plugin colonmark, ( -- addr ) \ marks a colon call +Plugin colon-resolve ( tcfa addr -- ) + +Plugin addr-resolve ( target-addr addr -- ) +Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt ) + +Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open +Plugin if, ( -- if-token ) +Plugin else, ( if-token -- if-token ) +Plugin then, ( if-token -- ) +Plugin ahead, +Plugin begin, +Plugin while, +Plugin until, +Plugin again, +Plugin repeat, +Plugin cs-swap ( x1 x2 -- x2 x1 ) + +Plugin case, ( -- n ) +Plugin of, ( n -- x1 n ) +Plugin endof, ( x1 n -- x2 n ) +Plugin endcase, ( x1 .. xn n -- ) + +Plugin do, ( -- do-token ) +Plugin ?do, ( -- ?do-token ) +Plugin for, ( -- for-token ) +Plugin loop, ( do-token / ?do-token -- ) +Plugin +loop, ( do-token / ?do-token -- ) +Plugin next, ( for-token ) +Plugin leave, ( -- ) +Plugin ?leave, ( -- ) + +Plugin ca>native \ Convert a code address to the processors + \ native address. This is used in doprim, and + \ code/code: primitive definitions word to + \ convert the addresses. + \ The only target where we need this is the misc + \ which is a 16 Bit processor with word addresses + \ but the forth system we build has a normal byte + \ addressed memory model + +Plugin doprim, \ compiles start of a primitive +Plugin docol, \ compiles start of a colon definition +Plugin doer, +Plugin fini, \ compiles end of definition ;s +Plugin doeshandler, +Plugin dodoes, + +Plugin colon-start +' noop plugin-of colon-start +Plugin colon-end +' noop plugin-of colon-end + +Plugin ]comp \ starts compilation +' noop plugin-of ]comp +Plugin comp[ \ ends compilation +' noop plugin-of comp[ + +Plugin t>body \ we need the system >body + \ and the target >body + +>TARGET +: >body t>body ; + + +\ Ghost Builder 06oct92py + +>CROSS +hex +\ Values for ghost magic +4711 Constant 4712 Constant +4713 Constant 4714 Constant +4715 Constant + +\ Bitmask for ghost flags +1 Constant +2 Constant + +\ FXIME: move this to general stuff? +: set-flag ( addr flag -- ) + over @ or swap ! ; + +: reset-flag ( addr flag -- ) + invert over @ and swap ! ; + +: get-flag ( addr flag -- f ) + swap @ and 0<> ; + + +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 semantics (while target compiling) of ghost + cell% field >exec + + \ compilation action of this ghost; this is what is + \ done to compile a call (or whatever) to this definition. + \ E.g. >comp contains the semantic of postpone s" + \ whereas >exec-compile contains the semantic of s" + cell% field >comp + + \ Compilation sematics (while parsing) of this ghost. E.g. + \ "\" will skip the rest of line. + \ These semantics are defined by Cond: and + \ if a word is made immediate in instant, then the >exec2 field + \ gets copied to here + cell% field >exec-compile + + \ Additional execution semantics of this ghost. This is used + \ for code generated by instant and for the doer-xt of created + \ words + 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 ! ; + +\ this is just for debugging, to see this in the backtrace +: 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 ; + +Defer is-forward + +: (ghostheader) ( -- ) + ghost-list linked , 0 , ['] NoExec , ['] is-forward , + 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 ; + +: xt>ghost ( xt -- ghost ) + gdiscover 0= ABORT" CROSS: ghost not found for this xt" ; + +: 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 + +: 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 ; + +: .ghost ( ghost -- ) >ghostname type ; + +\ ' >ghostname ALIAS @name + +: findghost ( "ghostname" -- ghost ) + bl word gfind 0= ABORT" CROSS: Ghost don't exists" ; + +: [G'] ( -- ghost : name ) +\G ticks a ghost and returns its address + findghost + state @ IF postpone literal THEN ; immediate + +: g>xt ( ghost -- xt ) +\G Returns the xt (cfa) of a ghost. Issues a warning if undefined. + dup undefined? ABORT" CROSS: forward " >link @ ; + +: g>body ( ghost -- body ) +\G Returns the body-address (pfa) of a ghost. +\G Issues a warning if undefined (a forward-reference). + g>xt X >body ; + +1 Constant