diff --git a/basis/compiler/generator/iterator/iterator.factor b/basis/compiler/generator/iterator/iterator.factor index 34a0cf149f..473d59c3e4 100644 --- a/basis/compiler/generator/iterator/iterator.factor +++ b/basis/compiler/generator/iterator/iterator.factor @@ -37,9 +37,9 @@ DEFER: (tail-call?) : tail-call? ( -- ? ) node-stack get [ rest-slice - dup [ + dup empty? [ drop t ] [ [ (tail-call?) ] [ first #terminate? not ] bi and - ] [ drop t ] if + ] if ] all? ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 42becc5588..f5a1a86ae3 100755 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -450,3 +450,14 @@ cell 8 = [ [ 8 ] [ 1 [ 3 fixnum-shift-fast ] compile-call ] unit-test + +TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ; + +[ B{ 0 1 } ] [ + B{ 0 0 } 1 alien-accessor-regression boa + dup [ + { alien-accessor-regression } declare + [ i>> ] [ b>> ] bi over set-alien-unsigned-1 + ] compile-call + b>> +] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 9f9a6e8e92..9f42ad201f 100755 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors -compiler.tree.builder compiler.tree.optimizer ; +compiler.tree.builder compiler.tree.optimizer sequences.deep ; IN: optimizer.tests GENERIC: xyz ( obj -- obj ) @@ -353,3 +353,12 @@ TUPLE: some-tuple x ; [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test + +: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ; + +[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test +[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test + +[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test + +[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 2c667eaceb..2f21777801 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test +[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 9feb931c03..c62c12eeef 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sequences.deep combinators fry -classes.algebra namespaces assocs math math.private -math.partial-dispatch classes.tuple classes.tuple.private -definitions stack-checker.state stack-checker.branches -compiler.tree +classes.algebra namespaces assocs words math math.private +math.partial-dispatch math.intervals classes classes.tuple +classes.tuple.private layouts definitions stack-checker.state +stack-checker.branches compiler.tree compiler.tree.intrinsics compiler.tree.combinators compiler.tree.propagation.info @@ -64,9 +64,19 @@ GENERIC: cleanup* ( node -- node/nodes ) { fixnum-shift fixnum-shift-fast } } at ; +: (remove-overflow-check?) ( #call -- ? ) + node-output-infos first class>> fixnum class<= ; + +: small-shift? ( #call -- ? ) + node-input-infos second interval>> + cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ; + : remove-overflow-check? ( #call -- ? ) - dup word>> no-overflow-variant - [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ; + { + { [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] } + { [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] } + [ drop f ] + } cond ; : remove-overflow-check ( #call -- #call ) [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ; @@ -92,8 +102,11 @@ M: #declare cleanup* drop f ; : fold-only-branch ( #branch -- node/nodes ) #! If only one branch is live we don't need to branch at #! all; just drop the condition value. - dup live-children sift dup length 1 = - [ first swap in-d>> #drop prefix ] [ drop ] if ; + dup live-children sift dup length { + { 0 [ 2drop f ] } + { 1 [ first swap in-d>> #drop prefix ] } + [ 2drop ] + } case ; SYMBOL: live-branches @@ -108,15 +121,18 @@ M: #branch cleanup* [ live-branches>> live-branches set ] } cleave ; +: output-fs ( values -- nodes ) + [ f swap #push ] map ; + : eliminate-single-phi ( #phi -- node ) [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all? - [ [ drop ] [ [ f swap #push ] map ] bi* ] + [ [ drop ] [ output-fs ] bi* ] [ #copy ] if ; : eliminate-phi ( #phi -- node ) live-branches get sift length { - { 0 [ drop f ] } + { 0 [ out-d>> output-fs ] } { 1 [ eliminate-single-phi ] } [ drop ] } case ; diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 4c04ec3917..e8d2b29027 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests : call-recursive-dce-1 ( a -- b ) [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive -[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [ +[ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [ [ call-recursive-dce-1 ] optimize-quot squish ] unit-test @@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests [ f call-recursive-dce-2 drop ] optimize-quot squish ] unit-test -[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [ +[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [ [ f call-recursive-dce-2 ] optimize-quot squish ] unit-test @@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests : call-recursive-dce-4 ( a -- b ) call-recursive-dce-4 ; inline recursive -[ [ "WRAP" [ "REC" ] label ] ] [ +[ [ drop "WRAP" [ "REC" ] label ] ] [ [ call-recursive-dce-4 ] optimize-quot squish ] unit-test @@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests [ [ drop ] ] [ [ { integer } declare f drop ] optimize-quot ] unit-test [ [ f drop ] ] [ [ f drop ] optimize-quot ] unit-test + +: call-recursive-dce-7 ( obj -- elt ? ) + dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive + +[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor index 4c6b411430..03d4e919ee 100644 --- a/basis/compiler/tree/dead-code/recursive/recursive.factor +++ b/basis/compiler/tree/dead-code/recursive/recursive.factor @@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values* #! corresponding inputs to the #call-recursive are live also. [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ; -: return-recursive-phi-in ( #return-recursive -- phi-in ) - [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; - M: #return-recursive compute-live-values* - [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ; + [ out-d>> ] [ in-d>> ] bi look-at-mapping ; M: #call-recursive compute-live-values* #! If the output of a #call-recursive is live, then the @@ -34,15 +31,6 @@ M: #call-recursive compute-live-values* drop-values ] ; -M: #recursive remove-dead-code* ( node -- nodes ) - dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs - { - [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ] - [ drop [ (remove-dead-code) ] change-child drop ] - [ drop label>> [ filter-live ] change-enter-out drop ] - [ swap 2array ] - } 2cleave ; - M: #enter-recursive remove-dead-code* [ filter-live ] change-out-d ; @@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code* [ drop-call-recursive-outputs ] tri 3array ; -M: #return-recursive remove-dead-code* ( node -- nodes ) - dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs - [ drop [ filter-live ] change-out-d drop ] - [ out-d>> >>in-d drop ] - [ swap 2array ] - 2tri ; +:: drop-recursive-inputs ( node -- shuffle ) + [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ] + new-outputs [ shuffle out-d>> ] | + node new-outputs + [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi + shuffle + ] ; + +:: drop-recursive-outputs ( node -- shuffle ) + [let* | return [ node label>> return>> ] + new-inputs [ return in-d>> filter-live ] + new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] | + return + [ new-inputs >>in-d new-outputs >>out-d drop ] + [ drop-dead-outputs ] + bi + ] ; + +M:: #recursive remove-dead-code* ( node -- nodes ) + [let* | drop-inputs [ node drop-recursive-inputs ] + drop-outputs [ node drop-recursive-outputs ] | + node [ (remove-dead-code) ] change-child drop + node label>> [ filter-live ] change-enter-out drop + drop-inputs node drop-outputs 3array + ] ; + +M: #return-recursive remove-dead-code* ; diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index f1be869295..2bcf91e6ab 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors words assocs sequences arrays namespaces -fry locals classes.algebra stack-checker.backend +fry locals definitions classes.algebra +stack-checker.state +stack-checker.backend compiler.tree compiler.tree.propagation.info compiler.tree.dead-code.liveness ; @@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; ] ; : drop-dead-outputs ( node -- nodes ) - dup out-d>> drop-dead-values - [ in-d>> >>out-d drop ] [ 2array ] 2bi ; + dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ; M: #introduce remove-dead-code* ( #introduce -- nodes ) - drop-dead-outputs ; + dup drop-dead-outputs 2array ; M: #>r remove-dead-code* [ filter-live ] change-out-r @@ -105,7 +106,9 @@ M: #push remove-dead-code* ] [ drop f ] if ; : remove-flushable-call ( #call -- node ) - in-d>> #drop remove-dead-code* ; + [ word>> +inlined+ depends-on ] + [ in-d>> #drop remove-dead-code* ] + bi ; : some-outputs-dead? ( #call -- ? ) out-d>> [ live-value? not ] contains? ; @@ -115,7 +118,7 @@ M: #call remove-dead-code* remove-flushable-call ] [ dup some-outputs-dead? [ - drop-dead-outputs + dup drop-dead-outputs 2array ] when ] if ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 9267df93ed..0b7db5b36a 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -7,7 +7,7 @@ compiler.tree.combinators compiler.tree sequences math math.private kernel tools.test accessors slots.private quotations.private prettyprint classes.tuple.private classes classes.tuple compiler.tree.intrinsics namespaces compiler.tree.propagation.info -stack-checker.errors ; +stack-checker.errors kernel.private ; \ escape-analysis must-infer @@ -316,3 +316,7 @@ C: ro-box [ \ too-many->r boa f f \ inference-error boa ] count-unboxed-allocations ] unit-test + +[ 0 ] [ + [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations +] unit-test diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index b30800b445..e01d12ac23 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -125,21 +125,20 @@ SYMBOL: history : remember-inlining ( word -- ) history [ swap suffix ] change ; -: inline-word ( #call word -- ) +: inline-word ( #call word -- ? ) dup history get memq? [ - 2drop + 2drop f ] [ [ dup remember-inlining dupd def>> splicing-nodes >>body propagate-body ] with-scope + t ] if ; : inline-method-body ( #call word -- ? ) - 2dup should-inline? [ inline-word t ] [ 2drop f ] if ; + 2dup should-inline? [ inline-word ] [ 2drop f ] if ; : always-inline-word? ( word -- ? ) { curry compose } memq? ; - -: always-inline-word ( #call word -- ? ) inline-word t ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index da68503c1e..503c633077 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -571,6 +571,8 @@ MIXIN: empty-mixin [ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test +[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test + ! [ V{ string } ] [ ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! ] unit-test diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 528829ff4d..48a4b478e6 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -93,7 +93,7 @@ M: #declare propagate-before : do-inlining ( #call word -- ? ) { - { [ dup always-inline-word? ] [ always-inline-word ] } + { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } { [ dup math-partial? ] [ inline-math-partial ] } diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 4528eb3edc..0ba3b93730 100755 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.allot cpu.architecture kernel kernel.private math -namespaces sequences compiler.generator.registers +namespaces sequences compiler.generator compiler.generator.registers compiler.generator.fixup system layouts alien alien.accessors alien.structs slots splitting assocs ; IN: cpu.x86.64 diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor index 203fe7ac67..536b914f39 100755 --- a/basis/cpu/x86/intrinsics/intrinsics.factor +++ b/basis/cpu/x86/intrinsics/intrinsics.factor @@ -404,10 +404,8 @@ IN: cpu.x86.intrinsics : %alien-integer-set ( quot reg -- ) small-reg PUSH - "offset" get "value" get = [ - "value" operand %untag-fixnum - ] unless small-reg "value" operand MOV + small-reg %untag-fixnum swap %alien-accessor small-reg POP ; inline diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index fa0e2f515d..041cff72ba 100755 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -87,7 +87,7 @@ M: threaded-server handle-client* handler>> call ; [ [ accept-connection ] with-semaphore ] [ accept-connection ] if* - ] [ accept-loop ] bi ; inline + ] [ accept-loop ] bi ; inline recursive : started-accept-loop ( server -- ) threaded-server get diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index e373d36124..6523598cff 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -67,8 +67,10 @@ SYMBOL: enter-out [ entry-stack-height current-stack-height swap - ] bi* = [ 2drop ] [ - word>> current-stack-height - unbalanced-recursion-error inference-error + terminated? get [ 2drop ] [ + word>> current-stack-height + unbalanced-recursion-error inference-error + ] if ] if ; : end-recursive-word ( word label -- ) @@ -79,7 +81,7 @@ SYMBOL: enter-out : recursive-word-inputs ( label -- n ) entry-stack-height d-in get + ; -: (inline-recursive-word) ( word -- label in out visitor ) +: (inline-recursive-word) ( word -- label in out visitor terminated? ) dup prepare-stack [ init-inference @@ -96,11 +98,13 @@ SYMBOL: enter-out dup recursive-word-inputs meta-d get stack-visitor get + terminated? get ] with-scope ; : inline-recursive-word ( word -- ) (inline-recursive-word) - [ consume-d ] [ output-d ] [ ] tri* #recursive, ; + [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip + [ terminate ] when ; : check-call-height ( label -- ) dup entry-stack-height current-stack-height > diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index e1da525f92..11e7a0d7fd 100755 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -331,7 +331,7 @@ SYMBOL: +primitive+ \ bignum-bitnot { bignum } { bignum } define-primitive \ bignum-bitnot make-foldable -\ bignum-shift { bignum bignum } { bignum } define-primitive +\ bignum-shift { bignum fixnum } { bignum } define-primitive \ bignum-shift make-foldable \ bignum< { bignum bignum } { object } define-primitive diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index b78e1b5729..dc049ee1a4 100755 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -575,3 +575,8 @@ DEFER: eee' : eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive [ [ eee' ] infer ] [ inference-error? ] must-fail-with + +: bogus-error ( x -- ) + dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive + +[ bogus-error ] must-infer diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor index 0aec1280de..ee5a5113bf 100644 --- a/basis/state-parser/state-parser.factor +++ b/basis/state-parser/state-parser.factor @@ -88,13 +88,12 @@ SYMBOL: prolog-data : next* ( -- ) get-char [ (next) record ] when ; -: skip-until ( quot -- ) - #! quot: ( -- ? ) +: skip-until ( quot: ( -- ? ) -- ) get-char [ [ call ] keep swap [ drop ] [ next skip-until ] if - ] [ drop ] if ; inline + ] [ drop ] if ; inline recursive : take-until ( quot -- string ) #! Take the substring of a string starting at spot diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 4b96d13316..ade9b34d93 100755 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel xml arrays math generic http.client combinators - hashtables namespaces io base64 sequences strings calendar - xml.data xml.writer xml.utilities assocs math.parser debugger - calendar.format math.order ; +USING: accessors kernel xml arrays math generic http.client +combinators hashtables namespaces io base64 sequences strings +calendar xml.data xml.writer xml.utilities assocs math.parser +debugger calendar.format math.order ; IN: xml-rpc ! * Sending RPC requests @@ -17,7 +17,7 @@ M: integer item>xml [ "Integers must fit in 32 bits" throw ] unless number>string "i4" build-tag ; -PREDICATE: boolean < object { t f } member? ; +UNION: boolean t POSTPONE: f ; M: boolean item>xml "1" "0" ? "boolean" build-tag ; @@ -147,10 +147,10 @@ TAG: array xml>item xml>item [ "faultCode" get "faultString" get ] bind ; : receive-rpc ( xml -- rpc ) - dup name-tag dup "methodCall" = + dup main>> dup "methodCall" = [ drop parse-method ] [ "methodResponse" = [ - dup first-child-tag name-tag "fault" = + dup first-child-tag main>> "fault" = [ parse-fault ] [ parse-rpc-response ] if ] [ "Bad main tag name" server-error ] if diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index da2e4ccb32..1bab8d0374 100755 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -1,25 +1,26 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private assocs arrays -delegate.protocols delegate vectors ; +delegate.protocols delegate vectors accessors multiline +macros words quotations combinators ; IN: xml.data -TUPLE: name space tag url ; +TUPLE: name space main url ; C: name : ?= ( object/f object/f -- ? ) 2dup and [ = ] [ 2drop t ] if ; : names-match? ( name1 name2 -- ? ) - [ name-space swap name-space ?= ] 2keep - [ name-url swap name-url ?= ] 2keep - name-tag swap name-tag ?= and and ; + [ [ space>> ] bi@ ?= ] + [ [ url>> ] bi@ ?= ] + [ [ main>> ] bi@ ?= ] 2tri and and ; -: ( string -- name ) +: ( string -- name ) f swap f ; : assure-name ( string/name -- name ) - dup name? [ ] unless ; + dup name? [ ] unless ; TUPLE: opener name attrs ; C: opener @@ -42,13 +43,11 @@ C: instruction TUPLE: prolog version encoding standalone ; C: prolog -TUPLE: tag attrs children ; - TUPLE: attrs alist ; C: attrs : attr@ ( key alist -- index {key,value} ) - >r assure-name r> attrs-alist + >r assure-name r> alist>> [ first names-match? ] with find ; M: attrs at* @@ -58,12 +57,12 @@ M: attrs set-at 2nip set-second ] [ >r assure-name swap 2array r> - [ attrs-alist ?push ] keep set-attrs-alist + [ alist>> ?push ] keep (>>alist) ] if* ; -M: attrs assoc-size attrs-alist length ; +M: attrs assoc-size alist>> length ; M: attrs new-assoc drop V{ } new-sequence ; -M: attrs >alist attrs-alist ; +M: attrs >alist alist>> ; : >attrs ( assoc -- attrs ) dup [ @@ -74,61 +73,71 @@ M: attrs assoc-like drop dup attrs? [ >attrs ] unless ; M: attrs clear-assoc - f swap set-attrs-alist ; + f >>alist drop ; M: attrs delete-at - tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ; + tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ; M: attrs clone - attrs-alist clone ; + alist>> clone ; INSTANCE: attrs assoc +TUPLE: tag name attrs children ; + : ( name attrs children -- tag ) - >r >r assure-name r> T{ attrs } assoc-like r> - { set-delegate set-tag-attrs set-tag-children } - tag construct ; + [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri* + tag boa ; ! For convenience, tags follow the assoc protocol too (for attrs) CONSULT: assoc-protocol tag tag-attrs ; INSTANCE: tag assoc ! They also follow the sequence protocol (for children) -CONSULT: sequence-protocol tag tag-children ; +CONSULT: sequence-protocol tag children>> ; INSTANCE: tag sequence +CONSULT: name tag name>> ; + M: tag like over tag? [ drop ] [ - [ delegate ] keep tag-attrs + [ name>> ] keep tag-attrs rot dup [ V{ } like ] when ] if ; +MACRO: clone-slots ( class -- tuple ) + [ + "slots" word-prop + [ reader>> 1quotation [ clone ] compose ] map + [ cleave ] curry + ] [ [ boa ] curry ] bi compose ; + M: tag clone - [ delegate clone ] keep [ tag-attrs clone ] keep - tag-children clone - { set-delegate set-tag-attrs set-tag-children } tag construct ; + tag clone-slots ; -TUPLE: xml prolog before main after ; -: ( prolog before main after -- xml ) - { set-xml-prolog set-xml-before set-delegate set-xml-after } - xml construct ; +TUPLE: xml prolog before body after ; +C: xml -CONSULT: sequence-protocol xml delegate ; +CONSULT: sequence-protocol xml body>> ; INSTANCE: xml sequence -CONSULT: assoc-protocol xml delegate ; +CONSULT: assoc-protocol xml body>> ; INSTANCE: xml assoc +CONSULT: tag xml body>> ; + +CONSULT: name xml body>> ; + xml ( xml tag -- newxml ) - swap [ dup xml-prolog swap xml-before rot ] keep xml-after ; + >r [ prolog>> ] [ before>> ] [ after>> ] tri r> + swap ; : seq>xml ( xml seq -- newxml ) - over delegate like tag>xml ; + over body>> like tag>xml ; PRIVATE> M: xml clone - [ xml-prolog clone ] keep [ xml-before clone ] keep - [ delegate clone ] keep xml-after clone ; + xml clone-slots ; M: xml like swap dup xml? [ nip ] [ @@ -139,5 +148,5 @@ M: xml like : ( name attrs -- tag ) f ; -PREDICATE: contained-tag < tag tag-children not ; -PREDICATE: open-tag < tag tag-children ; +PREDICATE: contained-tag < tag children>> not ; +PREDICATE: open-tag < tag children>> ; diff --git a/basis/xml/generator/generator.factor b/basis/xml/generator/generator.factor index bf4bd618b7..d5cf4dac40 100644 --- a/basis/xml/generator/generator.factor +++ b/basis/xml/generator/generator.factor @@ -27,7 +27,7 @@ IN: xml.generator ! Word-based XML literal syntax : parsed-name ( accum -- accum ) - scan ":" split1 [ f ] [ ] if* parsed ; + scan ":" split1 [ f ] [ ] if* parsed ; : run-combinator ( accum quot1 quot2 -- accum ) >r [ ] like parsed r> [ parsed ] each ; diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor index d81e807fe5..e95dad6618 100644 --- a/basis/xml/tests/templating.factor +++ b/basis/xml/tests/templating.factor @@ -1,5 +1,5 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces - xml.data xml.utilities xml.writer generic sequences.deep ; +accessors xml.data xml.utilities xml.writer generic sequences.deep ; IN: xml.tests : sub-tag @@ -11,7 +11,7 @@ GENERIC: (r-ref) ( xml -- ) M: tag (r-ref) sub-tag over at* [ ref-table get at - swap set-tag-children + >>children drop ] [ 2drop ] if ; M: object (r-ref) drop ; @@ -34,7 +34,7 @@ M: object (r-ref) drop ; [ H{ { "foo" { "foo" } } - { "bar" { "blah" T{ tag T{ name f "" "a" "" } V{ } f } } } + { "bar" { "blah" T{ tag f T{ name f "" "a" "" } f f } } } { "baz" f } } ref-table set sample-doc string>xml dup template xml>string diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index e3fc9d9bca..2dd2b848be 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -3,7 +3,7 @@ IN: xml.tests USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities parser strings xml.data io.files xml.writer xml.utilities state-parser - continuations assocs sequences.deep ; + continuations assocs sequences.deep accessors ; ! This is insufficient \ read-xml must-infer @@ -11,22 +11,22 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities SYMBOL: xml-file [ ] [ "resource:basis/xml/tests/test.xml" [ file>xml ] with-html-entities xml-file set ] unit-test -[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test -[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test -[ "a" ] [ xml-file get name-space ] unit-test -[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test +[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test +[ f ] [ xml-file get prolog>> standalone>> ] unit-test +[ "a" ] [ xml-file get space>> ] unit-test +[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test [ "that" ] [ xml-file get T{ name f "" "this" "http://d.de" } swap at ] unit-test -[ t ] [ xml-file get tag-children second contained-tag? ] unit-test +[ t ] [ xml-file get children>> second contained-tag? ] unit-test [ "" string>xml ] [ xml-parse-error? ] must-fail-with [ T{ comment f "This is where the fun begins!" } ] [ xml-file get xml-before [ comment? ] find nip ] unit-test [ "xsl stylesheet=\"that-one.xsl\"" ] [ - xml-file get xml-after [ instruction? ] find nip instruction-text + xml-file get after>> [ instruction? ] find nip text>> ] unit-test -[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test +[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test [ "that" ] [ xml-file get "this" swap at ] unit-test [ "" ] [ "" string>xml xml>string ] unit-test diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index b4ff3a4ce9..284f53023d 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: xml.errors xml.data xml.utilities xml.char-classes sets xml.entities kernel state-parser kernel namespaces strings math -math.parser sequences assocs arrays splitting combinators unicode.case ; +math.parser sequences assocs arrays splitting combinators unicode.case +accessors ; IN: xml.tokenize ! XML namespace processing: ns = namespace @@ -14,8 +15,8 @@ SYMBOL: ns-stack ! this should check to make sure URIs are valid [ [ - swap dup name-space "xmlns" = - [ name-tag set ] + swap dup space>> "xmlns" = + [ main>> set ] [ T{ name f "" "xmlns" f } names-match? [ "" set ] [ drop ] if @@ -24,8 +25,8 @@ SYMBOL: ns-stack ] { } make-assoc f like ; : add-ns ( name -- ) - dup name-space dup ns-stack get assoc-stack - [ nip ] [ throw ] if* swap set-name-url ; + dup space>> dup ns-stack get assoc-stack + [ nip ] [ throw ] if* >>url drop ; : push-ns ( hash -- ) ns-stack get push ; diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor index 209c0b55e9..2acb353bb6 100755 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/utilities/utilities.factor @@ -10,13 +10,13 @@ IN: xml.utilities TUPLE: process-missing process tag ; M: process-missing error. "Tag <" write - dup process-missing-tag print-name + dup tag>> print-name "> not implemented on process process " write - process-missing-process name>> print ; + name>> print ; : run-process ( tag word -- ) 2dup "xtable" word-prop - >r dup name-tag r> at* [ 2nip call ] [ + >r dup main>> r> at* [ 2nip call ] [ drop \ process-missing boa throw ] if ; @@ -48,17 +48,18 @@ M: process-missing error. standard-prolog { } rot { } ; : children>string ( tag -- string ) - tag-children { + children>> { { [ dup empty? ] [ drop "" ] } - { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] } + { [ dup [ string? not ] contains? ] + [ "XML tag unexpectedly contains non-text children" throw ] } [ concat ] } cond ; : children-tags ( tag -- sequence ) - tag-children [ tag? ] filter ; + children>> [ tag? ] filter ; : first-child-tag ( tag -- tag ) - tag-children [ tag? ] find nip ; + children>> [ tag? ] find nip ; ! * Accessing part of an XML document ! for tag- words, a start means that it searches all children @@ -91,7 +92,7 @@ M: process-missing error. assure-name [ tag-with-attr? ] 2curry find nip ; : tags-with-attr ( tag attr-value attr-name -- tags-seq ) - tags@ [ tag-with-attr? ] 2curry filter tag-children ; + tags@ [ tag-with-attr? ] 2curry filter children>> ; : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name [ tag-with-attr? ] 2curry deep-find ; @@ -109,8 +110,8 @@ M: process-missing error. names-match? [ "Unexpected XML tag found" throw ] unless ; : insert-children ( children tag -- ) - dup tag-children [ push-all ] - [ >r V{ } like r> set-tag-children ] if ; + dup children>> [ push-all ] + [ swap V{ } like >>children drop ] if ; : insert-child ( child tag -- ) >r 1vector r> insert-children ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 41e5422830..13f0be431c 100644 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -assocs combinators io io.streams.string +assocs combinators io io.streams.string accessors xml.data wrap xml.entities unicode.categories ; IN: xml.writer @@ -38,9 +38,9 @@ SYMBOL: indenter ] when ; : print-name ( name -- ) - dup name-space f like + dup space>> f like [ write CHAR: : write1 ] when* - name-tag write ; + main>> write ; : print-attrs ( assoc -- ) [ @@ -59,7 +59,7 @@ M: string write-item : write-tag ( tag -- ) ?indent CHAR: < write1 - dup print-name tag-attrs print-attrs ; + dup print-name attrs>> print-attrs ; : write-start-tag ( tag -- ) write-tag ">" write ; @@ -68,7 +68,7 @@ M: contained-tag write-item write-tag "/>" write ; : write-children ( tag -- ) - indent tag-children ?filter-children + indent children>> ?filter-children [ write-item ] each unindent ; : write-end-tag ( tag -- ) @@ -85,18 +85,18 @@ M: open-tag write-item r> xml-pprint? set ; M: comment write-item - "" write ; + "" write ; M: directive write-item - " write1 ; + "> write CHAR: > write1 ; M: instruction write-item - "" write ; + "> write "?>" write ; : write-prolog ( xml -- ) - "> write + "\" encoding=\"" write dup encoding>> write + standalone>> [ "\" standalone=\"yes" write ] when "\"?>" write ; : write-chunk ( seq -- ) @@ -104,10 +104,10 @@ M: instruction write-item : write-xml ( xml -- ) { - [ xml-prolog write-prolog ] - [ xml-before write-chunk ] - [ write-item ] - [ xml-after write-chunk ] + [ prolog>> write-prolog ] + [ before>> write-chunk ] + [ body>> write-item ] + [ after>> write-chunk ] } cleave ; : print-xml ( xml -- ) diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 4e2ad7a672..67168bfb49 100644 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -38,19 +38,19 @@ M: directive process add-child ; M: contained process - [ contained-name ] keep contained-attrs + [ name>> ] [ attrs>> ] bi add-child ; M: opener process push-xml ; : check-closer ( name opener -- name opener ) dup [ throw ] unless - 2dup opener-name = - [ opener-name swap throw ] unless ; + 2dup name>> = + [ name>> swap throw ] unless ; M: closer process - closer-name pop-xml first2 - >r check-closer opener-attrs r> + name>> pop-xml first2 + >r check-closer attrs>> r> add-child ; : init-xml-stack ( -- ) @@ -102,10 +102,10 @@ TUPLE: pull-xml scope ; init-parser reset-prolog init-ns-stack text-now? on ] H{ } make-assoc - { set-pull-xml-scope } pull-xml construct ; + pull-xml boa ; : pull-event ( pull -- xml-event/f ) - pull-xml-scope [ + scope>> [ text-now? get [ parse-text f ] [ get-char [ make-tag t ] [ f f ] if ] if text-now? set @@ -127,17 +127,17 @@ TUPLE: pull-xml scope ; : call-under ( quot object -- quot ) swap dup slip ; inline -: sax-loop ( quot -- ) ! quot: xml-elem -- +: sax-loop ( quot: ( xml-elem -- ) -- ) parse-text call-under get-char [ make-tag call-under sax-loop ] - [ drop ] if ; inline + [ drop ] if ; inline recursive -: sax ( stream quot -- ) ! quot: xml-elem -- +: sax ( stream quot: ( xml-elem -- ) -- ) swap [ reset-prolog init-ns-stack prolog-data get call-under sax-loop - ] state-parse ; inline + ] state-parse ; inline recursive : (read-xml) ( -- ) [ process ] sax-loop ; inline diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index f6ca9184b2..9a372e633e 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 [ ] [ "IN: classes.mixin.tests MIXIN: blah" "mixin-reset-test" parse-stream drop ] unit-test [ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test + +MIXIN: empty-mixin + +[ f ] [ "hi" empty-mixin? ] unit-test diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index a08d4ed20c..56ab6d37f1 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ; dup mixin-class? [ drop ] [ - { } redefine-mixin-class + [ { } redefine-mixin-class ] + [ update-classes ] + bi ] if ; TUPLE: check-mixin-class mixin ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 4ff9d4c674..4482eb8131 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -270,6 +270,9 @@ 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/generic/generic.factor b/core/generic/generic.factor index 70d406a39b..ff81b5ded3 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -62,7 +62,9 @@ TUPLE: check-method class generic ; [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter values ; -: update-generic ( class generic -- ) +GENERIC# update-generic 1 ( class generic -- ) + +M: class update-generic affected-methods [ +called+ changed-definition ] each ; : with-methods ( class generic quot -- ) diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index a6fea14fc7..5a496093d5 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -2,7 +2,9 @@ USING: io.binary tools.test classes math ; IN: io.binary.tests [ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test +[ B{ 0 0 0 0 0 0 4 HEX: d2 } ] [ 1234 8 >be ] unit-test [ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test +[ B{ HEX: d2 4 0 0 0 0 0 0 } ] [ 1234 8 >le ] unit-test [ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 502d4c1eba..c3742786b2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -24,7 +24,7 @@ t parser-notes set-global : note. ( str -- ) parser-notes? [ - file get [ path>> write ] when* + file get [ path>> write ":" write ] when* lexer get line>> number>string write ": " write "Note: " write dup print ] when drop ; diff --git a/extra/db/db.factor b/extra/db/db.factor index 889eff196c..c52d1db148 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -96,12 +96,12 @@ M: object execute-statement* ( statement type -- ) : sql-row-typed ( result-set -- seq ) dup #columns [ row-column-typed ] with map ; -: query-each ( statement quot -- ) +: query-each ( statement quot: ( statement -- ) -- ) over more-rows? [ [ call ] 2keep over advance-row query-each ] [ 2drop - ] if ; inline + ] if ; inline recursive : query-map ( statement quot -- seq ) accumulator >r query-each r> { } like ; inline diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 7960eecee5..3a751a9736 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -14,7 +14,7 @@ GENERIC: where ( specs obj -- ) : query-make ( class quot -- ) >r sql-props r> - [ 0 sql-counter rot with-variable ] { "" { } { } } nmake + [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake maybe-make-retryable ; inline M: db begin-transaction ( -- ) "BEGIN" sql-command ; diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 103020ee0f..67a7dc2045 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -28,6 +28,7 @@ DEFER: process-template [ drop name-url chloe-ns = not ] assoc-filter ; : chloe-tag? ( tag -- ? ) + dup xml? [ body>> ] when { { [ dup tag? not ] [ f ] } { [ dup url>> chloe-ns = not ] [ f ] } @@ -112,12 +113,12 @@ CHLOE-TUPLE: checkbox CHLOE-TUPLE: code : process-chloe-tag ( tag -- ) - dup name-tag dup tags get at + dup main>> dup tags get at [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ; : process-tag ( tag -- ) { - [ name-tag >lower tag-stack get push ] + [ main>> >lower tag-stack get push ] [ write-start-tag ] [ process-tag-children ] [ write-end-tag ] @@ -125,7 +126,7 @@ CHLOE-TUPLE: code } cleave ; : expand-attrs ( tag -- tag ) - dup [ tag? ] is? [ + dup [ tag? ] [ xml? ] bi or [ clone [ [ "@" ?head [ value present ] when ] assoc-map ] change-attrs @@ -134,8 +135,8 @@ CHLOE-TUPLE: code : process-template ( xml -- ) expand-attrs { - { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] } - { [ dup [ tag? ] is? ] [ process-tag ] } + { [ dup chloe-tag? ] [ process-chloe-tag ] } + { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] } { [ t ] [ write-item ] } } cond ; diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor index 9412fde423..82309a49b2 100644 --- a/extra/html/templates/chloe/syntax/syntax.factor +++ b/extra/html/templates/chloe/syntax/syntax.factor @@ -23,7 +23,7 @@ tags global [ H{ } clone or ] change-at MEMO: chloe-name ( string -- name ) name new - swap >>tag + swap >>main chloe-ns >>url ; : required-attr ( tag name -- value ) @@ -45,7 +45,7 @@ MEMO: chloe-name ( string -- name ) : attrs>slots ( tag tuple -- ) [ attrs>> ] [ ] bi* '[ - swap tag>> dup "name" = + swap main>> dup "name" = [ 2drop ] [ , set-at ] if ] assoc-each ; diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 0df41cf53f..3206636ea9 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -62,10 +62,10 @@ C: nil [ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test : empty-cons ( -- cons ) cons new ; -: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ; +: cons* ( cdr car -- cons ) cons boa ; [ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test -[ 1 2 ] [ 2 1 [ cons* ] undo ] unit-test +[ 1 2 ] [ 1 2 [ cons* ] undo ] unit-test [ t ] [ pi [ pi ] matches? ] unit-test [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test diff --git a/extra/io/files/unique/unique-tests.factor b/extra/io/files/unique/unique-tests.factor index 7007f593b6..c29a94f395 100644 --- a/extra/io/files/unique/unique-tests.factor +++ b/extra/io/files/unique/unique-tests.factor @@ -1,3 +1,5 @@ +USING: io.encodings.ascii sequences strings io io.files accessors +tools.test kernel io.files.unique ; IN: io.files.unique.tests [ 123 ] [ diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor index 72b33b9ae7..1e755d71d9 100644 --- a/extra/math/bitfields/lib/lib.factor +++ b/extra/math/bitfields/lib/lib.factor @@ -1,14 +1,14 @@ USING: hints kernel math ; IN: math.bitfields.lib -: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable -: set-bit ( x n -- y ) 2^ bitor ; foldable -: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable -: unmask ( x n -- ? ) bitnot bitand ; foldable -: unmask? ( x n -- ? ) unmask 0 > ; foldable -: mask ( x n -- ? ) bitand ; foldable -: mask? ( x n -- ? ) mask 0 > ; foldable -: wrap ( m n -- m' ) 1- bitand ; foldable +: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline +: set-bit ( x n -- y ) 2^ bitor ; inline +: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline +: unmask ( x n -- ? ) bitnot bitand ; inline +: unmask? ( x n -- ? ) unmask 0 > ; inline +: mask ( x n -- ? ) bitand ; inline +: mask? ( x n -- ? ) mask 0 > ; inline +: wrap ( m n -- m' ) 1- bitand ; inline : bits ( m n -- m' ) 2^ wrap ; inline : mask-bit ( m n -- m' ) 1- 2^ mask ; inline diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor index d4cab29f6a..6e83a61eb3 100755 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -31,10 +31,10 @@ SYMBOL: matrix >r over r> nth dup zero? [ 3drop 0 ] [ - >r nth dup zero? [ - r> 2drop 0 + >r nth dup zero? r> swap [ + 2drop 0 ] [ - r> swap / neg + swap / neg ] if ] if ; diff --git a/extra/namespaces/lib/lib-tests.factor b/extra/namespaces/lib/lib-tests.factor index 20769e161c..0bc2e6311a 100755 --- a/extra/namespaces/lib/lib-tests.factor +++ b/extra/namespaces/lib/lib-tests.factor @@ -1,6 +1,8 @@ IN: namespaces.lib.tests -USING: namespaces.lib tools.test ; +USING: namespaces.lib kernel tools.test ; [ ] [ [ ] { } nmake ] unit-test [ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test + +[ [ ] [ call ] curry { { } } nmake ] must-infer diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 4da3935727..da9fde9d79 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -1,8 +1,6 @@ - -! USING: kernel quotations namespaces sequences assocs.lib ; - USING: kernel namespaces namespaces.private quotations sequences - assocs.lib math.parser math generalizations locals mirrors ; + assocs.lib math.parser math generalizations locals mirrors + macros ; IN: namespaces.lib @@ -42,22 +40,20 @@ SYMBOL: building-seq : 4% ( seq -- ) 4 n% ; : 4# ( num -- ) 4 n# ; -MACRO:: nmake ( quot exemplars -- ) - [let | n [ exemplars length ] | - [ - [ - exemplars - [ 0 swap new-resizable ] map - building-seq set +MACRO: finish-nmake ( exemplars -- ) + length [ firstn ] curry ; - quot call +:: nmake ( quot exemplars -- ) + [ + exemplars + [ 0 swap new-resizable ] map + building-seq set - building-seq get - exemplars [ like ] 2map - n firstn - ] with-scope - ] - ] ; + quot call + + building-seq get + exemplars [ [ like ] 2map ] [ finish-nmake ] bi + ] with-scope ; inline : make-object ( quot class -- object ) new [ swap bind ] keep ; inline diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 9a0b86dbe3..9e984857f6 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -193,7 +193,7 @@ USE: continuations [ iterate-step roll [ 3nip ] [ iterate-next (attempt-each-integer) ] if* - ] [ 3drop f ] if-iterate? ; inline + ] [ 3drop f ] if-iterate? ; inline recursive PRIVATE> : attempt-each ( seq quot -- result ) diff --git a/extra/syndication/syndication.factor b/extra/syndication/syndication.factor index 8d4c91177a..2fa8abcd59 100644 --- a/extra/syndication/syndication.factor +++ b/extra/syndication/syndication.factor @@ -76,8 +76,8 @@ TUPLE: entry title url description date ; [ "link" tag-named "href" swap at >url >>url ] [ { "content" "summary" } any-tag-named - dup tag-children [ string? not ] contains? - [ tag-children [ write-chunk ] with-string-writer ] + dup children>> [ string? not ] contains? + [ children>> [ write-chunk ] with-string-writer ] [ children>string ] if >>description ] [ @@ -96,7 +96,7 @@ TUPLE: entry title url description date ; tri ; : xml>feed ( xml -- feed ) - dup name-tag { + dup main>> { { "RDF" [ rss1.0 ] } { "rss" [ rss2.0 ] } { "feed" [ atom1.0 ] } diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor index 4c95a45832..8b66774d7f 100644 --- a/extra/xmode/loader/syntax/syntax.factor +++ b/extra/xmode/loader/syntax/syntax.factor @@ -1,4 +1,4 @@ -USING: xmode.tokens xmode.rules xmode.keyword-map xml.data +USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data xml.utilities xml assocs kernel combinators sequences math.parser namespaces parser lexer xmode.utilities regexp io.files ; IN: xmode.loader.syntax @@ -7,7 +7,7 @@ SYMBOL: ignore-case? ! Rule tag parsing utilities : (parse-rule-tag) ( rule-set tag specs class -- ) - construct-rule swap init-from-tag swap add-rule ; inline + new swap init-from-tag swap add-rule ; inline : RULE: scan scan-word @@ -98,4 +98,4 @@ TAGS> : init-eol-span-tag ( -- ) [ drop init-eol-span ] , ; : parse-keyword-tag ( tag keyword-map -- ) - >r dup name-tag string>token swap children>string r> set-at ; + >r dup main>> string>token swap children>string r> set-at ; diff --git a/extra/xmode/marker/context/context.factor b/extra/xmode/marker/context/context.factor index 72ac3f2a3f..da20503fcb 100644 --- a/extra/xmode/marker/context/context.factor +++ b/extra/xmode/marker/context/context.factor @@ -1,4 +1,4 @@ -USING: kernel ; +USING: accessors kernel ; IN: xmode.marker.context ! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext @@ -11,10 +11,9 @@ end : ( ruleset parent -- line-context ) over [ "no context" throw ] unless - { set-line-context-in-rule-set set-line-context-parent } - line-context construct ; + line-context new + swap >>parent + swap >>in-rule-set ; M: line-context clone - (clone) - dup line-context-parent clone - over set-line-context-parent ; + call-next-method [ clone ] change-parent ; diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index 3fcae02a54..50d2924b61 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -66,14 +66,11 @@ delegate chars ; -: construct-rule ( class -- rule ) - >r rule new r> construct-delegate ; inline +TUPLE: seq-rule < rule ; -TUPLE: seq-rule ; +TUPLE: span-rule < rule ; -TUPLE: span-rule ; - -TUPLE: eol-span-rule ; +TUPLE: eol-span-rule < rule ; : init-span ( rule -- ) dup rule-delegate [ drop ] [ @@ -85,16 +82,15 @@ TUPLE: eol-span-rule ; dup init-span t swap set-rule-no-line-break? ; -TUPLE: mark-following-rule ; +TUPLE: mark-following-rule < rule ; -TUPLE: mark-previous-rule ; +TUPLE: mark-previous-rule < rule ; -TUPLE: escape-rule ; +TUPLE: escape-rule < rule ; : ( string -- rule ) f f f f - escape-rule construct-rule - [ set-rule-start ] keep ; + escape-rule new swap >>start ; GENERIC: text-hash-char ( text -- ch ) diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor index 55b6bbe26a..49a1265b09 100755 --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -1,7 +1,7 @@ IN: xmode.utilities.tests -USING: xmode.utilities tools.test xml xml.data kernel strings -vectors sequences io.files prettyprint assocs unicode.case ; - +USING: accessors xmode.utilities tools.test xml xml.data kernel +strings vectors sequences io.files prettyprint assocs +unicode.case ; [ "hi" 3 ] [ { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find ] unit-test @@ -35,7 +35,7 @@ TAGS> { { "type" >upper set-company-type } } init-from-tag dup ] keep - tag-children [ tag? ] filter + children>> [ tag? ] filter [ parse-employee-tag ] with each ; [ diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor index d6f9c42799..8f1a6184e8 100644 --- a/extra/xmode/utilities/utilities.factor +++ b/extra/xmode/utilities/utilities.factor @@ -1,10 +1,10 @@ -USING: sequences assocs kernel quotations namespaces xml.data -xml.utilities combinators macros parser lexer words ; +USING: accessors sequences assocs kernel quotations namespaces +xml.data xml.utilities combinators macros parser lexer words ; IN: xmode.utilities : implies >r not r> or ; inline -: child-tags ( tag -- seq ) tag-children [ tag? ] filter ; +: child-tags ( tag -- seq ) children>> [ tag? ] filter ; : map-find ( seq quot -- result elt ) f -rot @@ -53,5 +53,5 @@ SYMBOL: tag-handler-word : TAGS> tag-handler-word get - tag-handlers get >alist [ >r dup name-tag r> case ] curry + tag-handlers get >alist [ >r dup main>> r> case ] curry define ; parsing