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

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

Doug Coleman 2008-03-20 14:43:23 -05:00
parent bdda6fc3cb 59731ee24a
commit 668633b406
38 changed files with 360 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/alien.factor
View File

@ -77,7 +77,7 @@ ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
alien-indirect-error ;
TUPLE: alien-invoke library function return parameters ;
TUPLE: alien-invoke library function return parameters abi ;
ERROR: alien-invoke-error library symbol ;

54
core/alien/compiler/compiler.factor
View File

@ -6,14 +6,9 @@ inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts ;
compiler.errors continuations layouts accessors ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
GENERIC: alien-node-parameters ( node -- seq )
GENERIC: alien-node-return ( node -- ctype )
GENERIC: alien-node-abi ( node -- str )
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
@ -22,11 +17,11 @@ GENERIC: alien-node-abi ( node -- str )
] if ;
: alien-node-parameters* ( node -- seq )
dup alien-node-parameters
swap alien-node-return large-struct? [ "void*" add* ] when ;
dup parameters>>
swap return>> large-struct? [ "void*" add* ] when ;
: alien-node-return* ( node -- ctype )
alien-node-return dup large-struct? [ drop "void" ] when ;
return>> dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
@ -51,7 +46,7 @@ GENERIC: alien-node-abi ( node -- str )
: alien-invoke-frame ( node -- n )
#! One cell is temporary storage, temp@
dup alien-node-return return-size
dup return>> return-size
swap alien-stack-frame +
cell + ;
@ -147,9 +142,9 @@ M: long-long-type flatten-value-type ( type -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
: alien-invoke-stack ( node extra -- )
over alien-node-parameters length + dup reify-curries
over parameters>> length + dup reify-curries
over consume-values
dup alien-node-return "void" = 0 1 ?
dup return>> "void" = 0 1 ?
swap produce-values ;
: (make-prep-quot) ( parameters -- )
@ -161,11 +156,11 @@ M: long-long-type flatten-value-type ( type -- )
] if ;
: make-prep-quot ( node -- quot )
alien-node-parameters
parameters>>
[ <reversed> (make-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- )
alien-node-parameters [
parameters>> [
%prepare-unbox >r over + r> unbox-parameter
] reverse-each-parameter drop ;
@ -174,7 +169,7 @@ M: long-long-type flatten-value-type ( type -- )
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
alien-node-return dup large-struct?
return>> dup large-struct?
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
: objects>registers ( node -- )
@ -188,14 +183,7 @@ M: long-long-type flatten-value-type ( type -- )
] with-param-regs ;
: box-return* ( node -- )
alien-node-return [ ] [ box-return ] if-void ;
M: alien-invoke alien-node-parameters alien-invoke-parameters ;
M: alien-invoke alien-node-return alien-invoke-return ;
M: alien-invoke alien-node-abi
alien-invoke-library library
[ library-abi ] [ "cdecl" ] if* ;
return>> [ ] [ box-return ] if-void ;
M: alien-invoke-error summary
drop
@ -205,7 +193,7 @@ M: alien-invoke-error summary
: stdcall-mangle ( symbol node -- symbol )
"@"
swap alien-node-parameters parameter-sizes drop
swap parameters>> parameter-sizes drop
number>string 3append ;
TUPLE: no-such-library name ;
@ -256,6 +244,10 @@ M: no-such-symbol compiler-error-type
pop-literal nip over set-alien-invoke-return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Set ABI
dup alien-invoke-library
library [ library-abi ] [ "cdecl" ] if*
over set-alien-invoke-abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
@ -274,10 +266,6 @@ M: alien-invoke generate-node
iterate-next
] with-stack-frame ;
M: alien-indirect alien-node-parameters alien-indirect-parameters ;
M: alien-indirect alien-node-return alien-indirect-return ;
M: alien-indirect alien-node-abi alien-indirect-abi ;
M: alien-indirect-error summary
drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
@ -323,10 +311,6 @@ callbacks global [ H{ } assoc-like ] change-at
: register-callback ( word -- ) dup callbacks get set-at ;
M: alien-callback alien-node-parameters alien-callback-parameters ;
M: alien-callback alien-node-return alien-callback-return ;
M: alien-callback alien-node-abi alien-callback-abi ;
M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
@ -373,7 +357,7 @@ TUPLE: callback-context ;
wait-to-return ; inline
: prepare-callback-return ( ctype -- quot )
alien-node-return {
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
{ [ t ] [ c-type c-type-prep ] }
@ -390,8 +374,8 @@ TUPLE: callback-context ;
: callback-unwind ( node -- n )
{
{ [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] }
{ [ dup alien-node-return large-struct? ] [ drop 4 ] }
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
{ [ t ] [ drop 0 ] }
} cond ;

4
core/alien/syntax/syntax.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman.
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
kernel math namespaces parser sequences words quotations
@ -9,7 +9,7 @@ IN: alien.syntax
<PRIVATE
: parse-arglist ( return seq -- types effect )
2 group dup keys swap values
2 group dup keys swap values [ "," ?tail drop ] map
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
: function-quot ( type lib func types -- quot )

6
core/cpu/x86/32/32.factor
View File

@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system layouts
alien.compiler combinators command-line
compiler compiler.units io vocabs.loader ;
compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
@ -244,10 +244,10 @@ M: x86-32-backend %cleanup ( alien-node -- )
#! have to fix ESP.
{
{
[ dup alien-node-abi "stdcall" = ]
[ dup abi>> "stdcall" = ]
[ alien-stack-frame ESP swap SUB ]
} {
[ dup alien-node-return large-struct? ]
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
} {
[ t ] [ drop ]

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

@ -85,7 +85,7 @@ HELP: pop-back*
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl
@ -93,20 +93,20 @@ HELP: dlist-find
} ;
HELP: dlist-contains?
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if*
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } }
{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
{ $notes "This operation is O(n)." } ;
HELP: dlist-each
{ $values { "quot" quotation } { "dlist" { $link dlist } } }
{ $values { "dlist" { $link dlist } } { "quot" quotation } }
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

26
core/dlists/dlists-tests.factor
View File

@ -43,20 +43,20 @@ IN: dlists.tests
dlist-front dlist-node-next dlist-node-next
] unit-test
[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test

126
core/dlists/dlists.factor
View File

@ -1,71 +1,67 @@
! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences ;
USING: combinators kernel math sequences accessors ;
IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
dlist construct-empty
0 over set-dlist-length ;
0 >>length ;
: dlist-empty? ( dlist -- ? ) dlist-front not ;
: dlist-empty? ( dlist -- ? ) front>> not ;
<PRIVATE
TUPLE: dlist-node obj prev next ;
C: <dlist-node> dlist-node
: inc-length ( dlist -- )
[ dlist-length 1+ ] keep set-dlist-length ; inline
[ 1+ ] change-length drop ; inline
: dec-length ( dlist -- )
[ dlist-length 1- ] keep set-dlist-length ; inline
[ 1- ] change-length drop ; inline
: set-prev-when ( dlist-node dlist-node/f -- )
[ set-dlist-node-prev ] [ drop ] if* ;
[ (>>prev) ] [ drop ] if* ;
: set-next-when ( dlist-node dlist-node/f -- )
[ set-dlist-node-next ] [ drop ] if* ;
[ (>>next) ] [ drop ] if* ;
: set-next-prev ( dlist-node -- )
dup dlist-node-next set-prev-when ;
dup next>> set-prev-when ;
: normalize-front ( dlist -- )
dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
dup back>> [ f >>front ] unless drop ;
: normalize-back ( dlist -- )
dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
dup front>> [ f >>back ] unless drop ;
: set-back-to-front ( dlist -- )
dup dlist-back
[ drop ] [ dup dlist-front swap set-dlist-back ] if ;
dup back>> [ dup front>> >>back ] unless drop ;
: set-front-to-back ( dlist -- )
dup dlist-front
[ drop ] [ dup dlist-back swap set-dlist-front ] if ;
dup front>> [ dup back>> >>front ] unless drop ;
: (dlist-find-node) ( quot dlist-node -- node/f ? )
dup dlist-node-obj pick dupd call [
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ; inline
: (dlist-find-node) ( dlist-node quot -- node/f ? )
over [
[ >r obj>> r> call ] 2keep rot
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
] [ 2drop f f ] if ; inline
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
: dlist-find-node ( dlist quot -- node/f ? )
>r front>> r> (dlist-find-node) ; inline
: (dlist-each-node) ( quot dlist -- )
over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ; inline
: dlist-each-node ( dlist quot -- )
[ t ] compose dlist-find-node 2drop ; inline
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
PRIVATE>
: push-front* ( obj dlist -- dlist-node )
[ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
[ set-dlist-front ] keep
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep
[ set-back-to-front ] keep
inc-length ;
@ -76,9 +72,9 @@ PRIVATE>
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
[ set-dlist-back ] 2keep
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
@ -89,70 +85,75 @@ PRIVATE>
[ push-back ] curry each ;
: peek-front ( dlist -- obj )
dlist-front dlist-node-obj ;
front>> obj>> ;
: pop-front ( dlist -- obj )
dup dlist-front [
dup dlist-node-next
f rot set-dlist-node-next
dup front>> [
dup next>>
f rot (>>next)
f over set-prev-when
swap set-dlist-front
] 2keep dlist-node-obj
swap (>>front)
] 2keep obj>>
swap [ normalize-back ] keep dec-length ;
: pop-front* ( dlist -- ) pop-front drop ;
: peek-back ( dlist -- obj )
dlist-back dlist-node-obj ;
back>> obj>> ;
: pop-back ( dlist -- obj )
dup dlist-back [
dup dlist-node-prev
f rot set-dlist-node-prev
dup back>> [
dup prev>>
f rot (>>prev)
f over set-next-when
swap set-dlist-back
] 2keep dlist-node-obj
swap (>>back)
] 2keep obj>>
swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- ) pop-back drop ;
: dlist-find ( quot dlist -- obj/f ? )
dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
: dlist-find ( dlist quot -- obj/f ? )
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( quot dlist -- ? )
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
: unlink-node ( dlist-node -- )
dup dlist-node-prev over dlist-node-next set-prev-when
dup dlist-node-next swap dlist-node-prev set-next-when ;
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ;
: delete-node ( dlist dlist-node -- )
{
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
{ [ over front>> over eq? ] [ drop pop-front* ] }
{ [ over back>> over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] }
} cond ;
: delete-node-if* ( quot dlist -- obj/f ? )
tuck dlist-find-node [
[ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
: delete-node-if* ( dlist quot -- obj/f ? )
dupd dlist-find-node [
dup [
[ delete-node ] keep obj>> t
] [
2drop f f
] if
] [
2drop f f
] if ; inline
: delete-node-if ( quot dlist -- obj/f )
: delete-node-if ( dlist quot -- obj/f )
delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
>r [ eq? ] curry r> delete-node-if ;
swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- )
f over set-dlist-front
f over set-dlist-back
0 swap set-dlist-length ;
f >>front
f >>back
0 >>length
drop ;
: dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline
[ obj>> ] swap compose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?
@ -160,4 +161,3 @@ PRIVATE>
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;

4
core/generic/generic-docs.factor
View File

@ -126,7 +126,7 @@ HELP: method
{ method create-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
HELP: methods
@ -143,7 +143,7 @@ HELP: check-method
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $values { "generic" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;

2
core/generic/math/math-docs.factor Normal file → Executable file
View File

@ -15,7 +15,7 @@ HELP: no-math-method
HELP: math-method
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;

12
core/io/encodings/encodings-docs.factor
View File

@ -14,19 +14,19 @@ ARTICLE: "encodings-constructors" "Constructing an encoded stream"
{ $subsection <decoder> }
{ $subsection <encoder-duplex> } ;
HELP: <encoder> ( stream encoding -- newstream )
HELP: <encoder>
{ $values { "stream" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
HELP: <decoder> ( stream encoding -- newstream )
HELP: <decoder>
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
HELP: <encoder-duplex>
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
@ -50,12 +50,12 @@ ARTICLE: "encodings-protocol" "Encoding protocol"
{ $subsection <encoder> }
{ $subsection <decoder> } ;
HELP: decode-char ( stream encoding -- char/f )
HELP: decode-char
{ $values { "stream" "an underlying input stream" }
{ "encoding" "An encoding descriptor tuple" } }
{ "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
HELP: encode-char ( char stream encoding -- )
HELP: encode-char
{ $values { "char" "a character" }
{ "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } }

2
core/io/encodings/encodings.factor
View File

@ -12,7 +12,7 @@ GENERIC: decode-char ( stream encoding -- char/f )
GENERIC: encode-char ( char stream encoding -- )
GENERIC: <decoder> ( stream decoding -- newstream )
GENERIC: <decoder> ( stream encoding -- newstream )
: replacement-char HEX: fffd ;

18
core/io/io-tests.factor
View File

@ -28,15 +28,6 @@ IN: io.tests
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
[ "" ] [ 0 read ] unit-test
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
[
"/core/io/test/binary.txt" <resource-reader>
[ 0.2 read ] with-stream
] must-fail
[
{
{ "It seems " CHAR: J }
@ -58,3 +49,12 @@ IN: io.tests
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
! [ "" ] [ 0 read ] unit-test
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
! [
! "/core/io/test/binary.txt" <resource-reader>
! [ 0.2 read ] with-stream
! ] must-fail

9
core/mirrors/mirrors-docs.factor
View File

@ -2,14 +2,17 @@ USING: help.markup help.syntax slots kernel assocs sequences ;
IN: mirrors
ARTICLE: "mirrors" "Mirrors"
"A reflective view of an object's slots and their values:"
"The " { $vocab-link "mirrors" } " vocabulary defines data types which present an object's slots and slot values as an associative structure. This enables idioms such as iteration over all slots in a tuple, or editing of tuples, sequences and assocs in a generic fashion. This functionality is used by developer tools and meta-programming utilities."
$nl
"A mirror provides such a view of a tuple:"
{ $subsection mirror }
{ $subsection <mirror> }
"A view of a sequence as an associative structure:"
"An enum provides such a view of a sequence:"
{ $subsection enum }
{ $subsection <enum> }
"Utility word used by developer tools which inspect objects:"
{ $subsection make-mirror } ;
{ $subsection make-mirror }
{ $see-also "slots" } ;
ABOUT: "mirrors"

2
core/parser/parser-docs.factor
View File

@ -224,7 +224,7 @@ HELP: skip
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
HELP: change-column
HELP: change-lexer-column
{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;

10
core/parser/parser-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting tuples compiler.units debugger vocabs.loader ;
sorting tuples compiler.units debugger vocabs vocabs.loader ;
IN: parser.tests
[
@ -461,3 +461,11 @@ must-fail-with
] times
[ ] [ "parser" reload ] unit-test
[ ] [
[ "this-better-not-exist" forget-vocab ] with-compilation-unit
] unit-test
[
"USE: this-better-not-exist" eval
] must-fail

8
core/parser/parser.factor
View File

@ -60,7 +60,7 @@ t parser-notes set-global
[ swap CHAR: \s eq? xor ] curry find* drop
[ r> drop ] [ r> length ] if* ;
: change-column ( lexer quot -- )
: change-lexer-column ( lexer quot -- )
swap
[ dup lexer-column swap lexer-line-text rot call ] keep
set-lexer-column ; inline
@ -68,14 +68,14 @@ t parser-notes set-global
GENERIC: skip-blank ( lexer -- )
M: lexer skip-blank ( lexer -- )
[ t skip ] change-column ;
[ t skip ] change-lexer-column ;
GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- )
[
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
] change-column ;
] change-lexer-column ;
: still-parsing? ( lexer -- ? )
dup lexer-line swap lexer-text length <= ;
@ -153,7 +153,7 @@ name>char-hook global [
: parse-string ( -- str )
lexer get [
[ swap tail-slice (parse-string) ] "" make swap
] change-column ;
] change-lexer-column ;
TUPLE: parse-error file line col text ;

85
core/slots/slots-docs.factor
View File

@ -4,21 +4,86 @@ effects generic.standard tuples slots.private classes
strings math ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:"
{ $list
{ "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
{ "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
}
"In addition, two utility words are defined for each distinct slot name used in the system:"
{ $list
{ "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
{ "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
}
"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."
$nl
"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:"
{ $code
"<email>"
" \"Happy birthday\" >>subject"
" { \"bob@bigcorp.com\" } >>to"
" \"alice@bigcorp.com\" >>from"
"send-email"
}
"The following uses writers, and requires some stack shuffling:"
{ $code
"<email>"
" \"Happy birthday\" over (>>subject)"
" { \"bob@bigcorp.com\" } over (>>to)"
" \"alice@bigcorp.com\" over (>>from)"
"send-email"
}
"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:"
{ $code
"<email>"
" swap >>subject"
" swap >>to"
" \"alice@bigcorp.com\" >>from"
"send-email"
}
"This is because " { $link swap } " is easier to understand than " { $link tuck } ":"
{ $code
"<email>"
" tuck (>>subject)"
" tuck (>>to)"
" \"alice@bigcorp.com\" over (>>from)"
"send-email"
}
"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:"
{ $code
"find-manager"
" salary>> 0.75 * >>salary"
}
"The following version is preferred:"
{ $code
"find-manager"
" [ 0.75 * ] change-salary"
}
{ $see-also "slots" "mirrors" } ;
ARTICLE: "slots" "Slots"
"A " { $emphasis "slot" } " is a component of an object which can store a value. The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
"A " { $emphasis "slot" } " is a component of an object which can store a value."
$nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
$nl
"The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
{ $subsection slot-spec }
"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
"The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:"
{ $subsection reader-word }
{ $subsection writer-word }
{ $subsection setter-word }
{ $subsection changer-word }
"Slot methods type check, then call unsafe primitives:"
{ $subsection slot }
{ $subsection set-slot } ;
"Looking up a slot by name:"
{ $subsection slot-named }
"Defining slots dynamically:"
{ $subsection define-reader }
{ $subsection define-writer }
{ $subsection define-setter }
{ $subsection define-changer }
{ $subsection define-slot-methods }
{ $subsection define-accessors }
{ $see-also "accessors" "mirrors" } ;
ABOUT: "slots"
@ -58,8 +123,8 @@ HELP: reader-effect
{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } "." }
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: writer-effect
@ -67,13 +132,13 @@ HELP: writer-effect
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
HELP: define-writer
{ $values { "class" class } { "spec" slot-spec } }
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slot-methods
{ $values { "class" class } { "spec" slot-spec } }
{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a reader, writer, setter and changer for a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-accessors

2
core/slots/slots.factor
View File

@ -23,7 +23,7 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
: slot-named ( string specs -- spec/f )
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word )

8
core/splitting/splitting-tests.factor
View File

@ -1,4 +1,4 @@
USING: splitting tools.test ;
USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail
@ -56,3 +56,9 @@ unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
[ { V{ "a" "b" } V{ f f } } ] [
V{ "a" "b" } clone 2 <groups>
2 over set-length
>array
] unit-test

2
core/splitting/splitting.factor
View File

@ -17,7 +17,7 @@ M: groups length
dup groups-seq length swap groups-n [ + 1- ] keep /i ;
M: groups set-length
[ groups-n * ] keep delegate set-length ;
[ groups-n * ] keep groups-seq set-length ;
: group@ ( n groups -- from to seq )
[ groups-n [ * dup ] keep + ] keep

2
core/syntax/syntax-docs.factor
View File

@ -556,7 +556,7 @@ HELP: PREDICATE:
HELP: TUPLE:
{ $syntax "TUPLE: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "."
{ $description "Defines a new tuple class."
$nl
"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;

107
core/tuples/tuples-docs.factor
View File

@ -3,11 +3,10 @@ tuples.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
IN: tuples
ARTICLE: "tuple-constructors" "Constructors and slots"
"Tuples are created by calling one of a number of words:"
ARTICLE: "tuple-constructors" "Constructors"
"Tuples are created by calling one of two words:"
{ $subsection construct-empty }
{ $subsection construct-boa }
{ $subsection construct }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
$nl
"A shortcut for defining BOA constructors:"
@ -19,18 +18,13 @@ $nl
"C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above"
""
": <rgb>"
" { set-color-red set-color-green set-color-blue }"
" color construct ;"
": <rgb> f <rgba> ; ! identical to above"
": <rgb> f <rgba> ;"
""
": <color> construct-empty ;"
": <color> { } color construct ; ! identical to above"
": <color> f f f f <rgba> ; ! identical to above"
}
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
} ;
ARTICLE: "tuple-delegation" "Delegation"
ARTICLE: "tuple-delegation" "Tuple delegation"
"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
{ $subsection delegate }
{ $subsection set-delegate }
@ -48,7 +42,7 @@ $nl
"{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
"{ 1 0 0 } <colored> \"my-shape\" set"
"\"my-ellipse\" get \"my-shape\" get set-delegate"
"\"my-shape\" get dup colored-color swap ellipse-center .s"
"\"my-shape\" get dup color>> swap center>> .s"
"{ 0 0 }\n{ 1 0 0 }"
} ;
@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
{ $subsection tuple>array }
{ $subsection tuple-slots }
"Tuple classes can also be defined at run time:"
{ $subsection define-tuple-class } ;
{ $subsection define-tuple-class }
{ $see-also "slots" "mirrors" } ;
ARTICLE: "tuple-examples" "Tuple examples"
"An example:"
{ $code "TUPLE: employee name salary position ;" }
"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
{ $table
{ "Reader" "Writer" "Setter" "Changer" }
{ { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
{ { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
{ { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
}
"We can define a constructor which makes an empty employee:"
{ $code ": <employee> ( -- employee )"
" employee construct-empty ;" }
"Or we may wish the default constructor to always give employees a starting salary:"
{ $code
": <employee> ( -- employee )"
" employee construct-empty"
" 40000 >>salary ;"
}
"We can define more refined constructors:"
{ $code
": <manager> ( -- manager )"
" <employee> \"project manager\" >>position ;" }
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
": <employee> ( name position -- person )"
" 40000 employee construct-boa ;"
}
"Now we can define more specific constructors:"
{ $code
": <manager> ( name -- person )"
" \"manager\" <person> ;" }
"An example using reader words:"
{ $code
"TUPLE: check to amount number ;"
""
"SYMBOL: checks"
""
": <check> ( to amount -- check )"
" checks counter check construct-boa ;"
""
": biweekly-paycheck ( employee -- check )"
" dup name>> swap salary>> 26 / <check> ;"
}
"An example of using a changer:"
{ $code
": positions"
" {"
" \"junior programmer\""
" \"senior programmer\""
" \"project manager\""
" \"department manager\""
" \"executive\""
" \"CTO\""
" \"CEO\""
" \"enterprise Java world dictator\""
" } ;"
""
": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;"
""
": promote ( person -- person )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
} ;
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
"Tuples are user-defined classes composed of named slots."
{ $subsection "tuple-examples" }
"A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"An example:"
{ $code "TUPLE: person name address phone ;" "C: <person> person" }
"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
{ $table
{ "Reader" "Writer" }
{ { $snippet "person-name" } { $snippet "set-person-name" } }
{ { $snippet "person-address" } { $snippet "set-person-address" } }
{ { $snippet "person-phone" } { $snippet "set-person-phone" } }
}
"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
$nl
"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
"Further topics:"
{ $subsection "tuple-delegation" }
{ $subsection "tuple-introspection" } ;
{ $subsection "tuple-introspection" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples"

6
core/vocabs/loader/loader.factor
View File

@ -113,7 +113,11 @@ M: string (load-vocab)
rethrow
] [
drop
[ (load-vocab) ] with-compiler-errors
dup find-vocab-root [
[ (load-vocab) ] with-compiler-errors
] [
dup vocab [ drop ] [ no-vocab ] if
] if
] if
] with-compiler-errors
] load-vocab-hook set-global

3
core/vocabs/vocabs.factor
View File

@ -64,8 +64,7 @@ ERROR: no-vocab name ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
dup load-vocab-hook get call
dup vocab [ ] [ vocab-name no-vocab ] ?if ;
dup load-vocab-hook get call vocab ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;

2
extra/builder/util/util.factor
View File

@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
combinators sequences splitting quotations arrays strings tools.time
sequences.deep new-slots accessors assocs.lib
sequences.deep accessors assocs.lib
io.encodings.utf8
combinators.cleave bake calendar calendar.format ;

4
extra/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -49,8 +49,8 @@ HELP: while-mailbox-empty
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ $values { "mailbox" mailbox }
{ "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;

14
extra/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -16,9 +16,9 @@ tools.test math kernel strings ;
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
@ -27,10 +27,10 @@ tools.test math kernel strings ;
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ integer? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
[ [ string? ] mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put

18
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -17,17 +17,17 @@ TUPLE: mailbox threads data ;
[ mailbox-data push-front ] keep
mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
: block-unless-pred ( mailbox timeout pred -- )
pick mailbox-data over dlist-contains? [
3drop
] [
2dup >r mailbox-threads r> "mailbox" wait
>r over mailbox-threads over "mailbox" wait r>
block-unless-pred
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [
2dup >r mailbox-threads r> "mailbox" wait
over mailbox-threads over "mailbox" wait
block-if-empty
] [
drop
@ -58,12 +58,12 @@ TUPLE: mailbox threads data ;
2drop
] if ; inline
: mailbox-get-timeout? ( pred mailbox timeout -- obj )
[ block-unless-pred ] 3keep drop
mailbox-data delete-node-if ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
3dup block-unless-pred
nip >r mailbox-data r> delete-node-if ; inline
: mailbox-get? ( pred mailbox -- obj )
f mailbox-get-timeout? ; inline
: mailbox-get? ( mailbox pred -- obj )
f swap mailbox-get-timeout? ; inline
TUPLE: linked-error thread ;

6
extra/concurrency/messaging/messaging.factor
View File

@ -26,10 +26,10 @@ M: thread send ( message thread -- )
my-mailbox swap mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
my-mailbox mailbox-get? ?linked ; inline
my-mailbox swap mailbox-get? ?linked ; inline
: receive-if-timeout ( pred timeout -- message )
my-mailbox swap mailbox-get-timeout? ?linked ; inline
: receive-if-timeout ( timeout pred -- message )
my-mailbox -rot mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked-error> r> send ;

2
extra/help/lint/lint.factor
View File

@ -39,8 +39,6 @@ IN: help.lint
{
$shuffle
$values-x/y
$slot-reader
$slot-writer
$predicate
$class-description
$error-description

12
extra/help/markup/markup-tests.factor
View File

@ -4,18 +4,6 @@ IN: help.markup.tests
TUPLE: blahblah quux ;
: test-slot blahblah "slots" word-prop second ;
[
{ { "blahblah" { $instance blahblah } } { "quux" { $instance object } } }
] [
test-slot blahblah ($spec-reader-values)
] unit-test
[ ] [
test-slot blahblah $spec-reader-values
] unit-test
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ blahblah-quux help ] unit-test

2
extra/http/server/templating/fhtml/fhtml.factor
View File

@ -28,7 +28,7 @@ M: template-lexer skip-word
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
{ [ t ] [ f skip ] }
} cond
] change-column ;
] change-lexer-column ;
DEFER: <% delimiter

1
extra/new-slots/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

67
extra/new-slots/new-slots.factor
View File

@ -1,67 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: effects words kernel sequences slots slots.private
assocs parser mirrors namespaces math vocabs tuples ;
IN: new-slots
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
: reader-effect T{ effect f { "object" } { "value" } } ; inline
: reader-word ( name -- word )
">>" append reader-effect create-accessor ;
: define-reader ( class slot name -- )
reader-word [ slot ] define-slot-word ;
: writer-effect T{ effect f { "value" "object" } { } } ; inline
: writer-word ( name -- word )
"(>>" swap ")" 3append writer-effect create-accessor ;
: define-writer ( class slot name -- )
writer-word [ set-slot ] define-slot-word ;
: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
: setter-word ( name -- word )
">>" prepend setter-effect create-accessor ;
: define-setter ( name -- )
dup setter-word dup deferred? [
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
: changer-word ( name -- word )
"change-" prepend changer-effect create-accessor ;
: define-changer ( name -- )
dup changer-word dup deferred? [
[
[ over >r >r ] %
over reader-word ,
[ r> call r> swap ] %
swap setter-word ,
] [ ] make define-inline
] [ 2drop ] if ;
: define-new-slot ( class slot name -- )
dup define-changer
dup define-setter
3dup define-reader
define-writer ;
: define-new-slots ( tuple-class -- )
[ "slot-names" word-prop <enum> >alist ] keep
[ swap first2 >r 4 + r> define-new-slot ] curry each ;
: TUPLE:
CREATE-CLASS
dup ";" parse-tokens define-tuple-class
define-new-slots ; parsing
"accessors" create-vocab drop

2
extra/regexp/regexp.factor
View File

@ -292,7 +292,7 @@ TUPLE: regexp source parser ignore-case? ;
: parse-regexp ( accum end -- accum )
lexer get dup skip-blank [
[ index* dup 1+ swap ] 2keep swapd subseq swap
] change-column
] change-lexer-column
lexer get (parse-token) parse-options <regexp> parsed ;
: R! CHAR: ! parse-regexp ; parsing

9
extra/tools/vocabs/vocabs.factor
View File

@ -34,8 +34,13 @@ IN: tools.vocabs
: source-modified? ( path -- ? )
dup source-files get at [
dup source-file-path ?resource-path utf8 file-lines lines-crc32
swap source-file-checksum = not
dup source-file-path ?resource-path
dup exists? [
utf8 file-lines lines-crc32
swap source-file-checksum = not
] [
2drop f
] if
] [
resource-exists?
] ?if ;

15
extra/ui/gadgets/gadgets.factor
View File

@ -46,7 +46,7 @@ M: array rect-dim drop { 0 0 } ;
TUPLE: gadget
pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state
visible? root? clipped? layout-state graft-state graft-node
interior boundary
model ;
@ -254,17 +254,20 @@ M: gadget layout* drop ;
: graft-queue \ graft-queue get ;
: unqueue-graft ( gadget -- )
dup graft-queue dlist-delete [ "Not queued" throw ] unless
graft-queue over gadget-graft-node delete-node
dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-graft-state ;
: (queue-graft) ( gadget flags -- )
over set-gadget-graft-state
dup graft-queue push-front* swap set-gadget-graft-node
notify-ui-thread ;
: queue-graft ( gadget -- )
{ f t } over set-gadget-graft-state
graft-queue push-front notify-ui-thread ;
{ f t } (queue-graft) ;
: queue-ungraft ( gadget -- )
{ t f } over set-gadget-graft-state
graft-queue push-front notify-ui-thread ;
{ t f } (queue-graft) ;
: graft-later ( gadget -- )
dup gadget-graft-state {

2
extra/windows/time/time.factor Normal file → Executable file
View File

@ -8,7 +8,7 @@ IN: windows.time
32 shift bitor ;
: windows-1601 ( -- timestamp )
1601 1 1 0 0 0 0 <timestamp> ;
1601 1 1 0 0 0 instant <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] keep