steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

xt.factor fix

cvs
Slava Pestov 2005-12-04 21:29:30 +00:00
parent 45cf45af89
commit 343d70acee
1 changed files with 8 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
library/compiler/xt.factor
View File

@ -23,6 +23,12 @@ SYMBOL: compiled-xts
: compiled-xt ( word -- xt ) : compiled-xt ( word -- xt )
dup compiled-xts get hash [ ] [ word-xt ] ?if ; dup compiled-xts get hash [ ] [ word-xt ] ?if ;
! deferred-xts is a vector of objects responding to the fixup
! generic.
SYMBOL: deferred-xts
: deferred-xt deferred-xts get push ;
! To support saving compiled code to disk, generator words ! To support saving compiled code to disk, generator words
! append relocation instructions to this vector. ! append relocation instructions to this vector.
SYMBOL: relocation-table SYMBOL: relocation-table
@ -127,24 +133,11 @@ M: fixup-2/2 fixup ( addr fixup -- )
! when the vector is empty. ! when the vector is empty.
SYMBOL: compile-words SYMBOL: compile-words
! deferred-xts is a vector of objects responding to the fixup
! generic.
SYMBOL: deferred-xts
: deferred-xt deferred-xts get push ;
: compiling? ( word -- ? ) : compiling? ( word -- ? )
#! A word that is compiling or already compiled will not be #! A word that is compiling or already compiled will not be
#! added to the list of words to be compiled. #! added to the list of words to be compiled.
dup compiled? [ dup compiled? over compile-words get member? or
drop t [ drop t ] [ compiled-xts get hash ] if ;
] [
dup compile-words get member? [
drop t
] [
compiled-xts get hash
] if
] if ;
: fixup-xts ( -- ) : fixup-xts ( -- )
deferred-xts get [ fixup ] each deferred-xts off ; deferred-xts get [ fixup ] each deferred-xts off ;