\ CROSS.FS The Cross-Compiler 06oct92py \ Idea and implementation: Bernd Paysan (py) \ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004 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 used seperately. jaw - Do we need this char translation with >address and in branchoffset? (>body also affected) jaw [THEN] 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 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 \ Test against this definitions to find out whether we are cross-compiling \ may be usefull for assemblers 0 Constant gforth-cross-indicator \ 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 ! 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>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