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

db4
Doug Coleman 2008-12-03 10:03:37 -06:00
commit 06388da30d
84 changed files with 259 additions and 185 deletions
core/classes/mixin

View File

@ -71,7 +71,7 @@ M: object xyz ;
2over fixnum>= [
3drop
] [
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
[ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
] if ; inline recursive
: fx-repeat ( n quot -- )
@ -87,10 +87,10 @@ M: object xyz ;
2over dup xyz drop >= [
3drop
] [
[ swap >r call 1+ r> ] keep (i-repeat)
[ swap [ call 1+ ] dip ] keep (i-repeat)
] if ; inline recursive
: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
[ t ] [
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ;
2dup >= [
2drop
] [
>r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
@ -448,7 +448,7 @@ cell-bits 32 = [
] unit-test
[ ] [
[ [ >r "A" throw r> ] [ "B" throw ] if ]
[ [ [ "A" throw ] dip ] [ "B" throw ] if ]
cleaned-up-tree drop
] unit-test
@ -463,7 +463,7 @@ cell-bits 32 = [
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
>r 1+ r> buffalo-wings
[ 1+ ] dip buffalo-wings
] [
2drop
] if ; inline recursive
@ -482,7 +482,7 @@ cell-bits 32 = [
: ribs ( i seq -- )
2dup < [
steak
>r 1+ r> ribs
[ 1+ ] dip ribs
] [
2drop
] if ; inline recursive

View File

@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests
remove-dead-code
"no-check" get [ dup check-nodes ] unless nodes>quot ;
[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test

View File

@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test

View File

@ -435,7 +435,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
] unit-test
: recursive-test-4 ( i n -- )
2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test

View File

@ -561,7 +561,7 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
M: int-regs %save-param-reg drop >r param@ r> MOV ;
M: int-regs %save-param-reg drop [ param@ ] dip MOV ;
M: int-regs %load-param-reg drop swap param@ MOV ;
GENERIC: MOVSS/D ( dst src reg-class -- )
@ -569,8 +569,8 @@ GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ;
M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ;
GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( n reg-class -- )

View File

@ -131,11 +131,11 @@ HELP: datastack-overflow.
{ $notes "This error usually indicates a run-away recursion, however if you legitimately need a data stack larger than the default, see " { $link "runtime-cli-args" } "." } ;
HELP: retainstack-underflow.
{ $error-description "Thrown by the Factor VM if " { $link r> } " is called while the retain stack is empty." }
{ $error-description "Thrown by the Factor VM if an attempt is made to access the retain stack in an invalid manner. This bug should never come up in practice and indicates a bug in Factor." }
{ $notes "You can use the stack effect tool to statically check stack effects of quotations. See " { $link "inference" } "." } ;
HELP: retainstack-overflow.
{ $error-description "Thrown by the Factor VM if " { $link >r } " is called when the retain stack is full." }
{ $error-description "Thrown by the Factor VM if " { $link dip } " is called when the retain stack is full." }
{ $notes "This error usually indicates a run-away recursion, however if you legitimately need a retain stack larger than the default, see " { $link "runtime-cli-args" } "." } ;
HELP: memory-error.

View File

@ -3,13 +3,13 @@
USING: slots arrays definitions generic hashtables summary io
kernel math namespaces make prettyprint prettyprint.config
sequences assocs sequences.private strings io.styles io.files
vectors words system splitting math.parser classes.tuple
continuations continuations.private combinators generic.math
classes.builtin classes compiler.units generic.standard vocabs
init kernel.private io.encodings accessors math.order
destructors source-files parser classes.tuple.parser
effects.parser lexer compiler.errors generic.parser
strings.parser ;
vectors words system splitting math.parser classes.mixin
classes.tuple continuations continuations.private combinators
generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer compiler.errors
generic.parser strings.parser ;
IN: debugger
GENERIC: error. ( error -- )
@ -327,3 +327,5 @@ M: bad-effect summary
M: bad-escape summary drop "Bad escape code" ;
M: bad-literal-tuple summary drop "Bad literal tuple" ;
M: check-mixin-class summary drop "Not a mixin class" ;

View File

@ -97,7 +97,7 @@ ALIAS: $slot $snippet
[
snippet-style get [
last-element off
>r ($code-style) r> with-nesting
[ ($code-style) ] dip with-nesting
] with-style
] ($block) ; inline

View File

@ -11,9 +11,10 @@ IN: help.syntax
\ ; parse-until >array swap set-word-help ; parsing
: ARTICLE:
location >r
\ ; parse-until >array [ first2 ] keep 2 tail <article>
over add-article >link r> remember-definition ; parsing
location [
\ ; parse-until >array [ first2 ] keep 2 tail <article>
over add-article >link
] dip remember-definition ; parsing
: ABOUT:
in get vocab

View File

@ -24,7 +24,7 @@ SYMBOL: html
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
>r >r elements-vocab create r> r> define-declared ;
[ elements-vocab create ] 2dip define-declared ;
: <foo> ( str -- <str> ) "<" swap ">" 3append ;

View File

@ -77,7 +77,7 @@ TUPLE: html-sub-stream < html-stream style parent ;
"font-family: " % % "; " % ;
: apply-style ( style key quot -- style gadget )
>r over at r> when* ; inline
[ over at ] dip when* ; inline
: make-css ( style quot -- str )
"" make nip ; inline
@ -163,13 +163,13 @@ M: html-stream stream-flush
stream>> stream-flush ;
M: html-stream stream-write1
>r 1string r> stream-write ;
[ 1string ] dip stream-write ;
M: html-stream stream-write
not-a-div >r escape-string r> stream>> stream-write ;
not-a-div [ escape-string ] dip stream>> stream-write ;
M: html-stream stream-format
>r html over at [ >r escape-string r> ] unless r>
[ html over at [ [ escape-string ] dip ] unless ] dip
format-html-span ;
M: html-stream stream-nl

View File

@ -15,7 +15,7 @@ TUPLE: interval-map array ;
first2 between? ;
: all-intervals ( sequence -- intervals )
[ >r dup number? [ dup 2array ] when r> ] { } assoc-map-as ;
[ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
: disjoint? ( node1 node2 -- ? )
[ second ] [ first ] bi* < ;

1
basis/io/windows/nt/privileges/privileges.factor Normal file → Executable file
View File

@ -42,7 +42,6 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
[ lookup-privilege ] dip
[
TOKEN_PRIVILEGES-Privileges
[ 0 ] dip LUID_AND_ATTRIBUTES-nth
set-LUID_AND_ATTRIBUTES-Luid
] keep ;

View File

@ -38,8 +38,8 @@ SYMBOL: message-histogram
: histogram. ( assoc quot -- )
standard-table-style [
>r >alist sort-values <reversed> r> [
[ >r swap r> with-cell pprint-cell ] with-row
[ >alist sort-values <reversed> ] dip [
[ swapd with-cell pprint-cell ] with-row
] curry assoc-each
] tabular-output ;
@ -69,7 +69,7 @@ SYMBOL: message-histogram
errors. ;
: analyze-log ( lines word-names -- )
>r parse-log r> analyze-entries analysis. ;
[ parse-log ] dip analyze-entries analysis. ;
: analyze-log-file ( service word-names -- )
>r parse-log-file r> analyze-entries analysis. ;
[ parse-log-file ] dip analyze-entries analysis. ;

View File

@ -73,7 +73,7 @@ MACRO: match-cond ( assoc -- )
2dup [ length ] bi@ < [ 2drop f f ]
[
2dup length head over match
[ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
[ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
] if ;
: match-first ( seq pattern-seq -- bindings )

View File

@ -37,7 +37,7 @@ M: rect rect-dim dim>> ;
over rect-loc v+ swap rect-dim <rect> ;
: (rect-intersect) ( rect rect -- array array )
2rect-extent vmin >r vmax r> ;
2rect-extent [ vmax ] [ vmin ] 2bi* ;
: rect-intersect ( rect1 rect2 -- newrect )
(rect-intersect) <extent-rect> ;
@ -46,7 +46,7 @@ M: rect rect-dim dim>> ;
(rect-intersect) [v-] { 0 0 } = ;
: (rect-union) ( rect rect -- array array )
2rect-extent vmax >r vmin r> ;
2rect-extent [ vmin ] [ vmax ] 2bi* ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;

View File

@ -18,7 +18,7 @@ TUPLE: history < model back forward ;
: go-back/forward ( history to from -- )
[ 2drop ]
[ >r dupd (add-history) r> pop swap set-model ] if-empty ;
[ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;
: go-back ( history -- )
dup [ forward>> ] [ back>> ] bi go-back/forward ;

View File

@ -91,7 +91,7 @@ M: model update-model drop ;
] if ;
: ((change-model)) ( model quot -- newvalue model )
over >r >r value>> r> call r> ; inline
over [ [ value>> ] dip call ] dip ; inline
: change-model ( model quot -- )
((change-model)) set-model ; inline

View File

@ -28,7 +28,7 @@ PRIVATE>
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text>> [
2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [
[ rot dupd [ swap subseq % ] 2dip length + ] [
rot tail % "\n" % 0
lexer get next-line swap (parse-multiline-string)
] if*

View File

@ -234,13 +234,13 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_rsa ( ctx rsa -- n )
>r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ;
[ SSL_CTRL_SET_TMP_RSA 0 ] dip SSL_CTX_ctrl ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
[ SSL_CTRL_SET_TMP_DH 0 ] dip SSL_CTX_ctrl ;
: SSL_CTX_set_session_cache_mode ( ctx mode -- n )
>r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ;
[ SSL_CTRL_SET_SESS_CACHE_MODE ] dip f SSL_CTX_ctrl ;
: SSL_SESS_CACHE_OFF HEX: 0000 ; inline
: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline

View File

@ -24,7 +24,7 @@ M: just-parser (compile) ( parser -- quot )
: 1token ( ch -- parser ) 1string token ;
: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ over 2seq ] dip [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
: list-of ( items separator -- parser )
@ -60,11 +60,11 @@ PRIVATE>
[ flatten-vectors ] action ;
: from-m-to-n ( parser m n -- parser' )
>r [ exactly-n ] 2keep r> swap - at-most-n 2seq
[ [ exactly-n ] 2keep ] dip swap - at-most-n 2seq
[ flatten-vectors ] action ;
: pack ( begin body end -- parser )
>r >r hide r> r> hide 3seq [ first ] action ;
[ hide ] 2dip hide 3seq [ first ] action ;
: surrounded-by ( parser begin end -- parser' )
[ token ] bi@ swapd pack ;

View File

@ -146,8 +146,8 @@ TUPLE: peg-head rule-id involved-set eval-set ;
pos set dup involved-set>> clone >>eval-set drop ;
: (grow-lr) ( h p r: ( -- result ) m -- )
>r >r [ setup-growth ] 2keep r> r>
>r dup eval-rule r> swap
[ [ setup-growth ] 2keep ] 2dip
[ dup eval-rule ] dip swap
dup pick stop-growth? [
5 ndrop
] [
@ -156,8 +156,8 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] if ; inline recursive
: grow-lr ( h p r m -- ast )
>r >r [ heads set-at ] 2keep r> r>
pick over >r >r (grow-lr) r> r>
[ [ heads set-at ] 2keep ] 2dip
pick over [ (grow-lr) ] 2dip
swap heads delete-at
dup pos>> pos set ans>>
; inline
@ -352,7 +352,7 @@ TUPLE: token-parser symbol ;
[ ?head-slice ] keep swap [
<parse-result> f f add-error
] [
>r drop pos get "token '" r> append "'" append 1vector add-error f
[ drop pos get "token '" ] dip append "'" append 1vector add-error f
] if ;
M: token-parser (compile) ( peg -- quot )

View File

@ -21,9 +21,6 @@ M: effect pprint* effect>string "(" swap ")" 3append text ;
: ?end-group ( word -- )
?effect-height 0 < [ end-group ] when ;
\ >r hard "break-before" set-word-prop
\ r> hard "break-after" set-word-prop
! Atoms
: word-style ( word -- style )
dup "word-style" word-prop >hashtable [
@ -93,7 +90,7 @@ M: f pprint* drop \ f pprint-word ;
] H{ } make-assoc ;
: unparse-string ( str prefix suffix -- str )
[ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
[ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
: pprint-string ( obj str prefix suffix -- )
unparse-string swap string-style styled-text ;
@ -156,13 +153,13 @@ M: tuple pprint*
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
dup zero? [ 2drop f ] [ >r head r> ] if
dup zero? [ 2drop f ] [ [ head ] dip ] if
] when ;
: pprint-elements ( seq -- )
do-length-limit >r
[ pprint* ] each
r> [ "~" swap number>string " more~" 3append text ] when* ;
do-length-limit
[ [ pprint* ] each ] dip
[ "~" swap number>string " more~" 3append text ] when* ;
GENERIC: pprint-delims ( obj -- start end )
@ -206,10 +203,12 @@ M: tuple pprint-narrow? drop t ;
: pprint-object ( obj -- )
[
<flow
dup pprint-delims >r pprint-word
dup pprint-narrow? <inset
>pprint-sequence pprint-elements
block> r> pprint-word block>
dup pprint-delims [
pprint-word
dup pprint-narrow? <inset
>pprint-sequence pprint-elements
block>
] dip pprint-word block>
] check-recursion ;
M: object pprint* pprint-object ;

View File

@ -135,20 +135,6 @@ M: object method-layout ;
[ \ method-layout see-methods ] with-string-writer "\n" split
] unit-test
: retain-stack-test
{
"USING: io kernel sequences words ;"
"IN: prettyprint.tests"
": retain-stack-layout ( x -- )"
" dup stream-readln stream-readln"
" >r [ define ] map r>"
" define ;"
} ;
[ t ] [
"retain-stack-layout" retain-stack-test check-see
] unit-test
: soft-break-test
{
"USING: kernel math sequences strings ;"
@ -164,19 +150,6 @@ M: object method-layout ;
"soft-break-layout" soft-break-test check-see
] unit-test
: another-retain-layout-test
{
"USING: kernel sequences ;"
"IN: prettyprint.tests"
": another-retain-layout ( seq1 seq2 quot -- newseq )"
" -rot 2dup dupd min-length [ each drop roll ] map"
" >r 3drop r> ; inline"
} ;
[ t ] [
"another-retain-layout" another-retain-layout-test check-see
] unit-test
DEFER: parse-error-file
: another-soft-break-test
@ -219,8 +192,7 @@ DEFER: parse-error-file
"USING: kernel sequences ;"
"IN: prettyprint.tests"
": final-soft-break-layout ( class dim -- view )"
" >r \"alloc\" send 0 0 r>"
" first2 <NSRect>"
" [ \"alloc\" send 0 0 ] dip first2 <NSRect>"
" <PixelFormat> \"initWithFrame:pixelFormat:\" send"
" dup 1 \"setPostsBoundsChangedNotifications:\" send"
" dup 1 \"setPostsFrameChangedNotifications:\" send ;"

View File

@ -42,7 +42,7 @@ TUPLE: pprinter last-newline line-count indent ;
: text-fits? ( len -- ? )
margin get dup zero?
[ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
[ 2drop t ] [ [ pprinter get indent>> + ] dip <= ] if ;
! break only if position margin 2 / >
SYMBOL: soft
@ -189,7 +189,7 @@ M: block short-section ( block -- )
: empty-block? ( block -- ? ) sections>> empty? ;
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
[ dup empty-block? [ drop ] ] dip if ; inline
: (<block) ( block -- ) pprinter-stack get push ;

View File

@ -3,20 +3,18 @@ IN: sequences.next
<PRIVATE
: iterate-seq >r dup length swap r> ; inline
: iterate-seq [ dup length swap ] dip ; inline
: (map-next) ( i seq quot -- )
! this uses O(n) more bounds checks than is really necessary
>r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline
[ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline
PRIVATE>
: each-next ( seq quot -- )
! quot: next-elt elt --
: each-next ( seq quot: ( next-elt elt -- ) -- )
iterate-seq [ (map-next) ] 2curry each-integer ; inline
: map-next ( seq quot -- newseq )
! quot: next-elt elt -- newelt
over dup length swap new-sequence >r
iterate-seq [ (map-next) ] 2curry
r> [ collect ] keep ; inline
: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq )
over dup length swap new-sequence [
iterate-seq [ (map-next) ] 2curry
] dip [ collect ] keep ; inline

View File

@ -2,3 +2,4 @@ USING: shuffle tools.test ;
[ 8 ] [ 5 6 7 8 3nip ] unit-test
[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
[ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test

View File

@ -4,7 +4,7 @@ USING: kernel generalizations ;
IN: shuffle
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
: nipd ( a b c -- b c ) rot drop ; inline

View File

@ -115,7 +115,6 @@ ARTICLE: "inference-errors" "Inference warnings and errors"
{ $subsection inconsistent-recursive-call-error }
"Retain stack usage errors:"
{ $subsection too-many->r }
{ $subsection too-many-r> }
"See " { $link "shuffle-words" } " for retain stack usage conventions. This error can only occur if your code calls " { $link >r } " and " { $link r> } " directly. The " { $link dip } " combinator is safer to use because there is no way to leave the retain stack in an unbalanced state." ;
{ $subsection too-many-r> } ;
ABOUT: "inference-errors"

View File

@ -13,7 +13,7 @@ M: inference-error compiler-error-type type>> ;
M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
>r boa r>
[ boa ] dip
recursive-state get word>>
\ inference-error boa throw ; inline

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,23 @@
IN: struct-arrays
USING: help.markup help.syntax alien strings math ;
HELP: struct-array
{ $class-description "The class of C struct and union arrays."
$nl
"The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ;
HELP: <struct-array>
{ $values { "length" integer } { "c-type" string } }
{ $description "Creates a new array for holding values of the specified C type." } ;
HELP: <direct-struct-array>
{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } }
{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
ARTICLE: "struct-arrays" "C struct and union arrays"
"The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values."
{ $subsection struct-array }
{ $subsection <struct-array> }
{ $subsection <direct-struct-array> } ;
ABOUT: "struct-arrays"

View File

@ -0,0 +1,29 @@
IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors ;
C-STRUCT: test-struct
{ "int" "x" }
{ "int" "y" } ;
: make-point ( x y -- struct )
"test-struct" <c-object>
[ set-test-struct-y ] keep
[ set-test-struct-x ] keep ;
[ 5/4 ] [
2 "test-struct" <struct-array>
1 2 make-point over set-first
3 4 make-point over set-second
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
] unit-test
[ 5/4 ] [
[
2 "test-struct" malloc-struct-array
dup underlying>> &free drop
1 2 make-point over set-first
3 4 make-point over set-second
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
] with-destructors
] unit-test

View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types byte-arrays kernel libc
math sequences sequences.private ;
IN: struct-arrays
TUPLE: struct-array
{ underlying c-ptr read-only }
{ length array-capacity read-only }
{ element-size array-capacity read-only } ;
M: struct-array length length>> ;
M: struct-array nth-unsafe
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
M: struct-array set-nth-unsafe
[ nth-unsafe swap ] [ element-size>> ] bi memcpy ;
M: struct-array new-sequence
element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
: <struct-array> ( length c-type -- struct-array )
heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
ERROR: bad-byte-array-length byte-array ;
: byte-array>struct-array ( byte-array c-type -- struct-array )
heap-size [
[ dup length ] dip /mod 0 =
[ drop bad-byte-array-length ] unless
] keep struct-array boa ; inline
: <direct-struct-array> ( alien length c-type -- struct-array )
struct-array boa ; inline
: malloc-struct-array ( length c-type -- struct-array )
heap-size [ calloc ] 2keep <direct-struct-array> ;
INSTANCE: struct-array sequence

View File

@ -0,0 +1 @@
Arrays of C structs and unions

View File

@ -0,0 +1 @@
collections

View File

@ -4,7 +4,7 @@
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
dlists assocs system combinators init boxes accessors
math.order deques strings quotations ;
math.order deques strings quotations fry ;
IN: threads
SYMBOL: initial-thread
@ -101,7 +101,7 @@ DEFER: stop
<PRIVATE
: schedule-sleep ( thread dt -- )
>r check-registered dup r> sleep-queue heap-push*
[ check-registered dup ] dip sleep-queue heap-push*
>>sleep-entry drop ;
: expire-sleep? ( heap -- ? )
@ -164,10 +164,8 @@ PRIVATE>
: suspend ( quot state -- obj )
[
>r
>r self swap call
r> self (>>state)
r> self continuation>> >box
[ [ self swap call ] dip self (>>state) ] dip
self continuation>> >box
next
] callcc1 2nip ; inline
@ -176,7 +174,7 @@ PRIVATE>
GENERIC: sleep-until ( time/f -- )
M: integer sleep-until
[ schedule-sleep ] curry "sleep" suspend drop ;
'[ _ schedule-sleep ] "sleep" suspend drop ;
M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
@ -200,11 +198,11 @@ M: real sleep
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ loop ] curry r> spawn ;
[ '[ _ loop ] ] dip spawn ;
: in-thread ( quot -- )
>r datastack r>
[ >r set-datastack r> call ] 2curry
[ datastack ] dip
'[ _ set-datastack _ call ]
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )

View File

@ -33,8 +33,8 @@ IN: tools.completion
{
{ [ over zero? ] [ 2drop 10 ] }
{ [ 2dup length 1- number= ] [ 2drop 4 ] }
{ [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
{ [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
{ [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] }
{ [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] }
[ 2drop 1 ]
} cond ;
@ -67,7 +67,7 @@ IN: tools.completion
over empty? [
nip [ first ] map
] [
>r >lower r> [ completion ] with map
[ >lower ] dip [ completion ] with map
rank-completions
] if ;

View File

@ -76,7 +76,7 @@ SYMBOL: deploy-image
parse-fresh [ first assoc-union ] unless-empty ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>
[ unparse-use string-lines ] dip
dup deploy-config-path set-vocab-file-contents ;
: set-deploy-flag ( value key vocab -- )

View File

@ -7,13 +7,12 @@ urls math.parser ;
: shake-and-bake ( vocab -- )
[ "test.image" temp-file delete-file ] ignore-errors
"resource:" [
>r vm
"test.image" temp-file
r> dup deploy-config make-deploy-image
[ vm "test.image" temp-file ] dip
dup deploy-config make-deploy-image
] with-directory ;
: small-enough? ( n -- ? )
>r "test.image" temp-file file-info size>> r> cell 4 / * <= ;
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test

View File

@ -3,7 +3,7 @@
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
system sorting splitting grouping math.parser classes memory
combinators ;
combinators fry ;
IN: tools.memory
<PRIVATE
@ -51,9 +51,10 @@ IN: tools.memory
[ "Largest free block:" write-labelled-size ]
} spread ;
: heap-stat-step ( counts sizes obj -- )
[ dup size swap class rot at+ ] keep
1 swap class rot at+ ;
: heap-stat-step ( obj counts sizes -- )
[ over ] dip
[ [ [ drop 1 ] [ class ] bi ] dip at+ ]
[ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ;
PRIVATE>
@ -71,7 +72,7 @@ PRIVATE>
: heap-stats ( -- counts sizes )
H{ } clone H{ } clone
[ >r 2dup r> heap-stat-step ] each-object ;
2dup '[ _ _ heap-stat-step ] each-object ;
: heap-stats. ( -- )
heap-stats dup keys natural-sort standard-table-style [

View File

@ -34,7 +34,7 @@ M: method-body (profile.)
: counter. ( obj n -- )
[
>r [ (profile.) ] with-cell r>
[ [ (profile.) ] with-cell ] dip
[ number>string write ] with-cell
] with-row ;

View File

@ -3,7 +3,7 @@
USING: accessors namespaces arrays prettyprint sequences kernel
vectors quotations words parser assocs combinators continuations
debugger io io.styles io.files vocabs vocabs.loader source-files
compiler.units summary stack-checker effects tools.vocabs ;
compiler.units summary stack-checker effects tools.vocabs fry ;
IN: tools.test
SYMBOL: failures
@ -26,24 +26,22 @@ SYMBOL: this-test
] if ;
: unit-test ( output input -- )
[ 2array ] 2keep [
{ } swap with-datastack swap >array assert=
] 2curry (unit-test) ;
[ 2array ] 2keep '[
_ { } _ with-datastack swap >array assert=
] (unit-test) ;
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
: must-infer-as ( effect quot -- )
>r 1quotation r> [ infer short-effect ] curry unit-test ;
[ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
: must-infer ( word/quot -- )
dup word? [ 1quotation ] when
[ infer drop ] curry [ ] swap unit-test ;
'[ _ infer drop ] [ ] swap unit-test ;
: must-fail-with ( quot pred -- )
>r [ f ] compose r>
[ recover ] 2curry
[ t ] swap unit-test ;
[ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
: must-fail ( quot -- )
[ drop t ] must-fail-with ;

View File

@ -5,7 +5,7 @@ namespaces system sequences splitting grouping assocs strings ;
IN: tools.time
: benchmark ( quot -- runtime )
micros >r call micros r> - ; inline
micros [ call micros ] dip - ; inline
: time. ( data -- )
unclip
@ -37,4 +37,4 @@ IN: tools.time
] bi* ;
: time ( quot -- )
gc-reset micros >r call gc-stats micros r> - prefix time. ; inline
gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline

View File

@ -250,9 +250,9 @@ C: <vocab-author> vocab-author
: keyed-vocabs ( str quot -- seq )
all-vocabs [
swap >r
[ >r 2dup r> swap call member? ] filter
r> swap
swap [
[ [ 2dup ] dip swap call member? ] filter
] dip swap
] assoc-map 2nip ; inline
: tagged ( tag -- assoc )

View File

@ -203,7 +203,7 @@ M: vocab summary
M: vocab-link summary vocab-summary ;
: set-vocab-summary ( string vocab -- )
>r 1array r>
[ 1array ] dip
dup vocab-summary-path
set-vocab-file-contents ;

View File

@ -5,7 +5,7 @@ unicode.normalize math unicode.categories combinators
assocs strings splitting kernel accessors ;
IN: unicode.case
: at-default ( key assoc -- value/key ) over >r at r> or ;
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
: ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ;

View File

@ -49,7 +49,7 @@ VALUE: properties
: (process-data) ( index data -- newdata )
filter-comments
[ [ nth ] keep first swap ] with { } map>assoc
[ >r hex> r> ] assoc-map ;
[ [ hex> ] dip ] assoc-map ;
: process-data ( index data -- hash )
(process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;

View File

@ -27,14 +27,17 @@ IN: unicode.normalize
: hangul>jamo ( hangul -- jamo-string )
hangul-base - final-count /mod final-base +
>r medial-count /mod medial-base +
>r initial-base + r> r>
[
medial-count /mod medial-base +
[ initial-base + ] dip
] dip
dup final-base = [ drop 2array ] [ 3array ] if ;
: jamo>hangul ( initial medial final -- hangul )
>r >r initial-base - medial-count *
r> medial-base - + final-count *
r> final-base - + hangul-base + ;
[
[ initial-base - medial-count * ] dip
medial-base - + final-count *
] dip final-base - + hangul-base + ;
! Normalization -- Decomposition
@ -45,7 +48,7 @@ IN: unicode.normalize
: reorder-next ( string i -- new-i done? )
over [ non-starter? ] find-from drop [
reorder-slice
>r dup [ combining-class ] insertion-sort to>> r>
[ dup [ combining-class ] insertion-sort to>> ] dip
] [ length t ] if* ;
: reorder-loop ( string start -- )

33
basis/windows/com/wrapper/wrapper.factor Normal file → Executable file
View File

@ -1,8 +1,9 @@
USING: alien alien.c-types windows.com.syntax init
windows.com.syntax.private windows.com continuations kernel
USING: alien alien.c-types alien.accessors windows.com.syntax
init windows.com.syntax.private windows.com continuations kernel
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets ;
destructors fry math.parser generalizations sets
specialized-arrays.alien specialized-arrays.direct.alien ;
IN: windows.com.wrapper
TUPLE: com-wrapper callbacks vtbls disposed ;
@ -51,23 +52,26 @@ unless
_ case
[
"void*" heap-size * rot <displaced-alien> com-add-ref
0 rot set-void*-nth S_OK
] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
swap 0 set-alien-cell S_OK
] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
] ;
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[
_ swap <displaced-alien>
0 over ulong-nth
1+ [ 0 rot set-ulong-nth ] keep
_
[ alien-unsigned-4 1+ dup ]
[ set-alien-unsigned-4 ]
2bi
] ;
: (make-release) ( interfaces -- quot )
length "void*" heap-size * '[
_ over <displaced-alien>
0 over ulong-nth
1- [ 0 rot set-ulong-nth ] keep
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
_
[ drop ]
[ alien-unsigned-4 1- dup ]
[ set-alien-unsigned-4 ]
2tri
dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
] ;
: (make-iunknown-methods) ( interfaces -- quots )
@ -125,8 +129,7 @@ unless
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
vtbls>> length "void*" heap-size *
[ "ulong" heap-size + malloc ] keep
over <displaced-alien>
1 0 rot set-ulong-nth ;
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
[ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
@ -159,5 +162,5 @@ M: com-wrapper dispose*
: com-wrap ( object wrapper -- wrapped-object )
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
[ [ set-void*-nth ] curry each-index ] keep
[ over length <direct-void*-array> 0 swap copy ] keep
[ +wrapped-objects+ get-global set-at ] keep ;

17
basis/windows/dinput/constants/constants.factor Normal file → Executable file
View File

@ -1,7 +1,8 @@
USING: windows.dinput windows.kernel32 windows.ole32 windows.com
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
combinators sequences symbols fry math accessors macros words quotations
libc continuations generalizations splitting locals assocs init ;
libc continuations generalizations splitting locals assocs init
struct-arrays ;
IN: windows.dinput.constants
! Some global variables aren't provided by the DirectInput DLL (they're in the
@ -52,14 +53,14 @@ SYMBOLS:
} cleave
"DIOBJECTDATAFORMAT" <c-object> (DIOBJECTDATAFORMAT) ;
: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
[ nip length "DIOBJECTDATAFORMAT" malloc-array dup ]
[
-rot [| args i alien struct |
:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
[let | alien [ array length "DIOBJECTDATAFORMAT" malloc-struct-array ] |
array [| args i |
struct args <DIOBJECTDATAFORMAT>
i alien set-DIOBJECTDATAFORMAT-nth
] 2curry each-index
] 2bi ;
i alien set-nth
] each-index
alien underlying>>
] ;
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
[ {

View File

@ -25,7 +25,7 @@ M: mixin-class rank-class drop 3 ;
bi
] if ;
TUPLE: check-mixin-class mixin ;
TUPLE: check-mixin-class class ;
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [

View File

@ -6,8 +6,10 @@ USING: kernel alien.c-types combinators namespaces make arrays
vars colors self self.slots
random-weighted colors.hsv cfdg.gl accessors
ui.gadgets.handler ui.gestures assocs ui.gadgets macros
qualified speicalized-arrays.double ;
qualified specialized-arrays.double ;
QUALIFIED: syntax
IN: cfdg
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -53,7 +55,10 @@ VAR: color-stack
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
! : double-nth* ( c-array indices -- seq ) swap [ double-nth ] curry map ;
: double-nth* ( c-array indices -- seq )
swap byte-array>double-array [ nth ] curry map ;
: check-size ( modelview -- num ) { 0 1 4 5 } double-nth* [ abs ] map biggest ;