steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor 

Conflicts:

	core/classes/tuple/tuple.factor
db4
Eduardo Cavazos 2008-03-31 19:42:21 -06:00
parent e75222d039 8e2c2e1838
commit 4f07aefc97
35 changed files with 721 additions and 303 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
core/bootstrap/image/image.factor
View File

@ -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 add* [ ' ] 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>

49
core/bootstrap/primitives.factor
View File

@ -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 -- )

14
core/classes/tuple/tuple-docs.factor
View File

@ -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" } "." } ;

140
core/classes/tuple/tuple-tests.factor
View File

@ -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 ;

156
core/classes/tuple/tuple.factor
View File

@ -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 prefix ;
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 add* ;
: 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

14
core/compiler/units/units.factor
View File

@ -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 ]

1
core/continuations/continuations-docs.factor
View File

@ -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 } ;

10
core/debugger/debugger-docs.factor
View File

@ -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." }

1
core/io/files/files.factor
View File

@ -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 ] }

108
core/kernel/kernel-docs.factor
View File

@ -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 -- ... )" } } }

6
core/slots/slots.factor
View File

@ -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 ;

20
extra/db/types/types.factor
View File

@ -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 )
[

33
extra/help/cookbook/cookbook.factor
View File

@ -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." ;

1
extra/help/handbook/handbook.factor
View File

@ -206,6 +206,7 @@ ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "editor" }
{ $subsection "listener" }
{ $subsection "tools.crossref" }
{ $subsection "inspector" }
"Debugging tools:"

3
extra/help/markup/markup.factor
View File

@ -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) ;

4
extra/io/sockets/sockets-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: io.sockets.tests
USING: io.sockets sequences math tools.test ;
[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test

3
extra/io/sockets/sockets.factor
View File

@ -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 ;

25
extra/io/unix/linux/linux.factor
View File

@ -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

4
extra/io/unix/sockets/sockets.factor
View File

@ -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

17
extra/json/writer/writer.factor
View File

@ -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 ;

23
extra/match/match.factor
View File

@ -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 ;

11
extra/openssl/openssl-tests.factor
View File

@ -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

21
extra/peg/ebnf/ebnf-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf words ;
USING: kernel tools.test peg peg.ebnf words math math.parser ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@ -160,6 +160,25 @@ IN: peg.ebnf.tests
"1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
] unit-test
{ 6 } [
"4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast
] unit-test
{ 6 } [
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
] unit-test
{ 10 } [
{ 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
] unit-test
{ f } [
{ "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call
] unit-test
{ 3 } [
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
] unit-test
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.

59
extra/peg/ebnf/ebnf.factor
View File

@ -3,7 +3,7 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
splitting accessors ;
splitting accessors effects sequences.deep ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@ -19,6 +19,8 @@ TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional group ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action parser code ;
TUPLE: ebnf-var parser name ;
TUPLE: ebnf-semantic parser code ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
@ -34,6 +36,8 @@ C: <ebnf-repeat1> ebnf-repeat1
C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf-var> ebnf-var
C: <ebnf-semantic> ebnf-semantic
C: <ebnf> ebnf
: syntax ( string -- parser )
@ -79,6 +83,7 @@ C: <ebnf> ebnf
[ dup CHAR: * = ]
[ dup CHAR: + = ]
[ dup CHAR: ? = ]
[ dup CHAR: : = ]
} || not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
@ -99,7 +104,7 @@ C: <ebnf> ebnf
"]" syntax ,
] seq* [ first >string <ebnf-range> ] action ;
: 'element' ( -- parser )
: ('element') ( -- parser )
#! An element of a rule. It can be a terminal or a
#! non-terminal but must not be followed by a "=".
#! The latter indicates that it is the beginning of a
@ -117,6 +122,12 @@ C: <ebnf> ebnf
] choice* ,
] seq* [ first ] action ;
: 'element' ( -- parser )
[
[ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
('element') ,
] choice* ;
DEFER: 'choice'
: grouped ( quot suffix -- parser )
@ -147,6 +158,7 @@ DEFER: 'choice'
: 'factor-code' ( -- parser )
[
"]]" token ensure-not ,
"]?" token ensure-not ,
[ drop t ] satisfy ,
] seq* [ first ] action repeat0 [ >string ] action ;
@ -184,14 +196,15 @@ DEFER: 'choice'
: 'action' ( -- parser )
"[[" 'factor-code' "]]" syntax-pack ;
: 'semantic' ( -- parser )
"?[" 'factor-code' "]?" syntax-pack ;
: 'sequence' ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
[
[
('sequence') ,
'action' ,
] seq* [ first2 <ebnf-action> ] action ,
[ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
[ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,
('sequence') ,
] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
@ -200,6 +213,7 @@ DEFER: 'choice'
: 'actioned-sequence' ( -- parser )
[
[ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
[ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
'sequence' ,
] choice* ;
@ -223,15 +237,17 @@ GENERIC: (transform) ( ast -- parser )
SYMBOL: parser
SYMBOL: main
SYMBOL: vars
: transform ( ast -- object )
H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ;
M: ebnf (transform) ( ast -- parser )
rules>> [ (transform) ] map peek ;
M: ebnf-rule (transform) ( ast -- parser )
dup elements>> (transform) [
dup elements>>
vars get clone vars [ (transform) ] with-variable [
swap symbol>> set
] keep ;
@ -266,9 +282,30 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
M: ebnf-optional (transform) ( ast -- parser )
transform-group optional ;
: build-locals ( string vars -- string )
dup empty? [
drop
] [
[
"USING: locals namespaces ; [let* | " %
[ dup % " [ \"" % % "\" get ] " % ] each
" | " %
%
" ] with-locals" %
] "" make
] if ;
M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] keep
code>> string-lines [ parse-lines ] with-compilation-unit action ;
code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
M: ebnf-semantic (transform) ( ast -- parser )
[ parser>> (transform) ] keep
code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ;
M: ebnf-var (transform) ( ast -- parser )
[ parser>> (transform) ] [ name>> ] bi
dup vars get push [ dupd set ] curry action ;
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token sp ;
@ -296,12 +333,12 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: ebnf>quot ( string -- hashtable quot )
'ebnf' parse check-parse-result
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry ;
[ compiled-parse ] curry [ with-scope ] curry ;
: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
: EBNF:
CREATE-WORD dup
";EBNF" parse-multiline-string
ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing

15
extra/peg/peg-docs.factor
View File

@ -95,6 +95,19 @@ HELP: optional
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
HELP: semantic
{ $values
{ "parser" "a parser" }
{ "quot" "a quotation with stack effect ( object -- bool )" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
"the AST produced by 'p1' on the stack returns true." }
{ $examples
{ $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" }
{ $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" }
} ;
HELP: ensure
{ $values
{ "parser" "a parser" }
@ -124,7 +137,7 @@ HELP: action
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
"from that parse. The result of the quotation is then used as the final AST. This can be used "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
"the default AST." }
"the default AST. If the quotation returns " { $link fail } " then the parser fails." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp

13
extra/peg/peg-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words ;
USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
IN: peg.tests
{ f } [
@ -182,4 +182,13 @@ IN: peg.tests
[ f , "a" token , ] seq*
dup parsers>>
dupd 0 swap set-nth compile word?
] unit-test
] unit-test
{ f } [
"A" [ drop t ] satisfy [ 66 >= ] semantic parse
] unit-test
{ CHAR: B } [
"B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
] unit-test

42
extra/peg/peg.factor
View File

@ -3,7 +3,7 @@
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
words quotations effects memoize accessors locals ;
words quotations effects memoize accessors locals effects ;
IN: peg
USE: prettyprint
@ -208,7 +208,7 @@ GENERIC: (compile) ( parser -- quot )
:: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
[let* | rule [ parser (compile) define-temp dup parser "peg" set-word-prop ]
[let* | rule [ gensym dup parser (compile) 0 1 <effect> define-declared dup parser "peg" set-word-prop ]
|
[
rule pos get apply-rule dup fail = [
@ -218,7 +218,7 @@ GENERIC: (compile) ( parser -- quot )
] if
]
] ;
: compiled-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
#! If not, compile it to a temporary word, cache it,
@ -229,7 +229,7 @@ GENERIC: (compile) ( parser -- quot )
dup compiled>> [
nip
] [
gensym tuck >>compiled 2dup parser-body define dupd "peg" set-word-prop
gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
] if* ;
: compile ( parser -- word )
@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ;
M: optional-parser (compile) ( parser -- quot )
p1>> compiled-parser \ ?quot optional-pattern match-replace ;
TUPLE: semantic-parser p1 quot ;
MATCH-VARS: ?parser ;
: semantic-pattern ( -- quot )
[
?parser [
dup parse-result-ast ?quot call [ drop f ] unless
] [
f
] if*
] ;
M: semantic-parser (compile) ( parser -- quot )
[ p1>> compiled-parser ] [ quot>> ] bi
2array { ?parser ?quot } semantic-pattern match-replace ;
TUPLE: ensure-parser p1 ;
: ensure-pattern ( -- quot )
@ -490,8 +507,11 @@ M: box-parser (compile) ( parser -- quot )
#! Calls the quotation at compile time
#! to produce the parser to be compiled.
#! This differs from 'delay' which calls
#! it at run time.
quot>> call compiled-parser 1quotation ;
#! it at run time. Due to using the runtime
#! environment at compile time, this parser
#! must not be cached, so we clear out the
#! delgates cache.
f >>compiled quot>> call compiled-parser 1quotation ;
PRIVATE>
@ -543,6 +563,9 @@ PRIVATE>
: optional ( parser -- parser )
optional-parser construct-boa init-parser ;
: semantic ( parser quot -- parser )
semantic-parser construct-boa init-parser ;
: ensure ( parser -- parser )
ensure-parser construct-boa init-parser ;
@ -562,7 +585,12 @@ PRIVATE>
delay-parser construct-boa init-parser ;
: box ( quot -- parser )
box-parser construct-boa init-parser ;
#! because a box has its quotation run at compile time
#! it must always have a new parser delgate created,
#! not a cached one. This is because the same box,
#! compiled twice can have a different compiled word
#! due to running at compile time.
box-parser construct-boa next-id f <parser> over set-delegate ;
: PEG:
(:) [

35
extra/random/mersenne-twister/mersenne-twister.factor
View File

@ -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 ;

21
extra/serialize/serialize.factor
View File

@ -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> ;

5
extra/tools/disassembler/disassembler.factor
View File

@ -26,11 +26,14 @@ M: pair make-disassemble-cmd
M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
: gdb-binary ( -- string )
os "freebsd" = "gdb66" "gdb" ? ;
: run-gdb ( -- lines )
<process>
+closed+ >>stdin
out-file >>stdout
[ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command
[ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
try-process
out-file ascii file-lines ;

10
extra/unix/bsd/bsd.factor
View File

@ -24,16 +24,6 @@ IN: unix
: F_SETFL 4 ; inline
: O_NONBLOCK 4 ; inline
C-STRUCT: addrinfo
{ "int" "flags" }
{ "int" "family" }
{ "int" "socktype" }
{ "int" "protocol" }
{ "socklen_t" "addrlen" }
{ "char*" "canonname" }
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
C-STRUCT: sockaddr-in
{ "uchar" "len" }
{ "uchar" "family" }

11
extra/unix/bsd/freebsd/freebsd.factor
View File

@ -1,3 +1,14 @@
USING: alien.syntax ;
IN: unix
: FD_SETSIZE 1024 ;
C-STRUCT: addrinfo
{ "int" "flags" }
{ "int" "family" }
{ "int" "socktype" }
{ "int" "protocol" }
{ "socklen_t" "addrlen" }
{ "char*" "canonname" }
{ "void*" "addr" }
{ "addrinfo*" "next" } ;

11
extra/unix/bsd/macosx/macosx.factor
View File

@ -1,3 +1,14 @@
USING: alien.syntax ;
IN: unix
: FD_SETSIZE 1024 ; inline
C-STRUCT: addrinfo
{ "int" "flags" }
{ "int" "family" }
{ "int" "socktype" }
{ "int" "protocol" }
{ "socklen_t" "addrlen" }
{ "char*" "canonname" }
{ "void*" "addr" }
{ "addrinfo*" "next" } ;

11
extra/unix/bsd/netbsd/netbsd.factor
View File

@ -1,3 +1,14 @@
USING: alien.syntax ;
IN: unix
: FD_SETSIZE 256 ; inline
C-STRUCT: addrinfo
{ "int" "flags" }
{ "int" "family" }
{ "int" "socktype" }
{ "int" "protocol" }
{ "socklen_t" "addrlen" }
{ "char*" "canonname" }
{ "void*" "addr" }
{ "addrinfo*" "next" } ;

11
extra/unix/bsd/openbsd/openbsd.factor
View File

@ -1,3 +1,14 @@
USING: alien.syntax ;
IN: unix
: FD_SETSIZE 1024 ; inline
C-STRUCT: addrinfo
{ "int" "flags" }
{ "int" "family" }
{ "int" "socktype" }
{ "int" "protocol" }
{ "socklen_t" "addrlen" }
{ "void*" "addr" }
{ "char*" "canonname" }
{ "addrinfo*" "next" } ;