Fix implementation of deferred words
parent
2a24567546
commit
c5d91d12df
|
@ -74,23 +74,27 @@ SYMBOL: jit-dispatch
|
|||
SYMBOL: jit-epilog
|
||||
SYMBOL: jit-return
|
||||
|
||||
! Default definition for undefined words
|
||||
SYMBOL: undefined-quot
|
||||
|
||||
: userenv-offset ( symbol -- n )
|
||||
{
|
||||
{ bootstrap-boot-quot 20 }
|
||||
{ bootstrap-global 21 }
|
||||
{ jit-code-format 22 }
|
||||
{ jit-prolog 24 }
|
||||
{ jit-word-primitive-jump 25 }
|
||||
{ jit-word-primitive-call 26 }
|
||||
{ jit-word-jump 27 }
|
||||
{ jit-word-call 28 }
|
||||
{ jit-push-literal 30 }
|
||||
{ jit-if-word 31 }
|
||||
{ jit-if-jump 32 }
|
||||
{ jit-dispatch-word 34 }
|
||||
{ jit-dispatch 35 }
|
||||
{ jit-epilog 36 }
|
||||
{ jit-return 37 }
|
||||
{ jit-prolog 23 }
|
||||
{ jit-word-primitive-jump 24 }
|
||||
{ jit-word-primitive-call 25 }
|
||||
{ jit-word-jump 26 }
|
||||
{ jit-word-call 27 }
|
||||
{ jit-push-literal 28 }
|
||||
{ jit-if-word 29 }
|
||||
{ jit-if-jump 30 }
|
||||
{ jit-dispatch-word 31 }
|
||||
{ jit-dispatch 32 }
|
||||
{ jit-epilog 33 }
|
||||
{ jit-return 34 }
|
||||
{ undefined-quot 37 }
|
||||
} at header-size + ;
|
||||
|
||||
: emit ( cell -- ) image get push ;
|
||||
|
@ -364,6 +368,7 @@ M: curry '
|
|||
: emit-jit-data ( -- )
|
||||
\ if jit-if-word set
|
||||
\ dispatch jit-dispatch-word set
|
||||
[ undefined ] undefined-quot set
|
||||
{
|
||||
jit-code-format
|
||||
jit-prolog
|
||||
|
@ -378,6 +383,7 @@ M: curry '
|
|||
jit-dispatch
|
||||
jit-epilog
|
||||
jit-return
|
||||
undefined-quot
|
||||
} [ emit-userenv ] each ;
|
||||
|
||||
: fixup-header ( -- )
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays generic assocs kernel math namespaces
|
||||
sequences tools.test words definitions parser quotations
|
||||
vocabs continuations ;
|
||||
vocabs continuations tuples ;
|
||||
IN: temporary
|
||||
|
||||
[ 4 ] [
|
||||
|
@ -34,7 +34,7 @@ DEFER: plist-test
|
|||
[
|
||||
[ t ] [ \ array? "array?" "arrays" lookup = ] unit-test
|
||||
|
||||
"test-scope" "scratchpad" create drop
|
||||
[ ] [ "test-scope" "scratchpad" create drop ] unit-test
|
||||
] with-scope
|
||||
|
||||
[ "test-scope" ] [
|
||||
|
@ -52,7 +52,7 @@ DEFER: plist-test
|
|||
[ t ] [ \ colon-def compound? ] unit-test
|
||||
|
||||
SYMBOL: a-symbol
|
||||
[ f ] [ \ a-symbol compound? ] unit-test
|
||||
[ t ] [ \ a-symbol compound? ] unit-test
|
||||
[ t ] [ \ a-symbol symbol? ] unit-test
|
||||
|
||||
! See if redefining a generic as a colon def clears some
|
||||
|
@ -126,7 +126,7 @@ M: array freakish ;
|
|||
[ t ] [ \ bar \ freakish usage member? ] unit-test
|
||||
|
||||
DEFER: x
|
||||
[ t ] [ [ x ] catch third \ x eq? ] unit-test
|
||||
[ t ] [ [ x ] catch undefined? ] unit-test
|
||||
|
||||
[ ] [ "no-loc" "temporary" create drop ] unit-test
|
||||
[ f ] [ "no-loc" "temporary" lookup where ] unit-test
|
||||
|
@ -156,3 +156,8 @@ SYMBOL: quot-uses-b
|
|||
] unit-test
|
||||
|
||||
[ { + } ] [ \ quot-uses-b uses ] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ "IN: temporary : undef-test ; << undef-test >>" eval ] catch
|
||||
[ undefined? ] is?
|
||||
] unit-test
|
||||
|
|
|
@ -25,15 +25,13 @@ M: compound definer drop \ : \ ; ;
|
|||
|
||||
M: compound definition word-def ;
|
||||
|
||||
TUPLE: undefined word ;
|
||||
TUPLE: undefined ;
|
||||
|
||||
: undefined ( word -- * ) \ undefined construct-boa throw ;
|
||||
: undefined ( -- * ) \ undefined construct-empty throw ;
|
||||
|
||||
PREDICATE: compound deferred ( obj -- ? )
|
||||
dup [ undefined ] curry swap word-def sequence= ;
|
||||
|
||||
word-def [ undefined ] = ;
|
||||
M: deferred definer drop \ DEFER: f ;
|
||||
|
||||
M: deferred definition drop f ;
|
||||
|
||||
PREDICATE: compound symbol ( obj -- ? )
|
||||
|
@ -110,9 +108,6 @@ PRIVATE>
|
|||
: define-compound ( word def -- )
|
||||
[ ] like define ;
|
||||
|
||||
: undefine ( word -- )
|
||||
dup [ undefined ] curry define-compound ;
|
||||
|
||||
: define-declared ( word def effect -- )
|
||||
pick swap "declared-effect" set-word-prop
|
||||
define-compound ;
|
||||
|
@ -144,11 +139,8 @@ PRIVATE>
|
|||
: reset-generic ( word -- )
|
||||
dup reset-word { "methods" "combination" } reset-props ;
|
||||
|
||||
: <uninterned> ( name -- word )
|
||||
f <word> dup undefine ;
|
||||
|
||||
: gensym ( -- word )
|
||||
"G:" \ gensym counter number>string append <uninterned> ;
|
||||
"G:" \ gensym counter number>string append f <word> ;
|
||||
|
||||
: define-temp ( quot -- word )
|
||||
gensym dup rot define-compound ;
|
||||
|
@ -165,7 +157,7 @@ TUPLE: check-create name vocab ;
|
|||
|
||||
: create ( name vocab -- word )
|
||||
check-create 2dup lookup
|
||||
dup [ 2nip ] [ drop <word> dup reveal dup undefine ] if ;
|
||||
dup [ 2nip ] [ drop <word> dup reveal ] if ;
|
||||
|
||||
: constructor-word ( name vocab -- word )
|
||||
>r "<" swap ">" 3append r> create ;
|
||||
|
|
|
@ -35,6 +35,8 @@ void do_stage1_init(void)
|
|||
fprintf(stderr,"*** Starting stage 2 early init...\n");
|
||||
fflush(stderr);
|
||||
|
||||
jit_compile(userenv[UNDEFINED_ENV]);
|
||||
|
||||
begin_scan();
|
||||
|
||||
CELL obj;
|
||||
|
|
8
vm/run.h
8
vm/run.h
|
@ -34,26 +34,22 @@ typedef enum {
|
|||
|
||||
/* Used by the JIT compiler */
|
||||
JIT_CODE_FORMAT = 22,
|
||||
UNUSED_0,
|
||||
JIT_PROLOG,
|
||||
JIT_WORD_PRIMITIVE_JUMP,
|
||||
JIT_WORD_PRIMITIVE_CALL,
|
||||
JIT_WORD_JUMP,
|
||||
JIT_WORD_CALL,
|
||||
UNUSED_1,
|
||||
JIT_PUSH_LITERAL,
|
||||
JIT_IF_WORD,
|
||||
JIT_IF_JUMP,
|
||||
UNUSED_2,
|
||||
JIT_DISPATCH_WORD,
|
||||
JIT_DISPATCH,
|
||||
JIT_EPILOG,
|
||||
JIT_RETURN,
|
||||
|
||||
/* Profiler support */
|
||||
UNDEFINED_ENV = 37, /* default quotation for undefined words */
|
||||
PROFILING_ENV = 38, /* is the profiler on? */
|
||||
|
||||
STAGE2_ENV = 39 /* Have we bootstrapped? */
|
||||
STAGE2_ENV = 39 /* have we bootstrapped? */
|
||||
} F_ENVTYPE;
|
||||
|
||||
#define FIRST_SAVE_ENV BOOT_ENV
|
||||
|
|
|
@ -495,11 +495,11 @@ F_WORD *allot_word(CELL vocab, CELL name)
|
|||
word->hashcode = tag_fixnum(rand());
|
||||
word->vocabulary = vocab;
|
||||
word->name = name;
|
||||
word->def = F;
|
||||
word->def = userenv[UNDEFINED_ENV];
|
||||
word->props = F;
|
||||
word->counter = tag_fixnum(0);
|
||||
word->compiledp = F;
|
||||
word->xt = NULL;
|
||||
default_word_xt(word);
|
||||
return word;
|
||||
}
|
||||
|
||||
|
|
Loading…
Reference in New Issue