renaming word-parameter to word-def; renaming word-property to word-prop
Slava Pestov
parent
76efdb2f1d
commit
f0dfb77690
|
|
@ -6,6 +6,13 @@
|
|||
|
||||
+ ui:
|
||||
|
||||
- resizing a gadget should probably relayout children
|
||||
- when halo is shown, rollovers don't disappear
|
||||
- halo outline should be the clipped rect
|
||||
- sometimes releasing moving gadget doesn't work
|
||||
- after moving halo, halo is underneath the gadget
|
||||
- resizing: drag relative to initial click pos
|
||||
- thumb gadgetry breaks with halo sometimes
|
||||
- mouse enter onto overlapping with interior, but not child, gadget
|
||||
- menu dragging
|
||||
- scrollable inspector
|
||||
|
|
@ -17,7 +24,6 @@
|
|||
- console: scroll to bottom
|
||||
- split preferred size and layouting
|
||||
- remove shelf/pile duplication
|
||||
- resizing gadgets
|
||||
- faster layout
|
||||
- faster repaint
|
||||
- closing inspectors
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ vocabularies get [
|
|||
|
||||
"syntax" get [
|
||||
cdr dup word? [
|
||||
"syntax" "vocabulary" set-word-property
|
||||
"syntax" "vocabulary" set-word-prop
|
||||
] [
|
||||
drop
|
||||
] ifte
|
||||
|
|
|
|||
|
|
@ -191,7 +191,7 @@ M: f ' ( obj -- ptr )
|
|||
dup hashcode fixnum-tag immediate ,
|
||||
0 ,
|
||||
dup word-primitive ,
|
||||
dup word-parameter ' ,
|
||||
dup word-def ' ,
|
||||
dup word-props ' ,
|
||||
0 ,
|
||||
0 ,
|
||||
|
|
|
|||
|
|
@ -198,8 +198,8 @@ vocabularies get [
|
|||
] [
|
||||
3unlist >r create >r 1 + r> 2dup swap f define r>
|
||||
dup string? [
|
||||
"stack-effect" set-word-property
|
||||
"stack-effect" set-word-prop
|
||||
] [
|
||||
"infer-effect" set-word-property
|
||||
"infer-effect" set-word-prop
|
||||
] ifte
|
||||
] each drop
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@ SYMBOL: alien-parameters
|
|||
r> swap [ drop ] [ #cleanup swons , ] ifte
|
||||
linearize-returns ;
|
||||
|
||||
#alien-invoke [ linearize-alien ] "linearizer" set-word-property
|
||||
#alien-invoke [ linearize-alien ] "linearizer" set-word-prop
|
||||
|
||||
: alien-invoke ( ... returns library function parameters -- ... )
|
||||
#! Call a C library function.
|
||||
|
|
@ -140,9 +140,9 @@ SYMBOL: alien-parameters
|
|||
] make-string throw ;
|
||||
|
||||
\ alien-invoke [ [ object object object object ] [ ] ]
|
||||
"infer-effect" set-word-property
|
||||
"infer-effect" set-word-prop
|
||||
|
||||
\ alien-invoke [ infer-alien ] "infer" set-word-property
|
||||
\ alien-invoke [ infer-alien ] "infer" set-word-prop
|
||||
|
||||
global [
|
||||
"libraries" get [ <namespace> "libraries" set ] unless
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ USE: test
|
|||
"verbose-compile" get [
|
||||
"Compiling " write dup . flush
|
||||
] when
|
||||
dup word-parameter ;
|
||||
dup word-def ;
|
||||
|
||||
GENERIC: (compile) ( word -- )
|
||||
|
||||
|
|
@ -69,7 +69,7 @@ M: compound (compile) ( word -- )
|
|||
: precompile ( word -- )
|
||||
#! Print linear IR of word.
|
||||
[
|
||||
word-parameter dataflow optimize linearize simplify [.]
|
||||
word-def dataflow optimize linearize simplify [.]
|
||||
] with-scope ;
|
||||
|
||||
: compile-postponed ( -- )
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ SYMBOL: relocation-table
|
|||
|
||||
: generate-node ( [[ op params ]] -- )
|
||||
#! Generate machine code for a node.
|
||||
unswons dup "generator" word-property [
|
||||
unswons dup "generator" word-prop [
|
||||
call
|
||||
] [
|
||||
"No generator" throw
|
||||
|
|
@ -76,9 +76,9 @@ SYMBOL: previous-offset
|
|||
] when*
|
||||
] catch ;
|
||||
|
||||
#label [ save-xt ] "generator" set-word-property
|
||||
#label [ save-xt ] "generator" set-word-prop
|
||||
|
||||
#end-dispatch [ drop ] "generator" set-word-property
|
||||
#end-dispatch [ drop ] "generator" set-word-prop
|
||||
|
||||
: type-tag ( type -- tag )
|
||||
#! Given a type number, return the tag number.
|
||||
|
|
|
|||
|
|
@ -62,13 +62,13 @@ SYMBOL: #end-dispatch
|
|||
[ node-param get ] bind
|
||||
dup immediate? #push-immediate #push-indirect ?
|
||||
swons ,
|
||||
] "linearizer" set-word-property
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
: <label> ( -- label )
|
||||
gensym dup t "label" set-word-property ;
|
||||
gensym dup t "label" set-word-prop ;
|
||||
|
||||
: label? ( obj -- ? )
|
||||
dup word? [ "label" word-property ] [ drop f ] ifte ;
|
||||
dup word? [ "label" word-prop ] [ drop f ] ifte ;
|
||||
|
||||
: label, ( label -- )
|
||||
#label swons , ;
|
||||
|
|
@ -81,7 +81,7 @@ SYMBOL: #end-dispatch
|
|||
|
||||
#simple-label [
|
||||
linearize-simple-label
|
||||
] "linearizer" set-word-property
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
: linearize-label ( node -- )
|
||||
#! Labels are tricky, because they might contain non-tail
|
||||
|
|
@ -97,7 +97,7 @@ SYMBOL: #end-dispatch
|
|||
|
||||
#label [
|
||||
linearize-label
|
||||
] "linearizer" set-word-property
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
: linearize-ifte ( param -- )
|
||||
#! The parameter is a list of two lists, each one a dataflow
|
||||
|
|
@ -112,7 +112,7 @@ SYMBOL: #end-dispatch
|
|||
|
||||
\ ifte [
|
||||
[ node-param get ] bind linearize-ifte
|
||||
] "linearizer" set-word-property
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
: dispatch-head ( vtable -- end label/code )
|
||||
#! Output the jump table insn and return a list of
|
||||
|
|
@ -133,6 +133,6 @@ SYMBOL: #end-dispatch
|
|||
|
||||
\ dispatch [
|
||||
[ node-param get ] bind linearize-dispatch
|
||||
] "linearizer" set-word-property
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
#values [ drop ] "linearizer" set-word-property
|
||||
#values [ drop ] "linearizer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -131,43 +131,43 @@ SYMBOL: branch-returns
|
|||
node-param [ [ dupd kill-nodes ] map nip ] change
|
||||
] extend , ;
|
||||
|
||||
#push [ [ node-param get ] bind , ] "scan-literal" set-word-property
|
||||
#push [ consumes-literal? not ] "can-kill" set-word-property
|
||||
#push [ kill-node ] "kill-node" set-word-property
|
||||
#push [ [ node-param get ] bind , ] "scan-literal" set-word-prop
|
||||
#push [ consumes-literal? not ] "can-kill" set-word-prop
|
||||
#push [ kill-node ] "kill-node" set-word-prop
|
||||
|
||||
#label [
|
||||
[ node-param get ] bind (scan-literals)
|
||||
] "scan-literal" set-word-property
|
||||
] "scan-literal" set-word-prop
|
||||
|
||||
#label [
|
||||
[ node-param get ] bind can-kill?
|
||||
] "can-kill" set-word-property
|
||||
] "can-kill" set-word-prop
|
||||
|
||||
#call-label [
|
||||
[ node-param get ] bind =
|
||||
] "calls-label" set-word-property
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
: calls-label? ( label list -- ? )
|
||||
[ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
|
||||
|
||||
#label [
|
||||
[ node-param get ] bind calls-label?
|
||||
] "calls-label" set-word-property
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
#simple-label [
|
||||
[ node-param get ] bind calls-label?
|
||||
] "calls-label" set-word-property
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
: branches-call-label? ( label list -- ? )
|
||||
[ calls-label? ] some-with? ;
|
||||
|
||||
\ ifte [
|
||||
[ node-param get ] bind branches-call-label?
|
||||
] "calls-label" set-word-property
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
\ dispatch [
|
||||
[ node-param get ] bind branches-call-label?
|
||||
] "calls-label" set-word-property
|
||||
] "calls-label" set-word-prop
|
||||
|
||||
: optimize-label ( -- op )
|
||||
#! Does the label node contain calls to itself?
|
||||
|
|
@ -179,7 +179,7 @@ SYMBOL: branch-returns
|
|||
optimize-label node-op set
|
||||
node-param [ kill-nodes ] change
|
||||
] extend ,
|
||||
] "kill-node" set-word-property
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
#values [
|
||||
dupd consumes-literal? [
|
||||
|
|
@ -187,25 +187,25 @@ SYMBOL: branch-returns
|
|||
] [
|
||||
drop t
|
||||
] ifte
|
||||
] "can-kill" set-word-property
|
||||
] "can-kill" set-word-prop
|
||||
|
||||
\ ifte [ scan-branches ] "scan-literal" set-word-property
|
||||
\ ifte [ can-kill-branches? ] "can-kill" set-word-property
|
||||
\ ifte [ kill-branches ] "kill-node" set-word-property
|
||||
\ ifte [ scan-branches ] "scan-literal" set-word-prop
|
||||
\ ifte [ can-kill-branches? ] "can-kill" set-word-prop
|
||||
\ ifte [ kill-branches ] "kill-node" set-word-prop
|
||||
|
||||
\ dispatch [ scan-branches ] "scan-literal" set-word-property
|
||||
\ dispatch [ can-kill-branches? ] "can-kill" set-word-property
|
||||
\ dispatch [ kill-branches ] "kill-node" set-word-property
|
||||
\ dispatch [ scan-branches ] "scan-literal" set-word-prop
|
||||
\ dispatch [ can-kill-branches? ] "can-kill" set-word-prop
|
||||
\ dispatch [ kill-branches ] "kill-node" set-word-prop
|
||||
|
||||
! Don't care about inputs to recursive combinator calls
|
||||
#call-label [ 2drop t ] "can-kill" set-word-property
|
||||
#call-label [ 2drop t ] "can-kill" set-word-prop
|
||||
|
||||
\ drop [ 2drop t ] "can-kill" set-word-property
|
||||
\ drop [ kill-node ] "kill-node" set-word-property
|
||||
\ dup [ 2drop t ] "can-kill" set-word-property
|
||||
\ dup [ kill-node ] "kill-node" set-word-property
|
||||
\ swap [ 2drop t ] "can-kill" set-word-property
|
||||
\ swap [ kill-node ] "kill-node" set-word-property
|
||||
\ drop [ 2drop t ] "can-kill" set-word-prop
|
||||
\ drop [ kill-node ] "kill-node" set-word-prop
|
||||
\ dup [ 2drop t ] "can-kill" set-word-prop
|
||||
\ dup [ kill-node ] "kill-node" set-word-prop
|
||||
\ swap [ 2drop t ] "can-kill" set-word-prop
|
||||
\ swap [ kill-node ] "kill-node" set-word-prop
|
||||
|
||||
: kill-mask ( killing inputs -- mask )
|
||||
[ over [ over value= ] some? >boolean nip ] map nip ;
|
||||
|
|
@ -219,15 +219,15 @@ SYMBOL: branch-returns
|
|||
] keep
|
||||
over [ [ node-op set ] extend , ] [ 2drop ] ifte ;
|
||||
|
||||
\ over [ 2drop t ] "can-kill" set-word-property
|
||||
\ over [ 2drop t ] "can-kill" set-word-prop
|
||||
\ over [
|
||||
[
|
||||
[[ [ f f ] over ]]
|
||||
[[ [ f t ] dup ]]
|
||||
] reduce-stack-op
|
||||
] "kill-node" set-word-property
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
\ pick [ 2drop t ] "can-kill" set-word-property
|
||||
\ pick [ 2drop t ] "can-kill" set-word-prop
|
||||
\ pick [
|
||||
[
|
||||
[[ [ f f f ] pick ]]
|
||||
|
|
@ -235,9 +235,9 @@ SYMBOL: branch-returns
|
|||
[[ [ f t f ] over ]]
|
||||
[[ [ f t t ] dup ]]
|
||||
] reduce-stack-op
|
||||
] "kill-node" set-word-property
|
||||
] "kill-node" set-word-prop
|
||||
|
||||
\ >r [ 2drop t ] "can-kill" set-word-property
|
||||
\ >r [ kill-node ] "kill-node" set-word-property
|
||||
\ r> [ 2drop t ] "can-kill" set-word-property
|
||||
\ r> [ kill-node ] "kill-node" set-word-property
|
||||
\ >r [ 2drop t ] "can-kill" set-word-prop
|
||||
\ >r [ kill-node ] "kill-node" set-word-prop
|
||||
\ r> [ 2drop t ] "can-kill" set-word-prop
|
||||
\ r> [ kill-node ] "kill-node" set-word-prop
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ SYMBOL: simplifying
|
|||
#! A list of quotations with stack effect
|
||||
#! ( linear -- linear ? ) that can simplify the first node
|
||||
#! in the linear IR.
|
||||
car car "simplifiers" word-property ;
|
||||
car car "simplifiers" word-prop ;
|
||||
|
||||
: simplify-node ( linear list -- linear ? )
|
||||
dup [
|
||||
|
|
@ -45,7 +45,7 @@ SYMBOL: simplifying
|
|||
dup car cdr simplifying get label-called?
|
||||
[ f ] [ cdr t ] ifte
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
] "simplifiers" set-word-prop
|
||||
|
||||
: next-physical? ( op linear -- ? )
|
||||
cdr dup [ car car = ] [ 2drop f ] ifte ;
|
||||
|
|
@ -55,10 +55,10 @@ SYMBOL: simplifying
|
|||
#! its param.
|
||||
over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
|
||||
|
||||
\ >r [ [ \ r> cancel nip ] ] "simplifiers" set-word-property
|
||||
\ r> [ [ \ >r cancel nip ] ] "simplifiers" set-word-property
|
||||
\ dup [ [ \ drop cancel nip ] ] "simplifiers" set-word-property
|
||||
\ swap [ [ \ swap cancel nip ] ] "simplifiers" set-word-property
|
||||
\ >r [ [ \ r> cancel nip ] ] "simplifiers" set-word-prop
|
||||
\ r> [ [ \ >r cancel nip ] ] "simplifiers" set-word-prop
|
||||
\ dup [ [ \ drop cancel nip ] ] "simplifiers" set-word-prop
|
||||
\ swap [ [ \ swap cancel nip ] ] "simplifiers" set-word-prop
|
||||
|
||||
\ drop [
|
||||
[
|
||||
|
|
@ -70,7 +70,7 @@ SYMBOL: simplifying
|
|||
#replace-indirect swons swons t
|
||||
] when
|
||||
]
|
||||
] "simplifiers" set-word-property
|
||||
] "simplifiers" set-word-prop
|
||||
|
||||
: find-label ( label -- rest )
|
||||
simplifying get [
|
||||
|
|
@ -78,19 +78,19 @@ SYMBOL: simplifying
|
|||
] some? nip ;
|
||||
|
||||
: next-logical ( linear -- linear )
|
||||
dup car car "next-logical" word-property call ;
|
||||
dup car car "next-logical" word-prop call ;
|
||||
|
||||
#label [
|
||||
cdr next-logical
|
||||
] "next-logical" set-word-property
|
||||
] "next-logical" set-word-prop
|
||||
|
||||
#jump-label [
|
||||
car cdr find-label cdr
|
||||
] "next-logical" set-word-property
|
||||
] "next-logical" set-word-prop
|
||||
|
||||
#target-label [
|
||||
car cdr find-label cdr
|
||||
] "next-logical" set-word-property
|
||||
] "next-logical" set-word-prop
|
||||
|
||||
: next-logical? ( op linear -- ? )
|
||||
next-logical dup [ car car = ] [ 2drop f ] ifte ;
|
||||
|
|
@ -104,11 +104,11 @@ SYMBOL: simplifying
|
|||
|
||||
#call [
|
||||
[ #return #jump reduce ]
|
||||
] "simplifiers" set-word-property
|
||||
] "simplifiers" set-word-prop
|
||||
|
||||
#call-label [
|
||||
[ #return #jump-label reduce ]
|
||||
] "simplifiers" set-word-property
|
||||
] "simplifiers" set-word-prop
|
||||
|
||||
: double-jump ( linear op1 op2 -- linear ? )
|
||||
#! A jump to a jump is just a jump. If the next logical node
|
||||
|
|
@ -145,13 +145,13 @@ SYMBOL: simplifying
|
|||
[ #jump #jump double-jump ]
|
||||
[ useless-jump ]
|
||||
[ dead-code ]
|
||||
] "simplifiers" set-word-property
|
||||
] "simplifiers" set-word-prop
|
||||
|
||||
#target-label [
|
||||
[ #jump-label #target-label double-jump ]
|
||||
[ #jump #target double-jump ]
|
||||
] "simplifiers" set-word-property
|
||||
] "simplifiers" set-word-prop
|
||||
|
||||
#jump [ [ dead-code ] ] "simplifiers" set-word-property
|
||||
#return [ [ dead-code ] ] "simplifiers" set-word-property
|
||||
#end-dispatch [ [ dead-code ] ] "simplifiers" set-word-property
|
||||
#jump [ [ dead-code ] ] "simplifiers" set-word-prop
|
||||
#return [ [ dead-code ] ] "simplifiers" set-word-prop
|
||||
#end-dispatch [ [ dead-code ] ] "simplifiers" set-word-prop
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ GENERIC: displacement ( op -- )
|
|||
( Register operands -- eg, ECX )
|
||||
: REGISTER:
|
||||
CREATE dup define-symbol
|
||||
scan-word "register" set-word-property ; parsing
|
||||
scan-word "register" set-word-prop ; parsing
|
||||
|
||||
REGISTER: EAX 0
|
||||
REGISTER: ECX 1
|
||||
|
|
@ -98,10 +98,10 @@ REGISTER: EBP 5
|
|||
REGISTER: ESI 6
|
||||
REGISTER: EDI 7
|
||||
|
||||
PREDICATE: word register "register" word-property ;
|
||||
PREDICATE: word register "register" word-prop ;
|
||||
|
||||
M: register modifier drop BIN: 11 ;
|
||||
M: register register "register" word-property ;
|
||||
M: register register "register" word-prop ;
|
||||
M: register displacement drop ;
|
||||
|
||||
( Indirect register operands -- eg, [ ECX ] )
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ USE: math-internals
|
|||
! prototype to test the assembler.
|
||||
|
||||
: self ( word -- )
|
||||
f swap dup "infer-effect" word-property (consume/produce) ;
|
||||
f swap dup "infer-effect" word-prop (consume/produce) ;
|
||||
|
||||
: fixnum-insn ( overflow opcode -- )
|
||||
#! This needs to be factored.
|
||||
|
|
@ -59,15 +59,15 @@ USE: math-internals
|
|||
|
||||
\ fixnum+ [
|
||||
drop \ fixnum+ \ ADD fixnum-insn
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ fixnum+ [ \ fixnum+ self ] "infer" set-word-property
|
||||
\ fixnum+ [ \ fixnum+ self ] "infer" set-word-prop
|
||||
|
||||
\ fixnum- [
|
||||
drop \ fixnum- \ SUB fixnum-insn
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ fixnum- [ \ fixnum- self ] "infer" set-word-property
|
||||
\ fixnum- [ \ fixnum- self ] "infer" set-word-prop
|
||||
|
||||
\ fixnum* [
|
||||
drop
|
||||
|
|
@ -81,9 +81,9 @@ USE: math-internals
|
|||
ESI 4 SUB
|
||||
[ ESI ] EAX MOV
|
||||
r> compiled-offset swap patch
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ fixnum* [ \ fixnum* self ] "infer" set-word-property
|
||||
\ fixnum* [ \ fixnum* self ] "infer" set-word-prop
|
||||
|
||||
\ fixnum/i [
|
||||
drop
|
||||
|
|
@ -98,9 +98,9 @@ USE: math-internals
|
|||
ESI 4 SUB
|
||||
[ ESI ] EAX MOV
|
||||
r> compiled-offset swap patch
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ fixnum/i [ \ fixnum/i self ] "infer" set-word-property
|
||||
\ fixnum/i [ \ fixnum/i self ] "infer" set-word-prop
|
||||
|
||||
\ fixnum-mod [
|
||||
drop
|
||||
|
|
@ -115,9 +115,9 @@ USE: math-internals
|
|||
ESI 4 SUB
|
||||
[ ESI ] EDX MOV
|
||||
r> compiled-offset swap patch
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ fixnum-mod [ \ fixnum-mod self ] "infer" set-word-property
|
||||
\ fixnum-mod [ \ fixnum-mod self ] "infer" set-word-prop
|
||||
|
||||
\ fixnum/mod [
|
||||
drop
|
||||
|
|
@ -132,9 +132,9 @@ USE: math-internals
|
|||
[ ESI -4 ] EAX MOV
|
||||
[ ESI ] EDX MOV
|
||||
r> compiled-offset swap patch
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-property
|
||||
\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-prop
|
||||
|
||||
\ arithmetic-type [
|
||||
drop
|
||||
|
|
@ -150,6 +150,6 @@ USE: math-internals
|
|||
EAX 3 SHL
|
||||
PUSH-DS
|
||||
compiled-offset swap patch
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ arithmetic-type [ \ arithmetic-type self ] "infer" set-word-property
|
||||
\ arithmetic-type [ \ arithmetic-type self ] "infer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ math memory namespaces words ;
|
|||
PEEK-DS
|
||||
2unlist type-tag >r cell * r> - EAX swap 2list EAX swap MOV
|
||||
[ ESI ] EAX MOV
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
: compile-call-label ( label -- )
|
||||
0 CALL fixup compiled-offset defer-xt ;
|
||||
|
|
@ -24,21 +24,21 @@ math memory namespaces words ;
|
|||
|
||||
#call [
|
||||
compile-call
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#jump [
|
||||
dup dup postpone-word
|
||||
compile-jump-label
|
||||
t rel-word
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#call-label [
|
||||
compile-call-label
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#jump-label [
|
||||
compile-jump-label
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
: compile-jump-t ( word -- )
|
||||
POP-DS
|
||||
|
|
@ -49,11 +49,11 @@ math memory namespaces words ;
|
|||
|
||||
#jump-t-label [
|
||||
compile-jump-t
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#jump-t [
|
||||
dup compile-jump-t t rel-word
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
: compile-jump-f ( word -- )
|
||||
POP-DS
|
||||
|
|
@ -64,17 +64,17 @@ math memory namespaces words ;
|
|||
|
||||
#jump-f-label [
|
||||
compile-jump-f
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#jump-f [
|
||||
dup compile-jump-f t rel-word
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#return-to [
|
||||
0 PUSH fixup 0 defer-xt rel-address
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#return [ drop RET ] "generator" set-word-property
|
||||
#return [ drop RET ] "generator" set-word-prop
|
||||
|
||||
\ dispatch [
|
||||
#! Compile a piece of code that jumps to an offset in a
|
||||
|
|
@ -87,33 +87,33 @@ math memory namespaces words ;
|
|||
[ EAX ] JMP
|
||||
compile-aligned
|
||||
compiled-offset swap set-compiled-cell ( fixup -- )
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#target-label [
|
||||
#! Jump table entries are absolute addresses.
|
||||
compile-target rel-address
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#target [
|
||||
#! Jump table entries are absolute addresses.
|
||||
dup dup postpone-word compile-target f rel-word
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#c-call [
|
||||
uncons load-dll 2dup dlsym CALL t rel-dlsym
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#unbox [
|
||||
dup f dlsym CALL f t rel-dlsym
|
||||
EAX PUSH
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#box [
|
||||
EAX PUSH
|
||||
dup f dlsym CALL f t rel-dlsym
|
||||
ESP 4 ADD
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#cleanup [
|
||||
dup 0 = [ drop ] [ ESP swap ADD ] ifte
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
|
|
|||
|
|
@ -52,32 +52,32 @@ USING: inference kernel assembler words lists alien memory ;
|
|||
#push-immediate [
|
||||
ESI 4 ADD
|
||||
immediate-literal
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#push-indirect [
|
||||
indirect-literal
|
||||
PUSH-DS
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#replace-immediate [
|
||||
immediate-literal
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
#replace-indirect [
|
||||
indirect-literal
|
||||
[ ESI ] EAX MOV
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ drop [
|
||||
drop
|
||||
ESI 4 SUB
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ dup [
|
||||
drop
|
||||
PEEK-DS
|
||||
PUSH-DS
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ swap [
|
||||
drop
|
||||
|
|
@ -85,29 +85,29 @@ USING: inference kernel assembler words lists alien memory ;
|
|||
EDX [ ESI -4 ] MOV
|
||||
[ ESI ] EDX MOV
|
||||
[ ESI -4 ] EAX MOV
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ over [
|
||||
drop
|
||||
EAX [ ESI -4 ] MOV
|
||||
PUSH-DS
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ pick [
|
||||
drop
|
||||
EAX [ ESI -8 ] MOV
|
||||
PUSH-DS
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ >r [
|
||||
drop
|
||||
POP-DS
|
||||
ECX CS>
|
||||
PUSH-CS
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ r> [
|
||||
drop
|
||||
POP-CS
|
||||
PUSH-DS
|
||||
] "generator" set-word-property
|
||||
] "generator" set-word-prop
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ SYMBOL: compiled-xts
|
|||
compiled-offset swap compiled-xts [ acons ] change ;
|
||||
|
||||
: commit-xt ( xt word -- )
|
||||
dup t "compiled" set-word-property set-word-xt ;
|
||||
dup t "compiled" set-word-prop set-word-xt ;
|
||||
|
||||
: commit-xts ( -- )
|
||||
compiled-xts get [ unswons commit-xt ] each
|
||||
|
|
|
|||
|
|
@ -8,32 +8,32 @@ words vectors ;
|
|||
SYMBOL: builtin
|
||||
|
||||
builtin [
|
||||
"builtin-type" word-property unit
|
||||
] "builtin-supertypes" set-word-property
|
||||
"builtin-type" word-prop unit
|
||||
] "builtin-supertypes" set-word-prop
|
||||
|
||||
builtin [
|
||||
( generic vtable definition class -- )
|
||||
rot set-vtable drop
|
||||
] "add-method" set-word-property
|
||||
] "add-method" set-word-prop
|
||||
|
||||
builtin 50 "priority" set-word-property
|
||||
builtin 50 "priority" set-word-prop
|
||||
|
||||
! All builtin types are equivalent in ordering
|
||||
builtin [ 2drop t ] "class<" set-word-property
|
||||
builtin [ 2drop t ] "class<" set-word-prop
|
||||
|
||||
: builtin-predicate ( type# symbol -- )
|
||||
#! We call search here because we have to know if the symbol
|
||||
#! is t or f, and cannot compare type numbers or symbol
|
||||
#! identity during bootstrapping.
|
||||
dup "f" [ "syntax" ] search = [
|
||||
nip [ not ] "predicate" set-word-property
|
||||
nip [ not ] "predicate" set-word-prop
|
||||
] [
|
||||
dup "t" [ "syntax" ] search = [
|
||||
nip [ ] "predicate" set-word-property
|
||||
nip [ ] "predicate" set-word-prop
|
||||
] [
|
||||
dup predicate-word
|
||||
[ rot [ swap type eq? ] cons define-compound ] keep
|
||||
unit "predicate" set-word-property
|
||||
unit "predicate" set-word-prop
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
|
|
@ -41,7 +41,7 @@ builtin [ 2drop t ] "class<" set-word-property
|
|||
>r swap
|
||||
dup intern-symbol
|
||||
2dup builtin-predicate
|
||||
[ swap "builtin-type" set-word-property ] keep
|
||||
[ swap "builtin-type" set-word-prop ] keep
|
||||
dup builtin define-class r> define-slots ;
|
||||
|
||||
: builtin-type ( n -- symbol )
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ vectors words ;
|
|||
SYMBOL: complement
|
||||
|
||||
complement [
|
||||
"complement" word-property builtin-supertypes
|
||||
"complement" word-prop builtin-supertypes
|
||||
num-types count
|
||||
difference
|
||||
] "builtin-supertypes" set-word-property
|
||||
] "builtin-supertypes" set-word-prop
|
||||
|
||||
complement [
|
||||
( generic vtable definition class -- )
|
||||
|
|
@ -22,20 +22,20 @@ complement [
|
|||
dup [ add-method ] [ 2drop 2drop ] ifte
|
||||
] keep
|
||||
] repeat 3drop
|
||||
] "add-method" set-word-property
|
||||
] "add-method" set-word-prop
|
||||
|
||||
complement 90 "priority" set-word-property
|
||||
complement 90 "priority" set-word-prop
|
||||
|
||||
complement [
|
||||
swap "complement" word-property
|
||||
swap "complement" word-property
|
||||
swap "complement" word-prop
|
||||
swap "complement" word-prop
|
||||
class< not
|
||||
] "class<" set-word-property
|
||||
] "class<" set-word-prop
|
||||
|
||||
: complement-predicate ( complement -- list )
|
||||
"predicate" word-property [ not ] append ;
|
||||
"predicate" word-prop [ not ] append ;
|
||||
|
||||
: define-complement ( class complement -- )
|
||||
2dup "complement" set-word-property
|
||||
dupd complement-predicate "predicate" set-word-property
|
||||
2dup "complement" set-word-prop
|
||||
dupd complement-predicate "predicate" set-word-prop
|
||||
complement define-class ;
|
||||
|
|
|
|||
|
|
@ -23,33 +23,33 @@ namespaces parser strings words vectors math math-internals ;
|
|||
! methods are added to the vtable.
|
||||
|
||||
: metaclass ( class -- metaclass )
|
||||
"metaclass" word-property ;
|
||||
"metaclass" word-prop ;
|
||||
|
||||
: builtin-supertypes ( class -- list )
|
||||
#! A list of builtin supertypes of the class.
|
||||
dup metaclass "builtin-supertypes" word-property call ;
|
||||
dup metaclass "builtin-supertypes" word-prop call ;
|
||||
|
||||
: set-vtable ( definition class vtable -- )
|
||||
>r "builtin-type" word-property r> set-vector-nth ;
|
||||
>r "builtin-type" word-prop r> set-vector-nth ;
|
||||
|
||||
: class-ord ( class -- n ) metaclass "priority" word-property ;
|
||||
: class-ord ( class -- n ) metaclass "priority" word-prop ;
|
||||
|
||||
: class< ( cls1 cls2 -- ? )
|
||||
#! Test if class1 is a subclass of class2.
|
||||
over metaclass over metaclass = [
|
||||
dup metaclass "class<" word-property call
|
||||
dup metaclass "class<" word-prop call
|
||||
] [
|
||||
swap class-ord swap class-ord <
|
||||
] ifte ;
|
||||
|
||||
: methods ( generic -- alist )
|
||||
"methods" word-property hash>alist [ 2car class< ] sort ;
|
||||
"methods" word-prop hash>alist [ 2car class< ] sort ;
|
||||
|
||||
: add-method ( generic vtable definition class -- )
|
||||
#! Add the method entry to the vtable. Unlike define-method,
|
||||
#! this is called at vtable build time, and in the sorted
|
||||
#! order.
|
||||
dup metaclass "add-method" word-property [
|
||||
dup metaclass "add-method" word-prop [
|
||||
[ "Metaclass is missing add-method" throw ]
|
||||
] unless* call ;
|
||||
|
||||
|
|
@ -65,18 +65,20 @@ namespaces parser strings words vectors math math-internals ;
|
|||
] each nip ;
|
||||
|
||||
: make-generic ( word vtable -- )
|
||||
over "combination" word-property cons define-compound ;
|
||||
#! (define-compound) is used to avoid resetting generic
|
||||
#! word properties.
|
||||
over "combination" word-prop cons (define-compound) ;
|
||||
|
||||
: define-method ( class generic definition -- )
|
||||
-rot
|
||||
[ "methods" word-property set-hash ] keep dup <vtable>
|
||||
[ "methods" word-prop set-hash ] keep dup <vtable>
|
||||
make-generic ;
|
||||
|
||||
: init-methods ( word -- )
|
||||
dup "methods" word-property [
|
||||
dup "methods" word-prop [
|
||||
drop
|
||||
] [
|
||||
<namespace> "methods" set-word-property
|
||||
<namespace> "methods" set-word-prop
|
||||
] ifte ;
|
||||
|
||||
! Defining generic words
|
||||
|
|
@ -84,8 +86,8 @@ namespaces parser strings words vectors math math-internals ;
|
|||
#! Takes a combination parameter. A combination is a
|
||||
#! quotation that takes some objects and a vtable from the
|
||||
#! stack, and calls the appropriate row of the vtable.
|
||||
[ swap "definer" set-word-property ] keep
|
||||
[ swap "combination" set-word-property ] keep
|
||||
[ swap "definer" set-word-prop ] keep
|
||||
[ swap "combination" set-word-prop ] keep
|
||||
dup init-methods
|
||||
dup <vtable> make-generic ;
|
||||
|
||||
|
|
@ -93,7 +95,7 @@ namespaces parser strings words vectors math math-internals ;
|
|||
>r dup type r> dispatch ; inline
|
||||
|
||||
PREDICATE: compound generic ( word -- ? )
|
||||
"combination" word-property [ single-combination ] = ;
|
||||
"combination" word-prop [ single-combination ] = ;
|
||||
|
||||
: arithmetic-combination ( n n vtable -- )
|
||||
#! Note that the numbers remain on the stack, possibly after
|
||||
|
|
@ -101,7 +103,7 @@ PREDICATE: compound generic ( word -- ? )
|
|||
>r arithmetic-type r> dispatch ; inline
|
||||
|
||||
PREDICATE: compound 2generic ( word -- ? )
|
||||
"combination" word-property [ arithmetic-combination ] = ;
|
||||
"combination" word-prop [ arithmetic-combination ] = ;
|
||||
|
||||
! Maps lists of builtin type numbers to class objects.
|
||||
SYMBOL: classes
|
||||
|
|
@ -134,7 +136,7 @@ SYMBOL: object
|
|||
intersection lookup-union ;
|
||||
|
||||
: define-class ( class metaclass -- )
|
||||
dupd "metaclass" set-word-property
|
||||
dupd "metaclass" set-word-prop
|
||||
dup builtin-supertypes [ > ] sort
|
||||
classes get set-hash ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@ USING: kernel words ;
|
|||
|
||||
! Null metaclass with no instances.
|
||||
SYMBOL: null
|
||||
null [ drop [ ] ] "builtin-supertypes" set-word-property
|
||||
null [ 2drop 2drop ] "add-method" set-word-property
|
||||
null [ drop f ] "predicate" set-word-property
|
||||
null 100 "priority" set-word-property
|
||||
null [ 2drop t ] "class<" set-word-property
|
||||
null [ drop [ ] ] "builtin-supertypes" set-word-prop
|
||||
null [ 2drop 2drop ] "add-method" set-word-prop
|
||||
null [ drop f ] "predicate" set-word-prop
|
||||
null 100 "priority" set-word-prop
|
||||
null [ 2drop t ] "class<" set-word-prop
|
||||
null null define-class
|
||||
|
|
|
|||
|
|
@ -8,19 +8,19 @@ SYMBOL: object
|
|||
|
||||
object [
|
||||
drop num-types count
|
||||
] "builtin-supertypes" set-word-property
|
||||
] "builtin-supertypes" set-word-prop
|
||||
|
||||
object [
|
||||
( generic vtable definition class -- )
|
||||
drop over vector-length [
|
||||
3dup rot set-vector-nth
|
||||
] repeat 3drop
|
||||
] "add-method" set-word-property
|
||||
] "add-method" set-word-prop
|
||||
|
||||
object [ drop t ] "predicate" set-word-property
|
||||
object [ drop t ] "predicate" set-word-prop
|
||||
|
||||
object 100 "priority" set-word-property
|
||||
object 100 "priority" set-word-prop
|
||||
|
||||
object [ 2drop t ] "class<" set-word-property
|
||||
object [ 2drop t ] "class<" set-word-prop
|
||||
|
||||
object object define-class
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ SYMBOL: predicate
|
|||
|
||||
: predicate-dispatch ( existing definition class -- dispatch )
|
||||
[
|
||||
\ dup , "predicate" word-property append, , , \ ifte ,
|
||||
\ dup , "predicate" word-prop append, , , \ ifte ,
|
||||
] make-list ;
|
||||
|
||||
: predicate-method ( vtable definition class type# -- )
|
||||
|
|
@ -20,8 +20,8 @@ SYMBOL: predicate
|
|||
] 2keep set-vector-nth ;
|
||||
|
||||
predicate [
|
||||
"superclass" word-property builtin-supertypes
|
||||
] "builtin-supertypes" set-word-property
|
||||
"superclass" word-prop builtin-supertypes
|
||||
] "builtin-supertypes" set-word-prop
|
||||
|
||||
predicate [
|
||||
( generic vtable definition class -- )
|
||||
|
|
@ -29,20 +29,20 @@ predicate [
|
|||
( vtable definition class type# )
|
||||
>r 3dup r> predicate-method
|
||||
] each 2drop 2drop
|
||||
] "add-method" set-word-property
|
||||
] "add-method" set-word-prop
|
||||
|
||||
predicate 25 "priority" set-word-property
|
||||
predicate 25 "priority" set-word-prop
|
||||
|
||||
predicate [
|
||||
2dup = [
|
||||
2drop t
|
||||
] [
|
||||
>r "superclass" word-property r> class<
|
||||
>r "superclass" word-prop r> class<
|
||||
] ifte
|
||||
] "class<" set-word-property
|
||||
] "class<" set-word-prop
|
||||
|
||||
: define-predicate ( class predicate definition -- )
|
||||
pick "superclass" word-property "predicate" word-property
|
||||
pick "superclass" word-prop "predicate" word-prop
|
||||
[ \ dup , append, , [ drop f ] , \ ifte , ] make-list
|
||||
define-compound
|
||||
predicate "metaclass" set-word-property ;
|
||||
predicate "metaclass" set-word-prop ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ strings words ;
|
|||
#! the form [ slot reader writer ]. slot is an integer,
|
||||
#! reader and writer are either words, strings or f.
|
||||
intern-slots
|
||||
2dup "slots" set-word-property
|
||||
2dup "slots" set-word-prop
|
||||
[ 3unlist define-slot ] each-with ;
|
||||
|
||||
: reader-word ( class name -- word )
|
||||
|
|
@ -63,7 +63,7 @@ strings words ;
|
|||
#! the benefit of tuples. Built-in types do not have
|
||||
#! delegate slots.
|
||||
swap >r [ "delegate" = dup [ >r 1 + r> ] unless ] some? [
|
||||
r> swap "delegate-slot" set-word-property
|
||||
r> swap "delegate-slot" set-word-prop
|
||||
] [
|
||||
r> 2drop
|
||||
] ifte ;
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ UNION: arrayed array tuple ;
|
|||
] repeat nip ;
|
||||
|
||||
: literal-tuple ( list -- tuple )
|
||||
dup car "tuple-size" word-property over length over = [
|
||||
dup car "tuple-size" word-prop over length over = [
|
||||
(literal-tuple)
|
||||
] [
|
||||
"Incorrect tuple length" throw
|
||||
|
|
@ -46,14 +46,14 @@ UNION: arrayed array tuple ;
|
|||
#! If the new list of slots is different from the previous,
|
||||
#! forget the old definition.
|
||||
>r "use" get search dup [
|
||||
dup "tuple-size" word-property r> length 1 + =
|
||||
dup "tuple-size" word-prop r> length 1 + =
|
||||
[ drop ] [ forget ] ifte
|
||||
] [
|
||||
r> 2drop
|
||||
] ifte ;
|
||||
|
||||
: tuple-slots ( tuple slots -- )
|
||||
2dup length 1 + "tuple-size" set-word-property
|
||||
2dup length 1 + "tuple-size" set-word-prop
|
||||
3 -rot simple-slots ;
|
||||
|
||||
: constructor-word ( word -- word )
|
||||
|
|
@ -61,12 +61,12 @@ UNION: arrayed array tuple ;
|
|||
|
||||
: define-constructor ( word def -- )
|
||||
>r [ constructor-word ] keep [
|
||||
dup literal, "tuple-size" word-property , \ make-tuple ,
|
||||
dup literal, "tuple-size" word-prop , \ make-tuple ,
|
||||
] make-list r> append define-compound ;
|
||||
|
||||
: default-constructor ( tuple -- )
|
||||
dup [
|
||||
"slots" word-property
|
||||
"slots" word-prop
|
||||
reverse [ last unit , \ keep , ] each
|
||||
] make-list define-constructor ;
|
||||
|
||||
|
|
@ -76,13 +76,13 @@ UNION: arrayed array tuple ;
|
|||
dup save-location
|
||||
dup intern-symbol
|
||||
dup tuple-predicate
|
||||
dup tuple "metaclass" set-word-property
|
||||
dup tuple "metaclass" set-word-prop
|
||||
dup r> tuple-slots
|
||||
default-constructor ;
|
||||
|
||||
: tuple-delegate ( tuple -- obj )
|
||||
dup tuple? [
|
||||
dup class "delegate-slot" word-property dup [
|
||||
dup class "delegate-slot" word-prop dup [
|
||||
>fixnum slot
|
||||
] [
|
||||
2drop f
|
||||
|
|
@ -123,7 +123,7 @@ UNION: arrayed array tuple ;
|
|||
: default-tuple-method ( generic -- quot )
|
||||
#! If the generic does not define a specific method for a
|
||||
#! tuple, execute the return value of this.
|
||||
dup "methods" word-property
|
||||
dup "methods" word-prop
|
||||
tuple over hash* dup [
|
||||
2nip cdr
|
||||
] [
|
||||
|
|
@ -141,7 +141,7 @@ UNION: arrayed array tuple ;
|
|||
#! Generate a quotation that performs tuple class dispatch
|
||||
#! for methods defined on the given generic.
|
||||
dup default-tuple-method \ drop swons
|
||||
swap "methods" word-property hash>quot
|
||||
swap "methods" word-prop hash>quot
|
||||
[ dup class ] swap append ;
|
||||
|
||||
: add-tuple-dispatch ( word vtable -- )
|
||||
|
|
@ -153,7 +153,7 @@ UNION: arrayed array tuple ;
|
|||
dup array-capacity dup <tuple> [ -rot copy-array ] keep ;
|
||||
|
||||
: clone-delegate ( tuple -- )
|
||||
dup class "delegate-slot" word-property dup [
|
||||
dup class "delegate-slot" word-prop dup [
|
||||
[ >fixnum slot clone ] 2keep set-slot
|
||||
] [
|
||||
2drop
|
||||
|
|
@ -187,12 +187,12 @@ M: tuple hashcode ( vec -- n )
|
|||
tuple [
|
||||
( generic vtable definition class -- )
|
||||
2drop add-tuple-dispatch
|
||||
] "add-method" set-word-property
|
||||
] "add-method" set-word-prop
|
||||
|
||||
tuple [
|
||||
drop tuple "builtin-type" word-property unit
|
||||
] "builtin-supertypes" set-word-property
|
||||
drop tuple "builtin-type" word-prop unit
|
||||
] "builtin-supertypes" set-word-prop
|
||||
|
||||
tuple 10 "priority" set-word-property
|
||||
tuple 10 "priority" set-word-prop
|
||||
|
||||
tuple [ 2drop t ] "class<" set-word-property
|
||||
tuple [ 2drop t ] "class<" set-word-prop
|
||||
|
|
|
|||
|
|
@ -8,25 +8,25 @@ words vectors ;
|
|||
SYMBOL: union
|
||||
|
||||
union [
|
||||
[ ] swap "members" word-property [
|
||||
[ ] swap "members" word-prop [
|
||||
builtin-supertypes append
|
||||
] each
|
||||
] "builtin-supertypes" set-word-property
|
||||
] "builtin-supertypes" set-word-prop
|
||||
|
||||
union [
|
||||
( generic vtable definition class -- )
|
||||
"members" word-property [ >r 3dup r> add-method ] each 3drop
|
||||
] "add-method" set-word-property
|
||||
"members" word-prop [ >r 3dup r> add-method ] each 3drop
|
||||
] "add-method" set-word-prop
|
||||
|
||||
union 30 "priority" set-word-property
|
||||
union 30 "priority" set-word-prop
|
||||
|
||||
union [ 2drop t ] "class<" set-word-property
|
||||
union [ 2drop t ] "class<" set-word-prop
|
||||
|
||||
: union-predicate ( definition -- list )
|
||||
[
|
||||
[
|
||||
\ dup ,
|
||||
unswons "predicate" word-property append,
|
||||
unswons "predicate" word-prop append,
|
||||
[ drop t ] ,
|
||||
union-predicate ,
|
||||
\ ifte ,
|
||||
|
|
@ -46,5 +46,5 @@ union [ 2drop t ] "class<" set-word-property
|
|||
] keep ?
|
||||
] map
|
||||
[ union-predicate define-compound ] keep
|
||||
dupd "members" set-word-property
|
||||
dupd "members" set-word-prop
|
||||
union define-class ;
|
||||
|
|
|
|||
|
|
@ -123,7 +123,7 @@ errors unparser logging listener url-encoding hashtables memory ;
|
|||
|
||||
: word-uses ( word -- list )
|
||||
#! Return a list of vocabularies that the given word uses.
|
||||
word-parameter flatten [ word? ] subset [
|
||||
word-def flatten [ word? ] subset [
|
||||
word-vocabulary
|
||||
] map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -210,7 +210,7 @@ SYMBOL: cloned
|
|||
dynamic-ifte
|
||||
] ifte ;
|
||||
|
||||
\ ifte [ infer-ifte ] "infer" set-word-property
|
||||
\ ifte [ infer-ifte ] "infer" set-word-prop
|
||||
|
||||
: vtable>list ( value -- list )
|
||||
dup value-recursion swap literal-value vector>list
|
||||
|
|
@ -247,6 +247,6 @@ USE: kernel-internals
|
|||
dynamic-dispatch
|
||||
] ifte ;
|
||||
|
||||
\ dispatch [ infer-dispatch ] "infer" set-word-property
|
||||
\ dispatch [ infer-dispatch ] "infer" set-word-prop
|
||||
\ dispatch [ [ fixnum vector ] [ ] ]
|
||||
"infer-effect" set-word-property
|
||||
"infer-effect" set-word-prop
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@ SYMBOL: node-param
|
|||
#! if its not defined, apply default quotation to
|
||||
#! ( node ) otherwise apply property quotation to
|
||||
#! ( node ).
|
||||
>r >r dup [ node-op get ] bind r> word-property dup [
|
||||
>r >r dup [ node-op get ] bind r> word-prop dup [
|
||||
call r> drop
|
||||
] [
|
||||
drop r> call
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@ M: object apply-object apply-literal ;
|
|||
|
||||
: terminator? ( obj -- ? )
|
||||
#! Does it throw an error?
|
||||
dup word? [ "terminator" word-property ] [ drop f ] ifte ;
|
||||
dup word? [ "terminator" word-prop ] [ drop f ] ifte ;
|
||||
|
||||
: handle-terminator ( quot -- )
|
||||
#! If the quotation throws an error, do not count its stack
|
||||
|
|
|
|||
|
|
@ -36,22 +36,22 @@ USE: words
|
|||
f \ >r dataflow, [ 1 0 node-inputs ] extend
|
||||
pop-d push-r
|
||||
[ 0 1 node-outputs ] bind
|
||||
] "infer" set-word-property
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ r> [
|
||||
f \ r> dataflow, [ 0 1 node-inputs ] extend
|
||||
pop-r push-d
|
||||
[ 1 0 node-outputs ] bind
|
||||
] "infer" set-word-property
|
||||
] "infer" set-word-prop
|
||||
|
||||
: partial-eval ( word -- )
|
||||
#! Partially evaluate a word.
|
||||
f over dup
|
||||
"infer-effect" word-property
|
||||
"infer-effect" word-prop
|
||||
[ host-word ] with-dataflow ;
|
||||
|
||||
\ drop [ \ drop partial-eval ] "infer" set-word-property
|
||||
\ dup [ \ dup partial-eval ] "infer" set-word-property
|
||||
\ swap [ \ swap partial-eval ] "infer" set-word-property
|
||||
\ over [ \ over partial-eval ] "infer" set-word-property
|
||||
\ pick [ \ pick partial-eval ] "infer" set-word-property
|
||||
\ drop [ \ drop partial-eval ] "infer" set-word-prop
|
||||
\ dup [ \ dup partial-eval ] "infer" set-word-prop
|
||||
\ swap [ \ swap partial-eval ] "infer" set-word-prop
|
||||
\ over [ \ over partial-eval ] "infer" set-word-prop
|
||||
\ pick [ \ pick partial-eval ] "infer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -18,12 +18,12 @@ lists math namespaces strings vectors words stdio prettyprint ;
|
|||
|
||||
: computed-slot ( -- )
|
||||
"Computed slot access is slower" inference-warning
|
||||
\ slot dup "infer-effect" word-property consume/produce ;
|
||||
\ slot dup "infer-effect" word-prop consume/produce ;
|
||||
|
||||
\ slot [
|
||||
[ object fixnum ] ensure-d
|
||||
fast-slot? [ fast-slot ] [ computed-slot ] ifte
|
||||
] "infer" set-word-property
|
||||
] "infer" set-word-prop
|
||||
|
||||
: type-value-map ( value -- )
|
||||
num-types
|
||||
|
|
@ -47,4 +47,4 @@ lists math namespaces strings vectors words stdio prettyprint ;
|
|||
\ type [
|
||||
[ object ] ensure-d
|
||||
literal-type? [ literal-type ] [ computed-type ] ifte
|
||||
] "infer" set-word-property
|
||||
] "infer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -32,15 +32,12 @@ strings vectors words hashtables parser prettyprint ;
|
|||
: no-effect ( word -- )
|
||||
"Unknown stack effect: " swap word-name cat2 inference-error ;
|
||||
|
||||
: recursive? ( word -- ? )
|
||||
dup word-parameter tree-contains? ;
|
||||
|
||||
: inline-compound ( word -- effect node )
|
||||
#! Infer the stack effect of a compound word in the current
|
||||
#! inferencer instance. If the word in question is recursive
|
||||
#! we infer its stack effect inside a new block.
|
||||
gensym over word-parameter cons [
|
||||
word-parameter infer-quot effect
|
||||
gensym over word-def cons [
|
||||
word-def infer-quot effect
|
||||
] with-block ;
|
||||
|
||||
: infer-compound ( word -- )
|
||||
|
|
@ -50,14 +47,14 @@ strings vectors words hashtables parser prettyprint ;
|
|||
[
|
||||
recursive-state get init-inference
|
||||
dup dup inline-compound drop present-effect
|
||||
[ "infer-effect" set-word-property ] keep
|
||||
[ "infer-effect" set-word-prop ] keep
|
||||
] with-scope consume/produce
|
||||
] [
|
||||
[
|
||||
>r branches-can-fail? [
|
||||
drop
|
||||
] [
|
||||
t "no-effect" set-word-property
|
||||
t "no-effect" set-word-prop
|
||||
] ifte r> rethrow
|
||||
] when*
|
||||
] catch ;
|
||||
|
|
@ -70,7 +67,7 @@ M: object (apply-word) ( word -- )
|
|||
|
||||
M: compound (apply-word) ( word -- )
|
||||
#! Infer a compound word's stack effect.
|
||||
dup "no-effect" word-property [
|
||||
dup "no-effect" word-prop [
|
||||
no-effect
|
||||
] [
|
||||
infer-compound
|
||||
|
|
@ -82,8 +79,8 @@ M: symbol (apply-word) ( word -- )
|
|||
GENERIC: apply-word
|
||||
|
||||
: apply-default ( word -- )
|
||||
dup "infer-effect" word-property [
|
||||
over "infer" word-property [
|
||||
dup "infer-effect" word-prop [
|
||||
over "infer" word-prop [
|
||||
swap car ensure-d call drop
|
||||
] [
|
||||
consume/produce
|
||||
|
|
@ -96,7 +93,7 @@ M: word apply-word ( word -- )
|
|||
apply-default ;
|
||||
|
||||
M: compound apply-word ( word -- )
|
||||
dup "inline" word-property [
|
||||
dup "inline" word-prop [
|
||||
inline-compound 2drop
|
||||
] [
|
||||
apply-default
|
||||
|
|
@ -168,15 +165,15 @@ M: word apply-object ( word -- )
|
|||
[ general-list ] ensure-d
|
||||
dataflow-drop, pop-d infer-quot-value ;
|
||||
|
||||
\ call [ infer-call ] "infer" set-word-property
|
||||
\ call [ infer-call ] "infer" set-word-prop
|
||||
|
||||
! These hacks will go away soon
|
||||
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-property
|
||||
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-property
|
||||
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-property
|
||||
\ = [ [ object object ] [ object ] ] "infer-effect" set-word-property
|
||||
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
||||
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
||||
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
||||
\ = [ [ object object ] [ object ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ undefined-method t "terminator" set-word-property
|
||||
\ undefined-method [ [ object word ] [ ] ] "infer-effect" set-word-property
|
||||
\ not-a-number t "terminator" set-word-property
|
||||
\ throw t "terminator" set-word-property
|
||||
\ undefined-method t "terminator" set-word-prop
|
||||
\ undefined-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
|
||||
\ not-a-number t "terminator" set-word-prop
|
||||
\ throw t "terminator" set-word-prop
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ SYMBOL: surface
|
|||
swap bitor ;
|
||||
|
||||
: black [ 0 0 0 ] ;
|
||||
: gray [ 128 128 128 ] ;
|
||||
: white [ 255 255 255 ] ;
|
||||
: red [ 255 0 0 ] ;
|
||||
: green [ 0 255 0 ] ;
|
||||
|
|
|
|||
|
|
@ -34,16 +34,16 @@ USING: syntax generic kernel lists namespaces parser words ;
|
|||
CREATE
|
||||
dup intern-symbol
|
||||
dup predicate-word
|
||||
[ dupd unit "predicate" set-word-property ] keep
|
||||
[ dupd unit "predicate" set-word-prop ] keep
|
||||
[ define-union ] [ ] ; parsing
|
||||
|
||||
: PREDICATE: ( -- class predicate definition )
|
||||
#! Followed by a superclass name, then a class name.
|
||||
scan-word
|
||||
CREATE dup intern-symbol
|
||||
dup rot "superclass" set-word-property
|
||||
dup rot "superclass" set-word-prop
|
||||
dup predicate-word
|
||||
[ dupd unit "predicate" set-word-property ] keep
|
||||
[ dupd unit "predicate" set-word-prop ] keep
|
||||
[ define-predicate ] [ ] ; parsing
|
||||
|
||||
: TUPLE:
|
||||
|
|
|
|||
|
|
@ -10,11 +10,11 @@ math namespaces parser strings words vectors unparse ;
|
|||
#! Mark the most recently defined word to execute at parse
|
||||
#! time, rather than run time. The word can use 'scan' to
|
||||
#! read ahead in the input stream.
|
||||
word t "parsing" set-word-property ; parsing
|
||||
word t "parsing" set-word-prop ; parsing
|
||||
|
||||
: inline ( -- )
|
||||
#! Mark the last word to be inlined.
|
||||
word t "inline" set-word-property ; parsing
|
||||
word t "inline" set-word-prop ; parsing
|
||||
|
||||
! The variable "in-definition" is set inside a : ... ;.
|
||||
! ( and #! then add "stack-effect" and "documentation"
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ unparser ;
|
|||
! immediately. Otherwise it is appended to the parse tree.
|
||||
|
||||
: parsing? ( word -- ? )
|
||||
dup word? [ "parsing" word-property ] [ drop f ] ifte ;
|
||||
dup word? [ "parsing" word-prop ] [ drop f ] ifte ;
|
||||
|
||||
: skip ( n line quot -- n )
|
||||
#! Find the next character that satisfies the quotation,
|
||||
|
|
@ -109,9 +109,9 @@ global [ string-mode off ] bind
|
|||
: save-location ( word -- )
|
||||
#! Remember where this word was defined.
|
||||
dup set-word
|
||||
dup line-number get "line" set-word-property
|
||||
dup "col" get "col" set-word-property
|
||||
file get "file" set-word-property ;
|
||||
dup line-number get "line" set-word-prop
|
||||
dup "col" get "col" set-word-prop
|
||||
file get "file" set-word-prop ;
|
||||
|
||||
: create-in "in" get create ;
|
||||
|
||||
|
|
@ -150,20 +150,20 @@ global [ string-mode off ] bind
|
|||
|
||||
: parsed-stack-effect ( parsed str -- parsed )
|
||||
over doc-comment-here? [
|
||||
word "stack-effect" word-property [
|
||||
word "stack-effect" word-prop [
|
||||
drop
|
||||
] [
|
||||
word swap "stack-effect" set-word-property
|
||||
word swap "stack-effect" set-word-prop
|
||||
] ifte
|
||||
] [
|
||||
drop
|
||||
] ifte ;
|
||||
|
||||
: documentation+ ( word str -- )
|
||||
over "documentation" word-property [
|
||||
over "documentation" word-prop [
|
||||
swap "\n" swap cat3
|
||||
] when*
|
||||
"documentation" set-word-property ;
|
||||
"documentation" set-word-prop ;
|
||||
|
||||
: parsed-documentation ( parsed str -- parsed )
|
||||
over doc-comment-here? [
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ presentation unparser words ;
|
|||
tab-size get - ;
|
||||
|
||||
: prettyprint-prop ( word prop -- )
|
||||
tuck word-name word-property [
|
||||
tuck word-name word-prop [
|
||||
" " write prettyprint-word
|
||||
] [
|
||||
drop
|
||||
|
|
@ -57,12 +57,12 @@ presentation unparser words ;
|
|||
] make-string comment. ;
|
||||
|
||||
: stack-effect. ( indent word -- indent )
|
||||
dup "stack-effect" word-property [
|
||||
dup "stack-effect" word-prop [
|
||||
" " write
|
||||
[ CHAR: ( , , CHAR: ) , ] make-string
|
||||
comment.
|
||||
] [
|
||||
"infer-effect" word-property dup [
|
||||
"infer-effect" word-prop dup [
|
||||
infer-effect.
|
||||
] [
|
||||
drop
|
||||
|
|
@ -70,7 +70,7 @@ presentation unparser words ;
|
|||
] ?ifte ;
|
||||
|
||||
: documentation. ( indent word -- indent )
|
||||
"documentation" word-property [
|
||||
"documentation" word-prop [
|
||||
"\n" split [
|
||||
"#!" swap cat2 comment.
|
||||
dup prettyprint-newline
|
||||
|
|
@ -92,10 +92,7 @@ M: compound see ( word -- )
|
|||
0 prettyprint-: swap
|
||||
[ prettyprint-word ] keep
|
||||
[ prettyprint-docs ] keep
|
||||
[
|
||||
word-parameter prettyprint-elements
|
||||
prettyprint-;
|
||||
] keep
|
||||
[ word-def prettyprint-elements prettyprint-; ] keep
|
||||
prettyprint-plist prettyprint-newline ;
|
||||
|
||||
: see-method ( indent word class method -- indent )
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@ USE: words
|
|||
|
||||
: foo [ drop ] each-word ;
|
||||
|
||||
[ ] [ \ foo word-parameter dataflow linearize drop ] unit-test
|
||||
[ ] [ \ foo word-def dataflow linearize drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ USE: lists
|
|||
|
||||
: foo 1 2 3 ;
|
||||
|
||||
[ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test
|
||||
[ [ ] ] [ \ foo word-def dataflow kill-set ] unit-test
|
||||
|
||||
[ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ USE: generic
|
|||
|
||||
SYMBOL: #test
|
||||
|
||||
#test f "foobar" set-word-property
|
||||
#test f "foobar" set-word-prop
|
||||
|
||||
[ 6 ] [
|
||||
{{
|
||||
|
|
@ -82,7 +82,7 @@ SYMBOL: #test
|
|||
}} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow
|
||||
] unit-test
|
||||
|
||||
#test [ [ node-param get ] bind sq ] "foobar" set-word-property
|
||||
#test [ [ node-param get ] bind sq ] "foobar" set-word-prop
|
||||
|
||||
[ 25 ] [
|
||||
{{
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: generic kernel lists math memory words ;
|
|||
num-types [
|
||||
[
|
||||
builtin-type [
|
||||
"predicate" word-property instances [
|
||||
"predicate" word-prop instances [
|
||||
class drop
|
||||
] each
|
||||
] when*
|
||||
|
|
|
|||
|
|
@ -19,5 +19,5 @@ DEFER: foo
|
|||
! Test > 1 ( ) comment; only the first one should be used.
|
||||
[ t ] [
|
||||
"a" ": foo ( a ) ( b ) ;" parse drop word
|
||||
"stack-effect" word-property str-contains?
|
||||
"stack-effect" word-prop str-contains?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,5 @@
|
|||
IN: scratchpad
|
||||
USE: math
|
||||
USE: test
|
||||
USE: words
|
||||
USE: namespaces
|
||||
USE: lists
|
||||
USE: kernel
|
||||
USING: generic kernel lists math namespaces test words ;
|
||||
|
||||
[ 4 ] [
|
||||
"poo" "scratchpad" create [ 2 2 + ] define-compound
|
||||
|
|
@ -16,20 +11,20 @@ USE: kernel
|
|||
DEFER: plist-test
|
||||
|
||||
[ t ] [
|
||||
\ plist-test t "sample-property" set-word-property
|
||||
\ plist-test "sample-property" word-property
|
||||
\ plist-test t "sample-property" set-word-prop
|
||||
\ plist-test "sample-property" word-prop
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
\ plist-test f "sample-property" set-word-property
|
||||
\ plist-test "sample-property" word-property
|
||||
\ plist-test f "sample-property" set-word-prop
|
||||
\ plist-test "sample-property" word-prop
|
||||
] unit-test
|
||||
|
||||
[ f ] [ 5 compound? ] unit-test
|
||||
|
||||
"create-test" "scratchpad" create { 1 2 } "testing" set-word-property
|
||||
"create-test" "scratchpad" create { 1 2 } "testing" set-word-prop
|
||||
[ { 1 2 } ] [
|
||||
"create-test" [ "scratchpad" ] search "testing" word-property
|
||||
"create-test" [ "scratchpad" ] search "testing" word-prop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -56,6 +51,14 @@ SYMBOL: a-symbol
|
|||
[ f ] [ \ a-symbol compound? ] unit-test
|
||||
[ t ] [ \ a-symbol symbol? ] unit-test
|
||||
|
||||
! See if redefining a generic as a colon def clears some
|
||||
! word props.
|
||||
GENERIC: testing
|
||||
: testing ;
|
||||
|
||||
[ f ] [ \ testing generic? ] unit-test
|
||||
|
||||
! This has to be the last test in the file.
|
||||
: test-last ( -- ) ;
|
||||
word word-name "last-word-test" set
|
||||
|
||||
|
|
|
|||
|
|
@ -63,21 +63,17 @@ SYMBOL: meta-cf
|
|||
meta-cf [ [ push-r ] when* ] change ;
|
||||
|
||||
: meta-word ( word -- )
|
||||
dup "meta-word" word-property [
|
||||
dup "meta-word" word-prop [
|
||||
call
|
||||
] [
|
||||
dup compound? [
|
||||
word-parameter meta-call
|
||||
] [
|
||||
host-word
|
||||
] ifte
|
||||
dup compound? [ word-def meta-call ] [ host-word ] ifte
|
||||
] ?ifte ;
|
||||
|
||||
: do ( obj -- )
|
||||
dup word? [ meta-word ] [ push-d ] ifte ;
|
||||
|
||||
: meta-word-1 ( word -- )
|
||||
dup "meta-word" word-property [ call ] [ host-word ] ?ifte ;
|
||||
dup "meta-word" word-prop [ call ] [ host-word ] ?ifte ;
|
||||
|
||||
: do-1 ( obj -- )
|
||||
dup word? [ meta-word-1 ] [ push-d ] ifte ;
|
||||
|
|
@ -89,7 +85,7 @@ SYMBOL: meta-cf
|
|||
: run ( -- ) [ do ] interpret ;
|
||||
|
||||
: set-meta-word ( word quot -- )
|
||||
"meta-word" set-word-property ;
|
||||
"meta-word" set-word-prop ;
|
||||
|
||||
\ datastack [ meta-d get clone push-d ] set-meta-word
|
||||
\ set-datastack [ pop-d clone meta-d set ] set-meta-word
|
||||
|
|
|
|||
|
|
@ -108,7 +108,7 @@ C: jedit-stream ( stream -- stream )
|
|||
"name"
|
||||
"stack-effect"
|
||||
] [
|
||||
word-property
|
||||
word-prop
|
||||
] map-with
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ strings unparser words ;
|
|||
: jedit ( word -- )
|
||||
#! Note that line numbers here start from 1
|
||||
dup word-file dup [
|
||||
swap "line" word-property jedit-line/file
|
||||
swap "line" word-prop jedit-line/file
|
||||
] [
|
||||
2drop "Unknown source" print
|
||||
] ifte ;
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ M: arrayed (each-slot) ( quot array -- )
|
|||
] repeat 2drop ;
|
||||
|
||||
M: object (each-slot) ( quot obj -- )
|
||||
dup class "slots" word-property [
|
||||
dup class "slots" word-prop [
|
||||
pick pick >r >r car slot swap call r> r>
|
||||
] each 2drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,19 +8,14 @@ parser ;
|
|||
GENERIC: word-uses? ( of in -- ? )
|
||||
M: word word-uses? 2drop f ;
|
||||
M: compound word-uses? ( of in -- ? )
|
||||
2dup = [
|
||||
2drop f ! Don't say that a word uses itself
|
||||
] [
|
||||
word-parameter tree-contains?
|
||||
] ifte ;
|
||||
#! Don't say that a word uses itself.
|
||||
2dup = [ 2drop f ] [ word-def tree-contains? ] ifte ;
|
||||
|
||||
: generic-uses? ( of in -- ? )
|
||||
"methods" word-property hash>alist tree-contains? ;
|
||||
"methods" word-prop hash>alist tree-contains? ;
|
||||
|
||||
M: generic word-uses? ( of in -- ? )
|
||||
generic-uses? ;
|
||||
M: 2generic word-uses? ( of in -- ? )
|
||||
generic-uses? ;
|
||||
M: generic word-uses? ( of in -- ? ) generic-uses? ;
|
||||
M: 2generic word-uses? ( of in -- ? ) generic-uses? ;
|
||||
|
||||
: usages-in-vocab ( of vocab -- usages )
|
||||
#! Push a list of all usages of a word in a vocabulary.
|
||||
|
|
@ -82,7 +77,7 @@ M: 2generic word-uses? ( of in -- ? )
|
|||
words . ;
|
||||
|
||||
: word-file ( word -- file )
|
||||
"file" word-property dup [
|
||||
"file" word-prop dup [
|
||||
"resource:/" ?str-head [
|
||||
resource-path swap path+
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -94,7 +94,7 @@ C: gadget ( shape -- gadget )
|
|||
#! The position of the gadget on the screen.
|
||||
0 swap [ shape-pos + t ] each-parent drop ;
|
||||
|
||||
: relative ( g1 g2 -- g2-p1 )
|
||||
: relative ( g1 g2 -- g2-g1 )
|
||||
shape-pos swap screen-pos - ;
|
||||
|
||||
: child? ( parent child -- ? )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,23 @@
|
|||
IN: gadgets
|
||||
USING: kernel math namespaces prettyprint sdl ;
|
||||
|
||||
TUPLE: halo selected delegate ;
|
||||
: drag-sizer ( sizer -- )
|
||||
gadget-parent ( - halo) [
|
||||
dup hand relative >rect
|
||||
rot halo-selected resize-gadget
|
||||
] keep relayout ;
|
||||
|
||||
: sizer-actions ( sizer -- )
|
||||
dup [ drop ] [ button-down 1 ] set-action
|
||||
[ drag-sizer ] [ drag 1 ] set-action ;
|
||||
|
||||
: <sizer> ( -- sizer )
|
||||
0 0 10 10 <plain-rect> <gadget>
|
||||
dup sizer-actions ;
|
||||
|
||||
! A halo retains the gadget its surrounding, as well as the
|
||||
! resizing gadget and a delegate.
|
||||
TUPLE: halo selected sizer delegate ;
|
||||
|
||||
: show-halo* ( gadget -- )
|
||||
#! Show the halo on a specific gadget.
|
||||
|
|
@ -39,13 +55,25 @@ DEFER: halo-menu
|
|||
C: halo ( -- halo )
|
||||
0 0 0 0 <hollow-rect> <gadget> over set-halo-delegate
|
||||
dup red foreground set-paint-property
|
||||
dup red background set-paint-property
|
||||
<sizer> over 2dup set-halo-sizer add-gadget
|
||||
dup halo-actions ;
|
||||
|
||||
M: halo layout* ( halo -- )
|
||||
: halo-update ( halo -- )
|
||||
#! Move the halo to the position of its selected gadget.
|
||||
dup halo-selected
|
||||
2dup screen-pos >rect rot move-gadget
|
||||
dup shape-w swap shape-h rot resize-gadget ;
|
||||
|
||||
: sizer-layout ( halo -- )
|
||||
#! Position the sizer to the bottom right corner.
|
||||
dup halo-sizer
|
||||
over shape-h over shape-h -
|
||||
>r over shape-w over shape-w - r> rot move-gadget drop ;
|
||||
|
||||
M: halo layout* ( halo -- )
|
||||
dup halo-update sizer-layout ;
|
||||
|
||||
: default-actions ( gadget -- )
|
||||
[ show-halo ] [ button-down 2 ] set-action ;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ lists namespaces strings unparser vectors words ;
|
|||
<line-pile> [ add-gadget ] keep [ add-gadget ] keep ;
|
||||
|
||||
: object>alist ( obj -- assoc )
|
||||
dup class "slots" word-property [
|
||||
dup class "slots" word-prop [
|
||||
cdr car [ execute ] keep swons
|
||||
] map-with ;
|
||||
|
||||
|
|
@ -43,7 +43,7 @@ GENERIC: custom-sheet ( obj -- gadget )
|
|||
over top-sheet over add-gadget
|
||||
over slot-sheet over add-gadget
|
||||
swap custom-sheet over add-gadget
|
||||
line-border ;
|
||||
<scroller> line-border ;
|
||||
|
||||
M: object custom-sheet drop <empty-gadget> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -59,8 +59,8 @@ IN: words USING: hashtables kernel lists namespaces strings ;
|
|||
#! returned.
|
||||
2dup (search) [
|
||||
nip
|
||||
dup f "documentation" set-word-property
|
||||
dup f "stack-effect" set-word-property
|
||||
dup f "documentation" set-word-prop
|
||||
dup f "stack-effect" set-word-prop
|
||||
] [
|
||||
(create) dup reveal
|
||||
] ?ifte ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ namespaces strings ;
|
|||
|
||||
BUILTIN: word 17
|
||||
[ 1 hashcode f ]
|
||||
[ 4 "word-parameter" "set-word-parameter" ]
|
||||
[ 4 "word-def" "set-word-def" ]
|
||||
[ 5 "word-props" "set-word-props" ] ;
|
||||
|
||||
GENERIC: word-xt
|
||||
|
|
@ -32,11 +32,8 @@ M: word set-allot-count ( n w -- ) 7 set-integer-slot ;
|
|||
|
||||
SYMBOL: vocabularies
|
||||
|
||||
: word-property ( word pname -- pvalue )
|
||||
swap word-props hash ;
|
||||
|
||||
: set-word-property ( word pvalue pname -- )
|
||||
rot word-props set-hash ;
|
||||
: word-prop ( word name -- value ) swap word-props hash ;
|
||||
: set-word-prop ( word value name -- ) rot word-props set-hash ;
|
||||
|
||||
PREDICATE: word compound ( obj -- ? ) word-primitive 1 = ;
|
||||
PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;
|
||||
|
|
@ -44,16 +41,24 @@ PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ;
|
|||
PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ;
|
||||
|
||||
: define ( word primitive parameter -- )
|
||||
pick set-word-parameter
|
||||
pick set-word-def
|
||||
over set-word-primitive
|
||||
f "parsing" set-word-property ;
|
||||
f "parsing" set-word-prop ;
|
||||
|
||||
: (define-compound) ( word def -- ) 1 swap define ;
|
||||
|
||||
: define-compound ( word def -- )
|
||||
#! If the word is a generic word, clear the properties
|
||||
#! involved so that 'see' can work properly.
|
||||
over f "definer" set-word-prop
|
||||
over f "methods" set-word-prop
|
||||
over f "combination" set-word-prop
|
||||
(define-compound) ;
|
||||
|
||||
: define-compound ( word def -- ) 1 swap define ;
|
||||
: define-symbol ( word -- ) 2 over define ;
|
||||
|
||||
: intern-symbol ( word -- )
|
||||
dup undefined? [ define-symbol ] [ drop ] ifte ;
|
||||
|
||||
: word-name ( word -- str ) "name" word-property ;
|
||||
|
||||
: word-vocabulary ( word -- str ) "vocabulary" word-property ;
|
||||
: word-name ( word -- str ) "name" word-prop ;
|
||||
: word-vocabulary ( word -- str ) "vocabulary" word-prop ;
|
||||
|
|
|
|||
|
|
@ -94,7 +94,7 @@ void print_cons(CELL cons)
|
|||
|
||||
void print_word(F_WORD* word)
|
||||
{
|
||||
CELL name = hash(word->plist,tag_object(from_c_string("name")));
|
||||
CELL name = hash(word->props,tag_object(from_c_string("name")));
|
||||
if(type_of(name) == STRING_TYPE)
|
||||
fprintf(stderr,"%s",to_c_string(untag_string(name)));
|
||||
else
|
||||
|
|
|
|||
|
|
@ -69,14 +69,14 @@ void undefined(F_WORD* word)
|
|||
/* XT of compound definitions */
|
||||
void docol(F_WORD* word)
|
||||
{
|
||||
call(word->parameter);
|
||||
call(word->def);
|
||||
executing = tag_object(word);
|
||||
}
|
||||
|
||||
/* pushes word parameter */
|
||||
void dosym(F_WORD* word)
|
||||
{
|
||||
dpush(word->parameter);
|
||||
dpush(word->def);
|
||||
}
|
||||
|
||||
void primitive_execute(void)
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@ void primitive_word(void)
|
|||
word->hashcode = tag_fixnum((CELL)word); /* initial address */
|
||||
word->xt = (CELL)undefined;
|
||||
word->primitive = 0;
|
||||
word->parameter = F;
|
||||
word->plist = F;
|
||||
word->def = F;
|
||||
word->props = F;
|
||||
word->call_count = 0;
|
||||
word->allot_count = 0;
|
||||
dpush(tag_object(word));
|
||||
|
|
@ -46,12 +46,12 @@ void fixup_word(F_WORD* word)
|
|||
else
|
||||
update_xt(word);
|
||||
|
||||
data_fixup(&word->parameter);
|
||||
data_fixup(&word->plist);
|
||||
data_fixup(&word->def);
|
||||
data_fixup(&word->props);
|
||||
}
|
||||
|
||||
void collect_word(F_WORD* word)
|
||||
{
|
||||
COPY_OBJECT(word->parameter);
|
||||
COPY_OBJECT(word->plist);
|
||||
COPY_OBJECT(word->def);
|
||||
COPY_OBJECT(word->props);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -8,9 +8,9 @@ typedef struct {
|
|||
/* untagged on-disk primitive number */
|
||||
CELL primitive;
|
||||
/* TAGGED parameter to xt; used for colon definitions */
|
||||
CELL parameter;
|
||||
/* TAGGED property list for library code */
|
||||
CELL plist;
|
||||
CELL def;
|
||||
/* TAGGED property hash for library code */
|
||||
CELL props;
|
||||
/* UNTAGGED call count incremented by profiler */
|
||||
CELL call_count;
|
||||
/* UNTAGGED amount of memory allocated in word */
|
||||
|
|
|
|||
Loading…
Reference in New Issue