Merge with erg's changes

db4
Slava Pestov 2008-04-14 04:42:43 -05:00
commit d42ae9508f
252 changed files with 563 additions and 499 deletions

View File

@ -54,7 +54,7 @@ TUPLE: library path abi dll ;
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
over dup [ dlopen ] when \ library construct-boa ;
over dup [ dlopen ] when \ library boa ;
: load-library ( name -- dll )
library dup [ library-dll ] when ;

View File

@ -19,7 +19,7 @@ getter setter
reg-class size align stack-align? ;
: construct-c-type ( class -- type )
construct-empty
new
int-regs >>reg-class ;
: <c-type> ( -- type )

View File

@ -220,7 +220,7 @@ M: no-such-library compiler-error-type
drop +linkage+ ;
: no-such-library ( name -- )
\ no-such-library construct-boa
\ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
@ -232,7 +232,7 @@ M: no-such-symbol compiler-error-type
drop +linkage+ ;
: no-such-symbol ( name -- )
\ no-such-symbol construct-boa
\ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
@ -251,7 +251,7 @@ M: no-such-symbol compiler-error-type
\ alien-invoke [
! Four literals
4 ensure-values
#alien-invoke construct-empty
#alien-invoke new
! Compile-time parameters
pop-parameters >>parameters
pop-literal nip >>function
@ -288,7 +288,7 @@ M: alien-indirect-error summary
! Three literals and function pointer
4 ensure-values
4 reify-curries
#alien-indirect construct-empty
#alien-indirect new
! Compile-time parameters
pop-literal nip >>abi
pop-parameters >>parameters
@ -335,7 +335,7 @@ M: alien-callback-error summary
\ alien-callback [
4 ensure-values
#alien-callback construct-empty dup node,
#alien-callback new dup node,
pop-literal nip >>quot
pop-literal nip >>abi
pop-parameters >>parameters
@ -381,7 +381,7 @@ TUPLE: callback-context ;
: wrap-callback-quot ( node -- quot )
[
[ quot>> ] [ prepare-callback-return ] bi append ,
[ callback-context construct-empty do-callback ] %
[ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;

View File

@ -68,7 +68,7 @@ M: struct-type stack-size
: (define-struct) ( name vocab size align fields -- )
>r [ align ] keep r>
struct-type construct-boa
struct-type boa
-rot define-c-type ;
: make-field ( struct-name vocab type field-name -- spec )

View File

@ -12,9 +12,9 @@ M: array resize resize-array ;
: >array ( seq -- array ) { } clone-like ;
M: object new drop f <array> ;
M: object new-sequence drop f <array> ;
M: f new drop dup zero? [ drop f ] [ f <array> ] if ;
M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
M: array like drop dup array? [ >array ] unless ;

View File

@ -69,10 +69,10 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection subassoc? }
{ $subsection intersect }
{ $subsection assoc-intersect }
{ $subsection update }
{ $subsection union }
{ $subsection diff }
{ $subsection assoc-union }
{ $subsection assoc-diff }
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
@ -260,7 +260,7 @@ HELP: values
{ keys values } related-words
HELP: intersect
HELP: assoc-intersect
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
@ -270,11 +270,11 @@ HELP: update
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
{ $side-effects "assoc1" } ;
HELP: union
HELP: assoc-union
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
HELP: diff
HELP: assoc-diff
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
;

View File

@ -58,24 +58,24 @@ H{ } clone "cache-test" set
] [
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
intersect
assoc-intersect
] unit-test
[
H{ { 1 2 } { 2 3 } { 6 5 } }
] [
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
union
assoc-union
] unit-test
[ H{ { 1 2 } { 2 3 } } t ] [
f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd =
f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
] unit-test
[
H{ { 1 f } }
] [
H{ { 1 f } } H{ { 1 f } } intersect
H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test

View File

@ -109,17 +109,17 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
] { } assoc>map hashcode* ;
: intersect ( assoc1 assoc2 -- intersection )
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ;
: update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ;
: union ( assoc1 assoc2 -- union )
: assoc-union ( assoc1 assoc2 -- union )
2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ;
: diff ( assoc1 assoc2 -- diff )
: assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ;
: remove-all ( assoc seq -- subseq )

View File

@ -43,7 +43,7 @@ M: bit-array clone (clone) ;
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
M: bit-array new drop <bit-array> ;
M: bit-array new-sequence drop <bit-array> ;
M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ;

View File

@ -7,7 +7,7 @@ IN: bit-vectors
<PRIVATE
: bit-array>vector ( bit-array length -- bit-vector )
bit-vector construct-boa ; inline
bit-vector boa ; inline
PRIVATE>
@ -22,7 +22,7 @@ M: bit-vector like
[ dup length bit-array>vector ] [ >bit-vector ] if
] unless ;
M: bit-vector new
M: bit-vector new-sequence
drop [ <bit-array> ] keep >fixnum bit-array>vector ;
M: bit-vector equal?

View File

@ -53,7 +53,7 @@ nl
"." write flush
{
new nth push pop peek
new-sequence nth push pop peek
} compile
"." write flush

View File

@ -36,4 +36,4 @@ tag-numbers get H{
{ word 17 }
{ byte-array 18 }
{ tuple-layout 19 }
} union type-numbers set
} assoc-union type-numbers set

View File

@ -5,7 +5,7 @@ kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
math.parser generic ;
math.parser generic sets ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time
@ -24,7 +24,7 @@ SYMBOL: bootstrap-time
: load-components ( -- )
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] bi@
seq-diff
diff
[ "bootstrap." prepend require ] each ;
! : compile-remaining ( -- )

View File

@ -5,7 +5,7 @@ IN: boxes
TUPLE: box value full? ;
: <box> ( -- box ) box construct-empty ;
: <box> ( -- box ) box new ;
: >box ( value box -- )
dup box-full? [ "Box already has a value" throw ] when

View File

@ -10,7 +10,7 @@ M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
M: byte-array new drop <byte-array> ;
M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;

View File

@ -7,7 +7,7 @@ IN: byte-vectors
<PRIVATE
: byte-array>vector ( byte-array length -- byte-vector )
byte-vector construct-boa ; inline
byte-vector boa ; inline
PRIVATE>
@ -22,7 +22,7 @@ M: byte-vector like
[ dup length byte-array>vector ] [ >byte-vector ] if
] unless ;
M: byte-vector new
M: byte-vector new-sequence
drop [ <byte-array> ] keep >fixnum byte-array>vector ;
M: byte-vector equal?

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes classes.builtin combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private ;
math hashtables kernel.private sets ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )

View File

@ -89,7 +89,7 @@ M: word reset-class drop ;
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
r> union over set-word-props
r> assoc-union over set-word-props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]

View File

@ -24,7 +24,7 @@ TUPLE: check-mixin-class mixin ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
\ check-mixin-class construct-boa throw
\ check-mixin-class boa throw
] unless ;
: if-mixin-member? ( class mixin true false -- )

View File

@ -4,7 +4,7 @@ generic.standard sequences definitions compiler.units ;
IN: classes.tuple
ARTICLE: "parametrized-constructors" "Parameterized constructors"
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
$nl
"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
{ $code
@ -14,14 +14,14 @@ $nl
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
" car construct-empty"
" car new"
" V{ } clone >>occupants"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
" aeroplane construct-empty"
" aeroplane new"
" V{ } clone >>occupants"
" swap >>max-altitude"
" swap >>max-speed ;"
@ -33,7 +33,7 @@ $nl
": add-occupant ( person vehicle -- ) occupants>> push ;"
""
": construct-vehicle ( class -- vehicle )"
" construct-empty"
" new"
" V{ } clone >>occupants ;"
""
"TUPLE: car < vehicle engine ;"
@ -52,8 +52,8 @@ $nl
ARTICLE: "tuple-constructors" "Tuple constructors"
"Tuples are created by calling one of two constructor primitives:"
{ $subsection construct-empty }
{ $subsection construct-boa }
{ $subsection new }
{ $subsection boa }
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
@ -65,11 +65,11 @@ $nl
"TUPLE: color red green blue alpha ;"
""
"C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above"
": <rgba> color boa ; ! identical to above"
""
": <rgb> f <rgba> ;"
""
": <color> construct-empty ;"
": <color> new ;"
": <color> f f f f <rgba> ; ! identical to above"
}
{ $subsection "parametrized-constructors" } ;
@ -129,7 +129,7 @@ $nl
$nl
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor."
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
{ $see-also "parametrized-constructors" } ;
ARTICLE: "tuple-subclassing" "Tuple subclassing"
@ -164,11 +164,11 @@ ARTICLE: "tuple-examples" "Tuple examples"
}
"We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )"
" employee construct-empty ;" }
" employee new ;" }
"Or we may wish the default constructor to always give employees a starting salary:"
{ $code
": <employee> ( -- employee )"
" employee construct-empty"
" employee new"
" 40000 >>salary ;"
}
"We can define more refined constructors:"
@ -178,7 +178,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
": <employee> ( name position -- person )"
" 40000 employee construct-boa ;"
" 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
@ -191,7 +191,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
"SYMBOL: checks"
""
": <check> ( to amount -- check )"
" checks counter check construct-boa ;"
" checks counter check boa ;"
""
": biweekly-paycheck ( employee -- check )"
" dup name>> swap salary>> 26 / <check> ;"
@ -326,20 +326,20 @@ HELP: tuple>array ( tuple -- array )
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: construct-empty
HELP: new
{ $values { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
{ $examples
{ $example
"USING: kernel prettyprint ;"
"TUPLE: employee number name department ;"
"employee construct-empty ."
"employee new ."
"T{ employee f f f f }"
}
} ;
@ -361,12 +361,12 @@ HELP: construct
" color construct ;"
}
"The last definition is actually equivalent to the following:"
{ $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
{ $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
"Which can be abbreviated further:"
{ $code "C: <rgba> color" }
} ;
HELP: construct-boa
HELP: boa
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;

View File

@ -7,7 +7,7 @@ calendar prettyprint io.streams.string splitting inspector ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
: <rect> rect construct-boa ;
: <rect> rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
@ -198,8 +198,8 @@ SYMBOL: not-a-tuple-class
] unit-test
! Missing check
[ not-a-tuple-class construct-boa ] must-fail
[ not-a-tuple-class construct-empty ] must-fail
[ not-a-tuple-class boa ] must-fail
[ not-a-tuple-class new ] must-fail
TUPLE: erg's-reshape-problem a b c d ;
@ -207,8 +207,8 @@ C: <erg's-reshape-problem> erg's-reshape-problem
! We want to make sure constructors are recompiled when
! tuples are reshaped
: cons-test-1 \ erg's-reshape-problem construct-empty ;
: cons-test-2 \ erg's-reshape-problem construct-boa ;
: cons-test-1 \ erg's-reshape-problem new ;
: cons-test-2 \ erg's-reshape-problem boa ;
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval

View File

@ -208,7 +208,7 @@ M: tuple-class define-tuple-class
: define-error-class ( class superclass slots -- )
[ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ;
dup [ boa throw ] curry define ;
M: tuple-class reset-class
[

View File

@ -3,7 +3,7 @@
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words ;
hashtables sorting words sets ;
: cleave ( x seq -- )
[ call ] with each ;

View File

@ -4,16 +4,16 @@ USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ;
[ T{ color f 1 2 3 } ]
[ 1 2 3 [ color construct-boa ] compile-call ] unit-test
[ 1 2 3 [ color boa ] compile-call ] unit-test
[ 1 3 ] [
1 2 3 color construct-boa
1 2 3 color boa
[ { color-red color-blue } get-slots ] compile-call
] unit-test
[ T{ color f 10 2 20 } ] [
10 20
1 2 3 color construct-boa [
1 2 3 color boa [
[
{ set-color-red set-color-blue } set-slots
] compile-call
@ -21,4 +21,4 @@ TUPLE: color red green blue ;
] unit-test
[ T{ color f f f f } ]
[ [ color construct-empty ] compile-call ] unit-test
[ [ color new ] compile-call ] unit-test

View File

@ -10,7 +10,7 @@ SYMBOL: new-definitions
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
\ redefine-error construct-boa
\ redefine-error boa
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words ;
byte-arrays bit-arrays float-arrays combinators words sets ;
IN: cpu.architecture
! A pseudo-register class for parameters spilled on the stack

View File

@ -104,7 +104,7 @@ M: indirect extended? indirect-base extended? ;
canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect construct-boa dup canonicalize ;
indirect boa dup canonicalize ;
: reg-code "register" word-prop 7 bitand ;

View File

@ -79,7 +79,7 @@ IN: dlists.tests
[ dlist-push-all ] keep
[ dlist-delete-all ] keep
dlist>array
] 2keep seq-diff assert-same-elements
] 2keep diff assert-same-elements
] unit-test
[ ] [

View File

@ -7,7 +7,7 @@ IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist construct-empty
dlist new
0 >>length ;
: dlist-empty? ( dlist -- ? ) front>> not ;

View File

@ -8,7 +8,7 @@ TUPLE: effect in out terminated? ;
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
effect construct-boa ;
effect boa ;
: effect-height ( effect -- n )
dup effect-out length swap effect-in length - ;

View File

@ -24,7 +24,7 @@ M: float-array set-nth-unsafe
M: float-array like
drop dup float-array? [ >float-array ] unless ;
M: float-array new drop 0.0 <float-array> ;
M: float-array new-sequence drop 0.0 <float-array> ;
M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ;

View File

@ -7,7 +7,7 @@ IN: float-vectors
<PRIVATE
: float-array>vector ( float-array length -- float-vector )
float-vector construct-boa ; inline
float-vector boa ; inline
PRIVATE>
@ -22,7 +22,7 @@ M: float-vector like
[ dup length float-array>vector ] [ >float-vector ] if
] unless ;
M: float-vector new
M: float-vector new-sequence
drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;
M: float-vector equal?

View File

@ -10,7 +10,7 @@ IN: generator.fixup
TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required construct-boa , ;
: frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n )
no-stack-frame [
@ -25,7 +25,7 @@ GENERIC: fixup* ( frame-size obj -- frame-size )
TUPLE: label offset ;
: <label> ( -- label ) label construct-empty ;
: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset swap set-label-offset ;
@ -74,7 +74,7 @@ SYMBOL: label-table
TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup construct-boa , ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup label-fixup-class rc-absolute?
@ -84,7 +84,7 @@ M: label-fixup fixup*
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup construct-boa , ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: (rel-fixup) ( arg class type offset -- pair )
pick rc-absolute-cell = cell 4 ? -

View File

@ -202,7 +202,7 @@ M: #dispatch generate-node
: define-if>boolean-intrinsics ( word intrinsics -- )
[
>r [ if>boolean-intrinsic ] curry r>
{ { f "if-scratch" } } +scratch+ associate union
{ { f "if-scratch" } } +scratch+ associate assoc-union
] assoc-map "intrinsics" set-word-prop ;
: define-if-intrinsics ( word intrinsics -- )

View File

@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays
accessors ;
accessors sets ;
IN: generator.registers
SYMBOL: +input+
@ -76,7 +76,7 @@ INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
: <ds-loc> f ds-loc construct-boa ;
: <ds-loc> f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
@ -87,7 +87,7 @@ M: ds-loc live-loc?
! A retain stack location.
TUPLE: rs-loc n class ;
: <rs-loc> f rs-loc construct-boa ;
: <rs-loc> f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
@ -128,7 +128,7 @@ INSTANCE: cached value
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
f tagged construct-boa ;
f tagged boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
@ -238,7 +238,7 @@ M: phantom-stack clone
GENERIC: finalize-height ( stack -- )
: construct-phantom-stack ( class -- stack )
>r 0 V{ } clone r> construct-boa ; inline
>r 0 V{ } clone r> boa ; inline
: (loc)
#! Utility for methods on <loc>
@ -381,7 +381,7 @@ M: value (lazy-load)
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
[ <vreg> ] curry map seq-diff
[ <vreg> ] curry map diff
>vector ;
: compute-free-vregs ( -- )

View File

@ -50,7 +50,7 @@ TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
over class? over generic? and [
\ check-method construct-boa throw
\ check-method boa throw
] unless ; inline
: with-methods ( generic quot -- )

View File

@ -35,7 +35,7 @@ TUPLE: tuple-dispatch-engine echelons ;
dupd <echelon-dispatch-engine>
] if
] assoc-map [ nip ] assoc-subset
\ tuple-dispatch-engine construct-boa ;
\ tuple-dispatch-engine boa ;
: convert-tuple-methods ( assoc -- assoc' )
tuple bootstrap-word

View File

@ -183,22 +183,22 @@ M: ceo salary
[ salary ] must-infer
[ 24000 ] [ employee construct-boa salary ] unit-test
[ 24000 ] [ employee boa salary ] unit-test
[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
[ 24000 ] [ tape-monkey boa salary ] unit-test
[ 36000 ] [ junior-manager construct-boa salary ] unit-test
[ 36000 ] [ junior-manager boa salary ] unit-test
[ 41000 ] [ middle-manager construct-boa salary ] unit-test
[ 41000 ] [ middle-manager boa salary ] unit-test
[ 51000 ] [ senior-manager construct-boa salary ] unit-test
[ 51000 ] [ senior-manager boa salary ] unit-test
[ 102000 ] [ executive construct-boa salary ] unit-test
[ 102000 ] [ executive boa salary ] unit-test
[ ceo construct-boa salary ]
[ ceo boa salary ]
[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
[ intern construct-boa salary ]
[ intern boa salary ]
[ T{ no-next-method f intern salary } = ] must-fail-with
! Weird shit

View File

@ -49,11 +49,7 @@ $nl
ARTICLE: "hashtables.utilities" "Hashtable utilities"
"Utility words to create a new hashtable from a single key/value pair:"
{ $subsection associate }
{ $subsection ?set-at }
"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
{ $subsection prune }
"Test if a sequence contains duplicates in linear time:"
{ $subsection all-unique? } ;
{ $subsection ?set-at } ;
ABOUT: "hashtables"
@ -138,22 +134,6 @@ HELP: >hashtable
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $description "Constructs a hashtable from any assoc." } ;
HELP: prune
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ;
HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
{ $example
"USING: hashtables prettyprint ;"
"{ 0 1 1 2 3 5 } all-unique? ."
"f"
} ;
HELP: rehash
{ $values { "hash" hashtable } }
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;

View File

@ -164,6 +164,3 @@ H{ } "x" set
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test

View File

@ -116,7 +116,7 @@ IN: hashtables
PRIVATE>
: <hashtable> ( n -- hash )
hashtable construct-empty [ reset-hash ] keep ;
hashtable new [ reset-hash ] keep ;
M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
@ -174,18 +174,4 @@ M: hashtable assoc-like
: ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ;
: (prune) ( hash vec elt -- )
rot 2dup key?
[ 3drop ] [ dupd dupd set-at swap push ] if ; inline
: prune ( seq -- newseq )
[ length <hashtable> ]
[ length <vector> ]
[ ] tri
[ >r 2dup r> (prune) ] each nip ;
: all-unique? ( seq -- ? )
[ length ]
[ prune length ] bi = ;
INSTANCE: hashtable assoc

View File

@ -20,11 +20,11 @@ GENERIC: heap-size ( heap -- n )
TUPLE: heap data ;
: <heap> ( class -- heap )
>r V{ } clone r> construct-boa ; inline
>r V{ } clone r> boa ; inline
TUPLE: entry value key heap index ;
: <entry> ( value key heap -- entry ) f entry construct-boa ;
: <entry> ( value key heap -- entry ) f entry boa ;
PRIVATE>

View File

@ -39,9 +39,9 @@ M: inference-error compiler-error-type type>> ;
M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
>r construct-boa r>
>r boa r>
recursive-state get
\ inference-error construct-boa throw ; inline
\ inference-error boa throw ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline

View File

@ -12,7 +12,7 @@ IN: inference.dataflow
TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
<computed> recursive-state get value construct-boa ;
<computed> recursive-state get value boa ;
M: value hashcode* nip value-uid ;
@ -68,16 +68,16 @@ M: object flatten-curry , ;
[ in-d>> ] [ out-d>> ] bi <effect> ;
: param-node ( param class -- node )
construct-empty swap >>param ; inline
new swap >>param ; inline
: in-node ( seq class -- node )
construct-empty swap >>in-d ; inline
new swap >>in-d ; inline
: all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node )
construct-empty swap >>out-d ; inline
new swap >>out-d ; inline
: all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline
@ -111,19 +111,19 @@ TUPLE: #call-label < node ;
TUPLE: #push < node ;
: #push ( -- node ) \ #push construct-empty ;
: #push ( -- node ) \ #push new ;
TUPLE: #shuffle < node ;
: #shuffle ( -- node ) \ #shuffle construct-empty ;
: #shuffle ( -- node ) \ #shuffle new ;
TUPLE: #>r < node ;
: #>r ( -- node ) \ #>r construct-empty ;
: #>r ( -- node ) \ #>r new ;
TUPLE: #r> < node ;
: #r> ( -- node ) \ #r> construct-empty ;
: #r> ( -- node ) \ #r> new ;
TUPLE: #values < node ;
@ -150,7 +150,7 @@ TUPLE: #merge < node ;
TUPLE: #terminate < node ;
: #terminate ( -- node ) \ #terminate construct-empty ;
: #terminate ( -- node ) \ #terminate new ;
TUPLE: #declare < node ;

View File

@ -20,7 +20,7 @@ classes ;
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
\ construct-empty must-infer
\ new must-infer
TUPLE: a-tuple x y z ;

View File

@ -3,7 +3,7 @@
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
inspector hashtables classes generic ;
inspector hashtables classes generic sets ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@ -82,12 +82,12 @@ M: duplicated-slots-error summary
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
] 1 define-transform
\ construct-boa [
\ boa [
dup +inlined+ depends-on
tuple-layout [ <tuple-boa> ] curry
] 1 define-transform
\ construct-empty [
\ new [
1 ensure-values
peek-d value? [
pop-literal
@ -95,7 +95,7 @@ M: duplicated-slots-error summary
tuple-layout [ <tuple> ] curry
swap infer-quot
] [
\ construct-empty 1 1 <effect> make-call-node
\ new 1 1 <effect> make-call-node
] if
] "infer" set-word-prop

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
quotations mirrors splitting math.parser classes vocabs refs ;
quotations mirrors splitting math.parser classes vocabs refs
sets ;
IN: inspector
GENERIC: summary ( object -- string )

View File

@ -30,8 +30,8 @@ ERROR: encode-error ;
<PRIVATE
M: tuple-class <decoder> construct-empty <decoder> ;
M: tuple <decoder> f decoder construct-boa ;
M: tuple-class <decoder> new <decoder> ;
M: tuple <decoder> f decoder boa ;
: >decoder< ( decoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
@ -104,8 +104,8 @@ M: decoder stream-readln ( stream -- str )
M: decoder dispose decoder-stream dispose ;
! Encoding
M: tuple-class <encoder> construct-empty <encoder> ;
M: tuple <encoder> encoder construct-boa ;
M: tuple-class <encoder> new <encoder> ;
M: tuple <encoder> encoder boa ;
: >encoder< ( encoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;

View File

@ -4,7 +4,7 @@ IN: io.streams.duplex.tests
! Test duplex stream close behavior
TUPLE: closing-stream closed? ;
: <closing-stream> closing-stream construct-empty ;
: <closing-stream> closing-stream new ;
M: closing-stream dispose
dup closing-stream-closed? [
@ -15,7 +15,7 @@ M: closing-stream dispose
TUPLE: unclosable-stream ;
: <unclosable-stream> unclosable-stream construct-empty ;
: <unclosable-stream> unclosable-stream new ;
M: unclosable-stream dispose
"Can't close me!" throw ;

View File

@ -9,7 +9,7 @@ IN: io.streams.duplex
TUPLE: duplex-stream in out closed ;
: <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ;
f duplex-stream boa ;
ERROR: stream-closed-twice ;

View File

@ -45,7 +45,7 @@ C: <ignore-close-stream> ignore-close-stream
TUPLE: style-stream < filter-writer style ;
: do-nested-style ( style style-stream -- style stream )
[ style>> swap union ] [ stream>> ] bi ; inline
[ style>> swap assoc-union ] [ stream>> ] bi ; inline
C: <style-stream> style-stream

View File

@ -142,10 +142,10 @@ M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
: construct-empty ( class -- tuple )
: new ( class -- tuple )
tuple-layout <tuple> ;
: construct-boa ( ... class -- tuple )
: boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! Quotation building
@ -203,7 +203,7 @@ GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
: construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ; inline
new [ swap set-slots ] keep ; inline
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline

View File

@ -14,7 +14,7 @@ IN: mirrors
TUPLE: mirror object slots ;
: <mirror> ( object -- mirror )
dup object-slots mirror construct-boa ;
dup object-slots mirror boa ;
: >mirror< ( mirror -- obj slots )
dup mirror-object swap mirror-slots ;

View File

@ -17,7 +17,7 @@ SYMBOL: optimizer-changed
GENERIC: optimize-node* ( node -- node/t changed? )
: ?union ( assoc/f assoc -- hash )
over [ union ] [ nip ] if ;
over [ assoc-union ] [ nip ] if ;
: add-node-literals ( assoc node -- )
over assoc-empty? [
@ -82,7 +82,7 @@ M: node optimize-node* drop t f ;
2dup at* [ swap follow nip ] [ 2drop ] if ;
: union* ( assoc1 assoc2 -- assoc )
union [ keys ] keep
assoc-union [ keys ] keep
[ dupd follow ] curry
H{ } map>assoc ;

View File

@ -19,7 +19,7 @@ sequences.private combinators ;
] "output-classes" set-word-prop
] each
\ construct-empty [
\ new [
dup node-in-d peek node-literal
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop

View File

@ -283,7 +283,7 @@ TUPLE: silly-tuple a b ;
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
[ ] [ [ new ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test

View File

@ -5,7 +5,7 @@ prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.streams.string vocabs
io.encodings.utf8 source-files classes classes.tuple hashtables
compiler.errors compiler.units accessors ;
compiler.errors compiler.units accessors sets ;
IN: parser
TUPLE: lexer text line line-text line-length column ;
@ -164,7 +164,7 @@ name>char-hook global [
TUPLE: parse-error file line column line-text error ;
: <parse-error> ( msg -- error )
\ parse-error construct-empty
\ parse-error new
file get >>file
lexer get line>> >>line
lexer get column>> >>column
@ -261,7 +261,7 @@ M: no-word-error summary
drop "Word not found in current vocabulary search path" ;
: no-word ( name -- newword )
dup no-word-error construct-boa
dup no-word-error boa
swap words-named [ forward-reference? not ] subset
word-restarts throw-restarts
dup word-vocabulary (use+) ;
@ -293,7 +293,7 @@ M: no-word-error summary
scan-word bootstrap-word scan-word create-method-in ;
: shadowed-slots ( superclass slots -- shadowed )
>r all-slot-names r> seq-intersect ;
>r all-slot-names r> intersect ;
: check-slot-shadowing ( class superclass slots -- )
shadowed-slots [
@ -506,14 +506,14 @@ SYMBOL: interactive-vocabs
] if ;
: filter-moved ( assoc1 assoc2 -- seq )
diff [
assoc-diff [
drop where dup [ first ] when
file get source-file-path =
] assoc-subset keys ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
[ get first2 union ] bi@ ;
[ get first2 assoc-union ] bi@ ;
: removed-classes ( -- assoc1 assoc2 )
new-definitions old-definitions

View File

@ -7,7 +7,8 @@ vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.predicate classes.singleton combinators quotations ;
classes.predicate classes.singleton combinators quotations
sets ;
: make-pprint ( obj quot -- block in use )
[

View File

@ -17,7 +17,7 @@ SYMBOL: pprinter-use
TUPLE: pprinter last-newline line-count end-printing indent ;
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter construct-boa ;
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
@ -72,7 +72,7 @@ start-group? end-group?
style overhang ;
: construct-section ( length class -- section )
construct-empty
new
position get >>start
swap position [ + ] change
position get >>end

View File

@ -19,6 +19,6 @@ IN: sbufs.tests
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test
[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test

View File

@ -7,7 +7,7 @@ IN: sbufs
<PRIVATE
: string>sbuf ( string length -- sbuf )
sbuf construct-boa ; inline
sbuf boa ; inline
PRIVATE>
@ -16,7 +16,7 @@ PRIVATE>
M: sbuf set-nth-unsafe
underlying >r >r >fixnum r> >fixnum r> set-string-nth ;
M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;
M: sbuf new-sequence drop [ 0 <string> ] keep >fixnum string>sbuf ;
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline

View File

@ -33,7 +33,7 @@ ARTICLE: "sequence-protocol" "Sequence protocol"
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
{ $subsection new }
{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
@ -64,8 +64,7 @@ ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection seq-diff } ;
{ $subsection remove } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
@ -234,6 +233,7 @@ $nl
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
{ $subsection "sets" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
@ -281,7 +281,7 @@ HELP: immutable
{ $description "Throws an " { $link immutable } " error." }
{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
HELP: new
HELP: new-sequence
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
@ -660,10 +660,6 @@ HELP: prefix
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
HELP: seq-diff
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." } ;
HELP: sum-lengths
{ $values { "seq" "a sequence of sequences" } { "n" integer } }
{ $description "Outputs the sum of the lengths of all sequences in " { $snippet "seq" } "." } ;

View File

@ -240,8 +240,8 @@ unit-test
[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
[ V{ f f f } ] [ 3 V{ } new ] unit-test
[ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test
[ V{ f f f } ] [ 3 V{ } new-sequence ] unit-test
[ SBUF" \0\0\0" ] [ 3 SBUF" " new-sequence ] unit-test
[ 0 ] [ f length ] unit-test
[ f first ] must-fail

View File

@ -9,13 +9,13 @@ GENERIC: length ( seq -- n ) flushable
GENERIC: set-length ( n seq -- )
GENERIC: nth ( n seq -- elt ) flushable
GENERIC: set-nth ( elt n seq -- )
GENERIC: new ( len seq -- newseq ) flushable
GENERIC: new-sequence ( len seq -- newseq ) flushable
GENERIC: new-resizable ( len seq -- newseq ) flushable
GENERIC: like ( seq exemplar -- newseq ) flushable
GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq )
over >r >r new r> call r> like ; inline
over >r >r new-sequence r> call r> like ; inline
M: sequence like drop ;
@ -162,7 +162,7 @@ M: virtual-sequence set-nth virtual@ set-nth ;
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
M: virtual-sequence like virtual-seq like ;
M: virtual-sequence new virtual-seq new ;
M: virtual-sequence new-sequence virtual-seq new-sequence ;
INSTANCE: virtual-sequence sequence
@ -197,7 +197,7 @@ ERROR: slice-error reason ;
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
slice construct-boa ; inline
slice boa ; inline
M: slice virtual-seq slice-seq ;
@ -250,7 +250,7 @@ INSTANCE: repetition immutable-sequence
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
: prepare-subseq ( from to seq -- dst i src j n )
[ >r swap - r> new dup 0 ] 3keep
[ >r swap - r> new-sequence dup 0 ] 3keep
-rot drop roll length ; inline
: check-copy ( src n dst -- )
@ -275,7 +275,7 @@ PRIVATE>
(copy) drop ; inline
M: sequence clone-like
>r dup length r> new [ 0 swap copy ] keep ;
>r dup length r> new-sequence [ 0 swap copy ] keep ;
M: immutable-sequence clone-like like ;
@ -444,9 +444,6 @@ PRIVATE>
: memq? ( obj seq -- ? )
[ eq? ] with contains? ;
: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
swap [ member? ] curry subset ;
: remove ( obj seq -- newseq )
[ = not ] with subset ;
@ -512,9 +509,6 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
[ 0 swap copy ] keep
] new-like ;
: seq-diff ( seq1 seq2 -- newseq )
swap [ member? not ] curry subset ;
: peek ( seq -- elt ) dup length 1- swap nth ;
: pop* ( seq -- ) dup length 1- swap set-length ;

View File

@ -0,0 +1,58 @@
USING: kernel help.markup help.syntax sequences ;
IN: sets
ARTICLE: "sets" "Set theoretic operations"
"Remove duplicates:"
{ $subsection prune }
"Test for duplicates:"
{ $subsection all-unique? }
"Set operations on sequences:"
{ $subsection diff }
{ $subsection intersect }
{ $subsection union } ;
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
} ;
HELP: prune
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: sequences prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ;
HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
{ $example
"USING: hashtables prettyprint ;"
"{ 0 1 1 2 3 5 } all-unique? ."
"f"
} ;
HELP: diff
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality."
} { $examples
{ $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
} ;
HELP: intersect
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
{ $examples
{ $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
} ;
HELP: union
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
{ $examples
{ $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "{ 1 2 3 4 }" }
} ;
{ diff intersect union } related-words

View File

@ -0,0 +1,17 @@
USING: kernel sets tools.test ;
IN: sets.tests
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
[ V{ 1 2 3 } ] [ { 1 2 2 3 3 } prune ] unit-test
[ V{ 3 2 1 } ] [ { 3 3 2 2 1 } prune ] unit-test
[ { } ] [ { } { } intersect ] unit-test
[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
[ { } ] [ { } { } diff ] unit-test
[ { 4 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
[ V{ } ] [ { } { } union ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test

31
core/sets/sets.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences vectors ;
IN: sets
: (prune) ( elt hash vec -- )
3dup drop key?
[ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
3drop ; inline
: prune ( seq -- newseq )
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ;
: unique ( seq -- assoc )
[ dup ] H{ } map>assoc ;
: (all-unique?) ( elt hash -- ? )
2dup key? [ 2drop f ] [ dupd set-at t ] if ;
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
: intersect ( seq1 seq2 -- newseq )
unique [ key? ] curry subset ;
: diff ( seq1 seq2 -- newseq )
swap unique [ key? not ] curry subset ;
: union ( seq1 seq2 -- newseq )
append prune ;

View File

@ -69,7 +69,7 @@ M: pathname forget*
pathname-string forget-source ;
: rollback-source-file ( file -- )
dup source-file-definitions new-definitions get [ union ] 2map
dup source-file-definitions new-definitions get [ assoc-union ] 2map
swap set-source-file-definitions ;
SYMBOL: file

View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces strings arrays vectors sequences ;
USING: kernel math namespaces strings arrays vectors sequences
sets ;
IN: splitting
TUPLE: groups seq n sliced? ;
@ -8,7 +9,7 @@ TUPLE: groups seq n sliced? ;
: check-groups 0 <= [ "Invalid group count" throw ] when ;
: <groups> ( seq n -- groups )
dup check-groups f groups construct-boa ; inline
dup check-groups f groups boa ; inline
: <sliced-groups> ( seq n -- groups )
<groups> t over set-groups-sliced? ;
@ -69,7 +70,7 @@ INSTANCE: groups sequence
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
dup "\r\n" seq-intersect empty? [
dup "\r\n" intersect empty? [
1array
] [
"\n" split [

View File

@ -46,6 +46,6 @@ M: string resize resize-string ;
: >string ( seq -- str ) "" clone-like ;
M: string new drop 0 <string> ;
M: string new-sequence drop 0 <string> ;
INSTANCE: string sequence

View File

@ -573,21 +573,21 @@ HELP: ERROR:
""
"TUPLE: invalid-values x y ;"
": invalid-values ( x y -- * )"
" \\ invalid-values construct-boa throw ;"
" \\ invalid-values boa throw ;"
}
} ;
HELP: C:
{ $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }
{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link construct-boa } "." }
{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link boa } "." }
{ $examples
"Suppose the following tuple has been defined:"
{ $code "TUPLE: color red green blue ;" }
"The following two lines are equivalent:"
{ $code
"C: <color> color"
": <color> color construct-boa ;"
": <color> color boa ;"
}
"In both cases, a word " { $snippet "<color>" } " is defined, which reads three values from the stack and creates a " { $snippet "color" } " instance having these values in the " { $snippet "red" } ", " { $snippet "green" } " and " { $snippet "blue" } " slots, respectively."
} ;

View File

@ -166,7 +166,7 @@ IN: bootstrap.syntax
"C:" [
CREATE-WORD
scan-word dup check-tuple
[ construct-boa ] curry define-inline
[ boa ] curry define-inline
] define-syntax
"ERROR:" [

View File

@ -57,7 +57,7 @@ mailbox variables sleep-entry ;
PRIVATE>
: <thread> ( quot name -- thread )
\ thread construct-empty
\ thread new
swap >>name
swap >>quot
\ thread counter >>id

View File

@ -94,6 +94,6 @@ IN: vectors.tests
100 >array dup >vector <reversed> >array >r reverse r> =
] unit-test
[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test

View File

@ -6,7 +6,7 @@ IN: vectors
<PRIVATE
: array>vector ( array length -- vector )
vector construct-boa ; inline
vector boa ; inline
PRIVATE>
@ -19,7 +19,7 @@ M: vector like
dup array? [ dup length array>vector ] [ >vector ] if
] unless ;
M: vector new drop [ f <array> ] keep >fixnum array>vector ;
M: vector new-sequence drop [ f <array> ] keep >fixnum array>vector ;
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;

View File

@ -88,7 +88,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
vocab-link construct-boa ;
vocab-link boa ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;

View File

@ -21,7 +21,7 @@ SYMBOL: alarm-thread
pick callable? [ "Not a quotation" throw ] unless ; inline
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm construct-boa ;
check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
dup dup alarm-time alarms get-global heap-push*

View File

@ -48,7 +48,7 @@ SYMBOL: elements
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
: <element> element construct-empty ;
: <element> element new ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
@ -172,7 +172,7 @@ SYMBOL: tagnum
TUPLE: tag value ;
: <tag> ( -- <tag> ) 4 tag construct-boa ;
: <tag> ( -- <tag> ) 4 tag boa ;
: with-ber ( quot -- )
[

View File

@ -68,7 +68,7 @@ M: x30 g ;
"benchmark.dispatch1" words [ tuple-class? ] subset ;
: a-bunch-of-objects ( -- seq )
my-classes [ construct-empty ] map ;
my-classes [ new ] map ;
: dispatch-benchmark ( -- )
1000000 a-bunch-of-objects

View File

@ -68,7 +68,7 @@ INSTANCE: x30 g
"benchmark.dispatch5" words [ tuple-class? ] subset ;
: a-bunch-of-objects ( -- seq )
my-classes [ construct-empty ] map ;
my-classes [ new ] map ;
: dispatch-benchmark ( -- )
1000000 a-bunch-of-objects

View File

@ -5,6 +5,6 @@ TUPLE: hello n ;
: foo 0 100000000 [ over hello-n + ] times ;
: typecheck-main 0 hello construct-boa foo 2drop ;
: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main

View File

@ -7,6 +7,6 @@ TUPLE: hello n ;
: foo 0 100000000 [ over hello-n* + ] times ;
: typecheck-main 0 hello construct-boa foo 2drop ;
: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main

View File

@ -7,6 +7,6 @@ TUPLE: hello n ;
: foo 0 100000000 [ over hello-n* + ] times ;
: typecheck-main 0 hello construct-boa foo 2drop ;
: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main

View File

@ -7,6 +7,6 @@ TUPLE: hello n ;
: foo 0 100000000 [ over hello-n* + ] times ;
: typecheck-main 0 hello construct-boa foo 2drop ;
: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main

View File

@ -24,7 +24,7 @@ TUPLE: check< number bound ;
M: check< summary drop "Number exceeds upper bound" ;
: check< ( num cmp -- num )
2dup < [ drop ] [ \ check< construct-boa throw ] if ;
2dup < [ drop ] [ \ check< boa throw ] if ;
: ?check ( length -- )
safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;

View File

@ -9,7 +9,7 @@ IN: bubble-chamber.particle.axion
TUPLE: axion < particle ;
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
: <axion> ( -- axion ) axion new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -11,7 +11,7 @@ IN: bubble-chamber.particle.hadron
TUPLE: hadron < particle ;
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
: <hadron> ( -- hadron ) hadron new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -17,7 +17,7 @@ IN: bubble-chamber.particle.muon
TUPLE: muon < particle ;
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
: <muon> ( -- muon ) muon new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -8,7 +8,7 @@ IN: bubble-chamber.particle.quark
TUPLE: quark < particle ;
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
: <quark> ( -- quark ) quark new initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -61,7 +61,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
: <bunny-dlist> ( model -- geom )
GL_COMPILE [ first3 draw-triangles ] make-dlist
bunny-dlist construct-boa ;
bunny-dlist boa ;
: <bunny-buffers> ( model -- geom )
{
@ -76,7 +76,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
]
[ first length 3 * ]
[ third length 3 * ]
} cleave bunny-buffers construct-boa ;
} cleave bunny-buffers boa ;
GENERIC: bunny-geom ( geom -- )
GENERIC: draw-bunny ( geom draw -- )

View File

@ -29,7 +29,7 @@ ERROR: cairo-error string ;
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
[ cairo_image_surface_get_height check-zero ] [ ] tri
cairo-surface>array png construct-boa ;
cairo-surface>array png boa ;
: write-png ( png path -- )
>r png-surface r>

View File

@ -9,7 +9,7 @@ IN: channels
TUPLE: channel receivers senders ;
: <channel> ( -- channel )
V{ } clone V{ } clone channel construct-boa ;
V{ } clone V{ } clone channel boa ;
GENERIC: to ( value channel -- )
GENERIC: from ( channel -- value )

View File

@ -9,7 +9,7 @@ IN: circular
TUPLE: circular seq start ;
: <circular> ( seq -- circular )
0 circular construct-boa ;
0 circular boa ;
: circular-wrap ( n circular -- n circular )
[ start>> + ] keep

View File

@ -7,7 +7,7 @@ HELP: >tuple<
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a b c ;"
"1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
"1 2 3 \\ foo boa \\ foo >tuple< .s"
"1\n2\n3"
}
{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
@ -19,7 +19,7 @@ HELP: >tuple*<
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"TUPLE: foo a bb* ccc dddd* ;"
"1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
"1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
"2\n4"
}
{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }

View File

@ -3,6 +3,6 @@ IN: classes.tuple.lib.tests
TUPLE: foo a b* c d* e f* ;
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple< ] unit-test
[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple*< ] unit-test
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test

View File

@ -49,7 +49,7 @@ IN: cocoa.application
TUPLE: objc-error alien reason ;
: objc-error ( alien -- * )
dup -> reason CF>string \ objc-error construct-boa throw ;
dup -> reason CF>string \ objc-error boa throw ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;

View File

@ -43,7 +43,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
TUPLE: selector name object ;
MEMO: <selector> ( name -- sel ) f \ selector construct-boa ;
MEMO: <selector> ( name -- sel ) f \ selector boa ;
: selector ( selector -- alien )
dup selector-object expired? [
@ -139,7 +139,7 @@ H{
{ "NSRect" "{_NSRect=ffff}" }
{ "NSSize" "{_NSSize=ff}" }
{ "NSRange" "{_NSRange=II}" }
} union alien>objc-types set-global
} assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index* swap subseq

View File

@ -137,7 +137,7 @@ MACRO: map-exec-with ( words -- )
[ 1quotation ] map [ map-call-with ] curry ;
MACRO: construct-slots ( assoc tuple-class -- tuple )
[ construct-empty ] curry swap [
[ new ] curry swap [
[ dip ] curry swap 1quotation [ keep ] curry compose
] { } assoc>map concat compose ;

View File

@ -15,7 +15,7 @@ TUPLE: count-down n promise ;
: <count-down> ( n -- count-down )
dup 0 < [ "Invalid count for count down" throw ] when
<promise> \ count-down construct-boa
<promise> \ count-down boa
dup count-down-check ;
: count-down ( count-down -- )

View File

@ -9,7 +9,7 @@ IN: concurrency.exchangers
TUPLE: exchanger thread object ;
: <exchanger> ( -- exchanger )
<box> <box> exchanger construct-boa ;
<box> <box> exchanger boa ;
: exchange ( obj exchanger -- newobj )
dup exchanger-thread box-full? [

Some files were not shown because too many files have changed in this diff Show More