diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 2947362430..d340c21663 100755 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -42,12 +42,17 @@ SYMBOL: +failed+ [ compiled-unxref ] [ dup crossref? - [ dependencies get compiled-xref ] [ drop ] if + [ + dependencies get + generic-dependencies get + compiled-xref + ] [ drop ] if ] tri ; : (compile) ( word -- ) '[ H{ } clone dependencies set + H{ } clone generic-dependencies set , { [ compile-begins ] diff --git a/basis/compiler/tests/insane.factor b/basis/compiler/tests/insane.factor index 4c87f73722..aa79067252 100644 --- a/basis/compiler/tests/insane.factor +++ b/basis/compiler/tests/insane.factor @@ -1,4 +1,5 @@ IN: compiler.tests -USING: words kernel stack-checker alien.strings tools.test ; +USING: words kernel stack-checker alien.strings tools.test +compiler.units ; -[ ] [ \ if redefined [ string>alien ] infer. ] unit-test +[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor new file mode 100644 index 0000000000..8a6fb8a313 --- /dev/null +++ b/basis/compiler/tests/redefine10.factor @@ -0,0 +1,29 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math classes ; + IN: compiler.tests.redefine10 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine10 + INSTANCE: float my-mixin + "> eval +] unit-test + +[ 2.0 ] [ + 1.0 "my-inline" "compiler.tests.redefine10" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor new file mode 100644 index 0000000000..18b1a3a430 --- /dev/null +++ b/basis/compiler/tests/redefine11.factor @@ -0,0 +1,32 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel classes.mixin arrays ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math classes arrays ; + IN: compiler.tests.redefine11 + MIXIN: my-mixin + INSTANCE: array my-mixin + INSTANCE: fixnum my-mixin + GENERIC: my-generic ( a -- b ) + M: my-mixin my-generic drop 0 ; + M: object my-generic drop 1 ; + : my-inline ( -- b ) { } my-generic ; + "> eval +] unit-test + +[ ] [ + [ + array "my-mixin" "compiler.tests.redefine11" lookup + remove-mixin-instance + ] with-compilation-unit +] unit-test + +[ 1 ] [ + "my-inline" "compiler.tests.redefine11" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor new file mode 100644 index 0000000000..73225c55b8 --- /dev/null +++ b/basis/compiler/tests/redefine6.factor @@ -0,0 +1,33 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel kernel.private ; + IN: compiler.tests.redefine6 + GENERIC: my-generic ( a -- b ) + MIXIN: my-mixin + M: my-mixin my-generic drop 0 ; + : my-inline ( a -- b ) { my-mixin } declare my-generic ; + "> eval +] unit-test + +[ ] [ + <" + USING: kernel ; + IN: compiler.tests.redefine6 + TUPLE: my-tuple ; + M: my-tuple my-generic drop 1 ; + INSTANCE: my-tuple my-mixin + "> eval +] unit-test + +[ 1 ] [ + "my-tuple" "compiler.tests.redefine6" lookup boa + "my-inline" "compiler.tests.redefine6" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor new file mode 100644 index 0000000000..164a2e3831 --- /dev/null +++ b/basis/compiler/tests/redefine7.factor @@ -0,0 +1,29 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math ; + IN: compiler.tests.redefine7 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine7 + INSTANCE: float my-mixin + "> eval +] unit-test + +[ 2.0 ] [ + 1.0 "my-inline" "compiler.tests.redefine7" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor new file mode 100644 index 0000000000..c8b3377632 --- /dev/null +++ b/basis/compiler/tests/redefine8.factor @@ -0,0 +1,32 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math math.order sorting ; + IN: compiler.tests.redefine8 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + GENERIC: my-generic ( a -- b ) + ! We add the bogus quotation here to hinder inlining + ! since otherwise we cannot trigger this bug. + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine8 + INSTANCE: float my-mixin + "> eval +] unit-test + +[ 2.0 ] [ + 1.0 "my-generic" "compiler.tests.redefine8" lookup execute +] unit-test diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor new file mode 100644 index 0000000000..7b0f8a2e9c --- /dev/null +++ b/basis/compiler/tests/redefine9.factor @@ -0,0 +1,35 @@ +USING: eval tools.test compiler.units vocabs multiline words +kernel generic.math ; +IN: compiler.tests + +! Mixin redefinition did not recompile all necessary words. + +[ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test + +[ ] [ + <" + USING: kernel math math.order sorting ; + IN: compiler.tests.redefine9 + MIXIN: my-mixin + INSTANCE: fixnum my-mixin + GENERIC: my-generic ( a -- b ) + ! We add the bogus quotation here to hinder inlining + ! since otherwise we cannot trigger this bug. + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; + "> eval +] unit-test + +[ ] [ + <" + USE: math + IN: compiler.tests.redefine9 + TUPLE: my-tuple ; + INSTANCE: my-tuple my-mixin + "> eval +] unit-test + +[ + "my-tuple" "compiler.tests.redefine9" lookup boa + "my-generic" "compiler.tests.redefine9" lookup + execute +] [ no-math-method? ] must-fail-with diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 003bd1cc69..8056e75b3e 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -42,7 +42,7 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup-folding ( #call -- nodes ) #! Replace a #call having a known result with a #drop of its #! inputs followed by #push nodes for the outputs. - [ word>> +inlined+ depends-on ] + [ word>> inlined-dependency depends-on ] [ [ node-output-infos ] [ out-d>> ] bi [ [ literal>> ] dip #push ] 2map @@ -50,11 +50,16 @@ GENERIC: cleanup* ( node -- node/nodes ) [ in-d>> #drop ] tri prefix ; +: add-method-dependency ( #call -- ) + dup method>> word? [ + [ word>> ] [ class>> ] bi depends-on-generic + ] [ drop ] if ; + : cleanup-inlining ( #call -- nodes ) [ dup method>> - [ method>> dup word? [ +called+ depends-on ] [ drop ] if ] - [ word>> +inlined+ depends-on ] if + [ add-method-dependency ] + [ word>> inlined-dependency depends-on ] if ] [ body>> cleanup ] bi ; ! Removing overflow checks diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 2bcf91e6ab..3ea9139e5f 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -106,7 +106,7 @@ M: #push remove-dead-code* ] [ drop f ] if ; : remove-flushable-call ( #call -- node ) - [ word>> +inlined+ depends-on ] + [ word>> flushed-dependency depends-on ] [ in-d>> #drop remove-dead-code* ] bi ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index e01d12ac23..09f50b21ea 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -24,18 +24,19 @@ M: quotation splicing-nodes body>> (propagate) ; ! Dispatch elimination -: eliminate-dispatch ( #call word/quot/f -- ? ) - [ +: eliminate-dispatch ( #call class/f word/f -- ? ) + dup [ + [ >>class ] dip over method>> over = [ drop ] [ 2dup splicing-nodes [ >>method ] [ >>body ] bi* ] if propagate-body t - ] [ f >>method f >>body drop f ] if* ; + ] [ 2drop f >>method f >>body f >>class drop f ] if ; -: inlining-standard-method ( #call word -- method/f ) +: inlining-standard-method ( #call word -- class/f method/f ) [ in-d>> ] [ [ dispatch# ] keep ] bi* - [ swap nth value-info class>> ] dip + [ swap nth value-info class>> dup ] dip specific-method ; : inline-standard-method ( #call word -- ? ) @@ -51,15 +52,17 @@ M: quotation splicing-nodes object } [ class<= ] with find nip ; -: inlining-math-method ( #call word -- quot/f ) +: inlining-math-method ( #call word -- class/f quot/f ) swap in-d>> first2 [ value-info class>> normalize-math-class ] bi@ - 3dup math-both-known? [ math-method* ] [ 3drop f ] if ; + 3dup math-both-known? + [ math-method* ] [ 3drop f ] if + number swap ; : inline-math-method ( #call word -- ? ) dupd inlining-math-method eliminate-dispatch ; -: inlining-math-partial ( #call word -- quot/f ) +: inlining-math-partial ( #call word -- class/f quot/f ) [ "derived-from" word-prop first inlining-math-method ] [ nip 1quotation ] 2bi [ = not ] [ drop ] 2bi and ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d9fc18acb0..23323e107d 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -5,6 +5,8 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private +definitions +stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -280,6 +282,14 @@ generic-comparison-ops [ ] +constraints+ set-word-prop \ instance? [ + ! We need to force the caller word to recompile when the class + ! is redefined, since now we're making assumptions but the + ! class definition itself. dup literal>> class? - [ literal>> predicate-output-infos ] [ 2drop object-info ] if + [ + literal>> + [ inlined-dependency depends-on ] + [ predicate-output-infos ] + bi + ] [ 2drop object-info ] if ] +outputs+ set-word-prop diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 48a4b478e6..d664ae5ccf 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors kernel sequences sequences.private assocs words namespaces classes.algebra combinators classes classes.tuple -classes.tuple.private continuations arrays byte-arrays strings -math math.partial-dispatch math.private slots generic +classes.tuple.private continuations arrays +math math.partial-dispatch math.private slots generic definitions generic.standard generic.math +stack-checker.state compiler.tree compiler.tree.propagation.info compiler.tree.propagation.nodes @@ -32,7 +33,14 @@ M: #push propagate-before [ set-value-info ] 2each ; M: #declare propagate-before - declaration>> [ swap refine-value-info ] assoc-each ; + #! We need to force the caller word to recompile when the + #! classes mentioned in the declaration are redefined, since + #! now we're making assumptions but their definitions. + declaration>> [ + [ inlined-dependency depends-on ] + [ swap refine-value-info ] + bi + ] assoc-each ; : predicate-constraints ( value class boolean-value -- constraint ) [ [ is-instance-of ] dip t--> ] @@ -74,7 +82,11 @@ M: #declare propagate-before } cond 2nip ; : propagate-predicate ( #call word -- infos ) - [ in-d>> first value-info ] [ "predicating" word-prop ] bi* + #! We need to force the caller word to recompile when the class + #! is redefined, since now we're making assumptions but the + #! class definition itself. + [ in-d>> first value-info ] + [ "predicating" word-prop dup inlined-dependency depends-on ] bi* predicate-output-infos 1array ; : default-output-value-infos ( #call word -- infos ) diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 9234aa5d86..2bb3fa0cfc 100755 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -17,7 +17,7 @@ TUPLE: #introduce < node out-d ; : #introduce ( out-d -- node ) \ #introduce new swap >>out-d ; -TUPLE: #call < node word in-d out-d body method info ; +TUPLE: #call < node word in-d out-d body method class info ; : #call ( inputs outputs word -- node ) \ #call new diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 92dede1655..67f9bbb15a 100755 --- a/basis/concurrency/locks/locks-tests.factor +++ b/basis/concurrency/locks/locks-tests.factor @@ -174,7 +174,7 @@ threads sequences calendar accessors ; ] ; [ lock-timeout-test ] [ - linked-error-thread name>> "Lock timeout-er" = + thread>> name>> "Lock timeout-er" = ] must-fail-with :: read/write-test ( -- ) diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 95b6801db2..8c1392dbfb 100755 --- a/basis/concurrency/locks/locks.factor +++ b/basis/concurrency/locks/locks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: deques dlists kernel threads continuations math -concurrency.conditions ; +concurrency.conditions combinators.short-circuit accessors ; IN: concurrency.locks ! Simple critical sections @@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ; r lock-threads r> "lock" wait ] when drop - self swap set-lock-owner ; + over owner>> + [ 2dup >r threads>> r> "lock" wait ] when drop + self >>owner drop ; : release-lock ( lock -- ) - f over set-lock-owner - lock-threads notify-1 ; + f >>owner + threads>> notify-1 ; : do-lock ( lock timeout quot acquire release -- ) >r >r pick rot r> call ! use up timeout acquire @@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ; PRIVATE> : with-lock-timeout ( lock timeout quot -- ) - pick lock-reentrant? [ - pick lock-owner self eq? [ + pick reentrant?>> [ + pick owner>> self eq? [ 2nip call ] [ (with-lock) @@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> "read lock" wait ] when drop + over writer>> + [ 2dup >r readers>> r> "read lock" wait ] when drop add-reader ; : notify-writer ( lock -- ) - rw-lock-writers notify-1 ; + writers>> notify-1 ; : remove-reader ( lock -- ) - dup rw-lock-reader# 1- swap set-rw-lock-reader# ; + [ 1- ] change-reader# drop ; : release-read-lock ( lock -- ) dup remove-reader - dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; + dup reader#>> zero? [ notify-writer ] [ drop ] if ; : acquire-write-lock ( lock timeout -- ) - over rw-lock-writer pick rw-lock-reader# 0 > or - [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop - self swap set-rw-lock-writer ; + over writer>> pick reader#>> 0 > or + [ 2dup >r writers>> r> "write lock" wait ] when drop + self >>writer drop ; : release-write-lock ( lock -- ) - f over set-rw-lock-writer - dup rw-lock-readers deque-empty? - [ notify-writer ] [ rw-lock-readers notify-all ] if ; + f >>writer + dup readers>> deque-empty? + [ notify-writer ] [ readers>> notify-all ] if ; : reentrant-read-lock-ok? ( lock -- ? ) #! If we already have a write lock, then we can grab a read #! lock too. - rw-lock-writer self eq? ; + writer>> self eq? ; : reentrant-write-lock-ok? ( lock -- ? ) #! The only case where we have a writer and > 1 reader is #! write -> read re-entrancy, and in this case we prohibit #! a further write -> read -> write re-entrancy. - dup rw-lock-writer self eq? - swap rw-lock-reader# zero? and ; + { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ; PRIVATE> diff --git a/basis/concurrency/messaging/messaging-tests.factor b/basis/concurrency/messaging/messaging-tests.factor index b5c022effe..0f9f97c4cc 100755 --- a/basis/concurrency/messaging/messaging-tests.factor +++ b/basis/concurrency/messaging/messaging-tests.factor @@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes concurrency.count-downs accessors ; IN: concurrency.messaging.tests -[ ] [ my-mailbox mailbox-data clear-deque ] unit-test +[ ] [ my-mailbox data>> clear-deque ] unit-test [ "received" ] [ [ diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 877de30748..65120a5d01 100755 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -18,5 +18,5 @@ IN: help.syntax : ABOUT: scan-object in get vocab - dup +inlined+ changed-definition + dup changed-definition set-vocab-help ; parsing diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 59626a4f8a..28bce0ec42 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -55,7 +55,7 @@ IN: hints : HINTS: scan-word - [ +inlined+ changed-definition ] + [ redefined ] [ parse-definition "specializer" set-word-prop ] bi ; parsing diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index cf671c5609..1cc418a1f6 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces parser lexer kernel sequences words quotations math ; +USING: namespaces parser lexer kernel sequences words quotations math +accessors ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line lexer-line-text ; + lexer get dup next-line text>> ; : (parse-here) ( -- ) next-line-text [ @@ -22,7 +23,7 @@ IN: multiline parse-here 1quotation define-inline ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get lexer-line-text [ + lexer get text>> [ 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 @@ -32,8 +33,8 @@ IN: multiline : parse-multiline-string ( end-text -- str ) [ - lexer get lexer-column swap (parse-multiline-string) - lexer get set-lexer-column + lexer get column>> swap (parse-multiline-string) + lexer get (>>column) ] "" make rest but-last ; : <" diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 6ad883cfcb..9bffb34ed1 100755 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -195,11 +195,11 @@ DEFER: parse-error-file : string-layout { - "USING: debugger io kernel lexer ;" + "USING: accessors debugger io kernel ;" "IN: prettyprint.tests" ": string-layout-test ( error -- )" - " \"Expected \" write dup unexpected-want expected>string write" - " \" but got \" write unexpected-got expected>string print ;" + " \"Expected \" write dup want>> expected>string write" + " \" but got \" write got>> expected>string print ;" } ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index 168e118d4b..aed476b5c6 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -115,10 +115,10 @@ M: object short-section? section-fits? ; : pprint-section ( section -- ) dup short-section? [ - dup section-style [ short-section ] with-style + dup style>> [ short-section ] with-style ] [ [ > [ long-section ] with-style ] [ long-section> ] tri ] if ; diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 6a67b132c0..4d0fd6d8aa 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -8,29 +8,6 @@ sets generic.standard.engines.tuple stack-checker.state stack-checker.visitor stack-checker.errors ; IN: stack-checker.backend -! Word properties we use -SYMBOL: visited - -: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline - -: (redefined) ( word -- ) - dup visited get key? [ drop ] [ - [ reset-on-redefine reset-props ] - [ visited get conjoin ] - [ - crossref get at keys - [ word? ] filter - [ - [ reset-on-redefine [ word-prop ] with contains? ] - [ inline? ] - bi or - ] filter - [ (redefined) ] each - ] tri - ] if ; - -M: word redefined H{ } clone visited [ (redefined) ] with-variable ; - : push-d ( obj -- ) meta-d get push ; : pop-d ( -- obj ) @@ -72,7 +49,7 @@ GENERIC: apply-object ( obj -- ) M: wrapper apply-object wrapped>> - [ dup word? [ +called+ depends-on ] [ drop ] if ] + [ dup word? [ called-dependency depends-on ] [ drop ] if ] [ push-literal ] bi ; @@ -175,6 +152,7 @@ M: object apply-object push-literal ; init-known-values stack-visitor off dependencies off + generic-dependencies off [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ] [ finish-word current-effect ] bi diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 6523598cff..07ff016b2d 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -140,7 +140,7 @@ SYMBOL: enter-out ] [ undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) - [ +inlined+ depends-on ] + [ inlined-dependency depends-on ] [ { { [ dup inline-recursive-label ] [ call-recursive-inline-word ] } diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 11e7a0d7fd..c01236fba9 100755 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -176,7 +176,7 @@ do-primitive alien-invoke alien-indirect alien-callback SYMBOL: +primitive+ : non-inline-word ( word -- ) - dup +called+ depends-on + dup called-dependency depends-on { { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } { [ dup "special" word-prop ] [ infer-special ] } diff --git a/basis/stack-checker/state/state-tests.factor b/basis/stack-checker/state/state-tests.factor index 91382dfb99..a4dea993c0 100644 --- a/basis/stack-checker/state/state-tests.factor +++ b/basis/stack-checker/state/state-tests.factor @@ -9,22 +9,22 @@ definitions ; SYMBOL: a SYMBOL: b -[ ] [ a +called+ depends-on ] unit-test +[ ] [ a called-dependency depends-on ] unit-test -[ H{ { a +called+ } } ] [ - [ a +called+ depends-on ] computing-dependencies +[ H{ { a called-dependency } } ] [ + [ a called-dependency depends-on ] computing-dependencies ] unit-test -[ H{ { a +called+ } { b +inlined+ } } ] [ +[ H{ { a called-dependency } { b inlined-dependency } } ] [ [ - a +called+ depends-on b +inlined+ depends-on + a called-dependency depends-on b inlined-dependency depends-on ] computing-dependencies ] unit-test -[ H{ { a +inlined+ } { b +inlined+ } } ] [ +[ H{ { a inlined-dependency } { b inlined-dependency } } ] [ [ - a +inlined+ depends-on - a +called+ depends-on - b +inlined+ depends-on + a inlined-dependency depends-on + a called-dependency depends-on + b inlined-dependency depends-on ] computing-dependencies ] unit-test diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 1f85dc39fc..3d3db980e1 100755 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces sequences kernel definitions math -effects accessors words stack-checker.errors ; +effects accessors words fry classes.algebra stack-checker.errors +compiler.units ; IN: stack-checker.state : ( -- value ) \ counter ; @@ -88,9 +89,15 @@ SYMBOL: meta-r SYMBOL: dependencies : depends-on ( word how -- ) - swap dependencies get dup [ - 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if - ] [ 3drop ] if ; + dependencies get dup + [ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ; + +! Generic words that the current quotation depends on +SYMBOL: generic-dependencies + +: depends-on-generic ( generic class -- ) + generic-dependencies get dup + [ swap '[ null or , class-or ] change-at ] [ 3drop ] if ; ! Words we've inferred the stack effect of, for rollback SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index d941f3242b..200b5d9c43 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -46,7 +46,7 @@ SYMBOL: +transform-n+ ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) - [ +inlined+ depends-on ] [ + [ inlined-dependency depends-on ] [ [ ] [ +transform-quot+ word-prop ] [ +transform-n+ word-prop ] @@ -55,7 +55,7 @@ SYMBOL: +transform-n+ ] bi ; : apply-macro ( word -- ) - [ +inlined+ depends-on ] [ + [ inlined-dependency depends-on ] [ [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] @@ -92,13 +92,13 @@ SYMBOL: +transform-n+ \ spread [ spread>quot ] 1 define-transform \ (call-next-method) [ - [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi + [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi ] 2 define-transform ! Constructors \ boa [ dup tuple-class? [ - dup +inlined+ depends-on + dup inlined-dependency depends-on [ "boa-check" word-prop ] [ tuple-layout '[ , ] ] bi append @@ -107,7 +107,7 @@ SYMBOL: +transform-n+ \ new [ dup tuple-class? [ - dup +inlined+ depends-on + dup inlined-dependency depends-on dup all-slots rest-slice ! delegate slot [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ] [ drop f ] if diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 5ca63a254f..9171a480cf 100755 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -35,13 +35,13 @@ namespaces continuations layouts accessors ; [ t ] [ 1200000 small-enough? ] unit-test -[ ] [ "tetris" shake-and-bake ] unit-test - -[ t ] [ 1500000 small-enough? ] unit-test - -[ ] [ "bunny" shake-and-bake ] unit-test - -[ t ] [ 2500000 small-enough? ] unit-test +! [ ] [ "tetris" shake-and-bake ] unit-test +! +! [ t ] [ 1500000 small-enough? ] unit-test +! +! [ ] [ "bunny" shake-and-bake ] unit-test +! +! [ t ] [ 2500000 small-enough? ] unit-test { "tools.deploy.test.1" diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index b8c37af20a..aeec8e94f7 100755 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.2" } - { deploy-threads? t } - { deploy-compiler? t } { deploy-math? t } - { deploy-c-types? f } - { deploy-io 2 } - { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-reflection 2 } { deploy-ui? f } - { "stop-after-last-window?" t } { deploy-word-props? f } + { deploy-threads? t } + { deploy-c-types? f } + { deploy-random? f } + { "stop-after-last-window?" t } + { deploy-name "tools.deploy.test.2" } + { deploy-io 2 } + { deploy-word-defs? f } } diff --git a/basis/units/units.factor b/basis/units/units.factor index fb93691f0a..7604108b82 100755 --- a/basis/units/units.factor +++ b/basis/units/units.factor @@ -39,7 +39,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; [ dimensions 2array ] bi@ = [ dimensions-not-equal ] unless ; -: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ; +: 2values ( dim dim -- val val ) [ value>> ] bi@ ; : > ] bi@ append ] 2keep + [ [ bot>> ] bi@ append ] 2keep 2values * dimension-op> ; : d-neg ( d -- d ) -1 d* ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index b613147f29..56567fab85 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -110,6 +110,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) 2dup [ assoc-size ] bi@ + pick new-assoc [ rot update ] keep [ swap update ] keep ; +: assoc-combine ( seq -- union ) + H{ } clone [ dupd update ] reduce ; + : assoc-diff ( assoc1 assoc2 -- diff ) [ nip key? not ] curry assoc-filter ; @@ -186,7 +189,7 @@ M: sequence assoc-clone-like >r >alist r> clone-like ; M: sequence assoc-like - over sequence? [ like ] [ assoc-clone-like ] if ; + >r >alist r> like ; M: sequence >alist ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index b9191ac612..8d9f812cee 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -35,6 +35,7 @@ H{ } clone sub-primitives set H{ } clone dictionary set H{ } clone new-classes set H{ } clone changed-definitions set +H{ } clone changed-generics set H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index b43c8f3336..4558ce4737 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -310,3 +310,8 @@ SINGLETON: sb SINGLETON: sc [ sa ] [ sa { sa sb sc } min-class ] unit-test + +[ +lt+ ] [ integer sequence class<=> ] unit-test +[ +lt+ ] [ sequence object class<=> ] unit-test +[ +gt+ ] [ object sequence class<=> ] unit-test +[ +eq+ ] [ integer integer class<=> ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 23695c06f8..0f419678d1 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -186,6 +186,13 @@ M: anonymous-complement (classes-intersect?) [ [ rank-class ] bi@ < ] } cond ; +: class<=> ( first second -- ? ) + { + { [ 2dup class<= not ] [ 2drop +gt+ ] } + { [ 2dup swap class<= not ] [ 2drop +lt+ ] } + [ [ rank-class ] bi@ <=> ] + } cond ; + : class= ( first second -- ? ) [ class<= ] [ swap class<= ] 2bi and ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 64a8630f36..5ec96bbbb0 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -122,6 +122,7 @@ M: sequence implementors [ implementors ] gather ; dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless dup reset-class dup deferred? [ dup define-symbol ] when + dup redefined dup props>> r> assoc-union >>props dup predicate-word diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 56ab6d37f1..a7770e2eb2 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -63,8 +63,10 @@ TUPLE: check-mixin-class mixin ; : remove-mixin-instance ( class mixin -- ) [ - [ [ swap remove ] change-mixin-class ] keep - update-classes + [ class-usages update-methods ] + [ [ swap remove ] change-mixin-class ] + [ nip update-classes ] + 2tri ] [ 2drop ] if-mixin-member? ; M: mixin-class class-forgotten remove-mixin-instance ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 4482eb8131..8a9d230a7c 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -227,9 +227,8 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ +inlined+ changed-definition ] [ redefined ] - tri + bi ] each-subclass ] [ define-new-tuple-class ] @@ -270,9 +269,6 @@ M: tuple-class define-tuple-class tri* define-declared ] 3tri ; -M: tuple-class update-generic - over new-class? [ 2drop ] [ call-next-method ] if ; - M: tuple-class reset-class [ dup "slots" word-prop [ diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor new file mode 100644 index 0000000000..b30e92bbfd --- /dev/null +++ b/core/compiler/units/units-tests.factor @@ -0,0 +1,9 @@ +IN: compiler.units.tests +USING: definitions compiler.units tools.test arrays sequences ; + +[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test +[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test +[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test +[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test +[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test +[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index d141bf68e3..78799287f5 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel continuations assocs namespaces -sequences words vocabs definitions hashtables init sets ; +USING: accessors arrays kernel continuations assocs namespaces +sequences words vocabs definitions hashtables init sets +math.order classes classes.algebra ; IN: compiler.units SYMBOL: old-definitions @@ -72,9 +73,51 @@ GENERIC: definitions-changed ( assoc obj -- ) SYMBOL: outdated-tuples SYMBOL: update-tuples-hook +: strongest-dependency ( how1 how2 -- how ) + [ called-dependency or ] bi@ max ; + +: weakest-dependency ( how1 how2 -- how ) + [ inlined-dependency or ] bi@ min ; + +: compiled-usage ( word -- assoc ) + compiled-crossref get at ; + +: (compiled-usages) ( word -- assoc ) + #! If the word is not flushable anymore, we have to recompile + #! all words which flushable away a call (presumably when the + #! word was still flushable). If the word is flushable, we + #! don't have to recompile words that folded this away. + [ compiled-usage ] + [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi + [ after=? nip ] curry assoc-filter ; + +: compiled-usages ( assoc -- assocs ) + [ drop word? ] assoc-filter + [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ; + +: compiled-generic-usage ( word -- assoc ) + compiled-generic-crossref get at ; + +: (compiled-generic-usages) ( generic class -- assoc ) + dup class? [ + [ compiled-generic-usage ] dip + [ [ classes-intersect? ] [ null class<= ] bi or nip ] + curry assoc-filter + ] [ 2drop f ] if ; + +: compiled-generic-usages ( assoc -- assocs ) + [ (compiled-generic-usages) ] { } assoc>map ; + +: words-only ( assoc -- assoc' ) + [ drop word? ] assoc-filter ; + +: to-recompile ( -- seq ) + changed-definitions get compiled-usages + changed-generics get compiled-generic-usages + append assoc-combine keys ; + : call-recompile-hook ( -- ) - changed-definitions get [ drop word? ] assoc-filter - compiled-usages recompile-hook get call ; + to-recompile recompile-hook get call ; : call-update-tuples-hook ( -- ) update-tuples-hook get call ; @@ -93,13 +136,16 @@ SYMBOL: update-tuples-hook : with-nested-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set + H{ } clone changed-generics set H{ } clone outdated-tuples set + H{ } clone new-classes set [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline : with-compilation-unit ( quot -- ) [ H{ } clone changed-definitions set + H{ } clone changed-generics set H{ } clone forgotten-definitions set H{ } clone outdated-tuples set H{ } clone new-classes set diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 0a83e43097..d9e9732488 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,17 +1,38 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: definitions -USING: kernel sequences namespaces assocs graphs ; +USING: kernel sequences namespaces assocs graphs math math.order ; ERROR: no-compilation-unit definition ; +SINGLETON: inlined-dependency +SINGLETON: flushed-dependency +SINGLETON: called-dependency + +UNION: dependency +inlined-dependency +flushed-dependency +called-dependency ; + +M: dependency <=> + [ + { + called-dependency + flushed-dependency + inlined-dependency + } index + ] bi@ <=> ; + SYMBOL: changed-definitions -SYMBOL: +inlined+ -SYMBOL: +called+ +: changed-definition ( defspec -- ) + inlined-dependency swap changed-definitions get + [ set-at ] [ no-compilation-unit ] if* ; -: changed-definition ( defspec how -- ) - swap changed-definitions get +SYMBOL: changed-generics + +: changed-generic ( class generic -- ) + changed-generics get [ set-at ] [ no-compilation-unit ] if* ; SYMBOL: new-classes diff --git a/core/generic/generic.factor b/core/generic/generic.factor index ff81b5ded3..553ced5800 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -53,22 +53,12 @@ GENERIC: next-method-quot* ( class generic combination -- quot ) TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) - over class? over generic? and [ + 2dup [ class? ] [ generic? ] bi* and [ \ check-method boa throw ] unless ; inline -: affected-methods ( class generic -- seq ) - "methods" word-prop swap - [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter - values ; - -GENERIC# update-generic 1 ( class generic -- ) - -M: class update-generic - affected-methods [ +called+ changed-definition ] each ; - : with-methods ( class generic quot -- ) - [ drop update-generic ] + [ drop changed-generic ] [ [ "methods" word-prop ] dip call ] [ drop make-generic drop ] 3tri ; inline @@ -168,7 +158,7 @@ M: method-body smart-usage M: sequence update-methods ( class seq -- ) implementors [ - [ update-generic ] [ make-generic drop ] 2bi + [ changed-generic ] [ make-generic drop ] 2bi ] with each ; : define-generic ( word combination -- ) diff --git a/core/words/words.factor b/core/words/words.factor index 535295007e..5627a1a015 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -101,60 +101,79 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at -: compiled-xref ( word dependencies -- ) - [ drop crossref? ] assoc-filter - [ "compiled-uses" set-word-prop ] - [ compiled-crossref get add-vertex* ] - 2bi ; +SYMBOL: compiled-generic-crossref + +compiled-generic-crossref global [ H{ } assoc-like ] change-at + +: (compiled-xref) ( word dependencies word-prop variable -- ) + [ [ set-word-prop ] curry ] + [ [ get add-vertex* ] curry ] + bi* 2bi ; + +: compiled-xref ( word dependencies generic-dependencies -- ) + [ [ drop crossref? ] assoc-filter ] bi@ + [ over ] dip + [ "compiled-uses" compiled-crossref (compiled-xref) ] + [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ] + 2bi* ; + +: (compiled-unxref) ( word word-prop variable -- ) + [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ] + [ drop [ f swap set-word-prop ] curry ] + 2bi bi ; : compiled-unxref ( word -- ) - [ - dup "compiled-uses" word-prop - compiled-crossref get remove-vertex* - ] - [ f "compiled-uses" set-word-prop ] bi ; + [ "compiled-uses" compiled-crossref (compiled-unxref) ] + [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ] + bi ; : delete-compiled-xref ( word -- ) - dup compiled-unxref - compiled-crossref get delete-at ; + [ compiled-unxref ] + [ compiled-crossref get delete-at ] + [ compiled-generic-crossref get delete-at ] + tri ; -: compiled-usage ( word -- assoc ) - compiled-crossref get at ; +GENERIC: inline? ( word -- ? ) -: compiled-usages ( assoc -- seq ) - clone [ - dup [ +M: word inline? "inline" word-prop ; + +SYMBOL: visited + +: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline + +: (redefined) ( word -- ) + dup visited get key? [ drop ] [ + [ reset-on-redefine reset-props ] + [ visited get conjoin ] + [ + crossref get at keys + [ word? ] filter [ - [ compiled-usage ] dip - +inlined+ eq? [ - [ nip +inlined+ eq? ] assoc-filter - ] when - ] dip swap update - ] curry assoc-each - ] keep keys ; + [ reset-on-redefine [ word-prop ] with contains? ] + [ inline? ] + bi or + ] filter + [ (redefined) ] each + ] tri + ] if ; -GENERIC: redefined ( word -- ) - -M: object redefined drop ; +: redefined ( word -- ) + [ H{ } clone visited [ (redefined) ] with-variable ] + [ changed-definition ] + bi ; : define ( word def -- ) [ ] like over unxref over redefined >>def - dup +inlined+ changed-definition dup crossref? [ dup xref ] when drop ; : set-stack-effect ( effect word -- ) 2dup "declared-effect" word-prop = [ 2drop ] [ swap [ "declared-effect" set-word-prop ] - [ - drop - dup primitive? [ drop ] [ - [ redefined ] [ +inlined+ changed-definition ] bi - ] if - ] 2bi + [ drop dup primitive? [ dup redefined ] unless drop ] 2bi ] if ; : define-declared ( word def effect -- ) @@ -226,10 +245,6 @@ ERROR: bad-create name vocab ; : constructor-word ( name vocab -- word ) >r "<" swap ">" 3append r> create ; -GENERIC: inline? ( word -- ? ) - -M: word inline? "inline" word-prop ; - PREDICATE: parsing-word < word "parsing" word-prop ; : delimiter? ( obj -- ? ) diff --git a/extra/classes/tuple/lib/lib.factor b/extra/classes/tuple/lib/lib.factor index 509843b9cd..a234ce0d41 100755 --- a/extra/classes/tuple/lib/lib.factor +++ b/extra/classes/tuple/lib/lib.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel macros sequences slots words classes.tuple -quotations combinators ; +quotations combinators accessors ; IN: classes.tuple.lib : reader-slots ( seq -- quot ) - [ slot-spec-reader 1quotation ] map [ cleave ] curry ; + [ reader>> 1quotation ] map [ cleave ] curry ; MACRO: >tuple< ( class -- ) all-slots rest-slice reader-slots ; diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 5f1f977d20..e12092603a 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -353,11 +353,11 @@ M: quotation fjsc-parse ( object -- ast ) ] with-string-writer ; : fjsc-compile* ( string -- string ) - 'statement' parse parse-result-ast fjsc-compile ; + 'statement' parse ast>> fjsc-compile ; : fc* ( string -- string ) [ - 'statement' parse parse-result-ast values>> do-expressions + 'statement' parse ast>> values>> do-expressions ] { } make [ write ] each ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 72a74baf68..2340442d5b 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -208,7 +208,7 @@ DEFER: _ : slot-readers ( class -- quot ) all-slots rest ! tail gets rid of delegate - [ slot-spec-reader 1quotation [ keep ] curry ] map concat + [ reader>> 1quotation [ keep ] curry ] map concat [ ] like [ drop ] compose ; : ?wrapped ( object -- wrapped ) diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 6bd6905804..e21b1292e3 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings assocs math math.parser math.vectors math.functions math.order - lists hashtables ascii ; + lists hashtables ascii accessors ; IN: json.reader ! Grammar for JSON from RFC 4627 @@ -169,11 +169,12 @@ LAZY: 'value' ( -- parser ) 'array' , 'number' , ] [<|>] spaced ; +ERROR: could-not-parse-json ; : json> ( string -- object ) #! Parse a json formatted string to a factor object 'value' parse dup nil? [ - "Could not parse json" throw + could-not-parse-json ] [ - car parse-result-parsed + car parsed>> ] if ; diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index 6beb6e402d..8a1e73928c 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -24,7 +24,7 @@ TUPLE: lazy-cons car cdr ; : lazy-cons ( car cdr -- promise ) [ promise ] bi@ \ lazy-cons boa T{ promise f f t f } clone - [ set-promise-value ] keep ; + swap >>value ; M: lazy-cons car ( lazy-cons -- car ) car>> force ; diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 591915b317..4cce93a5a1 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -116,7 +116,7 @@ LAZY: 'morse-words' ( -- parser ) PRIVATE> : morse> ( str -- str ) - 'morse-words' parse car parse-result-parsed [ + 'morse-words' parse car parsed>> [ [ >string morse>ch ] map >string diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor index fc2727159b..429e6d9d9c 100644 --- a/extra/nehe/4/4.factor +++ b/extra/nehe/4/4.factor @@ -1,5 +1,5 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui -ui.gadgets ui.render threads ; +ui.gadgets ui.render threads accessors ; IN: nehe.4 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; @@ -10,8 +10,8 @@ TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ; : ( -- gadget ) nehe4-gadget new-gadget - 0.0 over set-nehe4-gadget-rtri - 0.0 over set-nehe4-gadget-rquad ; + 0.0 >>rtri + 0.0 >>rquad ; M: nehe4-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; @@ -53,22 +53,22 @@ M: nehe4-gadget draw-gadget* ( gadget -- ) 1.0 -1.0 0.0 glVertex3f -1.0 -1.0 0.0 glVertex3f ] do-state - dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri - dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ; + [ 0.2 + ] change-rtri + [ 0.15 - ] change-rquad drop ; : nehe4-update-thread ( gadget -- ) - dup nehe4-gadget-quit? [ drop ] [ + dup quit?>> [ drop ] [ redraw-interval sleep dup relayout-1 nehe4-update-thread ] if ; M: nehe4-gadget graft* ( gadget -- ) - [ f swap set-nehe4-gadget-quit? ] keep + f >>quit? [ nehe4-update-thread ] in-thread drop ; M: nehe4-gadget ungraft* ( gadget -- ) - t swap set-nehe4-gadget-quit? ; + t >>quit? drop ; : run4 ( -- ) "NeHe Tutorial 4" open-window ; diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor index f399a116ed..ebdfcd5367 100755 --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -1,5 +1,5 @@ USING: arrays kernel math opengl opengl.gl opengl.glu ui -ui.gadgets ui.render threads ; +ui.gadgets ui.render threads accessors ; IN: nehe.5 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; @@ -9,8 +9,8 @@ TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ; : ( -- gadget ) nehe5-gadget new-gadget - 0.0 over set-nehe5-gadget-rtri - 0.0 over set-nehe5-gadget-rquad ; + 0.0 >>rtri + 0.0 >>rquad ; M: nehe5-gadget pref-dim* ( gadget -- dim ) drop width height 2array ; @@ -103,11 +103,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- ) 1.0 -1.0 1.0 glVertex3f 1.0 -1.0 -1.0 glVertex3f ] do-state - dup nehe5-gadget-rtri 0.2 + over set-nehe5-gadget-rtri - dup nehe5-gadget-rquad 0.15 - swap set-nehe5-gadget-rquad ; + [ 0.2 + ] change-rtri + [ 0.15 - ] change-rquad drop ; : nehe5-update-thread ( gadget -- ) - dup nehe5-gadget-quit? [ + dup quit?>> [ drop ] [ redraw-interval sleep @@ -116,11 +116,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- ) ] if ; M: nehe5-gadget graft* ( gadget -- ) - [ f swap set-nehe5-gadget-quit? ] keep - [ nehe5-update-thread ] in-thread drop ; + f >>quit? + [ nehe5-update-thread ] in-thread drop ; M: nehe5-gadget ungraft* ( gadget -- ) - t swap set-nehe5-gadget-quit? ; + t >>quit? drop ; : run5 ( -- ) diff --git a/extra/ori/ori.factor b/extra/ori/ori.factor index 20f022f19f..de720a229f 100644 --- a/extra/ori/ori.factor +++ b/extra/ori/ori.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces +USING: kernel namespaces accessors math math.constants math.functions math.matrices math.vectors sequences splitting grouping self math.trig ; @@ -11,9 +11,9 @@ C: ori ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: ori> ( -- val ) self> ori-val ; +: ori> ( -- val ) self> val>> ; -: >ori ( val -- ) self> set-ori-val ; +: >ori ( val -- ) self> (>>val) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 2414c1ced3..a05c140b86 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: lists lists.lazy promises kernel sequences strings math arrays splitting quotations combinators namespaces -unicode.case unicode.categories sequences.deep ; +unicode.case unicode.categories sequences.deep accessors ; IN: parser-combinators ! Parser combinator protocol @@ -13,11 +13,13 @@ M: promise parse ( input parser -- list ) TUPLE: parse-result parsed unparsed ; +ERROR: cannot-parse input ; + : parse-1 ( input parser -- result ) dupd parse dup nil? [ - "Cannot parse " rot append throw + rot cannot-parse ] [ - nip car parse-result-parsed + nip car parsed>> ] if ; C: parse-result @@ -26,12 +28,12 @@ C: parse-result 1list ; : parse-result-parsed-slice ( parse-result -- slice ) - dup parse-result-parsed empty? [ - parse-result-unparsed 0 0 rot + dup parsed>> empty? [ + unparsed>> 0 0 rot ] [ - dup parse-result-unparsed - dup slice-from [ rot parse-result-parsed length - ] keep - rot slice-seq + dup unparsed>> + dup from>> [ rot parsed>> length - ] keep + rot seq>> ] if ; : string= ( str1 str2 ignore-case -- ? ) @@ -132,7 +134,7 @@ TUPLE: and-parser parsers ; : <&> ( parser1 parser2 -- parser ) over and-parser? [ - >r and-parser-parsers r> suffix + >r parsers>> r> suffix ] [ 2array ] if and-parser boa ; @@ -142,11 +144,11 @@ TUPLE: and-parser parsers ; : and-parser-parse ( list p1 -- list ) swap [ - dup parse-result-unparsed rot parse + dup unparsed>> rot parse [ - >r parse-result-parsed r> - [ parse-result-parsed 2array ] keep - parse-result-unparsed + >r parsed>> r> + [ parsed>> 2array ] keep + unparsed>> ] lazy-map-with ] lazy-map-with lconcat ; diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 9ca8f470bb..6e9d78e649 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -508,10 +508,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) : check-parse-result ( result -- result ) dup [ - dup parse-result-remaining [ blank? ] trim empty? [ + dup remaining>> [ blank? ] trim empty? [ [ "Unable to fully parse EBNF. Left to parse was: " % - parse-result-remaining % + remaining>> % ] "" make throw ] unless ] [ diff --git a/extra/pos/pos.factor b/extra/pos/pos.factor index 24c5410e99..38eb8dec96 100644 --- a/extra/pos/pos.factor +++ b/extra/pos/pos.factor @@ -1,5 +1,6 @@ -USING: kernel math math.functions math.vectors sequences self ; +USING: kernel math math.functions math.vectors sequences self +accessors ; IN: pos @@ -9,13 +10,13 @@ TUPLE: pos val ; C: pos -: pos> ( -- val ) self> pos-val ; +: pos> ( -- val ) self> val>> ; -: >pos ( val -- ) self> set-pos-val ; +: >pos ( val -- ) self> (>>val) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( pos pos -- n ) pos-val swap pos-val v- [ sq ] map sum sqrt ; +: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ; : move-by ( point -- ) pos> v+ >pos ; diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 1bd81d46ea..4920d481b1 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -270,14 +270,14 @@ TUPLE: regexp source parser ignore-case? ; ] keep regexp boa ; : do-ignore-case ( string regexp -- string regexp ) - dup regexp-ignore-case? [ >r >upper r> ] when ; + dup ignore-case?>> [ >r >upper r> ] when ; : matches? ( string regexp -- ? ) - do-ignore-case regexp-parser just parse nil? not ; + do-ignore-case parser>> just parse nil? not ; : match-head ( string regexp -- end ) - do-ignore-case regexp-parser parse dup nil? - [ drop f ] [ car parse-result-unparsed from>> ] if ; + do-ignore-case parser>> parse dup nil? + [ drop f ] [ car unparsed>> from>> ] if ; ! Literal syntax for regexps : parse-options ( string -- ? ) diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index b5e8c16b02..6a785e91b7 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -1,5 +1,6 @@ -USING: kernel parser lexer strings math namespaces sequences words io -arrays quotations debugger kernel.private sequences.private ; +USING: kernel parser lexer strings math namespaces +sequences words io arrays quotations debugger accessors +sequences.private ; IN: state-machine : STATES: @@ -20,9 +21,9 @@ M: missing-state error. ! quot is ( state string -- output-string ) [ missing-state ] dup [ - [ >r dup dup state-data swap state-place r> ] % + [ >r dup [ data>> ] [ place>> ] bi r> ] % [ swapd bounds-check dispatch ] curry , - [ each pick set-state-place swap set-state-data ] % + [ each pick (>>place) swap (>>date) ] % ] [ ] make [ over make ] curry ; : define-machine ( word state-class -- ) diff --git a/extra/turing/turing.factor b/extra/turing/turing.factor index f5b510237b..18d66a2e51 100644 --- a/extra/turing/turing.factor +++ b/extra/turing/turing.factor @@ -1,6 +1,6 @@ -IN: turing USING: arrays assocs io kernel math namespaces -prettyprint sequences strings vectors words ; +prettyprint sequences strings vectors words accessors ; +IN: turing ! A turing machine simulator. @@ -55,9 +55,9 @@ SYMBOL: tape : turing-step ( -- ) #! Do one step of the turing machine. next-state - dup state-sym set-sym - dup state-dir position [ + ] change - state-next state set ; + dup sym>> set-sym + dup dir>> position [ + ] change + next>> state set ; : c ( -- ) #! Print current turing machine state.