Merge commit 'origin/master'
Chris Double
commit
9d0485cd8a
|
|
@ -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 [ <c-object> 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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 <file-writer> [ (write-image) ] with-stream ;
|
||||
[ write "..." print flush ]
|
||||
[ binary <file-writer> [ (write-image) ] with-stream ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <array> 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 [ <tuple-boa> ] curry define
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
|
||||
"compose" "kernel" create
|
||||
"tuple" "kernel" lookup
|
||||
|
|
@ -515,8 +523,9 @@ dup tuple-layout [ <tuple-boa> ] curry define
|
|||
} define-tuple-class
|
||||
|
||||
"compose" "kernel" lookup
|
||||
dup f "inline" set-word-prop
|
||||
dup tuple-layout [ <tuple-boa> ] curry define
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
|
|
|
|||
|
|
@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
|
|||
members>> [ class-and ] with map <anonymous-union> ;
|
||||
|
||||
: left-anonymous-intersection-and ( first second -- class )
|
||||
>r members>> r> add <anonymous-intersection> ;
|
||||
>r members>> r> suffix <anonymous-intersection> ;
|
||||
|
||||
: right-anonymous-intersection-and ( first second -- class )
|
||||
members>> swap add <anonymous-intersection> ;
|
||||
members>> swap suffix <anonymous-intersection> ;
|
||||
|
||||
: (class-and) ( first second -- class )
|
||||
{
|
||||
|
|
@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
|
|||
} cond ;
|
||||
|
||||
: left-anonymous-union-or ( first second -- class )
|
||||
>r members>> r> add <anonymous-union> ;
|
||||
>r members>> r> suffix <anonymous-union> ;
|
||||
|
||||
: right-anonymous-union-or ( first second -- class )
|
||||
members>> swap add <anonymous-union> ;
|
||||
members>> swap suffix <anonymous-union> ;
|
||||
|
||||
: (class-or) ( first second -- class )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
|
|
|||
|
|
@ -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" } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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> 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> 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> 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> constructor-update-2
|
||||
|
||||
{ 3 1 } [ <constructor-update-2> ] must-infer-as
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
|
||||
|
||||
{ 5 1 } [ <constructor-update-2> ] must-infer-as
|
||||
|
||||
[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
|
||||
|
||||
! Redefinition problem
|
||||
TUPLE: redefinition-problem ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <tuple> [
|
||||
>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> [
|
||||
[ 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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple= ( tuple1 tuple2 -- ? )
|
||||
over tuple-layout over tuple-layout eq? [
|
||||
dup tuple-size -rot
|
||||
[ >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
|
||||
<tuple-layout> ;
|
||||
|
||||
|
|
@ -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 -- )
|
||||
<reversed> get-slots ;
|
||||
|
||||
M: object construct-empty ( class -- tuple )
|
||||
tuple-layout <tuple> ;
|
||||
|
||||
M: object construct-boa ( ... class -- tuple )
|
||||
tuple-layout <tuple-boa> ;
|
||||
|
||||
! Deprecated
|
||||
M: object set-slots ( ... obj slots -- )
|
||||
<reversed> get-slots ;
|
||||
|
||||
M: object construct ( ... slots class -- tuple )
|
||||
construct-empty [ swap set-slots ] keep ;
|
||||
|
||||
M: object construct-boa ( ... class -- tuple )
|
||||
tuple-layout <tuple-boa> ;
|
||||
: delegates ( obj -- seq )
|
||||
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
|
||||
|
||||
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ]
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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) ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ M: tuple <decoder> f decoder construct-boa ;
|
|||
over decoder-cr [
|
||||
over cr-
|
||||
"\n" ?head [
|
||||
over stream-read1 [ add ] when*
|
||||
over stream-read1 [ suffix ] when*
|
||||
] when
|
||||
] when nip ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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 -- ... )" } } }
|
||||
|
|
|
|||
|
|
@ -188,7 +188,7 @@ IN: math.intervals.tests
|
|||
{ max interval-max }
|
||||
}
|
||||
"math.ratios.private" vocab [
|
||||
{ / interval/ } add
|
||||
{ / interval/ } suffix
|
||||
] when
|
||||
random ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ IN: optimizer.specializers
|
|||
|
||||
: method-declaration ( method -- quot )
|
||||
dup "method-generic" word-prop dispatch# object <array>
|
||||
swap "method-class" word-prop add* ;
|
||||
swap "method-class" word-prop prefix ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration [ declare ] curry prepend ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@ unit-test
|
|||
"IN: prettyprint.tests"
|
||||
": another-soft-break-layout ( node -- quot )"
|
||||
" parse-error-file"
|
||||
" [ <reversed> \"hello world foo\" add ] [ ] make ;"
|
||||
" [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
|
||||
} ;
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ C: <slot-spec> 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> 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> 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- ? )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
} ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 -- )
|
||||
<colon \ SINGLETON: pprint-word pprint-word ;
|
||||
|
|
@ -76,7 +76,7 @@ IN: cocoa.subclassing
|
|||
r> <method-list> class_addMethods ;
|
||||
|
||||
: encode-types ( return types -- encoding )
|
||||
swap add* [
|
||||
swap prefix [
|
||||
alien>objc-types get at "0" append
|
||||
] map concat ;
|
||||
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ M: color-preview model-changed
|
|||
swap model-value over set-gadget-interior relayout-1 ;
|
||||
|
||||
: <color-model> ( model -- model )
|
||||
[ [ 256 /f ] map 1 add <solid> ] <filter> ;
|
||||
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
|
||||
|
||||
: <color-sliders> ( -- model gadget )
|
||||
3 [ drop 0 0 0 255 <range> ] map
|
||||
|
|
|
|||
|
|
@ -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: <arr*> ( 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
|
||||
|
|
|
|||
|
|
@ -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> mirror-slots [ slot-spec-name ] map
|
||||
swap tuple-slots 2array flip [ nip ] assoc-subset ;
|
||||
<mirror> [ nip ] assoc-subset ;
|
||||
|
||||
: tuple>params ( specs tuple -- obj )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ C: <faq> faq
|
|||
|
||||
: html>faq ( div -- faq )
|
||||
unclip swap { "h3" "ol" } [ tags-named ] with map
|
||||
first2 >r f add* r> [ html>question-list ] 2map <faq> ;
|
||||
first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
|
||||
|
||||
: header, ( faq -- )
|
||||
dup faq-header ,
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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." ;
|
||||
|
|
|
|||
|
|
@ -206,6 +206,7 @@ ARTICLE: "tools" "Developer tools"
|
|||
{ $subsection "tools.vocabs" }
|
||||
"Exploratory tools:"
|
||||
{ $subsection "editor" }
|
||||
{ $subsection "listener" }
|
||||
{ $subsection "tools.crossref" }
|
||||
{ $subsection "inspector" }
|
||||
"Debugging tools:"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
<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 )
|
||||
<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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session construct-empty
|
||||
swap dup [ string>number ] when >>id ;
|
||||
|
||||
M: sessions-in-db get-session ( id storage -- namespace/f )
|
||||
drop
|
||||
dup [
|
||||
<session>
|
||||
select-tuple dup [ namespace>> ] when
|
||||
] when ;
|
||||
|
||||
M: sessions-in-db update-session ( namespace id storage -- )
|
||||
drop
|
||||
<session>
|
||||
swap >>namespace
|
||||
update-tuple ;
|
||||
|
||||
M: sessions-in-db delete-session ( id storage -- )
|
||||
drop
|
||||
<session>
|
||||
delete-tuple ;
|
||||
|
||||
M: sessions-in-db new-session ( namespace storage -- id )
|
||||
drop
|
||||
f <session>
|
||||
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 ;
|
||||
|
||||
: <session> ( id -- session )
|
||||
session construct-empty
|
||||
swap dup [ string>number ] when >>id ;
|
||||
|
||||
M: sessions-in-db get-session ( id storage -- namespace/f )
|
||||
drop
|
||||
dup [
|
||||
<session>
|
||||
select-tuple dup [ namespace>> ] when
|
||||
] when ;
|
||||
|
||||
M: sessions-in-db update-session ( namespace id storage -- )
|
||||
drop
|
||||
<session>
|
||||
swap >>namespace
|
||||
update-tuple ;
|
||||
|
||||
M: sessions-in-db delete-session ( id storage -- )
|
||||
drop
|
||||
<session>
|
||||
delete-tuple ;
|
||||
|
||||
M: sessions-in-db new-session ( namespace storage -- id )
|
||||
drop
|
||||
f <session>
|
||||
swap >>namespace
|
||||
[ insert-tuple ] [ id>> number>string ] bi ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ IN: io.sockets
|
|||
|
||||
TUPLE: local path ;
|
||||
|
||||
C: <local> local
|
||||
: <local> ( path -- addrspec )
|
||||
normalize-pathname local construct-boa ;
|
||||
|
||||
TUPLE: inet4 host port ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <inotify> ( -- port/f )
|
||||
H{ } clone
|
||||
inotify_init dup 0 < [ 2drop f ] [
|
||||
inotify <buffered-port>
|
||||
{ set-inotify-watches set-delegate } inotify construct
|
||||
] if ;
|
||||
inotify_init [ io-error ] [ inotify <buffered-port> ] 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 <displaced-alien> ;
|
||||
ptr>> <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
|
|
@ -111,14 +109,17 @@ TUPLE: inotify-task ;
|
|||
f inotify-task <input-task> ;
|
||||
|
||||
: init-inotify ( mx -- )
|
||||
<inotify> dup inotify set-global
|
||||
<inotify>
|
||||
dup inotify set-global
|
||||
<inotify-task> swap register-io-task ;
|
||||
|
||||
M: inotify-task do-io-task ( task -- )
|
||||
io-task-port read-notifications f ;
|
||||
|
||||
M: linux-io init-io ( -- )
|
||||
<select-mx> dup mx set-global init-inotify ;
|
||||
<select-mx>
|
||||
[ mx set-global ]
|
||||
[ [ init-inotify ] curry ignore-errors ] bi ;
|
||||
|
||||
T{ linux-io } set-io-backend
|
||||
|
||||
|
|
|
|||
|
|
@ -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" <c-object>
|
||||
AF_UNIX over set-sockaddr-un-family
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
<mirror> [
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -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 <array> add
|
||||
1 tail dup first length 0 <array> suffix
|
||||
[ v- ] 2map ;
|
||||
|
||||
! Laplacian
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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+ ;
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ SYMBOL: and-needed?
|
|||
] if ;
|
||||
|
||||
: recombine ( seq -- str )
|
||||
dup singleton? [
|
||||
dup length 1 = [
|
||||
first 3digits>text
|
||||
] [
|
||||
dup set-conjunction "" swap
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -236,13 +236,13 @@ C: <connection> 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@ C: <head> 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: <head> 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 <memo-entry>
|
||||
] [
|
||||
r h eval-set>> member? [
|
||||
|
|
|
|||
|
|
@ -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 } [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -19,34 +19,33 @@ TUPLE: mersenne-twister seq i ;
|
|||
: wrap ( x n -- y ) 2dup >= [ - ] [ 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 <array> 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <@ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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) <wrapper> ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -235,7 +235,7 @@ C: <spring> spring
|
|||
6 nrot 6 nrot 2array
|
||||
5 nrot 5 nrot 2array
|
||||
0 0 2array <node>
|
||||
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> spring
|
|||
5 nrot node-id
|
||||
5 nrot node-id
|
||||
<spring>
|
||||
springs> swap add >springs ;
|
||||
springs> swap suffix >springs ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ TUPLE: board width height rows ;
|
|||
|
||||
: add-row ( board -- )
|
||||
dup board-rows over board-width f <array>
|
||||
add* swap set-board-rows ;
|
||||
prefix swap set-board-rows ;
|
||||
|
||||
: top-up-rows ( board -- )
|
||||
dup board-height over board-rows length = [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
|
|||
|
|
@ -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) ] }
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue