disambiguate namespaces:set and sets:set.
John Benediktsson
parent
e6864bd538
commit
71ef8a22c2
|
|
@ -125,13 +125,13 @@ SYMBOL: ac-counter
|
|||
] [ vreg kill-computed-set-slot ] if ;
|
||||
|
||||
: init-alias-analysis ( -- )
|
||||
H{ } clone vregs>acs set
|
||||
H{ } clone acs>vregs set
|
||||
H{ } clone live-slots set
|
||||
H{ } clone copies set
|
||||
H{ } clone recent-stores set
|
||||
HS{ } clone dead-stores set
|
||||
0 ac-counter set ;
|
||||
H{ } clone vregs>acs namespaces:set
|
||||
H{ } clone acs>vregs namespaces:set
|
||||
H{ } clone live-slots namespaces:set
|
||||
H{ } clone copies namespaces:set
|
||||
H{ } clone recent-stores namespaces:set
|
||||
HS{ } clone dead-stores namespaces:set
|
||||
0 ac-counter namespaces:set ;
|
||||
|
||||
GENERIC: insn-slot# ( insn -- slot#/f )
|
||||
GENERIC: insn-object ( insn -- vreg )
|
||||
|
|
@ -255,7 +255,7 @@ M: insn eliminate-dead-stores drop t ;
|
|||
copies get clear-assoc
|
||||
dead-stores get clear-set
|
||||
|
||||
next-ac heap-ac set
|
||||
next-ac heap-ac namespaces:set
|
||||
##vm-field set-new-ac
|
||||
##alien-global set-new-ac ;
|
||||
|
||||
|
|
|
|||
|
|
@ -85,8 +85,8 @@ SYMBOL: visited
|
|||
[ worklist get push-front ] [ drop ] if ;
|
||||
|
||||
: init-worklist ( cfg -- )
|
||||
<dlist> worklist set
|
||||
HS{ } clone visited set
|
||||
<dlist> worklist namespaces:set
|
||||
HS{ } clone visited namespaces:set
|
||||
entry>> add-to-worklist ;
|
||||
|
||||
: split-branches ( cfg -- )
|
||||
|
|
|
|||
|
|
@ -21,9 +21,9 @@ SYMBOL: allocations
|
|||
allocations get in? ;
|
||||
|
||||
: init-dead-code ( -- )
|
||||
H{ } clone liveness-graph set
|
||||
HS{ } clone live-vregs set
|
||||
HS{ } clone allocations set ;
|
||||
H{ } clone liveness-graph namespaces:set
|
||||
HS{ } clone live-vregs namespaces:set
|
||||
HS{ } clone allocations namespaces:set ;
|
||||
|
||||
GENERIC: build-liveness-graph ( insn -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@ SYMBOLS: defs insns ;
|
|||
_ set-def-of
|
||||
] with each
|
||||
] simple-analysis
|
||||
] keep defs set ;
|
||||
] keep defs namespaces:set ;
|
||||
|
||||
: compute-insns ( cfg -- )
|
||||
H{ } clone [
|
||||
|
|
@ -119,4 +119,4 @@ SYMBOLS: defs insns ;
|
|||
dup _ set-def-of
|
||||
] each
|
||||
] simple-analysis
|
||||
] keep insns set ;
|
||||
] keep insns namespaces:set ;
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@ M: insn assign-registers-in-insn drop ;
|
|||
|
||||
: begin-block ( bb -- )
|
||||
{
|
||||
[ basic-block set ]
|
||||
[ basic-block namespaces:set ]
|
||||
[ block-from activate-new-intervals ]
|
||||
[ compute-edge-live-in ]
|
||||
[ compute-live-in ]
|
||||
|
|
@ -139,12 +139,12 @@ M: insn assign-registers-in-insn drop ;
|
|||
] change-instructions compute-live-out ;
|
||||
|
||||
: init-assignment ( live-intervals -- )
|
||||
[ [ start>> ] map ] keep zip >min-heap unhandled-intervals set
|
||||
<min-heap> pending-interval-heap set
|
||||
H{ } clone pending-interval-assoc set
|
||||
H{ } clone machine-live-ins set
|
||||
H{ } clone machine-edge-live-ins set
|
||||
H{ } clone machine-live-outs set ;
|
||||
[ [ start>> ] map ] keep zip >min-heap unhandled-intervals namespaces:set
|
||||
<min-heap> pending-interval-heap namespaces:set
|
||||
H{ } clone pending-interval-assoc namespaces:set
|
||||
H{ } clone machine-live-ins namespaces:set
|
||||
H{ } clone machine-edge-live-ins namespaces:set
|
||||
H{ } clone machine-live-outs namespaces:set ;
|
||||
|
||||
: assign-registers ( cfg live-intervals -- )
|
||||
init-assignment
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ SYMBOLS: loop-heads visited ;
|
|||
[ visited? ] reject ;
|
||||
|
||||
: (linearization-order) ( cfg -- bbs )
|
||||
HS{ } clone visited set
|
||||
HS{ } clone visited namespaces:set
|
||||
entry>> <dlist> [ push-back ] keep
|
||||
[ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
|
||||
|
||||
|
|
|
|||
|
|
@ -137,10 +137,10 @@ M: insn visit-insn 2drop ;
|
|||
[ update-live-out/in ] keep predecessors>> { } ? ;
|
||||
|
||||
: init-liveness ( -- )
|
||||
H{ } clone live-ins set
|
||||
H{ } clone edge-live-ins set
|
||||
H{ } clone live-outs set
|
||||
H{ } clone base-pointers set ;
|
||||
H{ } clone live-ins namespaces:set
|
||||
H{ } clone edge-live-ins namespaces:set
|
||||
H{ } clone live-outs namespaces:set
|
||||
H{ } clone base-pointers namespaces:set ;
|
||||
|
||||
: compute-live-sets ( cfg -- )
|
||||
init-liveness
|
||||
|
|
|
|||
|
|
@ -55,13 +55,13 @@ SYMBOL: loop-nesting
|
|||
: compute-loop-nesting ( -- )
|
||||
loops get H{ } clone [
|
||||
[ values ] dip '[ blocks>> members [ _ inc-at ] each ] each
|
||||
] keep loop-nesting set ;
|
||||
] keep loop-nesting namespaces:set ;
|
||||
|
||||
: detect-loops ( cfg -- cfg' )
|
||||
H{ } clone loops set
|
||||
HS{ } clone visited set
|
||||
HS{ } clone active set
|
||||
H{ } clone loop-nesting set
|
||||
H{ } clone loops namespaces:set
|
||||
HS{ } clone visited namespaces:set
|
||||
HS{ } clone active namespaces:set
|
||||
H{ } clone loop-nesting namespaces:set
|
||||
[ needs-predecessors ]
|
||||
[ entry>> find-loop-headers process-loop-headers compute-loop-nesting ]
|
||||
[ ] tri ;
|
||||
|
|
|
|||
|
|
@ -39,8 +39,8 @@ M: vreg-insn (collect-vreg-reps)
|
|||
M: insn (collect-vreg-reps) drop ;
|
||||
|
||||
: collect-vreg-reps ( cfg -- )
|
||||
H{ } clone vreg-reps set
|
||||
HS{ } clone tagged-vregs set
|
||||
H{ } clone vreg-reps namespaces:set
|
||||
HS{ } clone tagged-vregs namespaces:set
|
||||
[ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
|
||||
|
||||
SYMBOL: possibilities
|
||||
|
|
@ -52,7 +52,7 @@ SYMBOL: possibilities
|
|||
|
||||
: compute-possibilities ( cfg -- )
|
||||
collect-vreg-reps
|
||||
vreg-reps get [ possible-reps ] assoc-map possibilities set ;
|
||||
vreg-reps get [ possible-reps ] assoc-map possibilities namespaces:set ;
|
||||
|
||||
! For every vreg, compute the cost of keeping it in every possible
|
||||
! representation.
|
||||
|
|
@ -60,7 +60,7 @@ SYMBOL: possibilities
|
|||
SYMBOL: costs
|
||||
|
||||
: init-costs ( -- )
|
||||
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
|
||||
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs namespaces:set ;
|
||||
|
||||
: increase-cost ( rep scc factor -- )
|
||||
[ costs get at 2dup key? ] dip
|
||||
|
|
@ -121,7 +121,7 @@ M: vreg-insn compute-insn-costs
|
|||
: compute-costs ( cfg -- )
|
||||
init-costs
|
||||
[
|
||||
[ basic-block set ]
|
||||
[ basic-block namespaces:set ]
|
||||
[ [ compute-insn-costs ] each-non-phi ] bi
|
||||
] each-basic-block ;
|
||||
|
||||
|
|
@ -133,4 +133,4 @@ M: vreg-insn compute-insn-costs
|
|||
compute-costs costs get minimize-costs
|
||||
[ components get [ disjoint-set-members ] keep ] dip
|
||||
'[ dup _ representative _ at ] H{ } map>assoc
|
||||
representations set ;
|
||||
representations namespaces:set ;
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: compiler.cfg.rpo
|
|||
|
||||
: optimize-basic-block ( bb quot -- )
|
||||
over kill-block?>> [ 2drop ] [
|
||||
over basic-block set
|
||||
over basic-block namespaces:set
|
||||
change-instructions drop
|
||||
] if ; inline
|
||||
|
||||
|
|
@ -42,7 +42,7 @@ IN: compiler.cfg.rpo
|
|||
|
||||
: analyze-basic-block ( bb quot -- )
|
||||
over kill-block?>> [ 2drop ] [
|
||||
[ dup basic-block set instructions>> ] dip call
|
||||
[ dup basic-block namespaces:set instructions>> ] dip call
|
||||
] if ; inline
|
||||
|
||||
: simple-analysis ( ... cfg quot: ( ... insns -- ... ) -- ... )
|
||||
|
|
|
|||
|
|
@ -25,8 +25,8 @@ M: vreg-insn compute-insn-defs
|
|||
] with each ;
|
||||
|
||||
: compute-defs ( cfg -- )
|
||||
H{ } clone defs set
|
||||
HS{ } clone defs-multi set
|
||||
H{ } clone defs namespaces:set
|
||||
HS{ } clone defs-multi namespaces:set
|
||||
[
|
||||
[ basic-block get ] dip
|
||||
[ compute-insn-defs ] with each
|
||||
|
|
@ -44,7 +44,7 @@ SYMBOL: inserting-phis
|
|||
members merge-set [ insert-phi-later ] with each ;
|
||||
|
||||
: compute-phis ( -- )
|
||||
H{ } clone inserting-phis set
|
||||
H{ } clone inserting-phis namespaces:set
|
||||
defs-multi get members
|
||||
defs get '[ dup _ at compute-phis-for ] each ;
|
||||
|
||||
|
|
@ -55,9 +55,9 @@ SYMBOL: used-vregs
|
|||
SYMBOLS: stacks pushed ;
|
||||
|
||||
: init-renaming ( -- )
|
||||
H{ } clone phis set
|
||||
<hashed-dlist> used-vregs set
|
||||
H{ } clone stacks set ;
|
||||
H{ } clone phis namespaces:set
|
||||
<hashed-dlist> used-vregs namespaces:set
|
||||
H{ } clone stacks namespaces:set ;
|
||||
|
||||
: gen-name ( vreg -- vreg' )
|
||||
[ next-vreg dup ] dip
|
||||
|
|
@ -109,7 +109,7 @@ M: vreg-insn rename-insn
|
|||
pushed get members stacks get '[ _ at pop* ] each ;
|
||||
|
||||
: rename-in-block ( bb -- )
|
||||
HS{ } clone pushed set
|
||||
HS{ } clone pushed namespaces:set
|
||||
{
|
||||
[ rename-phis ]
|
||||
[ rename-insns ]
|
||||
|
|
@ -117,7 +117,7 @@ M: vreg-insn rename-insn
|
|||
[
|
||||
pushed get
|
||||
[ dom-children [ rename-in-block ] each ] dip
|
||||
pushed set
|
||||
pushed namespaces:set
|
||||
]
|
||||
} cleave
|
||||
pop-stacks ;
|
||||
|
|
@ -132,7 +132,7 @@ SYMBOL: live-phis
|
|||
dst>> live-phis get in? ;
|
||||
|
||||
: compute-live-phis ( -- )
|
||||
HS{ } clone live-phis set
|
||||
HS{ } clone live-phis namespaces:set
|
||||
used-vregs get [
|
||||
phis get at [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -15,14 +15,15 @@ IN: compiler.cfg.ssa.construction.tdmsc
|
|||
SYMBOLS: merge-sets levels again? ;
|
||||
|
||||
: init-merge-sets ( cfg -- )
|
||||
post-order dup length '[ _ <bit-set> ] H{ } map>assoc merge-sets set ;
|
||||
post-order dup length '[ _ <bit-set> ] H{ } map>assoc
|
||||
merge-sets namespaces:set ;
|
||||
|
||||
: compute-levels ( cfg -- )
|
||||
0 over entry>> associate [
|
||||
'[
|
||||
_ [ [ dom-parent ] dip at 1 + ] 2keep set-at
|
||||
] each-basic-block
|
||||
] keep levels set ;
|
||||
] keep levels namespaces:set ;
|
||||
|
||||
: j-edge? ( from to -- ? )
|
||||
2dup eq? [ 2drop f ] [ dominates? not ] if ;
|
||||
|
|
|
|||
|
|
@ -41,8 +41,8 @@ ERROR: vregs-shouldn't-interfere vreg1 vreg2 ;
|
|||
defs get [ [ dup dup value-of ] dip <vreg-info> 1array ] assoc-map ;
|
||||
|
||||
: init-coalescing ( insns -- )
|
||||
initial-leaders leader-map set
|
||||
initial-class-elements class-element-map set ;
|
||||
initial-leaders leader-map namespaces:set
|
||||
initial-class-elements class-element-map namespaces:set ;
|
||||
|
||||
GENERIC: coalesce-now ( insn -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -75,8 +75,8 @@ SYMBOLS: local-peek-set replaces ;
|
|||
: begin-local-analysis ( basic-block -- )
|
||||
height-state get dup reset-emits
|
||||
current-height rot record-stack-heights
|
||||
HS{ } clone local-peek-set set
|
||||
H{ } clone replaces set ;
|
||||
HS{ } clone local-peek-set namespaces:set
|
||||
H{ } clone replaces namespaces:set ;
|
||||
|
||||
: remove-redundant-replaces ( replaces -- replaces' )
|
||||
[ [ loc>vreg ] dip = ] assoc-reject ;
|
||||
|
|
|
|||
|
|
@ -54,9 +54,9 @@ M: ##copy eliminate-write-barrier
|
|||
M: insn eliminate-write-barrier drop t ;
|
||||
|
||||
: write-barriers-step ( insns -- insns' )
|
||||
HS{ } clone fresh-allocations set
|
||||
HS{ } clone mutated-objects set
|
||||
H{ } clone copies set
|
||||
HS{ } clone fresh-allocations namespaces:set
|
||||
HS{ } clone mutated-objects namespaces:set
|
||||
H{ } clone copies namespaces:set
|
||||
[ eliminate-write-barrier ] filter! ;
|
||||
|
||||
: eliminate-write-barriers ( cfg -- )
|
||||
|
|
|
|||
|
|
@ -74,8 +74,8 @@ GENERIC: check-stack-flow* ( node -- )
|
|||
[ check-stack-flow* terminated? get not ] all? drop ;
|
||||
|
||||
: init-stack-flow ( -- )
|
||||
V{ } clone datastack set
|
||||
V{ } clone retainstack set ;
|
||||
V{ } clone datastack namespaces:set
|
||||
V{ } clone retainstack namespaces:set ;
|
||||
|
||||
: check-stack-flow ( nodes -- )
|
||||
[
|
||||
|
|
@ -149,7 +149,7 @@ SYMBOL: branch-out
|
|||
: check-branch ( nodes -- stack )
|
||||
[
|
||||
datastack [ clone ] change
|
||||
V{ } clone retainstack set
|
||||
V{ } clone retainstack namespaces:set
|
||||
(check-stack-flow)
|
||||
terminated? get [ assert-retainstack-empty ] unless
|
||||
terminated? get f datastack get ?
|
||||
|
|
@ -157,7 +157,7 @@ SYMBOL: branch-out
|
|||
|
||||
M: #branch check-stack-flow*
|
||||
[ check-in-d ]
|
||||
[ children>> [ check-branch ] map branch-out set ]
|
||||
[ children>> [ check-branch ] map branch-out namespaces:set ]
|
||||
bi ;
|
||||
|
||||
: check-phi-in ( #phi -- )
|
||||
|
|
@ -174,7 +174,7 @@ M: #branch check-stack-flow*
|
|||
|
||||
: set-phi-datastack ( #phi -- )
|
||||
phi-in-d>> first length
|
||||
branch-out get [ ] find nip swap head* >vector datastack set ;
|
||||
branch-out get [ ] find nip swap head* >vector datastack namespaces:set ;
|
||||
|
||||
M: #phi check-stack-flow*
|
||||
branch-out get [ ] any? [
|
||||
|
|
|
|||
|
|
@ -18,8 +18,8 @@ SYMBOL: live-values
|
|||
: look-at-inputs ( node -- ) in-d>> look-at-values ;
|
||||
|
||||
: init-dead-code ( -- )
|
||||
<hashed-dlist> work-list set
|
||||
H{ { +bottom+ f } } clone live-values set ;
|
||||
<hashed-dlist> work-list namespaces:set
|
||||
H{ { +bottom+ f } } clone live-values namespaces:set ;
|
||||
|
||||
GENERIC: mark-live-values* ( node -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -18,8 +18,8 @@ SYMBOLS: visited accum ;
|
|||
|
||||
: with-simplified-def-use ( quot -- real-usages )
|
||||
[
|
||||
HS{ } clone visited set
|
||||
HS{ } clone accum set
|
||||
HS{ } clone visited namespaces:set
|
||||
HS{ } clone accum namespaces:set
|
||||
call
|
||||
accum get members
|
||||
] with-scope ; inline
|
||||
|
|
|
|||
|
|
@ -98,8 +98,8 @@ M: node compute-modular-candidates*
|
|||
drop ;
|
||||
|
||||
: compute-modular-candidates ( nodes -- )
|
||||
HS{ } clone modular-values set
|
||||
HS{ } clone fixnum-values set
|
||||
HS{ } clone modular-values namespaces:set
|
||||
HS{ } clone fixnum-values namespaces:set
|
||||
[ compute-modular-candidates* ] each-node ;
|
||||
|
||||
GENERIC: only-reads-low-order? ( node -- ? )
|
||||
|
|
|
|||
|
|
@ -35,8 +35,8 @@ GENERIC: node-call-graph ( tail? node -- )
|
|||
|
||||
: build-call-graph ( nodes -- labels calls )
|
||||
[
|
||||
V{ } clone children set
|
||||
V{ } clone calls set
|
||||
V{ } clone children namespaces:set
|
||||
V{ } clone calls namespaces:set
|
||||
[ t ] dip (build-call-graph)
|
||||
children get
|
||||
calls get
|
||||
|
|
@ -111,8 +111,8 @@ SYMBOL: changed?
|
|||
[ changed? get [ while-changing ] [ drop ] if ] bi ; inline recursive
|
||||
|
||||
: detect-loops ( call-graph -- )
|
||||
HS{ } clone not-loops set
|
||||
V{ } clone recursive-nesting set
|
||||
HS{ } clone not-loops namespaces:set
|
||||
V{ } clone recursive-nesting namespaces:set
|
||||
[ visit-back-edges ]
|
||||
[ '[ _ detect-cross-frame-calls ] while-changing ]
|
||||
bi ;
|
||||
|
|
@ -130,7 +130,7 @@ SYMBOL: call-graph
|
|||
|
||||
: analyze-recursive ( nodes -- nodes )
|
||||
dup build-call-graph drop
|
||||
[ call-graph set ]
|
||||
[ call-graph namespaces:set ]
|
||||
[ detect-loops ]
|
||||
[ mark-loops ]
|
||||
tri ;
|
||||
|
|
|
|||
|
|
@ -93,12 +93,12 @@ M: user-saver dispose
|
|||
<user-saver> &dispose drop ;
|
||||
|
||||
: init-user ( user -- )
|
||||
[ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
|
||||
[ [ logged-in-user namespaces:set ] [ save-user-after ] bi ] when* ;
|
||||
|
||||
\ init-user DEBUG add-input-logging
|
||||
|
||||
M: realm call-responder* ( path responder -- response )
|
||||
dup realm set
|
||||
dup realm namespaces:set
|
||||
logged-in? [
|
||||
dup init-realm
|
||||
dup logged-in-username
|
||||
|
|
@ -147,7 +147,7 @@ TUPLE: protected < filter-responder description capabilities ;
|
|||
] if ;
|
||||
|
||||
M: protected call-responder* ( path responder -- response )
|
||||
dup protected set
|
||||
dup protected namespaces:set
|
||||
dup capabilities>> have-capabilities?
|
||||
[ call-next-method ] [
|
||||
[ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
|
||||
|
|
|
|||
|
|
@ -29,11 +29,11 @@ SYMBOL: blank-line
|
|||
and [ nl ] when ;
|
||||
|
||||
: ($blank-line) ( -- )
|
||||
nl nl blank-line last-element set ;
|
||||
nl nl blank-line last-element namespaces:set ;
|
||||
|
||||
: ($span) ( quot -- )
|
||||
last-block? [ nl ] when
|
||||
span last-element set
|
||||
span last-element namespaces:set
|
||||
call ; inline
|
||||
|
||||
GENERIC: print-element ( element -- )
|
||||
|
|
@ -58,9 +58,9 @@ M: f print-element drop ;
|
|||
|
||||
: ($block) ( quot -- )
|
||||
?nl
|
||||
span last-element set
|
||||
span last-element namespaces:set
|
||||
call
|
||||
block last-element set ; inline
|
||||
block last-element namespaces:set ; inline
|
||||
|
||||
! Some spans
|
||||
|
||||
|
|
@ -84,7 +84,7 @@ ALIAS: $slot $snippet
|
|||
|
||||
: $nl ( children -- )
|
||||
drop nl last-element get [ nl ] when
|
||||
blank-line last-element set ;
|
||||
blank-line last-element namespaces:set ;
|
||||
|
||||
! Some blocks
|
||||
: ($heading) ( children quot -- )
|
||||
|
|
|
|||
|
|
@ -140,8 +140,8 @@ ERROR: unknown-chloe-tag tag ;
|
|||
|
||||
: with-compiler ( quot -- quot' )
|
||||
[
|
||||
SBUF" " string-buffer set
|
||||
V{ } clone tag-stack set
|
||||
SBUF" " string-buffer namespaces:set
|
||||
V{ } clone tag-stack namespaces:set
|
||||
call
|
||||
reset-buffer
|
||||
] [ ] make ; inline
|
||||
|
|
@ -152,7 +152,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
: compile-quot ( quot -- )
|
||||
reset-buffer
|
||||
[
|
||||
SBUF" " string-buffer set
|
||||
SBUF" " string-buffer namespaces:set
|
||||
call
|
||||
reset-buffer
|
||||
] [ ] make , ; inline
|
||||
|
|
|
|||
|
|
@ -69,11 +69,11 @@ SYMBOL: inspector-stack
|
|||
SYMBOL: sorted-keys
|
||||
|
||||
: reinspect ( obj -- )
|
||||
[ me set ]
|
||||
[ me namespaces:set ]
|
||||
[
|
||||
dup make-mirror dup mirror set
|
||||
dup make-mirror dup mirror namespaces:set
|
||||
t +number-rows+ [ (describe) ] with-variable
|
||||
sorted-keys set
|
||||
sorted-keys namespaces:set
|
||||
] bi ;
|
||||
|
||||
: (inspect) ( obj -- )
|
||||
|
|
@ -118,7 +118,7 @@ PRIVATE>
|
|||
|
||||
: inspector ( obj -- )
|
||||
&help
|
||||
V{ } clone inspector-stack set
|
||||
V{ } clone inspector-stack namespaces:set
|
||||
(inspect) ;
|
||||
|
||||
: inspect ( obj -- )
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ M: f >insecure ;
|
|||
|
||||
: log-connection ( remote local -- )
|
||||
[ accepted-connection ]
|
||||
[ [ remote-address set ] [ local-address set ] bi* ]
|
||||
[ [ remote-address namespaces:set ] [ local-address namespaces:set ] bi* ]
|
||||
2bi ;
|
||||
|
||||
M: threaded-server handle-client* handler>> call( -- ) ;
|
||||
|
|
|
|||
|
|
@ -112,9 +112,9 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
|
||||
: process-rule-result ( p result -- result )
|
||||
[
|
||||
nip [ ast>> ] [ remaining>> ] bi input-from pos set
|
||||
nip [ ast>> ] [ remaining>> ] bi input-from pos namespaces:set
|
||||
] [
|
||||
pos set fail
|
||||
pos namespaces:set fail
|
||||
] if* ;
|
||||
|
||||
: eval-rule ( rule -- ast )
|
||||
|
|
@ -139,7 +139,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
pos>> <= or ;
|
||||
|
||||
: setup-growth ( h p -- )
|
||||
pos set dup involved-set>> clone >>eval-set drop ;
|
||||
pos namespaces:set dup involved-set>> clone >>eval-set drop ;
|
||||
|
||||
: (grow-lr) ( h p r: ( -- result ) m -- )
|
||||
[ [ setup-growth ] 2keep ] 2dip
|
||||
|
|
@ -155,7 +155,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
[ [ heads set-at ] 2keep ] 2dip
|
||||
pick over [ (grow-lr) ] 2dip
|
||||
swap heads delete-at
|
||||
dup pos>> pos set ans>>
|
||||
dup pos>> pos namespaces:set ans>>
|
||||
; inline
|
||||
|
||||
:: (setup-lr) ( l s -- )
|
||||
|
|
@ -209,9 +209,9 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
|
||||
:: apply-non-memo-rule ( r p -- ast )
|
||||
fail r rule-id f lrstack get left-recursion boa :> lr
|
||||
lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
|
||||
lr lrstack namespaces:set lr p memo-entry boa dup p r rule-id set-memo :> m
|
||||
r eval-rule :> ans
|
||||
lrstack get next>> lrstack set
|
||||
lrstack get next>> lrstack namespaces:set
|
||||
pos get m pos<<
|
||||
lr head>> [
|
||||
m ans>> left-recursion? [
|
||||
|
|
@ -224,7 +224,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
|||
] if ; inline
|
||||
|
||||
: apply-memo-rule ( r m -- ast )
|
||||
[ ans>> ] [ pos>> ] bi pos set
|
||||
[ ans>> ] [ pos>> ] bi pos namespaces:set
|
||||
dup left-recursion? [
|
||||
[ setup-lr ] keep seed>>
|
||||
] [
|
||||
|
|
@ -497,7 +497,7 @@ TUPLE: sp-parser parser ;
|
|||
|
||||
M: sp-parser (compile)
|
||||
parser>> compile-parser-quot '[
|
||||
input-slice [ blank? ] trim-head-slice input-from pos set @
|
||||
input-slice [ blank? ] trim-head-slice input-from pos namespaces:set @
|
||||
] ;
|
||||
|
||||
TUPLE: delay-parser quot ;
|
||||
|
|
|
|||
|
|
@ -326,8 +326,8 @@ SYMBOL: next
|
|||
: group-flow ( seq -- newseq )
|
||||
[
|
||||
dup length iota [
|
||||
2dup 1 - swap ?nth prev set
|
||||
2dup 1 + swap ?nth next set
|
||||
2dup 1 - swap ?nth prev namespaces:set
|
||||
2dup 1 + swap ?nth next namespaces:set
|
||||
swap nth dup split-before dup , split-after
|
||||
] with each
|
||||
] { } make { t } split harvest ;
|
||||
|
|
@ -358,10 +358,10 @@ M: block long-section ( block -- )
|
|||
|
||||
: make-pprint ( obj quot manifest? -- block manifest/f )
|
||||
[
|
||||
0 position set
|
||||
HS{ } clone pprinter-use set
|
||||
V{ } clone recursion-check set
|
||||
V{ } clone pprinter-stack set
|
||||
0 position namespaces:set
|
||||
HS{ } clone pprinter-use namespaces:set
|
||||
V{ } clone recursion-check namespaces:set
|
||||
V{ } clone pprinter-stack namespaces:set
|
||||
|
||||
[ over <object call pprinter-block ] dip
|
||||
[ pprinter-manifest ] [ f ] if
|
||||
|
|
|
|||
|
|
@ -158,8 +158,8 @@ M: with-options nfa-node ( node -- start end )
|
|||
|
||||
: construct-nfa ( ast -- nfa-table )
|
||||
[
|
||||
0 state set
|
||||
<transition-table> nfa-table set
|
||||
0 state namespaces:set
|
||||
<transition-table> nfa-table namespaces:set
|
||||
nfa-node
|
||||
nfa-table get
|
||||
swap 1array fast-set >>final-states
|
||||
|
|
|
|||
|
|
@ -20,8 +20,8 @@ GENERIC: see* ( defspec -- )
|
|||
: synopsis ( defspec -- str )
|
||||
[
|
||||
string-limit? off
|
||||
0 margin set
|
||||
1 line-limit set
|
||||
0 margin namespaces:set
|
||||
1 line-limit namespaces:set
|
||||
[ synopsis* ] with-in
|
||||
] with-string-writer ;
|
||||
|
||||
|
|
@ -46,7 +46,7 @@ M: word print-stack-effect? drop t ;
|
|||
<PRIVATE
|
||||
|
||||
: seeing-word ( word -- )
|
||||
vocabulary>> dup [ lookup-vocab ] when pprinter-in set ;
|
||||
vocabulary>> dup [ lookup-vocab ] when pprinter-in namespaces:set ;
|
||||
|
||||
: word-synopsis ( word -- )
|
||||
{
|
||||
|
|
@ -92,7 +92,8 @@ M: pathname synopsis* pprint* ;
|
|||
|
||||
M: alias summary
|
||||
[
|
||||
0 margin set 1 line-limit set
|
||||
0 margin namespaces:set
|
||||
1 line-limit namespaces:set
|
||||
[
|
||||
{
|
||||
[ seeing-word ]
|
||||
|
|
@ -127,8 +128,8 @@ M: word declarations.
|
|||
|
||||
M: object see*
|
||||
[
|
||||
12 nesting-limit set
|
||||
100 length-limit set
|
||||
12 nesting-limit namespaces:set
|
||||
100 length-limit namespaces:set
|
||||
<colon dup synopsis*
|
||||
<block dup definition pprint-elements block>
|
||||
dup definer nip [ pprint-word ] when* declarations.
|
||||
|
|
|
|||
|
|
@ -147,9 +147,9 @@ M: depends-on-final satisfied?
|
|||
class>> { [ class? ] [ final-class? ] } 1&& ;
|
||||
|
||||
: init-dependencies ( -- )
|
||||
H{ } clone dependencies set
|
||||
H{ } clone generic-dependencies set
|
||||
HS{ } clone conditional-dependencies set ;
|
||||
H{ } clone dependencies namespaces:set
|
||||
H{ } clone generic-dependencies namespaces:set
|
||||
HS{ } clone conditional-dependencies namespaces:set ;
|
||||
|
||||
: without-dependencies ( quot -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -619,7 +619,7 @@ SYMBOL: deploy-vocab
|
|||
"ui.debugger" require
|
||||
] when
|
||||
] unless
|
||||
[ deploy-vocab set ] [ require ] [
|
||||
[ deploy-vocab namespaces:set ] [ require ] [
|
||||
vocab-main [
|
||||
"Vocabulary has no MAIN: word." print flush 1 exit
|
||||
] unless
|
||||
|
|
|
|||
|
|
@ -269,10 +269,10 @@ SYMBOL: drag-timer
|
|||
dup multi-click? [
|
||||
hand-click# inc
|
||||
] [
|
||||
1 hand-click# set
|
||||
1 hand-click# namespaces:set
|
||||
] if
|
||||
hand-last-button set
|
||||
nano-count hand-last-time set
|
||||
hand-last-button namespaces:set
|
||||
nano-count hand-last-time namespaces:set
|
||||
] with-global ;
|
||||
|
||||
: update-clicked ( -- )
|
||||
|
|
|
|||
|
|
@ -20,11 +20,11 @@ SYMBOL: viewport-translation
|
|||
: init-clip ( gadget -- )
|
||||
[
|
||||
dim>>
|
||||
[ { 0 1 } v* viewport-translation set ]
|
||||
[ { 0 1 } v* viewport-translation namespaces:set ]
|
||||
[ [ { 0 0 } ] dip gl-viewport ]
|
||||
[ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
|
||||
]
|
||||
[ clip set ] bi
|
||||
[ clip namespaces:set ] bi
|
||||
do-clip ;
|
||||
|
||||
SLOT: background-color
|
||||
|
|
@ -87,7 +87,7 @@ M: gadget gadget-foreground dup interior>> pen-foreground ;
|
|||
<PRIVATE
|
||||
|
||||
: draw-selection-background ( gadget -- )
|
||||
selection-background get background set
|
||||
selection-background get background namespaces:set
|
||||
selection-background get gl-color
|
||||
[ { 0 0 } ] dip dim>> gl-fill-rect ;
|
||||
|
||||
|
|
@ -122,7 +122,8 @@ PRIVATE>
|
|||
>absolute clip [ rect-intersect ] change ;
|
||||
|
||||
: with-clipping ( gadget quot -- )
|
||||
clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
|
||||
clip get [ over change-clip do-clip call ] dip
|
||||
clip namespaces:set do-clip ; inline
|
||||
|
||||
: draw-gadget ( gadget -- )
|
||||
{
|
||||
|
|
@ -141,10 +142,10 @@ M: gadget draw-children
|
|||
} cleave [
|
||||
|
||||
{
|
||||
[ [ selected-gadgets set ] when* ]
|
||||
[ [ selection-background set ] when* ]
|
||||
[ [ background set ] when* ]
|
||||
[ [ foreground set ] when* ]
|
||||
[ [ selected-gadgets namespaces:set ] when* ]
|
||||
[ [ selection-background namespaces:set ] when* ]
|
||||
[ [ background namespaces:set ] when* ]
|
||||
[ [ foreground namespaces:set ] when* ]
|
||||
} spread
|
||||
[ draw-gadget ] each
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -121,8 +121,8 @@ DEFER: make-tag ! Is this unavoidable?
|
|||
|
||||
: take-internal-subset ( -- dtd )
|
||||
[
|
||||
H{ } clone pe-table set
|
||||
t in-dtd? set
|
||||
H{ } clone pe-table namespaces:set
|
||||
t in-dtd? namespaces:set
|
||||
dtd-loop
|
||||
pe-table get
|
||||
] { } make swap extra-entities get swap <dtd> ;
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ M: closer process
|
|||
<tag> add-child ;
|
||||
|
||||
: init-xml-stack ( -- )
|
||||
V{ } clone xml-stack set
|
||||
V{ } clone xml-stack namespaces:set
|
||||
f push-xml ;
|
||||
|
||||
: default-prolog ( -- prolog )
|
||||
|
|
@ -125,7 +125,7 @@ TUPLE: pull-xml scope ;
|
|||
scope>> [
|
||||
text-now? get [ parse-text f ] [
|
||||
get-char [ make-tag t ] [ f f ] if
|
||||
] if text-now? set
|
||||
] if text-now? namespaces:set
|
||||
] with-variables ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -157,7 +157,7 @@ PRIVATE>
|
|||
|
||||
: read-seq ( stream quot n -- seq )
|
||||
rot [
|
||||
depth set
|
||||
depth namespaces:set
|
||||
init-xml init-xml-stack
|
||||
call
|
||||
[ process ] xml-loop
|
||||
|
|
@ -200,7 +200,7 @@ PRIVATE>
|
|||
|
||||
: read-dtd ( stream -- dtd )
|
||||
[
|
||||
H{ } clone extra-entities set
|
||||
H{ } clone extra-entities namespaces:set
|
||||
take-internal-subset
|
||||
] with-state ;
|
||||
|
||||
|
|
|
|||
|
|
@ -24,12 +24,12 @@ SYMBOL: class-or-cache
|
|||
SYMBOL: next-method-quot-cache
|
||||
|
||||
: init-caches ( -- )
|
||||
H{ } clone class<=-cache set
|
||||
H{ } clone class-not-cache set
|
||||
H{ } clone classes-intersect-cache set
|
||||
H{ } clone class-and-cache set
|
||||
H{ } clone class-or-cache set
|
||||
H{ } clone next-method-quot-cache set ;
|
||||
H{ } clone class<=-cache namespaces:set
|
||||
H{ } clone class-not-cache namespaces:set
|
||||
H{ } clone classes-intersect-cache namespaces:set
|
||||
H{ } clone class-and-cache namespaces:set
|
||||
H{ } clone class-or-cache namespaces:set
|
||||
H{ } clone next-method-quot-cache namespaces:set ;
|
||||
|
||||
: reset-caches ( -- )
|
||||
class<=-cache get clear-assoc
|
||||
|
|
|
|||
|
|
@ -177,7 +177,7 @@ M: nesting-observer definitions-changed
|
|||
|
||||
: add-nesting-observer ( -- )
|
||||
new-words get nesting-observer boa
|
||||
[ nesting-observer set ] [ add-definition-observer ] bi ;
|
||||
[ nesting-observer namespaces:set ] [ add-definition-observer ] bi ;
|
||||
|
||||
: remove-nesting-observer ( -- )
|
||||
nesting-observer get remove-definition-observer ;
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: assocs hashtables kernel math sequences vectors ;
|
||||
IN: sets
|
||||
|
||||
! Set protocol
|
||||
MIXIN: set
|
||||
|
||||
GENERIC: adjoin ( elt set -- )
|
||||
|
|
|
|||
|
|
@ -71,8 +71,8 @@ SYMBOL: current-source-file
|
|||
H{ } clone [
|
||||
[
|
||||
path>source-file
|
||||
[ current-source-file set ]
|
||||
[ definitions>> old-definitions set ] bi
|
||||
[ current-source-file namespaces:set ]
|
||||
[ definitions>> old-definitions namespaces:set ] bi
|
||||
] dip
|
||||
[ wrap-source-file-error ] recover
|
||||
] with-variables ; inline
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ SYMBOL: terms
|
|||
|
||||
: with-terms ( quot -- hash )
|
||||
[
|
||||
H{ } clone terms set call terms get canonicalize
|
||||
H{ } clone terms namespaces:set call terms get canonicalize
|
||||
] with-scope ; inline
|
||||
|
||||
! Printing elements
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ PRIVATE>
|
|||
[ username server clients>> delete-at ] when-logged-in ;
|
||||
|
||||
: handle-managed-client ( -- )
|
||||
handle-login <managed-client> managed-client set
|
||||
handle-login <managed-client> managed-client namespaces:set
|
||||
maybe-login-client [
|
||||
handle-client-join
|
||||
[ handle-managed-client* client quit?>> not ] loop
|
||||
|
|
@ -92,7 +92,7 @@ PRIVATE>
|
|||
PRIVATE>
|
||||
|
||||
M: managed-server handle-client*
|
||||
managed-server set
|
||||
managed-server namespaces:set
|
||||
[ handle-managed-client ]
|
||||
[ cleanup-client ]
|
||||
[ ] cleanup ;
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@ IN: project-euler.051
|
|||
SYMBOL: family-count
|
||||
SYMBOL: large-families
|
||||
: reset-globals ( -- )
|
||||
H{ } clone family-count set
|
||||
H{ } clone large-families set ;
|
||||
H{ } clone family-count namespaces:set
|
||||
H{ } clone large-families namespaces:set ;
|
||||
|
||||
: digits-positions ( str -- positions )
|
||||
H{ } clone [ '[ swap _ push-at ] each-index ] keep ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue