diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index d874243d71..ae99f9e6bf 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable : parse-array-type ( name -- array ) "[" split unclip - >r [ "]" ?tail drop string>number ] map r> add* ; + >r [ "]" ?tail drop string>number ] map r> prefix ; M: string c-type ( name -- type ) CHAR: ] over member? [ @@ -162,7 +162,7 @@ DEFER: >c-ushort-array >r >c-ushort-array r> byte-array>memory ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * ] swap add* r> append define-inline ; + >r heap-size [ rot * ] swap prefix r> append define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; @@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- ) f swap box-parameter ; : define-deref ( name vocab -- ) - >r dup CHAR: * add* r> create - swap c-getter 0 add* define-inline ; + >r dup CHAR: * prefix r> create + swap c-getter 0 prefix define-inline ; : define-out ( name vocab -- ) over [ tuck 0 ] over c-setter append swap - >r >r constructor-word r> r> add* define-inline ; + >r >r constructor-word r> r> prefix define-inline ; : c-bool> ( int -- ? ) zero? not ; @@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- ) #! staging violations dup array? [ unclip >r [ dup word? [ word-def call ] when ] map - r> add* + r> prefix ] when ; : malloc-file-contents ( path -- alien len ) diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 3e0062c85a..1a9d5b5392 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -18,7 +18,7 @@ IN: alien.compiler : alien-node-parameters* ( node -- seq ) dup parameters>> - swap return>> large-struct? [ "void*" add* ] when ; + swap return>> large-struct? [ "void*" prefix ] when ; : alien-node-return* ( node -- ctype ) return>> dup large-struct? [ drop "void" ] when ; diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor index 6c7775de2b..e7e576293f 100755 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -8,7 +8,7 @@ kernel words slots assocs namespaces ; dup ?word-name swap 2array over slot-spec-name rot slot-spec-type 2array 2array - [ { $instance } swap add ] assoc-map ; + [ { $instance } swap suffix ] assoc-map ; : $spec-reader-values ( slot-spec class -- ) ($spec-reader-values) $values ; @@ -16,9 +16,9 @@ kernel words slots assocs namespaces ; : $spec-reader-description ( slot-spec class -- ) [ "Outputs the value stored in the " , - { $snippet } rot slot-spec-name add , + { $snippet } rot slot-spec-name suffix , " slot of " , - { $instance } swap add , + { $instance } swap suffix , " instance." , ] { } make $description ; @@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ; : $spec-writer-description ( slot-spec class -- ) [ "Stores a new value to the " , - { $snippet } rot slot-spec-name add , + { $snippet } rot slot-spec-name suffix , " slot of " , - { $instance } swap add , + { $instance } swap suffix , " instance." , ] { } make $description ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index e5de8ab83e..491f4351a3 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -16,7 +16,7 @@ IN: alien.structs ] reduce ; : define-struct-slot-word ( spec word quot -- ) - rot slot-spec-offset add* define-inline ; + rot slot-spec-offset prefix define-inline ; : define-getter ( type spec -- ) [ set-reader-props ] keep diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index deb54fdeeb..fc963683b6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -12,7 +12,7 @@ io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) - cpu dup "ppc" = [ os "-" rot 3append ] when ; + cpu dup "ppc" = [ >r os "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -55,7 +55,7 @@ IN: bootstrap.image : quot-xt@ 3 bootstrap-cells object tag-number - ; : jit-define ( quot rc rt offset name -- ) - >r >r >r >r { } make r> r> r> 4array r> set ; + >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ; ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -134,10 +134,10 @@ SYMBOL: undefined-quot : here ( -- size ) heap-size data-base + ; -: here-as ( tag -- pointer ) here swap bitor ; +: here-as ( tag -- pointer ) here bitor ; : align-here ( -- ) - here 8 mod 4 = [ heap-size drop 0 emit ] when ; + here 8 mod 4 = [ 0 emit ] when ; : emit-fixnum ( n -- ) tag-fixnum emit ; @@ -164,7 +164,7 @@ GENERIC: ' ( obj -- ptr ) userenv-size [ f ' emit ] times ; : emit-userenv ( symbol -- ) - dup get ' swap userenv-offset fixup ; + [ get ' ] [ userenv-offset ] bi fixup ; ! Bignums @@ -175,14 +175,15 @@ GENERIC: ' ( obj -- ptr ) : bignum>seq ( n -- seq ) #! n is positive or zero. [ dup 0 > ] - [ dup bignum-bits neg shift swap bignum-radix bitand ] + [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ] [ ] unfold nip ; -USE: continuations : emit-bignum ( n -- ) - dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq - dup length 1+ emit-fixnum - swap emit emit-seq ; + dup dup 0 < [ neg ] when bignum>seq + [ nip length 1+ emit-fixnum ] + [ drop 0 < 1 0 ? emit ] + [ nip emit-seq ] + 2tri ; M: bignum ' bignum tag-number dup [ emit-bignum ] emit-object ; @@ -221,28 +222,33 @@ M: f ' ! Words : emit-word ( word -- ) - dup subwords [ emit-word ] each [ - dup hashcode ' , - dup word-name ' , - dup word-vocabulary ' , - dup word-def ' , - dup word-props ' , - f ' , - 0 , ! count - 0 , ! xt - 0 , ! code - 0 , ! profiling - ] { } make - \ word type-number object tag-number - [ emit-seq ] emit-object - swap objects get set-at ; + [ subwords [ emit-word ] each ] + [ + [ + { + [ hashcode , ] + [ word-name , ] + [ word-vocabulary , ] + [ word-def , ] + [ word-props , ] + } cleave + f , + 0 , ! count + 0 , ! xt + 0 , ! code + 0 , ! profiling + ] { } make [ ' ] map + ] bi + \ word type-number object tag-number + [ emit-seq ] emit-object + ] keep objects get set-at ; : word-error ( word msg -- * ) [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - dup target-word swap or ; + [ target-word ] keep or ; : fixup-word ( word -- offset ) transfer-word dup objects get at @@ -285,9 +291,10 @@ M: string ' length 0 assert= ; : emit-dummy-array ( obj type -- ptr ) - swap assert-empty - type-number object tag-number - [ 0 emit-fixnum ] emit-object ; + [ assert-empty ] [ + type-number object tag-number + [ 0 emit-fixnum ] emit-object + ] bi* ; M: byte-array ' byte-array emit-dummy-array ; @@ -296,29 +303,28 @@ M: bit-array ' bit-array emit-dummy-array ; M: float-array ' float-array emit-dummy-array ; ! Tuples +: (emit-tuple) ( tuple -- pointer ) + [ tuple>array 1 tail-slice ] + [ class transfer-word tuple-layout ] bi prefix [ ' ] map + tuple type-number dup [ emit-seq ] emit-object ; + : emit-tuple ( tuple -- pointer ) - [ - [ - dup class transfer-word tuple-layout ' , - tuple>array 1 tail-slice [ ' ] map % - ] { } make - tuple type-number dup [ emit-seq ] emit-object - ] - ! Hack - over class word-name "tombstone" = - [ objects get swap cache ] [ call ] if ; + dup class word-name "tombstone" = + [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; M: tuple-layout ' objects get [ [ - dup layout-hashcode ' , - dup layout-class ' , - dup layout-size ' , - dup layout-superclasses ' , - layout-echelon ' , - ] { } make + { + [ layout-hashcode , ] + [ layout-class , ] + [ layout-size , ] + [ layout-superclasses , ] + [ layout-echelon , ] + } cleave + ] { } make [ ' ] map \ tuple-layout type-number object tag-number [ emit-seq ] emit-object ] cache ; @@ -329,14 +335,9 @@ M: tombstone ' word-def first objects get [ emit-tuple ] cache ; ! Arrays -: emit-array ( list type tag -- pointer ) - >r >r [ ' ] map r> r> [ - dup length emit-fixnum - emit-seq - ] emit-object ; - M: array ' - array type-number object tag-number emit-array ; + [ ' ] map array type-number object tag-number + [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; ! Quotations @@ -351,13 +352,6 @@ M: quotation ' ] emit-object ] cache ; -! Curries - -M: curry ' - dup curry-quot ' swap curry-obj ' - \ curry type-number object tag-number - [ emit emit ] emit-object ; - ! End of the image : emit-words ( -- ) @@ -437,8 +431,8 @@ M: curry ' : write-image ( image -- ) "Writing image to " write architecture get boot-image-name resource-path - dup write "..." print flush - binary [ (write-image) ] with-stream ; + [ write "..." print flush ] + [ binary [ (write-image) ] with-stream ] bi ; PRIVATE> diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 2e1a7f9f57..bc876c2dec 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions slots.deprecated -classes.union compiler.units bootstrap.image.private io.files ; +classes.union compiler.units bootstrap.image.private io.files +accessors combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -102,33 +103,36 @@ num-types get f builtins set ! Builtin classes : builtin-predicate-quot ( class -- quot ) [ - "type" word-prop dup - \ tag-mask get < \ tag \ type ? , , \ eq? , + "type" word-prop + [ tag-mask get < \ tag \ type ? , ] [ , ] bi + \ eq? , ] [ ] make ; : define-builtin-predicate ( class -- ) - dup - dup builtin-predicate-quot define-predicate - predicate-word make-inline ; + [ dup builtin-predicate-quot define-predicate ] + [ predicate-word make-inline ] + bi ; : lookup-type-number ( word -- n ) global [ target-word ] bind type-number ; : register-builtin ( class -- ) - dup - dup lookup-type-number "type" set-word-prop - dup "type" word-prop builtins get set-nth ; + [ dup lookup-type-number "type" set-word-prop ] + [ dup "type" word-prop builtins get set-nth ] + bi ; : define-builtin-slots ( symbol slotspec -- ) - dupd 1 simple-slots - 2dup "slots" set-word-prop - define-slots ; + [ drop ] [ 1 simple-slots ] 2bi + [ "slots" set-word-prop ] [ define-slots ] 2bi ; : define-builtin ( symbol slotspec -- ) >r - dup register-builtin - dup f f builtin-class define-class - dup define-builtin-predicate + { + [ register-builtin ] + [ f f builtin-class define-class ] + [ define-builtin-predicate ] + [ ] + } cleave r> define-builtin-slots ; ! Forward definitions @@ -335,7 +339,10 @@ define-builtin { "set-delegate" "kernel" } } } -define-tuple-slots +[ drop ] [ generate-tuple-slots ] 2bi +[ [ name>> ] map "slot-names" set-word-prop ] +[ "slots" set-word-prop ] +[ define-slots ] 2tri "tuple" "kernel" lookup define-tuple-layout @@ -495,8 +502,9 @@ f builtins get num-tags get tail union-class define-class } define-tuple-class "curry" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define "compose" "kernel" create "tuple" "kernel" lookup @@ -515,8 +523,9 @@ dup tuple-layout [ ] curry define } define-tuple-class "compose" "kernel" lookup -dup f "inline" set-word-prop -dup tuple-layout [ ] curry define +[ f "inline" set-word-prop ] +[ ] +[ tuple-layout [ ] curry ] tri define ! Primitive words : make-primitive ( word vocab n -- ) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 2945bd2546..5d7c114cbc 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -138,10 +138,10 @@ C: anonymous-complement members>> [ class-and ] with map ; : left-anonymous-intersection-and ( first second -- class ) - >r members>> r> add ; + >r members>> r> suffix ; : right-anonymous-intersection-and ( first second -- class ) - members>> swap add ; + members>> swap suffix ; : (class-and) ( first second -- class ) { @@ -158,10 +158,10 @@ C: anonymous-complement } cond ; : left-anonymous-union-or ( first second -- class ) - >r members>> r> add ; + >r members>> r> suffix ; : right-anonymous-union-or ( first second -- class ) - members>> swap add ; + members>> swap suffix ; : (class-or) ( first second -- class ) { diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 435c7413a3..d6d1a72121 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -72,7 +72,7 @@ M: word reset-class drop ; ! update-map : class-uses ( class -- seq ) - dup members swap superclass [ add ] when* ; + dup members swap superclass [ suffix ] when* ; : class-usages ( class -- assoc ) [ update-map get at ] closure ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index eb6b3bd6e2..b771aa8920 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ; swap redefine-mixin-class ; inline : add-mixin-instance ( class mixin -- ) - [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ; + [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ; : remove-mixin-instance ( class mixin -- ) [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 7123d5c7c8..18c8143654 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,23 +153,11 @@ HELP: tuple= { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } { $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; -HELP: permutation -{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } } -{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ; - -HELP: reshape-tuple -{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } } -{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ; - -HELP: reshape-tuples -{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } } -{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ; - HELP: removed-slots { $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } } { $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ; -HELP: forget-slots +HELP: forget-removed-slots { $values { "class" tuple-class } { "slots" "a sequence of strings" } } { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 9b8228155b..db0e25f091 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra -calendar prettyprint io.streams.string splitting ; +calendar prettyprint io.streams.string splitting inspector ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -265,9 +265,13 @@ C: laptop [ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get tuple? ] unit-test -[ "Pentium" ] [ "laptop" get cpu>> ] unit-test -[ 128 ] [ "laptop" get ram>> ] unit-test -[ t ] [ "laptop" get battery>> 3 hours = ] unit-test +: test-laptop-slot-values + [ laptop ] [ "laptop" get class ] unit-test + [ "Pentium" ] [ "laptop" get cpu>> ] unit-test + [ 128 ] [ "laptop" get ram>> ] unit-test + [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ; + +test-laptop-slot-values [ laptop ] [ "laptop" get tuple-layout @@ -294,9 +298,13 @@ C: server [ t ] [ "server" get computer? ] unit-test [ t ] [ "server" get tuple? ] unit-test -[ "PowerPC" ] [ "server" get cpu>> ] unit-test -[ 64 ] [ "server" get ram>> ] unit-test -[ "1U" ] [ "server" get rackmount>> ] unit-test +: test-server-slot-values + [ server ] [ "server" get class ] unit-test + [ "PowerPC" ] [ "server" get cpu>> ] unit-test + [ 64 ] [ "server" get ram>> ] unit-test + [ "1U" ] [ "server" get rackmount>> ] unit-test ; + +test-server-slot-values [ f ] [ "server" get laptop? ] unit-test [ f ] [ "laptop" get server? ] unit-test @@ -316,10 +324,10 @@ C: server "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval ] must-fail -! Reshaping with inheritance +! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test [ f ] [ electronic-device laptop class< ] unit-test [ t ] [ server electronic-device class< ] unit-test @@ -335,11 +343,123 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +TUPLE: make-me-some-accessors voltage grounded? ; + +[ f ] [ "laptop" get voltage>> ] unit-test +[ f ] [ "server" get voltage>> ] unit-test + +[ ] [ "laptop" get 220 >>voltage drop ] unit-test +[ ] [ "server" get 110 >>voltage drop ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +! Reshaping superclass and subclass simultaneously +"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval + +test-laptop-slot-values +test-server-slot-values + +[ 220 ] [ "laptop" get voltage>> ] unit-test +[ 110 ] [ "server" get voltage>> ] unit-test + +! Reshape crash +TUPLE: test1 a ; TUPLE: test2 < test1 b ; + +T{ test2 f "a" "b" } "test" set + +: test-a/b + [ "a" ] [ "test" get a>> ] unit-test + [ "b" ] [ "test" get b>> ] unit-test ; + +test-a/b + +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test + +test-a/b + +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test + +test-a/b + +! Twice in the same compilation unit +[ + test1 tuple { "a" "x" "y" } define-tuple-class + test1 tuple { "a" "y" } define-tuple-class +] with-compilation-unit + +test-a/b + +! Moving slots up and down +TUPLE: move-up-1 a b ; +TUPLE: move-up-2 < move-up-1 c ; + +T{ move-up-2 f "a" "b" "c" } "move-up" set + +: test-move-up + [ "a" ] [ "move-up" get a>> ] unit-test + [ "b" ] [ "move-up" get b>> ] unit-test + [ "c" ] [ "move-up" get c>> ] unit-test ; + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test + +test-move-up + +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test + +! Constructors must be recompiled when changing superclass +TUPLE: constructor-update-1 xxx ; + +TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ; + +C: constructor-update-2 + +{ 3 1 } [ ] must-infer-as + +[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test + +{ 5 1 } [ ] must-infer-as + +[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test + ! Redefinition problem TUPLE: redefinition-problem ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index a452d0eeec..3cacef25a1 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -23,8 +23,16 @@ M: class tuple-layout "layout" word-prop ; M: tuple tuple-layout 1 slot ; +M: tuple-layout tuple-layout ; + : tuple-size tuple-layout layout-size ; inline +: prepare-tuple>array ( tuple -- n tuple layout ) + [ tuple-size ] [ ] [ tuple-layout ] tri ; + +: copy-tuple-slots ( n tuple -- array ) + [ array-nth ] curry map ; + PRIVATE> : check-tuple ( class -- ) @@ -32,28 +40,29 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - dup tuple-layout - [ layout-size swap [ array-nth ] curry map ] keep - layout-class add* ; + prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ; -: >tuple ( seq -- tuple ) - dup first tuple-layout [ - >r 1 tail-slice dup length r> - [ tuple-size min ] keep - [ set-array-nth ] curry - 2each +: tuple-slots ( tuple -- array ) + prepare-tuple>array drop copy-tuple-slots ; + +: slots>tuple ( tuple class -- array ) + tuple-layout [ + [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each ] keep ; +: >tuple ( tuple -- array ) + unclip slots>tuple ; + : slot-names ( class -- seq ) - "slots" word-prop [ name>> ] map ; + "slot-names" word-prop ; r over r> array-nth >r array-nth r> = ] 2curry - all-integers? + 2dup [ tuple-layout ] bi@ eq? [ + [ drop tuple-size ] + [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ] + 2bi all-integers? ] [ 2drop f ] if ; @@ -92,18 +101,19 @@ PRIVATE> superclasses 1 head-slice* [ slot-names length ] map sum ; -: generate-tuple-slots ( class slots -- slots ) +: generate-tuple-slots ( class slots -- slot-specs ) over superclass-size 2 + simple-slots ; -: define-tuple-slots ( class slots -- ) - dupd generate-tuple-slots +: define-tuple-slots ( class -- ) + dup dup slot-names generate-tuple-slots [ "slots" set-word-prop ] - [ define-accessors ] - [ define-slots ] 2tri ; + [ define-accessors ] ! new + [ define-slots ] ! old + 2tri ; : make-tuple-layout ( class -- layout ) [ ] - [ [ superclass-size ] [ "slots" word-prop length ] bi + ] + [ [ superclass-size ] [ slot-names length ] bi + ] [ superclasses dup length 1- ] tri ; @@ -113,49 +123,75 @@ PRIVATE> : removed-slots ( class newslots -- seq ) swap slot-names seq-diff ; -: forget-slots ( class slots -- ) +: forget-removed-slots ( class slots -- ) dupd removed-slots [ [ reader-word forget-method ] [ writer-word forget-method ] 2bi ] with each ; -: permutation ( seq1 seq2 -- permutation ) - swap [ index ] curry map ; +: all-slot-names ( class -- slots ) + superclasses [ slot-names ] map concat \ class prefix ; -: reshape-tuple ( oldtuple permutation -- newtuple ) - >r tuple>array 2 cut r> - [ [ swap ?nth ] [ drop f ] if* ] with map - append >tuple ; +: compute-slot-permutation ( class old-slot-names -- permutation ) + >r all-slot-names r> [ index ] curry map ; -: reshape-tuples ( class superclass newslots -- ) - nip - >r dup slot-names r> permutation - [ - >r "predicate" word-prop instances dup - r> [ reshape-tuple ] curry map - become - ] 2curry after-compilation ; +: apply-slot-permutation ( old-values permutation -- new-values ) + [ [ swap ?nth ] [ drop f ] if* ] with map ; + +: permute-slots ( old-values -- new-values ) + dup first dup outdated-tuples get at + compute-slot-permutation + apply-slot-permutation ; + +: change-tuple ( tuple quot -- newtuple ) + >r tuple>array r> call >tuple ; inline + +: update-tuple ( tuple -- newtuple ) + [ permute-slots ] change-tuple ; + +: update-tuples ( -- ) + outdated-tuples get + dup assoc-empty? [ drop ] [ + [ >r class r> key? ] curry instances + dup [ update-tuple ] map become + ] if ; + +[ update-tuples ] update-tuples-hook set-global + +: update-tuples-after ( class -- ) + outdated-tuples get [ all-slot-names ] cache drop ; + +: subclasses ( class -- classes ) + class-usages keys [ tuple-class? ] subset ; + +: each-subclass ( class quot -- ) + >r subclasses r> each ; inline + +: define-tuple-shape ( class -- ) + [ define-tuple-slots ] + [ define-tuple-layout ] + [ define-tuple-predicate ] + tri ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip define-tuple-slots ] [ + [ nip "slot-names" set-word-prop ] + [ 2drop - class-usages keys [ tuple-class? ] subset [ - [ define-tuple-layout ] - [ define-tuple-predicate ] - bi - ] each + [ define-tuple-shape ] each-subclass ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) - [ reshape-tuples ] [ - nip - [ forget-slots ] - [ drop changed-word ] - [ drop redefined ] - 2tri + 2drop + [ + [ update-tuples-after ] + [ changed-word ] + [ redefined ] + tri + ] each-subclass ] + [ nip forget-removed-slots ] [ define-new-tuple-class ] 3tri ; @@ -175,7 +211,7 @@ M: tuple-class define-tuple-class 3drop ; : define-error-class ( class superclass slots -- ) - pick >r define-tuple-class r> + [ define-tuple-class ] [ 2drop ] 3bi dup [ construct-boa throw ] curry define ; M: tuple clone @@ -184,11 +220,6 @@ M: tuple clone M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; - -: is? ( obj quot -- ? ) >r delegates r> contains? ; inline - M: tuple hashcode* [ dup tuple-size -rot 0 -rot [ @@ -196,23 +227,26 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -: tuple-slots ( tuple -- seq ) tuple>array 2 tail ; - -! Definition protocol M: tuple-class reset-class { "metaclass" "superclass" "slots" "layout" } reset-props ; M: object get-slots ( obj slots -- ... ) [ execute ] with each ; -M: object set-slots ( ... obj slots -- ) - get-slots ; - M: object construct-empty ( class -- tuple ) tuple-layout ; +M: object construct-boa ( ... class -- tuple ) + tuple-layout ; + +! Deprecated +M: object set-slots ( ... obj slots -- ) + get-slots ; + M: object construct ( ... slots class -- tuple ) construct-empty [ swap set-slots ] keep ; -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; +: delegates ( obj -- seq ) + [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; + +: is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e19847dbd4..484c7ab730 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -43,7 +43,7 @@ ERROR: no-case ; : with-datastack ( stack quot -- newstack ) datastack >r >r >array set-datastack r> call - datastack r> swap add set-datastack 2nip ; inline + datastack r> swap suffix set-datastack 2nip ; inline : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline @@ -66,7 +66,7 @@ M: hashtable hashcode* reverse [ no-cond ] swap alist>quot ; : linear-case-quot ( default assoc -- quot ) - [ >r [ dupd = ] curry r> \ drop add* ] assoc-map + [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 9849ddca7d..f87c1ec985 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- ) dup [ drop crossref? ] assoc-contains? modify-code-heap ; -SYMBOL: post-compile-tasks - -: after-compilation ( quot -- ) - post-compile-tasks get push ; +SYMBOL: outdated-tuples +SYMBOL: update-tuples-hook : call-recompile-hook ( -- ) changed-words get keys compiled-usages recompile-hook get call ; -: call-post-compile-tasks ( -- ) - post-compile-tasks get [ call ] each ; +: call-update-tuples-hook ( -- ) + update-tuples-hook get call ; : finish-compilation-unit ( -- ) call-recompile-hook - call-post-compile-tasks + call-update-tuples-hook dup [ drop crossref? ] assoc-contains? modify-code-heap changed-definitions notify-definition-observers ; @@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks [ H{ } clone changed-words set H{ } clone forgotten-definitions set - V{ } clone post-compile-tasks set + H{ } clone outdated-tuples set new-definitions set old-definitions set [ finish-compilation-unit ] diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 7209b7ec4d..ca7af930f2 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -29,6 +29,7 @@ $nl { $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } +{ $subsection "debugger" } { $subsection "errors-post-mortem" } "When Factor encouters a critical error, it calls the following word:" { $subsection die } ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 7aa78ce52e..07698eaa92 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics } define-intrinsics : fixnum-register-op ( op -- pair ) - [ "out" operand "y" operand "x" operand ] swap add H{ + [ "out" operand "y" operand "x" operand ] swap suffix H{ { +input+ { { f "x" } { f "y" } } } { +scratch+ { { f "out" } } } { +output+ { "out" } } } 2array ; : fixnum-value-op ( op -- pair ) - [ "out" operand "x" operand "y" operand ] swap add H{ + [ "out" operand "x" operand "y" operand ] swap suffix H{ { +input+ { { f "x" } { [ small-tagged? ] "y" } } } { +scratch+ { { f "out" } } } { +output+ { "out" } } @@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics } define-intrinsic : fixnum-register-jump ( op -- pair ) - [ "x" operand 0 "y" operand CMP ] swap add + [ "x" operand 0 "y" operand CMP ] swap suffix { { f "x" } { f "y" } } 2array ; : fixnum-value-jump ( op -- pair ) - [ 0 "x" operand "y" operand CMPI ] swap add + [ 0 "x" operand "y" operand CMPI ] swap suffix { { f "x" } { [ small-tagged? ] "y" } } 2array ; : define-fixnum-jump ( word op -- ) @@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics } define-intrinsic : define-float-op ( word op -- ) - [ "z" operand "x" operand "y" operand ] swap add H{ + [ "z" operand "x" operand "y" operand ] swap suffix H{ { +input+ { { float "x" } { float "y" } } } { +scratch+ { { float "z" } } } { +output+ { "z" } } @@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics ] each : define-float-jump ( word op -- ) - [ "x" operand 0 "y" operand FCMPU ] swap add + [ "x" operand 0 "y" operand FCMPU ] swap suffix { { float "x" } { float "y" } } define-if-intrinsic ; { diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 796388ffe1..a3ab256ea1 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -230,7 +230,7 @@ UNION: operand register indirect ; : opcode-or ( opcode mask -- opcode' ) swap dup array? - [ 1 cut* first rot bitor add ] [ bitor ] if ; + [ 1 cut* first rot bitor suffix ] [ bitor ] if ; : 1-operand ( op reg rex.w opcode -- ) #! The 'reg' is not really a register, but a value for the diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index f5409a24f5..261ada025b 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -156,7 +156,7 @@ IN: cpu.x86.intrinsics ! Fixnums : fixnum-op ( op hash -- pair ) - >r [ "x" operand "y" operand ] swap add r> 2array ; + >r [ "x" operand "y" operand ] swap suffix r> 2array ; : fixnum-value-op ( op -- pair ) H{ @@ -251,7 +251,7 @@ IN: cpu.x86.intrinsics \ fixnum- \ SUB overflow-template : fixnum-jump ( op inputs -- pair ) - >r [ "x" operand "y" operand CMP ] swap add r> 2array ; + >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ; : fixnum-value-jump ( op -- pair ) { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ; diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor index 98e42fa7fe..9c477b4132 100755 --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -8,7 +8,7 @@ math.floats.private layouts quotations ; IN: cpu.x86.sse2 : define-float-op ( word op -- ) - [ "x" operand "y" operand ] swap add H{ + [ "x" operand "y" operand ] swap suffix H{ { +input+ { { float "x" } { float "y" } } } { +output+ { "x" } } } define-intrinsic ; @@ -23,7 +23,7 @@ IN: cpu.x86.sse2 ] each : define-float-jump ( word op -- ) - [ "x" operand "y" operand UCOMISD ] swap add + [ "x" operand "y" operand UCOMISD ] swap suffix { { float "x" } { float "y" } } define-if-intrinsic ; { diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index 5e8b6df34a..f8b53d4abc 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -86,7 +86,15 @@ HELP: error-hook HELP: try { $values { "quot" "a quotation" } } -{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ; +{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." } +{ $examples + "The following example prints an error and keeps going:" + { $code + "[ \"error\" throw ] try" + "\"still running...\" print" + } + { $link "listener" } " uses " { $link try } " to recover from user errors." +} ; HELP: expired-error. { $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." } diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 131b7e57c9..7dba7eb709 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -157,7 +157,7 @@ M: assoc update-methods ( assoc -- ) M: generic subwords dup "methods" word-prop values - swap "default-method" word-prop add ; + swap "default-method" word-prop suffix ; M: generic forget-word dup subwords [ forget ] each (forget-word) ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4447c5a264..13b5278735 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -34,8 +34,8 @@ ERROR: no-method object generic ; : empty-method ( word -- quot ) [ picker % [ delegate dup ] % - unpicker over add , - error-method \ drop add* , \ if , + unpicker over suffix , + error-method \ drop prefix , \ if , ] [ ] make ; : class-predicates ( assoc -- assoc ) @@ -137,7 +137,7 @@ ERROR: no-method object generic ; ] if ; : standard-methods ( word -- alist ) - dup methods swap default-method add* + dup methods swap default-method prefix [ 1quotation ] assoc-map ; M: standard-combination make-default-method diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 2a2e6995eb..5ca9b1b2e7 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -92,7 +92,7 @@ M: wrapper apply-object r> recursive-state set ; : infer-quot-recursive ( quot word label -- ) - recursive-state get -rot 2array add* infer-quot ; + recursive-state get -rot 2array prefix infer-quot ; : time-bomb ( error -- ) [ throw ] curry recursive-state get infer-quot ; @@ -109,7 +109,7 @@ TUPLE: recursive-quotation-error quot ; dup value-literal callable? [ dup value-literal over value-recursion - rot f 2array add* infer-quot + rot f 2array prefix infer-quot ] [ drop bad-call ] if @@ -430,7 +430,7 @@ M: #call-label collect-recursion* [ [ swap collect-recursion* ] curry each-node ] { } make ; : join-values ( node -- ) - collect-recursion [ node-in-d ] map meta-d get add + collect-recursion [ node-in-d ] map meta-d get suffix unify-lengths unify-stacks meta-d [ length tail* ] change ; diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index ed36ca4890..4aac98ce41 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -289,7 +289,7 @@ M: #label infer-classes-around ( #label -- ) dup annotate-node dup infer-classes-before dup infer-children - dup collect-recursion over add + dup collect-recursion over suffix pick annotate-entry node-child (infer-classes) ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 0b6cf04028..7fa2fbbcd3 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -205,7 +205,7 @@ UNION: #branch #if #dispatch ; 2dup 2slip rot [ 2drop t ] [ - >r dup node-children swap node-successor add r> + >r dup node-children swap node-successor suffix r> [ node-exists? ] curry contains? ] if ] [ diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 200208c6a5..4cfe0432a5 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -56,7 +56,7 @@ M: pair (bitfield-quot) ( spec -- quot ) [ shift bitor ] append 2curry ; : bitfield-quot ( spec -- quot ) - [ (bitfield-quot) ] map [ 0 ] add* concat ; + [ (bitfield-quot) ] map [ 0 ] prefix concat ; \ bitfield [ bitfield-quot ] 1 define-transform diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2ef26096e0..398fb6a068 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -59,7 +59,7 @@ M: tuple f decoder construct-boa ; over decoder-cr [ over cr- "\n" ?head [ - over stream-read1 [ add ] when* + over stream-read1 [ suffix ] when* ] when ] when nip ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 458a9145a6..099acb157e 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -267,6 +267,7 @@ M: object copy-file DEFER: copy-tree-into : copy-tree ( from to -- ) + normalize-pathname over link-info type>> { { +symbolic-link+ [ copy-link ] } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index a446869096..b1120de8e6 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -7,6 +7,8 @@ IN: kernel ARTICLE: "shuffle-words" "Shuffle words" "Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions." $nl +"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "." +$nl "Removing stack elements:" { $subsection drop } { $subsection 2drop } @@ -39,9 +41,28 @@ $nl { $code ": foo ( m ? n -- m+n/n )" " >r [ r> + ] [ drop r> ] if ; ! This is OK" -} -"An alternative to using " { $link >r } " and " { $link r> } " is the following:" -{ $subsection dip } ; +} ; + +ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" +"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." +$nl +"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" +{ $code + ": keep [ ] bi ;" + ": 2keep [ ] 2bi ;" + ": 3keep [ ] 3bi ;" + "" + ": dup [ ] [ ] bi ;" + ": 2dup [ ] [ ] 2bi ;" + ": 3dup [ ] [ ] 3bi ;" + "" + ": tuck [ nip ] [ ] 2bi ;" + ": swap [ nip ] [ drop ] 2bi ;" + "" + ": over [ ] [ drop ] 2bi ;" + ": pick [ ] [ 2drop ] 3bi ;" + ": 2over [ ] [ drop ] 3bi ;" +} ; ARTICLE: "cleave-combinators" "Cleave combinators" "The cleave combinators apply multiple quotations to a single value." @@ -49,9 +70,11 @@ $nl "Two quotations:" { $subsection bi } { $subsection 2bi } +{ $subsection 3bi } "Three quotations:" { $subsection tri } { $subsection 2tri } +{ $subsection 3tri } "Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" { $code "! First alternative; uses keep" @@ -66,13 +89,38 @@ $nl "The latter is more aesthetically pleasing than the former." $nl "A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "cleave-shuffle-equivalence" } ; + +ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "." $nl -"From the Merriam-Webster Dictionary: " -$nl -{ $strong "cleave" } -{ $list - { $emphasis "To divide by or as if by a cutting blow" } - { $emphasis "To separate into distinct parts and especially into groups having divergent views" } +"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" +{ $code + ": dip [ ] bi* ;" + "" + ": slip [ call ] [ ] bi* ;" + ": 2slip [ call ] [ ] [ ] tri* ;" + "" + ": nip [ drop ] [ ] bi* ;" + ": 2nip [ drop ] [ drop ] [ ] tri* ;" + "" + ": rot" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" + "" + ": -rot" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " 3tri ;" + "" + ": spin" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" } ; ARTICLE: "spread-combinators" "Spread combinators" @@ -96,7 +144,8 @@ $nl } $nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ; +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "spread-shuffle-equivalence" } ; ARTICLE: "apply-combinators" "Apply combinators" "The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application." @@ -496,7 +545,7 @@ HELP: 2bi "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:" { $code "[ p ] [ q ] 2bi" - "2dup p swap q" + "2dup p -rot q" } "In general, the following two lines are equivalent:" { $code @@ -505,6 +554,27 @@ HELP: 2bi } } ; +HELP: 3bi +{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." } +{ $examples + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "3dup p q" + } + "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "3dup p -roll q" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] 3bi" + "[ p ] 3keep q" + } +} ; + HELP: tri { $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } } { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." } @@ -542,6 +612,22 @@ HELP: 2tri } } ; +HELP: 3tri +{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." } +{ $examples + "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 3tri" + "3dup p 3dup q r" + } + "In general, the following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 3tri" + "[ p ] 3keep [ q ] 3keep r" + } +} ; + HELP: bi* { $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } } diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index f6317e7475..5204d7d45a 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -188,7 +188,7 @@ IN: math.intervals.tests { max interval-max } } "math.ratios.private" vocab [ - { / interval/ } add + { / interval/ } suffix ] when random ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index aef48452de..108c715ef0 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -60,7 +60,7 @@ sequences.private combinators ; [ value-literal sequence? ] [ drop f ] if ; : member-quot ( seq -- newquot ) - [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ; + [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ; : expand-member ( #call -- ) dup node-in-d peek value-literal member-quot f splice-quot ; diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 560a174289..cbdb1b9ec4 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -32,7 +32,7 @@ IN: optimizer.specializers : method-declaration ( method -- quot ) dup "method-generic" word-prop dispatch# object - swap "method-class" word-prop add* ; + swap "method-class" word-prop prefix ; : specialize-method ( quot method -- quot' ) method-declaration [ declare ] curry prepend ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 36e5decd05..58c68a3614 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -294,7 +294,7 @@ M: no-word-error summary scan { { ";" [ tuple f ] } { "<" [ scan-word ";" parse-tokens ] } - [ >r tuple ";" parse-tokens r> add* ] + [ >r tuple ";" parse-tokens r> prefix ] } case ; ERROR: staging-violation word ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 35b30ac46f..27b63ec26f 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -192,7 +192,7 @@ unit-test "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" - " [ \"hello world foo\" add ] [ ] make ;" + " [ \"hello world foo\" suffix ] [ ] make ;" } ; [ t ] [ diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index a4c9a619b5..d311dfad71 100755 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -10,8 +10,8 @@ IN: quotations.tests ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test -[ [ 1 2 3 ] ] [ [ 1 2 ] 3 add ] unit-test -[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test +[ [ 1 2 3 ] ] [ [ 1 2 ] 3 suffix ] unit-test +[ [ 3 1 2 ] ] [ [ 1 2 ] 3 prefix ] unit-test [ [ "hi" ] ] [ "hi" 1quotation ] unit-test diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 9e8dcd6559..f5e5bfcdb3 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -61,8 +61,8 @@ ARTICLE: "sequences-access" "Accessing sequence elements" ARTICLE: "sequences-add-remove" "Adding and removing sequence elements" "Adding elements:" -{ $subsection add } -{ $subsection add* } +{ $subsection prefix } +{ $subsection suffix } "Removing elements:" { $subsection remove } { $subsection seq-diff } ; @@ -641,22 +641,22 @@ HELP: push-new } { $side-effects "seq" } ; -{ push push-new add add* } related-words +{ push push-new prefix suffix } related-words -HELP: add +HELP: suffix { $values { "seq" sequence } { "elt" object } { "newseq" sequence } } { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." } { $examples - { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" } + { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" } } ; -HELP: add* +HELP: prefix { $values { "seq" sequence } { "elt" object } { "newseq" sequence } } { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." } { $examples -{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" } +{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" } } ; HELP: seq-diff @@ -940,7 +940,7 @@ HELP: unclip { $values { "seq" sequence } { "rest" sequence } { "first" object } } { $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." } { $examples - { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" } + { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip suffix ." "{ 2 3 1 }" } } ; HELP: unclip-slice diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 1f2a6c5501..ca46066861 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -478,18 +478,18 @@ M: sequence <=> : push-new ( elt seq -- ) [ delete ] 2keep push ; -: add ( seq elt -- newseq ) - over >r over length 1+ r> [ - [ >r over length r> set-nth-unsafe ] keep - [ 0 swap copy ] keep - ] new-like ; - -: add* ( seq elt -- newseq ) +: prefix ( seq elt -- newseq ) over >r over length 1+ r> [ [ 0 swap set-nth-unsafe ] keep [ 1 swap copy ] keep ] new-like ; +: suffix ( seq elt -- newseq ) + over >r over length 1+ r> [ + [ >r over length r> set-nth-unsafe ] keep + [ 0 swap copy ] keep + ] new-like ; + : seq-diff ( seq1 seq2 -- newseq ) swap [ member? not ] curry subset ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index dfd5c1b32a..e46e507b9d 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -14,7 +14,7 @@ C: slot-spec >r create-method r> define ; : define-slot-word ( class slot word quot -- ) - rot >fixnum add* define-typecheck ; + rot >fixnum prefix define-typecheck ; : reader-quot ( decl -- quot ) [ @@ -23,9 +23,6 @@ C: slot-spec [ drop ] [ 1array , \ declare , ] if ] [ ] make ; -: slot-named ( name specs -- spec/f ) - [ slot-spec-name = ] with find nip ; - : create-accessor ( name effect -- word ) >r "accessors" create dup r> "declared-effect" set-word-prop ; @@ -82,3 +79,6 @@ C: slot-spec dup slot-spec-offset swap slot-spec-name define-slot-methods ] with each ; + +: slot-named ( name specs -- spec/f ) + [ slot-spec-name = ] with find nip ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 9be1d5fc64..260a08c044 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -76,5 +76,5 @@ INSTANCE: groups sequence 1 head-slice* [ "\r" ?tail drop "\r" split ] map - ] keep peek "\r" split add concat + ] keep peek "\r" split suffix concat ] if ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 57947eefb0..1489750154 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -20,7 +20,7 @@ V{ : vocab-dir+ ( vocab str/f -- path ) >r vocab-name "." split r> - [ >r dup peek r> append add ] when* + [ >r dup peek r> append suffix ] when* "/" join ; : vocab-dir? ( root name -- ? ) diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 886417b715..a6a5a014a7 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -82,7 +82,7 @@ SYMBOL: load-vocab-hook ! ( name -- ) : child-vocab? ( prefix name -- ? ) 2dup = pick empty? or - [ 2drop t ] [ swap CHAR: . add head? ] if ; + [ 2drop t ] [ swap CHAR: . suffix head? ] if ; : child-vocabs ( vocab -- seq ) vocab-name vocabs [ child-vocab? ] with subset ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 30c3beb1ef..215b677e16 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -49,7 +49,7 @@ HINTS: random fixnum ; : make-cumulative ( freq -- chars floats ) dup keys >byte-array - swap values >float-array unclip [ + ] accumulate swap add ; + swap values >float-array unclip [ + ] accumulate swap suffix ; :: select-random ( seed chars floats -- seed elt ) floats seed random -rot diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 8a1d93aceb..63fd55a550 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -32,7 +32,7 @@ VAR: color ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ; +: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ; : gl-set-hsba ( hsva -- ) hsva>rgba gl-color ; diff --git a/extra/singleton/authors.txt b/extra/classes/singleton/authors.txt similarity index 100% rename from extra/singleton/authors.txt rename to extra/classes/singleton/authors.txt diff --git a/extra/singleton/singleton-docs.factor b/extra/classes/singleton/singleton-docs.factor similarity index 64% rename from extra/singleton/singleton-docs.factor rename to extra/classes/singleton/singleton-docs.factor index 92ddcc494a..95b5b6af18 100644 --- a/extra/singleton/singleton-docs.factor +++ b/extra/classes/singleton/singleton-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel words ; -IN: singleton +IN: classes.singleton HELP: SINGLETON: { $syntax "SINGLETON: class" @@ -12,15 +12,3 @@ HELP: SINGLETON: } { $see-also POSTPONE: PREDICATE: } ; - -HELP: SINGLETONS: -{ $syntax "SINGLETONS: classes... ;" -} { $values - { "classes" "new singletons to define" } -} { $description - "Defines a new singleton for each class in the list." -} { $examples - { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" } -} { $see-also - POSTPONE: SINGLETON: -} ; diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor new file mode 100644 index 0000000000..453a2a0ea5 --- /dev/null +++ b/extra/classes/singleton/singleton-tests.factor @@ -0,0 +1,12 @@ +USING: kernel singleton tools.test prettyprint io.streams.string ; +IN: classes.singleton.tests + +[ ] [ SINGLETON: bzzt ] unit-test +[ t ] [ bzzt bzzt? ] unit-test +[ t ] [ bzzt bzzt eq? ] unit-test +GENERIC: zammo ( obj -- ) +[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test +[ "yes!" ] [ bzzt zammo ] unit-test +[ ] [ SINGLETON: omg ] unit-test +[ t ] [ omg singleton? ] unit-test +[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test diff --git a/extra/classes/singleton/singleton.factor b/extra/classes/singleton/singleton.factor new file mode 100755 index 0000000000..61a519679c --- /dev/null +++ b/extra/classes/singleton/singleton.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes.predicate kernel namespaces parser quotations +sequences words prettyprint prettyprint.backend prettyprint.sections +compiler.units classes ; +IN: classes.singleton + +PREDICATE: singleton < predicate-class + [ "predicate-definition" word-prop ] + [ [ eq? ] curry ] bi sequence= ; + +: define-singleton ( token -- ) + create-class-in + dup save-location + \ singleton + over [ eq? ] curry define-predicate-class ; + +: SINGLETON: + scan define-singleton ; parsing + +M: singleton see-class* ( class -- ) + class_addMethods ; : encode-types ( return types -- encoding ) - swap add* [ + swap prefix [ alien>objc-types get at "0" append ] map concat ; diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 647c83d667..0480235dfe 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -21,7 +21,7 @@ M: color-preview model-changed swap model-value over set-gadget-interior relayout-1 ; : ( model -- model ) - [ [ 256 /f ] map 1 add ] ; + [ [ 256 /f ] map 1 suffix ] ; : ( -- model gadget ) 3 [ drop 0 0 0 255 ] map diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index d99fe7e1d2..8018adaaa4 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,5 +1,5 @@ -USING: kernel sequences macros combinators ; +USING: kernel arrays sequences macros combinators ; IN: combinators.cleave @@ -21,6 +21,18 @@ MACRO: <2arr> ( seq -- ) [ >quots ] [ length ] bi '[ , 2cleave , narray ] ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {1} ( x -- {x} ) 1array ; inline +: {2} ( x y -- {x,y} ) 2array ; inline +: {3} ( x y z -- {x,y,z} ) 3array ; inline + +: {n} narray ; + +: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline + +: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Spread into array ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -28,3 +40,8 @@ MACRO: <2arr> ( seq -- ) MACRO: ( seq -- ) [ >quots ] [ length ] bi '[ , spread , narray ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline +: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 3c73a933e9..98bc451a6f 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes mirrors classes.tuple combinators calendar.format symbols -singleton ; +classes.singleton ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -131,25 +131,17 @@ TUPLE: no-sql-modifier ; HOOK: bind% db ( spec -- ) -TUPLE: no-slot-named ; -: no-slot-named ( -- * ) T{ no-slot-named } throw ; - -: slot-spec-named ( str class -- slot-spec ) - "slots" word-prop [ slot-spec-name = ] with find nip - [ no-slot-named ] unless* ; - : offset-of-slot ( str obj -- n ) - class slot-spec-named slot-spec-offset ; + class "slots" word-prop slot-named slot-spec-offset ; -: get-slot-named ( str obj -- value ) - tuck offset-of-slot [ no-slot-named ] unless* slot ; +: get-slot-named ( name obj -- value ) + tuck offset-of-slot slot ; -: set-slot-named ( value str obj -- ) - tuck offset-of-slot [ no-slot-named ] unless* set-slot ; +: set-slot-named ( value name obj -- ) + tuck offset-of-slot set-slot ; : tuple>filled-slots ( tuple -- alist ) - dup mirror-slots [ slot-spec-name ] map - swap tuple-slots 2array flip [ nip ] assoc-subset ; + [ nip ] assoc-subset ; : tuple>params ( specs tuple -- obj ) [ diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 7f24d6258f..eadd1a03e8 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,7 +27,7 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add >r swap create-method r> define ; + pick suffix >r swap create-method r> define ; : define-consult ( class group quot -- ) >r group-words swap r> diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 85d58e7572..c442dfaa94 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -43,7 +43,7 @@ SYMBOL: edit-hook : fix ( word -- ) "Fixing " write dup pprint " and all usages..." print nl - dup usage swap add* [ + dup usage swap prefix [ "Editing " write dup . "RETURN moves on to the next usage, C+d stops." print flush diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor index c6d9cd04d2..1022a02d7e 100644 --- a/extra/faq/faq.factor +++ b/extra/faq/faq.factor @@ -69,7 +69,7 @@ C: faq : html>faq ( div -- faq ) unclip swap { "h3" "ol" } [ tags-named ] with map - first2 >r f add* r> [ html>question-list ] 2map ; + first2 >r f prefix r> [ html>question-list ] 2map ; : header, ( faq -- ) dup faq-header , diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 490ce992ab..d983bd2715 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -28,7 +28,7 @@ DEFER: (fry) ! to avoid confusion, remove if fry goes core { namespaces:, [ [ curry ] ((fry)) ] } - [ swap >r add r> (fry) ] + [ swap >r suffix r> (fry) ] } case ] if ; diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 319dd1586b..075ce2d0e8 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -267,16 +267,33 @@ $nl } ; ARTICLE: "cookbook-philosophy" "Factor philosophy" -"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write." +"Learning a stack language is like learning to ride a bicycle: it takes a bit of practice and you might graze your knees a couple of times, but once you get the hang of it, it becomes second nature." $nl -"If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps." -$nl -"If you run into problems with stack shuffling, take a deep breath and a step back, and reconsider the problem. A much simpler solution is waiting right around the corner, a natural solution which requires far less stack shuffling and far less code. As a last resort, if no simple solution exists, consider defining a domain-specific language." -$nl -"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition and save yourself some debugging time." -$nl -"In addition to writing short definitions and testing them interactively, a great habit to get into is writing unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } "." +"The most common difficulty encountered by beginners is trouble reading and writing code as a result of trying to place too many values on the stack at a time." $nl +"Keep the following guidelines in mind to avoid losing your sense of balance:" +{ $list + "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines." + "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code." + "If your code looks repetitive, factor it some more." + "If after factoring, your code still looks repetitive, introduce combinators." + "If after introducing combinators, your code still looks repetitive, look into using meta-programming techniques." + "Try to place items on the stack in the order in which they are needed. If everything is in the correct order, no shuffling needs to be performed." + "If you find yourself writing a stack comment in the middle of a word, break the word up." + { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." } + { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." } + "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." + { "Learn to use the " { $link "inference" } " tool." } + { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } + "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution." + { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } + { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." } + { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." } + { "If you find yourself wishing you could iterate over the datastack, or capture the contents of the datastack into a sequence, or push each element of a sequence onto the datastack, there is almost always a better way. Use " { $link "sequences" } " instead." } + "Don't use meta-programming if there's a simpler way." + "Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast." + { "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." } +} "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 912c3c35f3..1c2dfde85c 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -206,6 +206,7 @@ ARTICLE: "tools" "Developer tools" { $subsection "tools.vocabs" } "Exploratory tools:" { $subsection "editor" } +{ $subsection "listener" } { $subsection "tools.crossref" } { $subsection "inspector" } "Debugging tools:" diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index 5dc7255eed..b963a19f29 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -138,8 +138,7 @@ M: f print-element drop ; link-style get [ write-object ] with-style ; : ($link) ( article -- ) - dup article-name swap >link write-link - span last-element set ; + [ dup article-name swap >link write-link ] ($span) ; : $link ( element -- ) first ($link) ; @@ -235,7 +234,7 @@ M: string ($instance) : values-row ( seq -- seq ) unclip \ $snippet swap ?word-name 2array - swap dup first word? [ \ $instance add* ] when 2array ; + swap dup first word? [ \ $instance prefix ] when 2array ; : $values ( element -- ) "Inputs and outputs" $heading diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index 1e84e544b8..deab40e8d4 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,42 +1,42 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: db db.tuples db.types accessors -http.server.auth.providers kernel continuations -singleton ; -IN: http.server.auth.providers.db - -user "USERS" -{ - { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } - { "realname" "REALNAME" { VARCHAR 256 } } - { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } - { "email" "EMAIL" { VARCHAR 256 } } - { "ticket" "TICKET" { VARCHAR 256 } } - { "profile" "PROFILE" FACTOR-BLOB } -} define-persistent - -: init-users-table user ensure-table ; - -SINGLETON: users-in-db - -: find-user ( username -- user ) - - swap >>username - select-tuple ; - -M: users-in-db get-user - drop - find-user ; - -M: users-in-db new-user - drop - [ - dup username>> find-user [ - drop f - ] [ - dup insert-tuple - ] if - ] with-transaction ; - -M: users-in-db update-user - drop update-tuple ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db db.tuples db.types accessors +http.server.auth.providers kernel continuations +classes.singleton ; +IN: http.server.auth.providers.db + +user "USERS" +{ + { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ } + { "realname" "REALNAME" { VARCHAR 256 } } + { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } + { "email" "EMAIL" { VARCHAR 256 } } + { "ticket" "TICKET" { VARCHAR 256 } } + { "profile" "PROFILE" FACTOR-BLOB } +} define-persistent + +: init-users-table user ensure-table ; + +SINGLETON: users-in-db + +: find-user ( username -- user ) + + swap >>username + select-tuple ; + +M: users-in-db get-user + drop + find-user ; + +M: users-in-db new-user + drop + [ + dup username>> find-user [ + drop f + ] [ + dup insert-tuple + ] if + ] with-transaction ; + +M: users-in-db update-user + drop update-tuple ; diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor index 471b7fa6df..e573b22ba1 100755 --- a/extra/http/server/sessions/storage/db/db.factor +++ b/extra/http/server/sessions/storage/db/db.factor @@ -1,46 +1,46 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs accessors http.server.sessions.storage -alarms kernel http.server db.tuples db.types singleton -math.parser ; -IN: http.server.sessions.storage.db - -SINGLETON: sessions-in-db - -TUPLE: session id namespace ; - -session "SESSIONS" -{ - { "id" "ID" INTEGER +native-id+ } - { "namespace" "NAMESPACE" FACTOR-BLOB } -} define-persistent - -: init-sessions-table session ensure-table ; - -: ( id -- session ) - session construct-empty - swap dup [ string>number ] when >>id ; - -M: sessions-in-db get-session ( id storage -- namespace/f ) - drop - dup [ - - select-tuple dup [ namespace>> ] when - ] when ; - -M: sessions-in-db update-session ( namespace id storage -- ) - drop - - swap >>namespace - update-tuple ; - -M: sessions-in-db delete-session ( id storage -- ) - drop - - delete-tuple ; - -M: sessions-in-db new-session ( namespace storage -- id ) - drop - f - swap >>namespace - [ insert-tuple ] [ id>> number>string ] bi ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs accessors http.server.sessions.storage +alarms kernel http.server db.tuples db.types math.parser +classes.singleton ; +IN: http.server.sessions.storage.db + +SINGLETON: sessions-in-db + +TUPLE: session id namespace ; + +session "SESSIONS" +{ + { "id" "ID" INTEGER +native-id+ } + { "namespace" "NAMESPACE" FACTOR-BLOB } +} define-persistent + +: init-sessions-table session ensure-table ; + +: ( id -- session ) + session construct-empty + swap dup [ string>number ] when >>id ; + +M: sessions-in-db get-session ( id storage -- namespace/f ) + drop + dup [ + + select-tuple dup [ namespace>> ] when + ] when ; + +M: sessions-in-db update-session ( namespace id storage -- ) + drop + + swap >>namespace + update-tuple ; + +M: sessions-in-db delete-session ( id storage -- ) + drop + + delete-tuple ; + +M: sessions-in-db new-session ( namespace storage -- id ) + drop + f + swap >>namespace + [ insert-tuple ] [ id>> number>string ] bi ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1dc7f4883d..e1cc36cd2e 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -6,7 +6,8 @@ IN: io.sockets TUPLE: local path ; -C: local +: ( path -- addrspec ) + normalize-pathname local construct-boa ; TUPLE: inet4 host port ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 7580e7bf6b..2ae4065fb6 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,8 +3,8 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.timeouts io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs -namespaces threads continuations init math -alien.c-types alien vocabs.loader ; +namespaces threads continuations init math alien.c-types alien +vocabs.loader accessors ; IN: io.unix.linux TUPLE: linux-io ; @@ -18,18 +18,16 @@ TUPLE: linux-monitor ; TUPLE: inotify watches ; -: watches ( -- assoc ) inotify get-global inotify-watches ; +: watches ( -- assoc ) inotify get-global watches>> ; : wd>monitor ( wd -- monitor ) watches at ; : ( -- port/f ) H{ } clone - inotify_init dup 0 < [ 2drop f ] [ - inotify - { set-inotify-watches set-delegate } inotify construct - ] if ; + inotify_init [ io-error ] [ inotify ] bi + { set-inotify-watches set-delegate } inotify construct ; -: inotify-fd inotify get-global port-handle ; +: inotify-fd inotify get-global handle>> ; : (add-watch) ( path mask -- wd ) inotify-fd -rot inotify_add_watch dup io-error ; @@ -80,10 +78,10 @@ M: linux-monitor dispose ( monitor -- ) parse-action swap alien>char-string ; : events-exhausted? ( i buffer -- ? ) - buffer-fill >= ; + fill>> >= ; : inotify-event@ ( i buffer -- alien ) - buffer-ptr ; + ptr>> ; : next-event ( i buffer -- i buffer ) 2dup inotify-event@ @@ -111,14 +109,17 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - dup inotify set-global + + dup inotify set-global swap register-io-task ; M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; M: linux-io init-io ( -- ) - dup mx set-global init-inotify ; + + [ mx set-global ] + [ [ init-inotify ] curry ignore-errors ] bi ; T{ linux-io } set-io-backend diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index bd7dfd9ce1..69ce6a3069 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc -combinators ; +combinators io.backend io.files ; IN: io.unix.sockets : pending-init-error ( port -- ) @@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; M: local make-sockaddr - local-path + local-path cwd prepend-path dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index 1741b96e75..6ad0774e38 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -26,32 +26,27 @@ M: number json-print ( num -- ) M: integer json-print ( num -- ) number>string write ; -M: sequence json-print ( array -- string ) +M: sequence json-print ( array -- ) CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ; -: (jsvar-encode) ( char -- char ) - #! Convert the given character to a character usable in - #! javascript variable names. - dup H{ { CHAR: - CHAR: _ } } at dup [ nip ] [ drop ] if ; - : jsvar-encode ( string -- string ) #! Convert the string so that it contains characters usable within #! javascript variable names. - [ (jsvar-encode) ] map ; + { { CHAR: - CHAR: _ } } substitute ; -: tuple>fields ( object -- string ) +: tuple>fields ( object -- seq ) [ [ swap jsvar-encode >json % " : " % >json % ] "" make ] { } assoc>map ; -M: tuple json-print ( tuple -- string ) +M: tuple json-print ( tuple -- ) CHAR: { write1 tuple>fields "," join write CHAR: } write1 ; -M: hashtable json-print ( hashtable -- string ) +M: hashtable json-print ( hashtable -- ) CHAR: { write1 [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ] { } assoc>map "," join write CHAR: } write1 ; -M: object json-print ( object -- string ) +M: object json-print ( object -- ) unparse json-print ; diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index f286690d37..add37173b7 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -184,7 +184,7 @@ DEFER: (d) [ length ] keep [ (graded-ker/im-d) ] curry map ; : graded-betti ( generators -- seq ) - basis graded graded-ker/im-d flip first2 1 head* 0 add* v- ; + basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ; ! Bi-graded for two-step complexes : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank ) @@ -203,7 +203,7 @@ DEFER: (d) [ basis graded ] bi@ tensor bigraded-ker/im-d [ [ [ first ] map ] map ] keep [ [ second ] map 2 head* { 0 0 } prepend ] map - 1 tail dup first length 0 add + 1 tail dup first length 0 suffix [ v- ] 2map ; ! Laplacian diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 52cca64b2f..f642d8881c 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -365,7 +365,7 @@ M: lazy-concat nil? ( lazy-concat -- bool ) drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ add ] lmap-with ] lmap-with lconcat + swap [ swap [ suffix ] lmap-with ] lmap-with lconcat ] reduce ] if ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 5da0225be9..fe4bd65c14 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -108,7 +108,7 @@ UNION: special local quote local-word local-reader local-writer ; : point-free-end ( quot args -- newquot ) over peek special? [ drop-locals >r >r peek r> localize r> append ] - [ drop-locals nip swap peek add ] + [ drop-locals nip swap peek suffix ] if ; : (point-free) ( quot args -- newquot ) @@ -130,9 +130,9 @@ GENERIC: free-vars ( form -- vars ) : add-if-free ( vars object -- vars ) { - { [ dup local-writer? ] [ "local-reader" word-prop add ] } - { [ dup lexical? ] [ add ] } - { [ dup quote? ] [ quote-local add ] } + { [ dup local-writer? ] [ "local-reader" word-prop suffix ] } + { [ dup lexical? ] [ suffix ] } + { [ dup quote? ] [ quote-local suffix ] } { [ t ] [ free-vars append ] } } cond ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 42545500a5..664337c3d3 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -17,7 +17,7 @@ SYMBOL: CRITICAL { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; : send-to-log-server ( array string -- ) - add* "log-server" get send ; + prefix "log-server" get send ; SYMBOL: log-service diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor index d8429e7aaf..87536476ee 100644 --- a/extra/lsys/tortoise/graphics/graphics.factor +++ b/extra/lsys/tortoise/graphics/graphics.factor @@ -77,7 +77,7 @@ VAR: color-table { 0.25 0.25 0.25 } ! dark grey { 0.75 0.75 0.75 } ! medium grey { 1 1 1 } ! white -} [ 1 add ] map >color-table ; +} [ 1 suffix ] map >color-table ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/match/match.factor b/extra/match/match.factor index 2c6923a6ba..825d58c7c2 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -65,3 +65,26 @@ MACRO: match-cond ( assoc -- ) -rot match [ "Pattern does not match" throw ] unless* [ replace-patterns ] bind ; + +: ?1-tail ( seq -- tail/f ) + dup length zero? not [ 1 tail ] [ drop f ] if ; + +: (match-first) ( seq pattern-seq -- bindings leftover/f ) + 2dup [ length ] bi@ < [ 2drop f f ] + [ + 2dup length head over match + [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if* + ] if ; + +: match-first ( seq pattern-seq -- bindings ) + (match-first) drop ; + +: (match-all) ( seq pattern-seq -- ) + tuck (match-first) swap + [ + , [ swap (match-all) ] [ drop ] if* + ] [ 2drop ] if* ; + +: match-all ( seq pattern-seq -- bindings-seq ) + [ (match-all) ] { } make ; + diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index 99a098ca09..487d9828ea 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -18,7 +18,7 @@ IN: math.combinatorics 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; + [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor index d6ac71e629..0b0d3520ef 100644 --- a/extra/math/polynomials/polynomials.factor +++ b/extra/math/polynomials/polynomials.factor @@ -22,7 +22,7 @@ PRIVATE> : p= ( p p -- ? ) pextend = ; : ptrim ( p -- p ) - dup singleton? [ [ zero? ] right-trim ] unless ; + dup length 1 = [ [ zero? ] right-trim ] unless ; : 2ptrim ( p p -- p p ) [ ptrim ] bi@ ; : p+ ( p p -- p ) pextend v+ ; diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index b77ac725ab..cba8c28310 100755 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -79,7 +79,7 @@ SYMBOL: and-needed? ] if ; : recombine ( seq -- str ) - dup singleton? [ + dup length 1 = [ first 3digits>text ] [ dup set-conjunction "" swap diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index ac62fb08f9..5ea19bc957 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -191,14 +191,14 @@ M: hook-combination generic-prologue [ delete-at ] with-methods ; : method>spec ( method -- spec ) - dup method-classes swap method-generic add* ; + dup method-classes swap method-generic prefix ; : parse-method ( -- quot classes generic ) parse-definition dup 2 tail over second rot first ; : METHOD: location - >r parse-method [ define-method ] 2keep add* r> + >r parse-method [ define-method ] 2keep prefix r> remember-definition ; parsing ! For compatibility diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor new file mode 100644 index 0000000000..a5db87ca37 --- /dev/null +++ b/extra/newfx/newfx.factor @@ -0,0 +1,50 @@ + +USING: kernel sequences assocs qualified ; + +QUALIFIED: sequences + +IN: newfx + +! Now, we can see a new world coming into view. +! A world in which there is the very real prospect of a new world order. +! +! - George Herbert Walker Bush + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: nth-at ( seq i -- val ) swap nth ; +: nth-of ( i seq -- val ) nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: nth-is ( seq i val -- seq ) swap pick set-nth ; + +: is-nth ( seq val i -- seq ) pick set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: at-key ( tbl key -- val ) swap at ; +: key-of ( key tbl -- val ) at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: key-is ( tbl key val -- tbl ) swap pick set-at ; +: is-key ( tbl val key -- tbl ) pick set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: push ( seq obj -- seq ) over sequences:push ; +: push-on ( obj seq -- seq ) tuck sequences:push ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: member? ( seq obj -- ? ) swap sequences:member? ; +: member-of? ( obj seq -- ? ) sequences:member? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: delete-at-key ( tbl key -- tbl ) over delete-at ; +: delete-key-of ( key tbl -- tbl ) tuck delete-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index 01725ee9a9..fd9be4eb12 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -38,7 +38,7 @@ reset-gl-function-number-counter gl-function-calling-convention scan scan dup - scan drop "}" parse-tokens swap add* + scan drop "}" parse-tokens swap prefix gl-function-number [ gl-function-pointer ] 2curry swap ";" parse-tokens [ "()" subseq? not ] subset diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor index c689f729d1..c85c0ee218 100755 --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -11,11 +11,12 @@ namespaces math math.parser openssl prettyprint sequences tools.test ; ] [ "Hello world from the openssl binding" >md5 ] unit-test -[ - B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 - 82 115 0 } -] -[ "Hello world from the openssl binding" >sha1 ] unit-test +! Not found on netbsd, windows -- why? +! [ + ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 + ! 82 115 0 } +! ] +! [ "Hello world from the openssl binding" >sha1 ] unit-test ! ========================================================= ! Initialize context diff --git a/extra/oracle/oracle.factor b/extra/oracle/oracle.factor index d725de5994..a30ce64854 100644 --- a/extra/oracle/oracle.factor +++ b/extra/oracle/oracle.factor @@ -236,13 +236,13 @@ C: connection : fetch-each ( object -- object ) fetch-statement [ - buf get alien>char-string res get swap add res set + buf get alien>char-string res get swap suffix res set fetch-each ] [ ] if ; : run-query ( object -- object ) execute-statement [ - buf get alien>char-string res get swap add res set + buf get alien>char-string res get swap suffix res set fetch-each ] [ ] if ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index d6aacf9645..d8fccfb8f9 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -132,7 +132,7 @@ TUPLE: and-parser parsers ; : <&> ( parser1 parser2 -- parser ) over and-parser? [ - >r and-parser-parsers r> add + >r and-parser-parsers r> suffix ] [ 2array ] if and-parser construct-boa ; @@ -239,11 +239,11 @@ M: some-parser parse ( input parser -- result ) : <:&> ( parser1 parser2 -- result ) #! Same as <&> except flatten the result. - <&> [ first2 add ] <@ ; + <&> [ first2 suffix ] <@ ; : <&:> ( parser1 parser2 -- result ) #! Same as <&> except flatten the result. - <&> [ first2 swap add* ] <@ ; + <&> [ first2 swap prefix ] <@ ; : <:&:> ( parser1 parser2 -- result ) #! Same as <&> except flatten the result. diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ad821635d7..217805ce47 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -112,7 +112,7 @@ C: peg-head :: (setup-lr) ( r l s -- ) s head>> l head>> eq? [ l head>> s (>>head) - l head>> [ s rule>> add ] change-involved-set drop + l head>> [ s rule>> suffix ] change-involved-set drop r l s next>> (setup-lr) ] unless ; @@ -144,7 +144,7 @@ C: peg-head h [ p heads get at ] | h [ - m r h involved-set>> h rule>> add member? not and [ + m r h involved-set>> h rule>> suffix member? not and [ fail p ] [ r h eval-set>> member? [ diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index ffe3a4bca1..cf09277f31 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -76,10 +76,10 @@ PRIVATE> dup first 2 tail* swap second 2 head = ; : clean ( seq -- seq ) - [ unclip 1 head add* concat ] map [ all-unique? ] subset ; + [ unclip 1 head prefix concat ] map [ all-unique? ] subset ; : add-missing-digit ( seq -- seq ) - dup natural-sort 10 seq-diff first add* ; + dup natural-sort 10 seq-diff first prefix ; : interesting-pandigitals ( -- seq ) 17 candidates { 13 11 7 5 3 2 } [ diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 087b216b3a..5829f66c01 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -72,7 +72,7 @@ PRIVATE> : max-path ( triangle -- n ) dup length 1 > [ - 2 cut* first2 max-children [ + ] 2map add max-path + 2 cut* first2 max-children [ + ] 2map suffix max-path ] [ first first ] if ; @@ -95,7 +95,7 @@ PRIVATE> ! Not strictly needed, but it is nice to be able to dump the triangle after the ! propagation : propagate-all ( triangle -- newtriangle ) - reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ; + reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ; : sum-divisors ( n -- sum ) dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ; diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index b4eb4558fa..69e4c09b6e 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -4,7 +4,7 @@ IN: qualified : define-qualified ( vocab-name -- ) dup require - dup vocab-words swap CHAR: : add + dup vocab-words swap CHAR: : suffix [ -rot >r append r> ] curry assoc-map use get push ; diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor index ad9dae51ae..8ddbdac6f4 100755 --- a/extra/random/mersenne-twister/mersenne-twister.factor +++ b/extra/random/mersenne-twister/mersenne-twister.factor @@ -4,7 +4,7 @@ ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c USING: arrays kernel math namespaces sequences system init -accessors math.ranges new-effects random ; +accessors math.ranges random ; IN: random.mersenne-twister = [ - ] [ drop ] if ; inline : mt-wrap ( x -- y ) mt-n wrap ; inline -: set-generated ( mt y from-elt to -- ) - >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi - r> bitxor bitxor r> new-set-nth drop ; inline +: set-generated ( y from-elt to seq -- ) + >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi + r> bitxor bitxor r> r> set-nth ; inline -: calculate-y ( mt y1 y2 -- y ) - >r over r> - [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline +: calculate-y ( y1 y2 mt -- y ) + tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline -: (mt-generate) ( mt-seq n -- y to from-elt ) - [ dup 1+ mt-wrap calculate-y ] - [ mt-m + mt-wrap new-nth ] - [ nip ] 2tri ; +: (mt-generate) ( n mt-seq -- y to from-elt ) + [ >r dup 1+ mt-wrap r> calculate-y ] + [ >r mt-m + mt-wrap r> nth ] + [ drop ] 2tri ; : mt-generate ( mt -- ) - [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ] + [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ] [ 0 >>i drop ] bi ; : init-mt-first ( seed -- seq ) >r mt-n 0 r> - HEX: ffffffff bitand 0 new-set-nth ; + HEX: ffffffff bitand 0 pick set-nth ; : init-mt-formula ( seq i -- f(seq[i]) ) - tuck new-nth dup -30 shift bitxor 1812433253 * + + tuck swap nth dup -30 shift bitxor 1812433253 * + 1+ HEX: ffffffff bitand ; : init-mt-rest ( seq -- ) mt-n 1- [0,b) [ - dupd [ init-mt-formula ] keep 1+ new-set-nth drop + dupd [ init-mt-formula ] keep 1+ rot set-nth ] with each ; : init-mt-seq ( seed -- seq ) @@ -68,7 +67,7 @@ M: mersenne-twister seed-random ( mt seed -- ) init-mt-seq >>seq drop ; M: mersenne-twister random-32* ( mt -- r ) - dup [ seq>> ] [ i>> ] bi - dup mt-n < [ drop 0 pick mt-generate ] unless - new-nth mt-temper + dup [ i>> ] [ seq>> ] bi + over mt-n < [ nip >r dup mt-generate 0 r> ] unless + nth mt-temper swap [ 1+ ] change-i drop ; diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index f3f55007f0..3be2697bdf 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,5 +1,5 @@ USING: alien.c-types io io.files io.nonblocking kernel -namespaces random io.encodings.binary singleton init +namespaces random io.encodings.binary init accessors system ; IN: random.unix diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index fa36a7c6f8..b0cd61bd8f 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -21,7 +21,7 @@ SYMBOL: ignore-case? if 2curry ; : or-predicates ( quots -- quot ) - [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ; : <@literal [ nip ] curry <@ ; diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor index 1f2bbde171..8c26d880f1 100644 --- a/extra/regexp2/regexp2.factor +++ b/extra/regexp2/regexp2.factor @@ -21,7 +21,7 @@ SYMBOL: ignore-case? if 2curry ; : or-predicates ( quots -- quot ) - [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ; : literal-action [ nip ] curry action ; diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor index 541570f3f9..9629d569cb 100755 --- a/extra/sequences/deep/deep-tests.factor +++ b/extra/sequences/deep/deep-tests.factor @@ -11,7 +11,7 @@ IN: sequences.deep.tests [ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test : change-something ( seq -- newseq ) - dup array? [ "hi" add ] [ "hello" append ] if ; + dup array? [ "hi" suffix ] [ "hello" append ] if ; [ { { "heyhello" "hihello" } "hihello" } ] [ "hey" 1array 1array [ change-something ] deep-map ] unit-test diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 6e6a924382..99565e966c 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -46,9 +46,6 @@ IN: sequences.lib.tests [ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ] [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test -[ f ] [ { } singleton? ] unit-test -[ t ] [ { "asdf" } singleton? ] unit-test -[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test [ V{ } [ delete-random drop ] keep length ] must-fail diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0b93552e76..945ba1a3b7 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -94,13 +94,10 @@ MACRO: firstn ( n -- ) : monotonic-split ( seq quot -- newseq ) [ - >r dup unclip add r> + >r dup unclip suffix r> v, [ pick ,, call [ v, ] unless ] curry 2each ,v ] { } make ; -: singleton? ( seq -- ? ) - length 1 = ; - : delete-random ( seq -- value ) [ length random ] keep [ nth ] 2keep delete-nth ; diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index ac247057f4..7a2fbfae9e 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -90,13 +90,13 @@ M: float (serialize) ( obj -- ) M: complex (serialize) ( obj -- ) CHAR: c write1 - dup real-part (serialize) - imaginary-part (serialize) ; + [ real-part (serialize) ] + [ imaginary-part (serialize) ] bi ; M: ratio (serialize) ( obj -- ) CHAR: r write1 - dup numerator (serialize) - denominator (serialize) ; + [ numerator (serialize) ] + [ denominator (serialize) ] bi ; : serialize-seq ( obj code -- ) [ @@ -120,7 +120,8 @@ M: array (serialize) ( obj -- ) M: quotation (serialize) ( obj -- ) [ - CHAR: q write1 [ >array (serialize) ] [ add-object ] bi + CHAR: q write1 + [ >array (serialize) ] [ add-object ] bi ] serialize-shared ; M: hashtable (serialize) ( obj -- ) @@ -234,10 +235,12 @@ SYMBOL: deserialized ] if ; : deserialize-gensym ( -- word ) - gensym - dup intern-object - dup (deserialize) define - dup (deserialize) swap set-word-props ; + gensym { + [ intern-object ] + [ (deserialize) define ] + [ (deserialize) swap set-word-props ] + [ ] + } cleave ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor deleted file mode 100644 index 1698181ed3..0000000000 --- a/extra/singleton/singleton-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: kernel singleton tools.test ; -IN: singleton.tests - -[ ] [ SINGLETON: bzzt ] unit-test -[ t ] [ bzzt bzzt? ] unit-test -[ t ] [ bzzt bzzt eq? ] unit-test -GENERIC: zammo ( obj -- ) -[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test -[ "yes!" ] [ bzzt zammo ] unit-test diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor deleted file mode 100755 index 9ec9f2f4a3..0000000000 --- a/extra/singleton/singleton.factor +++ /dev/null @@ -1,16 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.predicate kernel namespaces parser quotations -sequences words ; -IN: singleton - -: define-singleton ( token -- ) - create-class-in - \ word - over [ eq? ] curry define-predicate-class ; - -: SINGLETON: - scan define-singleton ; parsing - -: SINGLETONS: - ";" parse-tokens [ define-singleton ] each ; parsing diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 3a1af786e2..cd6e1a7cfb 100644 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -235,7 +235,7 @@ C: spring 6 nrot 6 nrot 2array 5 nrot 5 nrot 2array 0 0 2array - nodes> swap add >nodes ; + nodes> swap suffix >nodes ; : spng ( id id-a id-b k damp rest-length -- ) 6 nrot drop @@ -243,4 +243,4 @@ C: spring 5 nrot node-id 5 nrot node-id - springs> swap add >springs ; + springs> swap suffix >springs ; diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index cd3cfc6324..489b7aaeb4 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -6,7 +6,7 @@ IN: state-machine ! STATES: set-name state1 state2 ... ; ";" parse-tokens [ length ] keep - unclip add + unclip suffix [ create-in swap 1quotation define ] 2each ; parsing TUPLE: state place data ; diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor index 13850f6bd7..93bbebf34f 100644 --- a/extra/tetris/board/board.factor +++ b/extra/tetris/board/board.factor @@ -37,7 +37,7 @@ TUPLE: board width height rows ; : add-row ( board -- ) dup board-rows over board-width f - add* swap set-board-rows ; + prefix swap set-board-rows ; : top-up-rows ( board -- ) dup board-height over board-rows length = [ diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index b019326ed5..395c4ff924 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -46,7 +46,7 @@ IN: tools.deploy.backend : staging-image-name ( profile -- name ) "staging." - swap strip-word-names? [ "strip" add ] when + swap strip-word-names? [ "strip" suffix ] when "-" join ".image" 3append temp-file ; DEFER: ?make-staging-image @@ -75,7 +75,7 @@ DEFER: ?make-staging-image ] { } make ; : run-factor ( vm flags -- ) - swap add* dup . run-with-output ; inline + swap prefix dup . run-with-output ; inline : make-staging-image ( profile -- ) vm swap staging-command-line run-factor ; diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index d7610c21c8..2f941ad2ce 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -230,7 +230,7 @@ MEMO: all-vocabs-seq ( -- seq ) try-everything load-failures. ; : unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . add ] unless + dup empty? [ CHAR: . suffix ] unless vocabs [ find-vocab-root not ] subset [ @@ -242,7 +242,7 @@ MEMO: all-vocabs-seq ( -- seq ) vocab-roots get [ dup pick (all-child-vocabs) [ >vocab-link ] map ] { } map>assoc - swap unrooted-child-vocabs f swap 2array add ; + swap unrooted-child-vocabs f swap 2array suffix ; : all-child-vocabs-seq ( prefix -- assoc ) vocab-roots get swap [ diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 2aed793a59..d548c0a4f5 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -49,10 +49,10 @@ DEFER: start-walker-thread \ break t "break?" set-word-prop : walk ( quot -- quot' ) - \ break add* [ break rethrow ] recover ; + \ break prefix [ break rethrow ] recover ; : add-breakpoint ( quot -- quot' ) - dup [ break ] head? [ \ break add* ] unless ; + dup [ break ] head? [ \ break prefix ] unless ; : (step-into-quot) ( quot -- ) add-breakpoint call ; @@ -114,7 +114,7 @@ SYMBOL: +stopped+ ] change-frame ; : step-out-msg ( continuation -- continuation' ) - [ nip \ break add ] change-frame ; + [ nip \ break suffix ] change-frame ; { { call [ (step-into-quot) ] } diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor index 789d9b9e6a..ed524148e3 100644 --- a/extra/ui/commands/commands-docs.factor +++ b/extra/ui/commands/commands-docs.factor @@ -14,7 +14,7 @@ IN: ui.commands : command-map. ( command-map -- ) [ command-map-row ] map { "Shortcut" "Command" "Word" "Notes" } - [ \ $strong swap ] { } map>assoc add* + [ \ $strong swap ] { } map>assoc prefix $table ; : $command-map ( element -- ) diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor index fce88c0ebb..533116824b 100755 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -18,7 +18,7 @@ SYMBOL: grid-dim grid-dim get spin set-axis ; : draw-grid-lines ( gaps orientation -- ) - grid get rot grid-positions grid get rect-dim add [ + grid get rot grid-positions grid get rect-dim suffix [ grid-line-from/to gl-line ] with each ; diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 52c5ca8a02..91b7f0f225 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -352,7 +352,7 @@ M: f sloppy-pick-up* : sloppy-pick-up ( loc gadget -- path ) 2dup sloppy-pick-up* dup - [ [ wet-and-sloppy sloppy-pick-up ] keep add* ] + [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ] [ 3drop { } ] if ; diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor index 5ea1ec20fa..ab2abeec5b 100644 --- a/extra/ui/gadgets/slate/slate.factor +++ b/extra/ui/gadgets/slate/slate.factor @@ -3,7 +3,11 @@ USING: kernel namespaces opengl ui.render ui.gadgets ; IN: ui.gadgets.slate -TUPLE: slate action dim graft ungraft ; +TUPLE: slate action dim graft ungraft + button-down + button-up + key-down + key-up ; : ( action -- slate ) slate construct-gadget @@ -19,4 +23,100 @@ M: slate draw-gadget* ( slate -- ) M: slate graft* ( slate -- ) slate-graft call ; -M: slate ungraft* ( slate -- ) slate-ungraft call ; \ No newline at end of file +M: slate ungraft* ( slate -- ) slate-ungraft call ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: key-pressed-value + +: key-pressed? ( -- ? ) key-pressed-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: mouse-pressed-value + +: mouse-pressed? ( -- ? ) mouse-pressed-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: key-value + +: key ( -- key ) key-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: button-value + +: button ( -- val ) button-value get ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: combinators ui.gestures accessors ; + +! M: slate handle-gesture* ( gadget gesture delegate -- ? ) +! drop nip +! { +! { +! [ dup key-down? ] +! [ + +! key-down-sym key-value set +! key-pressed-value on +! t +! ] +! } +! { [ dup key-up? ] [ drop key-pressed-value off t ] } +! { +! [ dup button-down? ] +! [ +! button-down-# mouse-button-value set +! mouse-pressed-value on +! t +! ] +! } +! { [ dup button-up? ] [ drop mouse-pressed-value off t ] } +! { [ t ] [ drop t ] } +! } +! cond ; + +M: slate handle-gesture* ( gadget gesture delegate -- ? ) + rot drop swap ! delegate gesture + { + { + [ dup key-down? ] + [ + key-down-sym key-value set + key-pressed-value on + key-down>> dup [ call ] [ drop ] if + t + ] + } + { + [ dup key-up? ] + [ + key-pressed-value off + drop + key-up>> dup [ call ] [ drop ] if + t + ] } + { + [ dup button-down? ] + [ + button-down-# button-value set + mouse-pressed-value on + button-down>> dup [ call ] [ drop ] if + t + ] + } + { + [ dup button-up? ] + [ + mouse-pressed-value off + drop + button-up>> dup [ call ] [ drop ] if + t + ] + } + { [ t ] [ 2drop t ] } + } + cond ; \ No newline at end of file diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index fc8103b656..ba02f15c7a 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -9,7 +9,7 @@ IN: unix.process ! io.launcher instead. : >argv ( seq -- alien ) - [ malloc-char-string ] map f add >c-void*-array ; + [ malloc-char-string ] map f suffix >c-void*-array ; : exec ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ; diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index 238ff18c39..acd3848f10 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -40,7 +40,7 @@ unless : (parse-com-function) ( tokens -- definition ) [ second ] [ first ] - [ 3 tail 2 group [ first ] map "void*" add* ] + [ 3 tail 2 group [ first ] map "void*" prefix ] tri ; diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index 28237a7b2c..8c74d61656 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -113,7 +113,7 @@ M: regexp text-hash-char drop f ; : rule-chars* ( rule -- string ) dup rule-chars swap rule-start matcher-text - text-hash-char [ add ] when* ; + text-hash-char [ suffix ] when* ; : add-rule ( rule ruleset -- ) >r dup rule-chars* >upper swap diff --git a/extra/ldap/authors.txt b/unmaintained/ldap/authors.txt similarity index 100% rename from extra/ldap/authors.txt rename to unmaintained/ldap/authors.txt diff --git a/extra/ldap/conf/addentry.ldif b/unmaintained/ldap/conf/addentry.ldif similarity index 100% rename from extra/ldap/conf/addentry.ldif rename to unmaintained/ldap/conf/addentry.ldif diff --git a/extra/ldap/conf/createdit.ldif b/unmaintained/ldap/conf/createdit.ldif similarity index 100% rename from extra/ldap/conf/createdit.ldif rename to unmaintained/ldap/conf/createdit.ldif diff --git a/extra/ldap/conf/slapd.conf b/unmaintained/ldap/conf/slapd.conf similarity index 100% rename from extra/ldap/conf/slapd.conf rename to unmaintained/ldap/conf/slapd.conf diff --git a/extra/ldap/ldap-tests.factor b/unmaintained/ldap/ldap-tests.factor similarity index 100% rename from extra/ldap/ldap-tests.factor rename to unmaintained/ldap/ldap-tests.factor diff --git a/extra/ldap/ldap.factor b/unmaintained/ldap/ldap.factor similarity index 100% rename from extra/ldap/ldap.factor rename to unmaintained/ldap/ldap.factor diff --git a/extra/ldap/libldap/authors.txt b/unmaintained/ldap/libldap/authors.txt similarity index 100% rename from extra/ldap/libldap/authors.txt rename to unmaintained/ldap/libldap/authors.txt diff --git a/extra/ldap/libldap/libldap.factor b/unmaintained/ldap/libldap/libldap.factor similarity index 100% rename from extra/ldap/libldap/libldap.factor rename to unmaintained/ldap/libldap/libldap.factor diff --git a/extra/ldap/libldap/tags.txt b/unmaintained/ldap/libldap/tags.txt similarity index 100% rename from extra/ldap/libldap/tags.txt rename to unmaintained/ldap/libldap/tags.txt diff --git a/extra/ldap/summary.txt b/unmaintained/ldap/summary.txt similarity index 100% rename from extra/ldap/summary.txt rename to unmaintained/ldap/summary.txt diff --git a/extra/ldap/tags.txt b/unmaintained/ldap/tags.txt similarity index 100% rename from extra/ldap/tags.txt rename to unmaintained/ldap/tags.txt